develooper Front page | perl.perl5.changes | Postings from February 2019

[perl.git] branch blead updated. v5.29.7-43-g5226e07ddf

From:
Tony Cook
Date:
February 4, 2019 23:21
Subject:
[perl.git] branch blead updated. v5.29.7-43-g5226e07ddf
Message ID:
E1gqnYP-00060f-PF@git.dc.perl.space
In perl.git, the branch blead has been updated

<https://perl5.git.perl.org/perl.git/commitdiff/5226e07ddf0fbe83ce338d40a5aee3cd37845ff1?hp=159eab64fc351538a7552181760aa94ffd72e5f6>

- Log -----------------------------------------------------------------
commit 5226e07ddf0fbe83ce338d40a5aee3cd37845ff1
Merge: 159eab64fc ee367d4ab3
Author: Tony Cook <tony@develop-help.com>
Date:   Tue Feb 5 10:19:51 2019 +1100

    (perl #108276) reduce recursion on ops
    
    This can prevent stack overflow when processing extremely deep op
    trees.

commit ee367d4ab3ae183f2bbf7de592391736d1cb6510
Author: Tony Cook <tony@develop-help.com>
Date:   Tue Jan 29 16:29:38 2019 +1100

    (perl #108276) optimize child ops in sibling order

commit f2861c9b15e4f5ce914d945a2d354a93a9fff926
Author: Tony Cook <tony@develop-help.com>
Date:   Wed Jan 30 11:06:52 2019 +1100

    (perl #108276) indent optimize_op() loop body

commit e76010b6a580610b68e389d4bfcdf53d64dbbdea
Author: Tony Cook <tony@develop-help.com>
Date:   Tue Jan 29 16:29:04 2019 +1100

    (perl #108276) remove recursion from optimize_op()
    
    The prevented code like:
    
      ./miniperl -e 'my $line = "\$cond ? \$a : \n"; my $code = ($line x 100000) . "\$b;\n"; eval $code;'
    
    from crashing due to stack overflow.
    
    It does however take a long time to compile.
    
    Because it doesn't strictly recurse through the op tree (due
    to OP_SUBST), I couldn't use traverse_op_tree().
    
    I considered wrapping a traverse_op_tree() loop inside a defer op
    loop, so OP_SUBST would defer its op, but processing order is
    somewhat important from setting PL_curcop.
    
    This also processes the child ops in reverse order, I'm not sure if
    that's a real problem (no tests failed), but the next commit fixes
    that order.

commit 3d5b2488ead2c20cc64174fabd97bb7a32da097f
Author: Tony Cook <tony@develop-help.com>
Date:   Tue Jan 29 15:03:43 2019 +1100

    (perl #108276) add wrappers for deferred op processing
    
    To avoid duplication of the declarations.

commit 64242fed14e14f183c1b237a88366b1589387cdc
Author: Tony Cook <tony@develop-help.com>
Date:   Tue Jan 29 14:22:02 2019 +1100

    (perl #108276) indent body of new finalize_op() loop

commit 7f8280cf23d815fd4e0e02a23b82859f0d03b84b
Author: Tony Cook <tony@develop-help.com>
Date:   Tue Jan 29 13:57:51 2019 +1100

    (perl #108276) eliminate recursion from finalize_op()
    
    whitespace in next commit

-----------------------------------------------------------------------

Summary of changes:
 embed.fnc |   1 +
 embed.h   |   1 +
 op.c      | 395 ++++++++++++++++++++++++++++++++++++--------------------------
 proto.h   |   3 +
 4 files changed, 234 insertions(+), 166 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index bdb29f7216..d311ca7f51 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -563,6 +563,7 @@ i	|OP*	|newMETHOP_internal	|I32 type|I32 flags|NULLOK OP* dynamic_meth \
 					|NULLOK SV* const_meth
 : FIXME
 s	|OP*	|fold_constants	|NN OP * const o
+s	|OP*	|traverse_op_tree|NN OP* top|NN OP* o
 #endif
 Afpd	|char*	|form		|NN const char* pat|...
 Ap	|char*	|vform		|NN const char* pat|NULLOK va_list* args
diff --git a/embed.h b/embed.h
index a94583870a..f3b95eadbd 100644
--- a/embed.h
+++ b/embed.h
@@ -1886,6 +1886,7 @@
 #define simplify_sort(a)	S_simplify_sort(aTHX_ a)
 #define too_few_arguments_pv(a,b,c)	S_too_few_arguments_pv(aTHX_ a,b,c)
 #define too_many_arguments_pv(a,b,c)	S_too_many_arguments_pv(aTHX_ a,b,c)
+#define traverse_op_tree(a,b)	S_traverse_op_tree(aTHX_ a,b)
 #    if defined(USE_ITHREADS)
 #define op_relocate_sv(a,b)	S_op_relocate_sv(aTHX_ a,b)
 #    endif
diff --git a/op.c b/op.c
index d966848055..8a61b8b616 100644
--- a/op.c
+++ b/op.c
@@ -175,6 +175,11 @@ static const char array_passed_to_stat[] = "Array passed to stat will be coerced
    op_free()
 */
 
+#define dDEFER_OP  \
+    SSize_t defer_stack_alloc = 0; \
+    SSize_t defer_ix = -1; \
+    OP **defer_stack = NULL;
+#define DEFER_OP_CLEANUP Safefree(defer_stack)
 #define DEFERRED_OP_STEP 100
 #define DEFER_OP(o) \
   STMT_START { \
@@ -185,6 +190,22 @@ static const char array_passed_to_stat[] = "Array passed to stat will be coerced
     } \
     defer_stack[++defer_ix] = o; \
   } STMT_END
+#define DEFER_REVERSE(count)                            \
+    STMT_START {                                        \
+        UV cnt = (count);                               \
+        if (cnt > 1) {                                  \
+            OP **top = defer_stack + defer_ix;          \
+            /* top - (cnt) + 1 isn't safe here */       \
+            OP **bottom = top - (cnt - 1);              \
+            OP *tmp;                                    \
+            assert(bottom >= defer_stack);              \
+            while (top > bottom) {                      \
+                tmp = *top;                             \
+                *top-- = *bottom;                       \
+                *bottom++ = tmp;                        \
+            }                                           \
+        }                                               \
+    } STMT_END;
 
 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 
@@ -770,9 +791,7 @@ Perl_op_free(pTHX_ OP *o)
 {
     dVAR;
     OPCODE type;
-    SSize_t defer_ix = -1;
-    SSize_t defer_stack_alloc = 0;
-    OP **defer_stack = NULL;
+    dDEFER_OP;
 
     do {
 
@@ -870,7 +889,7 @@ Perl_op_free(pTHX_ OP *o)
             PL_op = NULL;
     } while ( (o = POP_DEFERRED_OP()) );
 
-    Safefree(defer_stack);
+    DEFER_OP_CLEANUP;
 }
 
 /* S_op_clear_gv(): free a GV attached to an OP */
@@ -1892,10 +1911,8 @@ Perl_scalarvoid(pTHX_ OP *arg)
     dVAR;
     OP *kid;
     SV* sv;
-    SSize_t defer_stack_alloc = 0;
-    SSize_t defer_ix = -1;
-    OP **defer_stack = NULL;
     OP *o = arg;
+    dDEFER_OP;
 
     PERL_ARGS_ASSERT_SCALARVOID;
 
@@ -2256,7 +2273,7 @@ Perl_scalarvoid(pTHX_ OP *arg)
         }
     } while ( (o = POP_DEFERRED_OP()) );
 
-    Safefree(defer_stack);
+    DEFER_OP_CLEANUP;
 
     return arg;
 }
@@ -3458,39 +3475,47 @@ Perl_optimize_optree(pTHX_ OP* o)
 STATIC void
 S_optimize_op(pTHX_ OP* o)
 {
-    OP *kid;
+    dDEFER_OP;
 
     PERL_ARGS_ASSERT_OPTIMIZE_OP;
-    assert(o->op_type != OP_FREED);
+    do {
+        assert(o->op_type != OP_FREED);
 
-    switch (o->op_type) {
-    case OP_NEXTSTATE:
-    case OP_DBSTATE:
-	PL_curcop = ((COP*)o);		/* for warnings */
-	break;
+        switch (o->op_type) {
+        case OP_NEXTSTATE:
+        case OP_DBSTATE:
+            PL_curcop = ((COP*)o);		/* for warnings */
+            break;
 
 
-    case OP_CONCAT:
-    case OP_SASSIGN:
-    case OP_STRINGIFY:
-    case OP_SPRINTF:
-        S_maybe_multiconcat(aTHX_ o);
-        break;
+        case OP_CONCAT:
+        case OP_SASSIGN:
+        case OP_STRINGIFY:
+        case OP_SPRINTF:
+            S_maybe_multiconcat(aTHX_ o);
+            break;
 
-    case OP_SUBST:
-	if (cPMOPo->op_pmreplrootu.op_pmreplroot)
-	    optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
-	break;
+        case OP_SUBST:
+            if (cPMOPo->op_pmreplrootu.op_pmreplroot)
+                DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
+            break;
 
-    default:
-	break;
-    }
+        default:
+            break;
+        }
 
-    if (!(o->op_flags & OPf_KIDS))
-        return;
+        if (o->op_flags & OPf_KIDS) {
+            OP *kid;
+            IV child_count = 0;
+            for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+                DEFER_OP(kid);
+                ++child_count;
+            }
+            DEFER_REVERSE(child_count);
+        }
+    } while ( ( o = POP_DEFERRED_OP() ) );
 
-    for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
-        optimize_op(kid);
+    DEFER_OP_CLEANUP;
 }
 
 
@@ -3537,26 +3562,66 @@ S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
 }
 #endif
 
+/*
+=for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
+
+Return the next op in a depth-first traversal of the op tree,
+returning NULL when the traversal is complete.
+
+The initial call must supply the root of the tree as both top and o.
+
+For now it's static, but it may be exposed to the API in the future.
+
+=cut
+*/
+
+STATIC OP*
+S_traverse_op_tree(OP *top, OP *o) {
+    OP *sib;
+
+    PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
+
+    if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
+        return cUNOPo->op_first;
+    }
+    else if ((sib = OpSIBLING(o))) {
+        return sib;
+    }
+    else {
+        OP *parent = o->op_sibparent;
+        assert(!(o->op_moresib));
+        while (parent && parent != top) {
+            OP *sib = OpSIBLING(parent);
+            if (sib)
+                return sib;
+            parent = parent->op_sibparent;
+        }
+
+        return NULL;
+    }
+}
 
 STATIC void
 S_finalize_op(pTHX_ OP* o)
 {
+    OP * const top = o;
     PERL_ARGS_ASSERT_FINALIZE_OP;
 
-    assert(o->op_type != OP_FREED);
+    do {
+        assert(o->op_type != OP_FREED);
 
-    switch (o->op_type) {
-    case OP_NEXTSTATE:
-    case OP_DBSTATE:
-	PL_curcop = ((COP*)o);		/* for warnings */
-	break;
-    case OP_EXEC:
-        if (OpHAS_SIBLING(o)) {
-            OP *sib = OpSIBLING(o);
-            if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
-                && ckWARN(WARN_EXEC)
-                && OpHAS_SIBLING(sib))
-            {
+        switch (o->op_type) {
+        case OP_NEXTSTATE:
+        case OP_DBSTATE:
+            PL_curcop = ((COP*)o);		/* for warnings */
+            break;
+        case OP_EXEC:
+            if (OpHAS_SIBLING(o)) {
+                OP *sib = OpSIBLING(o);
+                if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
+                    && ckWARN(WARN_EXEC)
+                    && OpHAS_SIBLING(sib))
+                {
 		    const OPCODE type = OpSIBLING(sib)->op_type;
 		    if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
 			const line_t oldline = CopLINE(PL_curcop);
@@ -3567,149 +3632,147 @@ S_finalize_op(pTHX_ OP* o)
 			    "\t(Maybe you meant system() when you said exec()?)\n");
 			CopLINE_set(PL_curcop, oldline);
 		    }
-	    }
-        }
-	break;
+                }
+            }
+            break;
 
-    case OP_GV:
-	if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
-	    GV * const gv = cGVOPo_gv;
-	    if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
-		/* XXX could check prototype here instead of just carping */
-		SV * const sv = sv_newmortal();
-		gv_efullname3(sv, gv, NULL);
-		Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
-		    "%" SVf "() called too early to check prototype",
-		    SVfARG(sv));
-	    }
-	}
-	break;
+        case OP_GV:
+            if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
+                GV * const gv = cGVOPo_gv;
+                if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
+                    /* XXX could check prototype here instead of just carping */
+                    SV * const sv = sv_newmortal();
+                    gv_efullname3(sv, gv, NULL);
+                    Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
+                                "%" SVf "() called too early to check prototype",
+                                SVfARG(sv));
+                }
+            }
+            break;
 
-    case OP_CONST:
-	if (cSVOPo->op_private & OPpCONST_STRICT)
-	    no_bareword_allowed(o);
+        case OP_CONST:
+            if (cSVOPo->op_private & OPpCONST_STRICT)
+                no_bareword_allowed(o);
 #ifdef USE_ITHREADS
-        /* FALLTHROUGH */
-    case OP_HINTSEVAL:
-        op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
+            /* FALLTHROUGH */
+        case OP_HINTSEVAL:
+            op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
 #endif
-        break;
+            break;
 
 #ifdef USE_ITHREADS
-    /* Relocate all the METHOP's SVs to the pad for thread safety. */
-    case OP_METHOD_NAMED:
-    case OP_METHOD_SUPER:
-    case OP_METHOD_REDIR:
-    case OP_METHOD_REDIR_SUPER:
-        op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
-        break;
+            /* Relocate all the METHOP's SVs to the pad for thread safety. */
+        case OP_METHOD_NAMED:
+        case OP_METHOD_SUPER:
+        case OP_METHOD_REDIR:
+        case OP_METHOD_REDIR_SUPER:
+            op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
+            break;
 #endif
 
-    case OP_HELEM: {
-	UNOP *rop;
-	SVOP *key_op;
-	OP *kid;
+        case OP_HELEM: {
+            UNOP *rop;
+            SVOP *key_op;
+            OP *kid;
 
-	if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
-	    break;
+            if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
+                break;
 
-	rop = (UNOP*)((BINOP*)o)->op_first;
+            rop = (UNOP*)((BINOP*)o)->op_first;
 
-	goto check_keys;
+            goto check_keys;
 
-    case OP_HSLICE:
-	S_scalar_slice_warning(aTHX_ o);
-        /* FALLTHROUGH */
+            case OP_HSLICE:
+                S_scalar_slice_warning(aTHX_ o);
+                /* FALLTHROUGH */
 
-    case OP_KVHSLICE:
-        kid = OpSIBLING(cLISTOPo->op_first);
-	if (/* I bet there's always a pushmark... */
-	    OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
-	    && OP_TYPE_ISNT_NN(kid, OP_CONST))
-        {
-	    break;
-        }
+            case OP_KVHSLICE:
+                kid = OpSIBLING(cLISTOPo->op_first);
+	    if (/* I bet there's always a pushmark... */
+	        OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
+	        && OP_TYPE_ISNT_NN(kid, OP_CONST))
+            {
+	        break;
+            }
 
-	key_op = (SVOP*)(kid->op_type == OP_CONST
-				? kid
-				: OpSIBLING(kLISTOP->op_first));
+            key_op = (SVOP*)(kid->op_type == OP_CONST
+                             ? kid
+                             : OpSIBLING(kLISTOP->op_first));
 
-	rop = (UNOP*)((LISTOP*)o)->op_last;
+            rop = (UNOP*)((LISTOP*)o)->op_last;
 
-      check_keys:	
-        if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
-            rop = NULL;
-        S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
-	break;
-    }
-    case OP_NULL:
-	if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
-	    break;
-	/* FALLTHROUGH */
-    case OP_ASLICE:
-	S_scalar_slice_warning(aTHX_ o);
-	break;
-
-    case OP_SUBST: {
-	if (cPMOPo->op_pmreplrootu.op_pmreplroot)
-	    finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
-	break;
-    }
-    default:
-	break;
-    }
+        check_keys:
+            if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
+                rop = NULL;
+            S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
+            break;
+        }
+        case OP_NULL:
+            if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
+                break;
+            /* FALLTHROUGH */
+        case OP_ASLICE:
+            S_scalar_slice_warning(aTHX_ o);
+            break;
 
-    if (o->op_flags & OPf_KIDS) {
-	OP *kid;
+        case OP_SUBST: {
+            if (cPMOPo->op_pmreplrootu.op_pmreplroot)
+                finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+            break;
+        }
+        default:
+            break;
+        }
 
 #ifdef DEBUGGING
-        /* check that op_last points to the last sibling, and that
-         * the last op_sibling/op_sibparent field points back to the
-         * parent, and that the only ops with KIDS are those which are
-         * entitled to them */
-        U32 type = o->op_type;
-        U32 family;
-        bool has_last;
-
-        if (type == OP_NULL) {
-            type = o->op_targ;
-            /* ck_glob creates a null UNOP with ex-type GLOB
-             * (which is a list op. So pretend it wasn't a listop */
-            if (type == OP_GLOB)
-                type = OP_NULL;
-        }
-        family = PL_opargs[type] & OA_CLASS_MASK;
-
-        has_last = (   family == OA_BINOP
-                    || family == OA_LISTOP
-                    || family == OA_PMOP
-                    || family == OA_LOOP
-                   );
-        assert(  has_last /* has op_first and op_last, or ...
-              ... has (or may have) op_first: */
-              || family == OA_UNOP
-              || family == OA_UNOP_AUX
-              || family == OA_LOGOP
-              || family == OA_BASEOP_OR_UNOP
-              || family == OA_FILESTATOP
-              || family == OA_LOOPEXOP
-              || family == OA_METHOP
-              || type == OP_CUSTOM
-              || type == OP_NULL /* new_logop does this */
-              );
-
-        for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
-            if (!OpHAS_SIBLING(kid)) {
-                if (has_last)
-                    assert(kid == cLISTOPo->op_last);
-                assert(kid->op_sibparent == o);
+        if (o->op_flags & OPf_KIDS) {
+            OP *kid;
+
+            /* check that op_last points to the last sibling, and that
+             * the last op_sibling/op_sibparent field points back to the
+             * parent, and that the only ops with KIDS are those which are
+             * entitled to them */
+            U32 type = o->op_type;
+            U32 family;
+            bool has_last;
+
+            if (type == OP_NULL) {
+                type = o->op_targ;
+                /* ck_glob creates a null UNOP with ex-type GLOB
+                 * (which is a list op. So pretend it wasn't a listop */
+                if (type == OP_GLOB)
+                    type = OP_NULL;
+            }
+            family = PL_opargs[type] & OA_CLASS_MASK;
+
+            has_last = (   family == OA_BINOP
+                        || family == OA_LISTOP
+                        || family == OA_PMOP
+                        || family == OA_LOOP
+                       );
+            assert(  has_last /* has op_first and op_last, or ...
+                  ... has (or may have) op_first: */
+                  || family == OA_UNOP
+                  || family == OA_UNOP_AUX
+                  || family == OA_LOGOP
+                  || family == OA_BASEOP_OR_UNOP
+                  || family == OA_FILESTATOP
+                  || family == OA_LOOPEXOP
+                  || family == OA_METHOP
+                  || type == OP_CUSTOM
+                  || type == OP_NULL /* new_logop does this */
+                  );
+
+            for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+                if (!OpHAS_SIBLING(kid)) {
+                    if (has_last)
+                        assert(kid == cLISTOPo->op_last);
+                    assert(kid->op_sibparent == o);
+                }
             }
         }
 #endif
-
-	for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
-	    finalize_op(kid);
-    }
+    } while (( o = traverse_op_tree(top, o)) != NULL);
 }
 
 /*
diff --git a/proto.h b/proto.h
index 36a61db05d..daf338707b 100644
--- a/proto.h
+++ b/proto.h
@@ -5115,6 +5115,9 @@ STATIC OP*	S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 STATIC OP*	S_too_many_arguments_pv(pTHX_ OP *o, const char* name, U32 flags);
 #define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV	\
 	assert(o); assert(name)
+STATIC OP*	S_traverse_op_tree(pTHX_ OP* top, OP* o);
+#define PERL_ARGS_ASSERT_TRAVERSE_OP_TREE	\
+	assert(top); assert(o)
 #  if defined(USE_ITHREADS)
 #ifndef PERL_NO_INLINE_FUNCTIONS
 PERL_STATIC_INLINE void	S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp);

-- 
Perl5 Master Repository



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About