This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make Perl_scalar() mostly non-recursive
authorDavid Mitchell <davem@iabyn.com>
Tue, 28 May 2019 14:23:44 +0000 (15:23 +0100)
committerDavid Mitchell <davem@iabyn.com>
Mon, 24 Jun 2019 10:40:07 +0000 (11:40 +0100)
Where it just recursively calls scalar() on all its children, instead
iteratively walk the sub-tree, using o->op_sibparent to work back
upwards.

Where it is more complex, such as OP_REPEAT imposing scalar context on its
first arg but not its second, recurse as before.

op.c
t/op/cond.t

diff --git a/op.c b/op.c
index 503b203..f998f57 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1796,6 +1796,10 @@ S_scalar_slice_warning(pTHX_ const OP *o)
 OP *
 Perl_scalar(pTHX_ OP *o)
 {
+    OP * top_op = o;
+
+    while (1) {
+    OP *next_kid = NULL; /* what op (if any) to process next */
     OP *kid;
 
     /* assumes no premature commitment */
@@ -1803,7 +1807,7 @@ Perl_scalar(pTHX_ OP *o)
         || (o->op_flags & OPf_WANT)
         || o->op_type == OP_RETURN)
     {
-       return o;
+       goto do_next;
     }
 
     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
@@ -1827,15 +1831,13 @@ Perl_scalar(pTHX_ OP *o)
     case OP_OR:
     case OP_AND:
     case OP_COND_EXPR:
-       for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
-           scalar(kid);
+        /* impose scalar context on everything except the condition */
+        next_kid = OpSIBLING(cUNOPo->op_first);
        break;
 
     default:
-       if (o->op_flags & OPf_KIDS) {
-           for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
-               scalar(kid);
-       }
+       if (o->op_flags & OPf_KIDS)
+            next_kid = cUNOPo->op_first; /* do all kids */
        break;
 
     /* the children of these ops are usually a list of statements,
@@ -1911,7 +1913,22 @@ Perl_scalar(pTHX_ OP *o)
                        SVfARG(name), lbrack, SVfARG(keysv), rbrack);
     }
     } /* switch */
-    return o;
+
+    /* If next_kid is set, someone in the code above wanted us to process
+     * that kid and all its remaining siblings.  Otherwise, work our way
+     * back up the tree */
+  do_next:
+    while (!next_kid) {
+        if (o == top_op)
+            return top_op; /* at top; no parents/siblings to try */
+        if (OpHAS_SIBLING(o))
+            next_kid = o->op_sibparent;
+        else
+            o = o->op_sibparent; /*try parent's next sibling */
+
+    }
+    o = next_kid;
+    } /* while */
 }
 
 
index 25d5060..ae381c9 100644 (file)
@@ -13,4 +13,19 @@ $x = 1;
 is(  $x ? 1 : 0, 1, 'run time, true');
 is( !$x ? 0 : 1, 1, 'run time, false');
 
+# This used to SEGV due to deep recursion in Perl_scalar().
+# (Actually it only SEGVed with the depth being about 100_000; but
+# compiling the nested condition goes quadratic in some way, so I've
+# reduced to the count to a manageable size. So this is not so much a
+# proper test, as it is a comment on the sort of thing that used to break)
+
+{
+    my $e = "1";
+    $e = "(\$x ? 1 : $e)" for 1..20_000;
+    $e = "\$x = $e";
+    eval $e;
+    is $@, "", "SEGV in Perl_scalar";
+}
+
+
 done_testing();