Coredump in Perl_re_op_compile

[p5pRT]

Migrated from rt.perl.org#130561 (status was 'open')

Searchable as RT130561$

[p5pRT]

From @dur-randir

Created by @dur-randir

While fuzzing perl v5.25.8-207-gcbe2fc5001 built with afl and run
under libdislocator, I found the following program

/((?1)){8,0}/

to crash. GDB info about the crash location​:

#0 0x00007f565fa9442e in Perl_re_op_compile (patternp=0x0,
pat_count=1, expr=0x7f56600aa9b8, eng=0x7f565ffd3540
<PL_core_reg_engine>, old_re=0x0,
  is_bare_re=0x0, orig_rx_flags=0, pm_flags=0) at regcomp.c​:7772
7772 ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
(gdb) bt
#0 0x00007f565fa9442e in Perl_re_op_compile (patternp=0x0,
pat_count=1, expr=0x7f56600aa9b8, eng=0x7f565ffd3540
<PL_core_reg_engine>, old_re=0x0,
  is_bare_re=0x0, orig_rx_flags=0, pm_flags=0) at regcomp.c​:7772
#1 0x00007f565f9b1d58 in Perl_pmruntime (o=0x7f56600aa9f8,
expr=0x7f56600aa9b8, repl=0x0, flags=1, floor=0) at op.c​:5784
#2 0x00007f565fa629eb in Perl_yyparse (gramtype=258) at perly.y​:1204
#3 0x00007f565f9e22e1 in S_parse_body (env=0x0, xsinit=0x7f565f99dde8
<xs_init>) at perl.c​:2376
#4 0x00007f565f9e0646 in perl_parse (my_perl=0x7f5660088010,
xsinit=0x7f565f99dde8 <xs_init>, argc=2, argv=0x7ffe9dfb51b8, env=0x0)
at perl.c​:1691
#5 0x00007f565f99dd26 in main (argc=2, argv=0x7ffe9dfb51b8,
env=0x7ffe9dfb51d0) at perlmain.c​:121

Perl Info

Flags:
    category=core
    severity=high

Site configuration information for perl 5.25.9:

Configured by root at Sat Jan 14 02:25:05 MSK 2017.

Summary of my perl5 (revision 5 version 25 subversion 9) configuration:
  Commit id: cbe2fc5001aa59cdc73e04cc35e097a2ecfbeec0
  Platform:
    osname=linux
    osvers=3.16.0-4-amd64
    archname=x86_64-linux
    uname='linux dorothy 3.16.0-4-amd64 #1 smp debian 3.16.36-1+deb8u2
(2016-10-19) x86_64 gnulinux '
    config_args='-des -Dusedevel -DDEBUGGING -Dcc=afl-clang-fast
-Doptimize=-O0 -g -ggdb3'
    hint=recommended
    useposix=true
    d_sigaction=define
    useithreads=undef
    usemultiplicity=undef
    use64bitint=define
    use64bitall=define
    uselongdouble=undef
    usemymalloc=n
    bincompat5005=undef
  Compiler:
    cc='afl-clang-fast'
    ccflags ='-DDEBUGGING -fno-strict-aliasing -pipe
-fstack-protector-strong -I/usr/local/include -D_LARGEFILE_SOURCE
-D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2'
    optimize='-O0 -g -ggdb3'
    cppflags='-DDEBUGGING -fno-strict-aliasing -pipe
-fstack-protector-strong -I/usr/local/include'
    ccversion=''
    gccversion='4.2.1 Compatible Clang 3.9.1 (tags/RELEASE_391/rc2)'
    gccosandvers=''
    intsize=4
    longsize=8
    ptrsize=8
    doublesize=8
    byteorder=12345678
    doublekind=3
    d_longlong=define
    longlongsize=8
    d_longdbl=define
    longdblsize=16
    longdblkind=3
    ivtype='long'
    ivsize=8
    nvtype='double'
    nvsize=8
    Off_t='off_t'
    lseeksize=8
    alignbytes=8
    prototype=define
  Linker and Libraries:
    ld='afl-clang-fast'
    ldflags =' -fstack-protector-strong -L/usr/local/lib'
    libpth=/usr/local/lib /usr/lib/llvm-3.9/bin/../lib/clang/3.9.1/lib
/usr/include/x86_64-linux-gnu /usr/lib /lib/x86_64-linux-gnu
/lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib
    libs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc
    perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc
    libc=libc-2.24.so
    so=so
    useshrplib=false
    libperl=libperl.a
    gnulibc_version='2.24'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs
    dlext=so
    d_dlsymun=undef
    ccdlflags='-Wl,-E'
    cccdlflags='-fPIC'
    lddlflags='-shared -O0 -g -ggdb3 -L/usr/local/lib -fstack-protector-strong'



@INC for perl 5.25.9:
    lib
    /usr/local/lib/perl5/site_perl/5.25.9/x86_64-linux
    /usr/local/lib/perl5/site_perl/5.25.9
    /usr/local/lib/perl5/5.25.9/x86_64-linux
    /usr/local/lib/perl5/5.25.9


Environment for perl 5.25.9:
    HOME=/home/afl
    LANG=en_US.UTF-8
    LANGUAGE=en_US:en
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/home/afl/perlbrew/bin:/home/afl/perlbrew/perls/perl-5.22.1/bin:/usr/local/bin:/usr/bin:/bin:/usr/local/games:/usr/games
    PERLBREW_BASHRC_VERSION=0.78
    PERLBREW_HOME=/home/afl/.perlbrew
    PERLBREW_MANPATH=/home/afl/perlbrew/perls/perl-5.22.1/man
    PERLBREW_PATH=/home/afl/perlbrew/bin:/home/afl/perlbrew/perls/perl-5.22.1/bin
    PERLBREW_PERL=perl-5.22.1
    PERLBREW_ROOT=/home/afl/perlbrew
    PERLBREW_VERSION=0.78
    PERL_BADLANG (unset)
    SHELL=/usr/bin/zsh

[p5pRT]

From @dur-randir

Before v5.18.0, this'd just die() during a regex compilation. It was either exposed or caused by the following commit​:

31c15ce is the first bad commit
commit 31c15ce
Author​: Karl Williamson <public@​khwilliamson.com>
Date​: Sat Sep 15 12​:27​:22 2012 -0600

  PATCH​: [perl #82954] Make "Can't do {n,m} with n > m into warning

  This commit now causes this situation to warn instead of dying. The
  portion of the regular expression that can't match is optimized into an
  OPFAIL.

[p5pRT]

From [Unknown Contact. See original ticket]

Before v5.18.0, this'd just die() during a regex compilation. It was either exposed or caused by the following commit​:

31c15ce is the first bad commit
commit 31c15ce
Author​: Karl Williamson <public@​khwilliamson.com>
Date​: Sat Sep 15 12​:27​:22 2012 -0600

  PATCH​: [perl #82954] Make "Can't do {n,m} with n > m into warning

  This commit now causes this situation to warn instead of dying. The
  portion of the regular expression that can't match is optimized into an
  OPFAIL.

[p5pRT]

From @hvds

On Sun, 22 Jan 2017 04​:48​:49 -0800, randir wrote​:

Before v5.18.0, this'd just die() during a regex compilation. It was
either exposed or caused by the following commit​:

31c15ce is the first bad commit
commit 31c15ce
Author​: Karl Williamson <public@​khwilliamson.com>
Date​: Sat Sep 15 12​:27​:22 2012 -0600

PATCH​: [perl #82954] Make "Can't do {n,m} with n > m into warning

This commit now causes this situation to warn instead of dying. The
portion of the regular expression that can't match is optimized into
an
OPFAIL.

Yes, this change falls foul of​:
  /* Do setup, note this code has side effects beyond
  * the rest of this block. Specifically setting
  * RExC_recurse[] must happen at least once during
  * study_chunk(). */
.. since it optimizes away the node we must still study.

Karl, do you see any problem with just removing the optimizing aspect, per the attached patch? If not, I'll wrap in a test and commit.

Hugo

[p5pRT]

From @hvds

0001-perl-130561-Don-t-attempt-to-optimize-x-3-1.patch

From 5c0fa970ab98f53899b89c61536102da7b80b477 Mon Sep 17 00:00:00 2001
From: Hugo van der Sanden <hv@crypt.org>
Date: Wed, 25 Jan 2017 15:45:22 +0000
Subject: [PATCH] [perl #130561] Don't attempt to optimize /x{3,1}/

Nulling out the target of the quantifier risks causing other parts of
the regexp engine to get out of whack.
---
 regcomp.c | 19 ++-----------------
 1 file changed, 2 insertions(+), 17 deletions(-)

diff --git a/regcomp.c b/regcomp.c
index 97888ca..96339ac 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -11629,9 +11629,6 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
     const char *maxpos = NULL;
     UV uv;
 
-    /* Save the original in case we change the emitted regop to a FAIL. */
-    regnode * const orig_emit = RExC_emit;
-
     GET_RE_DEBUG_FLAGS_DECL;
 
     PERL_ARGS_ASSERT_REGPIECE;
@@ -11693,22 +11690,10 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
             }
 	    RExC_parse = next;
 	    nextchar(pRExC_state);
-            if (max < min) {    /* If can't match, warn and optimize to fail
-                                   unconditionally */
-                if (SIZE_ONLY) {
-
-                    /* We can't back off the size because we have to reserve
-                     * enough space for all the things we are about to throw
-                     * away, but we can shrink it by the amount we are about
-                     * to re-use here */
-                    RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
-                }
-                else {
+            if (max < min) {    /* If can't match, warn */
+                if (PASS2) {
                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
-                    RExC_emit = orig_emit;
                 }
-                ret = reganode(pRExC_state, OPFAIL, 0);
-                return ret;
             }
             else if (min == max && *RExC_parse == '?')
             {
-- 
2.10.2

[p5pRT]

The RT System itself - Status changed from 'new' to 'open'

[p5pRT]

From @khwilliamson

On 01/25/2017 08​:47 AM, Hugo van der Sanden via RT wrote​:

On Sun, 22 Jan 2017 04​:48​:49 -0800, randir wrote​:

Before v5.18.0, this'd just die() during a regex compilation. It was
either exposed or caused by the following commit​:

31c15ce is the first bad commit
commit 31c15ce
Author​: Karl Williamson <public@​khwilliamson.com>
Date​: Sat Sep 15 12​:27​:22 2012 -0600

PATCH​: [perl #82954] Make "Can't do {n,m} with n > m into warning

This commit now causes this situation to warn instead of dying. The
portion of the regular expression that can't match is optimized into
an
OPFAIL.

Yes, this change falls foul of​:
/* Do setup, note this code has side effects beyond
* the rest of this block. Specifically setting
* RExC_recurse[] must happen at least once during
* study_chunk(). */
.. since it optimizes away the node we must still study.

Karl, do you see any problem with just removing the optimizing aspect, per the attached patch? If not, I'll wrap in a test and commit.

I see no problems. Too bad that comment in the file is buried

Hugo

---
via perlbug​: queue​: perl5 status​: new
https://rt-archive.perl.org/perl5/Ticket/Display.html?id=130561

[p5pRT]

From @hvds

Ugh, I experimented with this some more, and found that after my patch to deoptimize this loops until stack exhaustion​:

./miniperl -wle '"abaad" =~ m{(a) b ( ((?1)){2,1} | aa )d}x'

I think it'd be worth trying to chase down the bugs here, but I suspect the fuzzers will find more, and we're quite late in the release cycle to be hoping for confidence in this before 5.26 freeze.

So for now I'm going to look instead whether I can make it less dangerous to miss RExC_recurse entries, that feels like the surer (and more useful) target.

Hugo

[p5pRT]

From @demerphq

On 26 January 2017 at 11​:20, Hugo van der Sanden via RT
<perlbug-followup@​perl.org> wrote​:

Ugh, I experimented with this some more, and found that after my patch to deoptimize this loops until stack exhaustion​:

./miniperl -wle '"abaad" =~ m{(a) b ( ((?1)){2,1} | aa )d}x'

That is because your patch did not change regexec.c to fail when the
min/max are incorrect.

I think it'd be worth trying to chase down the bugs here, but I suspect the fuzzers will find more, and we're quite late in the release cycle to be hoping for confidence in this before 5.26 freeze.

So for now I'm going to look instead whether I can make it less dangerous to miss RExC_recurse entries, that feels like the surer (and more useful) target.

That wont work either.

This​:

"foo"=~/(foo){8,0}|(?1)/

should match if we allow this pattern to execute. If we optimise away
the (foo){8,0} then the (?1) cant match 'foo'.

Because of this I think we should either revert the original change
until we can rethink it, or otherwise pursue your original solution
which IMO could work.

FWIW, before I realized the flaw in the original logic I nearly pushed
the following​:

commit c934d69b23fd180481261c72c04cda25924cb10e
Author​: Yves Orton <demerphq@​gmail.com>
Date​: Fri Jan 27 06​:50​:58 2017 +0100

  fix [#130561], optimizing away a RECURSE op should not result in a SEGV

  It is possible that an OPEN which is the target of a recurse op,
  or that a recursion call itself, such as (?1) might be optimised
  away, which broke assumptions made about optimising recursion.

  The simplest fix is to verify that scan and OP(scan) are correct
  before we try to update parameters in the possible optimised away
  opcode.

Inline Patch

diff --git a/regcomp.c b/regcomp.c
index 4f54b01..e515204 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -7789,7 +7789,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp,

int pat_count,

  while ( RExC_recurse_count > 0 ) {
  const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
- ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
+ /* this GOSUB may have been optimized away */
+ if (scan && OP(scan) == GOSUB)
+ ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
  }

  Newxz(r->offs, RExC_npar, regexp_paren_pair);

Inline Patch

diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
index 2b6063c..150c854 100644
--- a/t/re/pat_rt_report.t
+++ b/t/re/pat_rt_report.t
@@ -20,7 +20,7 @@ use warnings;
 use 5.010;
 use Config;

-plan tests => 2502;  # Update this when adding/deleting tests.
+plan tests => 2503;  # Update this when adding/deleting tests.

 run_tests() unless caller;

@@ -1131,6 +1131,12 @@ EOP
         my $s = "\x{f2}\x{140}\x{fe}\x{ff}\x{ff}\x{ff}";
         ok($s !~ /^0000.\34500\376\377\377\377/, "RT #129085");
     }
+    {
+        fresh_perl_is(
+            '"foo"=~/((?1)){8,0}/; print "ok"',
+            "ok", {}, 'RT #130561 - Optimised away recursion should

not cause SEGVs'); \+ \} \+

} # End of sub run_tests

--
perl -Mre=debug -e "/just|another|perl|hacker/"

[p5pRT]

From @demerphq

On 27 January 2017 at 07​:21, demerphq <demerphq@​gmail.com> wrote​:

On 26 January 2017 at 11​:20, Hugo van der Sanden via RT
<perlbug-followup@​perl.org> wrote​:

Ugh, I experimented with this some more, and found that after my patch to deoptimize this loops until stack exhaustion​:

./miniperl -wle '"abaad" =~ m{(a) b ( ((?1)){2,1} | aa )d}x'

That is because your patch did not change regexec.c to fail when the
min/max are incorrect.

And I am wrong. I tried going down that road, and it is painful. So
painful I prepared a revert. But just before I was going to send it I
had an epiphany and hopefully 3rd time lucky.

Instead of converting the impossible construct into an OPFAIL, we can
inject an OPFAIL in *front* of the impossible construct. This means
that the construct is still reachable via recursion, but will never be
executed otherwise. And since we have not removed the OPEN/CLOSE the
segfaults that lead to this bugreport also go away.

So fixed in​:

commit 31fc939
Author​: Yves Orton <demerphq@​gmail.com>
Date​: Fri Jan 27 10​:18​:51 2017 +0100

  fix RT #130561 - recursion and optimising away impossible
quantifiers are not friends

  Instead of optimising away impossible quantifiers like (foo){1,0} treat them
  as unquantified, and guard them with an OPFAIL. Thus /(foo){1,0}/ is treated
  the same as /(*FAIL)(foo)/ this is important in patterns like
/(foo){1,0}|(?1)/
  where the (?1) needs to be able to recurse into the (foo) even though the
  (foo){1,0} can never match. It also resolves various issues
(SEGVs) with patterns
  like /((?1)){1,0}/.

  This patch would have been easier if S_reginsert() documented that it is
  the callers responsibility to properly set up the NEXT_OFF() of the inserted
  node (if the node has a NEXT_OFF())

Along with a couple of cleanup patches which would have made fixing this easier.

Yves

--
perl -Mre=debug -e "/just|another|perl|hacker/"

[p5pRT]

From @hvds

On Fri, 27 Jan 2017 01​:26​:03 -0800, demerphq wrote​:

Instead of converting the impossible construct into an OPFAIL, we can
inject an OPFAIL in *front* of the impossible construct.

Cool, I like.

This patch would have been easier if S_reginsert() documented that it is
the callers responsibility to properly set up the NEXT_OFF() of the inserted
node (if the node has a NEXT_OFF())

Should it be setting that only if PASS2? I didn't think we were supposed to write into the node during sizing.

(and earlier)
hv> So for now I'm going to look instead whether I can make it less dangerous to
hv> miss RExC_recurse entries, that feels like the surer (and more useful) target.
dq> That wont work either.

Just to clarify​: I assume you mean "that won't be enough to let us remove the ops".

I'm not entirely sure that I have a use case, but what I had in mind was to modify the fixup loop as in your "this GOSUB may have been optimized away" change, but combine it with a regexec-time check & panic should we see a GOSUB that hasn't had its target set (which requires inventing a way to flag that). Failing that, we should at least have an assert at the point of fixup, for a clea[nr]er failure mode.

Hugo

[p5pRT]

From @demerphq

On 27 January 2017 at 16​:15, Hugo van der Sanden via RT
<perlbug-followup@​perl.org> wrote​:

On Fri, 27 Jan 2017 01​:26​:03 -0800, demerphq wrote​:

Instead of converting the impossible construct into an OPFAIL, we can
inject an OPFAIL in *front* of the impossible construct.

Cool, I like.

This patch would have been easier if S_reginsert() documented that it is
the callers responsibility to properly set up the NEXT_OFF() of the inserted
node (if the node has a NEXT_OFF())

Should it be setting that only if PASS2? I didn't think we were supposed to write into the node during sizing.

Good catch. Fix is testing and will be pushed shortly.

(and earlier)
hv> So for now I'm going to look instead whether I can make it less dangerous to
hv> miss RExC_recurse entries, that feels like the surer (and more useful) target.
dq> That wont work either.

Just to clarify​: I assume you mean "that won't be enough to let us remove the ops".

Yes, correct. "foo"=~/(foo){1,0}|(?1)/ should match (assuming we allow
the pattern at all).

I'm not entirely sure that I have a use case, but what I had in mind was to modify the fixup loop as in your "this GOSUB may have been optimized away" change, but combine it with a regexec-time check & panic should we see a GOSUB that hasn't had its target set (which requires inventing a way to flag that). Failing that, we should at least have an assert at the point of fixup, for a clea[nr]er failure mode.

If we do this in debug mode only then I see no harm. Right now I see
no immediate need, but your point about cleaner failure modes for
future developers is compelling. Can I leave that part to you?

Yves

[p5pRT]

From @demerphq

On 27 January 2017 at 17​:00, demerphq <demerphq@​gmail.com> wrote​:

On 27 January 2017 at 16​:15, Hugo van der Sanden via RT
<perlbug-followup@​perl.org> wrote​:

On Fri, 27 Jan 2017 01​:26​:03 -0800, demerphq wrote​:

Instead of converting the impossible construct into an OPFAIL, we can
inject an OPFAIL in *front* of the impossible construct.

Cool, I like.

This patch would have been easier if S_reginsert() documented that it is
the callers responsibility to properly set up the NEXT_OFF() of the inserted
node (if the node has a NEXT_OFF())

Should it be setting that only if PASS2? I didn't think we were supposed to write into the node during sizing.

Good catch. Fix is testing and will be pushed shortly.

Pushed as

commit 2253e8fbc23277e000d9e0dc692359f58ba6b0f6
Author​: Yves Orton <demerphq@​gmail.com>
Date​: Fri Jan 27 16​:57​:40 2017 +0100

  only mess with NEXT_OFF() when we are in PASS2

  In 31fc939 I added code that would modify
  NEXT_OFF() when we were not in PASS2, when we should not do so.
Strangly this
  did not segfault when I tested, but this fix is required.

Thanks Hugo!

cheers,
Yves

[p5pRT]

From @hvds

On Fri, 27 Jan 2017 08​:02​:14 -0800, demerphq wrote​:

On 27 January 2017 at 16​:15, Hugo van der Sanden wrote​:

I'm not entirely sure that I have a use case, but what I had in mind
was to modify the fixup loop as in your "this GOSUB may have been
optimized away" change, but combine it with a regexec-time check &
panic should we see a GOSUB that hasn't had its target set (which
requires inventing a way to flag that). Failing that, we should at
least have an assert at the point of fixup, for a clea[nr]er failure
mode.

If we do this in debug mode only then I see no harm.

I had planned to make it a mandatory panic (not only under DEBUGGING), instead of the SEGV or worse you would otherwise get.

Can I leave that part to you?

For now yes - I had already had a go at it (assuming I could set arg2=0 and test that for "not set") but got a bunch of test failures, which I haven't tried to dig into yet. If I can't use arg2, I might want to use flags - but as far as I can see we don't ever actually use those as flags, so some caution will be needed.

Hugo

[p5pRT]

From @demerphq

On 27 January 2017 at 19​:04, Hugo van der Sanden via RT
<perlbug-followup@​perl.org> wrote​:

On Fri, 27 Jan 2017 08​:02​:14 -0800, demerphq wrote​:

On 27 January 2017 at 16​:15, Hugo van der Sanden wrote​:

I'm not entirely sure that I have a use case, but what I had in mind
was to modify the fixup loop as in your "this GOSUB may have been
optimized away" change, but combine it with a regexec-time check &
panic should we see a GOSUB that hasn't had its target set (which
requires inventing a way to flag that). Failing that, we should at
least have an assert at the point of fixup, for a clea[nr]er failure
mode.

If we do this in debug mode only then I see no harm.

I had planned to make it a mandatory panic (not only under DEBUGGING), instead of the SEGV or worse you would otherwise get.

Can I leave that part to you?

For now yes - I had already had a go at it (assuming I could set arg2=0 and test that for "not set") but got a bunch of test failures, which I haven't tried to dig into yet. If I can't use arg2, I might want to use flags - but as far as I can see we don't ever actually use those as flags, so some caution will be needed.

Wait wait. Are we talking about the same thing? I thought you were
talking about guarding the code that produced the SEGV with logic like
i posted in my GOSUB patch which I did not apply.

I think the bulk of that patch is fine to apply. I just don't see the
need to do those check except under debugging as we no longer optimise
away parens.

And really, the core idea of optimising a capturing paren is broken in
the face of recursion. You simply cannot do it. So basically we are
talking about adding guard code for a problem that should never occur.
IMO that means a DEBUGGING only feature.

Maybe I should just post the patch I am thinking of then you can do
whatever you like on top, and then we get out of the game of broken
telephone. (Will that term ever be modernized I wonder?)

:-)

cheers,
Yves

--
perl -Mre=debug -e "/just|another|perl|hacker/"