X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=928fdfd28295a098bdf1fc69cbcf065d787d70df;hb=f5baf3c7bce8c08d6475fdcdb20fe23798f5cd8b;hp=c311bf2a14d5eeaad40ed23ebe383961a02e6af8;hpb=3dd049db64b7cecb2f4f12fb0a6f4043155429ee;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index c311bf2..928fdfd 100644 --- a/Upper.xs +++ b/Upper.xs @@ -729,16 +729,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)); \ @@ -751,11 +758,12 @@ typedef struct { 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; @@ -765,8 +773,8 @@ static void su_call(pTHX_ void *ud_) { 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); + "@@@ call scope_ix=%2d save_ix=%2d\n", + PL_scopestack_ix, PL_savestack_ix); }); ENTER; @@ -782,7 +790,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; @@ -793,36 +801,29 @@ 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) { @@ -898,10 +899,11 @@ 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; } @@ -912,7 +914,7 @@ static void su_localize(pTHX_ void *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) { @@ -942,14 +944,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; @@ -967,16 +969,72 @@ static void su_localize(pTHX_ void *ud_) { if (val) SvSetMagicSV((SV *) gv, val); -done: - SU_UD_LOCALIZE_FREE(ud); + return; +} + +/* ... Unique context ID ................................................... */ + +typedef struct { + su_ud_common ci; + su_uid *uid; +} su_ud_uid; + +#define SU_UD_UID_UID(U) (((su_ud_uid *) (U))->uid) + +static void su_uid_drop(pTHX_ void *ud_) { + su_uid *uid = ud_; + + uid->flags &= ~SU_UID_ACTIVE; + + 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 SU_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 SU_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) { @@ -1001,18 +1059,35 @@ static void su_pop(pTHX_ void *ud) { ud, 24, ' ', mark, base)); if (base < mark) { +#if SU_HAS_PERL(5, 19, 4) + I32 save = -1; + PERL_CONTEXT *cx; +#endif + SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud)); + +#if SU_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 SU_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))) { + if ((pad = SU_UD_PAD(ud)) > 0) { dMY_CXT; do { SU_D(PerlIO_printf(Perl_debug_log, @@ -1027,7 +1102,26 @@ static void su_pop(pTHX_ void *ud) { 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: { + 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, 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, SU_UD_UID_UID(ud)); + SU_UD_FREE(ud); + break; + } } SU_D(PerlIO_printf(Perl_debug_log, @@ -1039,7 +1133,8 @@ static void su_pop(pTHX_ void *ud) { 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; + I32 i, depth, offset, base, *origin; + U8 pad; SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix)); @@ -1056,41 +1151,23 @@ static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n", ud, size, pad, offset)); - 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; - } - } + depth = PL_scopestack_ix - cxstack[cxix].blk_oldscopesp; SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth)); 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[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. */ @@ -1203,12 +1280,12 @@ static void su_yield(pTHX_ void *ud_) { #if SU_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; @@ -1381,6 +1458,8 @@ static su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) { return sud; } +#if SU_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; @@ -1408,6 +1487,8 @@ static void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) { } } +#endif + static int su_uplevel_goto_static(const OP *o) { for (; o; o = OpSIBLING(o)) { /* goto ops are unops with kids. */ @@ -1945,20 +2026,6 @@ static int su_uid_storage_check(pTHX_ UV depth, UV seq) { return uid && (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); - - SU_UD_FREE(ud); -} - static SV *su_uid_get(pTHX_ I32 cxix) { #define su_uid_get(I) su_uid_get(aTHX_ (I)) su_uid *uid; @@ -1969,15 +2036,14 @@ static SV *su_uid_get(pTHX_ I32 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->uid = uid; su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE); } @@ -2198,9 +2264,77 @@ static I32 su_context_gimme(pTHX_ I32 cxix) { return G_VOID; } +/* --- Global setup/teardown ----------------------------------------------- */ + +static VOL U32 su_initialized = 0; + +static void su_global_teardown(pTHX_ void *root) { + if (!su_initialized) + return; + +#if SU_MULTIPLICITY + if (aTHX != root) + return; +#endif + + SU_LOCK(&su_uid_seq_counter_mutex); + PerlMemShared_free(su_uid_seq_counter.seqs); + su_uid_seq_counter.size = 0; + SU_UNLOCK(&su_uid_seq_counter_mutex); + + MUTEX_DESTROY(&su_uid_seq_counter_mutex); + + su_initialized = 0; + + return; +} + +XS(XS_Scope__Upper_unwind); +XS(XS_Scope__Upper_yield); +XS(XS_Scope__Upper_leave); + +#if SU_HAS_PERL(5, 9, 0) +# define SU_XS_FILE_TYPE const char +#else +# define SU_XS_FILE_TYPE char +#endif + +static void su_global_setup(pTHX_ SU_XS_FILE_TYPE *file) { +#define su_global_setup(F) su_global_setup(aTHX_ (F)) + HV *stash; + + if (su_initialized) + return; + + MUTEX_INIT(&su_uid_seq_counter_mutex); + + SU_LOCK(&su_uid_seq_counter_mutex); + su_uid_seq_counter.seqs = NULL; + su_uid_seq_counter.size = 0; + SU_UNLOCK(&su_uid_seq_counter_mutex); + + 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); + newXSproto("Scope::Upper::yield", XS_Scope__Upper_yield, file, NULL); + newXSproto("Scope::Upper::leave", XS_Scope__Upper_leave, file, NULL); + +#if SU_MULTIPLICITY + call_atexit(su_global_teardown, aTHX); +#else + call_atexit(su_global_teardown, NULL); +#endif + + su_initialized = 1; + + return; +} + /* --- Interpreter setup/teardown ------------------------------------------ */ -static void su_teardown(pTHX_ void *param) { +static void su_local_teardown(pTHX_ void *param) { su_uplevel_ud *cur; su_uid **map; dMY_CXT; @@ -2226,8 +2360,8 @@ static void su_teardown(pTHX_ void *param) { return; } -static void su_setup(pTHX) { -#define su_setup() su_setup(aTHX) +static void su_local_setup(pTHX) { +#define su_local_setup() su_local_setup(aTHX) MY_CXT_INIT; MY_CXT.stack_placeholder = NULL; @@ -2257,7 +2391,7 @@ static void su_setup(pTHX) { MY_CXT.uid_storage.used = 0; MY_CXT.uid_storage.alloc = 0; - call_atexit(su_teardown, NULL); + call_atexit(su_local_teardown, NULL); return; } @@ -2300,8 +2434,6 @@ default_cx: \ # define SU_INFO_COUNT 10 #endif -XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */ - XS(XS_Scope__Upper_unwind) { #ifdef dVAR dVAR; dXSARGS; @@ -2346,8 +2478,6 @@ XS(XS_Scope__Upper_unwind) { static const char su_yield_name[] = "yield"; -XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */ - XS(XS_Scope__Upper_yield) { #ifdef dVAR dVAR; dXSARGS; @@ -2377,8 +2507,6 @@ XS(XS_Scope__Upper_yield) { static const char su_leave_name[] = "leave"; -XS(XS_Scope__Upper_leave); /* prototype to pass -Wmissing-prototypes */ - XS(XS_Scope__Upper_leave) { #ifdef dVAR dVAR; dXSARGS; @@ -2406,22 +2534,8 @@ PROTOTYPES: ENABLE BOOT: { - HV *stash; - - MUTEX_INIT(&su_uid_seq_counter_mutex); - - su_uid_seq_counter.seqs = NULL; - su_uid_seq_counter.size = 0; - - 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); - newXSproto("Scope::Upper::yield", XS_Scope__Upper_yield, file, NULL); - newXSproto("Scope::Upper::leave", XS_Scope__Upper_leave, file, NULL); - - su_setup(); + su_global_setup(file); + su_local_setup(); } #if SU_THREADSAFE @@ -2757,9 +2871,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 @@ -2773,8 +2888,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); @@ -2791,10 +2905,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"); } @@ -2811,8 +2926,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);