X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=b68b08f24fe9d226189e42ad994f841e2c3d15c7;hb=refs%2Ftags%2Fv0.17;hp=fb6de17f2de76bec7edfe5aa8982f9a91b94f47f;hpb=ce1b964719f9e697652b60c1f3ac04dfd8ccd848;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index fb6de17..b68b08f 100644 --- a/Upper.xs +++ b/Upper.xs @@ -3,7 +3,7 @@ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" -#include "perl.h" +#include "perl.h" #include "XSUB.h" #define __PACKAGE__ "Scope::Upper" @@ -14,6 +14,30 @@ /* --- Compatibility ------------------------------------------------------- */ +#ifndef NOOP +# define NOOP +#endif + +#ifndef dNOOP +# define dNOOP +#endif + +#ifndef dVAR +# define dVAR dNOOP +#endif + +#ifndef MUTABLE_SV +# define MUTABLE_SV(S) ((SV *) (S)) +#endif + +#ifndef MUTABLE_AV +# define MUTABLE_AV(A) ((AV *) (A)) +#endif + +#ifndef MUTABLE_CV +# define MUTABLE_CV(C) ((CV *) (C)) +#endif + #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(V) #endif @@ -36,16 +60,64 @@ # define Newx(v, n, c) New(0, v, n, c) #endif +#ifdef DEBUGGING +# ifdef PoisonNew +# define SU_POISON(D, N, T) PoisonNew((D), (N), T) +# elif defined(Poison) +# define SU_POISON(D, N, T) Poison((D), (N), T) +# endif +#endif +#ifndef SU_POISON +# define SU_POISON(D, N, T) NOOP +#endif + +#ifndef newSV_type +STATIC SV *su_newSV_type(pTHX_ svtype t) { + SV *sv = newSV(0); + SvUPGRADE(sv, t); + return sv; +} +# define newSV_type(T) su_newSV_type(aTHX_ (T)) +#endif + #ifndef SvPV_const # define SvPV_const(S, L) SvPV(S, L) #endif +#ifndef SvPVX_const +# define SvPVX_const(S) SvPVX(S) +#endif + #ifndef SvPV_nolen_const # define SvPV_nolen_const(S) SvPV_nolen(S) #endif #ifndef SvREFCNT_inc_simple_void -# define SvREFCNT_inc_simple_void(sv) SvREFCNT_inc(sv) +# define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc(sv)) +#endif + +#ifndef mPUSHi +# define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I))) +#endif + +#ifndef GvCV_set +# define GvCV_set(G, C) (GvCV(G) = (C)) +#endif + +#ifndef CvGV_set +# define CvGV_set(C, G) (CvGV(C) = (G)) +#endif + +#ifndef CvSTASH_set +# define CvSTASH_set(C, S) (CvSTASH(C) = (S)) +#endif + +#ifndef CvISXSUB +# define CvISXSUB(C) CvXSUB(C) +#endif + +#ifndef CxHASARGS +# define CxHASARGS(C) ((C)->blk_sub.hasargs) #endif #ifndef HvNAME_get @@ -69,17 +141,10 @@ #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))) /* --- Threads and multiplicity -------------------------------------------- */ -#ifndef NOOP -# define NOOP -#endif - -#ifndef dNOOP -# define dNOOP -#endif - #ifndef SU_MULTIPLICITY # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) # define SU_MULTIPLICITY 1 @@ -114,16 +179,90 @@ # define MY_CXT_CLONE NOOP #endif +/* --- unwind() global storage --------------------------------------------- */ + +typedef struct { + I32 cxix; + I32 items; + SV **savesp; + LISTOP return_op; + OP proxy_op; +} su_unwind_storage; + +/* --- uplevel() data tokens and global storage ---------------------------- */ + +typedef struct { + void *next; + + I32 cxix; + bool died; + + CV *target; + I32 target_depth; + + CV *callback; + CV *renamed; + + PERL_SI *si; + PERL_SI *old_curstackinfo; + AV *old_mainstack; + + COP *old_curcop; + + runops_proc_t old_runops; + bool old_catch; + OP *old_op; +} su_uplevel_ud; + +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; + + Newx(sud, 1, su_uplevel_ud); + sud->next = NULL; + + Newx(si, 1, PERL_SI); + si->si_stack = newAV(); + AvREAL_off(si->si_stack); + si->si_cxstack = NULL; + si->si_cxmax = 0; + + sud->si = si; + + return 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; + + Safefree(si->si_cxstack); + SvREFCNT_dec(si->si_stack); + Safefree(si); + Safefree(sud); + + return; +} + +typedef struct { + su_uplevel_ud *top; + su_uplevel_ud *root; + I32 count; +} su_uplevel_storage; + +#ifndef SU_UPLEVEL_STORAGE_SIZE +# define SU_UPLEVEL_STORAGE_SIZE 4 +#endif + /* --- Global data --------------------------------------------------------- */ #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { - char *stack_placeholder; - I32 cxix; - I32 items; - SV **savesp; - OP fakeop; + char *stack_placeholder; + su_unwind_storage unwind_storage; + su_uplevel_storage uplevel_storage; } my_cxt_t; START_MY_CXT @@ -159,14 +298,16 @@ START_MY_CXT # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE #endif -#define SU_SAVE_SPTR_SIZE 3 +#define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE #if !SU_HAS_PERL(5, 8, 9) # define SU_SAVE_GP_SIZE 6 -#elif !SU_HAS_PERL(5, 13, 0) +#elif !SU_HAS_PERL(5, 13, 0) || (SU_RELEASE && SU_HAS_PERL_EXACT(5, 13, 0)) # define SU_SAVE_GP_SIZE 3 -#else +#elif !SU_HAS_PERL(5, 13, 8) # define SU_SAVE_GP_SIZE 4 +#else +# define SU_SAVE_GP_SIZE 3 #endif #ifndef SvCANEXISTDELETE @@ -308,6 +449,43 @@ 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) +# define mro_method_changed_in(G) PL_sub_generation++ +#endif + +typedef struct { + GV *gv; + CV *old_cv; +} su_save_gvcv_ud; + +STATIC void su_restore_gvcv(pTHX_ void *ud_) { + su_save_gvcv_ud *ud = ud_; + GV *gv = ud->gv; + + GvCV_set(gv, ud->old_cv); + GvCVGEN(gv) = 0; + mro_method_changed_in(GvSTASH(gv)); + + Safefree(ud); +} + +STATIC void su_save_gvcv(pTHX_ GV *gv) { +#define su_save_gvcv(G) su_save_gvcv(aTHX_ (G)) + su_save_gvcv_ud *ud; + + Newx(ud, 1, su_save_gvcv_ud); + ud->gv = gv; + ud->old_cv = GvCV(gv); + + GvCV_set(gv, NULL); + GvCVGEN(gv) = 0; + mro_method_changed_in(GvSTASH(gv)); + + SAVEDESTRUCTOR_X(su_restore_gvcv, ud); +} + /* --- Actions ------------------------------------------------------------- */ typedef struct { @@ -473,7 +651,7 @@ STATIC I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *el deref = 0; break; case SVt_PVCV: - size = SU_SAVE_SPTR_SIZE; + size = SU_SAVE_GVCV_SIZE; deref = 0; break; default: @@ -541,8 +719,7 @@ STATIC void su_localize(pTHX_ void *ud_) { save_gp(gv, 1); /* hide previous entry in symtab */ break; case SVt_PVCV: - SAVESPTR(GvCV(gv)); - GvCV(gv) = NULL; + su_save_gvcv(gv); break; default: gv = (GV *) save_scalar(gv); @@ -727,9 +904,9 @@ STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { STATIC void su_unwind(pTHX_ void *ud_) { dMY_CXT; - I32 cxix = MY_CXT.cxix; - I32 items = MY_CXT.items - 1; - SV **savesp = MY_CXT.savesp; + I32 cxix = MY_CXT.unwind_storage.cxix; + I32 items = MY_CXT.unwind_storage.items - 1; + SV **savesp = MY_CXT.unwind_storage.savesp; I32 mark; PERL_UNUSED_VAR(ud_); @@ -756,11 +933,578 @@ STATIC void su_unwind(pTHX_ void *ud_) { items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark); }); - PL_op = PL_ppaddr[OP_RETURN](aTHX); + PL_op = (OP *) &(MY_CXT.unwind_storage.return_op); + PL_op = PL_op->op_ppaddr(aTHX); + *PL_markstack_ptr = mark; - MY_CXT.fakeop.op_next = PL_op; - PL_op = &(MY_CXT.fakeop); + MY_CXT.unwind_storage.proxy_op.op_next = PL_op; + PL_op = &(MY_CXT.unwind_storage.proxy_op); +} + +/* --- Uplevel ------------------------------------------------------------- */ + +#ifndef OP_GIMME_REVERSE +STATIC U8 su_op_gimme_reverse(U8 gimme) { + switch (gimme) { + case G_VOID: + return OPf_WANT_VOID; + case G_ARRAY: + return OPf_WANT_LIST; + default: + break; + } + + return OPf_WANT_SCALAR; +} +#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G) +#endif + +#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) { +#define su_uplevel_storage_new() su_uplevel_storage_new(aTHX) + su_uplevel_ud *sud; + dMY_CXT; + + sud = MY_CXT.uplevel_storage.root; + if (sud) { + MY_CXT.uplevel_storage.root = sud->next; + MY_CXT.uplevel_storage.count--; + } else { + sud = su_uplevel_ud_new(); + } + + sud->next = MY_CXT.uplevel_storage.top; + MY_CXT.uplevel_storage.top = sud; + + return sud; +} + +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; + + MY_CXT.uplevel_storage.top = sud->next; + + if (MY_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++; + } +} + +STATIC int su_uplevel_goto_static(const OP *o) { + for (; o; o = o->op_sibling) { + /* goto ops are unops with kids. */ + if (!(o->op_flags & OPf_KIDS)) + continue; + + switch (o->op_type) { + case OP_LEAVEEVAL: + case OP_LEAVETRY: + /* Don't care about gotos inside eval, as they are forbidden at run time. */ + break; + case OP_GOTO: + return 1; + default: + if (su_uplevel_goto_static(cUNOPo->op_first)) + return 1; + break; + } + } + + return 0; +} + +STATIC int su_uplevel_goto_runops(pTHX) { +#define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX) + register OP *op; + dVAR; + + op = PL_op; + do { + if (op->op_type == OP_GOTO) { + AV *argarray = NULL; + I32 cxix; + + for (cxix = cxstack_ix; cxix >= 0; --cxix) { + const PERL_CONTEXT *cx = cxstack + cxix; + + switch (CxTYPE(cx)) { + case CXt_SUB: + if (CxHASARGS(cx)) { + argarray = cx->blk_sub.argarray; + goto done; + } + break; + case CXt_EVAL: + case CXt_FORMAT: + goto done; + default: + break; + } + } + +done: + if (argarray) { + dMY_CXT; + + if (MY_CXT.uplevel_storage.top->cxix == cxix) { + AV *args = GvAV(PL_defgv); + I32 items = AvFILLp(args); + + av_extend(argarray, items); + Copy(AvARRAY(args), AvARRAY(argarray), items + 1, SV *); + AvFILLp(argarray) = items; + } + } + } + + PL_op = op = op->op_ppaddr(aTHX); + +#if !SU_HAS_PERL(5, 13, 0) + PERL_ASYNC_CHECK(); +#endif + } while (op); + + TAINT_NOT; + + return 0; +} + +#define su_at_underscore(C) AvARRAY(AvARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] + +STATIC void su_uplevel_restore(pTHX_ void *sus_) { + su_uplevel_ud *sud = sus_; + PERL_SI *cur = sud->old_curstackinfo; + PERL_SI *si = sud->si; + + if (PL_runops == su_uplevel_goto_runops) + PL_runops = sud->old_runops; + + if (sud->callback) { + PERL_CONTEXT *cx = cxstack + sud->cxix; + AV *argarray = MUTABLE_AV(su_at_underscore(sud->callback)); + + /* We have to fix the pad entry for @_ in the original callback because it + * may have been reified. */ + if (AvREAL(argarray)) { + const I32 fill = AvFILLp(argarray); + SvREFCNT_dec(argarray); + argarray = newAV(); + AvREAL_off(argarray); + AvREIFY_on(argarray); + av_extend(argarray, fill); + su_at_underscore(sud->callback) = MUTABLE_SV(argarray); + } else { + CLEAR_ARGARRAY(argarray); + } + + /* If the old cv member is our renamed CV, it means that this place has been + * 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; + } + + CvDEPTH(sud->callback)--; + SvREFCNT_dec(sud->callback); + } + + /* Free the renamed CV. We must do it ourselves so that we can force the + * 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; + SvREFCNT_dec(sud->renamed); + } + + CATCH_SET(sud->old_catch); + + SU_UPLEVEL_RESTORE(op); + + /* stack_grow() wants PL_curstack so restore the old stack first */ + if (PL_curstackinfo == si) { + PL_curstack = cur->si_stack; + if (sud->old_mainstack) + SU_UPLEVEL_RESTORE(mainstack); + SU_UPLEVEL_RESTORE(curstackinfo); + + if (sud->died) { + CV *target = sud->target; + I32 levels = 0, i; + + /* When we die, the depth of the target CV is not updated because of the + * stack switcheroo. So we have to look at all the frames between the + * uplevel call and the catch block to count how many call frames to the + * target CV were skipped. */ + for (i = cur->si_cxix; i > sud->cxix; i--) { + register const PERL_CONTEXT *cx = cxstack + i; + + if (CxTYPE(cx) == CXt_SUB) { + if (cx->blk_sub.cv == target) + ++levels; + } + } + + /* If we died, the replacement stack was already unwinded to the first + * eval frame, and all the contexts down there were popped. We don't have + * to pop manually any context of the original stack, because they must + * have been in the replacement stack as well (since the second was copied + * from the first). Thus we only have to make sure the original stack index + * points to the context just below the first eval scope under the target + * frame. */ + for (; i >= 0; i--) { + register const PERL_CONTEXT *cx = cxstack + i; + + switch (CxTYPE(cx)) { + case CXt_SUB: + if (cx->blk_sub.cv == target) + ++levels; + break; + case CXt_EVAL: + goto found_it; + break; + default: + break; + } + } + +found_it: + CvDEPTH(target) = sud->target_depth - levels; + PL_curstackinfo->si_cxix = i - 1; + +#if !SU_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 + * su_uplevel_restore() must happen before the "reset $@" item of the save + * stack is processed, as uplevel was called after the localization. + * Andrew's changes to how $@ was handled, which were mainly integrated + * between perl 5.13.0 and 5.13.1, fixed this. */ + if (ERRSV && SvTRUE(ERRSV)) { + register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */ + SV *errsv = SvREFCNT_inc(ERRSV); + PL_scopestack_ix = cx->blk_oldscopesp; + leave_scope(PL_scopestack[PL_scopestack_ix]); + sv_setsv(ERRSV, errsv); + SvREFCNT_dec(errsv); + } +#endif + } + } + + SU_UPLEVEL_RESTORE(curcop); + + SvREFCNT_dec(sud->target); + + PL_stack_base = AvARRAY(cur->si_stack); + PL_stack_sp = PL_stack_base + AvFILLp(cur->si_stack); + PL_stack_max = PL_stack_base + AvMAX(cur->si_stack); + + /* When an exception is thrown from the uplevel'd subroutine, + * su_uplevel_restore() may be called by the LEAVE in die_unwind() (renamed + * die_where() in more recent perls), which has the sad habit of keeping a + * 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) + /* 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; + + 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++; + } +#endif + + return; +} + +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; + + cv = MUTABLE_CV(newSV_type(SvTYPE(proto))); + + CvFLAGS(cv) = CvFLAGS(proto); +#ifdef CVf_CVGV_RC + CvFLAGS(cv) &= ~CVf_CVGV_RC; +#endif + CvDEPTH(cv) = CvDEPTH(proto); +#ifdef USE_ITHREADS + CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto) : savepv(CvFILE(proto)); +#else + CvFILE(cv) = CvFILE(proto); +#endif + + CvGV_set(cv, gv); + 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 (CvSTASH(proto)) + Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv)); +#endif + + if (CvISXSUB(proto)) { + CvXSUB(cv) = CvXSUB(proto); + CvXSUBANY(cv) = CvXSUBANY(proto); + } else { + OP_REFCNT_LOCK; + CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); + OP_REFCNT_UNLOCK; + CvSTART(cv) = CvSTART(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 + + if (SvPOK(proto)) + sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); + +#ifdef CvCONST + if (CvCONST(cv)) + CvCONST_off(cv); +#endif + + return cv; +} + +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; + PERL_SI *si; + PERL_SI *cur = PL_curstackinfo; + SV **old_stack_sp; + CV *target; + CV *renamed; + UNOP sub_op; + I32 gimme; + I32 old_mark, new_mark; + I32 ret; + dSP; + + ENTER; + + gimme = GIMME_V; + /* Make PL_stack_sp point just before the CV. */ + PL_stack_sp -= args + 1; + old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base; + SPAGAIN; + + sud = su_uplevel_storage_new(); + + sud->cxix = cxix; + sud->died = 1; + sud->callback = NULL; + sud->renamed = NULL; + SAVEDESTRUCTOR_X(su_uplevel_restore, sud); + + si = sud->si; + + si->si_type = cur->si_type; + si->si_next = NULL; + si->si_prev = cur->si_prev; +#ifdef DEBUGGING + si->si_markoff = cx->blk_oldmarksp; +#endif + + /* Allocate enough space for all the elements of the original stack up to the + * target context, plus the forthcoming arguments. */ + new_mark = cx->blk_oldsp; + av_extend(si->si_stack, new_mark + 1 + args + 1); + Copy(PL_curstack, AvARRAY(si->si_stack), new_mark + 1, SV *); + AvFILLp(si->si_stack) = new_mark; + SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *); + + /* Specialized SWITCHSTACK() */ + PL_stack_base = AvARRAY(si->si_stack); + old_stack_sp = PL_stack_sp; + PL_stack_sp = PL_stack_base + AvFILLp(si->si_stack); + PL_stack_max = PL_stack_base + AvMAX(si->si_stack); + SPAGAIN; + + /* Copy the context stack up to the context just below the target. */ + si->si_cxix = (cxix < 0) ? -1 : (cxix - 1); + if (si->si_cxmax < cxix) { + /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */ + si->si_cxmax = (cxix < 4) ? 4 : cxix; + Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT); + } + Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT); + SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT); + + target = cx->blk_sub.cv; + sud->target = (CV *) SvREFCNT_inc(target); + sud->target_depth = CvDEPTH(target); + + /* blk_oldcop is essentially needed for caller() and stack traces. It has no + * run-time implication, since PL_curcop will be overwritten as soon as we + * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just + * make it point to the blk_oldcop for the target frame, so that caller() + * reports the right file name, line number and lexical hints. */ + SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop); + /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below + * this point. Don't reset PL_curpm either, we want the most recent matches. */ + + SU_UPLEVEL_SAVE(curstackinfo, si); + /* If those two are equal, we need to fool POPSTACK_TO() */ + if (PL_mainstack == PL_curstack) + SU_UPLEVEL_SAVE(mainstack, si->si_stack); + else + sud->old_mainstack = NULL; + PL_curstack = si->si_stack; + + renamed = su_cv_clone(callback, CvGV(target)); + sud->renamed = renamed; + + PUSHMARK(SP); + /* Both SP and old_stack_sp point just before the CV. */ + Copy(old_stack_sp + 2, SP + 1, args, SV *); + SP += args; + PUSHs((SV *) renamed); + PUTBACK; + + Zero(&sub_op, 1, UNOP); + sub_op.op_type = OP_ENTERSUB; + sub_op.op_next = NULL; + sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED; + if (PL_DBsub) + sub_op.op_flags |= OPpENTERSUB_DB; + + SU_UPLEVEL_SAVE(op, (OP *) &sub_op); + + sud->old_runops = PL_runops; + + sud->old_catch = CATCH_GET; + CATCH_SET(TRUE); + + if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) { + PERL_CONTEXT *sub_cx = cxstack + cxstack_ix; + + /* If pp_entersub() returns a non-null OP, it means that the callback is not + * an XSUB. */ + + sud->callback = MUTABLE_CV(SvREFCNT_inc(callback)); + CvDEPTH(callback)++; + + if (CxHASARGS(cx) && cx->blk_sub.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 + * as the ones in use at the context we uplevel to, so we replace the + * argarray with an unreal copy of the original @_. */ + 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; + } else { + SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray); + } + + if (su_uplevel_goto_static(CvROOT(renamed))) { + if (PL_runops != Perl_runops_standard) { + if (PL_runops == Perl_runops_debug) { + if (PL_debug) + croak("uplevel() can't execute code that calls goto when debugging flags are set"); + } else if (PL_runops != su_uplevel_goto_runops) + croak("uplevel() can't execute code that calls goto with a custom runloop"); + } + + PL_runops = su_uplevel_goto_runops; + } + + CALLRUNOPS(aTHX); + } + + sud->died = 0; + + ret = PL_stack_sp - (PL_stack_base + new_mark); + if (ret > 0) { + AV *old_stack = sud->old_curstackinfo->si_stack; + + if (old_mark + ret > AvMAX(old_stack)) { + /* Specialized EXTEND(old_sp, ret) */ + av_extend(old_stack, old_mark + ret + 1); + old_stack_sp = AvARRAY(old_stack) + old_mark; + } + + Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *); + PL_stack_sp += ret; + AvFILLp(old_stack) += ret; + } + + LEAVE; + + return ret; +} + +/* --- Interpreter setup/teardown ------------------------------------------ */ + +STATIC void su_teardown(pTHX_ void *param) { + su_uplevel_ud *cur; + dMY_CXT; + + cur = MY_CXT.uplevel_storage.root; + if (cur) { + su_uplevel_ud *prev; + do { + prev = cur; + cur = prev->next; + su_uplevel_ud_delete(prev); + } while (cur); + } + + 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; + + MY_CXT.uplevel_storage.top = NULL; + MY_CXT.uplevel_storage.root = NULL; + MY_CXT.uplevel_storage.count = 0; + + call_atexit(su_teardown, NULL); + + return; } /* --- XS ------------------------------------------------------------------ */ @@ -848,16 +1592,16 @@ XS(XS_Scope__Upper_unwind) { continue; case CXt_EVAL: case CXt_FORMAT: - MY_CXT.cxix = cxix; - MY_CXT.items = items; + MY_CXT.unwind_storage.cxix = cxix; + MY_CXT.unwind_storage.items = items; /* pp_entersub will want to sanitize the stack after returning from there * Screw that, we're insane */ if (GIMME_V == G_SCALAR) { - MY_CXT.savesp = PL_stack_sp; + MY_CXT.unwind_storage.savesp = PL_stack_sp; /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */ PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; } else { - MY_CXT.savesp = NULL; + MY_CXT.unwind_storage.savesp = NULL; } SAVEDESTRUCTOR_X(su_unwind, NULL); return; @@ -876,14 +1620,13 @@ BOOT: { HV *stash; - MY_CXT_INIT; - MY_CXT.stack_placeholder = NULL; - stash = gv_stashpv(__PACKAGE__, 1); newCONSTSUB(stash, "TOP", newSViv(0)); newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE)); newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL); + + su_setup(); } #if SU_THREADSAFE @@ -894,37 +1637,40 @@ PROTOTYPE: DISABLE PPCODE: { MY_CXT_CLONE; + MY_CXT.uplevel_storage.top = NULL; + MY_CXT.uplevel_storage.root = NULL; + MY_CXT.uplevel_storage.count = 0; } XSRETURN(0); #endif /* SU_THREADSAFE */ -SV * +void HERE() PROTOTYPE: PREINIT: I32 cxix = cxstack_ix; -CODE: +PPCODE: if (PL_DBsub) SU_SKIP_DB(cxix); - RETVAL = newSViv(cxix); -OUTPUT: - RETVAL + EXTEND(SP, 1); + mPUSHi(cxix); + XSRETURN(1); -SV * +void UP(...) PROTOTYPE: ;$ PREINIT: I32 cxix; -CODE: +PPCODE: SU_GET_CONTEXT(0, 0); if (--cxix < 0) cxix = 0; if (PL_DBsub) SU_SKIP_DB(cxix); - RETVAL = newSViv(cxix); -OUTPUT: - RETVAL + EXTEND(SP, 1); + mPUSHi(cxix); + XSRETURN(1); void SUB(...) @@ -933,6 +1679,7 @@ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0); + EXTEND(SP, 1); for (; cxix >= 0; --cxix) { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { @@ -941,7 +1688,7 @@ PPCODE: case CXt_SUB: if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) continue; - ST(0) = sv_2mortal(newSViv(cxix)); + mPUSHi(cxix); XSRETURN(1); } } @@ -954,13 +1701,14 @@ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0); + EXTEND(SP, 1); for (; cxix >= 0; --cxix) { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: - ST(0) = sv_2mortal(newSViv(cxix)); + mPUSHi(cxix); XSRETURN(1); } } @@ -987,7 +1735,8 @@ PPCODE: if (cxix < 0) cxix = 0; } - ST(0) = sv_2mortal(newSViv(cxix)); + EXTEND(SP, 1); + mPUSHi(cxix); XSRETURN(1); void @@ -1011,7 +1760,8 @@ PPCODE: } } done: - ST(0) = sv_2mortal(newSViv(cxix)); + EXTEND(SP, 1); + mPUSHi(cxix); XSRETURN(1); void @@ -1021,6 +1771,7 @@ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0); + EXTEND(SP, 1); while (cxix > 0) { PERL_CONTEXT *cx = cxstack + cxix--; switch (CxTYPE(cx)) { @@ -1103,3 +1854,37 @@ CODE: SU_UD_HANDLER(ud) = su_localize; size = su_ud_localize_init(ud, sv, NULL, elem); su_init(ud, cxix, size); + +void +uplevel(SV *code, ...) +PROTOTYPE: &@ +PREINIT: + I32 cxix, ret, args = 0; +PPCODE: + if (SvROK(code)) + code = SvRV(code); + if (SvTYPE(code) < SVt_PVCV) + croak("First argument to uplevel must be a code reference"); + SU_GET_CONTEXT(1, items - 1); + do { + PERL_CONTEXT *cx = cxstack + cxix; + switch (CxTYPE(cx)) { + case CXt_EVAL: + croak("Can't uplevel to an eval frame"); + case CXt_FORMAT: + croak("Can't uplevel to a format frame"); + case CXt_SUB: + if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) + continue; + if (items > 1) { + PL_stack_sp--; + args = items - 2; + } + /* su_uplevel() takes care of extending the stack if needed. */ + ret = su_uplevel((CV *) code, cxix, args); + XSRETURN(ret); + default: + break; + } + } while (--cxix >= 0); + croak("Can't uplevel outside a subroutine");