Optimise foreach on a list from builtin::indexed @array into two lexi…

…cals

Rather than generating an entire temporary list that is twice as big as
the original array, instead set a flag on the `OP_ITER` that tells it to
set one of the iteration variables to the current array index and use
the same `CXt_LOOP_ARY` optimisation that regular foreach over an array
would use.

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 );

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);
 }

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)) {

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();