From: Vincent Pit <vince@profvince.com>
Date: Sat, 3 Sep 2011 22:33:19 +0000 (+0200)
Subject: Implement uplevel()
X-Git-Tag: v0.16~2
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=1da764455f3f82a24aad0881beb01f5e4d3cf858

Implement uplevel()
---

diff --git a/MANIFEST b/MANIFEST
index 2408e3a..e5ae94c 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -6,6 +6,7 @@ Makefile.PL
 README
 Upper.xs
 lib/Scope/Upper.pm
+samples/bench_uplevel.pl
 samples/tag.pl
 samples/try.pl
 t/00-load.t
@@ -37,8 +38,18 @@ t/50-unwind-target.t
 t/55-unwind-multi.t
 t/56-unwind-context.t
 t/59-unwind-threads.t
+t/60-uplevel-target.t
+t/61-uplevel-args.t
+t/62-uplevel-return.t
+t/63-uplevel-ctl.t
+t/64-uplevel-caller.t
+t/65-uplevel-multi.t
+t/66-uplevel-context.t
+t/67-uplevel-scope.t
+t/69-uplevel-threads.t
 t/81-stress-level.t
 t/85-stress-unwind.t
+t/86-stress-uplevel.t
 t/91-pod.t
 t/92-pod-coverage.t
 t/95-portability-files.t
diff --git a/Upper.xs b/Upper.xs
index f8a35c7..d591a75 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -14,6 +14,14 @@
 
 /* --- Compatibility ------------------------------------------------------- */
 
+#ifndef NOOP
+# define NOOP
+#endif
+
+#ifndef dNOOP
+# define dNOOP
+#endif
+
 #ifndef PERL_UNUSED_VAR
 # define PERL_UNUSED_VAR(V)
 #endif
@@ -36,6 +44,17 @@
 # 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 SvPV_const
 # define SvPV_const(S, L) SvPV(S, L)
 #endif
@@ -52,6 +71,14 @@
 # define GvCV_set(G, C) (GvCV(G) = (C))
 #endif
 
+#ifndef CvGV_set
+# define CvGV_set(C, G) (CvGV(C) = (G))
+#endif
+
+#ifndef CxHASARGS
+# define CxHASARGS(C) ((C)->blk_sub.hasargs)
+#endif
+
 #ifndef HvNAME_get
 # define HvNAME_get(H) HvNAME(H)
 #endif
@@ -60,6 +87,10 @@
 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
 #endif
 
+#ifndef cv_clone
+# define cv_clone(P) Perl_cv_clone(aTHX_ (P))
+#endif
+
 #ifndef PERL_MAGIC_tied
 # define PERL_MAGIC_tied 'P'
 #endif
@@ -77,14 +108,6 @@
 
 /* --- 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
@@ -119,17 +142,79 @@
 # define MY_CXT_CLONE NOOP
 #endif
 
+/* --- uplevel() data tokens ----------------------------------------------- */
+
+typedef struct {
+ void *next;
+
+ I32  cxix;
+ CV  *target;
+ bool died;
+
+ PERL_SI *si;
+ PERL_SI *old_curstackinfo;
+ AV      *old_mainstack;
+
+ I32  old_depth;
+ COP *old_curcop;
+
+ bool old_catch;
+ OP  *old_op;
+ CV  *cloned_cv;
+} 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;
+ 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 *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;
  LISTOP   return_op;
  OP       proxy_op;
+
+ su_uplevel_storage uplevel_storage;
 } my_cxt_t;
 
 START_MY_CXT
@@ -809,6 +894,423 @@ STATIC void su_unwind(pTHX_ void *ud_) {
  PL_op = &(MY_CXT.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 int su_uplevel_restore_free(pTHX_ SV *sv, MAGIC *mg) {
+ su_uplevel_ud_delete((su_uplevel_ud *) mg->mg_ptr);
+
+ return 0;
+}
+
+STATIC MGVTBL su_uplevel_restore_vtbl = {
+ 0,
+ 0,
+ 0,
+ 0,
+ su_uplevel_restore_free
+};
+
+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
+  * before uplevel). argarray is either the fake AV we created in su_uplevel()
+  * or some empty replacement POPSUB creates when @_ is reified. In both cases
+  * we have to destroy it before the context stack is swapped back to its
+  * original state. */
+ SvREFCNT_dec(cxstack[sud->cxix].blk_sub.argarray);
+
+ CATCH_SET(sud->old_catch);
+
+ SvREFCNT_dec(sud->cloned_cv);
+
+ 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_cv = 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_cv)
+      ++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_cv)
+       ++levels;
+      break;
+     case CXt_EVAL:
+      goto found_it;
+      break;
+     default:
+      break;
+    }
+   }
+
+found_it:
+   CvDEPTH(target_cv) = sud->old_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 change to how $@ was treated, 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);
+
+#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. */
+  SV *sv = sv_newmortal();
+  sv_magicext(sv, NULL, PERL_MAGIC_ext, &su_uplevel_restore_vtbl,
+                        (const char *) sud, 0);
+ } else {
+#endif
+  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
+
+ return;
+}
+
+STATIC CV *su_cv_clone(pTHX_ CV *old_cv) {
+#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. */
+#if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
+ I32 old_depth;
+ CV *outside = CvOUTSIDE(old_cv);
+
+ if (outside && CvCLONE(outside) && !CvCLONED(outside))
+  outside = find_runcv(NULL);
+ old_depth = CvDEPTH(outside);
+ if (!old_depth)
+  CvDEPTH(outside) = 1;
+#endif
+
+ new_cv = cv_clone(old_cv);
+
+#if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
+ 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.
+  * 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)) {
+  const AV  *old_padname = (const AV *)  AvARRAY(CvPADLIST(old_cv))[0];
+  AV        *old_pad     = (AV *)        AvARRAY(CvPADLIST(old_cv))[1];
+  AV        *new_pad     = (AV *)        AvARRAY(CvPADLIST(new_cv))[1];
+  const SV **old_aryname = (const SV **) AvARRAY(old_padname);
+  SV       **old_ary     = AvARRAY(old_pad);
+  SV       **new_ary     = AvARRAY(new_pad);
+  I32 fname = AvFILLp(old_padname);
+  I32 fpad  = AvFILLp(old_pad);
+  I32 ix;
+
+  for (ix = fpad; ix > 0; ix--) {
+   const SV *namesv = (ix <= fname) ? old_aryname[ix] : NULL;
+
+   if (namesv && namesv != &PL_sv_undef && SvFAKE(namesv)) {
+    SvREFCNT_dec(new_ary[ix]);
+    new_ary[ix] = SvREFCNT_inc(old_ary[ix]);
+   }
+  }
+ }
+
+ return new_cv;
+}
+
+STATIC I32 su_uplevel(pTHX_ CV *cv, 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;
+ UNOP sub_op;
+ I32  marksize;
+ I32  gimme;
+ I32  old_mark, new_mark;
+ I32  ret;
+ dSP;
+ dMY_CXT;
+
+ 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 = 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->cxix = cxix;
+ sud->died = 1;
+ SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
+
+ si->si_type = cur->si_type;
+ si->si_next = NULL;
+ si->si_prev = cur->si_prev;
+
+ /* 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;
+
+#ifdef DEBUGGING
+ si->si_markoff = cx->blk_oldmarksp;
+#endif
+
+ /* Copy the context stack up to the context just below the target. */
+ si->si_cxix  = (cxix < 0) ? -1 : (cxix - 1);
+ /* 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_cv      = cx->blk_sub.cv;
+ sud->target    = (CV *) SvREFCNT_inc(target_cv);
+ sud->old_depth = CvDEPTH(target_cv);
+
+ /* 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, 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;
+
+ cv = su_cv_clone(cv);
+ sud->cloned_cv = cv;
+ CvGV_set(cv, CvGV(target_cv));
+
+ PUSHMARK(SP);
+ /* Both SP and old_stack_sp points just before the CV. */
+ Copy(old_stack_sp + 2, SP + 1, args, SV *);
+ SP += args;
+ PUSHs((SV *) cv);
+ 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_catch = CATCH_GET;
+ CATCH_SET(TRUE);
+
+ if (PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)) {
+  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);
+   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 *);
+   cxstack[cxix].blk_sub.argarray = av;
+  } else if (PL_DBsub) {
+   SvREFCNT_inc(cxstack[cxix].blk_sub.argarray);
+  }
+
+  CALLRUNOPS(aTHX);
+
+  ret = PL_stack_sp - (PL_stack_base + new_mark);
+ }
+
+ sud->died = 0;
+
+ SPAGAIN;
+
+ 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;
+ }
+
+ PUTBACK;
+
+ LEAVE;
+
+ return ret;
+}
+
+/* --- Interpreter setup/teardown ------------------------------------------ */
+
+STATIC void su_teardown(pTHX_ void *param) {
+ su_uplevel_ud *cur, *prev;
+ 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.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.proxy_op), 1, sizeof(MY_CXT.proxy_op));
+ MY_CXT.proxy_op.op_type   = OP_STUB;
+ MY_CXT.proxy_op.op_ppaddr = NULL;
+
+ MY_CXT.uplevel_storage.root  = NULL;
+ MY_CXT.uplevel_storage.count = 0;
+
+ call_atexit(su_teardown, NULL);
+
+ return;
+}
+
 /* --- XS ------------------------------------------------------------------ */
 
 #if SU_HAS_PERL(5, 8, 9)
@@ -922,24 +1424,13 @@ BOOT:
 {
  HV *stash;
 
- MY_CXT_INIT;
-
- 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.proxy_op), 1, sizeof(MY_CXT.proxy_op));
- MY_CXT.proxy_op.op_type   = OP_STUB;
- MY_CXT.proxy_op.op_ppaddr = 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
@@ -950,6 +1441,8 @@ PROTOTYPE: DISABLE
 PPCODE:
  {
   MY_CXT_CLONE;
+  MY_CXT.uplevel_storage.root  = NULL;
+  MY_CXT.uplevel_storage.count = 0;
  }
  XSRETURN(0);
 
@@ -1159,3 +1652,36 @@ 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;
+    }
+    ret = su_uplevel((CV *) code, cxix, args);
+    XSRETURN(ret);
+   default:
+    break;
+  }
+ } while (--cxix >= 0);
+ croak("Can't uplevel outside a subroutine");
diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm
index 9202740..7396188 100644
--- a/lib/Scope/Upper.pm
+++ b/lib/Scope/Upper.pm
@@ -109,6 +109,25 @@ L</unwind> and L</want_at> :
     my @stuff = zap(); # @stuff contains qw<a b c>
     my $stuff = zap(); # $stuff contains 3
 
+L</uplevel> :
+
+    package Uplevel;
+
+    use Scope::Upper qw<uplevel CALLER>;
+
+    sub target {
+     faker(@_);
+    }
+
+    sub faker {
+     uplevel {
+      my $sub = (caller 0)[3];
+      print "$_[0] from $sub()";
+     } @_ => CALLER(1);
+    }
+
+    target('hello'); # "hello from Uplevel::target()"
+
 =head1 DESCRIPTION
 
 This module lets you defer actions I<at run-time> that will take place when the control flow returns into an upper scope.
@@ -126,7 +145,11 @@ localize variables, array/hash values or deletions of elements in higher context
 
 =item *
 
-return values immediately to an upper level with L</unwind>, and know which context was in use then with L</want_at>.
+return values immediately to an upper level with L</unwind>, and know which context was in use then with L</want_at> ;
+
+=item *
+
+execute a subroutine in the context of an upper subroutine stack frame with L</uplevel>.
 
 =back
 
@@ -261,6 +284,75 @@ The previous example can then be "corrected" :
 
 will rightfully set C<$num> to C<26>.
 
+=head2 C<uplevel $code, @args, $context>
+
+Executes the code reference C<$code> with arguments C<@args> as if it were located at the subroutine stack frame pointed by C<$context>, effectively fooling C<caller> and C<die> into believing that the call actually happened higher in the stack.
+The code is executed in the context of the C<uplevel> call, and what it returns is returned as-is by C<uplevel>.
+
+    sub target {
+     faker(@_);
+    }
+
+    sub faker {
+     uplevel {
+      map { 1 / $_ } @_;
+     } @_ => CALLER(1);
+    }
+
+    my @inverses = target(1, 2, 4); # @inverses contains (0, 0.5, 0.25)
+    my $count    = target(1, 2, 4); # $target is 3
+
+L<Sub::Uplevel> also implements a pure-Perl version of C<uplevel>.
+Both are identical, with the following caveats :
+
+=over 4
+
+=item *
+
+The L<Sub::Uplevel> implementation of C<uplevel> may execute a code reference in the context of B<any> upper stack frame.
+The L<Scope::Upper> version only allows to uplevel to a B<subroutine> stack frame, and will croak if you try to target an C<eval> or a format.
+
+=item *
+
+Exceptions thrown from the code called by this version of C<uplevel> will not be caught by C<eval> blocks between the target frame and the uplevel call, while they will for L<Sub::Uplevel>'s version.
+This means that :
+
+    eval {
+     sub {
+      local $@;
+      eval {
+       sub {
+        uplevel { die 'wut' } CALLER(2); # for Scope::Upper
+        # uplevel(3, sub { die 'wut' })  # for Sub::Uplevel
+       }->();
+      };
+      print "inner block: $@";
+      $@ and exit;
+     }->();
+    };
+    print "outer block: $@";
+
+will print "inner block: wut..." with L<Sub::Uplevel> and "outer block: wut..." with L<Scope::Upper>.
+
+=item *
+
+L<Sub::Uplevel> globally overrides C<CORE::GLOBAL::caller>, while L<Scope::Upper> does not.
+
+=back
+
+A simple wrapper lets you mimic the interface of L<Sub::Uplevel/uplevel> :
+
+    use Scope::Upper;
+
+    sub uplevel {
+     my $frame = shift;
+     my $code  = shift;
+     my $cxt   = Scope::Upper::CALLER($frame);
+     &Scope::Upper::uplevel($code => @_ => $cxt);
+    }
+
+Albeit the three exceptions listed above, it passes all the tests of L<Sub::Uplevel>.
+
 =head1 CONSTANTS
 
 =head2 C<SU_THREADSAFE>
@@ -353,26 +445,29 @@ Where L</localize>, L</localize_elem> and L</localize_delete> act depending on t
     # $cxt = SCOPE(4), UP SUB UP SUB, or UP SUB EVAL, or UP CALLER(2), or TOP
     ...
 
-Where L</unwind> and L</want_at> point to depending on the C<$cxt>:
+Where L</unwind>, L</want_at> and L</uplevel> point to depending on the C<$cxt>:
 
     sub {
      eval {
       sub {
        {
-        unwind @things => $cxt;
+        unwind @things => $cxt;     # or uplevel { ... } $cxt;
         ...
        }
        ...
       }->(); # $cxt = SCOPE(0 .. 1), or HERE, or UP, or SUB, or CALLER(0)
       ...
-     };      # $cxt = SCOPE(2), or UP UP, or UP SUB, or EVAL, or CALLER(1)
+     };      # $cxt = SCOPE(2), or UP UP, or UP SUB, or EVAL, or CALLER(1) (*)
      ...
     }->();   # $cxt = SCOPE(3), or SUB UP SUB, or SUB EVAL, or CALLER(2)
     ...
 
+    # (*) Note that uplevel() will croak if you pass that scope frame,
+    #     because it can't target eval scopes.
+
 =head1 EXPORT
 
-The functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete>,  L</unwind> and L</want_at> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
+The functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete>,  L</unwind>, L</want_at> and L</uplevel> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
 
 The constant L</SU_THREADSAFE> is also only exported on request, individually or by the tags C<':consts'> and C<':all'>.
 
@@ -384,7 +479,12 @@ use base qw<Exporter>;
 
 our @EXPORT      = ();
 our %EXPORT_TAGS = (
- funcs  => [ qw<reap localize localize_elem localize_delete unwind want_at> ],
+ funcs  => [ qw<
+  reap
+  localize localize_elem localize_delete
+  unwind want_at
+  uplevel
+ > ],
  words  => [ qw<TOP HERE UP SUB EVAL SCOPE CALLER> ],
  consts => [ qw<SU_THREADSAFE> ],
 );
@@ -435,6 +535,8 @@ It's easier to use, but it requires you to have control over the scope where you
 
 L<Scope::Escape>.
 
+L<Sub::Uplevel> provides a pure-Perl implementation of L</uplevel>.
+
 =head1 AUTHOR
 
 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
diff --git a/samples/bench_uplevel.pl b/samples/bench_uplevel.pl
new file mode 100644
index 0000000..a700417
--- /dev/null
+++ b/samples/bench_uplevel.pl
@@ -0,0 +1,70 @@
+#!perl
+
+use strict;
+use warnings;
+
+use blib;
+
+use Benchmark qw<cmpthese>;
+
+use Scope::Upper qw<:words>;
+BEGIN { *uplevel_xs = \&Scope::Upper::uplevel }
+
+use Sub::Uplevel;
+BEGIN { *uplevel_pp = \&Sub::Uplevel::uplevel }
+
+sub void { }
+
+sub foo_t  { void { } }
+
+sub foo_pp { uplevel_pp(0, sub { }) }
+
+sub foo_xs { uplevel_xs { } }
+
+print "\nuplevel to current scope:\n";
+cmpthese -1, {
+ tare => sub { foo_t() },
+ pp   => sub { foo_pp() },
+ xs   => sub { foo_xs() },
+};
+
+sub bar_1_t  { bar_2_t() }
+sub bar_2_t  { void() }
+
+sub bar_1_pp { bar_2_pp() }
+sub bar_2_pp { uplevel_pp(1, sub { }) }
+
+sub bar_1_xs { bar_2_xs() }
+sub bar_2_xs { uplevel_xs { } UP }
+
+print "\nuplevel to one scope above:\n";
+cmpthese -1, {
+ tare => sub { bar_2_t() },
+ pp   => sub { bar_2_pp() },
+ xs   => sub { bar_2_xs() },
+};
+
+sub hundred { 1 .. 100 }
+
+sub baz_t  { hundred() }
+
+sub baz_pp { uplevel_pp(0, sub { 1 .. 100 }) }
+
+sub baz_xs { uplevel_xs { 1 .. 100 } }
+
+print "\nreturning 100 values:\n";
+cmpthese -1, {
+ tare => sub { my @r = baz_t() },
+ pp   => sub { my @r = baz_pp() },
+ xs   => sub { my @r = baz_xs() },
+};
+
+my $n = 10_000;
+my $tare_code = "sub { my \@c; \@c = caller(0) for 1 .. $n }->()";
+
+print "\ncaller() slowdown:\n";
+cmpthese 30, {
+ tare => sub { system { $^X } $^X, '-e', "use blib; use List::Util; $tare_code" },
+ pp   => sub { system { $^X } $^X, '-e', "use blib; use Sub::Uplevel; $tare_code" },
+ xs   => sub { system { $^X } $^X, '-e', "use blib; use Scope::Upper; $tare_code" },
+}
diff --git a/samples/try.pl b/samples/try.pl
index e207e14..38b0e50 100644
--- a/samples/try.pl
+++ b/samples/try.pl
@@ -25,3 +25,22 @@ my @stuff = zap(); # @stuff contains qw<a b c>
 my $stuff = zap(); # $stuff contains 3
 
 print "zap() returns @stuff in list context and $stuff in scalar context\n";
+
+{
+ package Uplevel;
+
+ use Scope::Upper qw<uplevel CALLER>;
+
+ sub target {
+  faker(@_);
+ }
+
+ sub faker {
+  uplevel {
+   my $sub = (caller 0)[3];
+   print "$_[0] from $sub()\n";
+  } @_ => CALLER(1);
+ }
+
+ target('hello'); # "hello from Uplevel::target()"
+}
diff --git a/t/01-import.t b/t/01-import.t
index 2699c19..de0260a 100644
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * 14;
+use Test::More tests => 2 * 15;
 
 require Scope::Upper;
 
@@ -14,6 +14,7 @@ my %syms = (
  localize_delete => '$$;$',
  unwind          => undef,
  want_at         => ';$',
+ uplevel         => '&@',
  TOP             => '',
  HERE            => '',
  UP              => ';$',
diff --git a/t/60-uplevel-target.t b/t/60-uplevel-target.t
new file mode 100644
index 0000000..6b3a444
--- /dev/null
+++ b/t/60-uplevel-target.t
@@ -0,0 +1,228 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5;
+
+use Scope::Upper qw<uplevel HERE UP TOP>;
+
+our ($desc, $target);
+
+my @cxt;
+
+sub three {
+ my ($depth, $code) = @_;
+ $cxt[0] = HERE;
+ $target = $cxt[$depth];
+ &uplevel($code => $target);
+ pass("$desc: reached end of three()");
+}
+
+my $two = sub {
+ $cxt[1] = HERE;
+ three(@_);
+ pass("$desc: reached end of \$two");
+};
+
+sub one {
+ $cxt[2] = HERE;
+ $two->(@_);
+ pass("$desc: reached end of one()");
+}
+
+sub tester_sub {
+ is(HERE, $target, "$desc: right context");
+}
+
+my $tester_anon = sub {
+ is(HERE, $target, "$desc: right context");
+};
+
+my @subs = (\&three, $two, \&one);
+
+for my $height (0 .. 2) {
+ my $base = $subs[$height];
+
+ for my $anon (0, 1) {
+  my $code = $anon ? $tester_anon : \&tester_sub;
+
+  for my $depth (0 .. $height) {
+   local $target;
+   local $desc = "uplevel at depth $depth/$height";
+   $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
+
+   local $@;
+   eval { $base->($depth, $code) };
+   is $@, '', "$desc: no error";
+  }
+ }
+}
+
+{
+ my $desc = 'uplevel called without a code reference';
+ local $@;
+ eval {
+  three(0, "wut");
+  fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^First argument to uplevel must be a code reference/,"$desc: dies";
+}
+
+sub four {
+ my $desc = shift;
+ my $cxt  = HERE;
+ uplevel { is HERE, $cxt, "$desc: right context" };
+ pass "$desc: reached end of four()";
+}
+
+{
+ my $desc = 'uplevel called without a target';
+ local $@;
+ eval {
+  four($desc);
+ };
+ is $@, '', "$desc: no error";
+}
+
+{
+ my $desc = 'uplevel to top';
+ local $@;
+ eval {
+  uplevel sub { fail "$desc: uplevel body should not be executed" }, TOP;
+  fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^Can't uplevel outside a subroutine/, "$desc: dies";
+}
+
+{
+ my $desc = 'uplevel to eval 1';
+ local $@;
+ eval {
+  uplevel sub { fail "$desc: uplevel body should not be executed" }, HERE;
+  fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
+}
+
+{
+ my $desc = 'uplevel to eval 2';
+ local $@;
+ sub {
+  eval {
+   uplevel {
+    fail "$desc: uplevel body should not be executed"
+   };
+   fail "$desc: uplevel should have croaked";
+  };
+  return;
+ }->();
+ like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
+}
+
+# Target destruction
+
+{
+ our $destroyed;
+ sub Scope::Upper::TestCodeDestruction::DESTROY { ++$destroyed }
+
+ {
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'target destruction 1';
+
+  {
+   my $lexical;
+   my $target = sub {
+    my $code = shift;
+    ++$lexical;
+    $code->();
+   };
+   $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    $target->(
+     sub {
+      uplevel {
+       is $destroyed, 0, "$desc: not yet 1";
+      } UP;
+      is $destroyed, 0, "$desc: not yet 2";
+     },
+    );
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 3";
+  }
+
+  is $destroyed, 1, "$desc: target is detroyed";
+ }
+
+ SKIP: {
+  skip 'This fails even with a plain subroutine call on 5.8.x' => 6
+                                                                if "$]" < 5.009;
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'target destruction 2';
+
+  {
+   my $lexical;
+   my $target = sub {
+    my $code = shift;
+    ++$lexical;
+    $code->();
+   };
+   $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    $target->(
+     sub {
+      uplevel {
+       $target->(sub {
+        is $destroyed, 0, "$desc: not yet 1";
+       });
+       is $destroyed, 0, "$desc: not yet 2";
+      } UP;
+      is $destroyed, 0, "$desc: not yet 3";
+     },
+    );
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 4";
+  }
+
+  is $destroyed, 1, "$desc: target is detroyed";
+ }
+
+ {
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'target destruction 3';
+
+  {
+   my $lexical;
+   my $target = sub {
+    ++$lexical;
+    if (@_) {
+     my $code = shift;
+     $code->();
+    } else {
+     is $destroyed, 0, "$desc: not yet 1";
+    }
+   };
+   $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    $target->(
+     sub {
+      &uplevel($target => UP);
+      is $destroyed, 0, "$desc: not yet 2";
+     },
+    );
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 3";
+  }
+
+  is $destroyed, 1, "$desc: target is detroyed";
+ }
+}
diff --git a/t/61-uplevel-args.t b/t/61-uplevel-args.t
new file mode 100644
index 0000000..d4ee2ed
--- /dev/null
+++ b/t/61-uplevel-args.t
@@ -0,0 +1,206 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 9 + 4 * 7 + 3 + 2 + 6;
+
+use Scope::Upper qw<uplevel HERE>;
+
+# Basic
+
+sub {
+ uplevel { pass 'no @_: callback' };
+ is_deeply \@_, [ 'dummy' ], 'no @_: @_ outside';
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ ], "no arguments, no context" }
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ ], "no arguments, with context" } HERE
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ 1 ], "one const argument" } 1, HERE
+}->('dummy');
+
+my $x = 2;
+sub {
+ uplevel { is_deeply \@_, [ 2 ], "one lexical argument" } $x, HERE
+}->('dummy');
+
+our $y = 3;
+sub {
+ uplevel { is_deeply \@_, [ 3 ], "one global argument" } $y, HERE
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ 4, 5 ], "two const arguments" } 4, 5, HERE
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ 1 .. 10 ], "ten const arguments" } 1 .. 10, HERE
+}->('dummy');
+
+# Reification of @_
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+  my $r = shift;
+  is        $r,  1,           'shift: result';
+  is_deeply \@_, [ 2 .. 10 ], 'shift: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'shift: args';
+ is_deeply \@_,    [ 'dummy' ], 'shift: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+  my $r = pop;
+  is        $r,  10,         'pop: result';
+  is_deeply \@_, [ 1 .. 9 ], 'pop: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'pop: args';
+ is_deeply \@_,    [ 'dummy' ], 'pop: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+  my $r = unshift @_, 0;
+  is        $r,  11,          'unshift: result';
+  is_deeply \@_, [ 0 .. 10 ], 'unshift: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'unshift: args';
+ is_deeply \@_,    [ 'dummy' ], 'unshift: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+  my $r = push @_, 11;
+  is        $r,  11,          'push: result';
+  is_deeply \@_, [ 1 .. 11 ], 'push: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'push: args';
+ is_deeply \@_,    [ 'dummy' ], 'push: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+  my ($r) = splice @_, 4, 1;
+  is        $r,  5,                   'splice: result';
+  is_deeply \@_, [ 1 .. 4, 6 .. 10 ], 'splice: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'splice: args';
+ is_deeply \@_,    [ 'dummy' ], 'splice: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+  my ($r, $s, $t, @rest) = @_;
+  is_deeply [ $r, $s, $t, \@rest ], [ 1 .. 3, [ 4 .. 10 ] ], 'unpack 1: result';
+  is_deeply \@_, [ 1 .. 10 ],                             'unpack 1: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'unpack 1: args';
+ is_deeply \@_,    [ 'dummy' ], 'unpack 1: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1, 2);
+ uplevel {
+  my ($r, $s, $t, @rest) = @_;
+  is_deeply [ $r, $s, $t, \@rest ], [ 1, 2, undef, [ ] ], 'unpack 2: result';
+  is_deeply \@_, [ 1, 2 ],                                'unpack 2: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1, 2 ],    'unpack 2: args';
+ is_deeply \@_,    [ 'dummy' ], 'unpack 2: @_ outside';
+}->('dummy');
+
+# Aliasing
+
+sub {
+ my $s = 'abc';
+ uplevel {
+  $_[0] = 'xyz';
+ } $s, HERE;
+ is $s, 'xyz', 'aliasing, one layer';
+}->('dummy');
+
+sub {
+ my $s = 'abc';
+ sub {
+  uplevel {
+   $_[0] = 'xyz';
+  } $_[0], HERE;
+  is $_[0], 'xyz', 'aliasing, two layers 1';
+ }->($s);
+ is $s, 'xyz', 'aliasing, two layers 2';
+}->('dummy');
+
+# Magic
+
+{
+ package Scope::Upper::TestMagic;
+
+ sub TIESCALAR {
+  my ($class, $cb) = @_;
+  bless { cb => $cb }, $class;
+ }
+
+ sub FETCH { $_[0]->{cb}->(@_) }
+
+ sub STORE { die "Read only magic scalar" }
+}
+
+tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
+sub {
+ uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
+}->('dummy');
+
+tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
+sub {
+ uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
+}->('dummy');
+
+# Destruction
+
+{
+ package Scope::Upper::TestTimelyDestruction;
+
+ sub new {
+  my ($class, $flag) = @_;
+  $$flag = 0;
+  bless { flag => $flag }, $class;
+ }
+
+ sub DESTROY {
+  ${$_[0]->{flag}}++;
+ }
+}
+
+SKIP: {
+ skip 'This fails even with a plain subroutine call on 5.8.0' => 6
+                                                               if "$]" <= 5.008;
+
+ my $destroyed;
+ {
+  my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
+  is $destroyed, 0, 'destruction: not yet 1';
+  sub {
+   is $destroyed, 0, 'destruction: not yet 2';
+   uplevel {
+    is $destroyed, 0, 'destruction: not yet 3';
+   } $z, HERE;
+   is $destroyed, 0, 'destruction: not yet 4';
+  }->('dummy');
+  is $destroyed, 0, 'destruction: not yet 5';
+ }
+ is $destroyed, 1, 'destruction: destroyed';
+}
diff --git a/t/62-uplevel-return.t b/t/62-uplevel-return.t
new file mode 100644
index 0000000..76c922f
--- /dev/null
+++ b/t/62-uplevel-return.t
@@ -0,0 +1,192 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => (10 + 5 + 4) * 2 + 11;
+
+use Scope::Upper qw<uplevel HERE UP>;
+
+# Basic
+
+sub check (&$$) {
+ my ($code, $exp_in, $desc) = @_;
+
+ local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
+
+ my $exp_out = [ 'A', map("X$_", @$exp_in), 'Z' ];
+
+ my @ret = sub {
+  my @ret = &uplevel($code, HERE);
+  is_deeply \@ret, $exp_in, "$desc: inside";
+  @$exp_out;
+ }->('dummy');
+
+ is_deeply \@ret, $exp_out, "$desc: outside";
+}
+
+check { return } [ ], 'empty explicit return';
+
+check { () }     [ ], 'empty implicit return';
+
+check { return 1 } [ 1 ], 'one const scalar explicit return';
+
+check { 2 }        [ 2 ], 'one const scalar implicit return';
+
+{
+ my $x = 3;
+ check { return $x } [ 3 ], 'one lexical scalar explicit return';
+}
+
+{
+ my $x = 4;
+ check { $x }        [ 4 ], 'one lexical scalar implicit return';
+}
+
+{
+ our $x = 3;
+ check { return $x } [ 3 ], 'one global scalar explicit return';
+}
+
+{
+ our $x = 4;
+ check { $x }        [ 4 ], 'one global scalar implicit return';
+}
+
+check { return 1 .. 5 } [ 1 .. 5 ],  'five const scalar explicit return';
+
+check { 6 .. 10 }       [ 6 .. 10 ], 'five const scalar implicit return';
+
+# Mark
+
+{
+ my $desc = 'one scalar explict return between two others, without args';
+ my @ret = sub {
+  my @ret = (1, uplevel(sub { return 2 }), 3);
+  is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
+  qw<X Y>;
+ }->('dummy');
+ is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
+}
+
+{
+ my $desc = 'one scalar implict return between two others, without args';
+ my @ret = sub {
+  my @ret = (4, uplevel(sub { 5 }), 6);
+  is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
+  qw<X Y>;
+ }->('dummy');
+ is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
+}
+
+{
+ my $desc = 'one scalar explict return between two others, with args';
+ my @ret = sub {
+  my @ret = (1, uplevel(sub { return 2 }, 7 .. 9, HERE), 3);
+  is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
+  qw<X Y>;
+ }->('dummy');
+ is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
+}
+
+{
+ my $desc = 'one scalar implict return between two others, with args';
+ my @ret = sub {
+  my @ret = (4, uplevel(sub { 5 }, 7 .. 9, HERE), 6);
+  is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
+  qw<X Y>;
+ }->('dummy');
+ is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
+}
+
+{
+ my $desc = 'complex chain of calls';
+
+ sub one   { "<",   two("{", @_, "}"), ">" }
+ sub two   { "(", three("[", @_, "]"), ")" }
+ sub three { (uplevel { "A", "B", four(@_) } @_, UP), "Z" }
+ sub four  {
+  is_deeply \@_, [ qw|[ { * } ]| ], "$desc: inside";
+  @_
+ }
+
+ my @ret  = one('*');
+ is_deeply \@ret, [ qw|< ( A B [ { * } ] Z ) >| ], "$desc: outside";
+}
+
+# Magic
+
+{
+ package Scope::Upper::TestMagic;
+
+ sub TIESCALAR {
+  my ($class, $cb) = @_;
+  bless { cb => $cb }, $class;
+ }
+
+ sub FETCH { $_[0]->{cb}->(@_) }
+
+ sub STORE { die "Read only magic scalar" }
+}
+
+{
+ tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
+ check { return $mg } [ $$ ], 'one magical scalar explicit return';
+ check { $mg }        [ $$ ], 'one magical scalar implicit return';
+
+ tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
+ check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
+ check { $mg2 }        [ $$ ], 'one double magical scalar implicit return';
+}
+
+# Destruction
+
+{
+ package Scope::Upper::TestTimelyDestruction;
+
+ sub new {
+  my ($class, $flag) = @_;
+  $$flag = 0;
+  bless { flag => $flag }, $class;
+ }
+
+ sub DESTROY {
+  ${$_[0]->{flag}}++;
+ }
+}
+
+{
+ my $destroyed;
+ {
+  sub {
+   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
+   is $destroyed, 0, 'destruction 1: not yet 1';
+   uplevel {
+    is $destroyed, 0, 'destruction 1: not yet 2';
+    $z;
+   }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
+  }->('dummy');
+  is $destroyed, 1, 'destruction 1: destroyed 1';
+ }
+ is $destroyed, 1, 'destruction 1: destroyed 2';
+}
+
+SKIP: {
+ skip 'This fails even with a plain subroutine call on 5.8.x' => 6
+                                                                if "$]" < 5.009;
+
+ my $destroyed;
+ {
+  my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
+  is $destroyed, 0, 'destruction 2: not yet 1';
+  sub {
+   is $destroyed, 0, 'destruction 2: not yet 2';
+   (uplevel {
+    is $destroyed, 0, 'destruction 2: not yet 3';
+    return $z;
+   }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
+  }->('dummy');
+  is $destroyed, 0, 'destruction 2: not yet 5';
+ }
+ is $destroyed, 1, 'destruction 2: destroyed';
+}
diff --git a/t/63-uplevel-ctl.t b/t/63-uplevel-ctl.t
new file mode 100644
index 0000000..645d6f8
--- /dev/null
+++ b/t/63-uplevel-ctl.t
@@ -0,0 +1,309 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7);
+
+use Scope::Upper qw<uplevel HERE SUB CALLER>;
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+  my @c = caller($depth);
+  last unless @c;
+  ++$depth;
+ }
+ return $depth - 1;
+}
+
+is depth(),                           0, 'check top depth';
+is sub { depth() }->(),               1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+{
+ my $desc = 'exception with no eval in between 1';
+ local $@;
+ eval {
+  sub {
+   is depth(), 2, "$desc: correct depth 1";
+   uplevel {
+    is depth(), 2, "$desc: correct depth 2";
+    die 'cabbage';
+   };
+   fail "$desc: not reached 1";
+  }->();
+  fail "$desc: not reached 2";
+ };
+ my $line = __LINE__-6;
+ like $@, qr/^cabbage at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with no eval in between 2';
+ local $@;
+ eval {
+  sub {
+   is depth(), 2, "$desc: correct depth 1";
+   uplevel {
+    is depth(), 2, "$desc: correct depth 2";
+    sub {
+     is depth(), 3, "$desc: correct depth 3";
+     die 'lettuce';
+    }->();
+   };
+   fail "$desc: not reached 1";
+  }->();
+  fail "$desc: not reached 2";
+ };
+ my $line = __LINE__-7;
+ like $@, qr/^lettuce at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with no eval in between 3';
+ local $@;
+ eval q[
+  sub {
+   is depth(), 2, "$desc: correct depth 1";
+   uplevel {
+    is depth(), 2, "$desc: correct depth 2";
+    sub {
+     is depth(), 3, "$desc: correct depth 3";
+     die 'onion';
+    }->();
+   };
+   fail "$desc: not reached 1";
+  }->();
+  fail "$desc: not reached 2";
+ ];
+ like $@, qr/^onion at \(eval \d+\) line 8/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 1';
+ local $@;
+ eval {
+  sub {
+   eval {
+    is depth(), 3, "$desc: correct depth 1";
+    uplevel {
+     is depth(), 2, "$desc: correct depth 2";
+     die 'macaroni';
+    } SUB;
+    fail "$desc: not reached 1";
+   };
+   fail "$desc: not reached 2";
+  }->();
+  fail "$desc: not reached 3";
+ };
+ my $line = __LINE__-8;
+ like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 2';
+ local $@;
+ eval {
+  sub {
+   eval {
+    is depth(), 3, "$desc: correct depth 1";
+    uplevel {
+     is depth(), 2, "$desc: correct depth 1";
+     sub {
+      is depth(), 3, "$desc: correct depth 1";
+      die 'spaghetti';
+     }->();
+    } SUB;
+    fail "$desc: not reached 1";
+   };
+   fail "$desc: not reached 2";
+  }->();
+  fail "$desc: not reached 3";
+ };
+ my $line = __LINE__-9;
+ like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 3';
+ local $@;
+ eval {
+  sub {
+   eval q[
+    is depth(), 3, "$desc: correct depth 1";
+    uplevel {
+     is depth(), 2, "$desc: correct depth 1";
+     sub {
+      is depth(), 3, "$desc: correct depth 1";
+      die 'ravioli';
+     }->();
+    } SUB;
+    fail "$desc: not reached 1";
+    ];
+   fail "$desc: not reached 2";
+  }->();
+  fail "$desc: not reached 3";
+ };
+ like $@, qr/^ravioli at \(eval \d+\) line 7/, "$desc: correct exception";
+}
+our $hurp;
+
+SKIP: {
+ skip "Causes failures during global destruction on perl 5.8.[0126]" => 5
+                    if ("$]" >= 5.008 and "$]" <= 5.008002) or "$]" == 5.008006;
+ my $desc = 'exception with an eval and a local $@ in between';
+ local $hurp = 'durp';
+ local $@;
+ my $x = (eval {
+  sub {
+   local $@;
+   eval {
+    sub {
+     is depth(), 4, "$desc: correct depth 1";
+     uplevel {
+      is depth(), 2, "$desc: correct depth 2";
+      die 'lasagna'
+     } CALLER(2);
+     fail "$desc: not reached 1";
+    }->();
+    fail "$desc: not reached 2";
+   };
+   fail "$desc: not reached 3";
+  }->();
+  fail "$desc: not reached 4";
+ }, $@);
+ my $line = __LINE__-10;
+ like $@, qr/^lasagna at \Q$0\E line $line/, "$desc: correct exception";
+ like $x, qr/^lasagna at \Q$0\E line $line/, "$desc: \$@ timely reset";
+ is $hurp, 'durp', "$desc: force save stack flushing didn't go too far";
+}
+
+{
+ my $desc = 'several exceptions in a row';
+ local $@;
+ eval {
+  sub {
+   is depth(), 2, "$desc (first): correct depth";
+   uplevel {
+    is depth(), 2, "$desc (first): correct depth";
+    die 'carrot';
+   };
+   fail "$desc (first): not reached 1";
+  }->();
+  fail "$desc (first): not reached 2";
+ };
+ my $line = __LINE__-6;
+ like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception";
+ eval {
+  sub {
+   is depth(), 2, "$desc (second): correct depth 1";
+   uplevel {
+    is depth(), 2, "$desc (second): correct depth 2";
+    die 'potato';
+   };
+   fail "$desc (second): not reached 1";
+  }->();
+  fail "$desc (second): not reached 2";
+ };
+ $line = __LINE__-6;
+ like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception";
+ eval {
+  sub {
+   is depth(), 2, "$desc (third): correct depth 1";
+   uplevel {
+    is depth(), 2, "$desc (third): correct depth 2";
+    die 'tomato';
+   };
+   fail "$desc (third): not reached 1";
+  }->();
+  fail "$desc (third): not reached 2";
+ };
+ $line = __LINE__-6;
+ like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception";
+}
+
+my $has_B = do { local $@; eval 'require B; 1' };
+
+sub check_depth {
+ my ($code, $expected, $desc) = @_;
+
+ SKIP: {
+  skip 'B.pm is needed to check CV depth' => 1 unless $has_B;
+
+  local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
+
+  my $depth = B::svref_2object($code)->DEPTH;
+  is $depth, $expected, $desc;
+ }
+}
+
+sub bonk {
+ my ($code, $n, $cxt) = @_;
+ $cxt = SUB unless defined $cxt;
+ if ($n) {
+  bonk($code, $n - 1, $cxt);
+ } else {
+  &uplevel($code, $cxt);
+ }
+}
+
+{
+ my $desc = "an exception unwinding several levels of the same sub 1";
+ local $@;
+ check_depth \&bonk, 0, "$desc: depth at the beginning";
+ my $rec = 7;
+ sub {
+  eval {
+   bonk(sub {
+    check_depth \&bonk, $rec + 1, "$desc: depth inside";
+    die 'pepperoni';
+   }, $rec);
+  }
+ }->();
+ my $line = __LINE__-4;
+ like $@, qr/^pepperoni at \Q$0\E line $line/, "$desc: correct exception";
+ check_depth \&bonk, 0, "$desc: depth at the end";
+}
+
+sub clash {
+ my ($pre, $rec, $desc, $cxt, $m, $n) = @_;
+ $m = 0 unless defined $m;
+ if ($m < $pre) {
+  clash($pre, $rec, $desc, $cxt, $m + 1, $n);
+ } elsif ($m == $pre) {
+  check_depth \&clash, $pre + 1, "$desc: depth after prepending frames";
+  eval {
+   clash($pre, $rec, $desc, $cxt, $pre + 1, $n);
+  };
+  my $line = __LINE__+11;
+  like $@, qr/^garlic at \Q$0\E line $line/, "$desc: correct exception";
+  check_depth \&clash, $pre + 1, "$desc: depth after unwinding";
+ } else {
+  $n   = 0   unless defined $n;
+  $cxt = SUB unless defined $cxt;
+  if ($n < $rec) {
+   clash($pre, $rec, $desc, $cxt, $m, $n + 1);
+  } else {
+   uplevel {
+    check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside";
+    die 'garlic';
+   } $cxt;
+  }
+ }
+}
+
+{
+ my $desc = "an exception unwinding several levels of the same sub 2";
+ local $@;
+ check_depth \&clash, 0, "$desc: depth at the beginning";
+ my $pre = 5;
+ my $rec = 10;
+ sub {
+  eval {
+   clash($pre, $rec, $desc);
+  }
+ }->();
+ is $@, '', "$desc: no exception outside";
+ check_depth \&clash, 0, "$desc: depth at the beginning";
+}
diff --git a/t/64-uplevel-caller.t b/t/64-uplevel-caller.t
new file mode 100644
index 0000000..50a44d7
--- /dev/null
+++ b/t/64-uplevel-caller.t
@@ -0,0 +1,151 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => ((3 * 4) / 2) * 2 * 2 + 8;
+
+use Scope::Upper qw<uplevel HERE CALLER>;
+
+sub callstack {
+ my ($check_args) = @_;
+ my $i = 1;
+ my @stack;
+ while (1) {
+  my @c = $check_args ? do { package DB; caller($i++) }
+                      : caller($i++);
+  last unless @c;
+  if ($check_args) {
+   my $args = $c[4] ? [ @DB::args ] : undef;
+   push @c, $args;
+  }
+  push @stack, \@c;
+ }
+ return \@stack;
+}
+
+my @stacks;
+
+sub three {
+ my ($depth, $code) = @_;
+ $stacks[0] = callstack(1);
+ &uplevel($code, 'three', CALLER($depth));
+}
+
+my $two = sub {
+ $stacks[1] = callstack(1);
+ three(@_, 'two');
+};
+
+sub one {
+ $stacks[2] = callstack(1);
+ $two->(@_, 'one');
+}
+
+sub tester_sub { callstack(1) }
+
+my $tester_anon = sub { callstack(1) };
+
+my @subs = (\&three, $two, \&one);
+
+for my $height (0 .. 2) {
+ my $base = $subs[$height];
+
+ for my $anon (0, 1) {
+  my $code = $anon ? $tester_anon : \&tester_sub;
+
+  for my $depth (0 .. $height) {
+   my $desc = "callstack at depth $depth/$height";
+   $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
+
+   local $@;
+   my $result = eval { $base->($depth, $code, 'zero') };
+   is        $@,    '',                "$desc: no error";
+   is_deeply $result, $stacks[$depth], "$desc: correct call stack";
+  }
+ }
+}
+
+sub four {
+ my $cb = shift;
+ &uplevel($cb, 1, HERE);
+}
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (anonymous)";
+ my $cb;
+ $cb = sub { $_[0] ? $cb->(0) : callstack(0) };
+ local $@;
+ my ($expected, $got) = eval { $cb->(1), four($cb) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+sub test_named_recall { $_[0] ? test_named_recall(0) : callstack(0) }
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (named)";
+ local $@;
+ my ($expected, $got) = eval { test_named_recall(1),four(\&test_named_recall) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+my $mixed_recall_1;
+sub test_mixed_recall_1 {
+ if ($_[0]) {
+  $mixed_recall_1->(0)
+ } else {
+  callstack(0)
+ }
+}
+$mixed_recall_1 = \&test_mixed_recall_1;
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (mixed 1)";
+ local $@;
+ my ($expected, $got) = eval { test_mixed_recall_1(1), four($mixed_recall_1) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+my $mixed_recall_2_bis = do {
+ my $mixed_recall_2;
+
+ {
+  my $fake1;
+
+  eval q{
+   my $fake2;
+
+   {
+    my $fake3;
+
+    sub test_mixed_recall_2 {
+     $fake1++;
+     $fake2++;
+     $fake3++;
+     if ($_[0]) {
+      $mixed_recall_2->(0)
+     } else {
+      callstack(0)
+     }
+    }
+   }
+  };
+ }
+
+ $mixed_recall_2 = \&test_mixed_recall_2;
+};
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (mixed 2)";
+ local $@;
+ my ($expected, $got) = eval { test_mixed_recall_2(1), four($mixed_recall_2_bis) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
diff --git a/t/65-uplevel-multi.t b/t/65-uplevel-multi.t
new file mode 100644
index 0000000..c74815f
--- /dev/null
+++ b/t/65-uplevel-multi.t
@@ -0,0 +1,94 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3 + 7 * 2 + 8;
+
+use Scope::Upper qw<uplevel HERE UP>;
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+  my @c = caller($depth);
+  last unless @c;
+  ++$depth;
+ }
+ return $depth - 1;
+}
+
+is depth(),                           0, 'check top depth';
+is sub { depth() }->(),               1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+{
+ my $desc = 'uplevel in uplevel : lower frame';
+ local $@;
+ my @ret = eval {
+  1, sub {
+   is depth(), 2, "$desc: correct depth 1";
+   2, uplevel(sub {
+    is depth(), 2, "$desc: correct depth 2";
+    3, sub {
+     is depth(), 3, "$desc: correct depth 3";
+     4, uplevel(sub {
+      is depth(), 3, "$desc: correct depth 4";
+      return 5, @_;
+     }, 6, @_, HERE);
+    }->(7, @_);
+   }, 8, @_, HERE);
+  }->(9);
+ };
+ is $@,      '',              "$desc: no error";
+ is depth(), 0,               "$desc: correct depth outside";
+ is_deeply \@ret, [ 1 .. 9 ], "$desc: correct return value"
+}
+
+{
+ my $desc = 'uplevel in uplevel : same frame';
+ local $@;
+ my @ret = eval {
+  11, sub {
+   is depth(), 2, "$desc: correct depth 1";
+   12, uplevel(sub {
+    is depth(), 2, "$desc: correct depth 2";
+    13, sub {
+     is depth(), 3, "$desc: correct depth 3";
+     14, uplevel(sub {
+      is depth(), 2, "$desc: correct depth 4";
+      return 15, @_;
+     }, 16, @_, UP);
+    }->(17, @_);
+   }, 18, @_, HERE);
+  }->(19);
+ };
+ is $@,      '',                "$desc: no error";
+ is depth(), 0,                 "$desc: correct depth outside";
+ is_deeply \@ret, [ 11 .. 19 ], "$desc: correct return value"
+}
+
+{
+ my $desc = 'uplevel in uplevel : higher frame';
+ local $@;
+ my @ret = eval {
+  20, sub {
+   is depth(), 2, "$desc: correct depth 1";
+   21, sub {
+    is depth(), 3, "$desc: correct depth 2";
+    22, uplevel(sub {
+     is depth(), 3, "$desc: correct depth 3";
+     23, sub {
+      is depth(), 4, "$desc: correct depth 4";
+      24, uplevel(sub {
+       is depth(), 2, "$desc: correct depth 5";
+       return 25, @_;
+      }, 26, @_, UP UP);
+     }->(27, @_);
+    }, 28, @_, HERE);
+   }->(29, @_);
+  }->('2A');
+ };
+ is $@,      '',                      "$desc: no error";
+ is depth(), 0,                       "$desc: correct depth outside";
+ is_deeply \@ret, [ 20 .. 29, '2A' ], "$desc: correct return value"
+}
diff --git a/t/66-uplevel-context.t b/t/66-uplevel-context.t
new file mode 100644
index 0000000..54e30a3
--- /dev/null
+++ b/t/66-uplevel-context.t
@@ -0,0 +1,80 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+use Scope::Upper qw<uplevel UP>;
+
+{
+ my $want;
+ my @res = sub {
+  uplevel {
+   $want = wantarray;
+  };
+  return;
+ }->();
+ is $want, undef, 'static void context';
+}
+
+{
+ my $want;
+ my @res = sub {
+  my $res = uplevel {
+   $want = wantarray;
+  };
+  return;
+ }->();
+ is $want, '', 'static scalar context';
+}
+
+{
+ my $want;
+ my $res = sub {
+  my @res = uplevel {
+   $want = wantarray;
+  };
+  return;
+ }->();
+ is $want, 1, 'static list context';
+}
+
+{
+ my $want;
+ my @res = sub {
+  sub {
+   uplevel {
+    $want = wantarray;
+   } UP;
+  }->();
+  return;
+ }->();
+ is $want, undef, 'dynamic void context';
+}
+
+{
+ my $want;
+ my @res = sub {
+  my $res = sub {
+   uplevel {
+    $want = wantarray;
+   } UP;
+  }->();
+  return;
+ }->();
+ is $want, '', 'dynamic scalar context';
+}
+
+{
+ my $want;
+ my $res = sub {
+  my @res = sub {
+   uplevel {
+    $want = wantarray;
+   } UP;
+  }->();
+  return;
+ }->();
+ is $want, 1, 'dynamic list context';
+}
diff --git a/t/67-uplevel-scope.t b/t/67-uplevel-scope.t
new file mode 100644
index 0000000..715c50c
--- /dev/null
+++ b/t/67-uplevel-scope.t
@@ -0,0 +1,46 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+use Scope::Upper qw<uplevel HERE UP>;
+
+{
+ our $x = 1;
+ sub {
+  local $x = 2;
+  sub {
+   local $x = 3;
+   uplevel { is $x, 3, 'global variables scoping 1' } HERE;
+  }->();
+ }->();
+}
+
+{
+ our $x = 4;
+ sub {
+  local $x = 5;
+  sub {
+   local $x = 6;
+   uplevel { is $x, 6, 'global variables scoping 2' } UP;
+  }->();
+ }->();
+}
+
+sub {
+ "abc" =~ /(.)/;
+ sub {
+  "xyz" =~ /(.)/;
+  uplevel { is $1, 'x', 'match variables scoping 1' } HERE;
+ }->();
+}->();
+
+sub {
+ "abc" =~ /(.)/;
+ sub {
+  "xyz" =~ /(.)/;
+  uplevel { is $1, 'x', 'match variables scoping 2' } UP;
+ }->();
+}->();
diff --git a/t/69-uplevel-threads.t b/t/69-uplevel-threads.t
new file mode 100644
index 0000000..6ea386a
--- /dev/null
+++ b/t/69-uplevel-threads.t
@@ -0,0 +1,98 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+sub skipall {
+ my ($msg) = @_;
+ require Test::More;
+ Test::More::plan(skip_all => $msg);
+}
+
+use Config qw<%Config>;
+
+BEGIN {
+ my $force = $ENV{PERL_SCOPE_UPPER_TEST_THREADS} ? 1 : !1;
+ my $t_v   = $force ? '0' : '1.67';
+ skipall 'This perl wasn\'t built to support threads'
+                                                    unless $Config{useithreads};
+ skipall 'perl 5.13.4 required to test thread safety'
+                                              unless $force or "$]" >= 5.013004;
+ skipall "threads $t_v required to test thread safety"
+                                              unless eval "use threads $t_v; 1";
+}
+
+use Test::More;
+
+use Scope::Upper qw<uplevel UP SU_THREADSAFE>;
+
+my $num;
+
+BEGIN {
+ skipall 'This Scope::Upper isn\'t thread safe' unless SU_THREADSAFE;
+ plan tests => 3 + ($num = 30) * 3;
+ defined and diag "Using threads $_" for $threads::VERSION;
+ if (eval "use Time::HiRes; 1") {
+  defined and diag "Using Time::HiRes $_" for $Time::HiRes::VERSION;
+  *usleep = \&Time::HiRes::usleep;
+ } else {
+  diag 'Using fallback usleep';
+  *usleep = sub {
+   my $s = int($_[0] / 2.5e5);
+   sleep $s if $s;
+  };
+ }
+}
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+  my @c = caller($depth);
+  last unless @c;
+  ++$depth;
+ }
+ return $depth - 1;
+}
+
+is depth(),                           0, 'check top depth';
+is sub { depth() }->(),               1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+our $z;
+
+sub cb {
+ my $d   = splice @_, 1, 1;
+ my $p   = shift;
+ my $tid = pop;
+ is depth(), $d - 1, "$p: correct depth inside";
+ $tid, @_, $tid + 2
+}
+
+sub up1 {
+ my $tid  = threads->tid();
+ local $z = $tid;
+ my $p    = "[$tid] up1";
+
+ usleep rand(1e6);
+
+ my @res = (
+  -2,
+  sub {
+   my @dummy = (
+    -1,
+    sub {
+     my $d = depth();
+     my @ret = &uplevel(\&cb => ($p, $d, $tid + 1, $tid) => UP);
+     is depth(), $d, "$p: correct depth after uplevel";
+     @ret;
+    }->(),
+    1
+   );
+  }->(),
+  2
+ );
+
+ is_deeply \@res, [ -2, -1, $tid .. $tid + 2, 1, 2 ], "$p: returns correctly";
+}
+
+$_->join for map threads->create(\&up1), 1 .. $num;
diff --git a/t/86-stress-uplevel.t b/t/86-stress-uplevel.t
new file mode 100644
index 0000000..85b5e54
--- /dev/null
+++ b/t/86-stress-uplevel.t
@@ -0,0 +1,130 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+use Test::Leaner;
+
+use Scope::Upper qw<uplevel HERE UP SUB CALLER>;
+
+my $n = 1_000;
+
+plan tests => 3 + $n * (6 + 3);
+
+my $period1 = 100;
+my $period2 = 10;
+my $shift   = 10;
+my $amp     = 10;
+
+sub PI () { CORE::atan2(0, -1) }
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+  my @c = caller($depth);
+  last unless @c;
+  ++$depth;
+ }
+ return $depth - 1;
+}
+
+sub cap {
+ my ($depth, $top) = @_;
+
+ $depth <= 0 ? 1
+             : $depth >= $top ? $top - 1
+                              : $depth;
+}
+
+sub base_depth {
+ cap($shift + int($amp * sin(2 * PI * $_[0] / $period1)), 2 * $shift + 1);
+}
+
+sub uplevel_depth {
+ my ($base_depth, $i) = @_;
+
+ my $h = int($base_depth / 2);
+
+ cap($h + int($h * sin(2 * PI * $i / $period2)), $base_depth);
+}
+
+sub rec_basic {
+ my ($base_depth, $uplevel_depth, $desc, $i) = @_;
+ if ($i < $base_depth) {
+  $i, rec_basic($base_depth, $uplevel_depth, $desc, $i + 1);
+ } else {
+  is depth(), $base_depth+1, "$desc: depth before uplevel";
+  my $ret = uplevel {
+   is depth(), $base_depth+1-$uplevel_depth, "$desc: depth inside uplevel";
+   is "@_", "$base_depth $uplevel_depth",  "$desc: arguments";
+   -$uplevel_depth;
+  } @_[0, 1], CALLER($uplevel_depth);
+  is depth(), $base_depth+1, "$desc: depth after uplevel";
+  $ret;
+ }
+}
+
+sub rec_die {
+ my ($base_depth, $uplevel_depth, $desc, $i) = @_;
+ if ($i < $base_depth) {
+  local $@;
+  my $ret;
+  if ($i % 2) {
+   $ret = eval q<
+    rec_die($base_depth, $uplevel_depth, $desc, $i + 1)
+   >
+  } else {
+   $ret = eval {
+    rec_die($base_depth, $uplevel_depth, $desc, $i + 1)
+   }
+  }
+  return $@ ? $@
+            : $ret ? $ret
+                   : undef;
+ } else {
+  my $cxt = SUB;
+  {
+   my $n = $uplevel_depth;
+   while ($n) {
+    $cxt = SUB UP $cxt;
+    $n--;
+   }
+  }
+  my $ret = uplevel {
+   is HERE, $cxt, "$desc: context inside uplevel";
+   die "XXX @_";
+  } @_[0, 1], $cxt;
+  $ret;
+ }
+}
+
+my $die_line = __LINE__-6;
+
+is depth(),                           0, 'check top depth';
+is sub { depth() }->(),               1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+for my $i (1 .. $n) {
+ my $base_depth    = base_depth($i);
+ my $uplevel_depth = uplevel_depth($base_depth, $i);
+
+ {
+  my $desc = "basic $base_depth $uplevel_depth";
+
+  my @ret = rec_basic($base_depth, $uplevel_depth, $desc, 0);
+  is depth(), 0, "$desc: depth outside";
+  is_deeply \@ret, [ 0 .. $base_depth-1, -$uplevel_depth ],
+                                                       "$desc: returned values";
+ }
+
+ {
+  ++$base_depth;
+  my $desc = "die $base_depth $uplevel_depth";
+
+  my $err = rec_die($base_depth, $uplevel_depth, $desc, 0);
+  is depth(), 0, "$desc: depth outside";
+  like $err, qr/^XXX $base_depth $uplevel_depth at \Q$0\E line $die_line/,
+                                                         "$desc: correct error";
+ }
+}