develooper Front page | perl.perl5.changes | Postings from February 2019

[perl.git] branch blead updated. v5.29.7-71-g9730c47616

From:
Dave Mitchell
Date:
February 5, 2019 14:12
Subject:
[perl.git] branch blead updated. v5.29.7-71-g9730c47616
Message ID:
E1gr1SX-0000dO-Vn@git.dc.perl.space
In perl.git, the branch blead has been updated

<https://perl5.git.perl.org/perl.git/commitdiff/9730c47616258ce7e7ec58cb5e16a1800bb5099b?hp=35c1827fadfaf0a26b8d1373f06ee242ee79c111>

- Log -----------------------------------------------------------------
commit 9730c47616258ce7e7ec58cb5e16a1800bb5099b
Merge: 35c1827fad 4e521aaf3e
Author: David Mitchell <davem@iabyn.com>
Date:   Tue Feb 5 14:04:32 2019 +0000

    [MERGE] various overload fixups
    
    This branch contains several commits which simplify the code concerning
    the processing of a value returned by an overload method, and
    specifically whether that value should be returned as-is by the op, or
    assigned to the targ / stack value: $lex = x op y) and (x op= y)
    respectively.
    
    The final commit fixes a bug in pp_multiconcat. That op bypasses most of
    the code in those earlier commits and "rolls it's own", and which was
    getting the set/assign decision wrong in some cases, causing a leak.

commit 4e521aaf3ed717774455b3906bd5aa46bc397319
Author: David Mitchell <davem@iabyn.com>
Date:   Tue Feb 5 13:48:21 2019 +0000

    Avoid leak in multiconcat with overloading.
    
    RT #133789
    
    In the path taken through pp_multiconcat() when one or more args have
    side-effects such tieing or overloading, multiconcat has to decide
    whether to just return the result of all the concatting as-is, or to
    first assign it to an expression or variable if the op includes an
    implicit assign (such as $lex = x.y.z or $a[0] = x.y.z).
    
    The code was getting this right for those two cases, and was also
    getting it right for the append cases ($lex .= x.y.z and $a[0] .= x.y.z),
    which don't need assigns. But for the bare case (x.y.z) it was assigning
    to the op's targ as well as returning the value. Hence leaking a
    reference until destruction of the sub and its pad.
    
    This commit stops the assign in that last case.

commit 13874762cb298e7f922df49e6c78fd3f2308d860
Author: David Mitchell <davem@iabyn.com>
Date:   Mon Feb 4 15:17:02 2019 +0000

    Perl_try_amagic_un/bin re-indent
    
    After the previous commit's simplification, eliminate a set of braces and
    re-indent a block of code.

commit 0872de45fff4b1f6c17e1d5bec82d3d5095801a2
Author: David Mitchell <davem@iabyn.com>
Date:   Mon Feb 4 15:07:11 2019 +0000

    Eliminate AMGf_set flag
    
    I added this flag a few years ago when I revamped the overload macros
    tryAMAGICbin() etc. It allowed two different classes of macros to
    share the same functions (Perl_try_amagic_un/Perl_try_amagic_bin)
    by indicating what type of action is required.
    
    However, the last few commits have made those two functions able to
    robustly always determine whether its an assign-type action
    ($x op= $y or  $lex = $x op $x) or a plain set-result-on-stack operation
    ($x op $y).
    
    So eliminate this flag.
    
    Note that this makes the ops which have the AMGf_set flag hard-coded
    infinitesimally slower, since Perl_try_amagic_bin no longer skips the
    checks for assign-ness. But compared with the overhead of having
    already called the overload method, this is is trivial.
    
    On the plus side, it makes the code smaller and easier to understand.

commit 9b2983ca78e5369d17559ca0aa5af58e9da3724a
Author: David Mitchell <davem@iabyn.com>
Date:   Mon Feb 4 14:52:01 2019 +0000

    Perl_try_amagic_bin(): eliminate dATARGET
    
    .. and replace with explicit tests and assigns to targ.
    
    This macro includes an OPf_STACKED test which has already been done
    above.  Also, by protecting the OPf_STACKED test within a AMGf_assign
    test, we can eliminate the AMGf_set flag in the next commit, and use the
    same set of code for both AMGf_set and AMGf_assign variant calls to
    Perl_try_amagic_bin().

commit 7554d34485b417b08875137130152d0168feefa8
Author: David Mitchell <davem@iabyn.com>
Date:   Mon Feb 4 14:11:13 2019 +0000

    Eliminate SvPADMY tests from overload code
    
    A couple of places in the overload code do  SvPADMY(TARG) to decide
    whether this is a normal op like ($x op $y), where the targ will have
    SVs_PADTMP set, or a lexical assignment like $lex = ($x op $y) where the
    assign has been optimised away and the op is expected to directly assign
    to the targ which it thinks is a PADTMP but is really $lex.
    
    Since the SVs_PADMY flag was eliminated a while ago, SvPADMY() is just
    defined as !(SvFLAGS(sv) & SVs_PADTMP). Thus the overload code is
    relying on the absence of a PADTMP flag in the target to deduce that the
    OPpTARGET_MY optimisation is in effect. This seems to work (at least for
    the code in the test suite), but can't be regarded as robust. This
    commit removes each SvPADMY() test and replaces it with the twin
    
                if (   (PL_opargs[PL_op->op_type] & OA_TARGLEX)
                    && (PL_op->op_private & OPpTARGET_MY))
    
    tests.

commit 72876cce4ecc7d8756e00d284e32df0b943d0da9
Author: David Mitchell <davem@iabyn.com>
Date:   Mon Feb 4 13:48:13 2019 +0000

    Eliminate opASSIGN macro usage from core
    
    This macro is defined as
    
        (PL_op->op_flags & OPf_STACKED)
    
    and indicates, for ops which support it, that the mutator-variant of the
    op is present (e.g. $x += 1).
    
    This macro was mainly used as an arg for the old-style overloading
    macros (tryAMAGICbin()) which were eliminated several years ago.
    
    This commit removes its vestigial usage, and instead tests OPf_STACKED
    directly at each location, along with adding a comment about the
    significance of the flag.
    
    This removes one item of obfuscation from the overloading code.
    
    There is one potentially functional change in this commit:
    Perl_try_amagic_bin() was sometimes testing for OPf_STACKED without
    first checking that it had been called with the AMGf_assign flag (which
    indicates that this op supports a mutator variant). With this commit, it
    now checks first, so this is theoretically a bug fix. In practice that
    section of code was never reached without AMGf_assign always being set
    anyway.

-----------------------------------------------------------------------

Summary of changes:
 gv.c                 | 73 +++++++++++++++++++++++++++++-----------------------
 lib/overload.t       | 21 ++++++++++++++-
 op.h                 |  5 ++++
 pod/perlhacktips.pod |  2 +-
 pod/perlinterp.pod   | 21 ++++++++-------
 pp.c                 | 30 ++++++++++-----------
 pp.h                 |  7 ++---
 pp_hot.c             | 21 +++++++++------
 8 files changed, 110 insertions(+), 70 deletions(-)

diff --git a/gv.c b/gv.c
index 798c3ae92f..ae7f2aa422 100644
--- a/gv.c
+++ b/gv.c
@@ -2938,8 +2938,6 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
 /* Implement tryAMAGICun_MG macro.
    Do get magic, then see if the stack arg is overloaded and if so call it.
    Flags:
-	AMGf_set     return the arg using SETs rather than assigning to
-		     the targ
 	AMGf_numeric apply sv_2num to the stack arg.
 */
 
@@ -2955,18 +2953,21 @@ Perl_try_amagic_un(pTHX_ int method, int flags) {
 					      AMGf_noright | AMGf_unary
 					    | (flags & AMGf_numarg))))
     {
-	if (flags & AMGf_set) {
-	    SETs(tmpsv);
-	}
-	else {
-	    dTARGET;
-	    if (SvPADMY(TARG)) {
-		sv_setsv(TARG, tmpsv);
-		SETTARG;
-	    }
-	    else
-		SETs(tmpsv);
-	}
+        /* where the op is of the form:
+         *    $lex = $x op $y (where the assign is optimised away)
+         * then assign the returned value to targ and return that;
+         * otherwise return the value directly
+         */
+        if (   (PL_opargs[PL_op->op_type] & OA_TARGLEX)
+            && (PL_op->op_private & OPpTARGET_MY))
+        {
+            dTARGET;
+            sv_setsv(TARG, tmpsv);
+            SETTARG;
+        }
+        else
+            SETs(tmpsv);
+
 	PUTBACK;
 	return TRUE;
     }
@@ -2981,8 +2982,6 @@ Perl_try_amagic_un(pTHX_ int method, int flags) {
    Do get magic, then see if the two stack args are overloaded and if so
    call it.
    Flags:
-	AMGf_set     return the arg using SETs rather than assigning to
-		     the targ
 	AMGf_assign  op may be called as mutator (eg +=)
 	AMGf_numeric apply sv_2num to the stack arg.
 */
@@ -2998,28 +2997,38 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) {
 	SvGETMAGIC(right);
 
     if (SvAMAGIC(left) || SvAMAGIC(right)) {
-	SV * const tmpsv = amagic_call(left, right, method,
-		    ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)
+	SV * tmpsv;
+        /* STACKED implies mutator variant, e.g. $x += 1 */
+        bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
+
+	tmpsv = amagic_call(left, right, method,
+		    (mutator ? AMGf_assign: 0)
 		  | (flags & AMGf_numarg));
 	if (tmpsv) {
-	    if (flags & AMGf_set) {
-		(void)POPs;
-		SETs(tmpsv);
-	    }
-	    else {
-		dATARGET;
-		(void)POPs;
-		if (opASSIGN || SvPADMY(TARG)) {
-		    sv_setsv(TARG, tmpsv);
-		    SETTARG;
-		}
-		else
-		    SETs(tmpsv);
-	    }
+            (void)POPs;
+            /* where the op is one of the two forms:
+             *    $x op= $y
+             *    $lex = $x op $y (where the assign is optimised away)
+             * then assign the returned value to targ and return that;
+             * otherwise return the value directly
+             */
+            if (   mutator
+                || (   (PL_opargs[PL_op->op_type] & OA_TARGLEX)
+                    && (PL_op->op_private & OPpTARGET_MY)))
+            {
+                dTARG;
+                TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
+                sv_setsv(TARG, tmpsv);
+                SETTARG;
+            }
+            else
+                SETs(tmpsv);
+
 	    PUTBACK;
 	    return TRUE;
 	}
     }
+
     if(left==right && SvGMAGICAL(left)) {
 	SV * const left = sv_newmortal();
 	*(sp-1) = left;
diff --git a/lib/overload.t b/lib/overload.t
index 055daab30f..5f2e0c2902 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl'; require './charset_tools.pl' }
-plan tests => 5362;
+plan tests => 5363;
 
 use Scalar::Util qw(tainted);
 
@@ -3174,3 +3174,22 @@ package Stringify {
         ::is $count, $stringify, $code;
     }
 }
+
+# RT #133789: in multiconcat with overload, the overloaded ref returned
+# from the overload method was being assigned to the pad targ, causing
+# a delay to the freeing of the object
+
+package RT33789 {
+    use overload
+        '.'  => sub { $_[0] }
+    ;
+
+    my $destroy = 0;
+    sub DESTROY { $destroy++ }
+
+    {
+        my $o = bless [];
+        my $result = '1' . ( '2' . ( '3' . ( '4' . ( '5' . $o ) ) ) );
+    }
+    ::is($destroy, 1, "RT #133789: delayed destroy");
+}
diff --git a/op.h b/op.h
index 6d9dae849e..c9f05b2271 100644
--- a/op.h
+++ b/op.h
@@ -99,7 +99,12 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPf_REF		16	/* Certified reference. */
 				/*  (Return container, not containee). */
 #define OPf_MOD		32	/* Will modify (lvalue). */
+
 #define OPf_STACKED	64	/* Some arg is arriving on the stack. */
+                                /*   Indicates mutator-variant of op for those
+                                 *     ops which support them, e.g. $x += 1
+                                 */
+
 #define OPf_SPECIAL	128	/* Do something weird for this op: */
 				/*  On local LVAL, don't init local value. */
 				/*  On OP_SORT, subroutine is inlined. */
diff --git a/pod/perlhacktips.pod b/pod/perlhacktips.pod
index 7ec2b40aa8..d5c34dd5c1 100644
--- a/pod/perlhacktips.pod
+++ b/pod/perlhacktips.pod
@@ -915,7 +915,7 @@ Lots of junk will go past as gdb reads in the relevant source files and
 libraries, and then:
 
     Breakpoint 1, Perl_pp_add () at pp_hot.c:309
-    309         dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+    1396    dSP; dATARGET; bool useleft; SV *svl, *svr;
     (gdb) step
     311           dPOPTOPnnrl_ul;
     (gdb)
diff --git a/pod/perlinterp.pod b/pod/perlinterp.pod
index 2d7073723e..b516badc8b 100644
--- a/pod/perlinterp.pod
+++ b/pod/perlinterp.pod
@@ -781,26 +781,27 @@ See L<perlguts/"Localizing changes"> for how to use the save stack.
 One thing you'll notice about the Perl source is that it's full of
 macros. Some have called the pervasive use of macros the hardest thing
 to understand, others find it adds to clarity. Let's take an example,
-the code which implements the addition operator:
+a stripped-down version the code which implements the addition operator:
 
    1  PP(pp_add)
    2  {
-   3      dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
-   4      {
-   5        dPOPTOPnnrl_ul;
-   6        SETn( left + right );
-   7        RETURN;
-   8      }
-   9  }
+   3      dSP; dATARGET;
+   4      tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
+   5      {
+   6        dPOPTOPnnrl_ul;
+   7        SETn( left + right );
+   8        RETURN;
+   9      }
+  10  }
 
 Every line here (apart from the braces, of course) contains a macro.
 The first line sets up the function declaration as Perl expects for PP
 code; line 3 sets up variable declarations for the argument stack and
-the target, the return value of the operation. Finally, it tries to see
+the target, the return value of the operation. Line 4 tries to see
 if the addition operation is overloaded; if so, the appropriate
 subroutine is called.
 
-Line 5 is another variable declaration - all variable declarations
+Line 6 is another variable declaration - all variable declarations
 start with C<d> - which pops from the top of the argument stack two NVs
 (hence C<nn>) and puts them into the variables C<right> and C<left>,
 hence the C<rl>. These are the two operands to the addition operator.
diff --git a/pp.c b/pp.c
index 522e985931..bf93ce76cd 100644
--- a/pp.c
+++ b/pp.c
@@ -2053,7 +2053,7 @@ PP(pp_lt)
     dSP;
     SV *left, *right;
 
-    tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
+    tryAMAGICbin_MG(lt_amg, AMGf_numeric);
     right = POPs;
     left  = TOPs;
     SETs(boolSV(
@@ -2069,7 +2069,7 @@ PP(pp_gt)
     dSP;
     SV *left, *right;
 
-    tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
+    tryAMAGICbin_MG(gt_amg, AMGf_numeric);
     right = POPs;
     left  = TOPs;
     SETs(boolSV(
@@ -2085,7 +2085,7 @@ PP(pp_le)
     dSP;
     SV *left, *right;
 
-    tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
+    tryAMAGICbin_MG(le_amg, AMGf_numeric);
     right = POPs;
     left  = TOPs;
     SETs(boolSV(
@@ -2101,7 +2101,7 @@ PP(pp_ge)
     dSP;
     SV *left, *right;
 
-    tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
+    tryAMAGICbin_MG(ge_amg, AMGf_numeric);
     right = POPs;
     left  = TOPs;
     SETs(boolSV(
@@ -2117,7 +2117,7 @@ PP(pp_ne)
     dSP;
     SV *left, *right;
 
-    tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
+    tryAMAGICbin_MG(ne_amg, AMGf_numeric);
     right = POPs;
     left  = TOPs;
     SETs(boolSV(
@@ -2249,7 +2249,7 @@ PP(pp_sle)
 	break;
     }
 
-    tryAMAGICbin_MG(amg_type, AMGf_set);
+    tryAMAGICbin_MG(amg_type, 0);
     {
       dPOPTOPssrl;
       const int cmp =
@@ -2267,7 +2267,7 @@ PP(pp_sle)
 PP(pp_seq)
 {
     dSP;
-    tryAMAGICbin_MG(seq_amg, AMGf_set);
+    tryAMAGICbin_MG(seq_amg, 0);
     {
       dPOPTOPssrl;
       SETs(boolSV(sv_eq_flags(left, right, 0)));
@@ -2278,7 +2278,7 @@ PP(pp_seq)
 PP(pp_sne)
 {
     dSP;
-    tryAMAGICbin_MG(sne_amg, AMGf_set);
+    tryAMAGICbin_MG(sne_amg, 0);
     {
       dPOPTOPssrl;
       SETs(boolSV(!sv_eq_flags(left, right, 0)));
@@ -2513,7 +2513,7 @@ PP(pp_not)
     dSP;
     SV *sv;
 
-    tryAMAGICun_MG(not_amg, AMGf_set);
+    tryAMAGICun_MG(not_amg, 0);
     sv = *PL_stack_sp;
     *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
     return NORMAL;
@@ -2710,7 +2710,7 @@ PP(pp_i_subtract)
 PP(pp_i_lt)
 {
     dSP;
-    tryAMAGICbin_MG(lt_amg, AMGf_set);
+    tryAMAGICbin_MG(lt_amg, 0);
     {
       dPOPTOPiirl_nomg;
       SETs(boolSV(left < right));
@@ -2721,7 +2721,7 @@ PP(pp_i_lt)
 PP(pp_i_gt)
 {
     dSP;
-    tryAMAGICbin_MG(gt_amg, AMGf_set);
+    tryAMAGICbin_MG(gt_amg, 0);
     {
       dPOPTOPiirl_nomg;
       SETs(boolSV(left > right));
@@ -2732,7 +2732,7 @@ PP(pp_i_gt)
 PP(pp_i_le)
 {
     dSP;
-    tryAMAGICbin_MG(le_amg, AMGf_set);
+    tryAMAGICbin_MG(le_amg, 0);
     {
       dPOPTOPiirl_nomg;
       SETs(boolSV(left <= right));
@@ -2743,7 +2743,7 @@ PP(pp_i_le)
 PP(pp_i_ge)
 {
     dSP;
-    tryAMAGICbin_MG(ge_amg, AMGf_set);
+    tryAMAGICbin_MG(ge_amg, 0);
     {
       dPOPTOPiirl_nomg;
       SETs(boolSV(left >= right));
@@ -2754,7 +2754,7 @@ PP(pp_i_ge)
 PP(pp_i_eq)
 {
     dSP;
-    tryAMAGICbin_MG(eq_amg, AMGf_set);
+    tryAMAGICbin_MG(eq_amg, 0);
     {
       dPOPTOPiirl_nomg;
       SETs(boolSV(left == right));
@@ -2765,7 +2765,7 @@ PP(pp_i_eq)
 PP(pp_i_ne)
 {
     dSP;
-    tryAMAGICbin_MG(ne_amg, AMGf_set);
+    tryAMAGICbin_MG(ne_amg, 0);
     {
       dPOPTOPiirl_nomg;
       SETs(boolSV(left != right));
diff --git a/pp.h b/pp.h
index 55efa0ba4e..98540be682 100644
--- a/pp.h
+++ b/pp.h
@@ -553,10 +553,10 @@ Does not use C<TARG>.  See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>.
 
 #define AMGf_noright	1
 #define AMGf_noleft	2
-#define AMGf_assign	4
+#define AMGf_assign	4       /* op supports mutator variant, e.g. $x += 1 */
 #define AMGf_unary	8
 #define AMGf_numeric	0x10	/* for Perl_try_amagic_bin */
-#define AMGf_set	0x20	/* for Perl_try_amagic_bin */
+
 #define AMGf_want_list	0x40
 #define AMGf_numarg	0x80
 
@@ -608,7 +608,7 @@ Does not use C<TARG>.  See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>.
             else { /* AMGf_want_scalar */                       \
                 dATARGET; /* just use the arg's location */     \
                 sv_setsv(TARG, tmpsv);                          \
-                if (opASSIGN)                                   \
+                if (PL_op->op_flags & OPf_STACKED)              \
                     sp--;                                       \
                 SETTARG;                                        \
             }                                                   \
@@ -634,6 +634,7 @@ Does not use C<TARG>.  See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>.
     } STMT_END
 
 
+/* 2019: no longer used in core */
 #define opASSIGN (PL_op->op_flags & OPf_STACKED)
 
 /*
diff --git a/pp_hot.c b/pp_hot.c
index 386787505f..7c6b3a8fc9 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1060,9 +1060,9 @@ PP(pp_multiconcat)
                     SV * const tmpsv = amagic_call(left, right, concat_amg,
                                                 (nextappend ? AMGf_assign: 0));
                     if (tmpsv) {
-                        /* NB: tryAMAGICbin_MG() includes an SvPADMY test
-                         * here, which isn;t needed as any implicit
-                         * assign does under OPpTARGET_MY is done after
+                        /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
+                         * here, which isn't needed as any implicit
+                         * assign done under OPpTARGET_MY is done after
                          * this loop */
                         if (nextappend) {
                             sv_setsv(left, tmpsv);
@@ -1097,15 +1097,20 @@ PP(pp_multiconcat)
 
         SP = toparg - stack_adj + 1;
 
-        /* Assign result of all RHS concats (left) to LHS (targ).
+        /* Return the result of all RHS concats, unless this op includes
+         * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
+         * to target (which will be $lex or expr).
          * If we are appending, targ will already have been appended to in
          * the loop */
-        if (is_append)
-            SvTAINT(targ);
-        else {
+        if (  !is_append
+            && (   (PL_op->op_flags   & OPf_STACKED)
+                || (PL_op->op_private & OPpTARGET_MY))
+        ) {
             sv_setsv(targ, left);
             SvSETMAGIC(targ);
         }
+        else
+            targ = left;
         SETs(targ);
         RETURN;
     }
@@ -1257,7 +1262,7 @@ PP(pp_eq)
     dSP;
     SV *left, *right;
 
-    tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
+    tryAMAGICbin_MG(eq_amg, AMGf_numeric);
     right = POPs;
     left  = TOPs;
     SETs(boolSV(

-- 
Perl5 Master Repository



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About