* License or the Artistic License, as specified in the README file.
*
* Control ops (cops) are one of the two ops OP_NEXTSTATE and OP_DBSTATE,
- * that (loosely speaking) are separate statements.
+ * that (loosely speaking) are statement separators.
* 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.
struct jmpenv {
struct jmpenv * je_prev;
- Sigjmp_buf je_buf; /* only for use if !je_throw */
+ Sigjmp_buf je_buf; /* uninit if je_prev is NULL */
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;
-#ifdef OP_IN_REGISTER
-#define OP_REG_TO_MEM PL_opsave = op
-#define OP_MEM_TO_REG op = PL_opsave
+#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 OP_REG_TO_MEM NOOP
-#define OP_MEM_TO_REG NOOP
+# define JE_OLD_STACK_HWM_zero NOOP
+# define JE_OLD_STACK_HWM_save(je) NOOP
+# define JE_OLD_STACK_HWM_restore(je) NOOP
#endif
/*
#define JMPENV_BOOTSTRAP \
STMT_START { \
- Zero(&PL_start_env, 1, JMPENV); \
+ PERL_POISON_EXPR(PoisonNew(&PL_start_env, 1, JMPENV));\
+ PL_top_env = &PL_start_env; \
+ PL_start_env.je_prev = NULL; \
PL_start_env.je_ret = -1; \
PL_start_env.je_mustcatch = TRUE; \
- PL_top_env = &PL_start_env; \
+ PL_start_env.je_old_delaymagic = 0; \
+ JE_OLD_STACK_HWM_zero; \
} STMT_END
/*
*
* 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
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; \
+ JE_OLD_STACK_HWM_save(cur_env); \
cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
- OP_MEM_TO_REG; \
+ JE_OLD_STACK_HWM_restore(cur_env); \
PL_top_env = &cur_env; \
cur_env.je_mustcatch = FALSE; \
+ cur_env.je_old_delaymagic = PL_delaymagic; \
(v) = cur_env.je_ret; \
} STMT_END
Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \
i, __FILE__, __LINE__);}) \
assert(PL_top_env == &cur_env); \
+ PL_delaymagic = cur_env.je_old_delaymagic; \
PL_top_env = cur_env.je_prev; \
} STMT_END
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)); \
if ((v) == 2) \
PerlProc_exit(STATUS_EXIT); \
- PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \
PerlProc_exit(1); \
} STMT_END
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 C<cophh> with the key specified by
+C<keypv> and C<keylen>. If C<flags> has the C<COPHH_KEY_UTF8> bit set,
+the key octets are interpreted as UTF-8, otherwise they are interpreted
+as Latin-1. C<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|"literal string" 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 C<cophh>. C<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 C<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 C<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 C<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 C<keypv> and C<keylen>. If C<flags> has the
+C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
+otherwise they are interpreted as Latin-1. C<hash> is a precomputed
+hash of the key string, or zero if it has not been precomputed.
+
+C<value> is the scalar value to store for this key. C<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|"literal string" 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 C<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 C<keypv> and C<keylen>. If C<flags> has the
+C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
+otherwise they are interpreted as Latin-1. C<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|"literal string" 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"
line_t cop_line; /* line # of this command */
/* label for this construct is now stored in cop_hints_hash */
#ifdef USE_ITHREADS
- char * cop_stashpv; /* package line was compiled in */
+ 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 */
#else
HV * cop_stash; /* package line was compiled in */
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
# ifdef NETWARE
# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
-# define CopFILE_setn(c,pv,l) ((c)->cop_file = savepv((pv),(l)))
+# define CopFILE_setn(c,pv,l) ((c)->cop_file = savepvn((pv),(l)))
# else
# define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv))
# define CopFILE_setn(c,pv,l) ((c)->cop_file = savesharedpvn((pv),(l)))
? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
# define CopFILEAV(c) (CopFILE(c) \
? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
-# ifdef DEBUGGING
-# define CopFILEAVx(c) (assert(CopFILE(c)), \
+# define CopFILEAVx(c) (assert_(CopFILE(c)) \
GvAV(gv_fetchfile(CopFILE(c))))
-# else
-# define CopFILEAVx(c) (GvAV(gv_fetchfile(CopFILE(c))))
-# endif
-# define CopSTASHPV(c) ((c)->cop_stashpv)
+# define CopSTASH(c) PL_stashpad[(c)->cop_stashoff]
+# define CopSTASH_set(c,hv) ((c)->cop_stashoff = (hv) \
+ ? alloccopstash(hv) \
+ : 0)
# ifdef NETWARE
-# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL))
-# else
-# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv))
-# endif
-
-# define CopSTASH(c) (CopSTASHPV(c) \
- ? 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))
-# ifdef NETWARE
-# define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
# define CopFILE_free(c) SAVECOPFILE_FREE(c)
# else
-# define CopSTASH_free(c) PerlMemShared_free(CopSTASHPV(c))
# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
# endif
#else
# else
# define CopFILEAVx(c) (GvAV(CopFILEGV(c)))
# endif
-# define CopFILE(c) (CopFILEGV(c) && GvSV(CopFILEGV(c)) \
- ? SvPVX(GvSV(CopFILEGV(c))) : NULL)
+# define CopFILE(c) (CopFILEGV(c) \
+ ? GvNAME(CopFILEGV(c))+2 : NULL)
# define CopSTASH(c) ((c)->cop_stash)
# 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 CopSTASH_free(c)
# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
#endif /* USE_ITHREADS */
-#define CopLABEL(c) Perl_fetch_cop_label(aTHX_ (c), NULL, NULL)
+
+#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 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 C<cop> with the key specified by
+C<keypv> and C<keylen>. If C<flags> has the C<COPHH_KEY_UTF8> bit set,
+the key octets are interpreted as UTF-8, otherwise they are interpreted
+as Latin-1. C<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|"literal string" 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 C<cop>. C<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_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)
#define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
/* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
#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.
- Setting it is ineficient 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)) \
- : 0)
-#define CopARYBASE_set(c, b) STMT_START { \
- if (b || ((c)->cop_hints & HINT_ARYBASE)) { \
- (c)->cop_hints |= HINT_ARYBASE; \
- 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
-
-/* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */
#define CopHINTS_get(c) ((c)->cop_hints + 0)
#define CopHINTS_set(c, h) STMT_START { \
(c)->cop_hints = (h); \
struct block_sub {
OP * retop; /* op to execute on exit from sub */
/* Above here is the same for sub, format and eval. */
+ PAD *prevcomppad; /* the caller's PL_comppad */
CV * cv;
/* Above here is the same for sub and format. */
- AV * savearray;
- AV * argarray;
I32 olddepth;
- PAD *oldcomppad;
+ AV *savearray;
};
struct block_format {
OP * retop; /* op to execute on exit from sub */
/* Above here is the same for sub, format and eval. */
+ PAD *prevcomppad; /* the caller's PL_comppad */
CV * cv;
/* Above here is the same for sub and format. */
GV * gv;
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->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(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.
- * 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) \
- ENTRY_PROBE(GvENAME(CvGV(cv)), \
- CopFILE((const COP *)CvSTART(cv)), \
- CopLINE((const COP *)CvSTART(cv))); \
- \
- cx->blk_sub.cv = cv; \
- cx->blk_sub.olddepth = CvDEPTH(cv); \
- cx->cx_type |= (hasargs) ? CXp_HASARGS : 0; \
- cx->blk_sub.retop = NULL; \
- if (!CvDEPTH(cv)) { \
- SvREFCNT_inc_simple_void_NN(cv); \
- SvREFCNT_inc_simple_void_NN(cv); \
- SAVEFREESV(cv); \
- }
-
-
-#define PUSHSUB(cx) \
- PUSHSUB_BASE(cx) \
- cx->blk_u16 = PL_op->op_private & \
- (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
-
-/* 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; \
- SvREFCNT_inc_void(cx->blk_format.dfoutgv)
-
-#define POP_SAVEARRAY() \
+ * The context frame holds a reference to the CV so that it can't be
+ * freed while we're executing it */
+
+
+#define CX_PUSHSUB_GET_LVALUE_MASK(func) \
+ /* If the context is indeterminate, then only the lvalue */ \
+ /* flags that the caller also has are applicable. */ \
+ ( \
+ (PL_op->op_flags & OPf_WANT) \
+ ? OPpENTERSUB_LVAL_MASK \
+ : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \
+ ? 0 : (U8)func(aTHX) \
+ )
+
+/* Restore old @_ */
+#define CX_POP_SAVEARRAY(cx) \
STMT_START { \
- SvREFCNT_dec(GvAV(PL_defgv)); \
+ AV *cx_pop_savearray_av = GvAV(PL_defgv); \
GvAV(PL_defgv) = cx->blk_sub.savearray; \
+ 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
AvFILLp(ary) = -1; \
} STMT_END
-#define POPSUB(cx,sv) \
- 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))); \
- \
- if (CxHASARGS(cx)) { \
- POP_SAVEARRAY(); \
- /* abandon @_ if it got reified */ \
- if (AvREAL(cx->blk_sub.argarray)) { \
- const SSize_t fill = AvFILLp(cx->blk_sub.argarray); \
- SvREFCNT_dec(cx->blk_sub.argarray); \
- 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) = MUTABLE_SV(cx->blk_sub.argarray); \
- } \
- else { \
- CLEAR_ARGARRAY(cx->blk_sub.argarray); \
- } \
- } \
- sv = MUTABLE_SV(cx->blk_sub.cv); \
- if (sv && (CvDEPTH((const CV*)sv) = cx->blk_sub.olddepth)) \
- sv = NULL; \
- } STMT_END
-
-#define LEAVESUB(sv) \
- STMT_START { \
- if (sv) \
- SvREFCNT_dec(sv); \
- } STMT_END
-
-#define POPFORMAT(cx) \
- setdefout(cx->blk_format.dfoutgv); \
- SvREFCNT_dec(cx->blk_format.dfoutgv);
/* eval context */
struct block_eval {
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(), 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); \
- optype = CxOLD_OP_TYPE(cx); \
- PL_eval_root = cx->blk_eval.old_eval_root; \
- 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 {
- I32 resetsp;
LOOP * my_op; /* My op, that contains redo, next and last ops. */
union { /* different ways of locating the iteration variable */
- SV **svp;
- GV *gv;
- PAD *oldcomppad; /* only used in ITHREADS */
+ SV **svp; /* for lexicals: address of pad slot */
+ GV *gv; /* for package vars */
} itervar_u;
+ SV *itersave; /* the original iteration var */
union {
- struct { /* valid if type is LOOP_FOR or LOOP_PLAIN (but {NULL,0})*/
- AV * ary; /* use the stack if this is NULL */
- IV ix;
+ struct { /* CXt_LOOP_ARY, C<for (@ary)> */
+ AV *ary; /* array being iterated over */
+ IV ix; /* index relative to base of array */
} ary;
- struct { /* valid if type is LOOP_LAZYIV */
+ struct { /* CXt_LOOP_LIST, C<for (list)> */
+ I32 basesp; /* first element of list on stack */
+ IV ix; /* index relative to basesp */
+ } stack;
+ struct { /* CXt_LOOP_LAZYIV, C<for (1..9)> */
IV cur;
IV end;
} lazyiv;
- struct { /* valid if type if LOOP_LAZYSV */
+ struct { /* CXt_LOOP_LAZYSV C<for ('a'..'z')> */
SV * cur;
SV * end; /* maxiumum value (or minimum in reverse) */
} lazysv;
} state_u;
-};
-
#ifdef USE_ITHREADS
-# define CxITERVAR_PADSV(c) \
- &CX_CURPAD_SV( (c)->blk_loop.itervar_u, (c)->blk_loop.my_op->op_targ)
-#else
-# define CxITERVAR_PADSV(c) ((c)->blk_loop.itervar_u.svp)
+ PAD *oldcomppad; /* needed to map itervar_u.svp during thread clone */
#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 CxITERVAR(c) \
+ (CxPADLOOP(c) \
+ ? (c)->blk_loop.itervar_u.svp \
+ : ((c)->cx_type & CXp_FOR_GV) \
+ ? &GvSV((c)->blk_loop.itervar_u.gv) \
+ : (SV **)&(c)->blk_loop.itervar_u.gv)
#define CxLABEL(c) (0 + CopLABEL((c)->blk_oldcop))
+#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)
-
-#define PUSHLOOP_PLAIN(cx, s) \
- cx->blk_loop.resetsp = s - PL_stack_base; \
- cx->blk_loop.my_op = cLOOP; \
- cx->blk_loop.state_u.ary.ary = NULL; \
- cx->blk_loop.state_u.ary.ix = 0; \
- cx->blk_loop.itervar_u.svp = NULL;
-
-#define PUSHLOOP_FOR(cx, ivar, s) \
- cx->blk_loop.resetsp = s - PL_stack_base; \
- cx->blk_loop.my_op = cLOOP; \
- cx->blk_loop.state_u.ary.ary = NULL; \
- cx->blk_loop.state_u.ary.ix = 0; \
- cx->blk_loop.itervar_u.svp = (SV**)(ivar);
-
-#define POPLOOP(cx) \
- if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { \
- SvREFCNT_dec(cx->blk_loop.state_u.lazysv.cur); \
- SvREFCNT_dec(cx->blk_loop.state_u.lazysv.end); \
- } \
- if (CxTYPE(cx) == CXt_LOOP_FOR) \
- SvREFCNT_dec(cx->blk_loop.state_u.ary.ary);
+
+/* 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))
+
+
/* given/when context */
struct block_givwhen {
OP *leave_op;
+ SV *defsv_save; /* the original $_ */
};
-#define PUSHGIVEN(cx) \
- cx->blk_givwhen.leave_op = cLOGOP->op_other;
-#define PUSHWHEN PUSHGIVEN
/* context common to subroutines, evals and loops */
struct block {
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_oldsp; /* stack pointer to copy stuff down to */
- COP * blku_oldcop; /* old curcop pointer */
+ 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 */
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) at %s:%d\n", \
+ 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)(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; \
- DEBUG_CX("PUSH");
-
-/* Exit a block (RETURN and LAST). */
-#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;
-
-/* 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 */
- I32 sbu_iters;
- I32 sbu_maxiters;
- I32 sbu_oldsave;
+ 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;
SV * sbu_dstr;
SV * sbu_targ;
#define sb_iters cx_u.cx_subst.sbu_iters
#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
#define sb_rx cx_u.cx_subst.sbu_rx
#ifdef PERL_CORE
-# define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
+# 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, \
- cx->sb_oldsave = oldsave, \
cx->sb_rxtainted = rxtainted, \
cx->sb_orig = orig, \
cx->sb_dstr = dstr, \
cx->sb_rx = rx, \
cx->cx_type = CXt_SUBST | (once ? CXp_ONCE : 0); \
rxres_save(&cx->sb_rxres, rx); \
- (void)ReREFCNT_inc(rx)
+ (void)ReREFCNT_inc(rx); \
+ SvREFCNT_inc_void_NN(targ)
-# define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \
+# define CX_POPSUBST(cx) \
+ STMT_START { \
+ REGEXP *re; \
+ assert(CxTYPE(cx) == CXt_SUBST); \
rxres_free(&cx->sb_rxres); \
- ReREFCNT_dec(cx->sb_rx)
+ 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)
/* If you re-order these, there is also an array of uppercase names in perl.h
and a static array of context names in pp_ctl.c */
#define CXTYPEMASK 0xf
-#define CXt_NULL 0
+#define CXt_NULL 0 /* currently only used for sort BLOCK */
#define CXt_WHEN 1
#define CXt_BLOCK 2
/* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a
The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c
*/
#define CXt_GIVEN 3
-/* This is first so that CXt_LOOP_FOR|CXt_LOOP_LAZYIV is CXt_LOOP_LAZYIV */
-#define CXt_LOOP_FOR 4
-#define CXt_LOOP_PLAIN 5
-#define CXt_LOOP_LAZYSV 6
-#define CXt_LOOP_LAZYIV 7
-#define CXt_SUB 8
-#define CXt_FORMAT 9
-#define CXt_EVAL 10
-#define CXt_SUBST 11
-/* SUBST doesn't feature in all switch statements. */
-/* private flags for CXt_SUB and CXt_NULL
- However, this is checked in many places which do not check the type, so
- this bit needs to be kept clear for most everything else. For reasons I
- haven't investigated, it can coexist with CXp_FOR_DEF */
-#define CXp_MULTICALL 0x10 /* part of a multicall (so don't
- tear down context on exit). */
+/* be careful of the ordering of these five. Macros like CxTYPE_is_LOOP,
+ * CxFOREACH compare ranges */
+#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 CXt_SUBST 12
+/* SUBST doesn't feature in all switch statements. */
/* private flags for CXt_SUB and CXt_FORMAT */
+#define CXp_MULTICALL 0x10 /* part of a multicall (so don't tear down
+ context on exit). (not CXt_FORMAT) */
#define CXp_HASARGS 0x20
+#define CXp_SUB_RE 0x40 /* code called within regex, i.e. (?{}) */
+#define CXp_SUB_RE_FAKE 0x80 /* fake sub CX for (?{}) in current scope */
/* private flags for CXt_EVAL */
#define CXp_REAL 0x20 /* truly eval'', not a lookalike */
#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 $_ */
-#define CxPADLOOP(c) ((c)->blk_loop.my_op->op_targ)
+/* 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) (((c)->cx_type & 0xC) == 0x4)
-#define CxMULTICALL(c) (((c)->cx_type & CXp_MULTICALL) \
- == CXp_MULTICALL)
+#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_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN)
-#define CxFOREACHDEF(c) ((CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN) \
- && ((c)->cx_type & CXp_FOR_DEF))
+#define CxFOREACH(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \
+ && CxTYPE(cx) <= CXt_LOOP_LIST)
#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
/*
=for apidoc AmU||G_SCALAR
-Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and
+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<GIMME_V>, C<GIMME> and
+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<
GIMME_V> and L<perlcall>.
+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
#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(). */
+#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
+#define G_METHOD_NAMED 4096 /* calling named method, eg without :: or ' */
/* flag bits for PL_in_eval */
#define EVAL_NULL 0 /* not in an eval */
#define EVAL_WARNONLY 2 /* used by yywarn() when calling yyerror() */
#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.
#define PERLSI_WARNHOOK 7
#define PERLSI_DIEHOOK 8
#define PERLSI_REQUIRE 9
+#define PERLSI_MULTICALL 10
struct stackinfo {
AV * si_stack; /* stack for current 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
+
};
typedef struct stackinfo PERL_SI;
# 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; \
+ PUSHSTACK_INIT_HWM(next); \
AvFILLp(next->si_stack) = 0; \
SWITCHSTACK(PL_curstack,next->si_stack); \
PL_curstackinfo = next; \
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); \
+ Perl_croak_popstack(); \
} \
SWITCHSTACK(PL_curstack,prev->si_stack); \
/* don't free prev here, free them all at the END{} */ \
} \
} STMT_END
-#define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
-#define IN_PERL_RUNTIME (PL_curcop != &PL_compiling)
+#define IN_PERL_COMPILETIME cBOOL(PL_curcop == &PL_compiling)
+#define IN_PERL_RUNTIME cBOOL(PL_curcop != &PL_compiling)
+
+
+
/*
=head1 Multicall Functions
=for apidoc Ams||dMULTICALL
-Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
+Declare local variables for a multicall. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
=for apidoc Ams||PUSH_MULTICALL
Opening bracket for a lightweight callback.
-See L<perlcall/Lightweight Callbacks>.
+See L<perlcall/LIGHTWEIGHT CALLBACKS>.
=for apidoc Ams||MULTICALL
-Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
+Make a lightweight callback. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
=for apidoc Ams||POP_MULTICALL
Closing bracket for a lightweight callback.
-See L<perlcall/Lightweight Callbacks>.
+See L<perlcall/LIGHTWEIGHT CALLBACKS>.
=cut
*/
#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)
+
+/* Like PUSH_MULTICALL, but allows you to specify extra flags
+ * for the CX stack entry (this isn't part of the public API) */
+
+#define PUSH_MULTICALL_FLAGS(the_cv, flags) \
STMT_START { \
+ PERL_CONTEXT *cx; \
CV * const _nOnclAshIngNamE_ = the_cv; \
CV * const cv = _nOnclAshIngNamE_; \
- AV * const padlist = CvPADLIST(cv); \
- ENTER; \
+ PADLIST * const padlist = CvPADLIST(cv); \
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) { \
- PERL_STACK_OVERFLOW_CHECK(); \
+ PUSHSTACKi(PERLSI_MULTICALL); \
+ 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_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
- } \
- SAVECOMPPAD(); \
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
- multicall_cv = cv; \
multicall_cop = CvSTART(cv); \
} STMT_END
#define POP_MULTICALL \
STMT_START { \
- LEAVESUB(multicall_cv); \
- CvDEPTH(multicall_cv)--; \
- POPBLOCK(cx,PL_curpm); \
+ PERL_CONTEXT *cx; \
+ cx = CX_CUR(); \
+ CX_LEAVE_SCOPE(cx); \
+ cx_popsub_common(cx); \
+ gimme = cx->blk_gimme; \
+ PERL_UNUSED_VAR(gimme); /* for API */ \
+ cx_popblock(cx); \
+ CX_POP(cx); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
- LEAVE; \
SPAGAIN; \
} STMT_END
+/* Change the CV of an already-pushed MULTICALL CxSUB block.
+ * (this isn't part of the public API) */
+
+#define CHANGE_MULTICALL_FLAGS(the_cv, flags) \
+ STMT_START { \
+ CV * const _nOnclAshIngNamE_ = the_cv; \
+ CV * const cv = _nOnclAshIngNamE_; \
+ PADLIST * const padlist = CvPADLIST(cv); \
+ PERL_CONTEXT *cx = CX_CUR(); \
+ assert(CxMULTICALL(cx)); \
+ cx_popsub_common(cx); \
+ cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \
+ cx_pushsub(cx, cv, NULL, 0); \
+ if (!(flags & CXp_SUB_RE_FAKE)) \
+ CvDEPTH(cv)++; \
+ if (CvDEPTH(cv) >= 2) \
+ Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
+ multicall_cop = CvSTART(cv); \
+ } STMT_END
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: t
- * End:
- *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff