In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c899ae2d02e643a00e4504a6657f4d6d870b8169?hp=61eef0f5eac901e462178b0556cbaacb988b8a58>
- Log ----------------------------------------------------------------- commit c899ae2d02e643a00e4504a6657f4d6d870b8169 Merge: 61eef0f 72621f8 Author: David Mitchell <[email protected]> Date: Sun Mar 16 18:51:07 2014 +0000 [MERGE] avoid calling pp_null(). Several 'empty' ops like OP_NULL and OP_SCOPE call pp_null() at run-time (which just returns). Attempts are made to strip such empty ops from the op_next execution chain, but this has not been not complete. In particular, ops at the head or tail of a sub-chain, or ops that rpeep() has itself nulled, weren't being eliminated. This merge avoids all calls to pp_null() in the test suite, apart from those called via the constant folder (which is called before null op elimination), and OP_REGCMAYBE (which isn't addressed here). commit 72621f848a21771e5c59382103fc6e1e528ddc47 Author: David Mitchell <[email protected]> Date: Wed Mar 5 16:08:02 2014 +0000 elide "empty" ops at the head of op_next chains Currently all OP_NULL/OP_SCOPE/OP_SCALAR/OP_LINESEQ ops (which all map at run time to pp_null()) are eliminated from op_next chains *except* ones at the head of a chain (e.g. pointed to by o->op_other). The API of peep()/rpeep() makes it difficult to directly do this within the function itself, as it has no return value - and thus RPEEP(o->op_other) has no way to update op_other to skip the first op if it happens to be a null or whatever. Instead, we add a small helper function, S_prune_chain_head(), and always call it after we call peep, e.g. CALL_PEEP(PL_main_start); finalize_optree(PL_main_root); +S_prune_chain_head(aTHX_ &PL_main_start); rpeep() is also complicated by its recursion reduction mechanism, where it saves the addresses of several ops before recursing on them. I had to change this so that it saves the addresses of the addresses of the ops instead, so they can be updated: i.e. rather than saving o->op_other, it saves &(o->op_other). With this commit, nothing in the test suite triggers executing pp_null(), execpt OP_REGCMAYBE and S_fold_constants(). I verified this with the following hacky diff: >>>>diff --git a/op.c b/op.c >>>>index 716c684..819a717 100644 >>>>--- a/op.c >>>>+++ b/op.c >>>>@@ -3489,6 +3489,7 @@ S_op_integerize(pTHX_ OP *o) >>>> return o; >>>> } >>>> >>>>+int XXX_folding = 0; >>>> static OP * >>>> S_fold_constants(pTHX_ OP *o) >>>> { >>>>@@ -3504,6 +3505,7 @@ S_fold_constants(pTHX_ OP *o) >>>> SV * const olddiehook = PL_diehook; >>>> COP not_compiling; >>>> dJMPENV; >>>>+ int XXX_folding_old = XXX_folding; >>>> >>>> PERL_ARGS_ASSERT_FOLD_CONSTANTS; >>>> >>>>@@ -3583,11 +3585,13 @@ S_fold_constants(pTHX_ OP *o) >>>> assert(IN_PERL_RUNTIME); >>>> PL_warnhook = PERL_WARNHOOK_FATAL; >>>> PL_diehook = NULL; >>>>+ XXX_folding = 1; >>>> JMPENV_PUSH(ret); >>>> >>>> switch (ret) { >>>> case 0: >>>> CALLRUNOPS(aTHX); >>>>+ XXX_folding = XXX_folding_old; >>>> sv = *(PL_stack_sp--); >>>> if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */ >>>> #ifdef PERL_MAD >>>>@@ -3608,10 +3612,12 @@ S_fold_constants(pTHX_ OP *o) >>>> case 3: >>>> /* Something tried to die. Abandon constant folding. */ >>>> /* Pretend the error never happened. */ >>>>+ XXX_folding = XXX_folding_old; >>>> CLEAR_ERRSV(); >>>> o->op_next = old_next; >>>> break; >>>> default: >>>>+ XXX_folding = XXX_folding_old; >>>> JMPENV_POP; >>>> /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ >>>> PL_warnhook = oldwarnhook; >>>>diff --git a/pp_hot.c b/pp_hot.c >>>>index 36eac2b..ccb582f 100644 >>>>--- a/pp_hot.c >>>>+++ b/pp_hot.c >>>>@@ -68,9 +68,16 @@ PP(pp_gvsv) >>>> RETURN; >>>> } >>>> >>>>+extern int XXX_folding; >>>> PP(pp_null) >>>> { >>>> dVAR; >>>>+ if (!XXX_folding && PL_op->op_type != OP_REGCMAYBE) { >>>>+ sv_dump((SV*)find_runcv(0)); >>>>+ op_dump(PL_op); >>>>+ op_dump((OP*)PL_curcop); >>>>+ assert(0); >>>>+ } >>>> return NORMAL; >>>> } >>>> M op.c commit e42737055d5d2ce05a8416a08c424c0d246ba839 Author: David Mitchell <[email protected]> Date: Wed Mar 5 19:42:36 2014 +0000 rpeep(): elide just-nulled ops Perl_rpeep() currently spots "empty" ops like OP_NULL, OP_SCOPE and elides them from the op_next chain (by setting oldop->op_next to point to the op following the current op). However, if rpeep() itself op_null()'s the current op, then when the main loop is re-entered, that mechanism is bypassed. Modify re-entry to the loop in this case so that the just nulled op re-processed and thus elided. (Also document what the OP_SASSIGN/OP_SUBSTR optimisation is doing; studying that was what originally led me to this general fix.) M op.c commit 1022336546c7c8280b26bac6ed9c55bfd217804f Author: David Mitchell <[email protected]> Date: Wed Mar 5 19:42:02 2014 +0000 rpeep(): remove trailing OP_NULLs etc Perl_rpeep() elides OP_NULLs etc in the middle of an op_next chain, but not at the start or end. Doing it at the start is hard (and not addressed here); doing it at the end is trivial, and it just looks like a mistake in the original code (there since 1994) that was (incorrectly) worried about following through a null pointer. M embed.fnc M op.c M proto.h commit cdec98ff86310d40c5a05f14e7e624f52ddcc156 Author: David Mitchell <[email protected]> Date: Thu Mar 6 13:32:56 2014 +0000 code following eval {} not always optimised In something like this eval { 1 while 1 }; $x = $a[0]; The optimising of the while loop makes Perl_rpeep() miss processing the chain of ops from the OP_LEAVETRY onwards. So in the code above for example, the alem wont be optimised into an alemfast. Fix this by explicitly recursing into the entertry->op_other branch (which actually points at the leavetry). The infinite loop above can be broken by, for example, a signal handler calling die. M op.c commit 932bca295d64243e2ef2aeaacc779b68cc05e1b2 Author: David Mitchell <[email protected]> Date: Wed Mar 5 14:44:41 2014 +0000 OP_SORT: store start of block in null->op_next When a sort with a code block, like sort { BLOCK } arg, ... is compiled, it comes out like sort pushmark null scope BLOCK arg ... (The 'scope' may be instead be 'ex-leave' depending on circumstances). At run time, pp_sort() navigates its way down from the sort op to find the start op of the BLOCK. We can shorten this process slightly by storing the start of BLOCK in the otherwise unused op_next field of the OP_NULL. Effectively we are using the null->op_next field as a surrogate op_other field for the op_sort (which doesn't have a spare field we could store the pointer in). The main point of this commit however is not the slight speed up from skipping a couple of pointer follows at run-time; rather that it will shortly allow us to trim any null ops from the beginning of the BLOCK. We can't do this directly, as that would involve changing the scope->op_first pointer, which might confuse B:: type modules. M op.c M pp_sort.c commit 22240f589eab50022218e3541b91a487c29a729b Author: David Mitchell <[email protected]> Date: Wed Mar 5 14:19:33 2014 +0000 rpeep(): OP_SORT with code block has OPf_SPECIAL In rpeep(), we check whether the OP_SORT has a code block as the first arg (e.g. sort {BLOCK} ...) by testing for OPf_STACKED, then looking for an OP_SCOPE or ex-OP_LEAVE. However, ck_sort() has already checked for this situation and set the OPf_SPECIAL flag. So just just check for this flag in rpeep(); leave in the OP_SCOPE/ex-OP_LEAVE checks as just assertions. Also, add some commentary to ck_sort() and S_simplify_sort(). M op.c ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- op.c | 126 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-------- pp_sort.c | 7 ++-- proto.h | 5 +-- 4 files changed, 117 insertions(+), 23 deletions(-) diff --git a/embed.fnc b/embed.fnc index 66c16d6..1e96cbc 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2017,7 +2017,7 @@ s |void |qsortsvu |NULLOK SV** array|size_t num_elts|NN SVCOMPARE_t compare #endif #if defined(PERL_IN_PP_SYS_C) -s |OP* |doform |NN CV *cv|NN GV *gv|NN OP *retop +s |OP* |doform |NN CV *cv|NN GV *gv|NULLOK OP *retop # if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) sR |int |dooneliner |NN const char *cmd|NN const char *filename # endif diff --git a/op.c b/op.c index a6488b0..716c684 100644 --- a/op.c +++ b/op.c @@ -109,6 +109,24 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o) +/* remove any leading "empty" ops from the op_next chain whose first + * node's address is stored in op_p. Store the updated address of the + * first node in op_p. + */ + +STATIC void +S_prune_chain_head(pTHX_ OP** op_p) +{ + while (*op_p + && ( (*op_p)->op_type == OP_NULL + || (*op_p)->op_type == OP_SCOPE + || (*op_p)->op_type == OP_SCALAR + || (*op_p)->op_type == OP_LINESEQ) + ) + *op_p = (*op_p)->op_next; +} + + /* See the explanatory comments above struct opslab in op.h. */ #ifdef PERL_DEBUG_READONLY_OPS @@ -3297,6 +3315,7 @@ Perl_newPROG(pTHX_ OP *o) ENTER; CALL_PEEP(PL_eval_start); finalize_optree(PL_eval_root); + S_prune_chain_head(aTHX_ &PL_eval_start); LEAVE; PL_savestack_ix = i; } @@ -3341,6 +3360,7 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root->op_next = 0; CALL_PEEP(PL_main_start); finalize_optree(PL_main_root); + S_prune_chain_head(aTHX_ &PL_main_start); cv_forget_slab(PL_compcv); PL_compcv = 0; @@ -3647,9 +3667,11 @@ S_gen_constant_list(pTHX_ OP *o) if (PL_parser && PL_parser->error_count) return o; /* Don't attempt to run with errors */ - PL_op = curop = LINKLIST(o); + curop = LINKLIST(o); o->op_next = 0; CALL_PEEP(curop); + S_prune_chain_head(aTHX_ &curop); + PL_op = curop; Perl_pp_pushmark(aTHX); CALLRUNOPS(aTHX); PL_op = curop; @@ -4876,6 +4898,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) /* have to peep the DOs individually as we've removed it from * the op_next chain */ CALL_PEEP(o); + S_prune_chain_head(aTHX_ &(o->op_next)); if (is_compiletime) /* runtime finalizes as part of finalizing whole tree */ finalize_optree(o); @@ -7599,6 +7622,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); + S_prune_chain_head(aTHX_ &CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ @@ -7954,6 +7978,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); + S_prune_chain_head(aTHX_ &CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ @@ -8351,6 +8376,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); + S_prune_chain_head(aTHX_ &CvSTART(cv)); cv_forget_slab(cv); finish: @@ -9962,9 +9988,12 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) simplify_sort(o); firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ + /* if the first arg is a code block, process it and mark sort as + * OPf_SPECIAL */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { LINKLIST(kid); if (kid->op_type == OP_LEAVE) @@ -9991,6 +10020,16 @@ Perl_ck_sort(pTHX_ OP *o) return o; } +/* for sort { X } ..., where X is one of + * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a + * elide the second child of the sort (the one containing X), + * and set these flags as appropriate + OPpSORT_NUMERIC; + OPpSORT_INTEGER; + OPpSORT_DESCEND; + * Also, check and warn on lexical $a, $b. + */ + STATIC void S_simplify_sort(pTHX_ OP *o) { @@ -11136,21 +11175,28 @@ S_inplace_aassign(pTHX_ OP *o) { op_null(oleft); } + + +/* mechanism for deferring recursion in rpeep() */ + #define MAX_DEFERRED 4 #define DEFER(o) \ STMT_START { \ if (defer_ix == (MAX_DEFERRED-1)) { \ - CALL_RPEEP(defer_queue[defer_base]); \ + OP **defer = defer_queue[defer_base]; \ + CALL_RPEEP(*defer); \ + S_prune_chain_head(aTHX_ defer); \ defer_base = (defer_base + 1) % MAX_DEFERRED; \ defer_ix--; \ } \ - defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \ + defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \ } STMT_END #define IS_AND_OP(o) (o->op_type == OP_AND) #define IS_OR_OP(o) (o->op_type == OP_OR) + STATIC void S_null_listop_in_list_context(pTHX_ OP *o) { @@ -11181,7 +11227,7 @@ Perl_rpeep(pTHX_ OP *o) dVAR; OP* oldop = NULL; OP* oldoldop = NULL; - OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ + OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ int defer_base = 0; int defer_ix = -1; @@ -11194,8 +11240,12 @@ Perl_rpeep(pTHX_ OP *o) if (o && o->op_opt) o = NULL; if (!o) { - while (defer_ix >= 0) - CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]); + while (defer_ix >= 0) { + OP **defer = + defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]; + CALL_RPEEP(*defer); + S_prune_chain_head(aTHX_ defer); + } break; } @@ -11440,7 +11490,7 @@ Perl_rpeep(pTHX_ OP *o) case OP_LINESEQ: case OP_SCOPE: nothin: - if (oldop && o->op_next) { + if (oldop) { oldop->op_next = o->op_next; o->op_opt = 0; continue; @@ -11871,6 +11921,11 @@ Perl_rpeep(pTHX_ OP *o) DEFER(cLOOP->op_lastop); break; + case OP_ENTERTRY: + assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); + DEFER(cLOGOPo->op_other); + break; + case OP_SUBST: assert(!(cPMOP->op_pmflags & PMf_ONCE)); while (cPMOP->op_pmstashstartu.op_pmreplstart && @@ -11883,12 +11938,28 @@ Perl_rpeep(pTHX_ OP *o) case OP_SORT: { OP *oright; - if (o->op_flags & OPf_STACKED) { - OP * const kid = - cUNOPx(cLISTOP->op_first->op_sibling)->op_first; - if (kid->op_type == OP_SCOPE - || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)) - DEFER(kLISTOP->op_first); + if (o->op_flags & OPf_SPECIAL) { + /* first arg is a code block */ + OP * const nullop = cLISTOP->op_first->op_sibling; + OP * kid = cUNOPx(nullop)->op_first; + + assert(nullop->op_type == OP_NULL); + assert(kid->op_type == OP_SCOPE + || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); + /* since OP_SORT doesn't have a handy op_other-style + * field that can point directly to the start of the code + * block, store it in the otherwise-unused op_next field + * of the top-level OP_NULL. This will be quicker at + * run-time, and it will also allow us to remove leading + * OP_NULLs by just messing with op_nexts without + * altering the basic op_first/op_sibling layout. */ + kid = kLISTOP->op_first; + assert( + (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + || kid->op_type == OP_STUB + || kid->op_type == OP_ENTER); + nullop->op_next = kLISTOP->op_next; + DEFER(nullop->op_next); } /* check that RHS of sort is a single plain array */ @@ -12040,6 +12111,23 @@ Perl_rpeep(pTHX_ OP *o) if (OP_GIMME(o,0) == G_VOID) { OP *right = cBINOP->op_first; if (right) { + /* sassign + * RIGHT + * substr + * pushmark + * arg1 + * arg2 + * ... + * becomes + * + * ex-sassign + * substr + * pushmark + * RIGHT + * arg1 + * arg2 + * ... + */ OP *left = right->op_sibling; if (left->op_type == OP_SUBSTR && (left->op_private & 7) < 4) { @@ -12065,8 +12153,16 @@ Perl_rpeep(pTHX_ OP *o) } } - oldoldop = oldop; - oldop = o; + /* did we just null the current op? If so, re-process it to handle + * eliding "empty" ops from the chain */ + if (o->op_type == OP_NULL && oldop && oldop->op_next == o) { + o->op_opt = 0; + o = oldop; + } + else { + oldoldop = oldop; + oldop = o; + } } LEAVE; } diff --git a/pp_sort.c b/pp_sort.c index 4741d71..0fe0411 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -1512,10 +1512,9 @@ PP(pp_sort) SAVEVPTR(PL_sortcop); if (flags & OPf_STACKED) { if (flags & OPf_SPECIAL) { - OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ - kid = kUNOP->op_first; /* pass rv2gv */ - kid = kUNOP->op_first; /* pass leave */ - PL_sortcop = kid->op_next; + OP *nullop = cLISTOP->op_first->op_sibling; /* pass pushmark */ + assert(nullop->op_type == OP_NULL); + PL_sortcop = nullop->op_next; } else { GV *autogv = NULL; diff --git a/proto.h b/proto.h index 87f06c5..9b33013 100644 --- a/proto.h +++ b/proto.h @@ -6579,10 +6579,9 @@ STATIC I32 S_sv_ncmp(pTHX_ SV *const a, SV *const b) #if defined(PERL_IN_PP_SYS_C) STATIC OP* S_doform(pTHX_ CV *cv, GV *gv, OP *retop) __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2) - __attribute__nonnull__(pTHX_3); + __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DOFORM \ - assert(cv); assert(gv); assert(retop) + assert(cv); assert(gv) STATIC SV * S_space_join_names_mortal(pTHX_ char *const *array) __attribute__nonnull__(pTHX_1); -- Perl5 Master Repository
