int je_ret; /* last exception thrown */
bool je_mustcatch; /* need to call longjmp()? */
U16 je_old_delaymagic; /* saved PL_delaymagic */
+ SSize_t je_old_stack_hwm;
};
typedef struct jmpenv JMPENV;
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+# define JE_OLD_STACK_HWM_zero PL_start_env.je_old_stack_hwm = 0
+# define JE_OLD_STACK_HWM_save(je) \
+ (je).je_old_stack_hwm = PL_curstackinfo->si_stack_hwm
+# define JE_OLD_STACK_HWM_restore(je) \
+ if (PL_curstackinfo->si_stack_hwm < (je).je_old_stack_hwm) \
+ PL_curstackinfo->si_stack_hwm = (je).je_old_stack_hwm
+#else
+# define JE_OLD_STACK_HWM_zero NOOP
+# define JE_OLD_STACK_HWM_save(je) NOOP
+# define JE_OLD_STACK_HWM_restore(je) NOOP
+#endif
+
/*
* How to build the first jmpenv.
*
PL_start_env.je_ret = -1; \
PL_start_env.je_mustcatch = TRUE; \
PL_start_env.je_old_delaymagic = 0; \
+ JE_OLD_STACK_HWM_zero; \
} 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
- *
+ * Message-Id: 20040713143217.GB1424@plum.flirble.org
+ * https://www.nntp.perl.org/group/perl.perl5.porters/2004/07/msg93041.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://perl5.git.perl.org/perl.git/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929
- * http://perl5.git.perl.org/perl.git/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a
- *
+ * https://github.com/Perl/perl5/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929
+ * https://github.com/Perl/perl5/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a
+ *
*/
#define dJMPENV JMPENV cur_env
Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
i, __FILE__, __LINE__);}) \
cur_env.je_prev = PL_top_env; \
+ JE_OLD_STACK_HWM_save(cur_env); \
cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
+ JE_OLD_STACK_HWM_restore(cur_env); \
PL_top_env = &cur_env; \
cur_env.je_mustcatch = FALSE; \
cur_env.je_old_delaymagic = PL_delaymagic; \
} STMT_END
/*
-=head1 COP Hint Hashes
+=for apidoc_section $COP
*/
typedef struct refcounted_he COPHH;
associated with the key, or C<&PL_sv_placeholder> if there is no value
associated with the key.
+=for apidoc Amnh||COPHH_KEY_UTF8
+
=cut
*/
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
+=for apidoc Amx|SV *|cophh_fetch_pvs|const COPHH *cophh|"key"|U32 flags
-Like L</cophh_fetch_pvn>, but takes a literal string instead of a
-string/length pair, and no precomputed hash.
+Like L</cophh_fetch_pvn>, but takes a literal string instead
+of a string/length pair, and no precomputed hash.
=cut
*/
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
+=for apidoc Amx|COPHH *|cophh_store_pvs|COPHH *cophh|"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.
+Like L</cophh_store_pvn>, but takes a literal string instead
+of a string/length pair, and no precomputed hash.
=cut
*/
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
+=for apidoc Amx|COPHH *|cophh_store_pv|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.
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
+=for apidoc Amx|COPHH *|cophh_store_sv|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.
(SV *)NULL, flags)
/*
-=for apidoc Amx|COPHH *|cophh_delete_pvs|const COPHH *cophh|const char *key|U32 flags
+=for apidoc Amx|COPHH *|cophh_delete_pvs|COPHH *cophh|"key"|U32 flags
-Like L</cophh_delete_pvn>, but takes a literal string instead of a
-string/length pair, and no precomputed hash.
+Like L</cophh_delete_pvn>, but takes a literal string instead
+of a string/length pair, and no precomputed hash.
=cut
*/
(SV *)NULL, flags)
/*
-=for apidoc Amx|COPHH *|cophh_delete_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags
+=for apidoc Amx|COPHH *|cophh_delete_pv|COPHH *cophh|char *key|U32 hash|U32 flags
Like L</cophh_delete_pvn>, but takes a nul-terminated string instead of
a string/length pair.
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
+=for apidoc Amx|COPHH *|cophh_delete_sv|COPHH *cophh|SV *key|U32 hash|U32 flags
Like L</cophh_delete_pvn>, but takes a Perl scalar instead of a
string/length pair.
#ifdef USE_ITHREADS
PADOFFSET cop_stashoff; /* offset into PL_stashpad, for the
package the line was compiled in */
- char * cop_file; /* file name the following line # is from */
+ char * cop_file; /* name of file this command is from */
#else
HV * cop_stash; /* package line was compiled in */
- GV * cop_filegv; /* file the following line # is from */
+ GV * cop_filegv; /* name of GV file this command is from */
#endif
U32 cop_hints; /* hints bits from pragmata */
U32 cop_seq; /* parse sequence number */
/* compile time state of %^H. See the comment in op.c for how this is
used to recreate a hash to return from caller. */
COPHH * cop_hints_hash;
+ /* for now just a bitmask stored here.
+ If we get sufficient features this may become a pointer.
+ How these flags are stored is subject to change without
+ notice. Use the macros to test for features.
+ */
+ U32 cop_features;
};
#ifdef USE_ITHREADS
# define CopFILE(c) ((c)->cop_file)
# define CopFILEGV(c) (CopFILE(c) \
? gv_fetchfile(CopFILE(c)) : NULL)
-
+
# ifdef NETWARE
# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
# define CopFILE_setn(c,pv,l) ((c)->cop_file = savepvn((pv),(l)))
# else
# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
# endif
-#else
+#else /* Above: no threads; Below yes threads */
# define CopFILEGV(c) ((c)->cop_filegv)
# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
# else
# define CopFILEAVx(c) (GvAV(CopFILEGV(c)))
# endif
-# define CopFILE(c) (CopFILEGV(c) \
+# define CopFILE(c) (CopFILEGV(c) /* +2 for '_<' */ \
? GvNAME(CopFILEGV(c))+2 : NULL)
# define CopSTASH(c) ((c)->cop_stash)
# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
#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 C<cop> with the key specified by
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
+=for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|"key"|U32 flags
-Like L</cop_hints_fetch_pvn>, but takes a literal string instead of a
-string/length pair, and no precomputed hash.
+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_2hv(cop, flags) \
cophh_2hv(CopHINTHASH_get(cop), flags)
+/*
+=for apidoc Am|const char *|CopLABEL|COP *const cop
+
+Returns the label attached to a cop.
+
+=for apidoc Am|const char *|CopLABEL_len|COP *const cop|STRLEN *len
+
+Returns the label attached to a cop, and stores its length in bytes into
+C<*len>.
+
+=for apidoc Am|const char *|CopLABEL_len_flags|COP *const cop|STRLEN *len|U32 *flags
+
+Returns the label attached to a cop, and stores its length in bytes into
+C<*len>. Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0.
+
+=cut
+*/
+
#define CopLABEL(c) Perl_cop_fetch_label(aTHX_ (c), NULL, NULL)
#define CopLABEL_len(c,len) Perl_cop_fetch_label(aTHX_ (c), len, NULL)
#define CopLABEL_len_flags(c,len,flags) Perl_cop_fetch_label(aTHX_ (c), len, flags)
/* subroutine context */
struct block_sub {
OP * retop; /* op to execute on exit from sub */
+ I32 old_cxsubix; /* previous value of si_cxsubix */
/* Above here is the same for sub, format and eval. */
PAD *prevcomppad; /* the caller's PL_comppad */
CV * cv;
/* format context */
struct block_format {
OP * retop; /* op to execute on exit from sub */
+ I32 old_cxsubix; /* previous value of si_cxsubix */
/* Above here is the same for sub, format and eval. */
PAD *prevcomppad; /* the caller's PL_comppad */
CV * cv;
GV * dfoutgv;
};
+/* return a pointer to the current context */
+
+#define CX_CUR() (&cxstack[cxstack_ix])
+
/* free all savestack items back to the watermark of the specified context */
-#define CX_LEAVE_SCOPE(cx) LEAVE_SCOPE(cx->cx_old_savestack_ix)
+#define CX_LEAVE_SCOPE(cx) LEAVE_SCOPE(cx->blk_oldsaveix)
#ifdef DEBUGGING
/* on debugging builds, poison cx afterwards so we know no code
* uses it - because after doing cxstack_ix--, any ties, exceptions etc
* may overwrite the current stack frame */
# define CX_POP(cx) \
- assert(&cxstack[cxstack_ix] == cx); \
+ assert(CX_CUR() == cx); \
cxstack_ix--; \
cx = NULL;
#else
# define CX_POP(cx) cxstack_ix--;
#endif
-
-/* base for the next two macros. Don't use directly.
- * The context frame holds a reference to the CV so that it can't be
- * freed while we're executing it */
-
-#define PUSHSUB_BASE(cx) \
- ENTRY_PROBE(CvNAMED(cv) \
- ? HEK_KEY(CvNAME_HEK(cv)) \
- : GvENAME(CvGV(cv)), \
- CopFILE((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); \
- cx->blk_sub.prevcomppad = PL_comppad; \
- cx->cx_type |= (hasargs) ? CXp_HASARGS : 0; \
- cx->blk_sub.retop = NULL; \
- SvREFCNT_inc_simple_void_NN(cv);
-
-#define PUSHSUB_GET_LVALUE_MASK(func) \
+#define CX_PUSHSUB_GET_LVALUE_MASK(func) \
/* If the context is indeterminate, then only the lvalue */ \
/* flags that the caller also has are applicable. */ \
( \
? 0 : (U8)func(aTHX) \
)
-#define PUSHSUB(cx) \
- { \
- U8 phlags = PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub); \
- PUSHSUB_BASE(cx) \
- cx->blk_u16 = PL_op->op_private & \
- (phlags|OPpDEREF); \
- }
-
-/* variant for use by OP_DBSTATE, where op_private holds hint bits */
-#define PUSHSUB_DB(cx) \
- PUSHSUB_BASE(cx) \
- cx->blk_u16 = 0;
-
-
-#define PUSHFORMAT(cx, retop) \
- cx->blk_format.cv = cv; \
- cx->blk_format.gv = gv; \
- cx->blk_format.retop = (retop); \
- cx->blk_format.dfoutgv = PL_defoutgv; \
- cx->blk_format.prevcomppad = PL_comppad; \
- cx->blk_u16 = 0; \
- cx->cx_old_savestack_ix = PL_savestack_ix; \
- SvREFCNT_inc_simple_void_NN(cv); \
- CvDEPTH(cv)++; \
- SvREFCNT_inc_void(cx->blk_format.dfoutgv)
-
/* Restore old @_ */
-#define POP_SAVEARRAY() \
+#define CX_POP_SAVEARRAY(cx) \
STMT_START { \
- AV *av = GvAV(PL_defgv); \
+ AV *cx_pop_savearray_av = GvAV(PL_defgv); \
GvAV(PL_defgv) = cx->blk_sub.savearray; \
- SvREFCNT_dec(av); \
+ cx->blk_sub.savearray = NULL; \
+ SvREFCNT_dec(cx_pop_savearray_av); \
} STMT_END
/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
} STMT_END
-/* subsets of POPSUB */
-
-#define POPSUB_COMMON(cx) \
- PL_comppad = cx->blk_sub.prevcomppad; \
- PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; \
- CvDEPTH((const CV*)cx->blk_sub.cv) = cx->blk_sub.olddepth; \
- SvREFCNT_dec_NN(cx->blk_sub.cv);
-
-/* handle the @_ part of leaving a sub */
-
-#define POPSUB_ARGS(cx) \
- STMT_START { \
- AV *av; \
- assert(AvARRAY(MUTABLE_AV( \
- PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ \
- CvDEPTH(cx->blk_sub.cv)])) == PL_curpad); \
- POP_SAVEARRAY(); \
- /* abandon @_ if it got reified */ \
- av = MUTABLE_AV(PAD_SVl(0)); \
- if (UNLIKELY(AvREAL(av))) \
- clear_defarray(av, 0); \
- else { \
- CLEAR_ARGARRAY(av); \
- } \
- } STMT_END
-
-#define POPSUB(cx) \
- STMT_START { \
- if (!(cx->blk_u16 & CxPOPSUB_DONE)) { \
- cx->blk_u16 |= CxPOPSUB_DONE; \
- RETURN_PROBE(CvNAMED(cx->blk_sub.cv) \
- ? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) \
- : GvENAME(CvGV(cx->blk_sub.cv)), \
- CopFILE((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)) { \
- POPSUB_ARGS(cx); \
- } \
- } \
- POPSUB_COMMON(cx); \
- } STMT_END
-
-#define POPFORMAT(cx) \
- STMT_START { \
- if (!(cx->blk_u16 & CxPOPSUB_DONE)) { \
- CV * const cv = cx->blk_format.cv; \
- GV * const dfuot = cx->blk_format.dfoutgv; \
- cx->blk_u16 |= CxPOPSUB_DONE; \
- setdefout(dfuot); \
- PL_comppad = cx->blk_format.prevcomppad; \
- PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; \
- --CvDEPTH(cv); \
- SvREFCNT_dec_NN(cx->blk_format.cv); \
- SvREFCNT_dec_NN(dfuot); \
- } \
- } STMT_END
-
/* eval context */
struct block_eval {
OP * retop; /* op to execute on exit from eval */
+ I32 old_cxsubix; /* previous value of si_cxsubix */
/* Above here is the same for sub, format and eval. */
SV * old_namesv;
OP * old_eval_root;
blku_gimme is actually also only 2 bits, so could be merged with something.
*/
-#define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x7F)
-#define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7)
+/* blk_u16 bit usage for eval contexts: */
-#define PUSHEVAL(cx,n) \
- STMT_START { \
- assert(!(PL_in_eval & ~0x7F)); \
- assert(!(PL_op->op_type & ~0x1FF)); \
- cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7); \
- cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL); \
- cx->blk_eval.old_eval_root = PL_eval_root; \
- cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL; \
- cx->blk_eval.cv = NULL; /* set by doeval_compile() as applicable */ \
- cx->blk_eval.retop = NULL; \
- cx->blk_eval.cur_top_env = PL_top_env; \
- } STMT_END
-
-#define POPEVAL(cx) \
- STMT_START { \
- PL_in_eval = CxOLD_IN_EVAL(cx); \
- PL_eval_root = cx->blk_eval.old_eval_root; \
- if (cx->blk_eval.cur_text && SvSCREAM(cx->blk_eval.cur_text)) \
- SvREFCNT_dec_NN(cx->blk_eval.cur_text); \
- if (cx->blk_eval.old_namesv) \
- sv_2mortal(cx->blk_eval.old_namesv); \
- } STMT_END
+#define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x3F) /* saved PL in_eval */
+#define CxEVAL_TXT_REFCNTED(cx) (((cx)->blk_u16) & 0x40) /* cur_text rc++ */
+#define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7) /* type of eval op */
/* loop context */
struct block_loop {
#define CxLABEL_len(c,len) (0 + CopLABEL_len((c)->blk_oldcop, len))
#define CxLABEL_len_flags(c,len,flags) (0 + CopLABEL_len_flags((c)->blk_oldcop, len, flags))
#define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
-#define CxLVAL(c) (0 + ((c)->blk_u16 & 0xff))
-/* POPSUB has already been performed on this context frame */
-#define CxPOPSUB_DONE 0x100
-
-#define PUSHLOOP_PLAIN(cx) \
- cx->blk_loop.my_op = cLOOP; \
- cx->cx_old_savestack_ix = PL_savestack_ix;
+/* CxLVAL(): the lval flags of the call site: the relevant flag bits from
+ * the op_private field of the calling pp_entersub (or its caller's caller
+ * if the caller's lvalue context isn't known):
+ * OPpLVAL_INTRO: sub used in lvalue context, e.g. f() = 1;
+ * OPpENTERSUB_INARGS (in conjunction with OPpLVAL_INTRO): the
+ * function is being used as a sub arg or as a referent, e.g.
+ * g(...,f(),...) or $r = \f()
+ * OPpDEREF: 2-bit mask indicating e.g. f()->[0].
+ * Note the contrast with CvLVALUE(), which is a property of the sub
+ * rather than the call site.
+ */
+#define CxLVAL(c) (0 + ((c)->blk_u16 & 0xff))
-#ifdef USE_ITHREADS
-# define PUSHLOOP_FOR_setpad(c) (c)->blk_loop.oldcomppad = PL_comppad
-#else
-# define PUSHLOOP_FOR_setpad(c) NOOP
-#endif
-#define PUSHLOOP_FOR(cx, ivar, isave) \
- cx->blk_loop.my_op = cLOOP; \
- cx->blk_loop.itervar_u.svp = (SV**)(ivar); \
- cx->cx_old_savestack_ix = PL_savestack_ix; \
- cx->blk_loop.itersave = isave; \
- PUSHLOOP_FOR_setpad(cx);
-
-#define POPLOOP(cx) \
- if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { \
- SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.cur); \
- SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.end); \
- } \
- else if (CxTYPE(cx) == CXt_LOOP_ARY) \
- SvREFCNT_dec(cx->blk_loop.state_u.ary.ary); \
- if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) { \
- SV *cursv; \
- SV **svp = (cx)->blk_loop.itervar_u.svp; \
- if ((cx->cx_type & CXp_FOR_GV)) \
- svp = &GvSV((GV*)svp); \
- cursv = *svp; \
- *svp = cx->blk_loop.itersave; \
- SvREFCNT_dec(cursv); \
- }
/* given/when context */
struct block_givwhen {
SV *defsv_save; /* the original $_ */
};
-#define PUSHWHEN(cx) \
- cx->cx_old_savestack_ix = PL_savestack_ix; \
- cx->blk_givwhen.leave_op = cLOGOP->op_other;
-
-#define PUSHGIVEN(cx, orig_var) \
- PUSHWHEN(cx); \
- cx->blk_givwhen.defsv_save = orig_var;
-
-#define POPWHEN(cx) \
- NOOP;
-
-#define POPGIVEN(cx) \
- SvREFCNT_dec(GvSV(PL_defgv)); \
- GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
-
-
-/* basic block, i.e. pp_enter/leave */
-
-#define PUSHBASICBLK(cx) \
- cx->cx_old_savestack_ix = PL_savestack_ix;
-
-#define POPBASICBLK(cx) \
- NOOP;
/* context common to subroutines, evals and loops */
U8 blku_type; /* what kind of context this is */
U8 blku_gimme; /* is this block running in list context? */
U16 blku_u16; /* used by block_sub and block_eval (so far) */
+ I32 blku_oldsaveix; /* saved PL_savestack_ix */
+ /* all the fields above must be aligned with same-sized fields as sbu */
I32 blku_oldsp; /* current sp floor: where nextstate pops to */
- COP * blku_oldcop; /* old curcop pointer */
I32 blku_oldmarksp; /* mark stack index */
- I32 blku_oldscopesp; /* scope stack index */
+ COP * blku_oldcop; /* old curcop pointer */
PMOP * blku_oldpm; /* values of pattern match vars */
SSize_t blku_old_tmpsfloor; /* saved PL_tmps_floor */
+ I32 blku_oldscopesp; /* scope stack index */
union {
struct block_sub blku_sub;
#define blk_oldpm cx_u.cx_blk.blku_oldpm
#define blk_gimme cx_u.cx_blk.blku_gimme
#define blk_u16 cx_u.cx_blk.blku_u16
+#define blk_oldsaveix cx_u.cx_blk.blku_oldsaveix
+#define blk_old_tmpsfloor cx_u.cx_blk.blku_old_tmpsfloor
#define blk_sub cx_u.cx_blk.blk_u.blku_sub
#define blk_format cx_u.cx_blk.blk_u.blku_format
#define blk_eval cx_u.cx_blk.blk_u.blku_eval
#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) \
+#define CX_DEBUG(cx, action) \
DEBUG_l( \
Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) (save %ld,%ld) at %s:%d\n",\
(long)cxstack_ix, \
action, \
- PL_block_type[CxTYPE(&cxstack[cxstack_ix])], \
+ PL_block_type[CxTYPE(cx)], \
(long)PL_scopestack_ix, \
- (long)(cxstack[cxstack_ix].blk_oldscopesp), \
+ (long)(cx->blk_oldscopesp), \
(long)PL_savestack_ix, \
- (long)(cxstack[cxstack_ix].cx_old_savestack_ix), \
+ (long)(cx->blk_oldsaveix), \
__FILE__, __LINE__));
-/* Enter a block. */
-#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
- cx->cx_type = t, \
- cx->blk_oldsp = sp - PL_stack_base, \
- cx->blk_oldcop = PL_curcop, \
- cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \
- cx->blk_oldscopesp = PL_scopestack_ix, \
- cx->blk_oldpm = PL_curpm, \
- cx->blk_gimme = (U8)gimme; \
- cx->cx_u.cx_blk.blku_old_tmpsfloor = PL_tmps_floor; \
- PL_tmps_floor = PL_tmps_ix; \
- DEBUG_CX("PUSH");
-
-/* Exit a block (RETURN and LAST). */
-#define POPBLOCK(cx) \
- DEBUG_CX("POP"); \
- PL_curcop = cx->blk_oldcop, \
- PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
- PL_scopestack_ix = cx->blk_oldscopesp, \
- /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
- * and leaves a CX entry lying around for repeated use, so
- * skip for multicall */ \
- assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx)) \
- || PL_savestack_ix == cx->cx_old_savestack_ix); \
- PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor; \
- PL_curpm = cx->blk_oldpm;
-
-/* Continue a block elsewhere (NEXT and REDO). */
-#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;
+
/* substitution context */
struct subst {
- U8 sbu_type; /* what kind of context this is */
+ U8 sbu_type; /* same as blku_type */
U8 sbu_rflags;
- U16 sbu_rxtainted; /* matches struct block */
+ U16 sbu_rxtainted;
+ I32 sbu_oldsaveix; /* same as blku_oldsaveix */
+ /* all the fields above must be aligned with same-sized fields as blk_u */
SSize_t sbu_iters;
SSize_t sbu_maxiters;
char * sbu_orig;
#define sb_rx cx_u.cx_subst.sbu_rx
#ifdef PERL_CORE
-# define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
- cx->cx_old_savestack_ix = oldsave, \
+# define CX_PUSHSUBST(cx) CXINC, cx = CX_CUR(), \
+ cx->blk_oldsaveix = oldsave, \
cx->sb_iters = iters, \
cx->sb_maxiters = maxiters, \
cx->sb_rflags = r_flags, \
(void)ReREFCNT_inc(rx); \
SvREFCNT_inc_void_NN(targ)
-# define POPSUBST(cx) \
+# define CX_POPSUBST(cx) \
+ STMT_START { \
+ REGEXP *re; \
+ assert(CxTYPE(cx) == CXt_SUBST); \
rxres_free(&cx->sb_rxres); \
- ReREFCNT_dec(cx->sb_rx); \
- SvREFCNT_dec_NN(cx->sb_targ)
+ re = cx->sb_rx; \
+ cx->sb_rx = NULL; \
+ ReREFCNT_dec(re); \
+ SvREFCNT_dec_NN(cx->sb_targ); \
+ } STMT_END
#endif
#define CxONCE(cx) ((cx)->cx_type & CXp_ONCE)
struct context {
- I32 cx_old_savestack_ix; /* saved PL_savestack_ix */
union {
struct block cx_blk;
struct subst cx_subst;
/* be careful of the ordering of these five. Macros like CxTYPE_is_LOOP,
* CxFOREACH compare ranges */
-#define CXt_LOOP_PLAIN 4 /* {} */
-#define CXt_LOOP_LAZYIV 5 /* for (1..9) {} */
-#define CXt_LOOP_LAZYSV 6 /* for ('a'..'z') {} */
-#define CXt_LOOP_LIST 7 /* for (1,2,3) {} */
-#define CXt_LOOP_ARY 8 /* for (@ary) {} */
-
+#define CXt_LOOP_ARY 4 /* for (@ary) { ...; } */
+#define CXt_LOOP_LAZYSV 5 /* for ('a'..'z') { ...; } */
+#define CXt_LOOP_LAZYIV 6 /* for (1..9) { ...; } */
+#define CXt_LOOP_LIST 7 /* for (1,2,3) { ...; } */
+#define CXt_LOOP_PLAIN 8 /* while (...) { ...; }
+ or plain block { ...; } */
#define CXt_SUB 9
#define CXt_FORMAT 10
#define CXt_EVAL 11
#define CXp_TRYBLOCK 0x40 /* eval{}, not eval'' or similar */
/* private flags for CXt_LOOP */
+
+/* this is only set in conjunction with CXp_FOR_GV */
#define CXp_FOR_DEF 0x10 /* foreach using $_ */
+/* these 3 are mutually exclusive */
#define CXp_FOR_LVREF 0x20 /* foreach using \$var */
#define CXp_FOR_GV 0x40 /* foreach using package var */
#define CXp_FOR_PAD 0x80 /* foreach using lexical var */
+
#define CxPADLOOP(c) ((c)->cx_type & CXp_FOR_PAD)
/* private flags for CXt_SUBST */
#define CXp_ONCE 0x10 /* What was sbu_once in struct subst */
#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK)
-#define CxTYPE_is_LOOP(c) ( CxTYPE(cx) >= CXt_LOOP_PLAIN \
- && CxTYPE(cx) <= CXt_LOOP_ARY)
+#define CxTYPE_is_LOOP(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \
+ && CxTYPE(cx) <= CXt_LOOP_PLAIN)
#define CxMULTICALL(c) ((c)->cx_type & CXp_MULTICALL)
#define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK|CXp_REAL)) \
== (CXt_EVAL|CXp_REAL))
#define CxTRYBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK)) \
== (CXt_EVAL|CXp_TRYBLOCK))
-#define CxFOREACH(c) ( CxTYPE(cx) >= CXt_LOOP_LAZYSV \
- && CxTYPE(cx) <= CXt_LOOP_ARY)
+#define CxFOREACH(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \
+ && CxTYPE(cx) <= CXt_LOOP_LIST)
#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
-/*
-=head1 "Gimme" Values
-*/
-
-/*
-=for apidoc AmU||G_SCALAR
-Used to indicate scalar context. See C<L</GIMME_V>>, C<L</GIMME>>, and
-L<perlcall>.
-
-=for apidoc AmU||G_ARRAY
-Used to indicate list context. See C<L</GIMME_V>>, C<L</GIMME>> and
-L<perlcall>.
-
-=for apidoc AmU||G_VOID
-Used to indicate void context. See C<L</GIMME_V>> and L<perlcall>.
-
-=for apidoc AmU||G_DISCARD
-Indicates that arguments returned from a callback should be discarded. See
-L<perlcall>.
-
-=for apidoc AmU||G_EVAL
-
-Used to force a Perl C<eval> wrapper around a callback. See
-L<perlcall>.
-
-=for apidoc AmU||G_NOARGS
-
-Indicates that no arguments are being sent to a callback. See
-L<perlcall>.
-
-=cut
-*/
-
#define G_SCALAR 2
#define G_ARRAY 3
#define G_VOID 1
#define G_WANT 3
/* extra flags for Perl_call_* routines */
-#define G_DISCARD 4 /* Call FREETMPS.
+#define G_DISCARD 0x4 /* Call FREETMPS.
Don't change this without consulting the
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 /* 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
+#define G_EVAL 0x8 /* Assume eval {} around subroutine call. */
+#define G_NOARGS 0x10 /* Don't construct a @_ array. */
+#define G_KEEPERR 0x20 /* Warn for errors, don't overwrite $@ */
+#define G_NODEBUG 0x40 /* Disable debugging at toplevel. */
+#define G_METHOD 0x80 /* Calling method. */
+#define G_FAKINGEVAL 0x100 /* Faking an eval context for call_sv or
fold_constants. */
-#define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef
+#define G_UNDEF_FILL 0x200 /* 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
+#define G_WRITING_TO_STDERR 0x400 /* Perl_write_to_stderr() is calling
Perl_magic_methcall(). */
-#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
-#define G_METHOD_NAMED 4096 /* calling named method, eg without :: or ' */
+#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
+#define G_METHOD_NAMED 0x1000 /* calling named method, eg without :: or ' */
+#define G_RETHROW 0x2000 /* eval_sv(): re-throw any error */
/* flag bits for PL_in_eval */
#define EVAL_NULL 0 /* not in an eval */
#define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */
#define EVAL_INREQUIRE 8 /* The code is being required. */
#define EVAL_RE_REPARSING 0x10 /* eval_sv() called with G_RE_REPARSING */
+/* if adding extra bits, make sure they can fit in CxOLD_OP_TYPE() */
/* Support for switching (stack and block) contexts.
* This ensures magic doesn't invalidate local stack and cx pointers.
+ * Which one to use (or add) is mostly, but not completely arbitrary: See
+ * http://nntp.perl.org/group/perl.perl5.porters/257169
*/
#define PERLSI_UNKNOWN -1
#define PERLSI_DIEHOOK 8
#define PERLSI_REQUIRE 9
#define PERLSI_MULTICALL 10
+#define PERLSI_REGCOMP 11
struct stackinfo {
AV * si_stack; /* stack for current runlevel */
struct stackinfo * si_next;
I32 si_cxix; /* current context index */
I32 si_cxmax; /* maximum allocated index */
+ I32 si_cxsubix; /* topmost sub/eval/format */
I32 si_type; /* type of runlevel */
I32 si_markoff; /* offset where markstack begins for us.
* currently used only with DEBUGGING,
* but not #ifdef-ed for bincompat */
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+/* high water mark: for checking if the stack was correctly extended /
+ * tested for extension by each pp function */
+ SSize_t si_stack_hwm;
+#endif
+
};
+/*
+=for apidoc Ay||PERL_SI
+Use this typedef to declare variables that are to hold C<struct stackinfo>.
+
+=cut
+*/
typedef struct stackinfo PERL_SI;
#define cxstack (PL_curstackinfo->si_cxstack)
# define SET_MARK_OFFSET NOOP
#endif
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+# define PUSHSTACK_INIT_HWM(si) ((si)->si_stack_hwm = 0)
+#else
+# define PUSHSTACK_INIT_HWM(si) NOOP
+#endif
+
#define PUSHSTACKi(type) \
STMT_START { \
PERL_SI *next = PL_curstackinfo->si_next; \
} \
next->si_type = type; \
next->si_cxix = -1; \
+ next->si_cxsubix = -1; \
+ PUSHSTACK_INIT_HWM(next); \
AvFILLp(next->si_stack) = 0; \
SWITCHSTACK(PL_curstack,next->si_stack); \
PL_curstackinfo = next; \
} \
} STMT_END
-#define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
-#define IN_PERL_RUNTIME (PL_curcop != &PL_compiling)
+/*
+=for apidoc_section $utility
+=for apidoc Amn|bool|IN_PERL_COMPILETIME
+Returns 1 if this macro is being called during the compilation phase of the
+program; otherwise 0;
+
+=for apidoc Amn|bool|IN_PERL_RUNTIME
+Returns 1 if this macro is being called during the execution phase of the
+program; otherwise 0;
+
+=cut
+*/
+#define IN_PERL_COMPILETIME cBOOL(PL_curcop == &PL_compiling)
+#define IN_PERL_RUNTIME cBOOL(PL_curcop != &PL_compiling)
/*
-=head1 Multicall Functions
+=for apidoc_section $multicall
-=for apidoc Ams||dMULTICALL
+=for apidoc Amns||dMULTICALL
Declare local variables for a multicall. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
-=for apidoc Ams||PUSH_MULTICALL
+=for apidoc Ams||PUSH_MULTICALL|CV* the_cv
Opening bracket for a lightweight callback.
See L<perlcall/LIGHTWEIGHT CALLBACKS>.
-=for apidoc Ams||MULTICALL
+=for apidoc Amns||MULTICALL
Make a lightweight callback. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
-=for apidoc Ams||POP_MULTICALL
+=for apidoc Amns||POP_MULTICALL
Closing bracket for a lightweight callback.
See L<perlcall/LIGHTWEIGHT CALLBACKS>.
*/
#define dMULTICALL \
- SV **newsp; /* set by POPBLOCK */ \
- PERL_CONTEXT *cx; \
- CV *multicall_cv; \
- OP *multicall_cop; \
- bool multicall_oldcatch; \
- U8 hasargs = 0 /* used by PUSHSUB */
+ OP *multicall_cop; \
+ bool multicall_oldcatch
#define PUSH_MULTICALL(the_cv) \
PUSH_MULTICALL_FLAGS(the_cv, 0)
#define PUSH_MULTICALL_FLAGS(the_cv, flags) \
STMT_START { \
+ PERL_CONTEXT *cx; \
CV * const _nOnclAshIngNamE_ = the_cv; \
CV * const cv = _nOnclAshIngNamE_; \
PADLIST * const padlist = CvPADLIST(cv); \
multicall_oldcatch = CATCH_GET; \
CATCH_SET(TRUE); \
PUSHSTACKi(PERLSI_MULTICALL); \
- PUSHBLOCK(cx, (CXt_SUB|CXp_MULTICALL|flags), PL_stack_sp); \
- PUSHSUB(cx); \
- cx->cx_old_savestack_ix = PL_savestack_ix; \
- SAVEVPTR(PL_op); \
+ cx = cx_pushblock((CXt_SUB|CXp_MULTICALL|flags), (U8)gimme, \
+ PL_stack_sp, PL_savestack_ix); \
+ cx_pushsub(cx, cv, NULL, 0); \
+ SAVEOP(); \
if (!(flags & CXp_SUB_RE_FAKE)) \
CvDEPTH(cv)++; \
- if (CvDEPTH(cv) >= 2) { \
- PERL_STACK_OVERFLOW_CHECK(); \
+ if (CvDEPTH(cv) >= 2) \
Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
- } \
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
- multicall_cv = cv; \
- PERL_UNUSED_VAR(multicall_cv); /* for API */ \
multicall_cop = CvSTART(cv); \
} STMT_END
#define POP_MULTICALL \
STMT_START { \
- cx = &cxstack[cxstack_ix]; \
+ PERL_CONTEXT *cx; \
+ cx = CX_CUR(); \
CX_LEAVE_SCOPE(cx); \
- POPSUB_COMMON(cx); \
- newsp = PL_stack_base + cx->blk_oldsp; \
+ cx_popsub_common(cx); \
gimme = cx->blk_gimme; \
- PERL_UNUSED_VAR(newsp); /* for API */ \
PERL_UNUSED_VAR(gimme); /* for API */ \
- POPBLOCK(cx); \
+ cx_popblock(cx); \
CX_POP(cx); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
CV * const _nOnclAshIngNamE_ = the_cv; \
CV * const cv = _nOnclAshIngNamE_; \
PADLIST * const padlist = CvPADLIST(cv); \
- cx = &cxstack[cxstack_ix]; \
+ PERL_CONTEXT *cx = CX_CUR(); \
assert(CxMULTICALL(cx)); \
- POPSUB_COMMON(cx); \
+ cx_popsub_common(cx); \
cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \
- PUSHSUB(cx); \
+ cx_pushsub(cx, cv, NULL, 0); \
if (!(flags & CXp_SUB_RE_FAKE)) \
CvDEPTH(cv)++; \
- if (CvDEPTH(cv) >= 2) { \
- PERL_STACK_OVERFLOW_CHECK(); \
+ if (CvDEPTH(cv) >= 2) \
Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
- } \
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
- multicall_cv = cv; \
multicall_cop = CvSTART(cv); \
} STMT_END
/*
https://perl5.git.perl.org / perl5.git / blobdiff