Skip no-common-vars optimisation for aliases

The ‘no common vars’ optimisation allows perl to copy the values
straight from the rhs to the lhs in a list assignment.

In ($a,$b) = ($c,$d), that means $c gets assigned to $a,
then $d to $b.

If the same variable occurs on both sides of the expression
(($a,$b)=($b,$a)), then it is necessary to make temporary copies of
the variables on the rhs, before assigning them to the left.

If some variables have been aliased to others, then the common vars
detection can be fooled:

    *x = *y;
    $x = 3;
    ($x, $z) = (1, $y);

That assigns 1 to $x, and then goes to assign $y to $z, but $y is
the same as $x, which has just been clobbered.  So 1 gets assigned
instead of 3.

This commit solves this by recording in each typeglob whether the sca-
lar is an alias of a scalar from elsewhere.

If such a glob is encountered, then the entire expression is ‘tainted’
such that list assignments will assume there might be common vars.

diff --git a/embedvar.h b/embedvar.h
index d481681..adc207d 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -262,6 +262,7 @@
 #define PL_savestack           (vTHX->Isavestack)
 #define PL_savestack_ix                (vTHX->Isavestack_ix)
 #define PL_savestack_max       (vTHX->Isavestack_max)
+#define PL_sawalias            (vTHX->Isawalias)
 #ifndef PL_sawampersand
 #define PL_sawampersand                (vTHX->Isawampersand)
 #endif

diff --git a/gv.h b/gv.h
index 412adc0..2b29b6d 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -198,6 +198,12 @@ Return the CV from the GV.
 #define GvIMPORTED_CV_on(gv)   (GvFLAGS(gv) |= GVf_IMPORTED_CV)
 #define GvIMPORTED_CV_off(gv)  (GvFLAGS(gv) &= ~GVf_IMPORTED_CV)
 
+#define GPf_ALIASED_SV 1
+
+#define GvALIASED_SV(gv)       (GvGPFLAGS(gv) & GPf_ALIASED_SV)
+#define GvALIASED_SV_on(gv)    (GvGPFLAGS(gv) |= GPf_ALIASED_SV)
+#define GvALIASED_SV_off(gv)   (GvGPFLAGS(gv) &= ~GPf_ALIASED_SV)
+
 #ifndef PERL_CORE
 #  define GvIN_PAD(gv)         0
 #  define GvIN_PAD_on(gv)      NOOP

diff --git a/intrpvar.h b/intrpvar.h
index 57918b2..362d0cb 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -60,6 +60,9 @@ PERLVAR(I, markstack, I32 *)          /* stack_sp locations we're
 PERLVAR(I, markstack_ptr, I32 *)
 PERLVAR(I, markstack_max, I32 *)
 
+PERLVARI(I, sawalias,  bool,   FALSE)  /* must enable common-vars
+                                          pessimisation */
+
 #ifdef PERL_HASH_RANDOMIZE_KEYS
 #ifdef USE_PERL_PERTURB_KEYS
 PERLVARI(I, hash_rand_bits_enabled, U8, 1) /* used to randomize hash stuff 0 == no-random, 1 == random, 2 == determinsitic */

diff --git a/pp_hot.c b/pp_hot.c
index 97f24d8..8ff2578 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -47,6 +47,7 @@ PP(pp_const)
 PP(pp_nextstate)
 {
     PL_curcop = (COP*)PL_op;
+    PL_sawalias = 0;
     TAINT_NOT;         /* Each statement is presumed innocent */
     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
     FREETMPS;
@@ -62,6 +63,8 @@ PP(pp_gvsv)
        PUSHs(save_scalar(cGVOP_gv));
     else
        PUSHs(GvSVn(cGVOP_gv));
+    if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
+       PL_sawalias = TRUE;
     RETURN;
 }
 
@@ -92,6 +95,9 @@ PP(pp_gv)
 {
     dSP;
     XPUSHs(MUTABLE_SV(cGVOP_gv));
+    if (isGV(cGVOP_gv)
+     && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
+       PL_sawalias = TRUE;
     RETURN;
 }
 
@@ -1005,7 +1011,7 @@ PP(pp_aassign)
      * Don't bother if LHS is just an empty hash or array.
      */
 
-    if (    (PL_op->op_private & OPpASSIGN_COMMON)
+    if (    (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
        &&  (
               firstlelem != lastlelem
            || ! ((sv = *firstlelem))

diff --git a/scope.c b/scope.c
index db67656..a9c73a4 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -1226,6 +1226,22 @@ Perl_leave_scope(pTHX_ I32 base)
        case SAVEt_READONLY_OFF:
            SvREADONLY_off(ARG0_SV);
            break;
+       case SAVEt_GP_ALIASED_SV: {
+           /* The GP may have been abandoned, leaving the savestack with
+              the only remaining reference to it.  */
+           GP * const gp = (GP *)ARG0_PTR;
+           if (gp->gp_refcnt == 1) {
+               GV * const gv = (GV *)sv_2mortal(newSV_type(SVt_PVGV));
+               GvGP_set(gv,gp);
+               gp_free(gv);
+           }
+           else {
+               gp->gp_refcnt--;
+               if (uv >> 8) gp->gp_flags |=  GPf_ALIASED_SV;
+               else         gp->gp_flags &= ~GPf_ALIASED_SV;
+           }
+           break;
+       }
        default:
            Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
        }

diff --git a/scope.h b/scope.h
index 0dce9d6..cad02cd 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -16,12 +16,12 @@
 #define SAVEt_CLEARPADRANGE    1
 #define SAVEt_CLEARSV          2
 #define SAVEt_REGCONTEXT       3
-/*** SPARE                     4 ***/
 
-#define SAVEt_ARG0_MAX         4
+#define SAVEt_ARG0_MAX         3
 
 /* one arg */
 
+#define SAVEt_GP_ALIASED_SV    4
 #define SAVEt_BOOL             5
 #define SAVEt_COMPILE_WARNINGS 6
 #define SAVEt_COMPPAD          7

diff --git a/sv.c b/sv.c
index 9723d3c..9df01b7 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4027,6 +4027,22 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
            && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
            GvFLAGS(dstr) |= import_flag;
        }
+       if (import_flag == GVf_IMPORTED_SV) {
+           if (intro) {
+               dSS_ADD;
+               SS_ADD_PTR(gp_ref(GvGP(dstr)));
+               SS_ADD_UV(SAVEt_GP_ALIASED_SV
+                       | cBOOL(GvALIASED_SV(dstr)) << 8);
+               SS_ADD_END(2);
+           }
+           /* Turn off the flag if sref is not referenced elsewhere,
+              even by weak refs.  (SvRMAGICAL is a pessimistic check for
+              back refs.)  */
+           if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
+               GvALIASED_SV_off(dstr);
+           else
+               GvALIASED_SV_on(dstr);
+       }
        if (stype == SVt_PVHV) {
            const char * const name = GvNAME((GV*)dstr);
            const STRLEN len = GvNAMELEN(dstr);
@@ -13896,6 +13912,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
            ptr = POPPTR(ss,ix);
            TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
            break;
+        case SAVEt_GP_ALIASED_SV:
+           ptr = POPPTR(ss,ix);
+           TOPPTR(nss,ix) = gp_dup((GP *)ptr, param);
+           ((GP *)ptr)->gp_refcnt++;
+           break;
        default:
            Perl_croak(aTHX_
                       "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
@@ -14125,6 +14146,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_minus_F         = proto_perl->Iminus_F;
     PL_doswitches      = proto_perl->Idoswitches;
     PL_dowarn          = proto_perl->Idowarn;
+    PL_sawalias                = proto_perl->Isawalias;
 #ifdef PERL_SAWAMPERSAND
     PL_sawampersand    = proto_perl->Isawampersand;
 #endif

diff --git a/t/op/gv.t b/t/op/gv.t
index 4c8c79d..081d280 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 
 use warnings;
 
-plan( tests => 270 );
+plan( tests => 271 );
 
 # type coercion on assignment
 $foo = 'foo';
@@ -1111,6 +1111,15 @@ undef $::{_119051again};   # CvGV, it still gets a fake one
 eval { $y->() };
 pass "No crash due to CvGV pointing to glob copy in the stash";
 
+# Aliasing should disable no-common-vars optimisation.
+{
+    *x = *y;
+    $x = 3;
+    ($x, my $z) = (1, $y);
+    is $z, 3, 'list assignment after aliasing [perl #89646]';
+}
+
+
 __END__
 Perl
 Rules