X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b4ab917c3d812d8e61d365bfa48d9bf7675bc113..0d2925a66a645be5c94e85ffc665c445ed1ca94c:/cop.h diff --git a/cop.h b/cop.h index 04eb7c0..172c265 100644 --- a/cop.h +++ b/cop.h @@ -1,7 +1,7 @@ /* cop.h * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -13,6 +13,126 @@ * and thus can be used to determine our current state. */ +/* A jmpenv packages the state required to perform a proper non-local jump. + * Note that there is a start_env initialized when perl starts, and top_env + * points to this initially, so top_env should always be non-null. + * + * Existence of a non-null top_env->je_prev implies it is valid to call + * longjmp() at that runlevel (we make sure start_env.je_prev is always + * null to ensure this). + * + * je_mustcatch, when set at any runlevel to TRUE, means eval ops must + * establish a local jmpenv to handle exception traps. Care must be taken + * to restore the previous value of je_mustcatch before exiting the + * stack frame iff JMPENV_PUSH was not called in that stack frame. + * GSAR 97-03-27 + */ + +struct jmpenv { + struct jmpenv * je_prev; + Sigjmp_buf je_buf; /* only for use if !je_throw */ + int je_ret; /* last exception thrown */ + bool je_mustcatch; /* need to call longjmp()? */ +}; + +typedef struct jmpenv JMPENV; + +#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. + * + * top_env needs to be non-zero. It points to an area + * in which longjmp() stuff is stored, as C callstack + * info there at least is thread specific this has to + * be per-thread. Otherwise a 'die' in a thread gives + * that thread the C stack of last thread to do an eval {}! + */ + +#define JMPENV_BOOTSTRAP \ + STMT_START { \ + Zero(&PL_start_env, 1, JMPENV); \ + PL_start_env.je_ret = -1; \ + PL_start_env.je_mustcatch = TRUE; \ + PL_top_env = &PL_start_env; \ + } STMT_END + +/* + * PERL_FLEXIBLE_EXCEPTIONS + * + * All the flexible exceptions code has been removed. + * See the following threads for details: + * + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html + * + * Joshua's original patches (which weren't applied) and discussion: + * + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html + * + * Chip's reworked patch and discussion: + * + * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html + * + * The flaw in these patches (which went unnoticed at the time) was + * that they moved some code that could potentially die() out of the + * region protected by the setjmp()s. This caused exceptions within + * END blocks and such to not be handled by the correct setjmp(). + * + * The original patches that introduces flexible exceptions were: + * + * http://public.activestate.com/cgi-bin/perlbrowse?patch=3386 + * http://public.activestate.com/cgi-bin/perlbrowse?patch=5162 + */ + +#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, SCOPE_SAVES_SIGNAL_MASK); \ + 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 { \ + DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n", \ + PL_top_env, cur_env.je_prev)); \ + 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 + +#define CATCH_GET (PL_top_env->je_mustcatch) +#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v)) + + + struct cop { BASEOP char * cop_label; /* label for this construct */ @@ -37,11 +157,11 @@ struct cop { # define CopFILEGV(c) (CopFILE(c) \ ? gv_fetchfile(CopFILE(c)) : Nullgv) - #ifdef NETWARE - #define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) - #else - #define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv)) - #endif +# ifdef NETWARE +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +# else +# define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv)) +# endif # define CopFILESV(c) (CopFILE(c) \ ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) @@ -49,11 +169,11 @@ struct cop { ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) # define CopSTASHPV(c) ((c)->cop_stashpv) - #ifdef NETWARE - #define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) - #else - #define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv)) - #endif +# ifdef NETWARE +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +# else +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv)) +# endif # define CopSTASH(c) (CopSTASHPV(c) \ ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) @@ -62,17 +182,17 @@ struct cop { && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) - #ifdef NETWARE - #define CopSTASH_free(c) SAVECOPSTASH_FREE(c) - #else - #define CopSTASH_free(c) PerlMemShared_free(CopSTASHPV(c)) - #endif - - #ifdef NETWARE - #define CopFILE_free(c) SAVECOPFILE_FREE(c) - #else - #define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = Nullch)) - #endif +# ifdef NETWARE +# define CopSTASH_free(c) SAVECOPSTASH_FREE(c) +# else +# define CopSTASH_free(c) PerlMemShared_free(CopSTASHPV(c)) +# endif + +# ifdef NETWARE +# define CopFILE_free(c) SAVECOPFILE_FREE(c) +# else +# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = Nullch)) +# endif #else # define CopFILEGV(c) ((c)->cop_filegv) # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) @@ -119,13 +239,24 @@ struct block_sub { U8 hasargs; U8 lval; /* XXX merge lval and hasargs? */ PAD *oldcomppad; + OP * retop; /* op to execute on exit from sub */ }; -/* base for the next two macros. Don't use directly */ +/* base for the next two macros. Don't use directly. + * Note that the refcnt of the cv is incremented twice; The CX one is + * decremented by LEAVESUB, the other by LEAVE. */ + #define PUSHSUB_BASE(cx) \ cx->blk_sub.cv = cv; \ cx->blk_sub.olddepth = CvDEPTH(cv); \ - cx->blk_sub.hasargs = hasargs; + cx->blk_sub.hasargs = hasargs; \ + cx->blk_sub.retop = Nullop; \ + if (!CvDEPTH(cv)) { \ + (void)SvREFCNT_inc(cv); \ + (void)SvREFCNT_inc(cv); \ + SAVEFREESV(cv); \ + } + #define PUSHSUB(cx) \ PUSHSUB_BASE(cx) \ @@ -141,6 +272,7 @@ struct block_sub { #define PUSHFORMAT(cx) \ cx->blk_sub.cv = cv; \ cx->blk_sub.gv = gv; \ + cx->blk_sub.retop = Nullop; \ cx->blk_sub.hasargs = 0; \ cx->blk_sub.dfoutgv = PL_defoutgv; \ (void)SvREFCNT_inc(cx->blk_sub.dfoutgv) @@ -156,7 +288,7 @@ struct block_sub { #define CLEAR_ARGARRAY(ary) \ STMT_START { \ AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \ - SvPVX(ary) = (char*)AvALLOC(ary); \ + SvPV_set(ary, (char*)AvALLOC(ary)); \ AvFILLp(ary) = -1; \ } STMT_END @@ -200,6 +332,7 @@ struct block_eval { OP * old_eval_root; SV * cur_text; CV * cv; + OP * retop; /* op to execute on exit from eval */ }; #define PUSHEVAL(cx,n,fgv) \ @@ -210,6 +343,7 @@ struct block_eval { cx->blk_eval.old_eval_root = PL_eval_root; \ cx->blk_eval.cur_text = PL_linestr; \ cx->blk_eval.cv = Nullcv; /* set by doeval(), as applicable */ \ + cx->blk_eval.retop = Nullop; \ } STMT_END #define POPEVAL(cx) \ @@ -289,7 +423,6 @@ struct block_loop { struct block { I32 blku_oldsp; /* stack pointer to copy stuff down to */ COP * blku_oldcop; /* old curcop pointer */ - I32 blku_oldretsp; /* return stack index */ I32 blku_oldmarksp; /* mark stack index */ I32 blku_oldscopesp; /* scope stack index */ PMOP * blku_oldpm; /* values of pattern match vars */ @@ -303,7 +436,6 @@ struct block { }; #define blk_oldsp cx_u.cx_blk.blku_oldsp #define blk_oldcop cx_u.cx_blk.blku_oldcop -#define blk_oldretsp cx_u.cx_blk.blku_oldretsp #define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp #define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp #define blk_oldpm cx_u.cx_blk.blku_oldpm @@ -319,7 +451,6 @@ struct block { cx->blk_oldcop = PL_curcop, \ cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \ cx->blk_oldscopesp = PL_scopestack_ix, \ - cx->blk_oldretsp = PL_retstack_ix, \ cx->blk_oldpm = PL_curpm, \ cx->blk_gimme = (U8)gimme; \ DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \ @@ -331,7 +462,6 @@ struct block { PL_curcop = cx->blk_oldcop, \ PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \ PL_scopestack_ix = cx->blk_oldscopesp, \ - PL_retstack_ix = cx->blk_oldretsp, \ pm = cx->blk_oldpm, \ gimme = cx->blk_gimme; \ DEBUG_SCOPE("POPBLOCK"); \ @@ -343,7 +473,6 @@ struct block { PL_stack_sp = PL_stack_base + cx->blk_oldsp, \ PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \ PL_scopestack_ix = cx->blk_oldscopesp, \ - PL_retstack_ix = cx->blk_oldretsp, \ PL_curpm = cx->blk_oldpm; \ DEBUG_SCOPE("TOPBLOCK"); @@ -572,3 +701,7 @@ typedef struct stackinfo PERL_SI; POPSTACK; \ } \ } STMT_END + +#define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#define IN_PERL_RUNTIME (PL_curcop != &PL_compiling) +