inhibit_exit in debugger not working when embedding perl5.5.650 #1179
Labels
Comments
From EFifer@sanwaint.comThis is a bug report for perl from efifer@sanwaint.com, This is a simple example of an embedded perl interpreter: #include <EXTERN.h> static PerlInterpreter *my_perl; int main(int argc, char **argv, char **env) my_perl = perl_alloc(); perl_call_pv("xxx", G_DISCARD); perl_destruct(my_perl); Sometime since perl5.005_03 "inhibit_exit" in the debugger stopped print "hello\n"; sub xxx { I have a debugging session like: % ./interp -I../perl5.005_03/lib -d xxx.pl Loading DB routines from perl5db.pl version 1.0402 Enter h or `h h' for help. main::(xxx.pl:1): print "hello\n"; DB<4> c However, with perl5.5.650 the call to perl_run exits without ever % ./interp -I../perl5.5.650/lib -d xxx.pl Loading DB routines from perl5db.pl version 1.05 Enter h or `h h' for help, run `perldoc perldebug' for more help. main::(xxx.pl:1): print "hello\n"; Am I doing something wrong or is something broken? Thanks. Eric Fifer Site configuration information for perl v5.5.650: Configured by fifere at Tue Feb 15 08:57:11 GMT 2000. Summary of my perl5 (revision 5.0 version 5 subversion 650) configuration: Locally applied patches: @INC for perl v5.5.650: Environment for perl v5.5.650: PATH=/usr/share/local/bin:/usr/local/bin:/opt/sybase/bin:/opt/perl/share/bin |
From @gsarOn Tue, 15 Feb 2000 11:30:14 GMT, "Fifer, Eric" wrote:
This is a known bug, that I mentioned in the 640 announcement. It was [ 3386] By: gsar on 1999/05/11 02:49:07 The problem is that some of the code in perl_run() can now execute We basically need to make the C++ exception support a build-time option Sarathy |
From @gsarOn Tue, 15 Feb 2000 07:05:43 PST, I wrote:
You may want to try this fix. Sarathy Inline Patch-----------------------------------8<-----------------------------------
Change 5162 by gsar@auger on 2000/02/20 16:07:38
make change#3386 a build-time option (avoids problems due to
perl_run() longjmping out)
Affected files ...
... //depot/perl/Todo-5.6#6 edit
... //depot/perl/embed.h#159 edit
... //depot/perl/embed.pl#110 edit
... //depot/perl/embedvar.h#89 edit
... //depot/perl/intrpvar.h#62 edit
... //depot/perl/objXSUB.h#101 edit
... //depot/perl/perl.c#222 edit
... //depot/perl/perl.h#233 edit
... //depot/perl/perlapi.c#44 edit
... //depot/perl/perlvars.h#31 edit
... //depot/perl/pp_ctl.c#182 edit
... //depot/perl/proto.h#194 edit
... //depot/perl/scope.c#64 edit
... //depot/perl/scope.h#42 edit
... //depot/perl/sv.c#206 edit
... //depot/perl/thrdvar.h#37 edit
... //depot/perl/util.c#175 edit
Differences ...
==== //depot/perl/Todo-5.6#6 (text) ====
Index: perl/Todo-5.6
--- perl/Todo-5.6.~1~ Sun Feb 20 13:22:33 2000
+++ perl/Todo-5.6 Sun Feb 20 13:22:33 2000
@@ -1,5 +1,4 @@
Bugs
- perl_run() can longjmp out
fix small memory leaks on compile-time failures
Unicode support
==== //depot/perl/embed.h#159 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~ Sun Feb 20 13:22:33 2000
+++ perl/embed.h Sun Feb 20 13:22:33 2000
@@ -774,8 +774,10 @@
#define do_pmop_dump Perl_do_pmop_dump
#define do_sv_dump Perl_do_sv_dump
#define magic_dump Perl_magic_dump
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
#define default_protect Perl_default_protect
#define vdefault_protect Perl_vdefault_protect
+#endif
#define reginitcolors Perl_reginitcolors
#define sv_2pv_nolen Perl_sv_2pv_nolen
#define sv_2pvutf8_nolen Perl_sv_2pvutf8_nolen
@@ -902,8 +904,13 @@
#define parse_body S_parse_body
#define run_body S_run_body
#define call_body S_call_body
-#define call_xbody S_call_xbody
#define call_list_body S_call_list_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define vparse_body S_vparse_body
+#define vrun_body S_vrun_body
+#define vcall_body S_vcall_body
+#define vcall_list_body S_vcall_list_body
+#endif
# if defined(USE_THREADS)
#define init_main_thread S_init_main_thread
# endif
@@ -919,6 +926,9 @@
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
#define docatch S_docatch
#define docatch_body S_docatch_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define vdocatch_body S_vdocatch_body
+#endif
#define dofindlabel S_dofindlabel
#define doparseform S_doparseform
#define dopoptoeval S_dopoptoeval
@@ -2187,7 +2197,9 @@
#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)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
#define vdefault_protect(a,b,c,d) Perl_vdefault_protect(aTHX_ a,b,c,d)
+#endif
#define reginitcolors() Perl_reginitcolors(aTHX)
#define sv_2pv_nolen(a) Perl_sv_2pv_nolen(aTHX_ a)
#define sv_2pvutf8_nolen(a) Perl_sv_2pvutf8_nolen(aTHX_ a)
@@ -2311,11 +2323,16 @@
# if defined(IAMSUID)
#define fd_on_nosuid_fs(a) S_fd_on_nosuid_fs(aTHX_ a)
# endif
-#define parse_body(a) S_parse_body(aTHX_ a)
+#define parse_body(a,b) S_parse_body(aTHX_ a,b)
#define run_body(a) S_run_body(aTHX_ a)
-#define call_body(a) S_call_body(aTHX_ a)
-#define call_xbody(a,b) S_call_xbody(aTHX_ a,b)
+#define call_body(a,b) S_call_body(aTHX_ a,b)
#define call_list_body(a) S_call_list_body(aTHX_ a)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define vparse_body(a) S_vparse_body(aTHX_ a)
+#define vrun_body(a) S_vrun_body(aTHX_ a)
+#define vcall_body(a) S_vcall_body(aTHX_ a)
+#define vcall_list_body(a) S_vcall_list_body(aTHX_ a)
+#endif
# if defined(USE_THREADS)
#define init_main_thread() S_init_main_thread(aTHX)
# endif
@@ -2330,7 +2347,10 @@
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
#define docatch(a) S_docatch(aTHX_ a)
-#define docatch_body(a) S_docatch_body(aTHX_ a)
+#define docatch_body() S_docatch_body(aTHX)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define vdocatch_body(a) S_vdocatch_body(aTHX_ a)
+#endif
#define dofindlabel(a,b,c,d) S_dofindlabel(aTHX_ a,b,c,d)
#define doparseform(a) S_doparseform(aTHX_ a)
#define dopoptoeval(a) S_dopoptoeval(aTHX_ a)
@@ -4289,10 +4309,12 @@
#define do_sv_dump Perl_do_sv_dump
#define Perl_magic_dump CPerlObj::Perl_magic_dump
#define magic_dump Perl_magic_dump
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
#define Perl_default_protect CPerlObj::Perl_default_protect
#define default_protect Perl_default_protect
#define Perl_vdefault_protect CPerlObj::Perl_vdefault_protect
#define vdefault_protect Perl_vdefault_protect
+#endif
#define Perl_reginitcolors CPerlObj::Perl_reginitcolors
#define reginitcolors Perl_reginitcolors
#define Perl_sv_2pv_nolen CPerlObj::Perl_sv_2pv_nolen
@@ -4521,10 +4543,18 @@
#define run_body S_run_body
#define S_call_body CPerlObj::S_call_body
#define call_body S_call_body
-#define S_call_xbody CPerlObj::S_call_xbody
-#define call_xbody S_call_xbody
#define S_call_list_body CPerlObj::S_call_list_body
#define call_list_body S_call_list_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define S_vparse_body CPerlObj::S_vparse_body
+#define vparse_body S_vparse_body
+#define S_vrun_body CPerlObj::S_vrun_body
+#define vrun_body S_vrun_body
+#define S_vcall_body CPerlObj::S_vcall_body
+#define vcall_body S_vcall_body
+#define S_vcall_list_body CPerlObj::S_vcall_list_body
+#define vcall_list_body S_vcall_list_body
+#endif
# if defined(USE_THREADS)
#define S_init_main_thread CPerlObj::S_init_main_thread
#define init_main_thread S_init_main_thread
@@ -4549,6 +4579,10 @@
#define docatch S_docatch
#define S_docatch_body CPerlObj::S_docatch_body
#define docatch_body S_docatch_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#define S_vdocatch_body CPerlObj::S_vdocatch_body
+#define vdocatch_body S_vdocatch_body
+#endif
#define S_dofindlabel CPerlObj::S_dofindlabel
#define dofindlabel S_dofindlabel
#define S_doparseform CPerlObj::S_doparseform
==== //depot/perl/embed.pl#110 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl.~1~ Sun Feb 20 13:22:33 2000
+++ perl/embed.pl Sun Feb 20 13:22:33 2000
@@ -2097,10 +2097,12 @@
Ap |void |do_sv_dump |I32 level|PerlIO *file|SV *sv|I32 nest \
|I32 maxnest|bool dumpops|STRLEN pvlim
Ap |void |magic_dump |MAGIC *mg
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
Ap |void* |default_protect|volatile JMPENV *je|int *excpt \
|protect_body_t body|...
Ap |void* |vdefault_protect|volatile JMPENV *je|int *excpt \
|protect_body_t body|va_list *args
+#endif
Ap |void |reginitcolors
Ap |char* |sv_2pv_nolen |SV* sv
Ap |char* |sv_2pvutf8_nolen|SV* sv
@@ -2237,11 +2239,16 @@
# if defined(IAMSUID)
s |int |fd_on_nosuid_fs|int fd
# endif
-s |void* |parse_body |va_list args
-s |void* |run_body |va_list args
-s |void* |call_body |va_list args
-s |void |call_xbody |OP *myop|int is_eval
-s |void* |call_list_body |va_list args
+s |void* |parse_body |char **env|XSINIT_t xsinit
+s |void* |run_body |I32 oldscope
+s |void |call_body |OP *myop|int is_eval
+s |void* |call_list_body |CV *cv
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+s |void* |vparse_body |va_list args
+s |void* |vrun_body |va_list args
+s |void* |vcall_body |va_list args
+s |void* |vcall_list_body|va_list args
+#endif
# if defined(USE_THREADS)
s |struct perl_thread * |init_main_thread
# endif
@@ -2258,7 +2265,10 @@
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
s |OP* |docatch |OP *o
-s |void* |docatch_body |va_list args
+s |void* |docatch_body
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+s |void* |vdocatch_body |va_list args
+#endif
s |OP* |dofindlabel |OP *o|char *label|OP **opstack|OP **oplimit
s |void |doparseform |SV *sv
s |I32 |dopoptoeval |I32 startingblock
==== //depot/perl/embedvar.h#89 (text+w) ====
==== //depot/perl/intrpvar.h#62 (text) ====
Index: perl/intrpvar.h
--- perl/intrpvar.h.~1~ Sun Feb 20 13:22:33 2000
+++ perl/intrpvar.h Sun Feb 20 13:22:33 2000
@@ -8,10 +8,7 @@
* generated when built with or without MULTIPLICITY. It is also used
* to generate the appropriate export list for win32.
*
- * When building without MULTIPLICITY, these variables will be truly global.
- *
- * Avoid build-specific #ifdefs here, like DEBUGGING. That way,
- * we can keep binary compatibility of the curinterp structure */
+ * When building without MULTIPLICITY, these variables will be truly global. */
/* pseudo environmental stuff */
PERLVAR(Iorigargc, int)
==== //depot/perl/objXSUB.h#101 (text+w) ====
Index: perl/objXSUB.h
--- perl/objXSUB.h.~1~ Sun Feb 20 13:22:33 2000
+++ perl/objXSUB.h Sun Feb 20 13:22:33 2000
@@ -1987,6 +1987,7 @@
#define Perl_magic_dump pPerl->Perl_magic_dump
#undef magic_dump
#define magic_dump Perl_magic_dump
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
#undef Perl_default_protect
#define Perl_default_protect pPerl->Perl_default_protect
#undef default_protect
@@ -1995,6 +1996,7 @@
#define Perl_vdefault_protect pPerl->Perl_vdefault_protect
#undef vdefault_protect
#define vdefault_protect Perl_vdefault_protect
+#endif
#undef Perl_reginitcolors
#define Perl_reginitcolors pPerl->Perl_reginitcolors
#undef reginitcolors
@@ -2151,12 +2153,16 @@
#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
# if defined(IAMSUID)
# endif
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#endif
# if defined(USE_THREADS)
# endif
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#endif
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
#endif
==== //depot/perl/perl.c#222 (text) ====
Index: perl/perl.c
--- perl/perl.c.~1~ Sun Feb 20 13:22:33 2000
+++ perl/perl.c Sun Feb 20 13:22:33 2000
@@ -155,7 +155,9 @@
thr = init_main_thread();
#endif /* USE_THREADS */
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
+#endif
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
@@ -800,13 +802,20 @@
oldscope = PL_scopestack_ix;
PL_dowarn = G_WARN_OFF;
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
- env, xsinit);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ parse_body(env,xsinit);
+#endif
if (PL_checkav)
call_list(oldscope, PL_checkav);
- return 0;
+ ret = 0;
+ break;
case 1:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
@@ -818,21 +827,34 @@
PL_curstash = PL_defstash;
if (PL_checkav)
call_list(oldscope, PL_checkav);
- return STATUS_NATIVE_EXPORT;
+ ret = STATUS_NATIVE_EXPORT;
+ break;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
- return 1;
+ ret = 1;
+ break;
}
- return 0;
+ JMPENV_POP;
+ return ret;
+}
+
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+STATIC void *
+S_vparse_body(pTHX_ va_list args)
+{
+ char **env = va_arg(args, char**);
+ XSINIT_t xsinit = va_arg(args, XSINIT_t);
+
+ return parse_body(env, xsinit);
}
+#endif
STATIC void *
-S_parse_body(pTHX_ va_list args)
+S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
dTHR;
int argc = PL_origargc;
char **argv = PL_origargv;
- char **env = va_arg(args, char**);
char *scriptname = NULL;
int fdscript = -1;
VOL bool dosearch = FALSE;
@@ -842,8 +864,6 @@
register char *s;
char *cddir = Nullch;
- XSINIT_t xsinit = va_arg(args, XSINIT_t);
-
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
SAVEFREESV(sv);
@@ -1230,7 +1250,7 @@
{
dTHR;
I32 oldscope;
- int ret;
+ int ret = 0;
dJMPENV;
#ifdef USE_THREADS
dTHX;
@@ -1238,14 +1258,23 @@
oldscope = PL_scopestack_ix;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 1:
cxstack_ix = -1; /* start context stack again */
goto redo_body;
- case 0: /* normal completion */
- case 2: /* my_exit() */
+ case 0: /* normal completion */
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ run_body(oldscope);
+#endif
+ /* FALL THROUGH */
+ case 2: /* my_exit() */
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
@@ -1256,7 +1285,8 @@
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- return STATUS_NATIVE_EXPORT;
+ ret = STATUS_NATIVE_EXPORT;
+ break;
case 3:
if (PL_restartop) {
POPSTACK_TO(PL_mainstack);
@@ -1264,18 +1294,29 @@
}
PerlIO_printf(Perl_error_log, "panic: restartop\n");
FREETMPS;
- return 1;
+ ret = 1;
+ break;
}
- /* NOTREACHED */
- return 0;
+ JMPENV_POP;
+ return ret;
+}
+
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+STATIC void *
+S_vrun_body(pTHX_ va_list args)
+{
+ I32 oldscope = va_arg(args, I32);
+
+ return run_body(oldscope);
}
+#endif
+
STATIC void *
-S_run_body(pTHX_ va_list args)
+S_run_body(pTHX_ I32 oldscope)
{
dTHR;
- I32 oldscope = va_arg(args, I32);
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
@@ -1543,7 +1584,7 @@
if (!(flags & G_EVAL)) {
CATCH_SET(TRUE);
- call_xbody((OP*)&myop, FALSE);
+ call_body((OP*)&myop, FALSE);
retval = PL_stack_sp - (PL_stack_base + oldmark);
CATCH_SET(oldcatch);
}
@@ -1571,11 +1612,19 @@
}
PL_markstack_ptr++;
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, FALSE);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ call_body((OP*)&myop, FALSE);
+#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
@@ -1587,6 +1636,7 @@
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
@@ -1620,6 +1670,7 @@
PL_curpm = newpm;
LEAVE;
}
+ JMPENV_POP;
}
if (flags & G_DISCARD) {
@@ -1632,18 +1683,20 @@
return retval;
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
-S_call_body(pTHX_ va_list args)
+S_vcall_body(pTHX_ va_list args)
{
OP *myop = va_arg(args, OP*);
int is_eval = va_arg(args, int);
- call_xbody(myop, is_eval);
+ call_body(myop, is_eval);
return NULL;
}
+#endif
STATIC void
-S_call_xbody(pTHX_ OP *myop, int is_eval)
+S_call_body(pTHX_ OP *myop, int is_eval)
{
dTHR;
@@ -1703,11 +1756,19 @@
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, TRUE);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ call_body((OP*)&myop,TRUE);
+#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
@@ -1719,6 +1780,7 @@
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
@@ -1739,6 +1801,7 @@
break;
}
+ JMPENV_POP;
if (flags & G_DISCARD) {
PL_stack_sp = PL_stack_base + oldmark;
retval = 0;
@@ -3373,9 +3436,16 @@
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ call_list_body(cv);
+#endif
atsv = ERRSV;
(void)SvPV(atsv, len);
if (len) {
@@ -3392,6 +3462,7 @@
: "END");
while (PL_scopestack_ix > oldscope)
LEAVE;
+ JMPENV_POP;
Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
}
break;
@@ -3406,6 +3477,7 @@
PL_curstash = PL_defstash;
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
if (paramList == PL_beginav)
Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
@@ -3427,15 +3499,22 @@
FREETMPS;
break;
}
+ JMPENV_POP;
}
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
-S_call_list_body(pTHX_ va_list args)
+S_vcall_list_body(pTHX_ va_list args)
{
- dTHR;
CV *cv = va_arg(args, CV*);
+ return call_list_body(cv);
+}
+#endif
+STATIC void *
+S_call_list_body(pTHX_ CV *cv)
+{
PUSHMARK(PL_stack_sp);
call_sv((SV*)cv, G_EVAL|G_DISCARD);
return NULL;
==== //depot/perl/perl.h#233 (text) ====
Index: perl/perl.h
--- perl/perl.h.~1~ Sun Feb 20 13:22:33 2000
+++ perl/perl.h Sun Feb 20 13:22:33 2000
@@ -215,7 +215,10 @@
#define CALLREG_INTUIT_START CALL_FPTR(PL_regint_start)
#define CALLREG_INTUIT_STRING CALL_FPTR(PL_regint_string)
#define CALLREGFREE CALL_FPTR(PL_regfree)
-#define CALLPROTECT CALL_FPTR(PL_protect)
+
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+# define CALLPROTECT CALL_FPTR(PL_protect)
+#endif
#define NOOP (void)0
#define dNOOP extern int Perl___notused
==== //depot/perl/perlapi.c#44 (text+w) ====
Index: perl/perlapi.c
--- perl/perlapi.c.~1~ Sun Feb 20 13:22:33 2000
+++ perl/perlapi.c Sun Feb 20 13:22:33 2000
@@ -3589,6 +3589,7 @@
{
((CPerlObj*)pPerl)->Perl_magic_dump(mg);
}
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
#undef Perl_default_protect
void*
@@ -3609,6 +3610,7 @@
{
return ((CPerlObj*)pPerl)->Perl_vdefault_protect(je, excpt, body, args);
}
+#endif
#undef Perl_reginitcolors
void
@@ -3864,12 +3866,16 @@
#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
# if defined(IAMSUID)
# endif
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#endif
# if defined(USE_THREADS)
# endif
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+#endif
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
#endif
==== //depot/perl/perlvars.h#31 (text) ====
Index: perl/perlvars.h
--- perl/perlvars.h.~1~ Sun Feb 20 13:22:33 2000
+++ perl/perlvars.h Sun Feb 20 13:22:33 2000
@@ -11,11 +11,7 @@
*
* The 'G' prefix is only needed for vars that need appropriate #defines
* generated in embed*.h. Such symbols are also used to generate
- * the appropriate export list for win32.
- *
- * Avoid build-specific #ifdefs here, like DEBUGGING. That way,
- * we can keep binary compatibility of the curinterp structure */
-
+ * the appropriate export list for win32. */
/* global state */
PERLVAR(Gcurinterp, PerlInterpreter *)
==== //depot/perl/pp_ctl.c#182 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c.~1~ Sun Feb 20 13:22:33 2000
+++ perl/pp_ctl.c Sun Feb 20 13:22:33 2000
@@ -2521,9 +2521,17 @@
}
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
S_docatch_body(pTHX_ va_list args)
{
+ return docatch_body();
+}
+#endif
+
+STATIC void *
+S_docatch_body(pTHX)
+{
CALLRUNOPS(aTHX);
return NULL;
}
@@ -2541,10 +2549,18 @@
assert(CATCH_GET == TRUE);
#endif
PL_op = o;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ docatch_body();
+#endif
break;
case 3:
if (PL_restartop && cursi == PL_curstackinfo) {
@@ -2554,10 +2570,12 @@
}
/* FALL THROUGH */
default:
+ JMPENV_POP;
PL_op = oldop;
JMPENV_JUMP(ret);
/* NOTREACHED */
}
+ JMPENV_POP;
PL_op = oldop;
return Nullop;
}
==== //depot/perl/proto.h#194 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~ Sun Feb 20 13:22:33 2000
+++ perl/proto.h Sun Feb 20 13:22:33 2000
@@ -876,8 +876,10 @@
PERL_CALLCONV void Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm);
PERL_CALLCONV void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim);
PERL_CALLCONV void Perl_magic_dump(pTHX_ MAGIC *mg);
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
PERL_CALLCONV void* Perl_default_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, ...);
PERL_CALLCONV void* Perl_vdefault_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, va_list *args);
+#endif
PERL_CALLCONV void Perl_reginitcolors(pTHX);
PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv);
PERL_CALLCONV char* Perl_sv_2pvutf8_nolen(pTHX_ SV* sv);
@@ -1011,11 +1013,16 @@
# if defined(IAMSUID)
STATIC int S_fd_on_nosuid_fs(pTHX_ int fd);
# endif
-STATIC void* S_parse_body(pTHX_ va_list args);
-STATIC void* S_run_body(pTHX_ va_list args);
-STATIC void* S_call_body(pTHX_ va_list args);
-STATIC void S_call_xbody(pTHX_ OP *myop, int is_eval);
-STATIC void* S_call_list_body(pTHX_ va_list args);
+STATIC void* S_parse_body(pTHX_ char **env, XSINIT_t xsinit);
+STATIC void* S_run_body(pTHX_ I32 oldscope);
+STATIC void S_call_body(pTHX_ OP *myop, int is_eval);
+STATIC void* S_call_list_body(pTHX_ CV *cv);
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+STATIC void* S_vparse_body(pTHX_ va_list args);
+STATIC void* S_vrun_body(pTHX_ va_list args);
+STATIC void* S_vcall_body(pTHX_ va_list args);
+STATIC void* S_vcall_list_body(pTHX_ va_list args);
+#endif
# if defined(USE_THREADS)
STATIC struct perl_thread * S_init_main_thread(pTHX);
# endif
@@ -1032,7 +1039,10 @@
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
STATIC OP* S_docatch(pTHX_ OP *o);
-STATIC void* S_docatch_body(pTHX_ va_list args);
+STATIC void* S_docatch_body(pTHX);
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
+STATIC void* S_vdocatch_body(pTHX_ va_list args);
+#endif
STATIC OP* S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit);
STATIC void S_doparseform(pTHX_ SV *sv);
STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock);
==== //depot/perl/scope.c#64 (text) ====
Index: perl/scope.c
--- perl/scope.c.~1~ Sun Feb 20 13:22:33 2000
+++ perl/scope.c Sun Feb 20 13:22:33 2000
@@ -16,6 +16,7 @@
#define PERL_IN_SCOPE_C
#include "perl.h"
+#if defined(PERL_FLEXIBLE_EXCEPTIONS)
void *
Perl_default_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
protect_body_t body, ...)
@@ -36,8 +37,6 @@
int ex;
void *ret;
- DEBUG_l(Perl_deb(aTHX_ "Setting up local jumplevel %p, was %p\n",
- pcur_env, PL_top_env));
JMPENV_PUSH(ex);
if (ex)
ret = NULL;
@@ -47,6 +46,7 @@
JMPENV_POP;
return ret;
}
+#endif
SV**
Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
==== //depot/perl/scope.h#42 (text) ====
Index: perl/scope.h
--- perl/scope.h.~1~ Sun Feb 20 13:22:33 2000
+++ perl/scope.h Sun Feb 20 13:22:33 2000
@@ -193,19 +193,21 @@
Sigjmp_buf je_buf; /* only for use if !je_throw */
int je_ret; /* last exception thrown */
bool je_mustcatch; /* need to call longjmp()? */
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
void (*je_throw)(int v); /* last for bincompat */
bool je_noset; /* no need for setjmp() */
+#endif
};
typedef struct jmpenv JMPENV;
-/*
- * Function that catches/throws, and its callback for the
- * body of protected processing.
- */
-typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list);
-typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
- int *, protect_body_t, ...);
+#ifdef OP_IN_REGISTER
+#define OP_REG_TO_MEM PL_opsave = op
+#define OP_MEM_TO_REG op = PL_opsave
+#else
+#define OP_REG_TO_MEM NOOP
+#define OP_MEM_TO_REG NOOP
+#endif
/*
* How to build the first jmpenv.
@@ -219,21 +221,13 @@
#define JMPENV_BOOTSTRAP \
STMT_START { \
- PL_start_env.je_prev = NULL; \
- PL_start_env.je_throw = NULL; \
+ Zero(&PL_start_env, 1, JMPENV); \
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
-#ifdef OP_IN_REGISTER
-#define OP_REG_TO_MEM PL_opsave = op
-#define OP_MEM_TO_REG op = PL_opsave
-#else
-#define OP_REG_TO_MEM NOOP
-#define OP_MEM_TO_REG NOOP
-#endif
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
/*
* These exception-handling macros are split up to
@@ -265,6 +259,14 @@
* JMPENV_POP; // don't forget this!
*/
+/*
+ * Function that catches/throws, and its callback for the
+ * body of protected processing.
+ */
+typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list);
+typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
+ int *, protect_body_t, ...);
+
#define dJMPENV JMPENV cur_env; \
volatile JMPENV *pcur_env = ((cur_env.je_noset = 0),&cur_env)
@@ -288,10 +290,11 @@
#define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(*(JMPENV*)pcur_env)
-
#define JMPENV_PUSH_ENV(ce,v) \
STMT_START { \
if (!(ce).je_noset) { \
+ DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
+ ce, PL_top_env)); \
JMPENV_PUSH_INIT_ENV(ce,NULL); \
EXCEPT_SET_ENV(ce,PerlProc_setjmp((ce).je_buf, 1));\
(ce).je_noset = 1; \
@@ -305,7 +308,10 @@
#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v)
#define JMPENV_POP_ENV(ce) \
- STMT_START { PL_top_env = (ce).je_prev; } STMT_END
+ STMT_START { \
+ if (PL_top_env == &(ce)) \
+ PL_top_env = (ce).je_prev; \
+ } STMT_END
#define JMPENV_POP JMPENV_POP_ENV(*(JMPENV*)pcur_env)
@@ -329,5 +335,38 @@
#define EXCEPT_SET_ENV(ce,v) ((ce).je_ret = (v))
#define EXCEPT_SET(v) EXCEPT_SET_ENV(*(JMPENV*)pcur_env,v)
+#else /* !PERL_FLEXIBLE_EXCEPTIONS */
+
+#define dJMPENV JMPENV cur_env
+
+#define JMPENV_PUSH(v) \
+ STMT_START { \
+ DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
+ &cur_env, PL_top_env)); \
+ cur_env.je_prev = PL_top_env; \
+ OP_REG_TO_MEM; \
+ cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1); \
+ OP_MEM_TO_REG; \
+ PL_top_env = &cur_env; \
+ cur_env.je_mustcatch = FALSE; \
+ (v) = cur_env.je_ret; \
+ } STMT_END
+
+#define JMPENV_POP \
+ STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
+
+#define JMPENV_JUMP(v) \
+ STMT_START { \
+ OP_REG_TO_MEM; \
+ if (PL_top_env->je_prev) \
+ PerlProc_longjmp(PL_top_env->je_buf, (v)); \
+ if ((v) == 2) \
+ PerlProc_exit(STATUS_NATIVE_EXPORT); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
+ PerlProc_exit(1); \
+ } STMT_END
+
+#endif /* PERL_FLEXIBLE_EXCEPTIONS */
+
#define CATCH_GET (PL_top_env->je_mustcatch)
#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
==== //depot/perl/sv.c#206 (text) ====
Index: perl/sv.c
--- perl/sv.c.~1~ Sun Feb 20 13:22:33 2000
+++ perl/sv.c Sun Feb 20 13:22:33 2000
@@ -107,7 +107,7 @@
SV* sva = (SV*)ptr;
register SV* sv;
register SV* svend;
- Zero(sva, size, char);
+ Zero(ptr, size, char);
/* The first SV in an arena isn't an SV. */
SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
@@ -7853,7 +7853,9 @@
PL_dirty = proto_perl->Tdirty;
PL_localizing = proto_perl->Tlocalizing;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = proto_perl->Tprotect;
+#endif
PL_errors = sv_dup_inc(proto_perl->Terrors);
PL_av_fetch_sv = Nullsv;
PL_hv_fetch_sv = Nullsv;
==== //depot/perl/thrdvar.h#37 (text) ====
Index: perl/thrdvar.h
--- perl/thrdvar.h.~1~ Sun Feb 20 13:22:33 2000
+++ perl/thrdvar.h Sun Feb 20 13:22:33 2000
@@ -10,10 +10,7 @@
*
* When building without USE_THREADS, these variables will be truly global.
* When building without USE_THREADS but with MULTIPLICITY, these variables
- * will be global per-interpreter.
- *
- * Avoid build-specific #ifdefs here, like DEBUGGING. That way,
- * we can keep binary compatibility of the curinterp structure */
+ * will be global per-interpreter. */
/* Important ones in the first cache line (if alignment is done right) */
@@ -112,7 +109,9 @@
PERLVAR(Ttop_env, JMPENV *) /* ptr. to current sigjmp() environment */
PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
PERLVARI(Tprotect, protect_proc_t, MEMBER_TO_FPTR(Perl_default_protect))
+#endif
PERLVARI(Terrors, SV *, Nullsv) /* outstanding queued errors */
/* statics "owned" by various functions */
==== //depot/perl/util.c#175 (text) ====
Index: perl/util.c
--- perl/util.c.~1~ Sun Feb 20 13:22:33 2000
+++ perl/util.c Sun Feb 20 13:22:33 2000
@@ -3488,7 +3488,9 @@
/* parent thread's data needs to be locked while we make copy */
MUTEX_LOCK(&t->mutex);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = t->Tprotect;
+#endif
PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
PL_defstash = t->Tdefstash; /* XXX maybe these should */
End of Patch. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Migrated from rt.perl.org#2149 (status was 'resolved')
Searchable as RT2149$
The text was updated successfully, but these errors were encountered: