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

diff --git a/embed.h b/embed.h
index 18953ae..bf2a0e8 100644 (file)
--- 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 e44ba23..7c05ab7 100755 (executable)
--- 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 74884b2..0bb828f 100644 (file)
--- 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 ac38dff..99a549b 100644 (file)
--- 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 ed395be..9af933b 100644 (file)
--- 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 3bf4f1d..5f3ca18 100644 (file)
--- 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 6551c31..787ec13 100644 (file)
--- 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 9ee0429..1597acc 100644 (file)
--- 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 f481306..9a196e6 100644 (file)
--- 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))