make peep optimiser recurse mostly only shallowly

Long blocks of code that include logical or loop ops (i.e. those with
multiple 'branches' of ops, such as op_other, op_redo etc) cause
Perl_rpeep to recurse deeply and eventaully SEGV.

For example this crashes, due to the ENTERLOOP:

    eval ("{\$x = 1 }\n" x 10000)

The deep recursion happens because the processing of the entire rest of
the code occurs in within the nested call. For example in the code

    A && B; C; D; E;

the ops are structured as

A -> AND -> C -> D -> E
       \   /
         B

where AND->op_next points to C, while AND->op_other points to B.
rpeep() would normally process each op in the op_next sequence in turn
(i.e. A/AND/C/D/E), but when it reaches AND, it recursively calls
rpeep(B), which happens to then process B/C/D/E. Finally it returns,
and the parent rpeep processes C, finds it's already done, and exits.

Clearly, if C,D,E etc also contain conditional/loop ops, then the
recursion level gradually stacks up.

The fix for this is to add a small deferred queue to rpeep().
Whenever rpeep wants to recurse with op_other or op_lastop etc,
it instead adds it to the deferred queue. Only if the queue is full is
rpeep actually called. The hope is that by deferring, when we do
eventually process it, enough of the main op_next chain has already been
processed to ensure that the child rpeep returns very early.

In the example above, processing of AND causes B to be added to the queue,
and the main rpeep process continues processing C, D etc. Sometime later,
the queue becomes full and B is processed via a recursive call to rpeep.
B is processed, and op_next is followed to C, but C is marked as already
processed, so the child rpeep returns almost immediately.

For LOOP ops, I've stopped following op_redoop and op_nextop, since
AFAIKT the ops these point to will also be reachable vie op_next anyway.
op_lastop is the exception; in while(1){..} only op_lastop points to the
rest of the code block.

Note that this commit doesn't guarantee only shallow recursion, it just
makes deep recursion fairly unlikely.

Note also that this commit causes the order of the processing of op_next
chains to be altered; this can affect the ordering of compiler warnings
and fatal messages among potentially other things.

4 files changed, 78 insertions, 21 deletions

diff --git a/ext/XS-APItest/t/peep.t b/ext/XS-APItest/t/peep.t
index 08928c44c9..87d749b7ff 100644
--- a/ext/XS-APItest/t/peep.t
+++ b/ext/XS-APItest/t/peep.t
@@ -2,7 +2,7 @@
 
 use strict;
 use warnings;
-use Test::More tests => 9;
+use Test::More tests => 6;
 
 use XS::APItest;
 
@@ -20,14 +20,17 @@ is($record->[0], 'affe');
 is($rrecord->[0], 'affe');
 
 
-# peep got called for each root op of the branch
-$::moo = $::moo = 0;
+# A deep-enough nesting of conditionals defeats the deferring mechanism
+# and triggers recursion. Note that this test is sensitive to the details
+# rpeep: the main thing it is testing is that rpeep is called more than
+# peep; the details are less important.
+
+my $code =  q[my ($a,$b); $a =];
+$code .= qq{ \$b ? "foo$_" :} for (1..10);
+$code .= qq{ "foo11" };
 XS::APItest::peep_enable;
-eval q[my $foo = $::moo ? q/x/ : q/y/];
+eval $code;
 XS::APItest::peep_disable;
 
-is(scalar @{ $record }, 1);
-is(scalar @{ $rrecord }, 2);
-is($record->[0], 'y');
-is($rrecord->[0], 'x');
-is($rrecord->[1], 'y');
+is_deeply($record,  [ "foo11" ]);
+is_deeply($rrecord, [ qw(foo1 foo2 foo3 foo4 foo5 foo6 foo11) ]);
diff --git a/op.c b/op.c
index b07301063d..1ad20745b2 100644
--- a/op.c
+++ b/op.c
@@ -9304,6 +9304,16 @@ S_is_inplace_av(pTHX_ OP *o, OP *oright) {
     return oleft;
 }
 
+#define MAX_DEFERRED 4
+
+#define DEFER(o) \
+    if (defer_ix == (MAX_DEFERRED-1)) { \
+	CALL_RPEEP(defer_queue[defer_base]); \
+	defer_base = (defer_base + 1) % MAX_DEFERRED; \
+	defer_ix--; \
+    } \
+    defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
+
 /* A peephole optimizer.  We visit the ops in the order they're to execute.
  * See the comments at the top of this file for more details about when
  * peep() is called */
@@ -9313,13 +9323,27 @@ Perl_rpeep(pTHX_ register OP *o)
 {
     dVAR;
     register OP* oldop = NULL;
+    OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
+    int defer_base = 0;
+    int defer_ix = -1;
 
     if (!o || o->op_opt)
 	return;
     ENTER;
     SAVEOP();
     SAVEVPTR(PL_curcop);
-    for (; o; o = o->op_next) {
+    for (;; o = o->op_next) {
+	if (o && o->op_opt)
+	    o = NULL;
+	while (!o) {
+	    if (defer_ix < 0)
+		break;
+	    o = defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
+	    oldop = NULL;
+	}
+	if (!o)
+	    break;
+
 #if defined(PERL_MAD) && defined(USE_ITHREADS)
 	MADPROP *mp = o->op_madprop;
 	while (mp) {
@@ -9361,8 +9385,6 @@ Perl_rpeep(pTHX_ register OP *o)
 	    mp = mp->mad_next;
 	}
 #endif
-	if (o->op_opt)
-	    break;
 	/* By default, this op has now been optimised. A couple of cases below
 	   clear this again.  */
 	o->op_opt = 1;
@@ -9601,7 +9623,7 @@ Perl_rpeep(pTHX_ register OP *o)
             sop = fop->op_sibling;
 	    while (cLOGOP->op_other->op_type == OP_NULL)
 		cLOGOP->op_other = cLOGOP->op_other->op_next;
-	    CALL_RPEEP(cLOGOP->op_other);
+	    DEFER(cLOGOP->op_other);
           
           stitch_keys:	    
 	    o->op_opt = 1;
@@ -9652,20 +9674,21 @@ Perl_rpeep(pTHX_ register OP *o)
 	case OP_ONCE:
 	    while (cLOGOP->op_other->op_type == OP_NULL)
 		cLOGOP->op_other = cLOGOP->op_other->op_next;
-	    CALL_RPEEP(cLOGOP->op_other);
+	    DEFER(cLOGOP->op_other);
 	    break;
 
 	case OP_ENTERLOOP:
 	case OP_ENTERITER:
 	    while (cLOOP->op_redoop->op_type == OP_NULL)
 		cLOOP->op_redoop = cLOOP->op_redoop->op_next;
-	    CALL_RPEEP(cLOOP->op_redoop);
 	    while (cLOOP->op_nextop->op_type == OP_NULL)
 		cLOOP->op_nextop = cLOOP->op_nextop->op_next;
-	    CALL_RPEEP(cLOOP->op_nextop);
 	    while (cLOOP->op_lastop->op_type == OP_NULL)
 		cLOOP->op_lastop = cLOOP->op_lastop->op_next;
-	    CALL_RPEEP(cLOOP->op_lastop);
+	    /* a while(1) loop doesn't have an op_next that escapes the
+	     * loop, so we have to explicitly follow the op_lastop to
+	     * process the rest of the code */
+	    DEFER(cLOOP->op_lastop);
 	    break;
 
 	case OP_SUBST:
@@ -9674,7 +9697,7 @@ Perl_rpeep(pTHX_ register OP *o)
 		   cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
 		cPMOP->op_pmstashstartu.op_pmreplstart
 		    = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
-	    CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
+	    DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
 	    break;
 
 	case OP_EXEC:
diff --git a/t/lib/strict/subs b/t/lib/strict/subs
index 4c88021a07..87311f8a16 100644
--- a/t/lib/strict/subs
+++ b/t/lib/strict/subs
@@ -45,8 +45,8 @@ Execution of - aborted due to compilation errors.
 use strict 'subs' ;
 my @a = (A..Z);
 EXPECT
-Bareword "Z" not allowed while "strict subs" in use at - line 4.
 Bareword "A" not allowed while "strict subs" in use at - line 4.
+Bareword "Z" not allowed while "strict subs" in use at - line 4.
 Execution of - aborted due to compilation errors.
 ########
 
@@ -54,8 +54,8 @@ Execution of - aborted due to compilation errors.
 use strict 'subs' ;
 my $a = (B..Y);
 EXPECT
-Bareword "Y" not allowed while "strict subs" in use at - line 4.
 Bareword "B" not allowed while "strict subs" in use at - line 4.
+Bareword "Y" not allowed while "strict subs" in use at - line 4.
 Execution of - aborted due to compilation errors.
 ########
 
diff --git a/t/op/threads.t b/t/op/threads.t
index 24e84e42a0..731e148ee4 100644
--- a/t/op/threads.t
+++ b/t/op/threads.t
@@ -9,7 +9,7 @@ BEGIN {
      skip_all_without_config('useithreads');
      skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
 
-     plan(24);
+     plan(25);
 }
 
 use strict;
@@ -342,6 +342,37 @@ threads->create(
 
 EOI
 
+# make sure peephole optimiser doesn't recurse heavily.
+# (We run this inside a thread to get a small stack)
+
+{
+    # lots of constructs that have o->op_other etc
+    my $code = <<'EOF';
+	$r = $x || $y;
+	$x ||= $y;
+	$r = $x // $y;
+	$x //= $y;
+	$r = $x && $y;
+	$x &&= $y;
+	$r = $x ? $y : $z;
+	$r = $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x"
+	   : $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x" : $x ? "x" : "y";
+	@a = map $x+1, @a;
+	@a = grep $x+1, @a;
+	$r = /$x/../$y/;
+	while (1) { $x = 0 };
+	while (0) { $x = 0 };
+	for ($x=0; $y; $z=0) { $r = 0 };
+	for (1) { $x = 0 };
+	{ $x = 0 };
+	$x =~ s/a/$x + 1/e;
+EOF
+    $code = 'my ($r, $x,$y,$z,@a); return 5; ' . ($code x 5000);
+    my $res = threads->create(sub { eval $code})->join;
+    is($res, 5, "avoid peephole recursion");
+}
+
+
 # [perl #78494] Pipes shared between threads block when closed
 watchdog 10;
 {