This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
replace leave_common() with leave_adjust_stacks()
authorDavid Mitchell <davem@iabyn.com>
Thu, 17 Dec 2015 12:13:09 +0000 (12:13 +0000)
committerDavid Mitchell <davem@iabyn.com>
Wed, 3 Feb 2016 09:18:34 +0000 (09:18 +0000)
Make the remaining callers of S_leave_common() use leave_adjust_stacks()
instead, then delete this static function.

This brings the benefits of freeing TEMPS on all scope exists that
has already been introduced on sub exits; uses the optimised code for
creating mortal copies; and finally unifies all the different 'process
return args on scope exit' implementations into single function.

embed.fnc
embed.h
pp_ctl.c
pp_hot.c
proto.h
t/op/do.t
t/op/grep.t

index ddc2f32..f83432d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2073,8 +2073,6 @@ sR        |PerlIO *|check_type_and_open|NN SV *name
 #ifndef PERL_DISABLE_PMC
 sR     |PerlIO *|doopen_pm     |NN SV *name
 #endif
-s      |void   |leave_common   |NN SV **newsp|NN SV **mark|I32 gimme \
-                                     |U32 flags|bool lvalue
 iRn    |bool   |path_is_searchable|NN const char *name
 sR     |I32    |run_user_filter|int idx|NN SV *buf_sv|int maxlen
 sR     |PMOP*  |make_matcher   |NN REGEXP* re
diff --git a/embed.h b/embed.h
index f69c975..5bd0489 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define dopoptoloop(a)         S_dopoptoloop(aTHX_ a)
 #define dopoptosub_at(a,b)     S_dopoptosub_at(aTHX_ a,b)
 #define dopoptowhen(a)         S_dopoptowhen(aTHX_ a)
-#define leave_common(a,b,c,d,e)        S_leave_common(aTHX_ a,b,c,d,e)
 #define make_matcher(a)                S_make_matcher(aTHX_ a)
 #define matcher_matches_sv(a,b)        S_matcher_matches_sv(aTHX_ a,b)
 #define num_overflow           S_num_overflow
index 69b2446..f5d786e 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2024,65 +2024,6 @@ PP(pp_dbstate)
        return NORMAL;
 }
 
-/* S_leave_common: Common code that many functions in this file use on
-                  scope exit.
-
-   Process the return args on the stack in the range (mark+1..PL_stack_sp)
-   based on context, with any final args starting at newsp+1.
-   Args are mortal copied (or mortalied if lvalue) unless its safe to use
-   as-is, based on whether it has the specified flags. Note that most
-   callers specify flags as (SVs_PADTMP|SVs_TEMP), while leaveeval skips
-   SVs_PADTMP since its optree gets immediately freed, freeing its padtmps
-   at the same time.
-
-   Also, taintedness is cleared.
-*/
-
-STATIC void
-S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme,
-                             U32 flags, bool lvalue)
-{
-    dSP;
-    PERL_ARGS_ASSERT_LEAVE_COMMON;
-
-    TAINT_NOT;
-    if (gimme == G_SCALAR) {
-       if (MARK < SP) {
-            SV *sv = *SP;
-
-           *++newsp = ((SvFLAGS(sv) & flags) && SvREFCNT(sv) == 1
-                         && !SvMAGICAL(sv))
-                           ? sv 
-                           : lvalue
-                               ? sv_2mortal(SvREFCNT_inc_simple_NN(sv))
-                               : sv_mortalcopy(sv);
-        }
-       else {
-           EXTEND(newsp, 1);
-           *++newsp = &PL_sv_undef;
-       }
-    }
-    else if (gimme == G_ARRAY) {
-       /* in case LEAVE wipes old return values */
-       while (++MARK <= SP) {
-            SV *sv = *MARK;
-           if ((SvFLAGS(sv) & flags) && SvREFCNT(sv) == 1
-                         && !SvMAGICAL(sv))
-               *++newsp = sv;
-           else {
-               *++newsp = lvalue
-                           ? sv_2mortal(SvREFCNT_inc_simple_NN(sv))
-                           : sv_mortalcopy(sv);
-               TAINT_NOT;      /* Each item is independent */
-           }
-       }
-       /* When this function was called with MARK == newsp, we reach this
-        * point with SP == newsp. */
-    }
-
-    PL_stack_sp = newsp;
-}
-
 
 PP(pp_enter)
 {
@@ -2114,8 +2055,8 @@ PP(pp_leave)
     if (gimme == G_VOID)
         PL_stack_sp = newsp;
     else
-        leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP,
-                               PL_op->op_private & OPpLVALUE);
+        leave_adjust_stacks(newsp, newsp, gimme,
+                                PL_op->op_private & OPpLVALUE ? 3 : 1);
 
     CX_LEAVE_SCOPE(cx);
     POPBASICBLK(cx);
@@ -2286,8 +2227,8 @@ PP(pp_leaveloop)
     if (gimme == G_VOID)
         PL_stack_sp = newsp;
     else
-        leave_common(newsp, MARK, gimme, SVs_PADTMP|SVs_TEMP,
-                              PL_op->op_private & OPpLVALUE);
+        leave_adjust_stacks(MARK, newsp, gimme,
+                                PL_op->op_private & OPpLVALUE ? 3 : 1);
 
     CX_LEAVE_SCOPE(cx);
     POPLOOP(cx);       /* Stack values are safe: release loop vars ... */
@@ -4279,7 +4220,7 @@ PP(pp_leaveeval)
     if (gimme == G_VOID)
         PL_stack_sp = newsp;
     else
-        leave_common(newsp, newsp, gimme, SVs_TEMP, FALSE);
+        leave_adjust_stacks(newsp, newsp, gimme, 0);
 
     /* the POPEVAL does a leavescope, which frees the optree associated
      * with eval, which if it frees the nextstate associated with
@@ -4374,7 +4315,7 @@ PP(pp_leavetry)
     if (gimme == G_VOID)
         PL_stack_sp = newsp;
     else
-        leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
+        leave_adjust_stacks(newsp, newsp, gimme, 1);
     CX_LEAVE_SCOPE(cx);
     POPEVAL(cx);
     POPBLOCK(cx);
@@ -4417,7 +4358,7 @@ PP(pp_leavegiven)
     if (gimme == G_VOID)
         PL_stack_sp = newsp;
     else
-        leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
+        leave_adjust_stacks(newsp, newsp, gimme, 1);
 
     CX_LEAVE_SCOPE(cx);
     POPGIVEN(cx);
@@ -5003,7 +4944,8 @@ PP(pp_leavewhen)
     if (gimme == G_VOID)
         PL_stack_sp = newsp;
     else
-        leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
+        leave_adjust_stacks(newsp, newsp, gimme, 1);
+
     /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
     assert(cxix < cxstack_ix);
     dounwind(cxix);
index 1da07a3..9d0b1e2 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -3463,9 +3463,10 @@ Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, I32 gimme, int pass)
                     else
                         SvTEMP_off(sv);
                 }
-                else {
+                else if (!SvPADTMP(sv)) {
                     /* mortalise arg to avoid it being freed during save
-                     * stack unwinding */
+                     * stack unwinding. Pad tmps don't need mortalising as
+                     * they're never freed */
                     SvREFCNT_inc_simple_void_NN(sv);
                     /* equivalent of sv_2mortal(), except that:
                      *  * it assumes that the temps stack has already been
diff --git a/proto.h b/proto.h
index faa0335..20fd667 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4507,9 +4507,6 @@ STATIC I32        S_dopoptosub_at(pTHX_ const PERL_CONTEXT* cxstk, I32 startingblock)
 STATIC I32     S_dopoptowhen(pTHX_ I32 startingblock)
                        __attribute__warn_unused_result__;
 
-STATIC void    S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme, U32 flags, bool lvalue);
-#define PERL_ARGS_ASSERT_LEAVE_COMMON  \
-       assert(newsp); assert(mark)
 STATIC PMOP*   S_make_matcher(pTHX_ REGEXP* re)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_MAKE_MATCHER  \
index 3cc4eae..0bbab5e 100644 (file)
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -293,4 +293,16 @@ SKIP: {
     }->(do { 1; delete $foo{bar} });
 }
 
+# A do block should FREETMPS on exit
+# RT #124248
+
+{
+    package p124248;
+    my $d = 0;
+    sub DESTROY { $d++ }
+    sub f { ::is($d, 1, "RT 124248"); }
+    f(do { 1; !!(my $x = bless []); });
+}
+
+
 done_testing();
index ea434a5..83ee4b6 100644 (file)
@@ -10,7 +10,7 @@ BEGIN {
     require "./test.pl";
 }
 
-plan( tests => 66 );
+plan( tests => 67 );
 
 {
     my @lol = ([qw(a b c)], [], [qw(1 2 3)]);
@@ -228,3 +228,13 @@ map is(\$_, \$_, '[perl #78194] \$_ == \$_ inside map ..., "$x"'),
     map { undef *_ } $y;
 }
 pass 'no double frees with grep/map { undef *_ }';
+
+# Don't mortalise PADTMPs.
+# This failed while I was messing with leave stuff (but not in a simple
+# test, so add one). The '1;' ensures the block is wrapped in ENTER/LEAVE;
+# the stringify returns a PADTMP. DAPM.
+
+{
+    my @a = map { 1; "$_" } 1,2;
+    is("@a", "1 2", "PADTMP");
+}