X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9fdd7fc4796d89d16dceea42f2af91e4fde296ed..02b54f9d07226e99a30271314e02617d5629b511:/peep.c diff --git a/peep.c b/peep.c index 32fa401..9b41daf 100644 --- a/peep.c +++ b/peep.c @@ -715,7 +715,7 @@ S_maybe_multiconcat(pTHX_ OP *o) * * During the conversion process, EXPR ops are stripped from the tree * and unshifted onto o. Finally, any of o's remaining original - * childen are discarded and o is converted into an OP_MULTICONCAT. + * children are discarded and o is converted into an OP_MULTICONCAT. * * In this middle of this, o may contain both: unshifted args on the * left, and some remaining original args on the right. lastkidop @@ -1990,7 +1990,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) /* for N levels of aggregate lookup, we normally expect * that the first N-1 [ah]elem ops will be flagged as - * /DEREF (so they autovivifiy if necessary), and the last + * /DEREF (so they autovivify if necessary), and the last * lookup op not to be. * For other things (like @{$h{k1}{k2}}) extra scope or * leave ops can appear, so abandon the effort in that @@ -3032,7 +3032,11 @@ Perl_rpeep(pTHX_ OP *o) /* Two NEXTSTATEs in a row serve no purpose. Except if they happen to carry two labels. For now, take the easier option, and skip - this optimisation if the first NEXTSTATE has a label. */ + this optimisation if the first NEXTSTATE has a label. + Yves asked what about if they have different hints or features? + Tony thinks that as we remove the first of the pair it should + be fine. + */ if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) { OP *nextop = o->op_next; while (nextop) { @@ -3147,6 +3151,62 @@ Perl_rpeep(pTHX_ OP *o) } } + /* If the pushmark is associated with an empty anonhash + * or anonlist, null out the pushmark and swap in a + * specialised op for the parent. + * 4 <@> anonhash sK* ->5 + * 3 <0> pushmark s ->4 + * becomes: + * 3 <@> emptyavhv sK* ->4 + * - <0> pushmark s ->3 + */ + if (!OpHAS_SIBLING(o) && (o->op_next == o->op_sibparent) && ( + (o->op_next->op_type == OP_ANONHASH) || + (o->op_next->op_type == OP_ANONLIST) ) && + (o->op_next->op_flags & OPf_SPECIAL) ) { + + OP* anon = o->op_next; + /* These next two are _potentially_ a padsv and an sassign */ + OP* padsv = anon->op_next; + OP* sassign = (padsv) ? padsv->op_next: NULL; + + anon->op_private = (anon->op_type == OP_ANONLIST) ? + 0 : OPpEMPTYAVHV_IS_HV; + OpTYPE_set(anon, OP_EMPTYAVHV); + op_null(o); + o = anon; + if (oldop) /* A previous optimization may have NULLED it */ + oldop->op_next = anon; + + /* Further optimise scalar assignment of an empty anonhash + * or anonlist by subsuming the padsv & sassign OPs. */ + if ((padsv->op_type == OP_PADSV) && + !(padsv->op_private & OPpDEREF) && + sassign && (sassign->op_type == OP_SASSIGN) ){ + + /* Take some public flags from the sassign */ + anon->op_flags = OPf_KIDS | OPf_SPECIAL | + (anon->op_flags & OPf_PARENS) | + (sassign->op_flags & (OPf_WANT|OPf_PARENS)); + + /* Take some private flags from the padsv */ + anon->op_private |= OPpTARGET_MY | + (padsv->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)); + + /* Take the targ slot from the padsv*/ + anon->op_targ = padsv->op_targ; + padsv->op_targ = 0; + + /* Clean up */ + anon->op_next = sassign->op_next; + op_null(padsv); + op_null(sassign); + } + break; + + } + + /* Convert a series of PAD ops for my vars plus support into a * single padrange op. Basically * @@ -3163,7 +3223,7 @@ Perl_rpeep(pTHX_ OP *o) * any other pad ops, and possibly some trailing ops. * Note that we don't null() the skipped ops, to make it * easier for Deparse to undo this optimisation (and none of - * the skipped ops are holding any resourses). It also makes + * the skipped ops are holding any resources). It also makes * it easier for find_uninit_var(), as it can just ignore * padrange, and examine the original pad ops. */ @@ -3775,6 +3835,58 @@ Perl_rpeep(pTHX_ OP *o) break; } + case OP_UNDEF: + if ((o->op_flags & OPf_KIDS) && + (cUNOPx(o)->op_first->op_type == OP_PADSV)) { + + /* Convert: + * undef + * padsv[$x] + * to: + * undef[$x] + */ + + OP * padsv = cUNOPx(o)->op_first; + o->op_private = OPpTARGET_MY | + (padsv->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)); + o->op_targ = padsv->op_targ; padsv->op_targ = 0; + op_null(padsv); + /* Optimizer does NOT seem to fix up the padsv op_next ptr */ + if (oldoldop) + oldoldop->op_next = o; + oldop = oldoldop; + oldoldop = NULL; + + } else if (o->op_next->op_type == OP_PADSV) { + OP * padsv = o->op_next; + OP * sassign = (padsv->op_next && + padsv->op_next->op_type == OP_SASSIGN) ? + padsv->op_next : NULL; + if (sassign && cBINOPx(sassign)->op_first == o) { + /* Convert: + * sassign + * undef + * padsv[$x] + * to: + * undef[$x] + * NOTE: undef does not have the "T" flag set in + * regen/opcodes, as this would cause + * S_maybe_targlex to do the optimization. + * Seems easier to keep it all here, rather + * than have an undef-specific branch in + * S_maybe_targlex just to add the + * OPpUNDEF_KEEP_PV flag. + */ + o->op_private = OPpTARGET_MY | OPpUNDEF_KEEP_PV | + (padsv->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)); + o->op_targ = padsv->op_targ; padsv->op_targ = 0; + op_null(padsv); + op_null(sassign); + /* Optimizer DOES seems to fix up the op_next ptrs */ + } + } + break; + case OP_QR: case OP_MATCH: if (!(cPMOP->op_pmflags & PMf_ONCE)) { @@ -3799,7 +3911,7 @@ Perl_rpeep(pTHX_ OP *o) } break; - case OP_SASSIGN: + case OP_SASSIGN: { if (OP_GIMME(o,0) == G_VOID || ( o->op_next->op_type == OP_LINESEQ && ( o->op_next->op_next->op_type == OP_LEAVESUB @@ -3854,8 +3966,14 @@ Perl_rpeep(pTHX_ OP *o) if (!(o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV)) && lval && (lval->op_type == OP_PADSV) && !(lval->op_private & OPpDEREF) + /* skip if padrange has already gazumped the padsv */ + && (lval == oldop) + /* Memoize::Once produces a non-standard SASSIGN that + * doesn't actually point to pp_sassign, has only one + * child (PADSV), and gets to it via op_other rather + * than op_next. Don't try to optimize this. */ + && (lval != rhs) ) { - /* SASSIGN's bitfield flags, such as op_moresib and * op_slabbed, will be carried over unchanged. */ OpTYPE_set(o, OP_PADSV_STORE); @@ -3876,6 +3994,7 @@ Perl_rpeep(pTHX_ OP *o) o->op_targ = lval->op_targ; lval->op_targ = 0; /* Fixup op_next ptrs */ + assert(oldop->op_type == OP_PADSV); /* oldoldop can be arbitrarily deep in the RHS OP tree */ oldoldop->op_next = o; @@ -3892,7 +4011,56 @@ Perl_rpeep(pTHX_ OP *o) /* NULL the previous op ptrs, so rpeep can continue */ oldoldop = NULL; oldop = NULL; } + + /* Combine a simple SASSIGN OP with an AELEMFAST_LEX lvalue + * into a single OP. This optimization covers arbitrarily + * complicated RHS OP trees. */ + + if (!(o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV)) + && (lval->op_type == OP_NULL) && (lval->op_private == 2) && + (cBINOPx(lval)->op_first->op_type == OP_AELEMFAST_LEX) + ) { + OP * lex = cBINOPx(lval)->op_first; + /* SASSIGN's bitfield flags, such as op_moresib and + * op_slabbed, will be carried over unchanged. */ + OpTYPE_set(o, OP_AELEMFASTLEX_STORE); + + /* Explicitly craft the new OP's op_flags, carrying + * some bits over from the SASSIGN */ + o->op_flags = ( + OPf_KIDS | OPf_STACKED | + (o->op_flags & (OPf_WANT|OPf_PARENS)) + ); + + /* Copy the AELEMFAST_LEX op->private, which contains + * the key index. */ + o->op_private = lex->op_private; + + /* Take the targ from the AELEMFAST_LEX */ + o->op_targ = lex->op_targ; lex->op_targ = 0; + + assert(oldop->op_type == OP_AELEMFAST_LEX); + /* oldoldop can be arbitrarily deep in the RHS OP tree */ + oldoldop->op_next = o; + + /* Even when (rhs != oldoldop), rhs might still have a + * relevant op_next ptr to lex. (Updating it here can + * also cause other ops in the RHS to get the desired + * op_next pointer, presumably thanks to the finalizer.) + * This is definitely truewhen rhs is OP_NULL with a + * LOGOP kid (e.g. orassign). There may be other cases. */ + if (rhs->op_next == lex) + rhs->op_next = o; + + /* Now null-out the AELEMFAST_LEX */ + op_null(lex); + + /* NULL the previous op ptrs, so rpeep can continue */ + oldop = oldoldop; oldoldop = NULL; + } + break; + } case OP_AASSIGN: { int l, r, lr, lscalars, rscalars;