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 <[email protected]> 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 <[email protected]> Date: Tue Jan 29 16:29:38 2019 +1100 (perl #108276) optimize child ops in sibling order commit f2861c9b15e4f5ce914d945a2d354a93a9fff926 Author: Tony Cook <[email protected]> Date: Wed Jan 30 11:06:52 2019 +1100 (perl #108276) indent optimize_op() loop body commit e76010b6a580610b68e389d4bfcdf53d64dbbdea Author: Tony Cook <[email protected]> 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 <[email protected]> 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 <[email protected]> Date: Tue Jan 29 14:22:02 2019 +1100 (perl #108276) indent body of new finalize_op() loop commit 7f8280cf23d815fd4e0e02a23b82859f0d03b84b Author: Tony Cook <[email protected]> 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
