From: Zefram <zefram@fysh.org>
Date: Tue, 20 Apr 2010 23:00:09 +0000 (+0100)
Subject: unwinding target nominated by separate global
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=febb3a6d221072614a4dcfef3d3953e212e5cf6c;p=p5sagit%2Fp5-mst-13.2.git

unwinding target nominated by separate global

When unwinding due to die, the new global PL_restartjmpenv points
to the JMP_ENV at which longjmping should stop and control should
be transferred to PL_restartop.  This replaces the previous
use of cxstack[cxstack_ix+1].blk_eval.cur_top_env, located in a
nominally-discarded context frame.
---

diff --git a/embedvar.h b/embedvar.h
index 63ed46e..609e107 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -254,6 +254,7 @@
 #define PL_rehash_seed		(vTHX->Irehash_seed)
 #define PL_rehash_seed_set	(vTHX->Irehash_seed_set)
 #define PL_replgv		(vTHX->Ireplgv)
+#define PL_restartjmpenv	(vTHX->Irestartjmpenv)
 #define PL_restartop		(vTHX->Irestartop)
 #define PL_rs			(vTHX->Irs)
 #define PL_runops		(vTHX->Irunops)
@@ -581,6 +582,7 @@
 #define PL_Irehash_seed		PL_rehash_seed
 #define PL_Irehash_seed_set	PL_rehash_seed_set
 #define PL_Ireplgv		PL_replgv
+#define PL_Irestartjmpenv	PL_restartjmpenv
 #define PL_Irestartop		PL_restartop
 #define PL_Irs			PL_rs
 #define PL_Irunops		PL_runops
diff --git a/intrpvar.h b/intrpvar.h
index 8fe641c..4af88f6 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -126,6 +126,7 @@ PERLVAR(Idefstash,	HV *)		/* main symbol table */
 PERLVAR(Icurstash,	HV *)		/* symbol table for current package */
 
 PERLVAR(Irestartop,	OP *)		/* propagating an error from croak? */
+PERLVAR(Irestartjmpenv,	JMPENV *)	/* target frame for longjmp in die */
 PERLVAR(Icurcop,	COP *)
 PERLVAR(Icurstack,	AV *)		/* THE STACK */
 PERLVAR(Icurstackinfo,	PERL_SI *)	/* current stack + context */
diff --git a/perl.c b/perl.c
index 5dad874..7a87120 100644
--- a/perl.c
+++ b/perl.c
@@ -2193,6 +2193,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #endif
 
     ENTER;
+    PL_restartjmpenv = NULL;
     PL_restartop = 0;
     return NULL;
 }
@@ -2298,6 +2299,7 @@ S_run_body(pTHX_ I32 oldscope)
     /* do it */
 
     if (PL_restartop) {
+	PL_restartjmpenv = NULL;
 	PL_op = PL_restartop;
 	PL_restartop = 0;
 	CALLRUNOPS(aTHX);
@@ -2620,6 +2622,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
 	    /* NOTREACHED */
 	case 3:
 	    if (PL_restartop) {
+		PL_restartjmpenv = NULL;
 		PL_op = PL_restartop;
 		PL_restartop = 0;
 		goto redo_body;
@@ -2720,6 +2723,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
 	/* NOTREACHED */
     case 3:
 	if (PL_restartop) {
+	    PL_restartjmpenv = NULL;
 	    PL_op = PL_restartop;
 	    PL_restartop = 0;
 	    goto redo_body;
diff --git a/perlapi.h b/perlapi.h
index 54ddab0..5b7c50b 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -544,6 +544,8 @@ END_EXTERN_C
 #define PL_rehash_seed_set	(*Perl_Irehash_seed_set_ptr(aTHX))
 #undef  PL_replgv
 #define PL_replgv		(*Perl_Ireplgv_ptr(aTHX))
+#undef  PL_restartjmpenv
+#define PL_restartjmpenv	(*Perl_Irestartjmpenv_ptr(aTHX))
 #undef  PL_restartop
 #define PL_restartop		(*Perl_Irestartop_ptr(aTHX))
 #undef  PL_rs
diff --git a/pp_ctl.c b/pp_ctl.c
index d62d58a..d565f6a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1664,6 +1664,7 @@ Perl_die_where(pTHX_ SV *msv)
 		    *msg ? msg : "Unknown error\n");
 	    }
 	    assert(CxTYPE(cx) == CXt_EVAL);
+	    PL_restartjmpenv = cx->blk_eval.cur_top_env;
 	    PL_restartop = cx->blk_eval.retop;
 	    JMPENV_JUMP(3);
 	    /* NOTREACHED */
@@ -2881,17 +2882,8 @@ S_docatch(pTHX_ OP *o)
 	break;
     case 3:
 	/* die caught by an inner eval - continue inner loop */
-
-	/* NB XXX we rely on the old popped CxEVAL still being at the top
-	 * of the stack; the way die_where() currently works, this
-	 * assumption is valid. In theory The cur_top_env value should be
-	 * returned in another global, the way retop (aka PL_restartop)
-	 * is. */
-	assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
-
-	if (PL_restartop
-	    && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
-	{
+	if (PL_restartop && PL_restartjmpenv == PL_top_env) {
+	    PL_restartjmpenv = NULL;
 	    PL_op = PL_restartop;
 	    PL_restartop = 0;
 	    goto redo_body;
diff --git a/sv.c b/sv.c
index 3837958..bc2450d 100644
--- a/sv.c
+++ b/sv.c
@@ -12475,6 +12475,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_bodytarget	= sv_dup_inc(proto_perl->Ibodytarget, param);
     PL_formtarget	= sv_dup(proto_perl->Iformtarget, param);
 
+    PL_restartjmpenv	= proto_perl->Irestartjmpenv;
     PL_restartop	= proto_perl->Irestartop;
     PL_in_eval		= proto_perl->Iin_eval;
     PL_delaymagic	= proto_perl->Idelaymagic;