X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/df530c37b924f51b6982d30ba7e0934eb75f2b6d..f0bb9bf76bbed7ffe177496880af0e8873394453:/cop.h diff --git a/cop.h b/cop.h index c91e9a4..e430201 100644 --- a/cop.h +++ b/cop.h @@ -7,7 +7,7 @@ * 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. @@ -31,21 +31,14 @@ 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 */ }; typedef struct jmpenv JMPENV; -#ifdef OP_IN_REGISTER -#define OP_REG_TO_MEM PL_opsave = op -#define OP_MEM_TO_REG op = PL_opsave -#else -#define OP_REG_TO_MEM NOOP -#define OP_MEM_TO_REG NOOP -#endif - /* * How to build the first jmpenv. * @@ -58,10 +51,12 @@ typedef struct jmpenv JMPENV; #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; \ } STMT_END /* @@ -92,8 +87,9 @@ typedef struct jmpenv JMPENV; * * 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 @@ -106,11 +102,10 @@ typedef struct jmpenv JMPENV; 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); \ - OP_MEM_TO_REG; \ PL_top_env = &cur_env; \ cur_env.je_mustcatch = FALSE; \ + cur_env.je_old_delaymagic = PL_delaymagic; \ (v) = cur_env.je_ret; \ } STMT_END @@ -122,6 +117,7 @@ typedef struct jmpenv JMPENV; 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 @@ -132,12 +128,11 @@ typedef struct jmpenv JMPENV; 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 @@ -152,6 +147,230 @@ typedef struct jmpenv JMPENV; 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 with the key specified by +C and C. If C has the C bit set, +the key octets are interpreted as UTF-8, otherwise they are interpreted +as Latin-1. C 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, 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, 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, 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. C 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. + +=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, 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, +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 if you need both hashes. + +The key is specified by C and C. If C has the +C bit set, the key octets are interpreted as UTF-8, +otherwise they are interpreted as Latin-1. C is a precomputed +hash of the key string, or zero if it has not been precomputed. + +C is the scalar value to store for this key. C 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, 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, 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, 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, +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 if you need both hashes. + +The key is specified by C and C. If C has the +C bit set, the key octets are interpreted as UTF-8, +otherwise they are interpreted as Latin-1. C 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, 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, 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, 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" @@ -162,7 +381,8 @@ struct cop { 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 */ @@ -174,7 +394,7 @@ struct cop { 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 @@ -184,7 +404,7 @@ struct cop { # 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))) @@ -194,29 +414,16 @@ struct cop { ? 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) - -# 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)) +# define CopSTASH(c) PL_stashpad[(c)->cop_stashoff] +# define CopSTASH_set(c,hv) ((c)->cop_stashoff = (hv) \ + ? alloccopstash(hv) \ + : 0) # 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 @@ -231,19 +438,95 @@ struct cop { # 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 with the key specified by +C and C. If C has the C bit set, +the key octets are interpreted as UTF-8, otherwise they are interpreted +as Latin-1. C 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, 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, 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, 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. C 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)) @@ -255,33 +538,6 @@ struct cop { /* 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); \ @@ -294,20 +550,24 @@ struct cop { /* subroutine context */ struct block_sub { OP * retop; /* op to execute on exit from sub */ + I32 old_savestack_ix; /* saved PL_savestack_ix (also CXt_NULL) */ + SSize_t old_tmpsfloor; /* also used in CXt_NULL sort block */ /* 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; }; /* format context */ struct block_format { OP * retop; /* op to execute on exit from sub */ + I32 old_savestack_ix; /* saved PL_savestack_ix (also CXt_NULL) */ + SSize_t old_tmpsfloor; /* also used in CXt_NULL sort block */ /* 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; @@ -315,29 +575,43 @@ struct block_format { }; /* 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. */ + * 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(GvENAME(CvGV(cv)), \ + ENTRY_PROBE(CvNAMED(cv) \ + ? HEK_KEY(CvNAME_HEK(cv)) \ + : 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); \ + cx->blk_sub.prevcomppad = PL_comppad; \ 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); \ - } - + SvREFCNT_inc_simple_void_NN(cv); \ + cx->blk_sub.old_tmpsfloor = PL_tmps_floor; \ + PL_tmps_floor = PL_tmps_ix; + +#define 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) \ + ) #define PUSHSUB(cx) \ + { \ + U8 phlags = PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub); \ PUSHSUB_BASE(cx) \ cx->blk_u16 = PL_op->op_private & \ - (OPpLVAL_INTRO|OPpENTERSUB_INARGS); + (phlags|OPpDEREF); \ + } /* variant for use by OP_DBSTATE, where op_private holds hint bits */ #define PUSHSUB_DB(cx) \ @@ -350,12 +624,21 @@ struct block_format { 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->blk_format.old_savestack_ix = PL_savestack_ix; \ + cx->blk_format.old_tmpsfloor = PL_tmps_floor; \ + PL_tmps_floor = PL_tmps_ix; \ + SvREFCNT_inc_simple_void_NN(cv); \ + CvDEPTH(cv)++; \ SvREFCNT_inc_void(cx->blk_format.dfoutgv) +/* Restore old @_ */ #define POP_SAVEARRAY() \ STMT_START { \ - SvREFCNT_dec(GvAV(PL_defgv)); \ + AV *av = GvAV(PL_defgv); \ GvAV(PL_defgv) = cx->blk_sub.savearray; \ + SvREFCNT_dec(av); \ } STMT_END /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't @@ -369,43 +652,65 @@ struct block_format { #define POPSUB(cx,sv) \ STMT_START { \ - RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)), \ + LEAVE_SCOPE(cx->blk_sub.old_savestack_ix); \ + 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))); \ + CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \ + CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \ \ if (CxHASARGS(cx)) { \ + 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 */ \ - 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); \ - } \ + av = MUTABLE_AV(PAD_SVl(0)); \ + if (UNLIKELY(AvREAL(av))) \ + clear_defarray(av, 0); \ else { \ - CLEAR_ARGARRAY(cx->blk_sub.argarray); \ + CLEAR_ARGARRAY(av); \ } \ } \ + } \ + PL_tmps_floor = cx->blk_sub.old_tmpsfloor; \ + PL_comppad = cx->blk_sub.prevcomppad; \ + PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; \ sv = MUTABLE_SV(cx->blk_sub.cv); \ - if (sv && (CvDEPTH((const CV*)sv) = cx->blk_sub.olddepth)) \ - sv = NULL; \ + CvDEPTH((const CV*)sv) = cx->blk_sub.olddepth; \ } STMT_END #define LEAVESUB(sv) \ STMT_START { \ - if (sv) \ - SvREFCNT_dec(sv); \ + SvREFCNT_dec(sv); \ } STMT_END #define POPFORMAT(cx) \ - setdefout(cx->blk_format.dfoutgv); \ - SvREFCNT_dec(cx->blk_format.dfoutgv); + STMT_START { \ + LEAVE_SCOPE(cx->blk_format.old_savestack_ix); \ + 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; \ + PL_tmps_floor = cx->blk_format.old_tmpsfloor; \ + 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_savestack_ix; /* saved PL_savestack_ix (also CXt_NULL) */ + SSize_t old_tmpsfloor; /* also used in CXt_NULL sort block */ /* Above here is the same for sub, format and eval. */ SV * old_namesv; OP * old_eval_root; @@ -426,6 +731,8 @@ struct block_eval { 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_tmpsfloor = PL_tmps_floor; \ + PL_tmps_floor = PL_tmps_ix; \ 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; \ @@ -439,6 +746,8 @@ struct block_eval { 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.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 @@ -446,12 +755,13 @@ struct block_eval { /* loop context */ struct block_loop { I32 resetsp; + I32 old_savestack_ix; /* saved PL_savestack_ix (also CXt_NULL) */ 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 */ @@ -466,43 +776,78 @@ struct block_loop { SV * end; /* maxiumum value (or minimum in reverse) */ } lazysv; } state_u; -}; - #ifdef USE_ITHREADS -# define CxITERVAR(c) \ - ((c)->blk_loop.itervar_u.oldcomppad \ - ? (CxPADLOOP(c) \ - ? &CX_CURPAD_SV( (c)->blk_loop.itervar_u, (c)->blk_loop.my_op->op_targ) \ - : &GvSV((c)->blk_loop.itervar_u.gv)) \ - : (SV**)NULL) -#else -# define CxITERVAR(c) ((c)->blk_loop.itervar_u.svp) + PAD *oldcomppad; /* needed to map itervar_u.svp during thread clone */ #endif +}; + +#define CxITERVAR(c) \ + (CxPADLOOP(c) \ + ? (c)->blk_loop.itervar_u.svp \ + : (c)->blk_loop.itervar_u.svp \ + ? isGV((c)->blk_loop.itervar_u.gv) \ + ? &GvSV((c)->blk_loop.itervar_u.gv) \ + : (SV **)&(c)->blk_loop.itervar_u.gv \ + : (SV**)NULL) + #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 CxLVAL(c) (0 + ((c)->blk_u16 & 0xff)) +/* POPSUB has already been performed on this context frame */ +#define CxPOPSUB_DONE 0x100 + #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; + cx->blk_loop.old_savestack_ix = PL_savestack_ix; \ + cx->blk_loop.itervar_u.svp = NULL; \ + cx->blk_loop.itersave = NULL; -#define PUSHLOOP_FOR(cx, ivar, s) \ +#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, 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); + cx->blk_loop.itervar_u.svp = (SV**)(ivar); \ + cx->blk_loop.old_savestack_ix = PL_savestack_ix; \ + cx->blk_loop.itersave = isave; \ + PUSHLOOP_FOR_setpad(cx); #define POPLOOP(cx) \ + LEAVE_SCOPE(cx->blk_loop.old_savestack_ix); \ if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { \ - SvREFCNT_dec(cx->blk_loop.state_u.lazysv.cur); \ - SvREFCNT_dec(cx->blk_loop.state_u.lazysv.end); \ + SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.cur); \ + SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.end); \ } \ - if (CxTYPE(cx) == CXt_LOOP_FOR) \ - SvREFCNT_dec(cx->blk_loop.state_u.ary.ary); + else if (CxTYPE(cx) == CXt_LOOP_FOR) \ + SvREFCNT_dec(cx->blk_loop.state_u.ary.ary); \ + if (cx->blk_loop.itersave) { \ + SV **svp = (cx)->blk_loop.itervar_u.svp; \ + SV *cursv; \ + if (isGV((GV*)svp)) { \ + svp = &GvSV((GV*)svp); \ + cursv = *svp; \ + *svp = cx->blk_loop.itersave; \ + SvREFCNT_dec_NN(cx->blk_loop.itersave); \ + } \ + else { \ + cursv = *svp; \ + *svp = cx->blk_loop.itersave; \ + } \ + /* delayed rc-- in case of "for $x (...) { return $x }" */ \ + sv_2mortal(cursv); \ + } \ /* given/when context */ struct block_givwhen { @@ -592,9 +937,9 @@ struct subst { U8 sbu_type; /* what kind of context this is */ U8 sbu_rflags; U16 sbu_rxtainted; /* matches struct block */ - I32 sbu_iters; - I32 sbu_maxiters; I32 sbu_oldsave; + SSize_t sbu_iters; + SSize_t sbu_maxiters; char * sbu_orig; SV * sbu_dstr; SV * sbu_targ; @@ -608,7 +953,6 @@ 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 @@ -636,11 +980,13 @@ struct subst { 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--]; \ rxres_free(&cx->sb_rxres); \ - ReREFCNT_dec(cx->sb_rx) + ReREFCNT_dec(cx->sb_rx); \ + SvREFCNT_dec_NN(cx->sb_targ) #endif #define CxONCE(cx) ((cx)->cx_type & CXp_ONCE) @@ -684,6 +1030,8 @@ struct context { /* private flags for CXt_SUB and 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 */ @@ -691,9 +1039,8 @@ struct context { /* private flags for CXt_LOOP */ #define CXp_FOR_DEF 0x10 /* foreach using $_ */ -#ifdef USE_ITHREADS -# define CxPADLOOP(c) ((c)->blk_loop.my_op->op_targ) -#endif +#define CXp_FOR_LVREF 0x20 /* foreach using \$var */ +#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 */ @@ -718,15 +1065,15 @@ struct context { /* =for apidoc AmU||G_SCALAR -Used to indicate scalar context. See C, C, and +Used to indicate scalar context. See C>, C>, and L. =for apidoc AmU||G_ARRAY -Used to indicate list context. See C, C and +Used to indicate list context. See C>, C> and L. =for apidoc AmU||G_VOID -Used to indicate void context. See C and L. +Used to indicate void context. See C> and L. =for apidoc AmU||G_DISCARD Indicates that arguments returned from a callback should be discarded. See @@ -764,6 +1111,10 @@ L. #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 */ @@ -771,6 +1122,7 @@ L. #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 */ /* Support for switching (stack and block) contexts. * This ensures magic doesn't invalidate local stack and cx pointers. @@ -787,6 +1139,7 @@ L. #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 */ @@ -849,8 +1202,7 @@ typedef struct stackinfo PERL_SI; 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{} */ \ @@ -872,18 +1224,18 @@ typedef struct stackinfo PERL_SI; =head1 Multicall Functions =for apidoc Ams||dMULTICALL -Declare local variables for a multicall. See L. +Declare local variables for a multicall. See L. =for apidoc Ams||PUSH_MULTICALL Opening bracket for a lightweight callback. -See L. +See L. =for apidoc Ams||MULTICALL -Make a lightweight callback. See L. +Make a lightweight callback. See L. =for apidoc Ams||POP_MULTICALL Closing bracket for a lightweight callback. -See L. +See L. =cut */ @@ -897,22 +1249,29 @@ See L. U8 hasargs = 0 /* used by PUSHSUB */ #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 { \ 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); \ + PUSHSTACKi(PERLSI_MULTICALL); \ + PUSHBLOCK(cx, (CXt_SUB|CXp_MULTICALL|flags), PL_stack_sp); \ PUSHSUB(cx); \ - if (++CvDEPTH(cv) >= 2) { \ + cx->blk_sub.old_savestack_ix = PL_savestack_ix; \ + SAVEVPTR(PL_op); \ + if (!(flags & CXp_SUB_RE_FAKE)) \ + CvDEPTH(cv)++; \ + if (CvDEPTH(cv) >= 2) { \ PERL_STACK_OVERFLOW_CHECK(); \ Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ } \ - SAVECOMPPAD(); \ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ multicall_cv = cv; \ multicall_cop = CvSTART(cv); \ @@ -926,21 +1285,53 @@ See L. #define POP_MULTICALL \ STMT_START { \ - LEAVESUB(multicall_cv); \ - CvDEPTH(multicall_cv)--; \ + cx = &cxstack[cxstack_ix]; \ + CvDEPTH(multicall_cv) = cx->blk_sub.olddepth; \ + LEAVESUB(multicall_cv); \ POPBLOCK(cx,PL_curpm); \ + /* includes partial unrolled POPSUB(): */ \ + LEAVE_SCOPE(cx->blk_sub.old_savestack_ix); \ + PL_comppad = cx->blk_sub.prevcomppad; \ + PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; \ 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); \ + cx = &cxstack[cxstack_ix]; \ + assert(cx->cx_type & CXp_MULTICALL); \ + CvDEPTH(multicall_cv) = cx->blk_sub.olddepth; \ + LEAVESUB(multicall_cv); \ + cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \ + { \ + /* save a few things that we don't want PUSHSUB to zap */ \ + PAD * const prevcomppad = cx->blk_sub.prevcomppad; \ + SSize_t old_floor = cx->blk_sub.old_tmpsfloor; \ + SSize_t floor = PL_tmps_floor; \ + PUSHSUB(cx); \ + /* undo the stuff that PUSHSUB zapped */ \ + cx->blk_sub.prevcomppad = prevcomppad ; \ + cx->blk_sub.old_tmpsfloor = old_floor; \ + PL_tmps_floor = floor; \ + } \ + if (!(flags & CXp_SUB_RE_FAKE)) \ + CvDEPTH(cv)++; \ + if (CvDEPTH(cv) >= 2) { \ + PERL_STACK_OVERFLOW_CHECK(); \ + Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ + } \ + PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ + multicall_cv = 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: */