This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make pp_leavesublv use S_leavesub_adjust_stacks()
authorDavid Mitchell <davem@iabyn.com>
Wed, 16 Dec 2015 12:30:01 +0000 (12:30 +0000)
committerDavid Mitchell <davem@iabyn.com>
Wed, 3 Feb 2016 09:18:34 +0000 (09:18 +0000)
Currently S_leavesub_adjust_stacks() is just used by pp_leavesub.
Rename it to Perl_leave_adjust_stacks(), extend its functionality
slightly, then make pp_leavesublv() use it too.

This means that lvalue sub exit gains the benefit of FREETMPS being done,
and (where mortal copying needs doing) the optimised copying code.
It also means there is now one less version of the "process args on scope
exit" code.

pp_leavesublv() still does a scan of its return args looking for things to
croak() on, but leaves everything else to leave_adjust_stacks().

leave_adjust_stacks() is intended shortly to be used in place of
S_leave_common() too, thus unifying all args-on-scope-exit code.

The changes to leave_adjust_stacks() in this commit (apart from the
renaming and doc changes) are:
* a new arg to indicate what condition to use to decide whether to
  pass or copy the arg;
* a new branch to mortalise and ref count bump an arg

embed.fnc
embed.h
pp_ctl.c
pp_hot.c
proto.h

index 61509f0..b8c5810 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2878,4 +2878,6 @@ Ei        |STRLEN |sv_or_pv_pos_u2b|NN SV *sv|NN const char *pv|STRLEN pos \
 EMpPX  |SV*    |_get_encoding
 Xp     |void   |clear_defarray |NN AV* av|bool abandon
 
+ApM    |void   |leave_adjust_stacks|NN SV **base_sp|I32 gimme|int filter
+
 : ex: set ts=8 sts=4 sw=4 noet:
diff --git a/embed.h b/embed.h
index 0639b5c..ec0f490 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define is_utf8_xidcont(a)     Perl_is_utf8_xidcont(aTHX_ a)
 #define is_utf8_xidfirst(a)    Perl_is_utf8_xidfirst(aTHX_ a)
 #define isinfnan               Perl_isinfnan
+#define leave_adjust_stacks(a,b,c)     Perl_leave_adjust_stacks(aTHX_ a,b,c)
 #define leave_scope(a)         Perl_leave_scope(aTHX_ a)
 #define lex_bufutf8()          Perl_lex_bufutf8(aTHX)
 #define lex_discard_to(a)      Perl_lex_discard_to(aTHX_ a)
index cde30a4..ff1fb42 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2308,13 +2308,9 @@ PP(pp_leaveloop)
 
 PP(pp_leavesublv)
 {
-    dSP;
-    SV **newsp;
-    SV **mark;
     I32 gimme;
     PERL_CONTEXT *cx;
-    bool ref;
-    const char *what = NULL;
+    SV **oldsp;
     OP *retop;
 
     cx = CX_CUR();
@@ -2327,99 +2323,78 @@ PP(pp_leavesublv)
        return 0;
     }
 
-    newsp = PL_stack_base + cx->blk_oldsp;
     gimme = cx->blk_gimme;
-    TAINT_NOT;
+    oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
 
-    mark = newsp + 1;
+    if (gimme == G_VOID)
+        PL_stack_sp = oldsp;
+    else {
+        U8   lval    = CxLVAL(cx);
+        bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
+        const char *what = NULL;
+
+        if (gimme == G_SCALAR) {
+            if (is_lval) {
+                /* check for bad return arg */
+                if (oldsp < PL_stack_sp) {
+                    SV *sv = *PL_stack_sp;
+                    if ((SvPADTMP(sv) || SvREADONLY(sv))) {
+                        what =
+                            SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
+                            : "a readonly value" : "a temporary";
+                    }
+                    else goto ok;
+                }
+                else {
+                    /* sub:lvalue{} will take us here. */
+                    what = "undef";
+                }
+              croak:
+                Perl_croak(aTHX_
+                          "Can't return %s from lvalue subroutine", what);
+            }
 
-    ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
-    if (gimme == G_SCALAR) {
-       if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
-           if (MARK <= SP) {
-               if ((SvPADTMP(TOPs) || SvREADONLY(TOPs))) {
-                   what =
-                       SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
-                       : "a readonly value" : "a temporary";
-               }
-               else goto copy_sv;
-           }
-           else {
-               /* sub:lvalue{} will take us here. */
-               what = "undef";
-           }
-          croak:
-           Perl_croak(aTHX_
-                     "Can't return %s from lvalue subroutine", what
-           );
-       }
-       if (MARK <= SP) {
-             copy_sv:
-               if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
-                   if (!SvPADTMP(*SP)) {
-                       *MARK = SvREFCNT_inc(*SP);
-                       FREETMPS;
-                       sv_2mortal(*MARK);
-                   }
-                   else {
-                       /* FREETMPS could clobber it */
-                       SV *sv = SvREFCNT_inc(*SP);
-                       FREETMPS;
-                       *MARK = sv_mortalcopy(sv);
-                       SvREFCNT_dec(sv);
-                   }
-               }
-               else
-                   *MARK =
-                     SvPADTMP(*SP)
-                      ? sv_mortalcopy(*SP)
-                      : !SvTEMP(*SP)
-                         ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
-                         : *SP;
-       }
-       else {
-           MEXTEND(MARK, 0);
-           *MARK = &PL_sv_undef;
-       }
-        SP = MARK;
+          ok:
+            leave_adjust_stacks(oldsp, gimme, is_lval ? 3 : 2);
 
-       if (CxLVAL(cx) & OPpDEREF) {
-           SvGETMAGIC(TOPs);
-           if (!SvOK(TOPs)) {
-               TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
-           }
-       }
-    }
-    else if (gimme == G_ARRAY) {
-       assert (!(CxLVAL(cx) & OPpDEREF));
-       if (ref || !CxLVAL(cx))
-           for (; MARK <= SP; MARK++)
-               *MARK =
-                      SvFLAGS(*MARK) & SVs_PADTMP
-                          ? sv_mortalcopy(*MARK)
-                    : SvTEMP(*MARK)
-                          ? *MARK
-                          : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
-       else for (; MARK <= SP; MARK++) {
-            /* the PL_sv_undef exception is to allow things like this to
-             * work, where PL_sv_undef acts as 'skip' placeholder on the
-             * LHS of list assigns:
-             *    sub foo :lvalue { undef }
-             *    ($a, undef, foo(), $b) = 1..4;
-             */
-           if (*MARK != &PL_sv_undef
-                   && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
-           ) {
-                   /* Might be flattened array after $#array =  */
-                    what = SvREADONLY(*MARK)
-                            ? "a readonly value" : "a temporary";
-                    goto croak;
-           }
-           else if (!SvTEMP(*MARK))
-               *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
-       }
+            if (lval & OPpDEREF) {
+                /* lval_sub()->{...} and similar */
+                dSP;
+                SvGETMAGIC(TOPs);
+                if (!SvOK(TOPs)) {
+                    TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
+                }
+                PUTBACK;
+            }
+        }
+        else {
+            assert(gimme == G_ARRAY);
+            assert (!(lval & OPpDEREF));
+
+            if (is_lval) {
+                /* scan for bad return args */
+                SV **p;
+                for (p = PL_stack_sp; p > oldsp; p--) {
+                    SV *sv = *p;
+                    /* the PL_sv_undef exception is to allow things like
+                     * this to work, where PL_sv_undef acts as 'skip'
+                     * placeholder on the LHS of list assigns:
+                     *    sub foo :lvalue { undef }
+                     *    ($a, undef, foo(), $b) = 1..4;
+                     */
+                    if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
+                    {
+                        /* Might be flattened array after $#array =  */
+                        what = SvREADONLY(sv)
+                                ? "a readonly value" : "a temporary";
+                        goto croak;
+                    }
+                }
+            }
+
+            leave_adjust_stacks(oldsp, gimme, is_lval ? 3 : 2);
+        }
     }
-    PUTBACK;
 
     CX_LEAVE_SCOPE(cx);
     POPSUB(cx);        /* Stack values are safe: release CV and @_ ... */
index 3ed672d..236e237 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -3282,36 +3282,46 @@ PP(pp_grepwhile)
     }
 }
 
-/* leavesub_adjust_stacks():
+/* leave_adjust_stacks():
  *
- * Process the sub's return args (in the range base_sp+1 .. PL_stack_sp),
- * and do the equivalent of a FREEMPS (and TAINT_NOT).
+ * Process a scope's return args (in the range base_sp+1 .. PL_stack_sp),
+ * and do the equivalent of a FREEMPS and TAINT_NOT.
  * Not intended to be called in void context.
  *
- * The main things done to process the return args are:
+ * When leaving a sub, eval, do{} or other scope, the things that need
+ * doing to process the return args are:
  *    * in scalar context, only return the last arg (or PL_sv_undef if none);
- *    * make a TEMP copy of every return arg, except where we can optimise
- *      the copy away without it being semantically visible;
- *    * make sure the arg isn't prematurely freed; in the case of an arg
- *      not copied, this may involve mortalising it. For example, in
+ *    * for the types of return that return copies of their args (such
+ *      as rvalue sub return), make a mortal copy of every return arg,
+ *      except where we can optimise the copy away without it being
+ *      semantically visible;
+ *    * make sure that the arg isn't prematurely freed; in the case of an
+ *      arg not copied, this may involve mortalising it. For example, in
  *      C<sub f { my $x = ...; $x }>, $x would be freed when we do
  *      CX_LEAVE_SCOPE(cx) unless it's protected or copied.
  *
+ * What condition to use when deciding whether to pass the arg through
+ * or make a copy, is determined by the 'pass' arg; its valid values are:
+ *   0: rvalue sub/eval exit
+ *   1: other rvalue scope exit
+ *   2: :lvalue sub exit in rvalue context
+ *   3: :lvalue sub exit in lvalue context and other lvalue scope exits
+ *
  * There is a big issue with doing a FREETMPS. We would like to free any
- * temps created by the last statement the sub executed, rather than
+ * temps created by the last statement which the sub executed, rather than
  * leaving them for the caller. In a situation where a sub call isn't
  * soon followed by a nextstate (e.g. nested recursive calls, a la
  * fibonacci()), temps can accumulate, causing memory and performance
  * issues.
  *
  * On the other hand, we don't want to free any TEMPs which are keeping
- * alive any return args that we skip copying; nor do we wish to undo any
- * mortalising or mortal copying we do here.
+ * alive any return args that we skipped copying; nor do we wish to undo
+ * any mortalising done here.
  *
  * The solution is to split the temps stack frame into two, with a cut
  * point delineating the two halves. We arrange that by the end of this
  * function, all the temps stack frame entries we wish to keep are in the
- * range  PL_tmps_floor+1.. tmps_base-1, while the ones we free now are in
+ * range  PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
  * the range  tmps_base .. PL_tmps_ix.  During the course of this
  * function, tmps_base starts off as PL_tmps_floor+1, then increases
  * whenever we find or create a temp that we know should be kept. In
@@ -3321,23 +3331,25 @@ PP(pp_grepwhile)
  * To determine whether a TEMP is keeping a return arg alive, every
  * arg that is kept rather than copied and which has the SvTEMP flag
  * set, has the flag temporarily unset, to mark it. At the end we scan
- * stack temps stack frame above the cut for entries without SvTEMP and
+ * the temps stack frame above the cut for entries without SvTEMP and
  * keep them, while turning SvTEMP on again. Note that if we die before
- * the SvTEMPs are enabled again, its safe: at worst, subsequent use of
+ * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
  * those SVs may be slightly less efficient.
  *
  * In practice various optimisations for some common cases mean we can
  * avoid most of the scanning and swapping about with the temps stack.
  */
 
-STATIC void
-S_leavesub_adjust_stacks(pTHX_ SV **base_sp, I32 gimme)
+void
+Perl_leave_adjust_stacks(pTHX_ SV **base_sp, I32 gimme, int pass)
 {
     dSP;
     SV    **from_sp;   /* where we're copying args from */
     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
     SSize_t nargs;
 
+    PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
+
     TAINT_NOT;
 
     if (gimme == G_ARRAY) {
@@ -3411,37 +3423,62 @@ S_leavesub_adjust_stacks(pTHX_ SV **base_sp, I32 gimme)
             }
 #endif
 
-            if (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1) {
-                /* can optimise away the copy */
+            if (
+               pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
+             : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
+             : pass == 2 ? (!SvPADTMP(sv))
+             : 1)
+            {
+                /* pass through: skip copy for logic or optimisation
+                 * reasons; instead mortalise it, except that ... */
                 *++base_sp = sv;
 
-                /* Since this SV is an SvTEMP with a ref count of 1, we
-                 * don't need to re-mortalise it; instead we just need to
-                 * ensure that its existing entry in the temps stack frame
-                 * ends up below the cut and so avoids being freed this
-                 * time round. We mark it as needing to be kept by
-                 * temporarily unsetting SvTEMP; then at the end, we
-                 * shuffle any !SvTEMP entries on the tmps stack back
-                 * below the cut.
-                 * However, there's a significant chance that there's a
-                 * 1:1 correspondence between the first few (or all)
-                 * elements in the return args stack frame and those in
-                 * the temps stack frame;
-                 * e,g.  sub f { ....; map {...} .... },
-                 * or e.g. if we're exiting multiple scopes and one of the
-                 * inner scopes has already made mortal copies of each
-                 * return arg.
-                 *
-                 * If so, this arg sv will correspond to the next item
-                 * above the cut, and so can be kept merely by moving the
-                 * cut boundary up one, rather than messing with SvTEMP.
-                 * If all args arre 1:1 then we can avoid the sorting
-                 * stage below completely.
-                 */
-                if (sv == *tmps_basep)
-                    tmps_basep++;
-                else
-                    SvTEMP_off(sv);
+                if (SvTEMP(sv)) {
+                    /* ... since this SV is an SvTEMP , we don't need to
+                     * re-mortalise it; instead we just need to ensure
+                     * that its existing entry in the temps stack frame
+                     * ends up below the cut and so avoids being freed
+                     * this time round. We mark it as needing to be kept
+                     * by temporarily unsetting SvTEMP; then at the end,
+                     * we shuffle any !SvTEMP entries on the tmps stack
+                     * back below the cut.
+                     * However, there's a significant chance that there's
+                     * a 1:1 correspondence between the first few (or all)
+                     * elements in the return args stack frame and those
+                     * in the temps stack frame; e,g.:
+                     *      sub f { ....; map {...} .... },
+                     * or if we're exiting multiple scopes and one of the
+                     * inner scopes has already made mortal copies of each
+                     * return arg.
+                     *
+                     * If so, this arg sv will correspond to the next item
+                     * on the tmps stack above the cut, and so can be kept
+                     * merely by moving the cut boundary up one, rather
+                     * than messing with SvTEMP.  If all args are 1:1 then
+                     * we can avoid the sorting stage below completely.
+                     */
+                    if (sv == *tmps_basep)
+                        tmps_basep++;
+                    else
+                        SvTEMP_off(sv);
+                }
+                else {
+                    /* mortalise arg to avoid it being freed during save
+                     * stack unwinding */
+                    SvREFCNT_inc_simple_void_NN(sv);
+                    /* equivalent of sv_2mortal(), except that:
+                     *  * it assumes that the temps stack has already been
+                     *    extended;
+                     *  * it puts the new item at the cut rather than at
+                     *    ++PL_tmps_ix, moving the previous occupant there
+                     *    instead.
+                     */
+                    if (!SvIMMORTAL(sv)) {
+                        SvTEMP_on(sv);
+                        PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
+                        *tmps_basep++ = sv;
+                    }
+                }
             }
             else {
                 /* Make a mortal copy of the SV.
@@ -3505,7 +3542,7 @@ S_leavesub_adjust_stacks(pTHX_ SV **base_sp, I32 gimme)
                     old_base = tmps_basep - PL_tmps_stack;
                     SvGETMAGIC(sv);
                     sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
-                    /* the mg_get or sv_setv might have created new temps
+                    /* the mg_get or sv_setsv might have created new temps
                      * or realloced the tmps stack; regrow and reload */
                     EXTEND_MORTAL(nargs);
                     tmps_basep = PL_tmps_stack + old_base;
@@ -3578,7 +3615,7 @@ PP(pp_leavesub)
     if (gimme == G_VOID)
         PL_stack_sp = oldsp;
     else
-        S_leavesub_adjust_stacks(aTHX_ oldsp, gimme);
+        leave_adjust_stacks(oldsp, gimme, 0);
 
     CX_LEAVE_SCOPE(cx);
     POPSUB(cx);        /* Stack values are safe: release CV and @_ ... */
diff --git a/proto.h b/proto.h
index 4820864..9578a67 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1610,6 +1610,9 @@ PERL_CALLCONV I32 Perl_keyword(pTHX_ const char *name, I32 len, bool all_keyword
 PERL_CALLCONV int      Perl_keyword_plugin_standard(pTHX_ char* keyword_ptr, STRLEN keyword_len, OP** op_ptr);
 #define PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD       \
        assert(keyword_ptr); assert(op_ptr)
+PERL_CALLCONV void     Perl_leave_adjust_stacks(pTHX_ SV **base_sp, I32 gimme, int filter);
+#define PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS   \
+       assert(base_sp)
 PERL_CALLCONV void     Perl_leave_scope(pTHX_ I32 base);
 PERL_CALLCONV bool     Perl_lex_bufutf8(pTHX);
 PERL_CALLCONV void     Perl_lex_discard_to(pTHX_ char* ptr);