This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_return(): handle dounwind() freeing args
authorDavid Mitchell <davem@iabyn.com>
Tue, 25 Aug 2015 12:57:55 +0000 (13:57 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 3 Feb 2016 08:59:38 +0000 (08:59 +0000)
Currently only POPSUB (and other sub-like contexts, such as POPEVAL) do a
LEAVE_SCOPE() as well as restoring things from the context struct. This
means that if pp_return() does a dounwind() to pop back to the next
SUB/EVAL/FORMAT context, LEAVE_SCOPE() won't get called, and any return
values aren't prematurely freed, e.g. in the following

    sub f {
        for (...) {
            my $x = 1;
            return $x;
        }
    }

POPLOOP() won't call LEAVE_SCOPE(), so $x doesn't get freed.

The next commit is about to change that: POPLOOP() will indeed call
LEAVE_SCOPE(), (and later commits may make other POPFOO() types do that
too). So in preparation, this commit makes pp_return() preserve any return
args before calling dounwind().

pp_ctl.c
t/op/sub.t
t/op/sub_lval.t

index 64d4e59..4286d6f 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1995,8 +1995,9 @@ PP(pp_dbstate)
 /* 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..sp) based on
-   context, with any final args starting at newsp.
+   Process the return args on the stack in the range (mark+1..sp) based on
+   context, with any final args starting at newsp+1. Returns the new
+   top-of-stack position
    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
@@ -2307,7 +2308,6 @@ PP(pp_leavesublv)
        if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
            SV *sv;
            if (MARK <= SP) {
-               assert(MARK == SP);
                if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
                    !SvSMAGICAL(TOPs)) {
                    what =
@@ -2404,45 +2404,70 @@ PP(pp_return)
 {
     dSP; dMARK;
     PERL_CONTEXT *cx;
-    SV **oldsp;
     const I32 cxix = dopoptosub(cxstack_ix);
 
     assert(cxstack_ix >= 0);
     if (cxix < cxstack_ix) {
         if (cxix < 0) {
-            if (CxMULTICALL(cxstack)) { /* In this case we must be in a
-                                         * sort block, which is a CXt_NULL
-                                         * not a CXt_SUB */
-                dounwind(0);
-                /* if we were in list context, we would have to splice out
-                 * any junk before the return args, like we do in the general
-                 * pp_return case, e.g.
-                 *   sub f { for (junk1, junk2) { return arg1, arg2 }}
-                 */
+            if (!CxMULTICALL(cxstack))
+                DIE(aTHX_ "Can't return outside a subroutine");
+            /* We must be in a sort block, which is a CXt_NULL not a
+             * CXt_SUB. Handle specially. */
+            if (cxstack_ix > 0) {
+                /* See comment below about context popping. Since we know
+                 * we're scalar and not lvalue, we can preserve the return
+                 * value in a simpler fashion than there. */
+                SV *sv = *SP;
                 assert(cxstack[0].blk_gimme == G_SCALAR);
-                return 0;
+                if (   (sp != PL_stack_base)
+                    && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
+                )
+                    *SP = sv_mortalcopy(sv);
+                dounwind(0);
             }
-            else
-                DIE(aTHX_ "Can't return outside a subroutine");
+            /* caller responsible for popping cxstack[0] */
+            return 0;
         }
+
+        /* There are contexts that need popping. Doing this may free the
+         * return value(s), so preserve them first, e.g. popping the plain
+         * loop here would free $x:
+         *     sub f {  { my $x = 1; return $x } }
+         * We may also need to shift the args down; for example,
+         *    for (1,2) { return 3,4 }
+         * leaves 1,2,3,4 on the stack. Both these actions can be done by
+         * leave_common().  By calling it with lvalue=TRUE, we just bump
+         * the ref count and mortalise the args that need it.  The "scan
+         * the args and maybe copy them" process will be repeated by
+         * whoever we tail-call (e.g. pp_leaveeval), where any copying etc
+         * will be done. That is to say, in this code path two scans of
+         * the args will be done; the first just shifts and preserves; the
+         * second is the "real" arg processing, based on the type of
+         * return.
+         */
+        cx = &cxstack[cxix];
+        SP = leave_common(PL_stack_base + cx->blk_oldsp, SP, MARK,
+                            cx->blk_gimme, SVs_TEMP|SVs_PADTMP, TRUE);
+        PUTBACK;
        dounwind(cxix);
     }
-
+    else {
+        /* Like in the branch above, we need to handle any extra junk on
+         * the stack. But because we're not also popping extra contexts, we
+         * don't have to worry about prematurely freeing args. So we just
+         * need to do the bare minimum to handle junk, and leave the main
+         * arg processing in the function we tail call, e.g. pp_leavesub.
+         * In list context we have to splice out the junk; in scalar
+         * context we can leave as-is (pp_leavesub will later return the
+         * top stack element). But for an  empty arg list, e.g.
+         *    for (1,2) { return }
+         * we need to set sp = oldsp so that pp_leavesub knows to push
+         * &PL_sv_undef onto the stack.
+         */
+    SV **oldsp;
     cx = &cxstack[cxix];
-
     oldsp = PL_stack_base + cx->blk_oldsp;
     if (oldsp != MARK) {
-        /* Handle extra junk on the stack. For example,
-         *    for (1,2) { return 3,4 }
-         * leaves 1,2,3,4 on the stack. In list context we
-         * have to splice out the 1,2; In scalar context for
-         *    for (1,2) { return }
-         * we need to set sp = oldsp so that pp_leavesub knows
-         * to push &PL_sv_undef onto the stack.
-         * Note that in pp_return we only do the extra processing
-         * required to handle junk; everything else we leave to
-         * pp_leavesub.
-         */
         SSize_t nargs = SP - MARK;
         if (nargs) {
             if (cx->blk_gimme == G_ARRAY) {
@@ -2454,6 +2479,7 @@ PP(pp_return)
         else
             PL_stack_sp  = oldsp;
     }
+    }
 
     /* fall through to a normal exit */
     switch (CxTYPE(cx)) {
index 367f325..df6df3e 100644 (file)
@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan(tests => 58);
+plan(tests => 59);
 
 sub empty_sub {}
 
@@ -364,3 +364,15 @@ is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,
 
 is(join('-', 10, check_ret(-1)),        "10",  "check_ret(-1) list");
 is(join('-', 10, check_ret(-1,5)),      "10",  "check_ret(-1,5) list");
+
+# a sub without nested scopes that still leaves rubbish on the stack
+# which needs popping
+{
+    my @res = sub {
+        my $false;
+        # conditional leaves rubbish on stack
+        return @_ unless $false and $false;
+        1;
+    }->('a','b');
+    is(join('-', @res), "a-b", "unnested rubbish");
+}
index f70e6fe..d0bcdf0 100644 (file)
@@ -1,9 +1,11 @@
+#!./perl
+
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
 }
-plan tests=>207;
+plan tests=>209;
 
 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
 sub b : lvalue { ${\shift} }
@@ -1055,3 +1057,28 @@ sub bare119797 : lvalue {
 eval { (bare119797(0)) = 4..6 };
 is $@, "", '$@ after writing to array returned by bare block';
 is "@119797", "4 5 6", 'writing to array returned by bare block';
+
+# a sub with nested scopes must pop rubbish on the stack
+{
+    my $x = "a";
+    sub loopreturn : lvalue {
+        for (1,2) {
+            return $x
+        }
+    }
+    loopreturn = "b";
+    is($x, "b", "loopreturn");
+}
+
+# a sub without nested scopes that still leaves rubbish on the stack
+# which needs popping
+{
+    my $x = "a";
+    sub junkreturn : lvalue {
+        my $false;
+        return $x unless $false and $false;
+        1;
+    }
+    junkreturn = "b";
+    is($x, "b", "junkreturn");
+}