avoid inefficiency in change#3386 (every longjmp() was followed

by an avoidable call to setjmp())

p4raw-link: @3386 on //depot/perl: 312caa8e97f1c7ee342a9895c2f0e749625b4929

p4raw-id: //depot/perl@4372

9 files changed, 70 insertions, 50 deletions

diff --git a/embed.h b/embed.h
index 18953ae651..bf2a0e800e 100644
--- a/embed.h
+++ b/embed.h
@@ -2102,7 +2102,7 @@
 #define do_pmop_dump(a,b,c)	Perl_do_pmop_dump(aTHX_ a,b,c)
 #define do_sv_dump(a,b,c,d,e,f,g)	Perl_do_sv_dump(aTHX_ a,b,c,d,e,f,g)
 #define magic_dump(a)		Perl_magic_dump(aTHX_ a)
-#define vdefault_protect(a,b,c)	Perl_vdefault_protect(aTHX_ a,b,c)
+#define vdefault_protect(a,b,c,d)	Perl_vdefault_protect(aTHX_ a,b,c,d)
 #define reginitcolors()		Perl_reginitcolors(aTHX)
 #define sv_2pv_nolen(a)		Perl_sv_2pv_nolen(aTHX_ a)
 #define sv_pv(a)		Perl_sv_pv(aTHX_ a)
diff --git a/embed.pl b/embed.pl
index e44ba23dd0..7c05ab7d64 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1756,8 +1756,10 @@ p	|void	|do_pmop_dump	|I32 level|PerlIO *file|PMOP *pm
 p	|void	|do_sv_dump	|I32 level|PerlIO *file|SV *sv|I32 nest \
 				|I32 maxnest|bool dumpops|STRLEN pvlim
 p	|void	|magic_dump	|MAGIC *mg
-p	|void*	|default_protect|int *excpt|protect_body_t body|...
-p	|void*	|vdefault_protect|int *excpt|protect_body_t body|va_list *args
+p	|void*	|default_protect|volatile JMPENV *je|int *excpt \
+				|protect_body_t body|...
+p	|void*	|vdefault_protect|volatile JMPENV *je|int *excpt \
+				|protect_body_t body|va_list *args
 p	|void	|reginitcolors
 p	|char*	|sv_2pv_nolen	|SV* sv
 p	|char*	|sv_pv		|SV *sv
diff --git a/perl.c b/perl.c
index 74884b2419..0bb828fb7a 100644
--- a/perl.c
+++ b/perl.c
@@ -590,6 +590,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
     dTHR;
     I32 oldscope;
     int ret;
+    dJMPENV;
 #ifdef USE_THREADS
     dTHX;
 #endif
@@ -638,7 +639,8 @@ setuid perl scripts securely.\n");
     oldscope = PL_scopestack_ix;
     PL_dowarn = G_WARN_OFF;
 
-    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
+		env, xsinit);
     switch (ret) {
     case 0:
 	return 0;
@@ -1005,6 +1007,7 @@ perl_run(pTHXx)
     dTHR;
     I32 oldscope;
     int ret;
+    dJMPENV;
 #ifdef USE_THREADS
     dTHX;
 #endif
@@ -1012,7 +1015,7 @@ perl_run(pTHXx)
     oldscope = PL_scopestack_ix;
 
  redo_body:
-    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
     switch (ret) {
     case 1:
 	cxstack_ix = -1;		/* start context stack again */
@@ -1206,6 +1209,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     bool oldcatch = CATCH_GET;
     int ret;
     OP* oldop = PL_op;
+    dJMPENV;
 
     if (flags & G_DISCARD) {
 	ENTER;
@@ -1273,7 +1277,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
 	PL_markstack_ptr++;
 
   redo_body:
-	CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
+	CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+		    (OP*)&myop, FALSE);
 	switch (ret) {
 	case 0:
 	    retval = PL_stack_sp - (PL_stack_base + oldmark);
@@ -1371,6 +1376,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     I32 oldscope;
     int ret;
     OP* oldop = PL_op;
+    dJMPENV;
 
     if (flags & G_DISCARD) {
 	ENTER;
@@ -1395,7 +1401,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
 	myop.op_flags |= OPf_SPECIAL;
 
  redo_body:
-    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+		(OP*)&myop, TRUE);
     switch (ret) {
     case 0:
 	retval = PL_stack_sp - (PL_stack_base + oldmark);
@@ -2990,11 +2997,12 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
     CV *cv;
     STRLEN len;
     int ret;
+    dJMPENV;
 
     while (AvFILL(paramList) >= 0) {
 	cv = (CV*)av_shift(paramList);
 	SAVEFREESV(cv);
-	CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
+	CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
 	switch (ret) {
 	case 0:
 	    (void)SvPV(atsv, len);
diff --git a/perlapi.c b/perlapi.c
index ac38dffdfb..99a549b403 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -4754,12 +4754,12 @@ Perl_magic_dump(pTHXo_ MAGIC *mg)
 
 #undef  Perl_default_protect
 void*
-Perl_default_protect(pTHXo_ int *excpt, protect_body_t body, ...)
+Perl_default_protect(pTHXo_ volatile JMPENV *je, int *excpt, protect_body_t body, ...)
 {
     void* retval;
     va_list args;
     va_start(args, body);
-    retval = ((CPerlObj*)pPerl)->Perl_vdefault_protect(excpt, body, &args);
+    retval = ((CPerlObj*)pPerl)->Perl_vdefault_protect(je, excpt, body, &args);
     va_end(args);
     return retval;
 
@@ -4767,9 +4767,9 @@ Perl_default_protect(pTHXo_ int *excpt, protect_body_t body, ...)
 
 #undef  Perl_vdefault_protect
 void*
-Perl_vdefault_protect(pTHXo_ int *excpt, protect_body_t body, va_list *args)
+Perl_vdefault_protect(pTHXo_ volatile JMPENV *je, int *excpt, protect_body_t body, va_list *args)
 {
-    return ((CPerlObj*)pPerl)->Perl_vdefault_protect(excpt, body, args);
+    return ((CPerlObj*)pPerl)->Perl_vdefault_protect(je, excpt, body, args);
 }
 
 #undef  Perl_reginitcolors
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index ed395be00e..9af933bfb0 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -1012,7 +1012,7 @@ change#4052
 =item Data::Dumper
 
 A C<Maxdepth> setting can be specified to avoid venturing
-too deeply into depp data structures.  See L<Data::Dumper>.
+too deeply into deep data structures.  See L<Data::Dumper>.
 
 Dumping C<qr//> objects works correctly.
 
diff --git a/pp_ctl.c b/pp_ctl.c
index 3bf4f1d169..5f3ca18667 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2436,13 +2436,14 @@ S_docatch(pTHX_ OP *o)
     dTHR;
     int ret;
     OP *oldop = PL_op;
+    dJMPENV;
 
 #ifdef DEBUGGING
     assert(CATCH_GET == TRUE);
 #endif
     PL_op = o;
  redo_body:
-    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_docatch_body));
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
     switch (ret) {
     case 0:
 	break;
diff --git a/proto.h b/proto.h
index 6551c31179..787ec137f8 100644
--- a/proto.h
+++ b/proto.h
@@ -724,8 +724,8 @@ VIRTUAL void	Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o);
 VIRTUAL void	Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm);
 VIRTUAL void	Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim);
 VIRTUAL void	Perl_magic_dump(pTHX_ MAGIC *mg);
-VIRTUAL void*	Perl_default_protect(pTHX_ int *excpt, protect_body_t body, ...);
-VIRTUAL void*	Perl_vdefault_protect(pTHX_ int *excpt, protect_body_t body, va_list *args);
+VIRTUAL void*	Perl_default_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, ...);
+VIRTUAL void*	Perl_vdefault_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, va_list *args);
 VIRTUAL void	Perl_reginitcolors(pTHX);
 VIRTUAL char*	Perl_sv_2pv_nolen(pTHX_ SV* sv);
 VIRTUAL char*	Perl_sv_pv(pTHX_ SV *sv);
diff --git a/scope.c b/scope.c
index 9ee0429e02..1597acc9dc 100644
--- a/scope.c
+++ b/scope.c
@@ -17,26 +17,27 @@
 #include "perl.h"
 
 void *
-Perl_default_protect(pTHX_ int *excpt, protect_body_t body, ...)
+Perl_default_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
+		     protect_body_t body, ...)
 {
     void *ret;
     va_list args;
     va_start(args, body);
-    ret = vdefault_protect(excpt, body, &args);
+    ret = vdefault_protect(pcur_env, excpt, body, &args);
     va_end(args);
     return ret;
 }
 
 void *
-Perl_vdefault_protect(pTHX_ int *excpt, protect_body_t body, va_list *args)
+Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
+		      protect_body_t body, va_list *args)
 {
     dTHR;
-    dJMPENV;
     int ex;
     void *ret;
 
     DEBUG_l(Perl_deb(aTHX_ "Setting up local jumplevel %p, was %p\n",
-		&cur_env, PL_top_env));
+		pcur_env, PL_top_env));
     JMPENV_PUSH(ex);
     if (ex)
 	ret = NULL;
diff --git a/scope.h b/scope.h
index f481306564..9a196e6eda 100644
--- a/scope.h
+++ b/scope.h
@@ -148,6 +148,7 @@ struct jmpenv {
     int			je_ret;		/* last exception thrown */
     bool		je_mustcatch;	/* need to call longjmp()? */
     void		(*je_throw)(int v); /* last for bincompat */
+    bool		je_noset;	/* no need for setjmp() */
 };
 
 typedef struct jmpenv JMPENV;
@@ -157,7 +158,8 @@ typedef struct jmpenv JMPENV;
  *  body of protected processing.
  */
 typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list);
-typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...);
+typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
+					     int *, protect_body_t, ...);
 
 /*
  * How to build the first jmpenv.
@@ -175,6 +177,7 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...);
 	PL_start_env.je_throw = NULL;		\
 	PL_start_env.je_ret = -1;		\
 	PL_start_env.je_mustcatch = TRUE;	\
+	PL_start_env.je_noset = 0;		\
 	PL_top_env = &PL_start_env;		\
     } STMT_END
 
@@ -216,43 +219,49 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...);
  *    JMPENV_POP;  // don't forget this!
  */
 
-#define dJMPENV		JMPENV cur_env
+#define dJMPENV	JMPENV cur_env;	\
+		volatile JMPENV *pcur_env = ((cur_env.je_noset = 0),&cur_env)
 
-#define JMPENV_PUSH_INIT_ENV(cur_env,THROWFUNC) \
+#define JMPENV_PUSH_INIT_ENV(ce,THROWFUNC) \
     STMT_START {					\
-	cur_env.je_throw = (THROWFUNC);			\
-	cur_env.je_ret = -1;				\
-	cur_env.je_mustcatch = FALSE;			\
-	cur_env.je_prev = PL_top_env;			\
-	PL_top_env = &cur_env;				\
+	(ce).je_throw = (THROWFUNC);			\
+	(ce).je_ret = -1;				\
+	(ce).je_mustcatch = FALSE;			\
+	(ce).je_prev = PL_top_env;			\
+	PL_top_env = &(ce);				\
 	OP_REG_TO_MEM;					\
     } STMT_END
 
-#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(cur_env,THROWFUNC) 
+#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(*(JMPENV*)pcur_env,THROWFUNC) 
 
-#define JMPENV_POST_CATCH_ENV(cur_env) \
+#define JMPENV_POST_CATCH_ENV(ce) \
     STMT_START {					\
 	OP_MEM_TO_REG;					\
-	PL_top_env = &cur_env;				\
+	PL_top_env = &(ce);				\
     } STMT_END
 
-#define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(cur_env)
+#define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(*(JMPENV*)pcur_env)
 
 
-#define JMPENV_PUSH_ENV(cur_env,v) \
-    STMT_START {					\
-	JMPENV_PUSH_INIT_ENV(cur_env,NULL);				\
-	EXCEPT_SET_ENV(cur_env,PerlProc_setjmp(cur_env.je_buf, 1));	\
-	JMPENV_POST_CATCH_ENV(cur_env);				\
-	(v) = EXCEPT_GET_ENV(cur_env);				\
+#define JMPENV_PUSH_ENV(ce,v) \
+    STMT_START {						\
+	if (!(ce).je_noset) {					\
+	    JMPENV_PUSH_INIT_ENV(ce,NULL);			\
+	    EXCEPT_SET_ENV(ce,PerlProc_setjmp((ce).je_buf, 1));\
+	    (ce).je_noset = 1;					\
+	}							\
+	else							\
+	    EXCEPT_SET_ENV(ce,0);				\
+	JMPENV_POST_CATCH_ENV(ce);				\
+	(v) = EXCEPT_GET_ENV(ce);				\
     } STMT_END
 
-#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(cur_env,v) 
+#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v) 
 
-#define JMPENV_POP_ENV(cur_env) \
-    STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
+#define JMPENV_POP_ENV(ce) \
+    STMT_START { PL_top_env = (ce).je_prev; } STMT_END
 
-#define JMPENV_POP  JMPENV_POP_ENV(cur_env) 
+#define JMPENV_POP  JMPENV_POP_ENV(*(JMPENV*)pcur_env) 
 
 #define JMPENV_JUMP(v) \
     STMT_START {						\
@@ -269,11 +278,10 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...);
 	PerlProc_exit(1);					\
     } STMT_END
 
-#define EXCEPT_GET_ENV(cur_env)	(cur_env.je_ret)
-#define EXCEPT_GET EXCEPT_GET_ENV(cur_env)
-#define EXCEPT_SET_ENV(cur_env,v)	(cur_env.je_ret = (v))
-#define EXCEPT_SET(v) EXCEPT_SET_ENV(cur_env,v)
+#define EXCEPT_GET_ENV(ce)	((ce).je_ret)
+#define EXCEPT_GET		EXCEPT_GET_ENV(*(JMPENV*)pcur_env)
+#define EXCEPT_SET_ENV(ce,v)	((ce).je_ret = (v))
+#define EXCEPT_SET(v)		EXCEPT_SET_ENV(*(JMPENV*)pcur_env,v)
 
-#define CATCH_GET	(PL_top_env->je_mustcatch)
-#define CATCH_SET(v)	(PL_top_env->je_mustcatch = (v))
-   
+#define CATCH_GET		(PL_top_env->je_mustcatch)
+#define CATCH_SET(v)		(PL_top_env->je_mustcatch = (v))