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.

8 files changed, 54 insertions, 9 deletions

diff --git a/cop.h b/cop.h
index d7482f903d..05ed67f093 100644
--- 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 e24b7c510a..66a78c2870 100644
--- 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 51a5bfeaf3..5b9c8a4f76 100644
--- 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 ace0a0559e..ff76478758 100644
--- 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 15b4d8bb75..83cf32ba36 100644
--- 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 8e1c1f68f2..9aec6c3ca5 100644
--- 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 d71a45d04c..94f23ea0b4 100644
--- 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 0e9b60334f..eaae3de3af 100644
--- 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