# define MY_CXT_CLONE NOOP
#endif
-/* --- uplevel() data tokens ----------------------------------------------- */
+/* --- 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;
#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
typedef struct {
- char *stack_placeholder;
-
- I32 cxix;
- I32 items;
- SV **savesp;
- LISTOP return_op;
- OP proxy_op;
-
- su_uplevel_storage uplevel_storage;
+ char *stack_placeholder;
+ su_unwind_storage unwind_storage;
+ su_uplevel_storage uplevel_storage;
} my_cxt_t;
START_MY_CXT
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_);
items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark);
});
- PL_op = (OP *) &(MY_CXT.return_op);
+ PL_op = (OP *) &(MY_CXT.unwind_storage.return_op);
PL_op = PL_op->op_ppaddr(aTHX);
*PL_markstack_ptr = mark;
- MY_CXT.proxy_op.op_next = PL_op;
- PL_op = &(MY_CXT.proxy_op);
+ MY_CXT.unwind_storage.proxy_op.op_next = PL_op;
+ PL_op = &(MY_CXT.unwind_storage.proxy_op);
}
/* --- Uplevel ------------------------------------------------------------- */
#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();
+ }
+
+ 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;
+
+ 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++;
+ }
+}
+
+#define SU_HAS_EXT_MAGIC SU_HAS_PERL(5, 8, 0)
+
+#if SU_HAS_EXT_MAGIC
+
STATIC int su_uplevel_restore_free(pTHX_ SV *sv, MAGIC *mg) {
- su_uplevel_ud_delete((su_uplevel_ud *) mg->mg_ptr);
+ su_uplevel_storage_delete((su_uplevel_ud *) mg->mg_ptr);
return 0;
}
su_uplevel_restore_free
};
+#endif /* SU_HAS_EXT_MAGIC */
+
STATIC void su_uplevel_restore(pTHX_ void *sus_) {
su_uplevel_ud *sud = sus_;
PERL_SI *cur = sud->old_curstackinfo;
PERL_SI *si = sud->si;
- dMY_CXT;
/* When we reach this place, POPSUB has already been called (with our fake
* argarray). GvAV(PL_defgv) points to the savearray (that is, what @_ was
* 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 change to how $@ was treated, which were mainly integrated
+ * 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 */
PL_stack_sp = PL_stack_base + AvFILLp(cur->si_stack);
PL_stack_max = PL_stack_base + AvMAX(cur->si_stack);
-#if SU_HAS_PERL(5, 8, 0)
- if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
- /* When an exception is thrown from the uplevel'd subroutine,
- * su_uplevel_restore() may be called by the LEAVE in die_unwind() (called
- * 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. We work around
- * this by attaching the state data to a scalar that will be freed "soon".
- * This issue has been fixed in perl with commit 8f89e5a9. */
+ /* 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);
+#elif SU_HAS_EXT_MAGIC
+ /* If 'ext' magic is available, we work around this by attaching the state
+ * data to a scalar that will be freed "soon". */
+ {
SV *sv = sv_newmortal();
+
sv_magicext(sv, NULL, PERL_MAGIC_ext, &su_uplevel_restore_vtbl,
(const char *) sud, 0);
- } else {
-#endif
+ }
+#else
+ /* Otherwise, we just enqueue it back in the global storage list. */
+ {
+ dMY_CXT;
+
sud->next = MY_CXT.uplevel_storage.root;
MY_CXT.uplevel_storage.root = sud;
MY_CXT.uplevel_storage.count++;
-#if SU_HAS_PERL(5, 8, 0)
}
#endif
#define su_cv_clone(C) su_cv_clone(aTHX_ (C))
CV *new_cv;
- /* Starting from commit b5c19bd7, cv_clone() has an assert that checks whether
- * CvDEPTH(CvOUTSIDE(proto)) > 0, so we have to fool cv_clone() with a little
- * dance. */
+ /* Starting from commit b5c19bd7 (first made public with perl 5.9.0),
+ * cv_clone() has an assert that checks whether CvDEPTH(CvOUTSIDE(proto)) > 0.
+ * If this perl has DEBUGGING enabled, we have to fool cv_clone() with a
+ * little dance. */
#if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
I32 old_depth;
CV *outside = CvOUTSIDE(old_cv);
CvDEPTH(outside) = old_depth;
#endif
- /* Starting from perl 5.9 (more exactly commit b5c19bd7), cv_clone() is no
- * longer able to clone named subs propery. With this commit, pad_findlex()
- * stores the parent index of a fake pad entry in the NV slot of the
- * corresponding pad name SV, but only for anonymous subs (since named subs
- * aren't supposed to be cloned in pure Perl land). To fix this, we just
- * manually relink the new fake pad entries to the new ones.
+ /* Still from commit b5c19bd7, cv_clone() is no longer able to clone named
+ * subs propery. With this commit, pad_findlex() stores the parent index of a
+ * fake pad entry in the NV slot of the corresponding pad name SV, but only
+ * for anonymous subs (since named subs aren't supposed to be cloned in pure
+ * Perl land). To fix this, we just manually relink the new fake pad entries
+ * to the new ones.
* For some reason perl 5.8 crashes too without this, supposedly because of
* other closure bugs. Hence we enable it everywhere. */
if (!CvCLONE(old_cv)) {
I32 old_mark, new_mark;
I32 ret;
dSP;
- dMY_CXT;
ENTER;
old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base;
SPAGAIN;
- 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();
- }
- si = sud->si;
+ sud = su_uplevel_storage_new();
+ si = sud->si;
sud->cxix = cxix;
sud->died = 1;
* 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, we want the most recent matches. */
+ * 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() */
CvGV_set(cv, CvGV(target_cv));
PUSHMARK(SP);
- /* Both SP and old_stack_sp points just before the CV. */
+ /* Both SP and old_stack_sp point just before the CV. */
Copy(old_stack_sp + 2, SP + 1, args, SV *);
SP += args;
PUSHs((SV *) cv);
MY_CXT.stack_placeholder = NULL;
/* NewOp() calls calloc() which just zeroes the memory with memset(). */
- Zero(&(MY_CXT.return_op), 1, sizeof(MY_CXT.return_op));
- MY_CXT.return_op.op_type = OP_RETURN;
- MY_CXT.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
+ 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.proxy_op), 1, sizeof(MY_CXT.proxy_op));
- MY_CXT.proxy_op.op_type = OP_STUB;
- MY_CXT.proxy_op.op_ppaddr = NULL;
+ 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.root = NULL;
MY_CXT.uplevel_storage.count = 0;
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;
projects / perl / modules / Scope-Upper.git / blobdiff