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.

builtin.c

@@ -490,9 +490,13 @@ static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
     }
 }
 
-XS(XS_builtin_indexed)
+/* This does not use the XS() macro so that op.c can see its prototype */
+void
+Perl_XS_builtin_indexed(pTHX_ CV *cv)
 {
     dXSARGS;
+    PERL_ARGS_ASSERT_XS_BUILTIN_INDEXED;
+    PERL_UNUSED_VAR(cv);
 
     switch(GIMME_V) {
         case G_VOID:
@@ -638,7 +642,7 @@ static const struct BuiltinFuncDescriptor builtins[] = {
     { "load_module", NO_BUNDLE, &XS_builtin_load_module, &ck_builtin_func1, 0, true },
 
     /* list functions */
-    { "indexed",          SHORTVER(5,39), &XS_builtin_indexed,          &ck_builtin_funcN, 0, false },
+    { "indexed",          SHORTVER(5,39), &Perl_XS_builtin_indexed,     &ck_builtin_funcN, 0, false },
     { "export_lexically",      NO_BUNDLE, &XS_builtin_export_lexically, NULL,              0, true },
 
     { NULL, 0, NULL, NULL, 0, false }

embed.fnc

@@ -4127,6 +4127,8 @@ p	|void	|finish_export_lexical
 p	|void	|import_builtin_bundle					\
 				|U16 ver
 p	|void	|prepare_export_lexical
+p	|void	|XS_builtin_indexed					\
+				|NN CV *cv
 #endif
 #if defined(PERL_IN_CLASS_C) || defined(PERL_IN_OP_C)    || \
     defined(PERL_IN_PAD_C)   || defined(PERL_IN_PERLY_C) || \

embed.h

@@ -1211,6 +1211,7 @@
 #     define get_aux_mg(a)                      S_get_aux_mg(aTHX_ a)
 #   endif
 #   if defined(PERL_IN_BUILTIN_C) || defined(PERL_IN_OP_C)
+#     define XS_builtin_indexed(a)              Perl_XS_builtin_indexed(aTHX_ a)
 #     define finish_export_lexical()            Perl_finish_export_lexical(aTHX)
 #     define import_builtin_bundle(a)           Perl_import_builtin_bundle(aTHX_ a)
 #     define prepare_export_lexical()           Perl_prepare_export_lexical(aTHX)

lib/B/Deparse.pm

@@ -7,7 +7,7 @@
 # This is based on the module of the same name by Malcolm Beattie,
 # but essentially none of his code remains.
 
-package B::Deparse 1.79;
+package B::Deparse 1.80;
 use strict;
 use Carp;
 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
@@ -66,7 +66,8 @@ BEGIN {
     # List version-specific constants here.
     # Easiest way to keep this code portable between version looks to
     # be to fake up a dummy constant that will never actually be true.
-    foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
+    foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_INDEXED
+		OPpITER_REVERSED OPpCONST_NOVER
 		OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
 		PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST
 		CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
@@ -4018,6 +4019,7 @@ sub loop_common {
     } elsif ($enter->name eq "enteriter") { # foreach
 	my $ary = $enter->first->sibling; # first was pushmark
 	my $var = $ary->sibling;
+	my $iter = $kid->first->first;
 	if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
 	    # "reverse" was optimised away
 	    $ary = listop($self, $ary->first->sibling, 1, 'reverse');
@@ -4030,6 +4032,10 @@ sub loop_common {
 	    $ary = $self->deparse($ary, 1);
 	}
 
+	if ($iter->private & OPpITER_INDEXED) {
+	    $ary = "builtin::indexed $ary";
+	}
+
         if ($enter->flags & OPf_PARENS) {
             # for my ($x, $y, ...) ...
             # for my ($foo, $bar) () stores the count (less 1) in the targ of
@@ -4057,7 +4063,7 @@ sub loop_common {
 	} else {
 	    $var = $self->deparse($var, 1);
 	}
-	$body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+	$body = $iter->sibling;
 	if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
 	    confess unless $var eq '$_';
 	    $body = $body->first;

lib/B/Deparse.t

@@ -2610,6 +2610,11 @@ foreach my ($key, $value) (%hash) {
     study $_;
 }
 ####
+my @arr;
+foreach my ($idx, $elem) (builtin::indexed @arr) {
+    die;
+}
+####
 my @ducks;
 foreach my ($tick, $trick, $track) (@ducks) {
     study $_;

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

@@ -9631,6 +9631,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 +9696,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 +9808,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, &Perl_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 +9874,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 +9911,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);
 }