Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Blead breaks Scope::Upper #15268

Closed
p5pRT opened this issue Apr 11, 2016 · 27 comments
Closed

Blead breaks Scope::Upper #15268

p5pRT opened this issue Apr 11, 2016 · 27 comments

Comments

@p5pRT
Copy link

p5pRT commented Apr 11, 2016

Migrated from rt.perl.org#127875 (status was 'resolved')

Searchable as RT127875$

@p5pRT
Copy link
Author

p5pRT commented Apr 11, 2016

From @kentfredric

There's been a lot of idle chat about this, but not any real commitment to a resolution either to block, or to vocally state an intent to release with a known broken and significant module.

- https://rt.cpan.org/Ticket/Display.html?id=112246

- Scope​::Upper is broken because of Stack Context Changes
- There is a respectable number of consumers of Scope​::Upper, including​:

-- Dancer2
-- TryCatch

Both of these are expected to be actively in use in the real world, and TryCatch has been in the Task​::Kensho recommendations list for several years, as well as Task​::Moose( amusingly, its a hidden dependency due to features ), which stands to reason there would be a considerable amount of darkpan using it.

https://metacpan.org/requires/distribution/TryCatch?sort=[[2,1]]&size=500

Given these factors, a resolution of "It shouldn't have done that, so its ok we break a lot of working code" leaves more than a sour taste in the mouth.

If we don't fix this now and block release, I fear we're going to be stuck in the same way 5.22 was, breaking known, heavily used modules like Coro, and still without a resolution an entire major release later. ( Please lets not be distracted by my choice of example, but focus on the principle )

@p5pRT
Copy link
Author

p5pRT commented Apr 11, 2016

From @rjbs

On Mon Apr 11 00​:41​:51 2016, kentfredric wrote​:

- There is a respectable number of consumers of Scope​::Upper,
including​:

-- Dancer2

I just installed Dancer2 on 5.23.9, and I'm not the only one​: http​://matrix.cpantesters.org/?dist=Dancer2+0.166001

--
rjbs

@p5pRT
Copy link
Author

p5pRT commented Apr 11, 2016

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Apr 11, 2016

From @xsawyerx

On Mon Apr 11 00​:41​:51 2016, kentfredric wrote​:

There's been a lot of idle chat about this, but not any real
commitment to a resolution either to block, or to vocally state an
intent to release with a known broken and significant module.

- https://rt.cpan.org/Ticket/Display.html?id=112246

- Scope​::Upper is broken because of Stack Context Changes
- There is a respectable number of consumers of Scope​::Upper,
including​:

-- Dancer2

To clarify this, Dancer2 does *not* use Scope​::Upper. It uses Return​::MultiLevel which *might* use Scope​::Upper if it's available.

When you install Dancer2, it will pull in Return​::MultiLevel which doesn't *require* Scope​::Upper. If you try to install Scope​::Upper it will fail (hence this ticket), but Return​::MultiLevel will just use a Pure-Perl implementation (because mauke is awesome) and Dancer2 will simply use that.

It's important to note, this does not break Dancer2. It does make it slower by making Return​::MultiLevel slower. Or, more accurately, does not allow it to be faster by utilizing Scope​::Upper.

@p5pRT
Copy link
Author

p5pRT commented Apr 11, 2016

From @khwilliamson

On 04/11/2016 01​:41 AM, Kent Fredric (via RT) wrote​:

# New Ticket Created by Kent Fredric
# Please include the string​: [perl #127875]
# in the subject line of all future correspondence about this issue.
# <URL​: https://rt-archive.perl.org/perl5/Ticket/Display.html?id=127875 >

There's been a lot of idle chat about this, but not any real commitment to a resolution either to block, or to vocally state an intent to release with a known broken and significant module.

- https://rt.cpan.org/Ticket/Display.html?id=112246

- Scope​::Upper is broken because of Stack Context Changes
- There is a respectable number of consumers of Scope​::Upper, including​:

-- Dancer2
-- TryCatch

Both of these are expected to be actively in use in the real world, and TryCatch has been in the Task​::Kensho recommendations list for several years, as well as Task​::Moose( amusingly, its a hidden dependency due to features ), which stands to reason there would be a considerable amount of darkpan using it.

https://metacpan.org/requires/distribution/TryCatch?sort=[[2,1]]&size=500

Given these factors, a resolution of "It shouldn't have done that, so its ok we break a lot of working code" leaves more than a sour taste in the mouth.

If we don't fix this now and block release, I fear we're going to be stuck in the same way 5.22 was, breaking known, heavily used modules like Coro, and still without a resolution an entire major release later. ( Please lets not be distracted by my choice of example, but focus on the principle )

I have made this a 5.24 blocker for now.

@p5pRT
Copy link
Author

p5pRT commented Apr 12, 2016

From @tonycoz

On Mon Apr 11 00​:41​:51 2016, kentfredric wrote​:

There's been a lot of idle chat about this, but not any real
commitment to a resolution either to block, or to vocally state an
intent to release with a known broken and significant module.

I wonder if either​:

a) Scope​::Upper should be maintained in core, since it's tied so much to the implementation, or

b) we should provide an API so that tools like Scope​::Upper (and perhaps Coro) can be written without implmentation changes breaking them

Tony

@p5pRT
Copy link
Author

p5pRT commented Apr 12, 2016

From @rjbs

* Tony Cook via RT <perlbug-followup@​perl.org> [2016-04-11T20​:09​:39]

a) Scope​::Upper should be maintained in core, since it's tied so much to the
implementation, or

Doing this doesn't produce the labor to keep it maintained. Instead, it acts
to create a higher barrier to changes that would break Scope​::Upper.

That is​: if Scope​::Upper is core, then you can't break it without breaking
core, so either​:

  a. you change "perl.c", and then also do the work of updating Scope​::Upper
  b. you decide not to make the changes in the first place

This is one way of carrying out a ruling that Scope​::Upper is too important to
allow to be broken. Jumping to this strategy is begging the question.

To me, the vital questions are​:

**Specifically​:** can Scope​::Upper be fixed with the APIs now available in
v5.24.0-RC0? That is​: if we release as-is, can it be fixed subsequently?

The options seem to be​:

  1. ship v5.24.0 with Scope​::Upper broken, but with the performance
  improvements and bugfixes of the context work in place

  2. revert the contexts work, putting it on hold until 5.25.x when someone
  (who?) has made Scope​::Upper work with it

In case (1), we hope that Scope​::Upper can be fixed on v5.24.0 with rework, or
that the specific shortcomings of the existing (still not-public!) API can be
determined so that it can be fixed on v5.25.x. If no one updates Scope​::Upper,
it remains broken "forever." (Even if some further, public API is provided,
Scope​::Upper would need to be updated to use it.)

In case (2), we must further decide whether the contexts work is permanently
blocked if no one ever overhauls Scope​::Upper to work with it.

**Generally​:** what is the appropriate way to divide cases where p5p is "on
the hook" and those where a module author is?

As Karl said, it's not realistic that by writing code against an "unpublished"
API, any API can become guaranteed. On the other hand, does this mean that end
user code surives only at the pleasure of the committers? Maybe, except that
the committers need to be guided by the idea that breaking downstream code has
a cost, and the cost needs to be considered beyond a mere "they shouldn't have
done that."

Still, there has to be a line drawn between what can be supported and what
cannot, and right now that line is the public API. It's not a great line. We
have talked about trying to improve it in the past, but so far nothing has
actually been done. What we've said in the past is that if you want to build
something that you can rely on, by all means build it now, but then come to p5p
and say, "Look, I made a thing. This thing is useful. I want to make sure it
doesn't get broken in the future. What can be done?" (This gets to what was
(b) in Tony's mail.)

That shares the onerousness​: some for p5p to provide a public API and some for
the reporter to rework code to use it.

--
rjbs

@p5pRT
Copy link
Author

p5pRT commented Apr 18, 2016

From @iabyn

On Tue, Apr 12, 2016 at 07​:45​:12PM -0400, Ricardo Signes wrote​:

Still, there has to be a line drawn between what can be supported and what
cannot, and right now that line is the public API. It's not a great line. We
have talked about trying to improve it in the past, but so far nothing has
actually been done. What we've said in the past is that if you want to build
something that you can rely on, by all means build it now, but then come to p5p
and say, "Look, I made a thing. This thing is useful. I want to make sure it
doesn't get broken in the future. What can be done?" (This gets to what was
(b) in Tony's mail.)

That shares the onerousness​: some for p5p to provide a public API and some for
the reporter to rework code to use it.

I've spent the last week doing more work on Scope​::Upper. I have it down
to 6 failing test scripts out of 58. The main failures at the moment are
the uplevel ones - uplevel being a mechanism to run a sub apparently in a
higher scope. I don't think the current implementation is fixable and will
need to be done a different way, which I will need to think about. I also
haven't tried it on perls older than 5.23.7 (I've been testing using
5.23.7 and 5.23.8 as representing the pre- and post-context perls), so may
need more fixes to run on older perls.

But one thing that should be made clear; it isn't just the case that S​::U
is doing something which relies on an internals-only API and that we have
the choice of making this API public; instead it is an inherently fragile
implementation that is extremely sensitive the exact details of how the
save stack is manipulated. It works by artificially altering the
boundaries of N parent savestack frames, then within each SAVEt_DESTRUCTOR
action called while freeing a savestack frame that has an artificially
increased lower bound, it itself frees the savestack items below that
higher threshold, then injects another SAVEt_DESTRUCTOR below that
threshold so that it appears to be in the caller's savestack frame. These
propagate on each scope exit until the desired scope level is reached.

So I don't think there's any sensible API we could create that would
shield S​::U from the details of perl's internals. Also, I don't think
S​::U should be included in core. We should be discouraging this module's
use, not implicitly endorsing it.

Also, although I have been putting in considerable effort to fix this
module, I don't think I *should* have to do this, nor should it be
expected that p5p will do similar fixups in future.

--
print+qq&$}$"$/$s$,$a$d$g$s$@​$.$q$,$​:$.$q$^$,$@​$a$$;$.$q$m&if+map{m,^\d{0\,},,${$​::{$'}}=chr($"+=$&amp;||1)}q&10m22,42}6​:17a22.3@​3;^2dg3q/s"&=~m*\d\*.*g

@p5pRT
Copy link
Author

p5pRT commented Apr 18, 2016

From @rjbs

* Dave Mitchell <davem@​iabyn.com> [2016-04-18T06​:10​:56]

I've spent the last week doing more work on Scope​::Upper.

Thanks for looking into this, Dave. I agree with your remarks on the question
of requiredness of this sort of work, but I'm also glad that it may continue to
work. Although I don't plan to block on Scope​::Upper, it is a useful tool.

(Leon T. was also talking about writing a subset of its functionality that was
easier to keep working, which is what more of Scope​::Upper's downstream
dependents use.)

--
rjbs

@p5pRT
Copy link
Author

p5pRT commented Apr 18, 2016

From perl@profvince.com

Le 18/04/2016 09​:29, Ricardo Signes a écrit :

* Dave Mitchell <davem@​iabyn.com> [2016-04-18T06​:10​:56]

I've spent the last week doing more work on Scope​::Upper.

Thanks for looking into this, Dave. I agree with your remarks on the question
of requiredness of this sort of work, but I'm also glad that it may continue to
work. Although I don't plan to block on Scope​::Upper, it is a useful tool.

(Leon T. was also talking about writing a subset of its functionality that was
easier to keep working, which is what more of Scope​::Upper's downstream
dependents use.)

The dependants seem to use all the features provided by Scope​::Upper, so
I don't really understand what subset would be "easier to keep working".
Unless all dependents are not treated equal, of course.

Vincent

@p5pRT
Copy link
Author

p5pRT commented Apr 18, 2016

From @rjbs

* "Vincent Pit (VPIT)" <perl@​profvince.com> [2016-04-18T08​:44​:35]

The dependants seem to use all the features provided by Scope​::Upper, so I
don't really understand what subset would be "easier to keep working".
Unless all dependents are not treated equal, of course.

The quote I'm going from, from IRC, is​:

  Following Pareto's principle, both Return​::MultiLevel and TryCatch only
  seem to use the unwind functionality of Scope​::Upper.

I read this as, "the great majority of things that end up relying on
Scope​::Upper do so for this particular feature." (I also assume, but did not
confirm, that this considered n-th order dependents, rather than only 1st
order.)

--
rjbs

@p5pRT
Copy link
Author

p5pRT commented Apr 18, 2016

From @Leont

On Mon, Apr 18, 2016 at 2​:29 PM, Ricardo Signes <perl.p5p@​rjbs.manxome.org>
wrote​:

(Leon T. was also talking about writing a subset of its functionality that
was
easier to keep working, which is what more of Scope​::Upper's downstream
dependents use.)

I did a trial release as Scope​::Unwind the other day. I'm observing some
transient threading issues with it, that may or may not have been inherited
from Scope​::Upper. It did not require any modification to run on bleadperl.

Leon

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

On Mon, Apr 18, 2016 at 09​:44​:35AM -0300, Vincent Pit (VPIT) wrote​:

Le 18/04/2016 09​:29, Ricardo Signes a écrit :

* Dave Mitchell <davem@​iabyn.com> [2016-04-18T06​:10​:56]

I've spent the last week doing more work on Scope​::Upper.

Thanks for looking into this, Dave. I agree with your remarks on the question
of requiredness of this sort of work, but I'm also glad that it may continue to
work. Although I don't plan to block on Scope​::Upper, it is a useful tool.

(Leon T. was also talking about writing a subset of its functionality that was
easier to keep working, which is what more of Scope​::Upper's downstream
dependents use.)

The dependants seem to use all the features provided by Scope​::Upper, so I
don't really understand what subset would be "easier to keep working".
Unless all dependents are not treated equal, of course.

The attached series of 8 patches makes Scope​::Upper pass all tests on
5.24.0, as well as all major perls back to 5.10.1. (I didn't test
on 5.6.x and 5.8.x as these require Test​::More to be installed).

--
The Enterprise is captured by a vastly superior alien intelligence which
does not put them on trial.
  -- Things That Never Happen in "Star Trek" #10

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

0001-Temporarily-rename-xsh_debug_log-to-su_debug_log.patch
From 7473ca20bf59ebe77148ed0994a939250b15d6e8 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Thu, 14 Apr 2016 15:39:37 +0100
Subject: [PATCH 1/8] Temporarily rename xsh_debug_log to su_debug_log

In a previous commit that function was renamed, but none of its callers
were renamed. For now, revert the function back to its old name
---
 xsh/debug.h | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/xsh/debug.h b/xsh/debug.h
index 707c760..e44428c 100644
--- a/xsh/debug.h
+++ b/xsh/debug.h
@@ -9,7 +9,7 @@
 
 #if XSH_DEBUG
 # define XSH_D(X) STMT_START X STMT_END
-static void xsh_debug_log(const char *fmt, ...) {
+static void su_debug_log(const char *fmt, ...) {
  va_list va;
  SV *sv;
  dTHX;
-- 
2.4.11

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

0002-Some-basic-5.23.8-fixes.patch
From 2e51af52f6eb4079dc9d9266a60131229cbabb0a Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 16 May 2016 13:34:09 +0100
Subject: [PATCH 2/8] Some basic 5.23.8 fixes

The context system has changed a lot in 5.23.8. This commit
just gets the code compiling again; it doesn';t attempt to fix any
breakage.
---
 Upper.xs | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 52 insertions(+), 9 deletions(-)

diff --git a/Upper.xs b/Upper.xs
index f6ed5c6..efc799a 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -16,6 +16,12 @@
 
 /* --- Compatibility ------------------------------------------------------- */
 
+/* perl 5.23.8 onwards has a revamped context system */
+#if XSH_HAS_PERL(5, 23, 8)
+# define SU_HAS_NEW_CXT
+#endif
+
+
 #ifndef dVAR
 # define dVAR dNOOP
 #endif
@@ -197,6 +203,27 @@ static U8 su_op_gimme_reverse(U8 gimme) {
 # define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
 #endif
 
+/* CX_ARGARRAY(cx): the AV at pad[0] of the CV associated with CXt_SUB
+ * context cx */
+
+#if XSH_HAS_PERL(5, 23, 8)
+# define CX_ARGARRAY(cx) \
+    ((AV*)(AvARRAY(MUTABLE_AV(                     \
+        PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[   \
+            CvDEPTH(cx->blk_sub.cv)]))[0]))
+/* XXX is the new def ok to use in lvalue cxt? Formerly it assigned to
+ * blk_sub.argarray, now to pad[0]. Does this matter?
+ */
+# define CX_ARGARRAY_set(cx,ary) \
+    (AvARRAY(MUTABLE_AV(                     \
+        PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[   \
+            CvDEPTH(cx->blk_sub.cv)]))[0] = (SV*)(ary))
+#else
+# define CX_ARGARRAY(cx)         (cx->blk_sub.argarray)
+# define CX_ARGARRAY_set(cx,ary) (cx->blk_sub.argarray = (ary))
+#endif
+
+
 /* --- Error messages ------------------------------------------------------ */
 
 static const char su_stack_smash[]    = "Cannot target a scope outside of the current stack";
@@ -1271,7 +1298,12 @@ static void su_yield(pTHX_ void *ud_) {
       o = SU_RETOP_EVAL(cx2);
       break;
 #if XSH_HAS_PERL(5, 11, 0)
+# if XSH_HAS_PERL(5, 23, 8)
+     case CXt_LOOP_ARY:
+     case CXt_LOOP_LIST:
+# else
      case CXt_LOOP_FOR:
+# endif
      case CXt_LOOP_PLAIN:
      case CXt_LOOP_LAZYSV:
      case CXt_LOOP_LAZYIV:
@@ -1312,7 +1344,12 @@ static void su_yield(pTHX_ void *ud_) {
    next = SU_RETOP_EVAL(cx);
    break;
 #if XSH_HAS_PERL(5, 11, 0)
+# if XSH_HAS_PERL(5, 23, 8)
+  case CXt_LOOP_ARY:
+  case CXt_LOOP_LIST:
+# else
   case CXt_LOOP_FOR:
+# endif
   case CXt_LOOP_PLAIN:
   case CXt_LOOP_LAZYSV:
   case CXt_LOOP_LAZYIV:
@@ -1483,7 +1520,7 @@ static int su_uplevel_goto_runops(pTHX) {
     switch (CxTYPE(cx)) {
      case CXt_SUB:
       if (CxHASARGS(cx)) {
-       argarray = cx->blk_sub.argarray;
+       argarray = CX_ARGARRAY(cx);
        goto done;
       }
       break;
@@ -1558,8 +1595,8 @@ static void su_uplevel_restore(pTHX_ void *sus_) {
    * reached without a goto() happening, and the old argarray member is
    * actually our fake argarray. Destroy it properly in that case. */
   if (cx->blk_sub.cv == sud->renamed) {
-   SvREFCNT_dec(cx->blk_sub.argarray);
-   cx->blk_sub.argarray = argarray;
+   SvREFCNT_dec(CX_ARGARRAY(cx));
+   CX_ARGARRAY_set(cx, argarray);
   }
 
   CvDEPTH(sud->callback)--;
@@ -1863,6 +1900,7 @@ static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
 
  if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
   PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
+  AV *argarray = CX_ARGARRAY(cx);
 
   /* If pp_entersub() returns a non-null OP, it means that the callback is not
    * an XSUB. */
@@ -1870,7 +1908,7 @@ static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
   sud->callback = MUTABLE_CV(SvREFCNT_inc(callback));
   CvDEPTH(callback)++;
 
-  if (CxHASARGS(cx) && cx->blk_sub.argarray) {
+  if (CxHASARGS(cx) && 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
@@ -1879,12 +1917,12 @@ static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
    AV *av = newAV();
    AvREAL_off(av);
    AvREIFY_on(av);
-   av_extend(av, AvMAX(cx->blk_sub.argarray));
-   AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
-   Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
-   sub_cx->blk_sub.argarray = av;
+   av_extend(av, AvMAX(argarray));
+   AvFILLp(av) = AvFILLp(argarray);
+   Copy(AvARRAY(argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
+   CX_ARGARRAY_set(sub_cx, av);
   } else {
-   SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
+   SvREFCNT_inc_simple_void(CX_ARGARRAY(sub_cx));
   }
 
   if (su_uplevel_goto_static(CvROOT(renamed))) {
@@ -2178,7 +2216,12 @@ static I32 su_context_gimme(pTHX_ I32 cxix) {
   switch (CxTYPE(cx)) {
    /* gimme is always G_ARRAY for loop contexts. */
 #if XSH_HAS_PERL(5, 11, 0)
+# if XSH_HAS_PERL(5, 23, 8)
+   case CXt_LOOP_ARY:
+   case CXt_LOOP_LIST:
+# else
    case CXt_LOOP_FOR:
+# endif
    case CXt_LOOP_PLAIN:
    case CXt_LOOP_LAZYSV:
    case CXt_LOOP_LAZYIV:
-- 
2.4.11

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

0003-get-su_init-su_pop-working-under-5.23.8.patch
From 0a34e21042dcbcc7972b994aecd1dfa2f573a31a Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 16 May 2016 13:38:21 +0100
Subject: [PATCH 3/8] get su_init/su_pop working under 5.23.8

In 5.23.8 there are two big differences to the way perl's context system
manipulates the savestack. Firstly, pushing a scope no longer does one or
two ENTER's instead the old value of PL_savestack_ix is stored as
cx->blk_oldsaveix. This means that the boundaries of savestack frames are
now not only specified as scopestack entries, but also as blk_oldsaveix
entries.

Secondly, most values that need restoring are saved in new fields in the
CX structure rather than being pushed on the savestack; this means that it
is quite likely that two nested scopes can share the same savestack index.

This commit gets all the test scripts working that mainly test the
savestack manipulation code (su_init and su_pop).

It does this by:

*) allowing the offset by which a savestack frame boundary is adjusted to
be variable (rather than always SU_SAVE_DESTRUCTOR_SIZE), and by turning
the origin array into an array of structs, one field of which is the
offset for that depth. This allows multiple empty savestack frames
to all trigger, by ensuring that each adjusted boundary is higher than the
previous.

*) padding the savestack using SAVEt_ALLOC, which allows a variable-sized
chunk of savestack to be reserved, with minimal overhead during scope exit.

In addition,

*) the various SU_SAVE_AELEM_SIZE type macros have been rationalised and
better commented;
*) debugging output for su_init and su_pop has been improved
*) the names of context types (for debugging) have been updated for 5.23.8
and some errors fixes for older perl versions
---
 Upper.xs | 491 +++++++++++++++++++++++++++++++++++++++++----------------------
 1 file changed, 322 insertions(+), 169 deletions(-)

diff --git a/Upper.xs b/Upper.xs
index efc799a..34edf04 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -446,7 +446,6 @@ typedef struct {
 /* --- Global data --------------------------------------------------------- */
 
 typedef struct {
- char               *stack_placeholder;
  su_unwind_storage   unwind_storage;
  su_yield_storage    yield_storage;
  su_uplevel_storage  uplevel_storage;
@@ -480,46 +479,64 @@ static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *
 
 /* --- Stack manipulations ------------------------------------------------- */
 
-#define SU_SAVE_PLACEHOLDER() save_pptr(&XSH_CXT.stack_placeholder)
+/* how many slots on the save stack various save types take up */
 
-#define SU_SAVE_DESTRUCTOR_SIZE  3
-#define SU_SAVE_PLACEHOLDER_SIZE 3
+#define SU_SAVE_DESTRUCTOR_SIZE 3 /* SAVEt_DESTRUCTOR_X */
+#define SU_SAVE_SCALAR_SIZE     3 /* SAVEt_SV */
+#define SU_SAVE_ARY_SIZE        3 /* SAVEt_AV */
+#define SU_SAVE_AELEM_SIZE      4 /* SAVEt_AELEM */
+#define SU_SAVE_HASH_SIZE       3 /* SAVEt_HV */
+#define SU_SAVE_HELEM_SIZE      4 /* SAVEt_HELEM */
+#define SU_SAVE_HDELETE_SIZE    4 /* SAVEt_DELETE */
 
-#define SU_SAVE_SCALAR_SIZE 3
+#define SU_SAVE_GVCV_SIZE       SU_SAVE_DESTRUCTOR_SIZE
+
+/* the overhead of save_alloc() but not including any elements,
+ * of which there must be at least 1 */
+#if XSH_HAS_PERL(5, 14, 0)
+# define SU_SAVE_ALLOC_SIZE      1 /* SAVEt_ALLOC */
+#else
+# define SU_SAVE_ALLOC_SIZE      2 /* SAVEt_ALLOC */
+#endif
 
-#define SU_SAVE_ARY_SIZE      3
-#define SU_SAVE_AELEM_SIZE    4
 #ifdef SAVEADELETE
-# define SU_SAVE_ADELETE_SIZE 3
+# define SU_SAVE_ADELETE_SIZE   3 /* SAVEt_ADELETE */
 #else
-# define SU_SAVE_ADELETE_SIZE SU_SAVE_DESTRUCTOR_SIZE
+# define SU_SAVE_ADELETE_SIZE   SU_SAVE_DESTRUCTOR_SIZE
+#endif
+
+/* (NB: it was 4 between 5.13.1 and 5.13.7) */
+#if XSH_HAS_PERL(5, 8, 9)
+# define SU_SAVE_GP_SIZE        3 /* SAVEt_GP */
+# else
+# define SU_SAVE_GP_SIZE        6 /* SAVEt_GP */
 #endif
+
+/* sometimes we don't know in advance whether we're saving or deleting
+ * an array/hash element. So include enough room for a variable-sized
+ * save_alloc() to pad it to a fixed size.
+ */
+
 #if SU_SAVE_AELEM_SIZE < SU_SAVE_ADELETE_SIZE
-# define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_ADELETE_SIZE
+# define SU_SAVE_AELEM_OR_ADELETE_SIZE \
+    (SU_SAVE_ADELETE_SIZE + SU_SAVE_ALLOC_SIZE + 1)
+#elif SU_SAVE_AELEM_SIZE > SU_SAVE_ADELETE_SIZE
+# define SU_SAVE_AELEM_OR_ADELETE_SIZE \
+    (SU_SAVE_AELEM_SIZE + SU_SAVE_ALLOC_SIZE + 1)
 #else
 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_AELEM_SIZE
 #endif
 
-#define SU_SAVE_HASH_SIZE    3
-#define SU_SAVE_HELEM_SIZE   4
-#define SU_SAVE_HDELETE_SIZE 4
 #if SU_SAVE_HELEM_SIZE < SU_SAVE_HDELETE_SIZE
-# define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HDELETE_SIZE
+# define SU_SAVE_HELEM_OR_HDELETE_SIZE \
+    (SU_SAVE_HDELETE_SIZE + SU_SAVE_ALLOC_SIZE + 1)
+#elif SU_SAVE_HELEM_SIZE > SU_SAVE_HDELETE_SIZE
+# define SU_SAVE_HELEM_OR_HDELETE_SIZE \
+    (SU_SAVE_HELEM_SIZE + SU_SAVE_ALLOC_SIZE + 1)
 #else
 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE
 #endif
 
-#define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE
-
-#if !XSH_HAS_PERL(5, 8, 9)
-# define SU_SAVE_GP_SIZE 6
-#elif !XSH_HAS_PERL(5, 13, 0) || (SU_RELEASE && XSH_HAS_PERL_EXACT(5, 13, 0))
-# define SU_SAVE_GP_SIZE 3
-#elif !XSH_HAS_PERL(5, 13, 8)
-# define SU_SAVE_GP_SIZE 4
-#else
-# define SU_SAVE_GP_SIZE 3
-#endif
 
 #ifndef SvCANEXISTDELETE
 # define SvCANEXISTDELETE(sv) \
@@ -701,17 +718,21 @@ static void su_save_gvcv(pTHX_ GV *gv) {
 /* --- Actions ------------------------------------------------------------- */
 
 typedef struct {
+ I32  orig_ix; /* original savestack_ix */
+ I32  offset;  /* how much we bumped this savestack index */
+} su_ud_origin_elem;
+
+typedef struct {
  U8   type;
  U8   private;
- U8   pad;
  /* spare */
  I32  depth;
- I32 *origin;
+ su_ud_origin_elem *origin;
 } su_ud_common;
 
+
 #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)
 
@@ -889,6 +910,15 @@ static void su_localize(pTHX_ void *ud_) {
  if (SvTYPE(sv) >= SVt_PVGV) {
   gv = (GV *) sv;
  } else {
+
+/* new perl context implementation frees savestack *before* restoring
+ * PL_curcop. Temporarily restore it prematurely to make gv_fetch*
+ * looks up unqualified var names in the caller's package */
+#ifdef SU_HAS_NEW_CXT
+  COP *old_cop = PL_curcop;
+  PL_curcop = CX_CUR()->blk_oldcop;
+#endif
+
 #ifdef gv_fetchsv
   gv = gv_fetchsv(sv, GV_ADDMULTI, t);
 #else
@@ -896,13 +926,16 @@ static void su_localize(pTHX_ void *ud_) {
   const char *name = SvPV_const(sv, len);
   gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
 #endif
+#ifdef SU_HAS_NEW_CXT
+  CX_CUR()->blk_oldcop = PL_curcop;
+#endif
  }
 
  XSH_D({
   SV *z = newSV(0);
   SvUPGRADE(z, t);
-  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",
+  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);
  });
@@ -966,35 +999,48 @@ static void su_uid_drop(pTHX_ void *ud_) {
 #ifdef DEBUGGING
 # define SU_CXNAME(C) PL_block_type[CxTYPE(C)]
 #else
-# if XSH_HAS_PERL(5, 11, 0)
+# if XSH_HAS_PERL(5, 23, 8)
 static const char *su_block_type[] = {
  "NULL",
  "WHEN",
  "BLOCK",
  "GIVEN",
- "LOOP_FOR",
- "LOOP_PLAIN",
+ "LOOP_ARY",
  "LOOP_LAZYSV",
  "LOOP_LAZYIV",
+ "LOOP_LIST",
+ "LOOP_PLAIN",
  "SUB",
  "FORMAT",
  "EVAL",
  "SUBST"
 };
-# elif XSH_HAS_PERL(5, 9, 3)
+# elif XSH_HAS_PERL(5, 11, 0)
 static const char *su_block_type[] = {
  "NULL",
- "SUB",
- "EVAL",
  "WHEN",
- "SUBST",
  "BLOCK",
- "FORMAT",
  "GIVEN",
  "LOOP_FOR",
  "LOOP_PLAIN",
  "LOOP_LAZYSV",
- "LOOP_LAZYIV"
+ "LOOP_LAZYIV",
+ "SUB",
+ "FORMAT",
+ "EVAL",
+ "SUBST"
+};
+# elif XSH_HAS_PERL(5, 10, 0)
+static const char *su_block_type[] = {
+ "NULL",
+ "SUB",
+ "EVAL",
+ "LOOP",
+ "SUBST",
+ "BLOCK",
+ "FORMAT"
+ "WHEN",
+ "GIVEN"
 };
 # else
 static const char *su_block_type[] = {
@@ -1003,78 +1049,105 @@ static const char *su_block_type[] = {
  "EVAL",
  "LOOP",
  "SUBST",
- "BLOCK"
+ "BLOCK",
+ "FORMAT"
 };
 # endif
 # define SU_CXNAME(C) su_block_type[CxTYPE(C)]
 #endif
 
-static void su_pop(pTHX_ void *ud) {
-#define su_pop(U) su_pop(aTHX_ (U))
- I32 depth, base, mark, *origin;
- depth = SU_UD_DEPTH(ud);
+/* for debugging. These indicate how many ENTERs each context type
+ * does before the PUSHBLOCK */
 
+static const int su_cxt_enter_count[] = {
+# if XSH_HAS_PERL(5, 23, 8)
+  0 /* context pushes no longer do ENTERs */
+# elif XSH_HAS_PERL(5, 11, 0)
+ /* NULL WHEN BLOCK GIVEN LOOP_FOR LOOP_PLAIN LOOP_LAZYSV
+  * LOOP_LAZYIV SUB FORMAT EVAL SUBST */
+ 0, 1, 1, 1, 2, 2, 2, 2, 1, 1, 1, 0
+# elif XSH_HAS_PERL(5, 10, 0)
+ /* NULL SUB EVAL LOOP SUBST BLOCK FORMAT WHEN GIVEN */
+ 0, 1, 1, 2, 0, 1, 1, 1, 1
+# else
+ /* NULL SUB EVAL LOOP SUBST BLOCK FORMAT */
+ 0, 1, 1, 2, 0, 1, 1
+# endif
+};
+
+
+
+/* push at least 'size' slots worth of padding onto the savestack */
+
+static void su_ss_push_padding(pTHX_ void *ud, I32 size) {
+ if (size <= 0)
+  return;
+ if (size < SU_SAVE_ALLOC_SIZE + 1) /* minimum possible SAVEt_ALLOC */
+  size = SU_SAVE_ALLOC_SIZE + 1;
  XSH_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]
- ));
+        "%p:     push %2d padding at save_ix=%d\n",
+         ud, size, PL_savestack_ix));
+ save_alloc((size - SU_SAVE_ALLOC_SIZE)*sizeof(*PL_savestack), 0);
+}
 
- origin = SU_UD_ORIGIN(ud);
- mark   = origin[depth];
- base   = origin[depth - 1];
 
- XSH_D(su_debug_log("%p: original scope was %*c top=%2d     base=%2d\n",
-                     ud,                24, ' ',    mark,        base));
+static void su_pop(pTHX_ void *ud);
 
- if (base < mark) {
-#if XSH_HAS_PERL(5, 19, 4)
-  I32 save = -1;
-  PERL_CONTEXT *cx;
-#endif
 
-  XSH_D(su_debug_log("%p: clear leftovers\n", ud));
 
-#if XSH_HAS_PERL(5, 19, 4)
-  cx = cxstack + cxstack_ix;
-  if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
-   save = PL_scopestack[cx->blk_oldscopesp - 1];
-#endif
+/* push an su_pop destructor onto the savestack with suitable padding.
+ * first indicates that this is the first push of a destructor */
 
-  PL_savestack_ix = mark;
-  leave_scope(base);
+static void su_ss_push_destructor(pTHX_ void *ud, I32 depth, bool first) {
+ su_ud_origin_elem *origin = SU_UD_ORIGIN(ud);
+ I32 pad;
 
-#if XSH_HAS_PERL(5, 19, 4)
-  if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
-   PL_scopestack[cx->blk_oldscopesp - 1] = save;
-#endif
+ assert(first || origin[depth+1].orig_ix == PL_savestack_ix);
+ su_ss_push_padding(aTHX_ ud,
+    (origin[depth].orig_ix + origin[depth].offset) - PL_savestack_ix);
+ XSH_D(su_debug_log(
+        "%p:     push destructor at save_ix=%d depth=%d scope_ix=%d\n",
+         ud, PL_savestack_ix, depth, PL_scopestack_ix));
+ SAVEDESTRUCTOR_X(su_pop, ud);
+ assert(first ||
+        PL_savestack_ix <= origin[depth+1].orig_ix +  origin[depth+1].offset);
+}
+
+
+/* this is called during each leave_scope() via SAVEDESTRUCTOR_X */
+
+static void su_pop(pTHX_ void *ud) {
+#define su_pop(U) su_pop(aTHX_ (U))
+ I32 depth, base, mark;
+ su_ud_origin_elem *origin;
+
+ depth  = SU_UD_DEPTH(ud);
+ origin = SU_UD_ORIGIN(ud);
+
+ XSH_D(su_debug_log( "%p: ### su_pop: depth=%d\n", ud, depth));
+
+ depth--;
+ mark = PL_savestack_ix;
+ base = origin[depth].orig_ix;
+
+ XSH_D(su_debug_log("%p:     residual savestack frame is %d(+%d)..%d\n",
+                     ud, base, origin[depth].offset, mark));
+
+ if (base < mark) {
+  XSH_D(su_debug_log("%p:     clear leftovers at %d..%d\n", ud, base, mark));
+  leave_scope(base);
  }
- PL_savestack_ix = base;
+ assert(PL_savestack_ix == base);
 
- SU_UD_DEPTH(ud) = --depth;
+ SU_UD_DEPTH(ud) = depth;
 
  if (depth > 0) {
-  U8 pad;
-
-  if ((pad = SU_UD_PAD(ud)) > 0) {
-   dXSH_CXT;
-   do {
-    XSH_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);
-  }
-
-  XSH_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);
+  su_ss_push_destructor(aTHX_ ud, depth-1, 0);
  } else {
+  I32 offset = origin[0].offset; /* grab value before origin is freed */
   switch (SU_UD_TYPE(ud)) {
    case SU_UD_TYPE_REAP: {
-    XSH_D(su_debug_log("%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
+    XSH_D(su_debug_log("%p:     === reap\n%p: depth=%d scope_ix=%d save_ix=%d\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);
@@ -1088,100 +1161,181 @@ static void su_pop(pTHX_ void *ud) {
     SAVEDESTRUCTOR_X(su_uid_drop, ud);
     break;
   }
+  /* perl 5.23.8 onwards is very fussy about the return from leave_scope()
+   * leaving PL_savestack_ix where it expects it to be */
+  if (PL_savestack_ix < base + offset) {
+   I32 gap = (base + offset) - PL_savestack_ix;
+   assert(gap >= SU_SAVE_ALLOC_SIZE + 1);
+   su_ss_push_padding(aTHX_ ud, gap);
+  }
+  assert(PL_savestack_ix == base + offset);
  }
 
- XSH_D(su_debug_log("%p: --- end pop: cur_top=%2d == cur_base=%2d\n",
-                     ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix]));
+ XSH_D(su_debug_log("%p:     end pop: ss_ix=%d\n", ud, PL_savestack_ix));
 }
 
+
 /* --- Initialize the stack and the action userdata ------------------------ */
 
-static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
+static void su_init(pTHX_ void *ud, I32 cxix, I32 size) {
 #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
- I32 i, depth, offset, base, *origin;
- U8 pad;
-
- XSH_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 {
-  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;
- XSH_D(su_debug_log("%p: size=%d pad=%d offset=%d\n", ud, size, pad, offset));
+ I32 i, depth, base;
+ su_ud_origin_elem *origin;
+ I32 cur_cx_ix;
+ I32 cur_scope_ix;
+
+ XSH_D(su_debug_log("%p: ### su_init(cxix=%d, size=%d)\n", ud, cxix, size));
 
  depth = PL_scopestack_ix - cxstack[cxix].blk_oldscopesp;
- XSH_D(su_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;
- origin[0] = PL_scopestack[base];
- 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;
+#ifdef SU_HAS_NEW_CXT
+ depth += (cxstack_ix - cxix); /* each context frame holds 1 scope */
+#endif
+ XSH_D(su_debug_log(
+   "%p:     going down by depth=%d with scope_ix=%d save_ix=%d\n",
+    ud, depth, PL_scopestack_ix, PL_savestack_ix));
+
+ /* Artificially increase the position of each savestack frame boundary
+  * to make space to squeeze in a 'size' sized entry (first one) or a
+  * SU_SAVE_DESTRUCTOR_SIZE sized entry (higher ones). In addition, make
+  * sure that each boundary is higher than the previous, so that *every*
+  * scope exit triggers a call to leave_scope(). Each scope exit will call
+  * the su_pop() destructor, which is responsible for: freeing any
+  * savestack entries below the artificially raised floor; then pushing a
+  * new destructor in that space. On the final pop, the "real" savestack
+  * action is pushed rather than another destructor.
+  *
+  * On older perls, savestack frame boundaries are specified by a range of
+  * scopestack entries (one per ENTER). Each scope entry typically does
+  * one or two ENTERs followed by a PUSHBLOCK. Thus the
+  * cx->blku_oldscopesp field set by the PUSHBLOCK points to the next free
+  * slot, which is one above the last of the ENTERs. In the debugging
+  * output we indicate that by bracketing the ENTERs directly preceding
+  * that context push with dashes, e.g.:
+  *
+  *   13b98d8:     ------------------
+  *   13b98d8:                 ENTER origin[0] scope[3] savestack=3+3
+  *   13b98d8:                 ENTER origin[1] scope[4] savestack=9+3
+  *   13b98d8:     cx=1  LOOP_LAZYIV
+  *   13b98d8:     ------------------
+  *
+  * In addition to context stack pushes, other activities can push ENTERs
+  * too, such as grep expr and XS sub calls.
+  *
+  * For newer perls (SU_HAS_NEW_CXT), a context push no longer does any
+  * ENTERs; instead the old savestack position is stored in the new
+  * cx->blk_oldsaveix field; thus this field specifies an additional
+  * savestack frame boundary point in addition to the scopestack entries,
+  * and will also need adjusting.
+  *
+  * We record the original and modified position of each boundary in the
+  * origin array.
+  *
+  * The passed cxix argument represents the scope we wish to inject into;
+  * we have to adjust all the savestack frame boundaries above (but not
+  * including) that context. 
+  */
+
+ Newx(origin, depth, su_ud_origin_elem);
+
+ cur_cx_ix  = cxix;
+ cur_scope_ix = cxstack[cxix].blk_oldscopesp;
+#ifdef SU_HAS_NEW_CXT
+ XSH_D(su_debug_log("%p:     cx=%-2d %-11s\n",
+      ud, cur_cx_ix, SU_CXNAME(cxstack+cur_cx_ix)));
+ cur_cx_ix++;
+#endif
+
+ for (i = 0; cur_scope_ix < PL_scopestack_ix; i++) {
+  I32 *ixp;
+  I32 offset;
+
+#ifdef SU_HAS_NEW_CXT
+
+  if (   cur_cx_ix <= cxstack_ix
+      && cur_scope_ix == cxstack[cur_cx_ix].blk_oldscopesp
+  )
+   ixp = &(cxstack[cur_cx_ix++].blk_oldsaveix);
+  else
+   ixp = &PL_scopestack[cur_scope_ix++]; /* an ENTER pushed after cur context */
 
- SU_UD_PAD(ud)    = pad;
- SU_UD_DEPTH(ud)  = depth;
- SU_UD_ORIGIN(ud) = origin;
+#else
+
+  XSH_D({
+   if (cur_cx_ix <= cxstack_ix) {
+    if (cur_scope_ix == cxstack[cur_cx_ix].blk_oldscopesp) {
+     su_debug_log(
+       "%p:     cx=%-2d %s\n%p:     ------------------\n",
+       ud, cur_cx_ix, SU_CXNAME(cxstack+cur_cx_ix), ud);
+     cur_cx_ix++;
+    }
+    else if (cur_scope_ix + su_cxt_enter_count[CxTYPE(cxstack+cur_cx_ix)]
+             == cxstack[cur_cx_ix].blk_oldscopesp)
+     su_debug_log("%p:     ------------------\n", ud);
+   }
+  });
+  ixp = &PL_scopestack[cur_scope_ix++];
+
+#endif
+
+  if (i == 0)
+   offset = size;
+  else {
+   /* we have three constraints to satisfy:
+    * 1) Each adjusted offset must be at least SU_SAVE_DESTRUCTOR_SIZE
+    *    above its unadjusted boundary, so that there is space to inject a
+    *    destructor into the outer scope.
+    * 2) Each adjusted boundary must be at least SU_SAVE_DESTRUCTOR_SIZE
+    *    higher than the previous adjusted boundary, so that a new
+    *    destructor can be added below the Nth adjusted frame boundary,
+    *    but be within the (N-1)th adjusted frame and so be triggered on
+    *    the next scope exit;
+    * 3) If the adjustment needs to be greater than SU_SAVE_DESTRUCTOR_SIZE,
+    *    then it should be greater by an amount of at least the minimum
+    *    pad side, so a destructor and padding can be pushed.
+    */
+   I32 pad;
+   offset = SU_SAVE_DESTRUCTOR_SIZE; /* rule 1 */
+   pad = (origin[i-1].orig_ix + origin[i-1].offset) + offset - (*ixp + offset);
+   if (pad > 0) { /* rule 2 */
+    if (pad < SU_SAVE_ALLOC_SIZE + 1) /* rule 3 */
+     pad = SU_SAVE_ALLOC_SIZE + 1;
+    offset += pad;
+   }
+  }
+
+  origin[i].offset = offset;
+  origin[i].orig_ix = *ixp;
+  *ixp += offset;
+
+#ifdef SU_HAS_NEW_CXT
+  XSH_D({
+   if (ixp == &PL_scopestack[cur_scope_ix-1])
+    su_debug_log(
+     "%p:           ENTER       origin[%d] scope[%d] savestack=%d+%d\n",
+      ud, i, cur_scope_ix, origin[i].orig_ix, origin[i].offset);
+   else
+    su_debug_log(
+     "%p:     cx=%-2d %-11s origin[%d] scope[%d] savestack=%d+%d\n",
+      ud, cur_cx_ix-1, SU_CXNAME(cxstack+cur_cx_ix-1),
+      i, cur_scope_ix, origin[i].orig_ix, origin[i].offset);
+  });
+#else
+  XSH_D(su_debug_log(
+    "%p:                 ENTER origin[%d] scope[%d] savestack=%d+%d\n",
+     ud, i, cur_scope_ix, origin[i].orig_ix, origin[i].offset));
+#endif
 
- /* Make sure the first destructor fires by pushing enough fake slots on the
-  * stack. */
- if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
-                                       <= PL_scopestack[PL_scopestack_ix - 1]) {
-  dXSH_CXT;
-  do {
-   XSH_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]);
  }
- XSH_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);
 
- XSH_D({
-  for (i = 0; i <= depth; ++i) {
-   I32 j = PL_scopestack_ix  - 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]);
-  }
- });
+ assert(i == depth);
 
- return depth;
+ SU_UD_DEPTH(ud)  = depth;
+ SU_UD_ORIGIN(ud) = origin;
+
+ su_ss_push_destructor(aTHX_ ud, depth-1, 1);
 }
 
+
 /* --- Unwind stack -------------------------------------------------------- */
 
 static void su_unwind(pTHX_ void *ud_) {
@@ -2273,7 +2427,6 @@ static void xsh_user_global_setup(pTHX) {
 }
 
 static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) {
- cxt->stack_placeholder = NULL;
 
  /* NewOp() calls calloc() which just zeroes the memory with memset(). */
  Zero(&(cxt->unwind_storage.return_op), 1, LISTOP);
-- 
2.4.11

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

0004-fix-unwind.patch
From 42dd866e16359bbc539ecfe9756edd908a1f6ebe Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 16 May 2016 14:52:07 +0100
Subject: [PATCH 4/8] fix unwind()

Perl 5.23.4 debugging builds added asserts to POPMARK etc that nothing
was underflowing etc. At this point 52-unwind-context.t started failing
with

    Perl_pp_return: Assertion `((my_perl->Imarkstack_ptr) >
    (my_perl->Imarkstack)) || !"MARK underflow"' failed.

Properly pushing a new mark for pp_return to pop rather than doing it
manually seems to fix this.
---
 Upper.xs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Upper.xs b/Upper.xs
index 34edf04..f6e678d 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -1361,7 +1361,7 @@ static void su_unwind(pTHX_ void *ud_) {
   dounwind(cxix);
 
  mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
- *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
+ PUSHMARK(PL_stack_sp - items);
 
  XSH_D({
   I32 gimme = GIMME_V;
-- 
2.4.11

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

0005-su_uplevel-populate-lower-stack-frames-properly.patch
From de953f805c6c0164d510777fc1f169938688b28c Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Thu, 19 May 2016 12:03:48 +0100
Subject: [PATCH 5/8] su_uplevel: populate lower stack frames properly

When creating a temporary new argument stack, su_uplevel() copies most of
the old stack to a new one. This isn't really needed, as the new stack
will be abandoned before it ever pops back to that level.  But it *is*
needed when debugging code prints out the stack, as in for example,
'perl -Dstv'.

However, the code didn't actually copy the old stack: it copied garbage
instead, since it was using PL_curstack rather than AvARRAY(PL_curstack)
as the address of of the old stack. Which was causing 'perl -Dstv' to
SEGV.

This commit fixes that.
---
 Upper.xs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Upper.xs b/Upper.xs
index f6e678d..f7698d8 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -1984,7 +1984,7 @@ static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
   * 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 *);
+ Copy(AvARRAY(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 *);
 
-- 
2.4.11

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

0006-fix-uplevel-under-5.23.8.patch
From afc32aa948fbb4e7be9198a44be522f0722d705e Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Tue, 17 May 2016 09:23:00 +0100
Subject: [PATCH 6/8] fix uplevel() under 5.23.8+

The old method of creating a new curstackinfo containing the faked-up
new context stack no longer works. This is because leave_scope() is now
called just prior to each context stack entry popping, and so a destructor
which restores the old context array leaves a dangling pointer.

E.g. pp_leavesub() on 5.23.8 onwards looks something like:

    cx = CX_CUR();
    ....
    CX_LEAVE_SCOPE(cx);

    /* at this point the destructor has been called and the old context
     * stack back been restored; cx now points at freed garbage
    */
    cx_popsub(cx); /* SEGV */

Conversely, now that it's guaranteed that the save stack is always
processed prior to each context pop - regardless of whether its a normal
scope exit or an exception - it allows us to use a simpler method to fake
things up for uplevel(): just temporarily change the types of all the
higher contexts to CXt_NULL so that they won't be seen by caller() etc. On
scope exit the savestack destructor restores the old types, which are then
processed and popped as normal.

As well as setting each entry to CXt_NULL we set a flag,
CXp_SU_UPLEVEL_NULLED (whose bit is currently unused by the perl core)
to indicate that this is a temporarily ignored context.

We then introduce a distinction between logical and physical context stack
indices: functions like UP return a logical index which ignore all the
nulled-out contexts; when such a logical value is passed as an arg to a
function such as localize(), it is first converted back to a real index.

The other main change is how uplevel() doctors the sub's arg list as seen
by caller(): previously this was done by modifying the argarray field of
the context entry for the just-called sub. Since 5.23.8 onwards doesn't
have an argarray field, we instead modify the pad[0] of the running sub
(which is what caller() examines now). Since there's no longer a
possibility of getting argarray and pad[0] out of sync, the special fixups
formerly required in the presence of goto are no longer required.

Rather than rolling our own OP_ENTERSUB op, we just use call_sv()
instead, with a PL_runops pointing to a temporary hook that allows the
args to be fixed up on return from pp_entersub. After that, a normal
runops loop is called.

Since uplevel is so different under 5.23.8, I've split the original
functions into

    su_uplevel_old/su_uplevel_new
    su_uplevel_restore_old/su_uplevel_restore_new

with #defines compiling only one set.
---
 Upper.xs | 284 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 264 insertions(+), 20 deletions(-)

diff --git a/Upper.xs b/Upper.xs
index f7698d8..2ce8527 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -211,9 +211,6 @@ static U8 su_op_gimme_reverse(U8 gimme) {
     ((AV*)(AvARRAY(MUTABLE_AV(                     \
         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[   \
             CvDEPTH(cx->blk_sub.cv)]))[0]))
-/* XXX is the new def ok to use in lvalue cxt? Formerly it assigned to
- * blk_sub.argarray, now to pad[0]. Does this matter?
- */
 # define CX_ARGARRAY_set(cx,ary) \
     (AvARRAY(MUTABLE_AV(                     \
         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[   \
@@ -374,27 +371,39 @@ typedef struct {
 
  I32            cxix;
 
- I32            target_depth;
- CV            *target;
-
  CV            *callback;
  CV            *renamed;
 
+#ifdef SU_HAS_NEW_CXT
+ U8            *cxtypes; /* array of saved context types */
+ I32           gap;      /* how many contexts have temporarily CXt_NULLed out */
+ AV*           argarray; /* the PL_curpad[0] of the uplevel sub */
+#else
+ I32            target_depth;
+ CV            *target;
  PERL_SI       *si;
  PERL_SI       *old_curstackinfo;
  AV            *old_mainstack;
+ OP            *old_op;
+ bool           old_catch;
+ bool           died;
+#endif
 
  COP           *old_curcop;
 
- OP            *old_op;
 #if SU_UPLEVEL_HIJACKS_RUNOPS
  runops_proc_t  old_runops;
 #endif
- bool           old_catch;
-
- bool           died;
 } su_uplevel_ud;
 
+#ifdef SU_HAS_NEW_CXT
+/* used to flag a context stack entry whose type has been temporarily
+ * set to CXt_NULL. It relies on perl not using this value for real
+ * CXt_NULL entries.
+ */
+# define CXp_SU_UPLEVEL_NULLED 0x20
+#endif
+
 static su_uplevel_ud *su_uplevel_ud_new(pTHX) {
 #define su_uplevel_ud_new() su_uplevel_ud_new(aTHX)
  su_uplevel_ud *sud;
@@ -407,6 +416,7 @@ static su_uplevel_ud *su_uplevel_ud_new(pTHX) {
  sud->tmp_uid_storage.used  = 0;
  sud->tmp_uid_storage.alloc = 0;
 
+ #ifndef SU_HAS_NEW_CXT
  Newx(si, 1, PERL_SI);
  si->si_stack   = newAV();
  AvREAL_off(si->si_stack);
@@ -414,17 +424,21 @@ static su_uplevel_ud *su_uplevel_ud_new(pTHX) {
  si->si_cxmax   = -1;
 
  sud->si = si;
+#endif
 
  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))
+
+#ifndef SU_HAS_NEW_CXT
  PERL_SI *si = sud->si;
 
  Safefree(si->si_cxstack);
  SvREFCNT_dec(si->si_stack);
  Safefree(si);
+#endif
 
  Safefree(sud->tmp_uid_storage.map);
 
@@ -462,7 +476,6 @@ static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *
  new_cxt->uplevel_storage.top   = NULL;
  new_cxt->uplevel_storage.root  = NULL;
  new_cxt->uplevel_storage.count = 0;
-
  new_cxt->uid_storage.map   = NULL;
  new_cxt->uid_storage.used  = 0;
  new_cxt->uid_storage.alloc = 0;
@@ -997,7 +1010,7 @@ static void su_uid_drop(pTHX_ void *ud_) {
 /* --- Pop a context back -------------------------------------------------- */
 
 #ifdef DEBUGGING
-# define SU_CXNAME(C) PL_block_type[CxTYPE(C)]
+# define SU_CX_TYPENAME(T) PL_block_type[(T)]
 #else
 # if XSH_HAS_PERL(5, 23, 8)
 static const char *su_block_type[] = {
@@ -1053,9 +1066,11 @@ static const char *su_block_type[] = {
  "FORMAT"
 };
 # endif
-# define SU_CXNAME(C) su_block_type[CxTYPE(C)]
+# define SU_CX_TYPENAME(T) su_block_type[(T)]
 #endif
 
+#define SU_CXNAME(C) SU_CX_TYPENAME(CxTYPE(C))
+
 /* for debugging. These indicate how many ENTERs each context type
  * does before the PUSHBLOCK */
 
@@ -1655,7 +1670,7 @@ static int su_uplevel_goto_static(const OP *o) {
  return 0;
 }
 
-#if SU_UPLEVEL_HIJACKS_RUNOPS
+#if !defined(SU_HAS_NEW_CXT) && SU_UPLEVEL_HIJACKS_RUNOPS
 
 static int su_uplevel_goto_runops(pTHX) {
 #define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX)
@@ -1717,7 +1732,53 @@ done:
 
 #define su_at_underscore(C) PadARRAY(PadlistARRAY(CvPADLIST(C))[CvDEPTH(C)])[0]
 
-static void su_uplevel_restore(pTHX_ void *sus_) {
+#ifdef SU_HAS_NEW_CXT
+
+static void su_uplevel_restore_new(pTHX_ void *sus_) {
+ su_uplevel_ud *sud = sus_;
+ PERL_CONTEXT *cx;
+ I32 i;
+ U8 *saved_cxtypes = sud->cxtypes;
+
+ for (i = 0; i < sud->gap; i++) {
+  PERL_CONTEXT *cx = cxstack + sud->cxix + i;
+   XSH_D(su_debug_log("su_uplevel_restore: i=%d cxix=%d type %s => %s\n",
+        i, cx-cxstack, SU_CX_TYPENAME(CxTYPE(cx)),
+        SU_CX_TYPENAME(saved_cxtypes[i] & CXTYPEMASK)));
+   cx->cx_type = saved_cxtypes[i];
+ }
+ Safefree(saved_cxtypes);
+
+ /* renamed is a copy of callback, but they share the same CvPADLIST.
+  * At this point any calls to renamed should have exited so that its
+  * depth is back to that of of callback. At this point its safe to free
+  * renamed, then undo the extra ref count that was ensuring that callback
+  * remains alive
+  */
+ assert(sud->renamed);
+ assert(sud->callback);
+
+ CvDEPTH(sud->callback)--;
+ assert(CvDEPTH(sud->callback) == CvDEPTH(sud->renamed));
+ if (!CvISXSUB(sud->renamed)) {
+  CvDEPTH(sud->renamed)   = 0;
+  CvPADLIST(sud->renamed) = NULL;
+ }
+ SvREFCNT_dec(sud->renamed);
+ SvREFCNT_dec(sud->callback);
+
+ SU_UPLEVEL_RESTORE(curcop);
+
+ su_uplevel_storage_delete(sud);
+
+ return;
+}
+
+#else
+
+/* 5.23.7 and earlier */
+
+static void su_uplevel_restore_old(pTHX_ void *sus_) {
  su_uplevel_ud *sud = sus_;
  PERL_SI *cur = sud->old_curstackinfo;
  PERL_SI *si  = sud->si;
@@ -1879,6 +1940,8 @@ found_it:
  return;
 }
 
+#endif
+
 static CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
 #define su_cv_clone(P, G) su_cv_clone(aTHX_ (P), (G))
  dVAR;
@@ -1940,8 +2003,124 @@ static CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
  return cv;
 }
 
-static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
-#define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
+
+
+#ifdef SU_HAS_NEW_CXT
+
+/* this one-shot runops "loop" is designed to be called just before
+ * execution of the first op following an uplevel()'s entersub. It gets a
+ * chance to fix up the args as seen by caller(), before immediately
+ * falling through to the previous runops loop. Note that pp_entersub is
+ * called directly by call_sv() rather than being called from a runops
+ * loop.
+ */
+
+static int su_uplevel_runops_hook_entersub(pTHX) {
+ OP *op = PL_op;
+ dXSH_CXT;
+ su_uplevel_ud *sud = XSH_CXT.uplevel_storage.top;
+
+ /* Create a new array containing a copy of the original sub's call args,
+  * then stick it in PL_curpad[0] of the current running sub so that
+  * thay will be seen by caller().
+  */
+ assert(sud);
+ if (sud->argarray) {
+  AV *av = newAV();
+  AvREAL_off(av);
+  AvREIFY_on(av);
+  av_extend(av, AvMAX(sud->argarray));
+  AvFILLp(av) = AvFILLp(sud->argarray);
+  Copy(AvARRAY(sud->argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
+
+  /* should be referenced by PL_curpad[0] and *_ */
+  assert(SvREFCNT(PL_curpad[0]) > 1);
+  SvREFCNT_dec(PL_curpad[0]);
+
+  PL_curpad[0] = (SV*)av;
+ }
+
+ /* undo the temporary runops hook and fall through to a real runops loop. */
+ assert(sud->old_runops != su_uplevel_runops_hook_entersub);
+ PL_runops = sud->old_runops;
+ CALLRUNOPS(aTHX);
+ return 0;
+}
+
+
+
+static I32 su_uplevel_new(pTHX_ CV *callback, I32 cxix, I32 args) {
+ su_uplevel_ud *sud;
+ U8 *saved_cxtypes;
+ I32 i, ret;
+ I32  gimme;
+ CV *base_cv = cxstack[cxix].blk_sub.cv;
+ dSP;
+
+ assert(CxTYPE(&cxstack[cxix]) == CXt_SUB);
+
+ ENTER;
+
+ gimme = GIMME_V;
+
+ /* At this point SP points to the top arg.
+  * Shuffle the args down by one, eliminating the CV slot */
+ Move(SP - args + 1, SP - args, args, SV*);
+ SP--;
+ PUSHMARK(SP - args);
+ PUTBACK;
+
+ sud = su_uplevel_storage_new(cxix);
+
+ sud->cxix     = cxix;
+ sud->callback = (CV*)SvREFCNT_inc_simple(callback);
+ sud->renamed  = NULL;
+ sud->gap      = cxstack_ix - cxix + 1;
+ sud->argarray = NULL;
+
+
+ Newx(saved_cxtypes, sud->gap, U8);
+ sud->cxtypes = saved_cxtypes;
+
+ SAVEDESTRUCTOR_X(su_uplevel_restore_new, sud);
+ SU_UPLEVEL_SAVE(curcop, cxstack[cxix].blk_oldcop);
+
+/* temporarily change the type of any contexts to NULL, so they're
+ * invisible to caller() etc. */
+ for (i = 0; i < sud->gap; i++) {
+  PERL_CONTEXT *cx = cxstack + cxix + i;
+  saved_cxtypes[i] = cx->cx_type; /* save type and flags */
+  XSH_D(su_debug_log("su_uplevel: i=%d cxix=%d type %-11s => %s\n",
+        i, cx-cxstack, SU_CX_TYPENAME(CxTYPE(cx)), SU_CX_TYPENAME(CXt_NULL)));
+  cx->cx_type = (CXt_NULL | CXp_SU_UPLEVEL_NULLED);
+ }
+
+ /* create a copy of the callback with a doctored name (as seen by
+  * caller). It shares the padlist with callback */
+ sud->renamed = su_cv_clone(callback, CvGV(base_cv));
+ sud->old_runops = PL_runops;
+
+
+ if (!CvISXSUB(sud->renamed) && CxHASARGS(&cxstack[cxix])) {
+  sud->argarray = (AV*)su_at_underscore(base_cv);
+  assert(PL_runops != su_uplevel_runops_hook_entersub);
+  /* set up a one-shot runops hook so that we can fake up the
+   * args as seen by caller() on return from pp_entersub */
+  PL_runops = su_uplevel_runops_hook_entersub;
+ }
+
+ CvDEPTH(callback)++; /* match what CvDEPTH(sud->renamed) is about to become */
+
+ ret = call_sv((SV*)sud->renamed, gimme);
+
+ LEAVE;
+
+ return ret;
+}
+
+#else
+
+static I32 su_uplevel_old(pTHX_ CV *callback, I32 cxix, I32 args) {
  su_uplevel_ud *sud;
  const PERL_CONTEXT *cx = cxstack + cxix;
  PERL_SI *si;
@@ -1969,7 +2148,7 @@ static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
  sud->died     = 1;
  sud->callback = NULL;
  sud->renamed  = NULL;
- SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
+ SAVEDESTRUCTOR_X(su_uplevel_restore_old, sud);
 
  si = sud->si;
 
@@ -2120,6 +2299,8 @@ static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
  return ret;
 }
 
+#endif
+
 /* --- Unique context ID --------------------------------------------------- */
 
 static su_uid *su_uid_storage_fetch(pTHX_ UV depth) {
@@ -2286,6 +2467,57 @@ static I32 su_context_skip_db(pTHX_ I32 cxix) {
 }
 
 
+#ifdef SU_HAS_NEW_CXT
+
+/* convert a physical context stack index into the logical equivalent:
+ * one that ignores all the context frames hidden by uplevel().
+ * Perl-level functions use logical args (e.g. UP takes an optional logical
+ * value and returns a logical value), while we use and store *real*
+ * values internally.
+ */
+
+static I32 su_context_real2logical(pTHX_ I32 cxix) {
+# define su_context_real2logical(C) su_context_real2logical(aTHX_ (C))
+ PERL_CONTEXT *cx;
+ I32 i, gaps = 0;
+
+ for (i = 0; i <= cxix; i++) {
+  cx = cxstack + i;
+  if (cx->cx_type == (CXt_NULL | CXp_SU_UPLEVEL_NULLED))
+   gaps++;
+ }
+ XSH_D(su_debug_log("su_context_real2logical: %d => %d\n", cxix, cxix - gaps));
+ return cxix - gaps;
+}
+
+/* convert a logical context stack index (one that ignores all the context
+ * frames hidden by uplevel) into the physical equivalent
+ */
+
+static I32 su_context_logical2real(pTHX_ I32 cxix) {
+# define su_context_logical2real(C) su_context_logical2real(aTHX_ (C))
+ PERL_CONTEXT *cx;
+ I32 i, seen = -1;
+
+ for (i = 0; i <= cxstack_ix; i++) {
+  PERL_CONTEXT *cx = cxstack + i;
+  if (cx->cx_type != (CXt_NULL | CXp_SU_UPLEVEL_NULLED))
+   seen++;
+  if (seen >= cxix)
+   break;
+ }
+ XSH_D(su_debug_log("su_context_logical2real: %d => %d\n", cxix, i));
+ if (i > cxstack_ix)
+  i = cxstack_ix;
+ return i;
+}
+
+#else
+# define su_context_real2logical(C) (C)
+# define su_context_logical2real(C) (C)
+#endif
+
+
 static I32 su_context_normalize_up(pTHX_ I32 cxix) {
 #define su_context_normalize_up(C) su_context_normalize_up(aTHX_ (C))
  PERL_CONTEXT *cx;
@@ -2487,6 +2719,8 @@ static void xsh_user_global_teardown(pTHX) {
 
 /* --- XS ------------------------------------------------------------------ */
 
+/* D is real; B is logical. Returns real. */
+
 #define SU_GET_CONTEXT(A, B, D) \
  STMT_START {                   \
   if (items > A) {              \
@@ -2498,6 +2732,7 @@ static void xsh_user_global_teardown(pTHX) {
     cxix = 0;                   \
    else if (cxix > cxstack_ix)  \
     goto default_cx;            \
+   cxix = su_context_logical2real(cxix); \
   } else {                      \
 default_cx:                     \
    cxix = (D);                  \
@@ -2646,7 +2881,7 @@ PROTOTYPE:
 PREINIT:
  I32 cxix;
 PPCODE:
- cxix = su_context_here();
+ cxix = su_context_real2logical(su_context_here());
  EXTEND(SP, 1);
  mPUSHi(cxix);
  XSRETURN(1);
@@ -2662,6 +2897,7 @@ PPCODE:
   --cxix;
   cxix = su_context_skip_db(cxix);
   cxix = su_context_normalize_up(cxix);
+  cxix = su_context_real2logical(cxix);
  } else {
   warn(su_stack_smash);
  }
@@ -2685,6 +2921,7 @@ PPCODE:
    case CXt_SUB:
     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
      continue;
+    cxix = su_context_real2logical(cxix);
     mPUSHi(cxix);
     XSRETURN(1);
   }
@@ -2706,6 +2943,7 @@ PPCODE:
    default:
     continue;
    case CXt_EVAL:
+    cxix = su_context_real2logical(cxix);
     mPUSHi(cxix);
     XSRETURN(1);
   }
@@ -2729,6 +2967,7 @@ PPCODE:
   --cxix;
   cxix = su_context_skip_db(cxix);
   cxix = su_context_normalize_up(cxix);
+  cxix = su_context_real2logical(cxix);
  }
  EXTEND(SP, 1);
  mPUSHi(cxix);
@@ -2758,6 +2997,7 @@ done:
  if (level >= 0)
   warn(su_stack_smash);
  EXTEND(SP, 1);
+ cxix = su_context_real2logical(cxix);
  mPUSHi(cxix);
  XSRETURN(1);
 
@@ -3040,7 +3280,11 @@ PPCODE:
      args = items - 2;
     }
     /* su_uplevel() takes care of extending the stack if needed. */
-    ret = su_uplevel((CV *) code, cxix, args);
+#ifdef SU_HAS_NEW_CXT
+    ret = su_uplevel_new(aTHX_ (CV *) code, cxix, args);
+#else
+    ret = su_uplevel_old(aTHX_ (CV *) code, cxix, args);
+#endif
     XSRETURN(ret);
    default:
     break;
-- 
2.4.11

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

0007-eliminate-CX_ARGARRAY-and-CX_ARGARRAY_set.patch
From ab40044ad16cbb46d4c12c684ed1c116dd5770d7 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Sun, 29 May 2016 22:06:38 +0100
Subject: [PATCH 7/8] eliminate CX_ARGARRAY() and CX_ARGARRAY_set()

I added these earlier as a way of compiling the code under both 5.23.7 and
5.23.8, since the latter no longer has the argarray field in the context
struct. I didn't know at the time whether they were logically correct
under 5.23.8 - I just wanted the code to compile.

Having now properly fixed uplevel() to work on 5.23.8, and since uplevel
under 5.23.8 uses an entirely separate code path, only 5.23.7 and earlier
make use of CX_ARGARRAY() and _set(), so eliminate these macros and
revert back to the original usage (i.e. cx->blk_sub.argarray).
---
 Upper.xs | 30 ++++++------------------------
 1 file changed, 6 insertions(+), 24 deletions(-)

diff --git a/Upper.xs b/Upper.xs
index 2ce8527..2d7efd3 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -203,24 +203,6 @@ static U8 su_op_gimme_reverse(U8 gimme) {
 # define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
 #endif
 
-/* CX_ARGARRAY(cx): the AV at pad[0] of the CV associated with CXt_SUB
- * context cx */
-
-#if XSH_HAS_PERL(5, 23, 8)
-# define CX_ARGARRAY(cx) \
-    ((AV*)(AvARRAY(MUTABLE_AV(                     \
-        PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[   \
-            CvDEPTH(cx->blk_sub.cv)]))[0]))
-# define CX_ARGARRAY_set(cx,ary) \
-    (AvARRAY(MUTABLE_AV(                     \
-        PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[   \
-            CvDEPTH(cx->blk_sub.cv)]))[0] = (SV*)(ary))
-#else
-# define CX_ARGARRAY(cx)         (cx->blk_sub.argarray)
-# define CX_ARGARRAY_set(cx,ary) (cx->blk_sub.argarray = (ary))
-#endif
-
-
 /* --- Error messages ------------------------------------------------------ */
 
 static const char su_stack_smash[]    = "Cannot target a scope outside of the current stack";
@@ -1689,7 +1671,7 @@ static int su_uplevel_goto_runops(pTHX) {
     switch (CxTYPE(cx)) {
      case CXt_SUB:
       if (CxHASARGS(cx)) {
-       argarray = CX_ARGARRAY(cx);
+       argarray = cx->blk_sub.argarray;
        goto done;
       }
       break;
@@ -1810,8 +1792,8 @@ static void su_uplevel_restore_old(pTHX_ void *sus_) {
    * reached without a goto() happening, and the old argarray member is
    * actually our fake argarray. Destroy it properly in that case. */
   if (cx->blk_sub.cv == sud->renamed) {
-   SvREFCNT_dec(CX_ARGARRAY(cx));
-   CX_ARGARRAY_set(cx, argarray);
+   SvREFCNT_dec(cx->blk_sub.argarray);
+   cx->blk_sub.argarray = argarray;
   }
 
   CvDEPTH(sud->callback)--;
@@ -2233,7 +2215,7 @@ static I32 su_uplevel_old(pTHX_ CV *callback, I32 cxix, I32 args) {
 
  if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
   PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
-  AV *argarray = CX_ARGARRAY(cx);
+  AV *argarray = cx->blk_sub.argarray;
 
   /* If pp_entersub() returns a non-null OP, it means that the callback is not
    * an XSUB. */
@@ -2253,9 +2235,9 @@ static I32 su_uplevel_old(pTHX_ CV *callback, I32 cxix, I32 args) {
    av_extend(av, AvMAX(argarray));
    AvFILLp(av) = AvFILLp(argarray);
    Copy(AvARRAY(argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
-   CX_ARGARRAY_set(sub_cx, av);
+   sub_cx->blk_sub.argarray = av;
   } else {
-   SvREFCNT_inc_simple_void(CX_ARGARRAY(sub_cx));
+   SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
   }
 
   if (su_uplevel_goto_static(CvROOT(renamed))) {
-- 
2.4.11

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @iabyn

0008-fixup-t-13-reap-ctl.t-for-5.23.8.patch
From d88bc67a25773d96dec08d158f233a2f4f910a29 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Sun, 29 May 2016 22:20:40 +0100
Subject: [PATCH 8/8] fixup t/13-reap-ctl.t for 5.23.8

One test in this script failed under 5.23.8 due to a change in the way
the die while leaving an eval scope is now handled.

Consider the following code, where leaving an eval scope triggers a call
to STORE to unlocalise a tied scalar, and where STORE raises an exception:

    sub TIESCALAR { bless [] }
    sub FETCH { 1;  }
    sub STORE { die "died in store\n" if $_[1]  }

    tie $s, 'main';
    eval {
        local $s;
    };
    warn "caught: [$@]\n";

5.23.7 and earlier die, while 5.23.8 output:

    caught: [died in store
    ]

Similarly, one would expect the behaviour of "reap HERE" to change
in 5.23.8, with an exception raised in the reap handler to now be caught
be the innermost eval.

So fix up the test to reflect this new reality.
---
 t/13-reap-ctl.t | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/t/13-reap-ctl.t b/t/13-reap-ctl.t
index e4e47b5..085cc05 100644
--- a/t/13-reap-ctl.t
+++ b/t/13-reap-ctl.t
@@ -302,10 +302,12 @@ $y = undef;
    reap { ++$y; die "reaped\n" } => HERE;
    is $x, 3,     'die in reap at eval [not yet - x]';
    is $y, undef, 'die in reap at eval [not yet - y]';
-  }; # should trigger here, but the die isn't catched by this eval
-  die "failed\n";
+  }; # should trigger here, but the die isn't catched by this eval in
+     # ealier perls
+  die "inner\n";
  };
- is $@, "reaped\n", 'die in reap at eval [ok - $@]';
+ is $@, ($] >= 5.023008 ? "inner\n" : "reaped\n"),
+        'die in reap at eval [ok - $@]';
  is $x, 1, 'die in reap at eval [ok - x]';
  is $y, 1, 'die in reap at eval [ok - y]';
 }
-- 
2.4.11

@p5pRT
Copy link
Author

p5pRT commented May 29, 2016

From @kentfredric

On 30 May 2016 at 09​:53, Dave Mitchell <davem@​iabyn.com> wrote​:

The attached series of 8 patches makes Scope​::Upper pass all tests on
5.24.0, as well as all major perls back to 5.10.1. (I didn't test
on 5.6.x and 5.8.x as these require Test​::More to be installed).

+++ :)

I've thrown together your patches and thrown a tar.gz here for anyone
who wants to do testing​:

http​://kentfredric.github.io/cpan-fixes/perl-5.24.0/Scope-Upper/Scope-Upper-0.28_01.tar.gz

--
Kent

KENTNL - https://metacpan.org/author/KENTNL

@p5pRT
Copy link
Author

p5pRT commented May 30, 2016

From @xsawyerx

On 05/29/2016 11​:53 PM, Dave Mitchell wrote​:

On Mon, Apr 18, 2016 at 09​:44​:35AM -0300, Vincent Pit (VPIT) wrote​:

Le 18/04/2016 09​:29, Ricardo Signes a écrit :

* Dave Mitchell <davem@​iabyn.com> [2016-04-18T06​:10​:56]

I've spent the last week doing more work on Scope​::Upper.
Thanks for looking into this, Dave. I agree with your remarks on the question
of requiredness of this sort of work, but I'm also glad that it may continue to
work. Although I don't plan to block on Scope​::Upper, it is a useful tool.

(Leon T. was also talking about writing a subset of its functionality that was
easier to keep working, which is what more of Scope​::Upper's downstream
dependents use.)

The dependants seem to use all the features provided by Scope​::Upper, so I
don't really understand what subset would be "easier to keep working".
Unless all dependents are not treated equal, of course.

The attached series of 8 patches makes Scope​::Upper pass all tests on
5.24.0, as well as all major perls back to 5.10.1. (I didn't test
on 5.6.x and 5.8.x as these require Test​::More to be installed).

Dave, thank you so much for working on this! I *really* appreciate it. :)

I'll test it out using Kent's tarball against Dancer2.
(It uses Return​::MultiLevel extensively, which uses Scope​::Upper as the
underlying implementation, if available.)

@p5pRT
Copy link
Author

p5pRT commented May 30, 2016

From @Leont

On Sun, May 29, 2016 at 11​:53 PM, Dave Mitchell <davem@​iabyn.com> wrote​:

The attached series of 8 patches makes Scope​::Upper pass all tests on
5.24.0, as well as all major perls back to 5.10.1. (I didn't test
on 5.6.x and 5.8.x as these require Test​::More to be installed).

Excellent!

Leon

@p5pRT
Copy link
Author

p5pRT commented Jun 5, 2016

From perl@profvince.com

Le 29/05/2016 à 23​:53, Dave Mitchell a écrit :

On Mon, Apr 18, 2016 at 09​:44​:35AM -0300, Vincent Pit (VPIT) wrote​:

Le 18/04/2016 09​:29, Ricardo Signes a écrit :

* Dave Mitchell <davem@​iabyn.com> [2016-04-18T06​:10​:56]

I've spent the last week doing more work on Scope​::Upper.

Thanks for looking into this, Dave. I agree with your remarks on the question
of requiredness of this sort of work, but I'm also glad that it may continue to
work. Although I don't plan to block on Scope​::Upper, it is a useful tool.

(Leon T. was also talking about writing a subset of its functionality that was
easier to keep working, which is what more of Scope​::Upper's downstream
dependents use.)

The dependants seem to use all the features provided by Scope​::Upper, so I
don't really understand what subset would be "easier to keep working".
Unless all dependents are not treated equal, of course.

The attached series of 8 patches makes Scope​::Upper pass all tests on
5.24.0, as well as all major perls back to 5.10.1. (I didn't test
on 5.6.x and 5.8.x as these require Test​::More to be installed).

Thanks a lot for your hard work, Dave. I hope that the code base was not
too unpleasant to work on.

I just have a small question regarding commit ded730eb9 ("get
su_init/su_pop working under 5.23.8"). In su_localize, you added this
snippet :

=======================================================================

+
+/* new perl context implementation frees savestack *before* restoring
+ * PL_curcop. Temporarily restore it prematurely to make gv_fetch*
+ * looks up unqualified var names in the caller's package */
+#ifdef SU_HAS_NEW_CXT
+ COP *old_cop = PL_curcop;
+ PL_curcop = CX_CUR()->blk_oldcop;
+#endif
+
  #ifdef gv_fetchsv
  gv = gv_fetchsv(sv, GV_ADDMULTI, t);
  #else
@​@​ -896,13 +926,16 @​@​ static void su_localize(pTHX_ void *ud_) {
  const char *name = SvPV_const(sv, len);
  gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
  #endif
+#ifdef SU_HAS_NEW_CXT
+ CX_CUR()->blk_oldcop = PL_curcop;
+#endif

=======================================================================

but as far as I can tell this old_cop variable is never used. Since the
tests pass with this change, does it mean that it can be removed?

Vincent

@p5pRT
Copy link
Author

p5pRT commented Jun 5, 2016

From @iabyn

On Sun, Jun 05, 2016 at 08​:39​:20PM +0200, Vincent Pit (VPIT) wrote​:

I just have a small question regarding commit ded730eb9 ("get su_init/su_pop
working under 5.23.8"). In su_localize, you added this snippet :

=======================================================================

+
+/* new perl context implementation frees savestack *before* restoring
+ * PL_curcop. Temporarily restore it prematurely to make gv_fetch*
+ * looks up unqualified var names in the caller's package */
+#ifdef SU_HAS_NEW_CXT
+ COP *old_cop = PL_curcop;
+ PL_curcop = CX_CUR()->blk_oldcop;
+#endif
+
#ifdef gv_fetchsv
gv = gv_fetchsv(sv, GV_ADDMULTI, t);
#else
@​@​ -896,13 +926,16 @​@​ static void su_localize(pTHX_ void *ud_) {
const char *name = SvPV_const(sv, len);
gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
#endif
+#ifdef SU_HAS_NEW_CXT
+ CX_CUR()->blk_oldcop = PL_curcop;
+#endif

=======================================================================

but as far as I can tell this old_cop variable is never used. Since the
tests pass with this change, does it mean that it can be removed?

Hmmm... the second chunk of that diff was *supposed* to be

  PL_curcop = old_cop;

which would make it logically correct, although I *think* that in
practice, since su_pop() frees all items in the current savestack frame
below itself before calling su_localize(), so su_localize() is effectively
always called after all the other savestack items have been processed, its
hard to think of test case where it matters. I'd recommend still changing
it to PL_curcop = old_cop rather than removing it though.

--
A major Starfleet emergency breaks out near the Enterprise, but
fortunately some other ships in the area are able to deal with it to
everyone's satisfaction.
  -- Things That Never Happen in "Star Trek" #13

@p5pRT
Copy link
Author

p5pRT commented Jul 18, 2016

@iabyn - Status changed from 'open' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant