From d24e3eb1402c1294265f99342e2ec0ecfd0f5d34 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Tue, 22 Nov 2016 16:41:54 +0000
Subject: [PATCH] avoid premature free of referent in list assign

RT #130132

My recent commit v5.25.6-266-ga083329 made it so that perl could
sometimes avoid mortalising the referent when assigning to a reference
(e.g. for $ref1 = $ref2, where $$ref1 has a ref count of 1).

Unfortunately it turns out that list assign relied on this behaviour
to avoid premature freeing, e.g.

    ($ref1, $x) = ($y, $$ref1);

where $$ref1 needs to continue to live for at least the rest of the
assign.

This commit fixes it by mortalising the referent in pp_assign when
required.
---
 op.c              | 16 ++++++++++++++++
 pp_hot.c          | 20 ++++++++++++++++++++
 t/op/aassign.t    | 34 ++++++++++++++++++++++++++++++++++
 t/perf/benchmarks | 13 +++++++++++++
 4 files changed, 83 insertions(+)

diff --git a/op.c b/op.c
index 9724ff0..3cd7ea2 100644
--- a/op.c
+++ b/op.c
@@ -12635,6 +12635,11 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
         break;
     }
 
+    /* XXX this assumes that all other ops are "transparent" - i.e. that
+     * they can return some of their children. While this true for e.g.
+     * sort and grep, it's not true for e.g. map. We really need a
+     * 'transparent' flag added to regen/opcodes
+     */
     if (o->op_flags & OPf_KIDS) {
         OP *kid;
         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
@@ -14605,6 +14610,17 @@ Perl_rpeep(pTHX_ OP *o)
                         NOOP;
                     }
                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
+                        /* if there are only lexicals on the LHS and no
+                         * common ones on the RHS, then we assume that the
+                         * only way those lexicals could also get
+                         * on the RHS is via some sort of dereffing or
+                         * closure, e.g.
+                         *    $r = \$lex;
+                         *    ($lex, $x) = (1, $$r)
+                         * and in this case we assume the var must have
+                         *  a bumped ref count. So if its ref count is 1,
+                         *  it must only be on the LHS.
+                         */
                         o->op_private |= OPpASSIGN_COMMON_RC1;
                 }
             }
diff --git a/pp_hot.c b/pp_hot.c
index 7db8cbe..c614d29 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1708,6 +1708,8 @@ PP(pp_aassign)
 
 	default:
 	    if (!SvIMMORTAL(lsv)) {
+                SV *ref;
+
                 if (UNLIKELY(
                   SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
                   (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
@@ -1716,6 +1718,24 @@ PP(pp_aassign)
                        packWARN(WARN_MISC),
                       "Useless assignment to a temporary"
                     );
+
+                /* avoid freeing $$lsv if it might be needed for further
+                 * elements, e.g. ($ref, $foo) = (1, $$ref) */
+                if (   SvROK(lsv)
+                    && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
+                    && lelem <= lastlelem
+                ) {
+                    SSize_t ix;
+                    SvREFCNT_inc_simple_void_NN(ref);
+                    /* an unrolled sv_2mortal */
+                    ix = ++PL_tmps_ix;
+                    if (UNLIKELY(ix >= PL_tmps_max))
+                        /* speculatively grow enough to cover other
+                         * possible refs */
+                        ix = tmps_grow_p(ix + (lastlelem - lelem));
+                    PL_tmps_stack[ix] = ref;
+                }
+
                 sv_setsv(lsv, *relem);
                 *relem = lsv;
                 SvSETMAGIC(lsv);
diff --git a/t/op/aassign.t b/t/op/aassign.t
index e789210..b8025cf 100644
--- a/t/op/aassign.t
+++ b/t/op/aassign.t
@@ -559,5 +559,39 @@ SKIP: {
     like($@, qr//, "RT #129991");
 }
 
+{
+    # [perl #130132]
+    # lexical refs on LHS, dereffed on the RHS
+
+    my $fill;
+
+    my $sref = do { my $tmp = 2; \$tmp };
+    ($sref, $fill) = (1, $$sref);
+    is ($sref, 1, "RT #130132 scalar 1");
+    is ($fill, 2, "RT #130132 scalar 2");
+
+    my $x = 1;
+    $sref = \$x;
+    ($sref, $$sref) = (2, 3);
+    is ($sref, 2, "RT #130132 scalar derefffed 1");
+    is ($x,    3, "RT #130132 scalar derefffed 2");
+
+    $x = 1;
+    $sref = \$x;
+    ($sref, $$sref) = (2);
+    is ($sref, 2,     "RT #130132 scalar undef 1");
+    is ($x,    undef, "RT #130132 scalar undef 2");
+
+    my @a;
+    $sref = do { my $tmp = 2; \$tmp };
+    @a = (($sref) = (1, $$sref));
+    is ($sref, 1,     "RT #130132 scalar list cxt 1");
+    is ($a[0], 1,     "RT #130132 scalar list cxt a[0]");
+
+    my $aref = [ 1, 2 ];
+    ($aref, $fill) = @$aref;
+    is ($aref, 1, "RT #130132 array 1");
+    is ($fill, 2, "RT #130132 array 2");
+}
 
 done_testing();
diff --git a/t/perf/benchmarks b/t/perf/benchmarks
index 8306b1f..6386f47 100644
--- a/t/perf/benchmarks
+++ b/t/perf/benchmarks
@@ -694,6 +694,19 @@
         code    => '($x, $y) = (1, 2)',
     },
 
+    'expr::aassign::lex_rv' => {
+        desc    => 'lexical ($ref1, $ref2) = ($ref3, $ref4)',
+        setup   => 'my ($r1, $r2, $r3, $r4);
+                    ($r1, $r2) = (($r3, $r4) = ([],  []));',
+        code    => '($r1, $r2) = ($r3, $r4)',
+    },
+
+    'expr::aassign::lex_rv1' => {
+        desc    => 'lexical ($ref1, $ref2) = ($ref3, $ref4) where ref1,2 are freed',
+        setup   => 'my ($r1, $r2);',
+        code    => '($r1, $r2) = ([], []);',
+    },
+
     # array assign of strings
 
     'expr::aassign::la_3s' => {
-- 
1.8.3.1