/* cop.h
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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.
*
- * Control ops (cops) are one of the three ops OP_NEXTSTATE, OP_DBSTATE,
- * and OP_SETSTATE that (loosely speaking) are separate statements.
+ * Control ops (cops) are one of the two ops OP_NEXTSTATE and OP_DBSTATE,
+ * that (loosely speaking) are separate statements.
* They hold information important for lexical state and error reporting.
* At run time, PL_curcop is set to point to the most recently executed cop,
* 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.
+ * Note that there is a PL_start_env initialized when perl starts, and
+ * PL_top_env points to this initially, so PL_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
+ * Existence of a non-null PL_top_env->je_prev implies it is valid to call
+ * longjmp() at that runlevel (we make sure PL_start_env.je_prev is always
* null to ensure this).
*
* je_mustcatch, when set at any runlevel to TRUE, means eval ops must
#define JMPENV_PUSH(v) \
STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
- (void*)&cur_env, (void*)PL_top_env)); \
+ DEBUG_l({ \
+ int i = 0; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
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); \
#define JMPENV_POP \
STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n", \
- (void*)PL_top_env, (void*)cur_env.je_prev)); \
+ DEBUG_l({ \
+ int i = -1; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
+ assert(PL_top_env == &cur_env); \
PL_top_env = cur_env.je_prev; \
} STMT_END
#define JMPENV_JUMP(v) \
STMT_START { \
+ DEBUG_l({ \
+ int i = -1; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \
+ (int)v, i, __FILE__, __LINE__);}) \
OP_REG_TO_MEM; \
if (PL_top_env->je_prev) \
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
} STMT_END
#define CATCH_GET (PL_top_env->je_mustcatch)
-#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
+#define CATCH_SET(v) \
+ STMT_START { \
+ DEBUG_l( \
+ Perl_deb(aTHX_ \
+ "JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \
+ PL_top_env->je_mustcatch, v, (void*)PL_top_env, \
+ __FILE__, __LINE__);) \
+ PL_top_env->je_mustcatch = (v); \
+ } STMT_END
#include "mydtrace.h"
/* On LP64 putting this here takes advantage of the fact that BASEOP isn't
an exact multiple of 8 bytes to save structure padding. */
line_t cop_line; /* line # of this command */
- char * cop_label; /* label for this construct */
+ /* label for this construct is now stored in cop_hints_hash */
#ifdef USE_ITHREADS
char * cop_stashpv; /* package line was compiled in */
char * cop_file; /* file name the following line # is from */
? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL)
# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL)
# define CopSTASH_eq(c,hv) ((hv) && stashpv_hvname_match(c,hv))
-# define CopLABEL(c) ((c)->cop_label)
-# define CopLABEL_set(c,pv) (CopLABEL(c) = (pv))
# ifdef NETWARE
# define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
# define CopFILE_free(c) SAVECOPFILE_FREE(c)
-# define CopLABEL_free(c) SAVESHAREDPV(CopLABEL(c))
-# define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
# else
# define CopSTASH_free(c) PerlMemShared_free(CopSTASHPV(c))
# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
-# define CopLABEL_free(c) (PerlMemShared_free(CopLABEL(c)),(CopLABEL(c) = NULL))
-# define CopLABEL_alloc(pv) ((pv)?savesharedpv(pv):NULL)
# endif
#else
# define CopFILEGV(c) ((c)->cop_filegv)
# define CopFILE(c) (CopFILEGV(c) && GvSV(CopFILEGV(c)) \
? SvPVX(GvSV(CopFILEGV(c))) : NULL)
# define CopSTASH(c) ((c)->cop_stash)
-# define CopLABEL(c) ((c)->cop_label)
# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
/* cop_stash is not refcounted */
# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
-# define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
-# define CopLABEL_set(c,pv) (CopLABEL(c) = (pv))
# define CopSTASH_free(c)
# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
-# define CopLABEL_free(c) (Safefree(CopLABEL(c)),(CopLABEL(c) = NULL))
#endif /* USE_ITHREADS */
+#define CopLABEL(c) Perl_fetch_cop_label(aTHX_ (c)->cop_hints_hash, NULL, NULL)
+#define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
#define CopLINE(c) ((c)->cop_line)
#define CopLINE_set(c,l) (CopLINE(c) = (l))
/* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
-#ifdef MACOS_TRADITIONAL
-# define OutCopFILE(c) MacPerl_MPWFileName(CopFILE(c))
-#else
-# define OutCopFILE(c) CopFILE(c)
-#endif
+#define OutCopFILE(c) CopFILE(c)
/* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
HINT_ARYBASE is set to indicate this.
#define CopARYBASE_set(c, b) STMT_START { \
if (b || ((c)->cop_hints & HINT_ARYBASE)) { \
(c)->cop_hints |= HINT_ARYBASE; \
- if ((c) == &PL_compiling) \
- PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE; \
- (c)->cop_hints_hash \
- = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash, \
+ if ((c) == &PL_compiling) { \
+ SV *val = newSViv(b); \
+ (void)hv_stores(GvHV(PL_hintgv), "$[", val); \
+ mg_set(val); \
+ PL_hints |= HINT_ARYBASE; \
+ } else { \
+ (c)->cop_hints_hash \
+ = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash, \
newSVpvs_flags("$[", SVs_TEMP), \
sv_2mortal(newSViv(b))); \
+ } \
} \
} STMT_END
#define PUSHSUB_BASE(cx) \
ENTRY_PROBE(GvENAME(CvGV(cv)), \
- CopFILE((COP*)CvSTART(cv)), \
- CopLINE((COP*)CvSTART(cv))); \
+ CopFILE((const COP *)CvSTART(cv)), \
+ CopLINE((const COP *)CvSTART(cv))); \
\
cx->blk_sub.cv = cv; \
cx->blk_sub.olddepth = CvDEPTH(cv); \
#define POPSUB(cx,sv) \
STMT_START { \
- RETURN_PROBE(GvENAME(CvGV((CV*)cx->blk_sub.cv)), \
- CopFILE((COP*)CvSTART((CV*)cx->blk_sub.cv)), \
- CopLINE((COP*)CvSTART((CV*)cx->blk_sub.cv))); \
+ RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)), \
+ CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \
+ CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \
\
if (CxHASARGS(cx)) { \
POP_SAVEARRAY(); \
cx->blk_sub.argarray = newAV(); \
av_extend(cx->blk_sub.argarray, fill); \
AvREIFY_only(cx->blk_sub.argarray); \
- CX_CURPAD_SV(cx->blk_sub, 0) = (SV*)cx->blk_sub.argarray; \
+ CX_CURPAD_SV(cx->blk_sub, 0) = MUTABLE_SV(cx->blk_sub.argarray); \
} \
else { \
CLEAR_ARGARRAY(cx->blk_sub.argarray); \
} \
} \
- sv = (SV*)cx->blk_sub.cv; \
- if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth)) \
+ sv = MUTABLE_SV(cx->blk_sub.cv); \
+ if (sv && (CvDEPTH((const CV*)sv) = cx->blk_sub.olddepth)) \
sv = NULL; \
} STMT_END
# define CX_ITERDATA_SET(cx,ivar,o) \
cx->blk_loop.itervar = (SV**)(ivar);
#endif
-#define CxLABEL(c) (0 + (c)->blk_oldcop->cop_label)
+#define CxLABEL(c) (0 + CopLABEL((c)->blk_oldcop))
#define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
#define CxLVAL(c) (0 + (c)->blk_u16)
#define blk_loop cx_u.cx_blk.blk_u.blku_loop
#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
+#define DEBUG_CX(action) \
+ DEBUG_l( \
+ Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) at %s:%d\n", \
+ (long)cxstack_ix, \
+ action, \
+ PL_block_type[CxTYPE(&cxstack[cxstack_ix])], \
+ (long)PL_scopestack_ix, \
+ (long)(cxstack[cxstack_ix].blk_oldscopesp), \
+ __FILE__, __LINE__));
+
/* Enter a block. */
#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
cx->cx_type = t, \
cx->blk_oldscopesp = PL_scopestack_ix, \
cx->blk_oldpm = PL_curpm, \
cx->blk_gimme = (U8)gimme; \
- DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
- (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
+ DEBUG_CX("PUSH");
/* Exit a block (RETURN and LAST). */
-#define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \
+#define POPBLOCK(cx,pm) \
+ DEBUG_CX("POP"); \
+ cx = &cxstack[cxstack_ix--], \
newsp = PL_stack_base + cx->blk_oldsp, \
PL_curcop = cx->blk_oldcop, \
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
pm = cx->blk_oldpm, \
- gimme = cx->blk_gimme; \
- DEBUG_SCOPE("POPBLOCK"); \
- DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n", \
- (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
+ gimme = cx->blk_gimme;
/* Continue a block elsewhere (NEXT and REDO). */
-#define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \
+#define TOPBLOCK(cx) \
+ DEBUG_CX("TOP"); \
+ cx = &cxstack[cxstack_ix], \
PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
- PL_curpm = cx->blk_oldpm; \
- DEBUG_SCOPE("TOPBLOCK");
+ PL_curpm = cx->blk_oldpm;
/* substitution context */
struct subst {
#define sb_rxres cx_u.cx_subst.sbu_rxres
#define sb_rx cx_u.cx_subst.sbu_rx
-#define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
+#ifdef PERL_CORE
+# define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
cx->sb_iters = iters, \
cx->sb_maxiters = maxiters, \
cx->sb_rflags = r_flags, \
rxres_save(&cx->sb_rxres, rx); \
(void)ReREFCNT_inc(rx)
-#define CxONCE(cx) ((cx)->cx_type & CXp_ONCE)
-
-#define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \
+# define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \
rxres_free(&cx->sb_rxres); \
ReREFCNT_dec(cx->sb_rx)
+#endif
+
+#define CxONCE(cx) ((cx)->cx_type & CXp_ONCE)
struct context {
union {
#define CxFOREACHDEF(c) ((CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN) \
&& ((c)->cx_type & CXp_FOR_DEF))
-#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
+#define CXINC ((cxstack_ix + 1) < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
/*
=head1 "Gimme" Values
hash actions codes defined in hv.h */
#define G_EVAL 8 /* Assume eval {} around subroutine call. */
#define G_NOARGS 16 /* Don't construct a @_ array. */
-#define G_KEEPERR 32 /* Append errors to $@, don't overwrite it */
+#define G_KEEPERR 32 /* Warn for errors, don't overwrite $@ */
#define G_NODEBUG 64 /* Disable debugging at toplevel. */
#define G_METHOD 128 /* Calling method. */
#define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or
fold_constants. */
+#define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef
+ A special case for UNSHIFT in
+ Perl_magic_methcall(). */
/* flag bits for PL_in_eval */
#define EVAL_NULL 0 /* not in an eval */
#define PUSHSTACKi(type) \
STMT_START { \
PERL_SI *next = PL_curstackinfo->si_next; \
+ DEBUG_l({ \
+ int i = 0; PERL_SI *p = PL_curstackinfo; \
+ while (p) { i++; p = p->si_prev; } \
+ Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
if (!next) { \
next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
next->si_prev = PL_curstackinfo; \
STMT_START { \
dSP; \
PERL_SI * const prev = PL_curstackinfo->si_prev; \
+ DEBUG_l({ \
+ int i = -1; PERL_SI *p = PL_curstackinfo; \
+ while (p) { i++; p = p->si_prev; } \
+ Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
if (!prev) { \
PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); \
my_exit(1); \
multicall_oldcatch = CATCH_GET; \
SAVETMPS; SAVEVPTR(PL_op); \
CATCH_SET(TRUE); \
+ PUSHSTACKi(PERLSI_SORT); \
PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp); \
PUSHSUB(cx); \
if (++CvDEPTH(cv) >= 2) { \
LEAVESUB(multicall_cv); \
CvDEPTH(multicall_cv)--; \
POPBLOCK(cx,PL_curpm); \
+ POPSTACK; \
CATCH_SET(multicall_oldcatch); \
LEAVE; \
+ SPAGAIN; \
} STMT_END
/*
https://perl5.git.perl.org / perl5.git / blobdiff