fix common assign issue on @a = (split(), 1)

RT #127999 Slowdown in split + list assign

The compile-time common-value detection mechanism for OP_ASSIGN
was getting OP_SPLIT wrong.

It was assuming that OP_SPLIT was always dangerous. In fact,
OP_SPLIT is usually completely safe, not passing though any of its
arguments, except where the assign in (@a = split()) has been optimised
away and the array attached directly to the OP_SPLIT op, or the ops that
produce the array have been appended as an extra child of the OP_SPLIT op
(OPf_STACKED).

diff --git a/op.c b/op.c
index d6d7a84..613c8bf 100644 (file)
--- a/op.c
+++ b/op.c
@@ -12520,6 +12520,7 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
     case OP_PADAV:
     case OP_PADHV:
         (*scalars_p) += 2;
+        /* if !top, could be e.g. @a[0,1] */
         if (top && (o->op_flags & OPf_REF))
             return (o->op_private & OPpLVAL_INTRO)
                 ? AAS_MY_AGG : AAS_LEX_AGG;
@@ -12540,6 +12541,7 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
         if (cUNOPx(o)->op_first->op_type != OP_GV)
             return AAS_DANGEROUS; /* @{expr}, %{expr} */
         /* @pkg, %pkg */
+        /* if !top, could be e.g. @a[0,1] */
         if (top && (o->op_flags & OPf_REF))
             return AAS_PKG_AGG;
         return AAS_DANGEROUS;
@@ -12553,17 +12555,32 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
         return AAS_PKG_SCALAR; /* $pkg */
 
     case OP_SPLIT:
-        if (1) { /* XXX this condition is wrong - fix later
-        if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
-        */
-            /* "@foo = split... " optimises away the aassign and stores its
-             * destination array in the OP_PUSHRE that precedes it.
-             * A flattened array is always dangerous.
+        if (o->op_private & OPpSPLIT_ASSIGN) {
+            /* the assign in @a = split() has been optimised away
+             * and the @a attached directly to the split op
+             * Treat the array as appearing on the RHS, i.e.
+             *    ... = (@a = split)
+             * is treated like
+             *    ... = @a;
              */
+
+            if (o->op_flags & OPf_STACKED)
+                /* @{expr} = split() - the array expression is tacked
+                 * on as an extra child to split - process kid */
+                return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
+                                        top, scalars_p);
+
+            /* ... else array is directly attached to split op */
             (*scalars_p) += 2;
-            return AAS_DANGEROUS;
+            if (PL_op->op_private & OPpSPLIT_LEX)
+                return (o->op_private & OPpLVAL_INTRO)
+                    ? AAS_MY_AGG : AAS_LEX_AGG;
+            else
+                return AAS_PKG_AGG;
         }
-        break;
+        (*scalars_p)++;
+        /* other args of split can't be returned */
+        return AAS_SAFE_SCALAR;
 
     case OP_UNDEF:
         /* undef counts as a scalar on the RHS:

diff --git a/t/perf/benchmarks b/t/perf/benchmarks
index f02a06a..56987bc 100644 (file)
--- a/t/perf/benchmarks
+++ b/t/perf/benchmarks
@@ -993,6 +993,11 @@
         setup   => 'my $s = "abc:def"; my $r = []',
         code    => '@$r = split /:/, $s, 2;',
     },
+    'func::split::arraylist' => {
+        desc    => 'split into an array with extra arg',
+        setup   => 'my @a; my $s = "abc:def";',
+        code    => '@a = (split(/:/, $s, 2), 1);',
+    },
 
 
     'loop::block' => {

diff --git a/t/perf/optree.t b/t/perf/optree.t
index a2ff7f2..49959ce 100644 (file)
--- a/t/perf/optree.t
+++ b/t/perf/optree.t
@@ -10,7 +10,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-plan 54;
+plan 59;
 
 use v5.10; # state
 use B qw(svref_2object
@@ -74,6 +74,11 @@ for my $test (
     [ "---", '(undef,$x) = f()', 'single scalar on LHS' ],
     [ "---", '($x,$y) = ($x)', 'single scalar on RHS, no AGG' ],
     [ "--A", '($x,@b) = ($x)', 'single scalar on RHS' ],
+    [ "--A", 'my @a; @a = (@a = split())',      'split a/a'   ],
+    [ "--A", 'my (@a,@b); @a = (@b = split())', 'split a/b'   ],
+    [ "---", 'my @a; @a = (split(), 1)',        '(split(),1)' ],
+    [ "---", '@a = (split(//, @a), 1)',         'split(@a)'   ],
+    [ "--A", 'my @a; my $ar = @a; @a = (@$ar = split())', 'a/ar split'  ],
 ) {
     my ($exp, $code, $desc) = @$test;
     my $sub = eval "sub { $code }"