*/
/* 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
*
* 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
+ * http://perl5.git.perl.org/perl.git/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929
+ * http://perl5.git.perl.org/perl.git/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a
+ *
*/
#define dJMPENV JMPENV cur_env
#define JMPENV_PUSH(v) \
STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p at %s:%d\n", \
- (void*)&cur_env, (void*)PL_top_env, \
- __FILE__, __LINE__)); \
+ 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 at %s:%d\n", \
- (void*)PL_top_env, (void*)cur_env.je_prev, \
- __FILE__, __LINE__)); \
+ 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
+
+/*
+=head1 COP Hint Hashes
+*/
+
+typedef struct refcounted_he COPHH;
+
+#define COPHH_KEY_UTF8 REFCOUNTED_HE_KEY_UTF8
+
+/*
+=for apidoc Amx|SV *|cophh_fetch_pvn|const COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags
+
+Look up the entry in the cop hints hash I<cophh> with the key specified by
+I<keypv> and I<keylen>. If I<flags> has the C<COPHH_KEY_UTF8> bit set,
+the key octets are interpreted as UTF-8, otherwise they are interpreted
+as Latin-1. I<hash> is a precomputed hash of the key string, or zero if
+it has not been precomputed. Returns a mortal scalar copy of the value
+associated with the key, or C<&PL_sv_placeholder> if there is no value
+associated with the key.
+
+=cut
+*/
+
+#define cophh_fetch_pvn(cophh, keypv, keylen, hash, flags) \
+ Perl_refcounted_he_fetch_pvn(aTHX_ cophh, keypv, keylen, hash, flags)
+
+/*
+=for apidoc Amx|SV *|cophh_fetch_pvs|const COPHH *cophh|const char *key|U32 flags
+
+Like L</cophh_fetch_pvn>, but takes a literal string instead of a
+string/length pair, and no precomputed hash.
+
+=cut
+*/
+
+#define cophh_fetch_pvs(cophh, key, flags) \
+ Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, flags)
+
+/*
+=for apidoc Amx|SV *|cophh_fetch_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags
+Like L</cophh_fetch_pvn>, but takes a nul-terminated string instead of
+a string/length pair.
+
+=cut
+*/
+
+#define cophh_fetch_pv(cophh, key, hash, flags) \
+ Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, flags)
+
+/*
+=for apidoc Amx|SV *|cophh_fetch_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags
+
+Like L</cophh_fetch_pvn>, but takes a Perl scalar instead of a
+string/length pair.
+
+=cut
+*/
+
+#define cophh_fetch_sv(cophh, key, hash, flags) \
+ Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, flags)
+
+/*
+=for apidoc Amx|HV *|cophh_2hv|const COPHH *cophh|U32 flags
+
+Generates and returns a standard Perl hash representing the full set of
+key/value pairs in the cop hints hash I<cophh>. I<flags> is currently
+unused and must be zero.
+
+=cut
+*/
+
+#define cophh_2hv(cophh, flags) \
+ Perl_refcounted_he_chain_2hv(aTHX_ cophh, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_copy|COPHH *cophh
+
+Make and return a complete copy of the cop hints hash I<cophh>.
+
+=cut
+*/
+
+#define cophh_copy(cophh) Perl_refcounted_he_inc(aTHX_ cophh)
+
+/*
+=for apidoc Amx|void|cophh_free|COPHH *cophh
+
+Discard the cop hints hash I<cophh>, freeing all resources associated
+with it.
+
+=cut
+*/
+
+#define cophh_free(cophh) Perl_refcounted_he_free(aTHX_ cophh)
+
+/*
+=for apidoc Amx|COPHH *|cophh_new_empty
+
+Generate and return a fresh cop hints hash containing no entries.
+
+=cut
+*/
+
+#define cophh_new_empty() ((COPHH *)NULL)
+
+/*
+=for apidoc Amx|COPHH *|cophh_store_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
+
+Stores a value, associated with a key, in the cop hints hash I<cophh>,
+and returns the modified hash. The returned hash pointer is in general
+not the same as the hash pointer that was passed in. The input hash is
+consumed by the function, and the pointer to it must not be subsequently
+used. Use L</cophh_copy> if you need both hashes.
+
+The key is specified by I<keypv> and I<keylen>. If I<flags> has the
+C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
+otherwise they are interpreted as Latin-1. I<hash> is a precomputed
+hash of the key string, or zero if it has not been precomputed.
+
+I<value> is the scalar value to store for this key. I<value> is copied
+by this function, which thus does not take ownership of any reference
+to it, and later changes to the scalar will not be reflected in the
+value visible in the cop hints hash. Complex types of scalar will not
+be stored with referential integrity, but will be coerced to strings.
+
+=cut
+*/
+
+#define cophh_store_pvn(cophh, keypv, keylen, hash, value, flags) \
+ Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, value, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_store_pvs|const COPHH *cophh|const char *key|SV *value|U32 flags
+
+Like L</cophh_store_pvn>, but takes a literal string instead of a
+string/length pair, and no precomputed hash.
+
+=cut
+*/
+
+#define cophh_store_pvs(cophh, key, value, flags) \
+ Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_store_pv|const COPHH *cophh|const char *key|U32 hash|SV *value|U32 flags
+
+Like L</cophh_store_pvn>, but takes a nul-terminated string instead of
+a string/length pair.
+
+=cut
+*/
+
+#define cophh_store_pv(cophh, key, hash, value, flags) \
+ Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_store_sv|const COPHH *cophh|SV *key|U32 hash|SV *value|U32 flags
+
+Like L</cophh_store_pvn>, but takes a Perl scalar instead of a
+string/length pair.
+
+=cut
+*/
+
+#define cophh_store_sv(cophh, key, hash, value, flags) \
+ Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, value, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_delete_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags
+
+Delete a key and its associated value from the cop hints hash I<cophh>,
+and returns the modified hash. The returned hash pointer is in general
+not the same as the hash pointer that was passed in. The input hash is
+consumed by the function, and the pointer to it must not be subsequently
+used. Use L</cophh_copy> if you need both hashes.
+
+The key is specified by I<keypv> and I<keylen>. If I<flags> has the
+C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
+otherwise they are interpreted as Latin-1. I<hash> is a precomputed
+hash of the key string, or zero if it has not been precomputed.
+
+=cut
+*/
+
+#define cophh_delete_pvn(cophh, keypv, keylen, hash, flags) \
+ Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, \
+ (SV *)NULL, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_delete_pvs|const COPHH *cophh|const char *key|U32 flags
+
+Like L</cophh_delete_pvn>, but takes a literal string instead of a
+string/length pair, and no precomputed hash.
+
+=cut
+*/
+
+#define cophh_delete_pvs(cophh, key, flags) \
+ Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \
+ (SV *)NULL, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_delete_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags
+
+Like L</cophh_delete_pvn>, but takes a nul-terminated string instead of
+a string/length pair.
+
+=cut
+*/
+
+#define cophh_delete_pv(cophh, key, hash, flags) \
+ Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_delete_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags
+
+Like L</cophh_delete_pvn>, but takes a Perl scalar instead of a
+string/length pair.
+
+=cut
+*/
+
+#define cophh_delete_sv(cophh, key, hash, flags) \
+ Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
#include "mydtrace.h"
STRLEN * cop_warnings; /* lexical warnings bitmask */
/* compile time state of %^H. See the comment in op.c for how this is
used to recreate a hash to return from caller. */
- struct refcounted_he * cop_hints_hash;
+ COPHH * cop_hints_hash;
};
#ifdef USE_ITHREADS
# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
#endif /* USE_ITHREADS */
-#define CopLABEL(c) Perl_fetch_cop_label(aTHX_ (c)->cop_hints_hash, NULL, NULL)
+
+#define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
+#define CopHINTHASH_set(c,h) ((c)->cop_hints_hash = (h))
+
+/*
+=head1 COP Hint Reading
+*/
+
+/*
+=for apidoc Am|SV *|cop_hints_fetch_pvn|const COP *cop|const char *keypv|STRLEN keylen|U32 hash|U32 flags
+
+Look up the hint entry in the cop I<cop> with the key specified by
+I<keypv> and I<keylen>. If I<flags> has the C<COPHH_KEY_UTF8> bit set,
+the key octets are interpreted as UTF-8, otherwise they are interpreted
+as Latin-1. I<hash> is a precomputed hash of the key string, or zero if
+it has not been precomputed. Returns a mortal scalar copy of the value
+associated with the key, or C<&PL_sv_placeholder> if there is no value
+associated with the key.
+
+=cut
+*/
+
+#define cop_hints_fetch_pvn(cop, keypv, keylen, hash, flags) \
+ cophh_fetch_pvn(CopHINTHASH_get(cop), keypv, keylen, hash, flags)
+
+/*
+=for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|const char *key|U32 flags
+
+Like L</cop_hints_fetch_pvn>, but takes a literal string instead of a
+string/length pair, and no precomputed hash.
+
+=cut
+*/
+
+#define cop_hints_fetch_pvs(cop, key, flags) \
+ cophh_fetch_pvs(CopHINTHASH_get(cop), key, flags)
+
+/*
+=for apidoc Am|SV *|cop_hints_fetch_pv|const COP *cop|const char *key|U32 hash|U32 flags
+
+Like L</cop_hints_fetch_pvn>, but takes a nul-terminated string instead
+of a string/length pair.
+
+=cut
+*/
+
+#define cop_hints_fetch_pv(cop, key, hash, flags) \
+ cophh_fetch_pv(CopHINTHASH_get(cop), key, hash, flags)
+
+/*
+=for apidoc Am|SV *|cop_hints_fetch_sv|const COP *cop|SV *key|U32 hash|U32 flags
+
+Like L</cop_hints_fetch_pvn>, but takes a Perl scalar instead of a
+string/length pair.
+
+=cut
+*/
+
+#define cop_hints_fetch_sv(cop, key, hash, flags) \
+ cophh_fetch_sv(CopHINTHASH_get(cop), key, hash, flags)
+
+/*
+=for apidoc Am|HV *|cop_hints_2hv|const COP *cop|U32 flags
+
+Generates and returns a standard Perl hash representing the full set of
+hint entries in the cop I<cop>. I<flags> is currently unused and must
+be zero.
+
+=cut
+*/
+
+#define cop_hints_2hv(cop, flags) \
+ cophh_2hv(CopHINTHASH_get(cop), flags)
+
+#define CopLABEL(c) Perl_fetch_cop_label(aTHX_ (c), NULL, NULL)
#define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
/* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
HINT_ARYBASE is set to indicate this.
- Setting it is ineficient due to the need to create 2 mortal SVs, but as
+ Setting it is inefficient due to the need to create 2 mortal SVs, but as
using $[ is highly discouraged, no sane Perl code will be using it. */
#define CopARYBASE_get(c) \
((CopHINTS_get(c) & HINT_ARYBASE) \
- ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0, \
- "$[", 2, 0, 0)) \
+ ? SvIV(cop_hints_fetch_pvs((c), "$[", 0)) \
: 0)
#define CopARYBASE_set(c, b) STMT_START { \
if (b || ((c)->cop_hints & HINT_ARYBASE)) { \
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))); \
+ CopHINTHASH_set((c), \
+ cophh_store_pvs(CopHINTHASH_get((c)), "$[", \
+ sv_2mortal(newSViv(b)), 0)); \
} \
} \
} STMT_END
#define PUSHSUB_BASE(cx) \
ENTRY_PROBE(GvENAME(CvGV(cv)), \
CopFILE((const COP *)CvSTART(cv)), \
- CopLINE((const COP *)CvSTART(cv))); \
+ CopLINE((const COP *)CvSTART(cv)), \
+ CopSTASHPV((const COP *)CvSTART(cv))); \
\
cx->blk_sub.cv = cv; \
cx->blk_sub.olddepth = CvDEPTH(cv); \
STMT_START { \
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))); \
+ CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \
+ CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \
\
if (CxHASARGS(cx)) { \
POP_SAVEARRAY(); \
struct block_loop {
I32 resetsp;
LOOP * my_op; /* My op, that contains redo, next and last ops. */
- /* (except for non_ithreads we need to modify next_op in pp_ctl.c, hence
- why next_op is conditionally defined below.) */
-#ifdef USE_ITHREADS
- PAD *oldcomppad; /* Also used for the GV, if targoffset is 0 */
- /* This is also accesible via cx->blk_loop.my_op->op_targ */
- PADOFFSET targoffset;
-#else
- OP * next_op;
- SV ** itervar;
-#endif
+ union { /* different ways of locating the iteration variable */
+ SV **svp;
+ GV *gv;
+ PAD *oldcomppad; /* only used in ITHREADS */
+ } itervar_u;
union {
struct { /* valid if type is LOOP_FOR or LOOP_PLAIN (but {NULL,0})*/
AV * ary; /* use the stack if this is NULL */
};
#ifdef USE_ITHREADS
-# define CxITERVAR(c) \
- ((c)->blk_loop.oldcomppad \
- ? (CxPADLOOP(c) \
- ? &CX_CURPAD_SV( (c)->blk_loop, (c)->blk_loop.targoffset ) \
- : &GvSV((GV*)(c)->blk_loop.oldcomppad)) \
- : (SV**)NULL)
-# define CX_ITERDATA_SET(cx,idata,o) \
- if ((cx->blk_loop.targoffset = (o))) \
- CX_CURPAD_SAVE(cx->blk_loop); \
- else \
- cx->blk_loop.oldcomppad = (idata);
+# define CxITERVAR_PADSV(c) \
+ &CX_CURPAD_SV( (c)->blk_loop.itervar_u, (c)->blk_loop.my_op->op_targ)
#else
-# define CxITERVAR(c) ((c)->blk_loop.itervar)
-# define CX_ITERDATA_SET(cx,ivar,o) \
- cx->blk_loop.itervar = (SV**)(ivar);
+# define CxITERVAR_PADSV(c) ((c)->blk_loop.itervar_u.svp)
#endif
+
+#define CxITERVAR(c) \
+ ((c)->blk_loop.itervar_u.oldcomppad \
+ ? (CxPADLOOP(c) \
+ ? CxITERVAR_PADSV(c) \
+ : &GvSV((c)->blk_loop.itervar_u.gv)) \
+ : (SV**)NULL)
+
#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)
-#ifdef USE_ITHREADS
-# define PUSHLOOP_OP_NEXT /* No need to do anything. */
-# define CX_LOOP_NEXTOP_GET(cx) ((cx)->blk_loop.my_op->op_nextop + 0)
-#else
-# define PUSHLOOP_OP_NEXT cx->blk_loop.next_op = cLOOP->op_nextop
-# define CX_LOOP_NEXTOP_GET(cx) ((cx)->blk_loop.next_op + 0)
-#endif
-
#define PUSHLOOP_PLAIN(cx, s) \
cx->blk_loop.resetsp = s - PL_stack_base; \
cx->blk_loop.my_op = cLOOP; \
- PUSHLOOP_OP_NEXT; \
cx->blk_loop.state_u.ary.ary = NULL; \
cx->blk_loop.state_u.ary.ix = 0; \
- CX_ITERDATA_SET(cx, NULL, 0);
+ cx->blk_loop.itervar_u.svp = NULL;
-#define PUSHLOOP_FOR(cx, dat, s, offset) \
+#define PUSHLOOP_FOR(cx, ivar, s) \
cx->blk_loop.resetsp = s - PL_stack_base; \
cx->blk_loop.my_op = cLOOP; \
- PUSHLOOP_OP_NEXT; \
cx->blk_loop.state_u.ary.ary = NULL; \
cx->blk_loop.state_u.ary.ix = 0; \
- CX_ITERDATA_SET(cx, dat, offset);
+ cx->blk_loop.itervar_u.svp = (SV**)(ivar);
#define POPLOOP(cx) \
if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { \
#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_maxiters cx_u.cx_subst.sbu_maxiters
#define sb_rflags cx_u.cx_subst.sbu_rflags
#define sb_oldsave cx_u.cx_subst.sbu_oldsave
-#define sb_once cx_u.cx_subst.sbu_once
#define sb_rxtainted cx_u.cx_subst.sbu_rxtainted
#define sb_orig cx_u.cx_subst.sbu_orig
#define sb_dstr cx_u.cx_subst.sbu_dstr
/* private flags for CXt_LOOP */
#define CXp_FOR_DEF 0x10 /* foreach using $_ */
-#ifdef USE_ITHREADS
-# define CxPADLOOP(c) ((c)->blk_loop.targoffset)
-#endif
+#define CxPADLOOP(c) ((c)->blk_loop.my_op->op_targ)
/* private flags for CXt_SUBST */
#define CXp_ONCE 0x10 /* What was sbu_once in struct subst */
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(). */
+#define G_WRITING_TO_STDERR 1024 /* Perl_write_to_stderr() is calling
+ 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); \
#define POP_MULTICALL \
STMT_START { \
- LEAVESUB(multicall_cv); \
- CvDEPTH(multicall_cv)--; \
+ if (! --CvDEPTH(multicall_cv)) \
+ LEAVESUB(multicall_cv); \
POPBLOCK(cx,PL_curpm); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
https://perl5.git.perl.org / perl5.git / blobdiff