diff --git a/lib/builtin.t b/lib/builtin.t index ce5de3455b60f..c4b26ee3640b2 100644 --- a/lib/builtin.t +++ b/lib/builtin.t @@ -347,6 +347,30 @@ package FetchStoreCounter { is(prototype(\&builtin::indexed), '@', 'indexed prototype'); } +# indexed + foreach loop optimisation appears transparent +{ + my @output; + my @input = qw( zero one two three four five ); + + foreach my ( $idx, $val ) ( builtin::indexed @input ) { + push @output, "[$idx]=$val"; + } + + ok(eq_array(\@output, [qw( [0]=zero [1]=one [2]=two [3]=three [4]=four [5]=five )] ), + 'foreach + builtin::indexed' ); + + undef @output; + + use builtin qw( indexed ); + + foreach my ( $idx, $val ) ( indexed @input ) { + push @output, "[$idx]=$val"; + } + + ok(eq_array(\@output, [qw( [0]=zero [1]=one [2]=two [3]=three [4]=four [5]=five )] ), + 'foreach + imported indexed' ); +} + # Vanilla trim tests { use builtin qw( trim ); diff --git a/op.c b/op.c index e0340bb7707a9..bc8df993cfaa5 100644 --- a/op.c +++ b/op.c @@ -171,6 +171,9 @@ recursive, but it's recursive on basic blocks, not on tree nodes. static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar"; +/* UGH!! */ +EXTERN_C void XS_builtin_indexed(pTHX_ CV *); + /* 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. @@ -9631,6 +9634,39 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, return o; } +#define op_is_cv_xsub(o, xsub) S_op_is_cv_xsub(aTHX_ o, xsub) +static bool +S_op_is_cv_xsub(pTHX_ OP *o, XSUBADDR_t xsub) +{ + if(o->op_type == OP_NULL) + o = cUNOPo->op_first; + + CV *cv; + switch(o->op_type) { + case OP_GV: + { + GV *gv; + if(!(gv = cGVOPo_gv)) + return false; + cv = GvCV(gv); + break; + } + + case OP_PADCV: + cv = (CV *)PAD_SVl(o->op_targ); + assert(cv && SvTYPE(cv) == SVt_PVCV); + break; + + default: + return false; + } + + if(!cv || !CvISXSUB(cv)) + return false; + + return CvXSUB(cv) == xsub; +} + /* =for apidoc newFOROP @@ -9663,6 +9699,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) PADOFFSET how_many_more = 0; I32 enteriterflags = 0; I32 enteriterpflags = 0; + U8 iterpflags = 0; bool parens = 0; PERL_ARGS_ASSERT_NEWFOROP; @@ -9774,6 +9811,42 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) expr = op_lvalue(op_force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); enteriterflags |= OPf_STACKED; } + else if (padoff != 0 && how_many_more == 1 && /* two lexical vars */ + expr->op_type == OP_ENTERSUB) { + OP *args = cUNOPx(expr)->op_first; + assert(OP_TYPE_IS_OR_WAS(args, OP_LIST)); + + OP *pre_firstarg = NULL; + OP *firstarg = cLISTOPx(args)->op_first; + OP *lastarg = cLISTOPx(args)->op_last; + + if(firstarg->op_type == OP_PUSHMARK) + pre_firstarg = firstarg, firstarg = OpSIBLING(firstarg); + if(firstarg == lastarg) + firstarg = NULL; + + if (op_is_cv_xsub(lastarg, &XS_builtin_indexed) && /* a call to builtin::indexed */ + firstarg && OpSIBLING(firstarg) == lastarg && /* with one arg */ + (firstarg->op_type == OP_RV2AV || firstarg->op_type == OP_PADAV) /* ... which is an array */ + ) { + /* Turn for my ($idx, $val) (indexed @arr) into a similar OPf_STACKED + * loop on the array itself as the case above, plus a flag to tell + * pp_iter to set the index directly + */ + + /* Cut the array arg out of the args list and discard the rest of + * the original expr + */ + op_sibling_splice(args, pre_firstarg, 1, NULL); + op_free(expr); + + expr = op_lvalue(op_force_list(scalar(ref(firstarg, OP_ITER))), OP_GREPSTART); + enteriterflags |= OPf_STACKED; + iterpflags |= OPpITER_INDEXED; + } + else + goto expr_not_special; + } else if (expr->op_type == OP_NULL && (expr->op_flags & OPf_KIDS) && cBINOPx(expr)->op_first->op_type == OP_FLOP) @@ -9804,6 +9877,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) enteriterflags |= OPf_STACKED; } else { +expr_not_special: expr = op_lvalue(op_force_list(expr), OP_GREPSTART); } @@ -9840,7 +9914,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) if (parens) /* hint to deparser that this: for my (...) ... */ loop->op_flags |= OPf_PARENS; - iter = newOP(OP_ITER, 0); + iter = newOP(OP_ITER, (U32)iterpflags << 8); iter->op_targ = how_many_more; return newWHILEOP(flags, 1, loop, iter, block, cont, 0); } diff --git a/pp_hot.c b/pp_hot.c index 4f1e54711f22d..b6042fad0498b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -4868,6 +4868,7 @@ PP(pp_iter) PERL_CONTEXT *cx = CX_CUR(); SV **itersvp = CxITERVAR(cx); const U8 type = CxTYPE(cx); + U8 pflags = PL_op->op_private; /* Classic "for" syntax iterates one-at-a-time. Many-at-a-time for loops are only for lexicals declared as part of the @@ -5014,7 +5015,7 @@ PP(pp_iter) case CXt_LOOP_LIST: /* for (1,2,3) */ assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */ - inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); + inc = (IV)1 - (IV)(pflags & OPpITER_REVERSED); ix = (cx->blk_loop.state_u.stack.ix += inc); if (UNLIKELY(inc > 0 ? ix > cx->blk_oldsp @@ -5036,7 +5037,7 @@ PP(pp_iter) case CXt_LOOP_ARY: /* for (@ary) */ av = cx->blk_loop.state_u.ary.ary; - inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); + inc = (IV)1 - (IV)(pflags & OPpITER_REVERSED); ix = (cx->blk_loop.state_u.ary.ix += inc); if (UNLIKELY(inc > 0 ? ix > AvFILL(av) @@ -5055,6 +5056,14 @@ PP(pp_iter) sv = AvARRAY(av)[ix]; } + if (UNLIKELY(pflags & OPpITER_INDEXED) && (i == 0)) { + SvREFCNT_dec(*itersvp); + *itersvp = newSViv(ix); + + ++i; + ++itersvp; + } + loop_ary_common: if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) { diff --git a/t/perf/opcount.t b/t/perf/opcount.t index 45f4bbcb991ae..ece5ec8ef9077 100644 --- a/t/perf/opcount.t +++ b/t/perf/opcount.t @@ -1011,4 +1011,13 @@ test_opcount(0, "Empty anonhash ref and direct lexical assignment", srefgen => 1, }); +test_opcount(0, "foreach 2 lexicals on builtin::indexed", + sub { my @input = (); foreach my ($i, $x) (builtin::indexed @input) { } }, + { + entersub => 0, # no call to builtin::indexed + enteriter => 1, + iter => 1, + padav => 2, + }); + done_testing();