X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=blobdiff_plain;f=Upper.xs;h=823b32e38a6556f6f486baec573d2b387467b85c;hp=e3713ae95ffccae1ced4042185b620c704947522;hb=c8b3fd1af4c37a5d52756381215a5d4117b5b44f;hpb=181496f2ca2ce70348ee900a89f3e8854958c385 diff --git a/Upper.xs b/Upper.xs index e3713ae..823b32e 100644 --- a/Upper.xs +++ b/Upper.xs @@ -52,6 +52,17 @@ #if SU_DEBUG # define SU_D(X) STMT_START X STMT_END +static void su_debug_log(const char *fmt, ...) { + va_list va; + SV *sv; + dTHX; + va_start(va, fmt); + sv = get_sv(__PACKAGE__ "::DEBUG", 0); + if (sv && SvTRUE(sv)) + PerlIO_vprintf(Perl_debug_log, fmt, va); + va_end(va); + return; +} #else # define SU_D(X) #endif @@ -256,6 +267,11 @@ static U8 su_op_gimme_reverse(U8 gimme) { # define MY_CXT_CLONE NOOP #endif +/* --- Error messages ------------------------------------------------------ */ + +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 ------------------------------------ */ /* ... Sequence ID counter ................................................. */ @@ -330,53 +346,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) { #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; } } @@ -467,16 +477,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); @@ -729,16 +730,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 +759,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; @@ -763,11 +772,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); - }); + SU_D(su_debug_log("@@@ call scope_ix=%2d save_ix=%2d\n", + PL_scopestack_ix, PL_savestack_ix)); ENTER; SAVETMPS; @@ -782,7 +788,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 +799,29 @@ static void su_call(pTHX_ void *ud_) { FREETMPS; LEAVE; - SvREFCNT_dec(ud->cb); - SU_UD_FREE(ud); -} - -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); - }); + SvREFCNT_dec(cb); - 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 +897,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 +912,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) { @@ -930,10 +930,9 @@ static void su_localize(pTHX_ void *ud_) { SU_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); }); @@ -942,14 +941,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,8 +966,28 @@ 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 MY_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_; + dMY_CXT; + + MY_CXT.uid_storage.map[ud->idx].flags &= ~SU_UID_ACTIVE; + + SU_UD_FREE(ud); + + return; } /* --- Pop a context back -------------------------------------------------- */ @@ -1024,21 +1043,19 @@ static void su_pop(pTHX_ void *ud) { 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]) - ); + SU_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", - ud, 24, ' ', mark, base)); + SU_D(su_debug_log("%p: original scope was %*c top=%2d base=%2d\n", + ud, 24, ' ', mark, base)); if (base < mark) { #if SU_HAS_PERL(5, 19, 4) @@ -1046,7 +1063,7 @@ static void su_pop(pTHX_ void *ud) { PERL_CONTEXT *cx; #endif - SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud)); + SU_D(su_debug_log("%p: clear leftovers\n", ud)); #if SU_HAS_PERL(5, 19, 4) cx = cxstack + cxstack_ix; @@ -1067,73 +1084,88 @@ static void su_pop(pTHX_ void *ud) { 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, + SU_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)); + SU_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: { + SU_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", - ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix])); + SU_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) { #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S)) - I32 i, depth = 1, pad, offset, base, *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; + + SU_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; + SU_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; + SU_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); base = PL_scopestack_ix - depth; @@ -1141,14 +1173,15 @@ static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { 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. */ @@ -1156,24 +1189,21 @@ static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { <= PL_scopestack[PL_scopestack_ix - 1]) { dMY_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)); + SU_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)); + SU_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({ 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]); } }); @@ -1210,8 +1240,7 @@ static void su_unwind(pTHX_ void *ud_) { SU_D({ I32 gimme = GIMME_V; - PerlIO_printf(Perl_debug_log, - "%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n", + su_debug_log("%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n", &MY_CXT, cxix, gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar", items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark); @@ -1448,14 +1477,12 @@ static void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) { sud->tmp_uid_storage = MY_CXT.uid_storage; MY_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; @@ -1961,8 +1988,8 @@ static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { 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; + su_uid *map; + STRLEN alloc; dMY_CXT; map = MY_CXT.uid_storage.map; @@ -1971,27 +1998,20 @@ static su_uid *su_uid_storage_fetch(pTHX_ UV depth) { if (depth >= alloc) { STRLEN i; - Renew(map, depth + 1, su_uid *); - for (i = alloc; i <= depth; ++i) - map[i] = NULL; + Renew(map, depth + 1, su_uid); + for (i = alloc; i <= depth; ++i) { + map[i].seq = 0; + map[i].flags = 0; + } MY_CXT.uid_storage.map = map; MY_CXT.uid_storage.alloc = depth + 1; } - uid = map[depth]; - - if (!uid) { - Newx(uid, 1, su_uid); - uid->seq = 0; - uid->flags = 0; - map[depth] = uid; - } - if (depth >= MY_CXT.uid_storage.used) MY_CXT.uid_storage.used = depth + 1; - return uid; + return map + depth; } static int su_uid_storage_check(pTHX_ UV depth, UV seq) { @@ -2002,49 +2022,35 @@ static int su_uid_storage_check(pTHX_ UV depth, UV seq) { if (depth >= MY_CXT.uid_storage.used) return 0; - uid = MY_CXT.uid_storage.map[depth]; - - return uid && (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE); -} - -static void su_uid_drop(pTHX_ void *ud_) { - su_uid *uid = ud_; + uid = MY_CXT.uid_storage.map + depth; - 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); + return (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE); } 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; } @@ -2332,16 +2338,9 @@ static void su_global_setup(pTHX_ SU_XS_FILE_TYPE *file) { static void su_local_teardown(pTHX_ void *param) { su_uplevel_ud *cur; - su_uid **map; dMY_CXT; - 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); - } + Safefree(MY_CXT.uid_storage.map); cur = MY_CXT.uplevel_storage.root; if (cur) { @@ -2582,6 +2581,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); @@ -2607,6 +2608,7 @@ PPCODE: XSRETURN(1); } } + warn(su_no_such_target, "subroutine"); XSRETURN_UNDEF; void @@ -2627,6 +2629,7 @@ PPCODE: XSRETURN(1); } } + warn(su_no_such_target, "eval"); XSRETURN_UNDEF; void @@ -2638,8 +2641,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); @@ -2669,6 +2674,8 @@ PPCODE: } } done: + if (level >= 0) + warn(su_stack_smash); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2867,9 +2874,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 @@ -2883,8 +2891,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); @@ -2901,10 +2908,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"); } @@ -2921,8 +2929,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);