Perl / perl5

🐪 The Perl programming language
https://dev.perl.org/perl5/
Other
1.85k stars 527 forks source link

inhibit_exit in debugger not working when embedding perl5.5.650 #1179

Closed p5pRT closed 20 years ago

p5pRT commented 24 years ago

Migrated from rt.perl.org#2149 (status was 'resolved')

Searchable as RT2149$

p5pRT commented 24 years ago

From EFifer@sanwaint.com

This is a bug report for perl from efifer@​sanwaint.com\, generated with the help of perlbug 1.27 running under perl v5.5.650.


This is a simple example of an embedded perl interpreter​:

  #include \<EXTERN.h>   #include \<perl.h>   #include "XSUB.h"

  static PerlInterpreter *my_perl;

  int main(int argc\, char **argv\, char **env)   {   SV *sv;

  my_perl = perl_alloc();   perl_construct(my_perl);   perl_parse(my_perl\, NULL\, argc\, argv\, (char **)NULL);   perl_run(my_perl);

  perl_call_pv("xxx"\, G_DISCARD);

  perl_destruct(my_perl);   perl_free(my_perl);   }

Sometime since perl5.005_03 "inhibit_exit" in the debugger stopped working. With perl5.005_03 using this xxx.pl script\,

  print "hello\n";

  sub xxx {   print "xxx\n";   }

I have a debugging session like​:

  % ./interp -I../perl5.005_03/lib -d xxx.pl

  Loading DB routines from perl5db.pl version 1.0402   Emacs support available.

  Enter h or `h h' for help.

  main​::(xxx.pl​:1)​: print "hello\n";   DB\<1> b xxx   DB\<2> c   hello   Debugged program terminated. Use q to quit or R to restart\,   use O inhibit_exit to avoid stopping after program termination\,   h q\, h R or h O to get additional info.
  DB\<2> O inhibit_exit   inhibit_exit = '1'   DB\<3> q   main​::xxx(xxx.pl​:4)​: print "xxx\n";   DB\<3> $DB​::finished = 0

  DB\<4> c   xxx

However\, with perl5.5.650 the call to perl_run exits without ever returning (so perl_call_pv never occurs)​:

  % ./interp -I../perl5.5.650/lib -d xxx.pl

  Loading DB routines from perl5db.pl version 1.05   Emacs support available.

  Enter h or `h h' for help\, run `perldoc perldebug' for more help.

  main​::(xxx.pl​:1)​: print "hello\n";   DB\<1> b xxx   DB\<2> c   hello   Debugged program terminated. Use q to quit or R to restart\,   use O inhibit_exit to avoid stopping after program termination\,   h q\, h R or h O to get additional info.
  DB\<2> O inhibit_exit   inhibit_exit = '1'   DB\<3> q

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​:   Platform​:   osname=solaris\, osvers=2.6\, archname=sun4-solaris   uname='sunos ecd1 5.6 generic_105181-14 sun4u sparc sunw\,ultra-4 '   config_args=''   hint=recommended\, useposix=true\, d_sigaction=define   usethreads=undef use5005threads=undef useithreads=undef   usesocks=undef useperlio=undef d_sfio=undef   use64bits=undef uselargefiles=define usemultiplicity=undef   Compiler​:   cc='gcc'\, optimize='-g'\, gccversion=egcs-2.91.66 19990314 (egcs-1.1.2 release)   cppflags='-DDEBUGGING -fno-strict-aliasing'   ccflags ='-DDEBUGGING -fno-strict-aliasing -DUSE_LONG_LONG -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'   stdchar='unsigned char'\, d_stdstdio=define\, usevfork=false   intsize=4\, longsize=4\, ptrsize=4\, doublesize=8   d_longlong=define\, longlongsize=8\, d_longdbl=define\, longdblsize=16   alignbytes=8\, usemymalloc=y\, prototype=define   Linker and Libraries​:   ld='gcc'\, ldflags =' -L/usr/local/lib '   libpth=/usr/local/lib /lib /usr/lib /usr/ccs/lib   libs=-lsocket -lnsl -ldl -lm -lc -lcrypt -lsec   libc=/lib/libc.so\, so=so\, useshrplib=false\, libperl=libperl.a   Dynamic Linking​:   dlsrc=dl_dlopen.xs\, dlext=so\, d_dlsymun=undef\, ccdlflags=' '   cccdlflags='-fPIC'\, lddlflags='-G -L/usr/local/lib'

Locally applied patches​:  


@​INC for perl v5.5.650​:   ./lib   /usr/local/lib/perl5/5.5.650/sun4-solaris   /usr/local/lib/perl5/5.5.650   /usr/local/lib/perl5/site_perl   .


Environment for perl v5.5.650​:   HOME=/home/localhost/users/fifere   LANG (unset)   LANGUAGE (unset)   LD_LIBRARY_PATH=/opt/convertibles/lib   LOGDIR (unset)

PATH=/usr/share/local/bin​:/usr/local/bin​:/opt/sybase/bin​:/opt/perl/share/bin :/opt/perl/sparc-SunOS-5/bin​:/opt/enscript/sparc-SunOS-5/bin​:/opt/convertibl es​:/opt/top/sparc-SunOS-5/bin​:/opt/screen/sparc-SunOS-5/bin​:/opt/egcs/sparc- SunOS-5/bin​:/opt/make/sparc-SunOS-5/bin​:/opt/FSFgzip/bin​:/usr/ccs/bin​:/usr/o pt/SUNWmd/sbin​:/usr/openwin/bin​:/usr/sbin​:/usr/bin   PERL_BADLANG (unset)   SHELL=/bin/csh

p5pRT commented 24 years ago

From @gsar

On Tue\, 15 Feb 2000 11​:30​:14 GMT\, "Fifer\, Eric" wrote​:

This is a bug report for perl from efifer@​sanwaint.com\, generated with the help of perlbug 1.27 running under perl v5.5.650. [...] However\, with perl5.5.650 the call to perl_run exits without ever returning (so perl_call_pv never occurs)​:

This is a known bug\, that I mentioned in the 640 announcement. It was introduce by change#3386​:

  [ 3386] By​: gsar on 1999/05/11 02​:49​:07   Log​: gutsupport for C++ exceptions   From​: Chip Salzenberg \chip@&#8203;perlsupport\.com   Date​: Tue\, 9 Mar 1999 11​:51​:57 -0500   Message-ID​: \19990309115157\.E7911@&#8203;perlsupport\.com   Subject​: [PATCH 5.005] Flexible Exceptions   Branch​: perl   ! embed.h global.sym objXSUB.h perl.c perl.h pp_ctl.c proto.h   ! scope.c scope.h thrdvar.h util.c

The problem is that some of the code in perl_run() can now execute outside the setjmp() block (such as END{} blocks) and any exceptions that happen there will basically longjmp() out of perl_run() rather than making it return as it used to.

We basically need to make the C++ exception support a build-time option and go back to setting up the setjmp() at the perl_run() level. Patches welcome.

Sarathy gsar@​ActiveState.com

p5pRT commented 24 years ago

From @gsar

On Tue\, 15 Feb 2000 07​:05​:43 PST\, I wrote​:

We basically need to make the C++ exception support a build-time option and go back to setting up the setjmp() at the perl_run() level. Patches welcome.

You may want to try this fix.

Sarathy gsar@​ActiveState.com

Inline Patch ```diff -----------------------------------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. ```