pessimise pp_argelem, pp_argdefelem
authorDavid Mitchell <davem@iabyn.com>
Thu, 28 Jul 2016 09:18:26 +0000 (10:18 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 3 Aug 2016 19:54:41 +0000 (20:54 +0100)
These two ops assumed that, since they occur at the start of a
function, weird tricks with goto and closures can't be used to
cause the new lexical vars to already have a value, so the assign code
can be simpler and quicker than that found in pp_sassign and pp_aassign.

However Father Chrysostomos demonstrated that this wasn't the case,
using e.g. code that does strange things in signature default expressions.

In particular we can not assume:

    * that scalar lexicals will be undef
    * that array and hash lexicals will be empty
    * that lexicals and @_ can't be magical or tied;
    * that @_ remains unchanged (especially in relation to its number of
      elements)
    * that there are no common elements, since with aliases and closures,
      my @a = @_ can be equivalent to my @a = (...); @a = ($a_[0],...)

So this commit removes the short-cuts, and for aggregates, if the
new lexical array or hash may be non-empty, makes a copy of each @_
element first.

It is intended in the near future that normal runs of OP_ARGELEM
will be replaced by OP_SIGNATURE, which will be able to do a better job of
knowing when its safe to optimise.

pp.c
t/op/signatures.t

diff --git a/pp.c b/pp.c
index a403693..336122a 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -6628,10 +6628,6 @@ PP(pp_anonconst)
  * or
  *    my @foo = @_[N..$#_]
  * etc
- *
- * It assumes that the pad var is currently uninitialised, so this op
- * should only be used at the start of a sub, where its not possible to
- * skip the op (e.g. no 'my $x if $cond' stuff for example).
  */
 
 PP(pp_argelem)
@@ -6643,9 +6639,6 @@ PP(pp_argelem)
     AV *defav = GvAV(PL_defgv); /* @_ */
     IV ix = PTR2IV(cUNOP_AUXo->op_aux);
     IV argc;
-    SV **argv;
-
-    assert(!SvMAGICAL(defav));
 
     /* do 'my $var, @var or %var' action */
     padentry = &(PAD_SVl(o->op_targ));
@@ -6659,14 +6652,15 @@ PP(pp_argelem)
             PUTBACK;
         }
         else {
+            SV **svp;
             /* should already have been checked */
+            assert(ix >= 0);
 #if IVSIZE > PTRSIZE
             assert(ix <= SSize_t_MAX);
 #endif
-            assert(ix >=0 && ix <= AvFILLp(defav));
-            val = AvARRAY(defav)[ix];
-            if (UNLIKELY(!val))
-                val = &PL_sv_undef;
+
+            svp = av_fetch(defav, ix, FALSE);
+            val = svp ? *svp : &PL_sv_undef;
         }
 
         /* $var = $val */
@@ -6676,81 +6670,91 @@ PP(pp_argelem)
         if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
             TAINT_NOT;
 
-        /* Short-cut assignment of IV and RV values as these are
-         * common and simple. For RVs, it's likely that on
-         * subsequent calls to a function, targ is already of the
-         * correct storage class */
-        if (LIKELY(!SvMAGICAL(val))) {
-            /* just an IV */
-            if ((SvFLAGS(val) & (SVf_IOK|SVf_NOK|SVf_POK|SVf_IVisUV)) == SVf_IOK) {
-                IV i = SvIVX(val);
-                if (LIKELY(SvTYPE(targ) == SVt_IV)) {
-                    assert(!SvOK(targ));
-                    assert(!SvMAGICAL(targ));
-                    (void)SvIOK_only(targ);
-                    SvIV_set(targ, i);
-                }
-                else
-                    sv_setiv(targ, i);
-            }
-            else if (SvROK(val) && SvTYPE(targ) == SVt_IV) {
-                /* quick ref assignment */
-                assert(!SvOK(targ));
-                SvRV_set(targ, SvREFCNT_inc(SvRV(val)));
-                SvROK_on(targ);
-            }
-            else
-                sv_setsv(targ, val);
-        }
-        else
-            sv_setsv(targ, val);
+        SvSetMagicSV(targ, val);
         return o->op_next;
     }
 
     /* must be AV or HV */
 
     assert(!(o->op_flags & OPf_STACKED));
-    argc = ((IV)AvFILLp(defav) + 1) - ix;
-    assert(!SvMAGICAL(targ));
-    if (argc <= 0)
-        return o->op_next;
-    argv = AvARRAY(defav) + ix;
-    assert(argv);
+    argc = ((IV)AvFILL(defav) + 1) - ix;
 
     /* This is a copy of the relevant parts of pp_aassign().
-     * We *know* that @foo / %foo is a plain empty lexical at this point,
-     * so we can avoid a lot of the extra baggage.
-     * We know, because all the usual tricks like 'my @a if 0',
-     * 'foo: my @a = ...; goto foo' can't be done with signatures.
      */
     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
-        UV i = 0;
+        IV i;
+
+        if (AvFILL((AV*)targ) > -1) {
+            /* target should usually be empty. If we get get
+             * here, someone's been doing some weird closure tricks.
+             * Make a copy of all args before clearing the array,
+             * to avoid the equivalent of @a = ($a[0]) prematurely freeing
+             * elements. See similar code in pp_aassign.
+             */
+            for (i = 0; i < argc; i++) {
+                SV **svp = av_fetch(defav, ix + i, FALSE);
+                SV *newsv = newSV(0);
+                sv_setsv_flags(newsv,
+                                svp ? *svp : &PL_sv_undef,
+                                (SV_DO_COW_SVSETSV|SV_NOSTEAL));
+                if (!av_store(defav, ix + i, newsv))
+                    SvREFCNT_dec_NN(newsv);
+            }
+            av_clear((AV*)targ);
+        }
+
+        if (argc <= 0)
+            return o->op_next;
 
-        assert(AvFILLp((AV*)targ) == -1); /* can skip av_clear() */
         av_extend((AV*)targ, argc);
 
+        i = 0;
         while (argc--) {
             SV *tmpsv;
-            SV *arg = *argv++;
+            SV **svp = av_fetch(defav, ix + i, FALSE);
+            SV *val = svp ? *svp : &PL_sv_undef;
             tmpsv = newSV(0);
-            sv_setsv(tmpsv, arg);
+            sv_setsv(tmpsv, val);
             av_store((AV*)targ, i++, tmpsv);
             TAINT_NOT;
         }
 
     }
     else {
+        IV i;
+
         assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
 
+        if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
+            /* see "target should usually be empty" comment above */
+            for (i = 0; i < argc; i++) {
+                SV **svp = av_fetch(defav, ix + i, FALSE);
+                SV *newsv = newSV(0);
+                sv_setsv_flags(newsv,
+                                svp ? *svp : &PL_sv_undef,
+                                (SV_DO_COW_SVSETSV|SV_NOSTEAL));
+                if (!av_store(defav, ix + i, newsv))
+                    SvREFCNT_dec_NN(newsv);
+            }
+            hv_clear((HV*)targ);
+        }
+
+        if (argc <= 0)
+            return o->op_next;
         assert(argc % 2 == 0);
-        assert(!HvTOTALKEYS(targ)); /* can skip hv_clear() */
 
+        i = 0;
         while (argc) {
             SV *tmpsv;
-            SV *key = *argv++;
-            SV *val = *argv++;
+            SV **svp;
+            SV *key;
+            SV *val;
+
+            svp = av_fetch(defav, ix + i++, FALSE);
+            key = svp ? *svp : &PL_sv_undef;
+            svp = av_fetch(defav, ix + i++, FALSE);
+            val = svp ? *svp : &PL_sv_undef;
 
-            assert(key); assert(val);
             argc -= 2;
             if (UNLIKELY(SvGMAGICAL(key)))
                 key = sv_mortalcopy(key);
@@ -6781,14 +6785,16 @@ PP(pp_argdefelem)
     AV *defav = GvAV(PL_defgv); /* @_ */
     IV ix = (IV)o->op_targ;
 
-    assert(!SvMAGICAL(defav));
+    assert(ix >= 0);
 #if IVSIZE > PTRSIZE
     assert(ix <= SSize_t_MAX);
 #endif
-    assert(ix >= 0);
-    if (AvFILLp(defav) >= ix) {
+
+    if (AvFILL(defav) >= ix) {
         dSP;
-        XPUSHs(AvARRAY(defav)[ix]);
+        SV **svp = av_fetch(defav, ix, FALSE);
+        SV  *val = svp ? *svp : &PL_sv_undef;
+        XPUSHs(val);
         RETURN;
     }
     return cLOGOPo->op_other;
index f5c4dc1..27b7ead 100644 (file)
@@ -1314,6 +1314,151 @@ is scalar(t145()), undef;
     is ($want, "scalar", "default expression is scalar in list context");
 }
 
+
+# check for default arg code doing nasty things (closures, gotos,
+# modifying @_ etc).
+
+{
+    no warnings qw(closure);
+    use Tie::Array;
+    use Tie::Hash;
+
+    sub t146 ($a = t146x()) {
+        sub t146x { $a = "abc"; 1 }
+        $a;
+    }
+    is t146(), 1, "t146: closure can make new lexical not undef";
+
+    sub t147 ($a = t147x()) {
+        sub t147x { $a = "abc"; pos($a)=1; 1 }
+        is pos($a), undef, "t147: pos magic cleared";
+        $a;
+    }
+    is t147(), 1, "t147: closure can make new lexical not undef and magical";
+
+    sub t148 ($a = t148x()) {
+        sub t148x { $a = [];  1 }
+        $a;
+    }
+    is t148(), 1, "t148: closure can make new lexical a ref";
+
+    sub t149 ($a = t149x()) {
+        sub t149x { $a = 1;  [] }
+        $a;
+    }
+    is ref(t149()), "ARRAY", "t149: closure can make new lexical a ref";
+
+    sub t150 ($a = do {@_ = qw(a b c); 1}, $b = 2) {
+        is $a, 1,   "t150: a: growing \@_";
+        is $b, "b", "t150: b: growing \@_";
+    }
+    t150();
+
+
+    sub t151 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, $b = 2) {
+        is $a, 1,   "t151: a: tied \@_";
+        is $b, "b", "t151: b: tied \@_";
+    }
+    t151();
+
+    sub t152 ($a = t152x(), @b) {
+        sub t152x { @b = qw(a b c); 1 }
+        $a . '-' . join(':', @b);
+    }
+    is t152(), "1-", "t152: closure can make new lexical array non-empty";
+
+    sub t153 ($a = t153x(), %b) {
+        sub t153x { %b = qw(a 10 b 20); 1 }
+        $a . '-' . join(':', sort %b);
+    }
+    is t153(), "1-", "t153: closure can make new lexical hash non-empty";
+
+    sub t154 ($a = t154x(), @b) {
+        sub t154x { tie @b, 'Tie::StdArray'; @b = qw(a b c); 1 }
+        $a . '-' . join(':', @b);
+    }
+    is t154(), "1-", "t154: closure can make new lexical array tied";
+
+    sub t155 ($a = t155x(), %b) {
+        sub t155x { tie %b, 'Tie::StdHash'; %b = qw(a 10 b 20); 1 }
+        $a . '-' . join(':', sort %b);
+    }
+    is t155(), "1-", "t155: closure can make new lexical hash tied";
+
+    sub t156 ($a = do {@_ = qw(a b c); 1}, @b) {
+        is $a, 1,       "t156: a: growing \@_";
+        is "@b", "b c", "t156: b: growing \@_";
+    }
+    t156();
+
+    sub t157 ($a = do {@_ = qw(a b c); 1}, %b) {
+        is $a, 1,                     "t157: a: growing \@_";
+        is join(':', sort %b), "b:c", "t157: b: growing \@_";
+    }
+    t157();
+
+    sub t158 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, @b) {
+        is $a, 1,          "t158: a: tied \@_";
+        is "@b", "b c",    "t158: b: tied \@_";
+    }
+    t158();
+
+    sub t159 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, %b) {
+        is  $a, 1,                     "t159: a: tied \@_";
+        is  join(':', sort %b), "b:c", "t159: b: tied \@_";
+    }
+    t159();
+
+    # see if we can handle the equivalent of @a = ($a[1], $a[0])
+
+    sub t160 ($s, @a) {
+        sub t160x {
+            @a = qw(x y);
+            t160(1, $a[1], $a[0]);
+        }
+        # encourage recently-freed SVPVs to be realloced with new values
+        my @pad = qw(a b);
+        join ':', $s, @a;
+    }
+    is t160x(), "1:y:x", 'handle commonality in slurpy array';
+
+    # see if we can handle the equivalent of %h = ('foo', $h{foo})
+
+    sub t161 ($s, %h) {
+        sub t161x {
+            %h = qw(k1 v1 k2 v2);
+            t161(1, k1 => $h{k2}, k2 => $h{k1});
+        }
+        # encourage recently-freed SVPVs to be realloced with new values
+        my @pad = qw(a b);
+        join ' ', $s, map "($_,$h{$_})", sort keys %h;
+    }
+    is t161x(), "1 (k1,v2) (k2,v1)", 'handle commonality in slurpy hash';
+
+    # see if we can handle the equivalent of ($a,$b) = ($b,$a)
+    # Note that for non-signatured subs, my ($a,$b) = @_ already fails the
+    # equivalent of this test too, since I skipped pessimising it
+    # (90ce4d057857) as commonality in this case is rare and contrived,
+    # as the example below shows. DAPM.
+    sub t162 ($a, $b) {
+        sub t162x {
+            ($a, $b) = qw(x y);
+            t162($b, $a);
+        }
+        "$a:$b";
+    }
+    {
+        local $TODO = q{can't handle commonaility};
+        is t162x(), "y:x", 'handle commonality in scalar parms';
+    }
+
+
+
+
+}
+
+
+
 use File::Spec::Functions;
 my $keywords_file = catfile(updir,'regen','keywords.pl');
 open my $kh, $keywords_file