X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=blobdiff_plain;f=Upper.xs;h=efc799ab07f3baa44db5375b493261c05fbf4f49;hp=0d51f43925ba86c1823e3e3d447d508ab538a05f;hb=f0ee3a495f7f12754a9e79ef83f9affc69ad2f66;hpb=aa287c017fc604bccef210250c7235b4e2e5a849 diff --git a/Upper.xs b/Upper.xs index 0d51f43..efc799a 100644 --- a/Upper.xs +++ b/Upper.xs @@ -6,21 +6,21 @@ #include "perl.h" #include "XSUB.h" -#define __PACKAGE__ "Scope::Upper" +/* --- XS helpers ---------------------------------------------------------- */ -#ifndef SU_DEBUG -# define SU_DEBUG 0 -#endif +#define XSH_PACKAGE "Scope::Upper" + +#include "xsh/caps.h" +#include "xsh/util.h" +#include "xsh/debug.h" /* --- Compatibility ------------------------------------------------------- */ -#ifndef NOOP -# define NOOP +/* perl 5.23.8 onwards has a revamped context system */ +#if XSH_HAS_PERL(5, 23, 8) +# define SU_HAS_NEW_CXT #endif -#ifndef dNOOP -# define dNOOP -#endif #ifndef dVAR # define dVAR dNOOP @@ -42,20 +42,6 @@ # define PERL_UNUSED_VAR(V) #endif -#ifndef STMT_START -# define STMT_START do -#endif - -#ifndef STMT_END -# define STMT_END while (0) -#endif - -#if SU_DEBUG -# define SU_D(X) STMT_START X STMT_END -#else -# define SU_D(X) -#endif - #ifndef Newx # define Newx(v, n, c) New(0, v, n, c) #endif @@ -72,7 +58,7 @@ #endif #ifndef newSV_type -STATIC SV *su_newSV_type(pTHX_ svtype t) { +static SV *su_newSV_type(pTHX_ svtype t) { SV *sv = newSV(0); SvUPGRADE(sv, t); return sv; @@ -80,6 +66,13 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define newSV_type(T) su_newSV_type(aTHX_ (T)) #endif +#ifdef newSVpvn_flags +# define su_newmortal_pvn(S, L) newSVpvn_flags((S), (L), SVs_TEMP) +#else +# define su_newmortal_pvn(S, L) sv_2mortal(newSVpvn((S), (L))) +#endif +#define su_newmortal_pvs(S) su_newmortal_pvn((S), sizeof(S)-1) + #ifndef SvPV_const # define SvPV_const(S, L) SvPV(S, L) #endif @@ -125,16 +118,57 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define CxHASARGS(C) ((C)->blk_sub.hasargs) #endif +#ifndef CxGIMME +# ifdef G_WANT +# define CxGIMME(C) ((C)->blk_gimme & G_WANT) +# else +# define CxGIMME(C) ((C)->blk_gimme) +# endif +#endif + +#ifndef CxOLD_OP_TYPE +# define CxOLD_OP_TYPE(C) (C)->blk_eval.old_op_type +#endif + +#ifndef OutCopFILE +# define OutCopFILE(C) CopFILE(C) +#endif + +#ifndef OutCopFILE_len +# define OutCopFILE_len(C) strlen(OutCopFILE(C)) +#endif + +#ifndef CopHINTS_get +# define CopHINTS_get(C) ((I32) (C)->op_private & HINT_PRIVATE_MASK) +#endif + +#ifndef CopHINTHASH_get +# define CopHINTHASH_get(C) (C)->cop_hints_hash +#endif + +#ifndef cophh_2hv +# define COPHH struct refcounted_he +# define cophh_2hv(H, F) Perl_refcounted_he_chain_2hv(aTHX_ (H)) +#endif + #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif +#ifndef HvNAMELEN +# define HvNAMELEN(H) strlen(HvNAME(H)) +#endif + #ifndef gv_fetchpvn_flags # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D)) #endif +#ifndef hv_fetchs +# define hv_fetchs(H, K, L) hv_fetch((H), (K), sizeof(K)-1, (L)) +#endif + #ifndef OP_GIMME_REVERSE -STATIC U8 su_op_gimme_reverse(U8 gimme) { +static U8 su_op_gimme_reverse(U8 gimme) { switch (gimme) { case G_VOID: return OPf_WANT_VOID; @@ -149,6 +183,14 @@ STATIC U8 su_op_gimme_reverse(U8 gimme) { #define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G) #endif +#ifndef OpSIBLING +# ifdef OP_SIBLING +# define OpSIBLING(O) OP_SIBLING(O) +# else +# define OpSIBLING(O) ((O)->op_sibling) +# endif +#endif + #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif @@ -161,44 +203,31 @@ STATIC U8 su_op_gimme_reverse(U8 gimme) { # define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES" #endif -#define SU_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) -#define SU_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S))) +/* CX_ARGARRAY(cx): the AV at pad[0] of the CV associated with CXt_SUB + * context cx */ + +#if XSH_HAS_PERL(5, 23, 8) +# define CX_ARGARRAY(cx) \ + ((AV*)(AvARRAY(MUTABLE_AV( \ + PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ \ + CvDEPTH(cx->blk_sub.cv)]))[0])) +/* XXX is the new def ok to use in lvalue cxt? Formerly it assigned to + * blk_sub.argarray, now to pad[0]. Does this matter? + */ +# define CX_ARGARRAY_set(cx,ary) \ + (AvARRAY(MUTABLE_AV( \ + PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ \ + CvDEPTH(cx->blk_sub.cv)]))[0] = (SV*)(ary)) +#else +# define CX_ARGARRAY(cx) (cx->blk_sub.argarray) +# define CX_ARGARRAY_set(cx,ary) (cx->blk_sub.argarray = (ary)) +#endif -/* --- Threads and multiplicity -------------------------------------------- */ -#ifndef SU_MULTIPLICITY -# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) -# define SU_MULTIPLICITY 1 -# else -# define SU_MULTIPLICITY 0 -# endif -#endif -#if SU_MULTIPLICITY && !defined(tTHX) -# define tTHX PerlInterpreter* -#endif +/* --- Error messages ------------------------------------------------------ */ -#if SU_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV)) -# define SU_THREADSAFE 1 -# ifndef MY_CXT_CLONE -# define MY_CXT_CLONE \ - dMY_CXT_SV; \ - my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ - Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ - sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) -# endif -#else -# define SU_THREADSAFE 0 -# undef dMY_CXT -# define dMY_CXT dNOOP -# undef MY_CXT -# define MY_CXT su_globaldata -# undef START_MY_CXT -# define START_MY_CXT STATIC my_cxt_t MY_CXT; -# undef MY_CXT_INIT -# define MY_CXT_INIT NOOP -# undef MY_CXT_CLONE -# define MY_CXT_CLONE NOOP -#endif +static const char su_stack_smash[] = "Cannot target a scope outside of the current stack"; +static const char su_no_such_target[] = "No targetable %s scope in the current stack"; /* --- Unique context ID global storage ------------------------------------ */ @@ -209,28 +238,20 @@ typedef struct { STRLEN size; } su_uv_array; -STATIC su_uv_array su_uid_seq_counter; +static su_uv_array su_uid_seq_counter; #ifdef USE_ITHREADS -STATIC perl_mutex su_uid_seq_counter_mutex; - -#define SU_LOCK(M) MUTEX_LOCK(M) -#define SU_UNLOCK(M) MUTEX_UNLOCK(M) - -#else /* USE_ITHREADS */ - -#define SU_LOCK(M) -#define SU_UNLOCK(M) +static perl_mutex su_uid_seq_counter_mutex; -#endif /* !USE_ITHREADS */ +#endif /* USE_ITHREADS */ -STATIC UV su_uid_seq_next(pTHX_ UV depth) { +static UV su_uid_seq_next(pTHX_ UV depth) { #define su_uid_seq_next(D) su_uid_seq_next(aTHX_ (D)) UV seq; UV *seqs; - SU_LOCK(&su_uid_seq_counter_mutex); + XSH_LOCK(&su_uid_seq_counter_mutex); seqs = su_uid_seq_counter.seqs; @@ -247,7 +268,7 @@ STATIC UV su_uid_seq_next(pTHX_ UV depth) { seq = ++seqs[depth]; - SU_UNLOCK(&su_uid_seq_counter_mutex); + XSH_UNLOCK(&su_uid_seq_counter_mutex); return seq; } @@ -261,7 +282,7 @@ typedef struct { #define SU_UID_ACTIVE 1 -STATIC UV su_uid_depth(pTHX_ I32 cxix) { +static UV su_uid_depth(pTHX_ I32 cxix) { #define su_uid_depth(I) su_uid_depth(aTHX_ (I)) const PERL_SI *si; UV depth; @@ -274,53 +295,47 @@ STATIC UV su_uid_depth(pTHX_ I32 cxix) { } typedef struct { - su_uid **map; - STRLEN used; - STRLEN alloc; + su_uid *map; + STRLEN used; + STRLEN alloc; } su_uid_storage; -STATIC void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_storage *old_cxt, UV max_depth) { +static void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_storage *old_cxt, UV max_depth) { #define su_uid_storage_dup(N, O, D) su_uid_storage_dup(aTHX_ (N), (O), (D)) - su_uid **old_map = old_cxt->map; + su_uid *old_map = old_cxt->map; if (old_map) { - su_uid **new_map = new_cxt->map; - STRLEN old_used = old_cxt->used; - STRLEN new_used, new_alloc; - STRLEN i; + su_uid *new_map = new_cxt->map; + STRLEN old_used = old_cxt->used; + STRLEN new_used, new_alloc; + STRLEN i; - new_used = max_depth < old_used ? max_depth : old_used; + new_used = max_depth < old_used ? max_depth : old_used; new_cxt->used = new_used; - if (new_used <= new_cxt->alloc) - new_alloc = new_cxt->alloc; - else { - new_alloc = new_used; - Renew(new_map, new_alloc, su_uid *); - for (i = new_cxt->alloc; i < new_alloc; ++i) - new_map[i] = NULL; + if (new_used <= new_cxt->alloc) { + new_alloc = new_cxt->alloc; + } else { + new_alloc = new_used; + Renew(new_map, new_alloc, su_uid); new_cxt->map = new_map; new_cxt->alloc = new_alloc; } for (i = 0; i < new_alloc; ++i) { - su_uid *new_uid = new_map[i]; + su_uid *new_uid = new_map + i; if (i < new_used) { /* => i < max_depth && i < old_used */ - su_uid *old_uid = old_map[i]; + su_uid *old_uid = old_map + i; if (old_uid && (old_uid->flags & SU_UID_ACTIVE)) { - if (!new_uid) { - Newx(new_uid, 1, su_uid); - new_map[i] = new_uid; - } *new_uid = *old_uid; continue; } } - if (new_uid) - new_uid->flags &= ~SU_UID_ACTIVE; + new_uid->seq = 0; + new_uid->flags = 0; } } @@ -349,7 +364,7 @@ typedef struct { /* --- uplevel() data tokens and global storage ---------------------------- */ -#define SU_UPLEVEL_HIJACKS_RUNOPS SU_HAS_PERL(5, 8, 0) +#define SU_UPLEVEL_HIJACKS_RUNOPS XSH_HAS_PERL(5, 8, 0) typedef struct { void *next; @@ -380,7 +395,7 @@ typedef struct { bool died; } su_uplevel_ud; -STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) { +static su_uplevel_ud *su_uplevel_ud_new(pTHX) { #define su_uplevel_ud_new() su_uplevel_ud_new(aTHX) su_uplevel_ud *sud; PERL_SI *si; @@ -396,14 +411,14 @@ STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) { si->si_stack = newAV(); AvREAL_off(si->si_stack); si->si_cxstack = NULL; - si->si_cxmax = 0; + si->si_cxmax = -1; sud->si = si; return sud; } -STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) { +static void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) { #define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S)) PERL_SI *si = sud->si; @@ -411,16 +426,7 @@ STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) { SvREFCNT_dec(si->si_stack); Safefree(si); - if (sud->tmp_uid_storage.map) { - su_uid **map = sud->tmp_uid_storage.map; - STRLEN alloc = sud->tmp_uid_storage.alloc; - STRLEN i; - - for (i = 0; i < alloc; ++i) - Safefree(map[i]); - - Safefree(map); - } + Safefree(sud->tmp_uid_storage.map); Safefree(sud); @@ -439,21 +445,42 @@ typedef struct { /* --- Global data --------------------------------------------------------- */ -#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION - typedef struct { char *stack_placeholder; su_unwind_storage unwind_storage; su_yield_storage yield_storage; su_uplevel_storage uplevel_storage; su_uid_storage uid_storage; -} my_cxt_t; +} xsh_user_cxt_t; + +#define XSH_THREADS_USER_CONTEXT 1 +#define XSH_THREADS_USER_CLONE_NEEDS_DUP 0 +#define XSH_THREADS_COMPILE_TIME_PROTECTION 0 -START_MY_CXT +#if XSH_THREADSAFE + +static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt) { + new_cxt->uplevel_storage.top = NULL; + new_cxt->uplevel_storage.root = NULL; + new_cxt->uplevel_storage.count = 0; + + new_cxt->uid_storage.map = NULL; + new_cxt->uid_storage.used = 0; + new_cxt->uid_storage.alloc = 0; + + su_uid_storage_dup(&new_cxt->uid_storage, &old_cxt->uid_storage, + old_cxt->uid_storage.used); + + return; +} + +#endif /* XSH_THREADSAFE */ + +#include "xsh/threads.h" /* --- Stack manipulations ------------------------------------------------- */ -#define SU_SAVE_PLACEHOLDER() save_pptr(&MY_CXT.stack_placeholder) +#define SU_SAVE_PLACEHOLDER() save_pptr(&XSH_CXT.stack_placeholder) #define SU_SAVE_DESTRUCTOR_SIZE 3 #define SU_SAVE_PLACEHOLDER_SIZE 3 @@ -484,11 +511,11 @@ START_MY_CXT #define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE -#if !SU_HAS_PERL(5, 8, 9) +#if !XSH_HAS_PERL(5, 8, 9) # define SU_SAVE_GP_SIZE 6 -#elif !SU_HAS_PERL(5, 13, 0) || (SU_RELEASE && SU_HAS_PERL_EXACT(5, 13, 0)) +#elif !XSH_HAS_PERL(5, 13, 0) || (SU_RELEASE && XSH_HAS_PERL_EXACT(5, 13, 0)) # define SU_SAVE_GP_SIZE 3 -#elif !SU_HAS_PERL(5, 13, 8) +#elif !XSH_HAS_PERL(5, 13, 8) # define SU_SAVE_GP_SIZE 4 #else # define SU_SAVE_GP_SIZE 3 @@ -507,7 +534,7 @@ START_MY_CXT /* ... Saving array elements ............................................... */ -STATIC I32 su_av_key2idx(pTHX_ AV *av, I32 key) { +static I32 su_av_key2idx(pTHX_ AV *av, I32 key) { #define su_av_key2idx(A, K) su_av_key2idx(aTHX_ (A), (K)) I32 idx; @@ -515,13 +542,14 @@ STATIC I32 su_av_key2idx(pTHX_ AV *av, I32 key) { return key; /* Added by MJD in perl-5.8.1 with 6f12eb6d2a1dfaf441504d869b27d2e40ef4966a */ -#if SU_HAS_PERL(5, 8, 1) +#if XSH_HAS_PERL(5, 8, 1) if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((SV *) av, PERL_MAGIC_tied); if (tied_magic) { - SV * const * const negative_indices_glob = - hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))), - NEGATIVE_INDICES_VAR, 16, 0); + SV * const * const negative_indices_glob = hv_fetch( + SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))), + NEGATIVE_INDICES_VAR, sizeof(NEGATIVE_INDICES_VAR)-1, 0 + ); if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) return key; } @@ -542,7 +570,7 @@ typedef struct { I32 idx; } su_ud_adelete; -STATIC void su_adelete(pTHX_ void *ud_) { +static void su_adelete(pTHX_ void *ud_) { su_ud_adelete *ud = (su_ud_adelete *) ud_; av_delete(ud->av, ud->idx, G_DISCARD); @@ -551,7 +579,7 @@ STATIC void su_adelete(pTHX_ void *ud_) { Safefree(ud); } -STATIC void su_save_adelete(pTHX_ AV *av, I32 idx) { +static void su_save_adelete(pTHX_ AV *av, I32 idx) { #define su_save_adelete(A, K) su_save_adelete(aTHX_ (A), (K)) su_ud_adelete *ud; @@ -567,7 +595,7 @@ STATIC void su_save_adelete(pTHX_ AV *av, I32 idx) { #endif /* SAVEADELETE */ -STATIC void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) { +static void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) { #define su_save_aelem(A, K, V) su_save_aelem(aTHX_ (A), (K), (V)) I32 idx; I32 preeminent = 1; @@ -597,7 +625,7 @@ STATIC void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) { /* ... Saving hash elements ................................................ */ -STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) { +static void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) { #define su_save_helem(H, K, V) su_save_helem(aTHX_ (H), (K), (V)) I32 preeminent = 1; HE *he; @@ -635,7 +663,7 @@ STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) { /* ... Saving code slots from a glob ....................................... */ -#if !SU_HAS_PERL(5, 10, 0) && !defined(mro_method_changed_in) +#if !XSH_HAS_PERL(5, 10, 0) && !defined(mro_method_changed_in) # define mro_method_changed_in(G) PL_sub_generation++ #endif @@ -644,7 +672,7 @@ typedef struct { CV *old_cv; } su_save_gvcv_ud; -STATIC void su_restore_gvcv(pTHX_ void *ud_) { +static void su_restore_gvcv(pTHX_ void *ud_) { su_save_gvcv_ud *ud = ud_; GV *gv = ud->gv; @@ -655,7 +683,7 @@ STATIC void su_restore_gvcv(pTHX_ void *ud_) { Safefree(ud); } -STATIC void su_save_gvcv(pTHX_ GV *gv) { +static void su_save_gvcv(pTHX_ GV *gv) { #define su_save_gvcv(G) su_save_gvcv(aTHX_ (G)) su_save_gvcv_ud *ud; @@ -673,16 +701,23 @@ STATIC void su_save_gvcv(pTHX_ GV *gv) { /* --- Actions ------------------------------------------------------------- */ typedef struct { - I32 depth; - I32 pad; + U8 type; + U8 private; + U8 pad; + /* spare */ + I32 depth; I32 *origin; - void (*handler)(pTHX_ void *); } su_ud_common; -#define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth) +#define SU_UD_TYPE(U) (((su_ud_common *) (U))->type) +#define SU_UD_PRIVATE(U) (((su_ud_common *) (U))->private) #define SU_UD_PAD(U) (((su_ud_common *) (U))->pad) +#define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth) #define SU_UD_ORIGIN(U) (((su_ud_common *) (U))->origin) -#define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler) + +#define SU_UD_TYPE_REAP 0 +#define SU_UD_TYPE_LOCALIZE 1 +#define SU_UD_TYPE_UID 2 #define SU_UD_FREE(U) STMT_START { \ if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \ @@ -691,15 +726,16 @@ typedef struct { /* ... Reap ................................................................ */ -#define SU_SAVE_LAST_CX (!SU_HAS_PERL(5, 8, 4) || (SU_HAS_PERL(5, 9, 5) && !SU_HAS_PERL(5, 14, 0)) || SU_HAS_PERL(5, 15, 0)) +#define SU_SAVE_LAST_CX (!XSH_HAS_PERL(5, 8, 4) || (XSH_HAS_PERL(5, 9, 5) && !XSH_HAS_PERL(5, 14, 0)) || XSH_HAS_PERL(5, 15, 0)) typedef struct { su_ud_common ci; - SV *cb; + SV *cb; } su_ud_reap; -STATIC void su_call(pTHX_ void *ud_) { - su_ud_reap *ud = (su_ud_reap *) ud_; +#define SU_UD_REAP_CB(U) (((su_ud_reap *) (U))->cb) + +static void su_call(pTHX_ SV *cb) { #if SU_SAVE_LAST_CX I32 cxix; PERL_CONTEXT saved_cx; @@ -707,11 +743,8 @@ STATIC void su_call(pTHX_ void *ud_) { dSP; - SU_D({ - PerlIO_printf(Perl_debug_log, - "%p: @@@ call\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n", - ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix); - }); + XSH_D(su_debug_log("@@@ call scope_ix=%2d save_ix=%2d\n", + PL_scopestack_ix, PL_savestack_ix)); ENTER; SAVETMPS; @@ -726,7 +759,7 @@ STATIC void su_call(pTHX_ void *ud_) { saved_cx = cxstack[cxix]; #endif /* SU_SAVE_LAST_CX */ - call_sv(ud->cb, G_VOID); + call_sv(cb, G_VOID); #if SU_SAVE_LAST_CX cxstack[cxix] = saved_cx; @@ -737,39 +770,32 @@ STATIC void su_call(pTHX_ void *ud_) { FREETMPS; LEAVE; - SvREFCNT_dec(ud->cb); - SU_UD_FREE(ud); -} + SvREFCNT_dec(cb); -STATIC void su_reap(pTHX_ void *ud) { -#define su_reap(U) su_reap(aTHX_ (U)) - SU_D({ - PerlIO_printf(Perl_debug_log, - "%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n", - ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix); - }); - - SAVEDESTRUCTOR_X(su_call, ud); + return; } /* ... Localize & localize array/hash element .............................. */ typedef struct { su_ud_common ci; - SV *sv; - SV *val; - SV *elem; - svtype type; + SV *sv; + SV *val; + SV *elem; } su_ud_localize; +#define SU_UD_LOCALIZE_SV(U) (((su_ud_localize *) (U))->sv) +#define SU_UD_LOCALIZE_VAL(U) (((su_ud_localize *) (U))->val) +#define SU_UD_LOCALIZE_ELEM(U) (((su_ud_localize *) (U))->elem) + #define SU_UD_LOCALIZE_FREE(U) STMT_START { \ - SvREFCNT_dec((U)->elem); \ - SvREFCNT_dec((U)->val); \ - SvREFCNT_dec((U)->sv); \ - SU_UD_FREE(U); \ + SvREFCNT_dec(SU_UD_LOCALIZE_ELEM(U)); \ + SvREFCNT_dec(SU_UD_LOCALIZE_VAL(U)); \ + SvREFCNT_dec(SU_UD_LOCALIZE_SV(U)); \ + SU_UD_FREE(U); \ } STMT_END -STATIC I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) { +static I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) { #define su_ud_localize_init(UD, S, V, E) su_ud_localize_init(aTHX_ (UD), (S), (V), (E)) UV deref = 0; svtype t = SVt_NULL; @@ -842,21 +868,22 @@ STATIC I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *el } /* When deref is set, val isn't NULL */ + SU_UD_PRIVATE(ud) = t; + ud->sv = sv; ud->val = val ? newSVsv(deref ? SvRV(val) : val) : NULL; ud->elem = SvREFCNT_inc(elem); - ud->type = t; return size; } -STATIC void su_localize(pTHX_ void *ud_) { +static void su_localize(pTHX_ void *ud_) { #define su_localize(U) su_localize(aTHX_ (U)) su_ud_localize *ud = (su_ud_localize *) ud_; SV *sv = ud->sv; SV *val = ud->val; SV *elem = ud->elem; - svtype t = ud->type; + svtype t = SU_UD_PRIVATE(ud); GV *gv; if (SvTYPE(sv) >= SVt_PVGV) { @@ -871,13 +898,12 @@ STATIC void su_localize(pTHX_ void *ud_) { #endif } - SU_D({ + XSH_D({ SV *z = newSV(0); SvUPGRADE(z, t); - PerlIO_printf(Perl_debug_log, "%p: === localize a %s\n",ud, sv_reftype(z, 0)); - PerlIO_printf(Perl_debug_log, - "%p: depth=%2d scope_ix=%2d save_ix=%2d\n", - ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix); + su_debug_log("%p: === localize a %s\n",ud, sv_reftype(z, 0)); + su_debug_log("%p: depth=%2d scope_ix=%2d save_ix=%2d\n", + ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix); SvREFCNT_dec(z); }); @@ -886,14 +912,14 @@ STATIC void su_localize(pTHX_ void *ud_) { case SVt_PVAV: if (elem) { su_save_aelem(GvAV(gv), elem, val); - goto done; + return; } else save_ary(gv); break; case SVt_PVHV: if (elem) { su_save_helem(GvHV(gv), elem, val); - goto done; + return; } else save_hash(gv); break; @@ -911,155 +937,244 @@ STATIC void su_localize(pTHX_ void *ud_) { if (val) SvSetMagicSV((SV *) gv, val); -done: - SU_UD_LOCALIZE_FREE(ud); + return; +} + +/* ... Unique context ID ................................................... */ + +/* We must pass the index because XSH_CXT.uid_storage might be reallocated + * between the UID fetch and the invalidation at the end of scope. */ + +typedef struct { + su_ud_common ci; + I32 idx; +} su_ud_uid; + +static void su_uid_drop(pTHX_ void *ud_) { + su_ud_uid *ud = ud_; + dXSH_CXT; + + XSH_CXT.uid_storage.map[ud->idx].flags &= ~SU_UID_ACTIVE; + + SU_UD_FREE(ud); + + return; } /* --- Pop a context back -------------------------------------------------- */ -#if SU_DEBUG && defined(DEBUGGING) +#ifdef DEBUGGING # define SU_CXNAME(C) PL_block_type[CxTYPE(C)] #else -# define SU_CXNAME(C) "XXX" +# if XSH_HAS_PERL(5, 11, 0) +static const char *su_block_type[] = { + "NULL", + "WHEN", + "BLOCK", + "GIVEN", + "LOOP_FOR", + "LOOP_PLAIN", + "LOOP_LAZYSV", + "LOOP_LAZYIV", + "SUB", + "FORMAT", + "EVAL", + "SUBST" +}; +# elif XSH_HAS_PERL(5, 9, 3) +static const char *su_block_type[] = { + "NULL", + "SUB", + "EVAL", + "WHEN", + "SUBST", + "BLOCK", + "FORMAT", + "GIVEN", + "LOOP_FOR", + "LOOP_PLAIN", + "LOOP_LAZYSV", + "LOOP_LAZYIV" +}; +# else +static const char *su_block_type[] = { + "NULL", + "SUB", + "EVAL", + "LOOP", + "SUBST", + "BLOCK" +}; +# endif +# define SU_CXNAME(C) su_block_type[CxTYPE(C)] #endif -STATIC void su_pop(pTHX_ void *ud) { +static void su_pop(pTHX_ void *ud) { #define su_pop(U) su_pop(aTHX_ (U)) I32 depth, base, mark, *origin; depth = SU_UD_DEPTH(ud); - SU_D( - PerlIO_printf(Perl_debug_log, - "%p: --- pop a %s\n" - "%p: leave scope at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n", - ud, SU_CXNAME(cxstack + cxstack_ix), - ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix]) - ); + XSH_D(su_debug_log( + "%p: --- pop a %s\n" + "%p: leave scope at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n", + ud, SU_CXNAME(cxstack + cxstack_ix), + ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix] + )); origin = SU_UD_ORIGIN(ud); mark = origin[depth]; base = origin[depth - 1]; - SU_D(PerlIO_printf(Perl_debug_log, - "%p: original scope was %*c top=%2d base=%2d\n", + XSH_D(su_debug_log("%p: original scope was %*c top=%2d base=%2d\n", ud, 24, ' ', mark, base)); if (base < mark) { - SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud)); +#if XSH_HAS_PERL(5, 19, 4) + I32 save = -1; + PERL_CONTEXT *cx; +#endif + + XSH_D(su_debug_log("%p: clear leftovers\n", ud)); + +#if XSH_HAS_PERL(5, 19, 4) + cx = cxstack + cxstack_ix; + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) + save = PL_scopestack[cx->blk_oldscopesp - 1]; +#endif + PL_savestack_ix = mark; leave_scope(base); + +#if XSH_HAS_PERL(5, 19, 4) + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) + PL_scopestack[cx->blk_oldscopesp - 1] = save; +#endif } PL_savestack_ix = base; SU_UD_DEPTH(ud) = --depth; if (depth > 0) { - I32 pad; + U8 pad; - if ((pad = SU_UD_PAD(ud))) { - dMY_CXT; + if ((pad = SU_UD_PAD(ud)) > 0) { + dXSH_CXT; do { - SU_D(PerlIO_printf(Perl_debug_log, + XSH_D(su_debug_log( "%p: push a pad slot at depth=%2d scope_ix=%2d save_ix=%2d\n", ud, depth, PL_scopestack_ix, PL_savestack_ix)); SU_SAVE_PLACEHOLDER(); } while (--pad); } - SU_D(PerlIO_printf(Perl_debug_log, - "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n", - ud, depth, PL_scopestack_ix, PL_savestack_ix)); + XSH_D(su_debug_log( + "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n", + ud, depth, PL_scopestack_ix, PL_savestack_ix)); SAVEDESTRUCTOR_X(su_pop, ud); } else { - SU_UD_HANDLER(ud)(aTHX_ ud); + switch (SU_UD_TYPE(ud)) { + case SU_UD_TYPE_REAP: { + XSH_D(su_debug_log("%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n", + ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix)); + SAVEDESTRUCTOR_X(su_call, SU_UD_REAP_CB(ud)); + SU_UD_FREE(ud); + break; + } + case SU_UD_TYPE_LOCALIZE: + su_localize(ud); + SU_UD_LOCALIZE_FREE(ud); + break; + case SU_UD_TYPE_UID: + SAVEDESTRUCTOR_X(su_uid_drop, ud); + break; + } } - SU_D(PerlIO_printf(Perl_debug_log, - "%p: --- end pop: cur_top=%2d == cur_base=%2d\n", + XSH_D(su_debug_log("%p: --- end pop: cur_top=%2d == cur_base=%2d\n", ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix])); } /* --- Initialize the stack and the action userdata ------------------------ */ -STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { +static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S)) - I32 i, depth = 1, pad, offset, *origin; - - SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix)); - - if (size <= SU_SAVE_DESTRUCTOR_SIZE) + I32 i, depth, offset, base, *origin; + U8 pad; + + XSH_D(su_debug_log("%p: ### init for cx %d\n", ud, cxix)); + + /* su_pop() is going to be called from leave_scope(), so before pushing the + * next callback, we'll want to flush the current scope stack slice first. + * However, if we want the next callback not to be processed immediately by + * the current leave_scope(), we'll need to hide it by artificially + * incrementing the scope stack marker before. For the intermediate bumps, + * we will only need a bump of SU_SAVE_DESTRUCTOR_SIZE items, but for the + * last one we will need a bump of size items. However, in order to preserve + * the natural ordering between scope stack markers, we cannot bump lower + * markers more than higher ones. This is why we bump the intermediate markers + * by the smallest multiple of SU_SAVE_PLACEHOLDER_SIZE greater or equal to + * max(SU_SAVE_DESTRUCTOR_SIZE, size). */ + + if (size <= SU_SAVE_DESTRUCTOR_SIZE) { pad = 0; - else { + } else { I32 extra = size - SU_SAVE_DESTRUCTOR_SIZE; pad = extra / SU_SAVE_PLACEHOLDER_SIZE; if (extra % SU_SAVE_PLACEHOLDER_SIZE) ++pad; } offset = SU_SAVE_DESTRUCTOR_SIZE + SU_SAVE_PLACEHOLDER_SIZE * pad; + XSH_D(su_debug_log("%p: size=%d pad=%d offset=%d\n", ud, size, pad, offset)); - SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n", - ud, size, pad, offset)); + depth = PL_scopestack_ix - cxstack[cxix].blk_oldscopesp; + XSH_D(su_debug_log("%p: going down to depth %d\n", ud, depth)); - for (i = cxstack_ix; i > cxix; --i) { - PERL_CONTEXT *cx = cxstack + i; - switch (CxTYPE(cx)) { -#if SU_HAS_PERL(5, 11, 0) - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_LAZYIV: -#else - case CXt_LOOP: -#endif - SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i)); - depth += 2; - break; - default: - SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is other\n", ud, i)); - depth++; - break; - } - } - SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth)); + /* We need to bump all the intermediary stack markers just in case an + * exception is thrown before the target scope is reached. Indeed, in this + * case there might be arbitrary many scope frames flushed at the same time, + * and since we cannot know in advance whether this will happen or not, we + * have to make sure the final frame is protected for the actual action. But + * of course, in order to do that, we also need to bump all the previous stack + * markers. If not for this, it should have been possible to just bump the two + * next frames in su_pop(). */ Newx(origin, depth + 1, I32); - origin[0] = PL_scopestack[PL_scopestack_ix - depth]; - PL_scopestack[PL_scopestack_ix - depth] += size; - for (i = depth - 1; i >= 1; --i) { - I32 j = PL_scopestack_ix - i; - origin[depth - i] = PL_scopestack[j]; + base = PL_scopestack_ix - depth; + origin[0] = PL_scopestack[base]; + PL_scopestack[base] += size; + for (i = 1; i < depth; ++i) { + I32 j = i + base; + /* origin[depth - i] == PL_scopestack[PL_scopestack_ix - i] */ + origin[i] = PL_scopestack[j]; PL_scopestack[j] += offset; } origin[depth] = PL_savestack_ix; - SU_UD_ORIGIN(ud) = origin; - SU_UD_DEPTH(ud) = depth; SU_UD_PAD(ud) = pad; + SU_UD_DEPTH(ud) = depth; + SU_UD_ORIGIN(ud) = origin; /* Make sure the first destructor fires by pushing enough fake slots on the * stack. */ if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE <= PL_scopestack[PL_scopestack_ix - 1]) { - dMY_CXT; + dXSH_CXT; do { - SU_D(PerlIO_printf(Perl_debug_log, - "%p: push a fake slot at scope_ix=%2d save_ix=%2d\n", - ud, PL_scopestack_ix, PL_savestack_ix)); + XSH_D(su_debug_log("%p: push a fake slot at scope_ix=%2d save_ix=%2d\n", + ud, PL_scopestack_ix, PL_savestack_ix)); SU_SAVE_PLACEHOLDER(); } while (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE <= PL_scopestack[PL_scopestack_ix - 1]); } - SU_D(PerlIO_printf(Perl_debug_log, - "%p: push first destructor at scope_ix=%2d save_ix=%2d\n", - ud, PL_scopestack_ix, PL_savestack_ix)); + XSH_D(su_debug_log("%p: push first destructor at scope_ix=%2d save_ix=%2d\n", + ud, PL_scopestack_ix, PL_savestack_ix)); SAVEDESTRUCTOR_X(su_pop, ud); - SU_D({ + XSH_D({ for (i = 0; i <= depth; ++i) { I32 j = PL_scopestack_ix - i; - PerlIO_printf(Perl_debug_log, - "%p: depth=%2d scope_ix=%2d saved_floor=%2d new_floor=%2d\n", - ud, i, j, origin[depth - i], + su_debug_log("%p: depth=%2d scope_ix=%2d saved_floor=%2d new_floor=%2d\n", + ud, i, j, origin[depth - i], i == 0 ? PL_savestack_ix : PL_scopestack[j]); } }); @@ -1069,15 +1184,24 @@ STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { /* --- Unwind stack -------------------------------------------------------- */ -STATIC void su_unwind(pTHX_ void *ud_) { - dMY_CXT; - I32 cxix = MY_CXT.unwind_storage.cxix; - I32 items = MY_CXT.unwind_storage.items; +static void su_unwind(pTHX_ void *ud_) { + dXSH_CXT; + I32 cxix = XSH_CXT.unwind_storage.cxix; + I32 items = XSH_CXT.unwind_storage.items; I32 mark; PERL_UNUSED_VAR(ud_); - PL_stack_sp = MY_CXT.unwind_storage.savesp; + PL_stack_sp = XSH_CXT.unwind_storage.savesp; +#if XSH_HAS_PERL(5, 19, 4) + { + I32 i; + SV **sp = PL_stack_sp; + for (i = -items + 1; i <= 0; ++i) + if (!SvTEMP(sp[i])) + sv_2mortal(SvREFCNT_inc(sp[i])); + } +#endif if (cxstack_ix > cxix) dounwind(cxix); @@ -1085,27 +1209,26 @@ STATIC void su_unwind(pTHX_ void *ud_) { mark = PL_markstack[cxstack[cxix].blk_oldmarksp]; *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items; - SU_D({ + XSH_D({ I32 gimme = GIMME_V; - PerlIO_printf(Perl_debug_log, - "%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n", - &MY_CXT, cxix, + su_debug_log("%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n", + &XSH_CXT, cxix, gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar", items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark); }); - PL_op = (OP *) &(MY_CXT.unwind_storage.return_op); + PL_op = (OP *) &(XSH_CXT.unwind_storage.return_op); PL_op = PL_op->op_ppaddr(aTHX); *PL_markstack_ptr = mark; - MY_CXT.unwind_storage.proxy_op.op_next = PL_op; - PL_op = &(MY_CXT.unwind_storage.proxy_op); + XSH_CXT.unwind_storage.proxy_op.op_next = PL_op; + PL_op = &(XSH_CXT.unwind_storage.proxy_op); } /* --- Yield --------------------------------------------------------------- */ -#if SU_HAS_PERL(5, 10, 0) +#if XSH_HAS_PERL(5, 10, 0) # define SU_RETOP_SUB(C) ((C)->blk_sub.retop) # define SU_RETOP_EVAL(C) ((C)->blk_eval.retop) # define SU_RETOP_LOOP(C) ((C)->blk_loop.my_op->op_lastop->op_next) @@ -1116,11 +1239,12 @@ STATIC void su_unwind(pTHX_ void *ud_) { # define SU_RETOP_LOOP(C) ((C)->blk_loop.last_op->op_next) #endif -STATIC void su_yield(pTHX_ void *ud_) { - dMY_CXT; +static void su_yield(pTHX_ void *ud_) { + dXSH_CXT; PERL_CONTEXT *cx; - I32 cxix = MY_CXT.yield_storage.cxix; - I32 items = MY_CXT.yield_storage.items; + const char *which = ud_; + I32 cxix = XSH_CXT.yield_storage.cxix; + I32 items = XSH_CXT.yield_storage.items; opcode type = OP_NULL; U8 flags = 0; OP *next; @@ -1134,15 +1258,15 @@ STATIC void su_yield(pTHX_ void *ud_) { OP *o = NULL; /* Is this actually a given/when block? This may occur only when yield was * called with HERE (or nothing) as the context. */ -#if SU_HAS_PERL(5, 10, 0) +#if XSH_HAS_PERL(5, 10, 0) if (cxix > 0) { PERL_CONTEXT *prev = cx - 1; - U8 type = CxTYPE(prev); - if ((type == CXt_GIVEN || type == CXt_WHEN) + U8 prev_type = CxTYPE(prev); + if ((prev_type == CXt_GIVEN || prev_type == CXt_WHEN) && (prev->blk_oldcop == cx->blk_oldcop)) { cxix--; cx = prev; - if (type == CXt_GIVEN) + if (prev_type == CXt_GIVEN) goto cxt_given; else goto cxt_when; @@ -1173,8 +1297,13 @@ STATIC void su_yield(pTHX_ void *ud_) { case CXt_EVAL: o = SU_RETOP_EVAL(cx2); break; -#if SU_HAS_PERL(5, 11, 0) +#if XSH_HAS_PERL(5, 11, 0) +# if XSH_HAS_PERL(5, 23, 8) + case CXt_LOOP_ARY: + case CXt_LOOP_LIST: +# else case CXt_LOOP_FOR: +# endif case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYSV: case CXt_LOOP_LAZYIV: @@ -1214,8 +1343,13 @@ STATIC void su_yield(pTHX_ void *ud_) { type = CxTRYBLOCK(cx) ? OP_LEAVETRY : OP_LEAVEEVAL; next = SU_RETOP_EVAL(cx); break; -#if SU_HAS_PERL(5, 11, 0) +#if XSH_HAS_PERL(5, 11, 0) +# if XSH_HAS_PERL(5, 23, 8) + case CXt_LOOP_ARY: + case CXt_LOOP_LIST: +# else case CXt_LOOP_FOR: +# endif case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYSV: case CXt_LOOP_LAZYIV: @@ -1225,7 +1359,7 @@ STATIC void su_yield(pTHX_ void *ud_) { type = OP_LEAVELOOP; next = SU_RETOP_LOOP(cx); break; -#if SU_HAS_PERL(5, 10, 0) +#if XSH_HAS_PERL(5, 10, 0) case CXt_GIVEN: cxt_given: type = OP_LEAVEGIVEN; @@ -1233,7 +1367,7 @@ cxt_given: break; case CXt_WHEN: cxt_when: -#if SU_HAS_PERL(5, 15, 1) +#if XSH_HAS_PERL(5, 15, 1) type = OP_LEAVEWHEN; #else type = OP_BREAK; @@ -1243,14 +1377,24 @@ cxt_when: break; #endif case CXt_SUBST: - croak("yield() cannot target a substitution context"); + croak("%s() can't target a substitution context", which); break; default: - croak("yield() don't know how to leave a %s context", SU_CXNAME(cxstack + cxix)); + croak("%s() doesn't know how to leave a %s context", + which, SU_CXNAME(cxstack + cxix)); break; } - PL_stack_sp = MY_CXT.yield_storage.savesp; + PL_stack_sp = XSH_CXT.yield_storage.savesp; +#if XSH_HAS_PERL(5, 19, 4) + { + I32 i; + SV **sp = PL_stack_sp; + for (i = -items + 1; i <= 0; ++i) + if (!SvTEMP(sp[i])) + sv_2mortal(SvREFCNT_inc(sp[i])); + } +#endif if (cxstack_ix > cxix) dounwind(cxix); @@ -1263,16 +1407,16 @@ cxt_when: flags |= OP_GIMME_REVERSE(cx->blk_gimme); - MY_CXT.yield_storage.leave_op.op_type = type; - MY_CXT.yield_storage.leave_op.op_ppaddr = PL_ppaddr[type]; - MY_CXT.yield_storage.leave_op.op_flags = flags; - MY_CXT.yield_storage.leave_op.op_next = next; + XSH_CXT.yield_storage.leave_op.op_type = type; + XSH_CXT.yield_storage.leave_op.op_ppaddr = PL_ppaddr[type]; + XSH_CXT.yield_storage.leave_op.op_flags = flags; + XSH_CXT.yield_storage.leave_op.op_next = next; - PL_op = (OP *) &(MY_CXT.yield_storage.leave_op); + PL_op = (OP *) &(XSH_CXT.yield_storage.leave_op); PL_op = PL_op->op_ppaddr(aTHX); - MY_CXT.yield_storage.proxy_op.op_next = PL_op; - PL_op = &(MY_CXT.yield_storage.proxy_op); + XSH_CXT.yield_storage.proxy_op.op_next = PL_op; + PL_op = &(XSH_CXT.yield_storage.proxy_op); } /* --- Uplevel ------------------------------------------------------------- */ @@ -1280,60 +1424,62 @@ cxt_when: #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END -STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) { +static su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) { #define su_uplevel_storage_new(I) su_uplevel_storage_new(aTHX_ (I)) su_uplevel_ud *sud; UV depth; - dMY_CXT; + dXSH_CXT; - sud = MY_CXT.uplevel_storage.root; + sud = XSH_CXT.uplevel_storage.root; if (sud) { - MY_CXT.uplevel_storage.root = sud->next; - MY_CXT.uplevel_storage.count--; + XSH_CXT.uplevel_storage.root = sud->next; + XSH_CXT.uplevel_storage.count--; } else { sud = su_uplevel_ud_new(); } - sud->next = MY_CXT.uplevel_storage.top; - MY_CXT.uplevel_storage.top = sud; + sud->next = XSH_CXT.uplevel_storage.top; + XSH_CXT.uplevel_storage.top = sud; depth = su_uid_depth(cxix); - su_uid_storage_dup(&sud->tmp_uid_storage, &MY_CXT.uid_storage, depth); - sud->old_uid_storage = MY_CXT.uid_storage; - MY_CXT.uid_storage = sud->tmp_uid_storage; + su_uid_storage_dup(&sud->tmp_uid_storage, &XSH_CXT.uid_storage, depth); + sud->old_uid_storage = XSH_CXT.uid_storage; + XSH_CXT.uid_storage = sud->tmp_uid_storage; return sud; } -STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) { +#if XSH_HAS_PERL(5, 13, 7) + +static void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) { #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S)) - dMY_CXT; + dXSH_CXT; - sud->tmp_uid_storage = MY_CXT.uid_storage; - MY_CXT.uid_storage = sud->old_uid_storage; + sud->tmp_uid_storage = XSH_CXT.uid_storage; + XSH_CXT.uid_storage = sud->old_uid_storage; { - su_uid **map; - UV i, alloc; + su_uid *map; + STRLEN i, alloc; map = sud->tmp_uid_storage.map; alloc = sud->tmp_uid_storage.alloc; - for (i = 0; i < alloc; ++i) { - if (map[i]) - map[i]->flags &= SU_UID_ACTIVE; - } + for (i = 0; i < alloc; ++i) + map[i].flags &= ~SU_UID_ACTIVE; } - MY_CXT.uplevel_storage.top = sud->next; + XSH_CXT.uplevel_storage.top = sud->next; - if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) { + if (XSH_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) { su_uplevel_ud_delete(sud); } else { - sud->next = MY_CXT.uplevel_storage.root; - MY_CXT.uplevel_storage.root = sud; - MY_CXT.uplevel_storage.count++; + sud->next = XSH_CXT.uplevel_storage.root; + XSH_CXT.uplevel_storage.root = sud; + XSH_CXT.uplevel_storage.count++; } } -STATIC int su_uplevel_goto_static(const OP *o) { - for (; o; o = o->op_sibling) { +#endif + +static int su_uplevel_goto_static(const OP *o) { + for (; o; o = OpSIBLING(o)) { /* goto ops are unops with kids. */ if (!(o->op_flags & OPf_KIDS)) continue; @@ -1357,7 +1503,7 @@ STATIC int su_uplevel_goto_static(const OP *o) { #if SU_UPLEVEL_HIJACKS_RUNOPS -STATIC int su_uplevel_goto_runops(pTHX) { +static int su_uplevel_goto_runops(pTHX) { #define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX) register OP *op; dVAR; @@ -1374,7 +1520,7 @@ STATIC int su_uplevel_goto_runops(pTHX) { switch (CxTYPE(cx)) { case CXt_SUB: if (CxHASARGS(cx)) { - argarray = cx->blk_sub.argarray; + argarray = CX_ARGARRAY(cx); goto done; } break; @@ -1388,9 +1534,9 @@ STATIC int su_uplevel_goto_runops(pTHX) { done: if (argarray) { - dMY_CXT; + dXSH_CXT; - if (MY_CXT.uplevel_storage.top->cxix == cxix) { + if (XSH_CXT.uplevel_storage.top->cxix == cxix) { AV *args = GvAV(PL_defgv); I32 items = AvFILLp(args); @@ -1403,7 +1549,7 @@ done: PL_op = op = op->op_ppaddr(aTHX); -#if !SU_HAS_PERL(5, 13, 0) +#if !XSH_HAS_PERL(5, 13, 0) PERL_ASYNC_CHECK(); #endif } while (op); @@ -1417,7 +1563,7 @@ done: #define su_at_underscore(C) PadARRAY(PadlistARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] -STATIC void su_uplevel_restore(pTHX_ void *sus_) { +static void su_uplevel_restore(pTHX_ void *sus_) { su_uplevel_ud *sud = sus_; PERL_SI *cur = sud->old_curstackinfo; PERL_SI *si = sud->si; @@ -1449,8 +1595,8 @@ STATIC void su_uplevel_restore(pTHX_ void *sus_) { * reached without a goto() happening, and the old argarray member is * actually our fake argarray. Destroy it properly in that case. */ if (cx->blk_sub.cv == sud->renamed) { - SvREFCNT_dec(cx->blk_sub.argarray); - cx->blk_sub.argarray = argarray; + SvREFCNT_dec(CX_ARGARRAY(cx)); + CX_ARGARRAY_set(cx, argarray); } CvDEPTH(sud->callback)--; @@ -1461,8 +1607,10 @@ STATIC void su_uplevel_restore(pTHX_ void *sus_) { * depth to be 0, or perl would complain about it being "still in use". * But we *know* that it cannot be so. */ if (sud->renamed) { - CvDEPTH(sud->renamed) = 0; - CvPADLIST(sud->renamed) = NULL; + if (!CvISXSUB(sud->renamed)) { + CvDEPTH(sud->renamed) = 0; + CvPADLIST(sud->renamed) = NULL; + } SvREFCNT_dec(sud->renamed); } @@ -1521,7 +1669,7 @@ found_it: CvDEPTH(target) = sud->target_depth - levels; PL_curstackinfo->si_cxix = i - 1; -#if !SU_HAS_PERL(5, 13, 1) +#if !XSH_HAS_PERL(5, 13, 1) /* Since $@ was maybe localized between the target frame and the uplevel * call, we forcefully flush the save stack to get rid of it and then * reset $@ to its proper value. Note that the the call to @@ -1555,29 +1703,29 @@ found_it: * pointer to the current context frame across this call. This means that we * can't free the temporary context stack we used for the uplevel call right * now, or that pointer upwards would point to garbage. */ -#if SU_HAS_PERL(5, 13, 7) +#if XSH_HAS_PERL(5, 13, 7) /* This issue has been fixed in perl with commit 8f89e5a9, which was made * public in perl 5.13.7. */ su_uplevel_storage_delete(sud); #else /* Otherwise, we just enqueue it back in the global storage list. */ { - dMY_CXT; + dXSH_CXT; - sud->tmp_uid_storage = MY_CXT.uid_storage; - MY_CXT.uid_storage = sud->old_uid_storage; + sud->tmp_uid_storage = XSH_CXT.uid_storage; + XSH_CXT.uid_storage = sud->old_uid_storage; - MY_CXT.uplevel_storage.top = sud->next; - sud->next = MY_CXT.uplevel_storage.root; - MY_CXT.uplevel_storage.root = sud; - MY_CXT.uplevel_storage.count++; + XSH_CXT.uplevel_storage.top = sud->next; + sud->next = XSH_CXT.uplevel_storage.root; + XSH_CXT.uplevel_storage.root = sud; + XSH_CXT.uplevel_storage.count++; } #endif return; } -STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) { +static CV *su_cv_clone(pTHX_ CV *proto, GV *gv) { #define su_cv_clone(P, G) su_cv_clone(aTHX_ (P), (G)) dVAR; CV *cv; @@ -1596,11 +1744,14 @@ STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) { #endif CvGV_set(cv, gv); +#if SU_RELEASE && XSH_HAS_PERL_EXACT(5, 21, 4) + CvNAMED_off(cv); +#endif CvSTASH_set(cv, CvSTASH(proto)); /* Commit 4c74a7df, publicized with perl 5.13.3, began to add backrefs to * stashes. CvSTASH_set() started to do it as well with commit c68d95645 * (which was part of perl 5.13.7). */ -#if SU_HAS_PERL(5, 13, 3) && !SU_HAS_PERL(5, 13, 7) +#if XSH_HAS_PERL(5, 13, 3) && !XSH_HAS_PERL(5, 13, 7) if (CvSTASH(proto)) Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv)); #endif @@ -1613,13 +1764,13 @@ STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) { CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); OP_REFCNT_UNLOCK; CvSTART(cv) = CvSTART(proto); + CvPADLIST(cv) = CvPADLIST(proto); } CvOUTSIDE(cv) = CvOUTSIDE(proto); #ifdef CVf_WEAKOUTSIDE if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE)) #endif SvREFCNT_inc_simple_void(CvOUTSIDE(cv)); - CvPADLIST(cv) = CvPADLIST(proto); #ifdef CvOUTSIDE_SEQ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); #endif @@ -1635,7 +1786,7 @@ STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) { return cv; } -STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { +static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { #define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A)) su_uplevel_ud *sud; const PERL_CONTEXT *cx = cxstack + cxix; @@ -1749,6 +1900,7 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) { PERL_CONTEXT *sub_cx = cxstack + cxstack_ix; + AV *argarray = CX_ARGARRAY(cx); /* If pp_entersub() returns a non-null OP, it means that the callback is not * an XSUB. */ @@ -1756,7 +1908,7 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { sud->callback = MUTABLE_CV(SvREFCNT_inc(callback)); CvDEPTH(callback)++; - if (CxHASARGS(cx) && cx->blk_sub.argarray) { + if (CxHASARGS(cx) && argarray) { /* The call to pp_entersub() has saved the current @_ (in XS terms, * GvAV(PL_defgv)) in the savearray member, and has created a new argarray * with what we put on the stack. But we want to fake up the same arguments @@ -1765,12 +1917,12 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { AV *av = newAV(); AvREAL_off(av); AvREIFY_on(av); - av_extend(av, AvMAX(cx->blk_sub.argarray)); - AvFILLp(av) = AvFILLp(cx->blk_sub.argarray); - Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *); - sub_cx->blk_sub.argarray = av; + av_extend(av, AvMAX(argarray)); + AvFILLp(av) = AvFILLp(argarray); + Copy(AvARRAY(argarray), AvARRAY(av), AvFILLp(av) + 1, SV *); + CX_ARGARRAY_set(sub_cx, av); } else { - SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray); + SvREFCNT_inc_simple_void(CX_ARGARRAY(sub_cx)); } if (su_uplevel_goto_static(CvROOT(renamed))) { @@ -1816,90 +1968,71 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { /* --- Unique context ID --------------------------------------------------- */ -STATIC su_uid *su_uid_storage_fetch(pTHX_ UV depth) { +static su_uid *su_uid_storage_fetch(pTHX_ UV depth) { #define su_uid_storage_fetch(D) su_uid_storage_fetch(aTHX_ (D)) - su_uid **map, *uid; - STRLEN alloc; - dMY_CXT; + su_uid *map; + STRLEN alloc; + dXSH_CXT; - map = MY_CXT.uid_storage.map; - alloc = MY_CXT.uid_storage.alloc; + map = XSH_CXT.uid_storage.map; + alloc = XSH_CXT.uid_storage.alloc; if (depth >= alloc) { STRLEN i; - Renew(map, depth + 1, su_uid *); - for (i = alloc; i <= depth; ++i) - map[i] = NULL; - - MY_CXT.uid_storage.map = map; - MY_CXT.uid_storage.alloc = depth + 1; - } - - uid = map[depth]; + Renew(map, depth + 1, su_uid); + for (i = alloc; i <= depth; ++i) { + map[i].seq = 0; + map[i].flags = 0; + } - if (!uid) { - Newx(uid, 1, su_uid); - uid->seq = 0; - uid->flags = 0; - map[depth] = uid; + XSH_CXT.uid_storage.map = map; + XSH_CXT.uid_storage.alloc = depth + 1; } - if (depth >= MY_CXT.uid_storage.used) - MY_CXT.uid_storage.used = depth + 1; + if (depth >= XSH_CXT.uid_storage.used) + XSH_CXT.uid_storage.used = depth + 1; - return uid; + return map + depth; } -STATIC int su_uid_storage_check(pTHX_ UV depth, UV seq) { +static int su_uid_storage_check(pTHX_ UV depth, UV seq) { #define su_uid_storage_check(D, S) su_uid_storage_check(aTHX_ (D), (S)) su_uid *uid; - dMY_CXT; + dXSH_CXT; - if (depth >= MY_CXT.uid_storage.used) + if (depth >= XSH_CXT.uid_storage.used) return 0; - uid = MY_CXT.uid_storage.map[depth]; + uid = XSH_CXT.uid_storage.map + depth; - return uid && (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE); + return (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE); } -STATIC void su_uid_drop(pTHX_ void *ud_) { - su_uid *uid = ud_; - - uid->flags &= ~SU_UID_ACTIVE; -} - -STATIC void su_uid_bump(pTHX_ void *ud_) { - su_ud_reap *ud = ud_; - - SAVEDESTRUCTOR_X(su_uid_drop, ud->cb); -} - -STATIC SV *su_uid_get(pTHX_ I32 cxix) { +static SV *su_uid_get(pTHX_ I32 cxix) { #define su_uid_get(I) su_uid_get(aTHX_ (I)) su_uid *uid; - SV *uid_sv; - UV depth; + SV *uid_sv; + UV depth; depth = su_uid_depth(cxix); uid = su_uid_storage_fetch(depth); if (!(uid->flags & SU_UID_ACTIVE)) { - su_ud_reap *ud; + su_ud_uid *ud; - uid->seq = su_uid_seq_next(depth); + uid->seq = su_uid_seq_next(depth); uid->flags |= SU_UID_ACTIVE; - Newx(ud, 1, su_ud_reap); - SU_UD_ORIGIN(ud) = NULL; - SU_UD_HANDLER(ud) = su_uid_bump; - ud->cb = (SV *) uid; + Newx(ud, 1, su_ud_uid); + SU_UD_TYPE(ud) = SU_UD_TYPE_UID; + ud->idx = depth; su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE); } uid_sv = sv_newmortal(); sv_setpvf(uid_sv, "%"UVuf"-%"UVuf, depth, uid->seq); + return uid_sv; } @@ -1911,7 +2044,7 @@ STATIC SV *su_uid_get(pTHX_ I32 cxix) { #define IS_NUMBER_IN_UV 0x1 -STATIC int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) { +static int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) { #define su_grok_number(S, L, VP) su_grok_number(aTHX_ (S), (L), (VP)) STRLEN i; SV *tmpsv; @@ -1932,7 +2065,7 @@ STATIC int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) { #endif /* !grok_number */ -STATIC int su_uid_validate(pTHX_ SV *uid) { +static int su_uid_validate(pTHX_ SV *uid) { #define su_uid_validate(U) su_uid_validate(aTHX_ (U)) const char *s; STRLEN len, p = 0; @@ -1964,7 +2097,7 @@ STATIC int su_uid_validate(pTHX_ SV *uid) { /* Remove sequences of BLOCKs having DB for stash, followed by a SUB context * for the debugger callback. */ -STATIC I32 su_context_skip_db(pTHX_ I32 cxix) { +static I32 su_context_skip_db(pTHX_ I32 cxix) { #define su_context_skip_db(C) su_context_skip_db(aTHX_ (C)) I32 i; @@ -1975,6 +2108,9 @@ STATIC I32 su_context_skip_db(pTHX_ I32 cxix) { PERL_CONTEXT *cx = cxstack + i; switch (CxTYPE(cx)) { +#if XSH_HAS_PERL(5, 17, 1) + case CXt_LOOP_PLAIN: +#endif case CXt_BLOCK: if (cx->blk_oldcop && CopSTASH(cx->blk_oldcop) == GvSTASH(PL_DBgv)) continue; @@ -1996,7 +2132,7 @@ STATIC I32 su_context_skip_db(pTHX_ I32 cxix) { } -STATIC I32 su_context_normalize_up(pTHX_ I32 cxix) { +static I32 su_context_normalize_up(pTHX_ I32 cxix) { #define su_context_normalize_up(C) su_context_normalize_up(aTHX_ (C)) PERL_CONTEXT *cx; @@ -2008,11 +2144,11 @@ STATIC I32 su_context_normalize_up(pTHX_ I32 cxix) { PERL_CONTEXT *prev = cx - 1; switch (CxTYPE(prev)) { -#if SU_HAS_PERL(5, 10, 0) +#if XSH_HAS_PERL(5, 10, 0) case CXt_GIVEN: case CXt_WHEN: #endif -#if SU_HAS_PERL(5, 11, 0) +#if XSH_HAS_PERL(5, 11, 0) /* That's the only subcategory that can cause an extra BLOCK context */ case CXt_LOOP_PLAIN: #else @@ -2022,8 +2158,8 @@ STATIC I32 su_context_normalize_up(pTHX_ I32 cxix) { return cxix - 1; break; case CXt_SUBST: - if (cx->blk_oldcop && cx->blk_oldcop->op_sibling - && cx->blk_oldcop->op_sibling->op_type == OP_SUBST) + if (cx->blk_oldcop && OpSIBLING(cx->blk_oldcop) + && OpSIBLING(cx->blk_oldcop)->op_type == OP_SUBST) return cxix - 1; break; } @@ -2032,7 +2168,7 @@ STATIC I32 su_context_normalize_up(pTHX_ I32 cxix) { return cxix; } -STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) { +static I32 su_context_normalize_down(pTHX_ I32 cxix) { #define su_context_normalize_down(C) su_context_normalize_down(aTHX_ (C)) PERL_CONTEXT *next; @@ -2044,11 +2180,11 @@ STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) { PERL_CONTEXT *cx = next - 1; switch (CxTYPE(cx)) { -#if SU_HAS_PERL(5, 10, 0) +#if XSH_HAS_PERL(5, 10, 0) case CXt_GIVEN: case CXt_WHEN: #endif -#if SU_HAS_PERL(5, 11, 0) +#if XSH_HAS_PERL(5, 11, 0) /* That's the only subcategory that can cause an extra BLOCK context */ case CXt_LOOP_PLAIN: #else @@ -2058,8 +2194,8 @@ STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) { return cxix + 1; break; case CXt_SUBST: - if (next->blk_oldcop && next->blk_oldcop->op_sibling - && next->blk_oldcop->op_sibling->op_type == OP_SUBST) + if (next->blk_oldcop && OpSIBLING(next->blk_oldcop) + && OpSIBLING(next->blk_oldcop)->op_type == OP_SUBST) return cxix + 1; break; } @@ -2070,22 +2206,109 @@ STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) { #define su_context_here() su_context_normalize_up(su_context_skip_db(cxstack_ix)) -/* --- Interpreter setup/teardown ------------------------------------------ */ +static I32 su_context_gimme(pTHX_ I32 cxix) { +#define su_context_gimme(C) su_context_gimme(aTHX_ (C)) + I32 i; -STATIC void su_teardown(pTHX_ void *param) { - su_uplevel_ud *cur; - su_uid **map; - dMY_CXT; + for (i = cxix; i >= 0; --i) { + PERL_CONTEXT *cx = cxstack + i; - map = MY_CXT.uid_storage.map; - if (map) { - STRLEN i; - for (i = 0; i < MY_CXT.uid_storage.used; ++i) - Safefree(map[i]); - Safefree(map); + switch (CxTYPE(cx)) { + /* gimme is always G_ARRAY for loop contexts. */ +#if XSH_HAS_PERL(5, 11, 0) +# if XSH_HAS_PERL(5, 23, 8) + case CXt_LOOP_ARY: + case CXt_LOOP_LIST: +# else + case CXt_LOOP_FOR: +# endif + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LAZYIV: +#else + case CXt_LOOP: +#endif + case CXt_SUBST: { + const COP *cop = cx->blk_oldcop; + if (cop && OpSIBLING(cop)) { + switch (OpSIBLING(cop)->op_flags & OPf_WANT) { + case OPf_WANT_VOID: + return G_VOID; + case OPf_WANT_SCALAR: + return G_SCALAR; + case OPf_WANT_LIST: + return G_ARRAY; + default: + break; + } + } + break; + } + default: + return CxGIMME(cx); + break; + } } - cur = MY_CXT.uplevel_storage.root; + return G_VOID; +} + +/* --- Module setup/teardown ----------------------------------------------- */ + +static void xsh_user_global_setup(pTHX) { + HV *stash; + + MUTEX_INIT(&su_uid_seq_counter_mutex); + + XSH_LOCK(&su_uid_seq_counter_mutex); + su_uid_seq_counter.seqs = NULL; + su_uid_seq_counter.size = 0; + XSH_UNLOCK(&su_uid_seq_counter_mutex); + + stash = gv_stashpv(XSH_PACKAGE, 1); + newCONSTSUB(stash, "TOP", newSViv(0)); + newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(XSH_THREADSAFE)); + + return; +} + +static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) { + cxt->stack_placeholder = NULL; + + /* NewOp() calls calloc() which just zeroes the memory with memset(). */ + Zero(&(cxt->unwind_storage.return_op), 1, LISTOP); + cxt->unwind_storage.return_op.op_type = OP_RETURN; + cxt->unwind_storage.return_op.op_ppaddr = PL_ppaddr[OP_RETURN]; + + Zero(&(cxt->unwind_storage.proxy_op), 1, OP); + cxt->unwind_storage.proxy_op.op_type = OP_STUB; + cxt->unwind_storage.proxy_op.op_ppaddr = NULL; + + Zero(&(cxt->yield_storage.leave_op), 1, UNOP); + cxt->yield_storage.leave_op.op_type = OP_STUB; + cxt->yield_storage.leave_op.op_ppaddr = NULL; + + Zero(&(cxt->yield_storage.proxy_op), 1, OP); + cxt->yield_storage.proxy_op.op_type = OP_STUB; + cxt->yield_storage.proxy_op.op_ppaddr = NULL; + + cxt->uplevel_storage.top = NULL; + cxt->uplevel_storage.root = NULL; + cxt->uplevel_storage.count = 0; + + cxt->uid_storage.map = NULL; + cxt->uid_storage.used = 0; + cxt->uid_storage.alloc = 0; + + return; +} + +static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) { + su_uplevel_ud *cur; + + Safefree(cxt->uid_storage.map); + + cur = cxt->uplevel_storage.root; if (cur) { su_uplevel_ud *prev; do { @@ -2098,38 +2321,13 @@ STATIC void su_teardown(pTHX_ void *param) { return; } -STATIC void su_setup(pTHX) { -#define su_setup() su_setup(aTHX) - MY_CXT_INIT; - - MY_CXT.stack_placeholder = NULL; - - /* NewOp() calls calloc() which just zeroes the memory with memset(). */ - Zero(&(MY_CXT.unwind_storage.return_op), 1, LISTOP); - MY_CXT.unwind_storage.return_op.op_type = OP_RETURN; - MY_CXT.unwind_storage.return_op.op_ppaddr = PL_ppaddr[OP_RETURN]; - - Zero(&(MY_CXT.unwind_storage.proxy_op), 1, OP); - MY_CXT.unwind_storage.proxy_op.op_type = OP_STUB; - MY_CXT.unwind_storage.proxy_op.op_ppaddr = NULL; - - Zero(&(MY_CXT.yield_storage.leave_op), 1, UNOP); - MY_CXT.yield_storage.leave_op.op_type = OP_STUB; - MY_CXT.yield_storage.leave_op.op_ppaddr = NULL; - - Zero(&(MY_CXT.yield_storage.proxy_op), 1, OP); - MY_CXT.yield_storage.proxy_op.op_type = OP_STUB; - MY_CXT.yield_storage.proxy_op.op_ppaddr = NULL; - - MY_CXT.uplevel_storage.top = NULL; - MY_CXT.uplevel_storage.root = NULL; - MY_CXT.uplevel_storage.count = 0; - - MY_CXT.uid_storage.map = NULL; - MY_CXT.uid_storage.used = 0; - MY_CXT.uid_storage.alloc = 0; +static void xsh_user_global_teardown(pTHX) { + XSH_LOCK(&su_uid_seq_counter_mutex); + PerlMemShared_free(su_uid_seq_counter.seqs); + su_uid_seq_counter.size = 0; + XSH_UNLOCK(&su_uid_seq_counter_mutex); - call_atexit(su_teardown, NULL); + MUTEX_DESTROY(&su_uid_seq_counter_mutex); return; } @@ -2166,7 +2364,11 @@ default_cx: \ } \ } STMT_END -XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */ +#if XSH_HAS_PERL(5, 10, 0) +# define SU_INFO_COUNT 11 +#else +# define SU_INFO_COUNT 10 +#endif XS(XS_Scope__Upper_unwind) { #ifdef dVAR @@ -2174,7 +2376,7 @@ XS(XS_Scope__Upper_unwind) { #else dXSARGS; #endif - dMY_CXT; + dXSH_CXT; I32 cxix; PERL_UNUSED_VAR(cv); /* -W */ @@ -2189,12 +2391,12 @@ XS(XS_Scope__Upper_unwind) { continue; case CXt_EVAL: case CXt_FORMAT: - MY_CXT.unwind_storage.cxix = cxix; - MY_CXT.unwind_storage.items = items; - MY_CXT.unwind_storage.savesp = PL_stack_sp; + XSH_CXT.unwind_storage.cxix = cxix; + XSH_CXT.unwind_storage.items = items; + XSH_CXT.unwind_storage.savesp = PL_stack_sp; if (items > 0) { - MY_CXT.unwind_storage.items--; - MY_CXT.unwind_storage.savesp--; + XSH_CXT.unwind_storage.items--; + XSH_CXT.unwind_storage.savesp--; } /* pp_entersub will want to sanitize the stack after returning from there * Screw that, we're insane! @@ -2210,7 +2412,7 @@ XS(XS_Scope__Upper_unwind) { croak("Can't return outside a subroutine"); } -XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */ +static const char su_yield_name[] = "yield"; XS(XS_Scope__Upper_yield) { #ifdef dVAR @@ -2218,75 +2420,72 @@ XS(XS_Scope__Upper_yield) { #else dXSARGS; #endif - dMY_CXT; + dXSH_CXT; I32 cxix; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(ax); /* -Wall */ SU_GET_CONTEXT(0, items - 1, su_context_here()); - MY_CXT.yield_storage.cxix = cxix; - MY_CXT.yield_storage.items = items; - MY_CXT.yield_storage.savesp = PL_stack_sp; + XSH_CXT.yield_storage.cxix = cxix; + XSH_CXT.yield_storage.items = items; + XSH_CXT.yield_storage.savesp = PL_stack_sp; if (items > 0) { - MY_CXT.yield_storage.items--; - MY_CXT.yield_storage.savesp--; + XSH_CXT.yield_storage.items--; + XSH_CXT.yield_storage.savesp--; } /* See XS_Scope__Upper_unwind */ if (GIMME_V == G_SCALAR) PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; - SAVEDESTRUCTOR_X(su_yield, NULL); + SAVEDESTRUCTOR_X(su_yield, su_yield_name); return; } -MODULE = Scope::Upper PACKAGE = Scope::Upper +static const char su_leave_name[] = "leave"; -PROTOTYPES: ENABLE +XS(XS_Scope__Upper_leave) { +#ifdef dVAR + dVAR; dXSARGS; +#else + dXSARGS; +#endif + dXSH_CXT; -BOOT: -{ - HV *stash; + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ - MUTEX_INIT(&su_uid_seq_counter_mutex); + XSH_CXT.yield_storage.cxix = su_context_here(); + XSH_CXT.yield_storage.items = items; + XSH_CXT.yield_storage.savesp = PL_stack_sp; + /* See XS_Scope__Upper_unwind */ + if (GIMME_V == G_SCALAR) + PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; + SAVEDESTRUCTOR_X(su_yield, su_leave_name); + return; +} - su_uid_seq_counter.seqs = NULL; - su_uid_seq_counter.size = 0; +MODULE = Scope::Upper PACKAGE = Scope::Upper - stash = gv_stashpv(__PACKAGE__, 1); - newCONSTSUB(stash, "TOP", newSViv(0)); - newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE)); +PROTOTYPES: ENABLE +BOOT: +{ + xsh_setup(); newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL); newXSproto("Scope::Upper::yield", XS_Scope__Upper_yield, file, NULL); - - su_setup(); + newXSproto("Scope::Upper::leave", XS_Scope__Upper_leave, file, NULL); } -#if SU_THREADSAFE +#if XSH_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE -PREINIT: - su_uid_storage new_cxt; PPCODE: - { - dMY_CXT; - new_cxt.map = NULL; - new_cxt.used = 0; - new_cxt.alloc = 0; - su_uid_storage_dup(&new_cxt, &MY_CXT.uid_storage, MY_CXT.uid_storage.used); - } - { - MY_CXT_CLONE; - MY_CXT.uplevel_storage.top = NULL; - MY_CXT.uplevel_storage.root = NULL; - MY_CXT.uplevel_storage.count = 0; - MY_CXT.uid_storage = new_cxt; - } + xsh_clone(); XSRETURN(0); -#endif /* SU_THREADSAFE */ +#endif /* XSH_THREADSAFE */ void HERE() @@ -2310,6 +2509,8 @@ PPCODE: --cxix; cxix = su_context_skip_db(cxix); cxix = su_context_normalize_up(cxix); + } else { + warn(su_stack_smash); } EXTEND(SP, 1); mPUSHi(cxix); @@ -2335,6 +2536,7 @@ PPCODE: XSRETURN(1); } } + warn(su_no_such_target, "subroutine"); XSRETURN_UNDEF; void @@ -2355,6 +2557,7 @@ PPCODE: XSRETURN(1); } } + warn(su_no_such_target, "eval"); XSRETURN_UNDEF; void @@ -2366,8 +2569,10 @@ PPCODE: SU_GET_LEVEL(0, 0); cxix = su_context_here(); while (--level >= 0) { - if (cxix <= 0) + if (cxix <= 0) { + warn(su_stack_smash); break; + } --cxix; cxix = su_context_skip_db(cxix); cxix = su_context_normalize_up(cxix); @@ -2397,6 +2602,8 @@ PPCODE: } } done: + if (level >= 0) + warn(su_stack_smash); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2429,6 +2636,162 @@ PPCODE: } XSRETURN_UNDEF; +void +context_info(...) +PROTOTYPE: ;$ +PREINIT: + I32 cxix; + const PERL_CONTEXT *cx, *dbcx; + COP *cop; +PPCODE: + SU_GET_CONTEXT(0, 0, su_context_skip_db(cxstack_ix)); + cxix = su_context_normalize_up(cxix); + cx = cxstack + cxix; + dbcx = cx; + if (PL_DBsub && cxix && (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)) { + I32 i = su_context_skip_db(cxix - 1) + 1; + if (i < cxix && CxTYPE(cxstack + i) == CXt_SUB) + cx = cxstack + i; + } + cop = cx->blk_oldcop; + EXTEND(SP, SU_INFO_COUNT); + /* stash (0) */ + { + HV *stash = CopSTASH(cop); + if (stash) + PUSHs(su_newmortal_pvn(HvNAME(stash), HvNAMELEN(stash))); + else + PUSHs(&PL_sv_undef); + } + /* file (1) */ + PUSHs(su_newmortal_pvn(OutCopFILE(cop), OutCopFILE_len(cop))); + /* line (2) */ + mPUSHi(CopLINE(cop)); + /* subroutine (3) and has_args (4) */ + switch (CxTYPE(cx)) { + case CXt_SUB: + case CXt_FORMAT: { + GV *cvgv = CvGV(dbcx->blk_sub.cv); + if (cvgv && isGV(cvgv)) { + SV *sv = sv_newmortal(); + gv_efullname3(sv, cvgv, NULL); + PUSHs(sv); + } else { + PUSHs(su_newmortal_pvs("(unknown)")); + } + if (CxHASARGS(cx)) + PUSHs(&PL_sv_yes); + else + PUSHs(&PL_sv_no); + break; + } + case CXt_EVAL: + PUSHs(su_newmortal_pvs("(eval)")); + mPUSHi(0); + break; + default: + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } + /* gimme (5) */ + switch (su_context_gimme(cxix)) { + case G_ARRAY: + PUSHs(&PL_sv_yes); + break; + case G_SCALAR: + PUSHs(&PL_sv_no); + break; + default: /* G_VOID */ + PUSHs(&PL_sv_undef); + break; + } + /* eval text (6) and is_require (7) */ + switch (CxTYPE(cx)) { + case CXt_EVAL: + if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { + /* eval STRING */ +#if XSH_HAS_PERL(5, 17, 4) + PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text), + SvCUR(cx->blk_eval.cur_text)-2, + SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP)); +#else + PUSHs(cx->blk_eval.cur_text); +#endif + PUSHs(&PL_sv_no); + break; + } else if (cx->blk_eval.old_namesv) { + /* require */ + PUSHs(sv_mortalcopy(cx->blk_eval.old_namesv)); + PUSHs(&PL_sv_yes); + break; + } + /* FALLTHROUGH */ + default: + /* Anything else including eval BLOCK */ + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + break; + } + /* hints (8) */ + mPUSHi(CopHINTS_get(cop)); + /* warnings (9) */ + { + SV *mask = NULL; +#if XSH_HAS_PERL(5, 9, 4) + STRLEN *old_warnings = cop->cop_warnings; +#else + SV *old_warnings = cop->cop_warnings; +#endif + if (old_warnings == pWARN_STD) { + if (PL_dowarn & G_WARN_ON) + goto context_info_warnings_on; + else +#if XSH_HAS_PERL(5, 17, 4) + mask = &PL_sv_undef; +#else + goto context_info_warnings_off; +#endif + } else if (old_warnings == pWARN_NONE) { +#if !XSH_HAS_PERL(5, 17, 4) +context_info_warnings_off: +#endif + mask = su_newmortal_pvn(WARN_NONEstring, WARNsize); + } else if (old_warnings == pWARN_ALL) { + HV *bits; +context_info_warnings_on: +#if XSH_HAS_PERL(5, 8, 7) + bits = get_hv("warnings::Bits", 0); + if (bits) { + SV **bits_all = hv_fetchs(bits, "all", FALSE); + if (bits_all) + mask = sv_mortalcopy(*bits_all); + } +#endif + if (!mask) + mask = su_newmortal_pvn(WARN_ALLstring, WARNsize); + } else { +#if XSH_HAS_PERL(5, 9, 4) + mask = su_newmortal_pvn((char *) (old_warnings + 1), old_warnings[0]); +#else + mask = sv_mortalcopy(old_warnings); +#endif + } + PUSHs(mask); + } +#if XSH_HAS_PERL(5, 10, 0) + /* hints hash (10) */ + { + COPHH *hints_hash = CopHINTHASH_get(cop); + if (hints_hash) { + SV *rhv = sv_2mortal(newRV_noinc((SV *) cophh_2hv(hints_hash, 0))); + PUSHs(rhv); + } else { + PUSHs(&PL_sv_undef); + } + } +#endif + XSRETURN(SU_INFO_COUNT); + void reap(SV *hook, ...) PROTOTYPE: &;$ @@ -2439,9 +2802,10 @@ CODE: SU_GET_CONTEXT(1, 1, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_reap); - SU_UD_ORIGIN(ud) = NULL; - SU_UD_HANDLER(ud) = su_reap; - ud->cb = newSVsv(hook); + SU_UD_TYPE(ud) = SU_UD_TYPE_REAP; + ud->cb = (SvROK(hook) && SvTYPE(SvRV(hook)) >= SVt_PVCV) + ? SvRV(hook) : hook; + SvREFCNT_inc_simple_void(ud->cb); su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE); void @@ -2455,8 +2819,7 @@ CODE: SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); - SU_UD_ORIGIN(ud) = NULL; - SU_UD_HANDLER(ud) = su_localize; + SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE; size = su_ud_localize_init(ud, sv, val, NULL); su_init(ud, cxix, size); @@ -2473,10 +2836,11 @@ CODE: SU_GET_CONTEXT(3, 3, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); - SU_UD_ORIGIN(ud) = NULL; - SU_UD_HANDLER(ud) = su_localize; + /* Initialize SU_UD_ORIGIN(ud) in case SU_UD_LOCALIZE_FREE(ud) needs it */ + SU_UD_ORIGIN(ud) = NULL; + SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE; size = su_ud_localize_init(ud, sv, val, elem); - if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) { + if (SU_UD_PRIVATE(ud) != SVt_PVAV && SU_UD_PRIVATE(ud) != SVt_PVHV) { SU_UD_LOCALIZE_FREE(ud); croak("Can't localize an element of something that isn't an array or a hash"); } @@ -2493,8 +2857,7 @@ CODE: SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); - SU_UD_ORIGIN(ud) = NULL; - SU_UD_HANDLER(ud) = su_localize; + SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE; size = su_ud_localize_init(ud, sv, NULL, elem); su_init(ud, cxix, size);