save old PL_comppad in CXt_SUB/FORMAT block

Currently when we call a sub, the old value of PL_comppad is
saved on the save stack using SAVECOMPPAD(). Instead, save it in
a new field in the context struct, called prevcomppad. This is simpler
and more efficient.

Note that there is already a confusingly-named field in the CXt_SUB
context struct called oldcomppad, which holds the value of PL_comppad for
the *current* sub, not for its caller. So the new field had to be called
something else.

One side effect of this is that an existing bug  - which causes too much
to be popped off the savestack when dieing while leaving a sub scope - is
now more noticeable, since PL_curpad and SAVEt_CLEARSV are now out of
sync: formerly, the unwinding of the save stack restored PL_curpad in
lockstep. The fix for this will come later in this branch, when the whole
issue of context stack popping order and reentrancy is addressed; for
now, a TODO test has been added.

diff --git a/cop.h b/cop.h
index d7482f9..05ed67f 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -556,7 +556,8 @@ struct block_sub {
     AV *       savearray;
     AV *       argarray;
     I32                olddepth;
-    PAD                *oldcomppad;
+    PAD                *oldcomppad; /* the *current* PL_comppad */
+    PAD                *prevcomppad; /* the caller's PL_comppad */
 };
 
 
@@ -568,6 +569,7 @@ struct block_format {
     /* Above here is the same for sub and format.  */
     GV *       gv;
     GV *       dfoutgv;
+    PAD                *prevcomppad; /* the caller's PL_comppad */
 };
 
 /* base for the next two macros. Don't use directly.
@@ -584,6 +586,7 @@ struct block_format {
                                                                        \
        cx->blk_sub.cv = cv;                                            \
        cx->blk_sub.olddepth = CvDEPTH(cv);                             \
+       cx->blk_sub.prevcomppad = PL_comppad;                           \
        cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;                     \
        cx->blk_sub.retop = NULL;                                       \
         SvREFCNT_inc_simple_void_NN(cv);
@@ -617,6 +620,7 @@ struct block_format {
        cx->blk_format.gv = gv;                                         \
        cx->blk_format.retop = (retop);                                 \
        cx->blk_format.dfoutgv = PL_defoutgv;                           \
+       cx->blk_format.prevcomppad = PL_comppad;                        \
        cx->blk_u16 = 0;                                                \
        SvREFCNT_inc_simple_void_NN(cv);                                \
        CvDEPTH(cv)++;                                                  \
@@ -667,6 +671,8 @@ struct block_format {
         }                                                               \
        sv = MUTABLE_SV(cx->blk_sub.cv);                                \
        LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]);               \
+        PL_comppad = cx->blk_sub.prevcomppad;                           \
+        PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;    \
         CvDEPTH((const CV*)sv) = olddepth;                              \
     } STMT_END
 
@@ -683,6 +689,8 @@ struct block_format {
         cx->blk_u16 |= CxPOPSUB_DONE;                                   \
        setdefout(dfuot);                                               \
        LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]);               \
+        PL_comppad = cx->blk_format.prevcomppad;                        \
+        PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;    \
        --CvDEPTH(cv);                                                  \
        SvREFCNT_dec_NN(cx->blk_format.cv);                             \
        SvREFCNT_dec_NN(dfuot);                                         \
@@ -1226,7 +1234,6 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>.
            PERL_STACK_OVERFLOW_CHECK();                                \
            Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
        }                                                               \
-       SAVECOMPPAD();                                                  \
        PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
        multicall_cv = cv;                                              \
        multicall_cop = CvSTART(cv);                                    \
@@ -1244,6 +1251,9 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>.
         CvDEPTH(multicall_cv) = cx->blk_sub.olddepth;                   \
         LEAVESUB(multicall_cv);                                        \
        POPBLOCK(cx,PL_curpm);                                          \
+       LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]);               \
+        PL_comppad = cx->blk_sub.prevcomppad;                           \
+        PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;    \
        POPSTACK;                                                       \
        CATCH_SET(multicall_oldcatch);                                  \
        LEAVE;                                                          \
@@ -1258,19 +1268,20 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>.
        CV * const _nOnclAshIngNamE_ = the_cv;                          \
        CV * const cv = _nOnclAshIngNamE_;                              \
        PADLIST * const padlist = CvPADLIST(cv);                        \
+        PAD * const prevcomppad = cx->blk_sub.prevcomppad;              \
        cx = &cxstack[cxstack_ix];                                      \
        assert(cx->cx_type & CXp_MULTICALL);                            \
        CvDEPTH(multicall_cv) = cx->blk_sub.olddepth;                   \
         LEAVESUB(multicall_cv);                                                \
        cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags);                    \
        PUSHSUB(cx);                                                    \
+        cx->blk_sub.prevcomppad = prevcomppad ; /* undo PUSHSUB */      \
         if (!(flags & CXp_SUB_RE_FAKE))                                 \
             CvDEPTH(cv)++;                                             \
        if (CvDEPTH(cv) >= 2) {                                         \
            PERL_STACK_OVERFLOW_CHECK();                                \
            Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
        }                                                               \
-       SAVECOMPPAD();                                                  \
        PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
        multicall_cv = cv;                                              \
        multicall_cop = CvSTART(cv);                                    \

diff --git a/pp_ctl.c b/pp_ctl.c
index e24b7c5..66a78c2 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1977,7 +1977,6 @@ PP(pp_dbstate)
                PERL_STACK_OVERFLOW_CHECK();
                pad_push(CvPADLIST(cv), CvDEPTH(cv));
            }
-           SAVECOMPPAD();
            PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
            RETURNOP(CvSTART(cv));
        }
@@ -2747,6 +2746,8 @@ PP(pp_goto)
            assert(PL_scopestack_ix == cx->blk_oldscopesp);
            oldsave = PL_scopestack[cx->blk_oldscopesp - 1];
            LEAVE_SCOPE(oldsave);
+            PL_comppad = cx->blk_sub.prevcomppad;
+            PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
 
            /* A destructor called during LEAVE_SCOPE could have undefined
             * our precious cv.  See bug #99850. */
@@ -2833,7 +2834,7 @@ PP(pp_goto)
                    pad_push(padlist, CvDEPTH(cv));
                }
                PL_curcop = cx->blk_oldcop;
-               SAVECOMPPAD();
+                cx->blk_sub.prevcomppad = PL_comppad;
                PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
                if (CxHASARGS(cx))
                {

diff --git a/pp_hot.c b/pp_hot.c
index 51a5bfe..5b9c8a4 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -3474,7 +3474,6 @@ PP(pp_entersub)
            PERL_STACK_OVERFLOW_CHECK();
            pad_push(padlist, depth);
        }
-       SAVECOMPPAD();
        PAD_SET_CUR_NOSAVE(padlist, depth);
        if (LIKELY(hasargs)) {
            AV *const av = MUTABLE_AV(PAD_SVl(0));

diff --git a/pp_sort.c b/pp_sort.c
index ace0a05..ff76478 100644 (file)
--- a/pp_sort.c
+++ b/pp_sort.c
@@ -1680,7 +1680,6 @@ PP(pp_sort)
                        PERL_STACK_OVERFLOW_CHECK();
                        pad_push(padlist, CvDEPTH(cv));
                    }
-                   SAVECOMPPAD();
                    PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
 
                    if (hasargs) {

diff --git a/pp_sys.c b/pp_sys.c
index 15b4d8b..83cf32b 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1395,7 +1395,6 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
        PERL_STACK_OVERFLOW_CHECK();
        pad_push(CvPADLIST(cv), CvDEPTH(cv));
     }
-    SAVECOMPPAD();
     PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
 
     setdefout(gv);         /* locally select filehandle so $% et al work */

diff --git a/regexec.c b/regexec.c
index 8e1c1f6..9aec6c3 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -6590,6 +6590,13 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                     U8 flags = (CXp_SUB_RE |
                                 ((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0));
                    if (last_pushed_cv) {
+                        /* PUSH/POP_MULTICALL save and restore the
+                         * caller's PL_comppad; if we call multiple subs
+                         * using the same CX block, we have to save and
+                         * unwind the varying PL_comppad's ourselves,
+                         * especially restoring the right PL_comppad on
+                         * backtrack - so save it on the save stack */
+                        SAVECOMPPAD();
                        CHANGE_MULTICALL_FLAGS(newcv, flags);
                    }
                    else {

diff --git a/sv.c b/sv.c
index d71a45d..94f23ea 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -13952,6 +13952,8 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
                }
                ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
                                           ncx->blk_sub.oldcomppad);
+               ncx->blk_sub.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
+                                          ncx->blk_sub.prevcomppad);
                break;
            case CXt_EVAL:
                ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,

diff --git a/t/op/sub.t b/t/op/sub.t
index 0e9b603..eaae3de 100644 (file)
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan(tests => 57);
+plan(tests => 58);
 
 sub empty_sub {}
 
@@ -303,6 +303,33 @@ pass("RT #126845: stub with prototype, then definition with attribute");
     ::is($destroyed, 1, "RT124156 freed cv");
 }
 
+# trapping dying while popping a scope needs to have the right pad at all
+# times. Localising a tied array then dying in STORE raises an exception
+# while leaving g(). Note that using an object and destructor wouldn't be
+# sufficient since DESTROY is called with call_sv(...,G_EVAL).
+# We make sure that the first item in every sub's pad is a lexical with
+# different values per sub.
+
+{
+    package tie_exception;
+    sub TIEARRAY { my $x = 4; bless [0] }
+    sub FETCH    { my $x = 5; 1 }
+    sub STORE    { my $x = 6; die if $_[0][0]; $_[0][0] = 1 }
+
+    my $y;
+    sub f { my $x = 7; eval { g() }; $y = $x }
+    sub g {
+        my $x = 8;
+        my @a;
+        tie @a, "tie_exception";
+        local $a[0];
+    }
+
+    f();
+    local $::TODO = "sub unwinding not safe yet";
+    ::is($y, 7, "tie_exception");
+}
+
 
 # check that return pops extraneous stuff from the stack