In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/67351791393b2c43b52afa23fc853d19c47a3da3?hp=75e935adf0585621c7dfb464674056f199c35824>
- Log ----------------------------------------------------------------- commit 67351791393b2c43b52afa23fc853d19c47a3da3 Merge: 75e935adf0 843fe1cac3 Author: David Mitchell <[email protected]> Date: Mon Sep 23 14:21:32 2019 +0100 [MERGE] fixup add+use si_cxsubix field Re-apply merged branch that was temporarily reverted, and add a fix which fixes the breakage which triggered the revert. commit 843fe1cac3dd0142b6beb4102c4616fff1a0ac38 Author: David Mitchell <[email protected]> Date: Mon Sep 23 14:02:49 2019 +0100 si_cxsubix not restored on goto &XS_sub My recent merge commit v5.31.3-198-gd2cd363728 (temporarily reverted by v5.31.4-0-g20ef288c53) added a si_cxsubix field to the stackinfo struct to track the most recent sub context. This field wasn't being restored correctly with 'goto &XS-sub', and broke Test::Deep. commit 5b6f744373565ad7bd6bbd484c9e09bc90a0125e Author: David Mitchell <[email protected]> Date: Sat Sep 21 13:23:16 2019 +0100 Un-revert "[MERGE] add+use si_cxsubix field" original merge commit: v5.31.3-198-gd2cd363728 reverted by: v5.31.4-0-g20ef288c53 The commit following this commit fixes the breakage, which that means the revert can be undone. ----------------------------------------------------------------------- Summary of changes: cop.h | 5 +++++ embed.fnc | 1 + embed.h | 1 + ext/B/t/optree_concise.t | 12 ++++++------ ext/B/t/optree_constants.t | 8 ++++---- ext/B/t/optree_misc.t | 4 ++-- ext/B/t/optree_samples.t | 8 ++++---- ext/B/t/optree_sort.t | 16 ++++++++-------- ext/B/t/optree_varinit.t | 40 ++++++++++++++++++++-------------------- ext/Devel-Peek/t/Peek.t | 2 +- inline.h | 26 ++++++++++++++++++++++++++ op.c | 3 ++- op.h | 2 +- pod/perldelta.pod | 6 +++++- pp_ctl.c | 22 ++++++++++++++++------ proto.h | 4 ++++ scope.c | 1 + sv.c | 1 + t/op/goto.t | 19 ++++++++++++++++++- t/perf/benchmarks | 6 ++++++ 20 files changed, 132 insertions(+), 55 deletions(-) diff --git a/cop.h b/cop.h index 00396f04a4..f9bf85222d 100644 --- a/cop.h +++ b/cop.h @@ -585,6 +585,7 @@ C<*len>. Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0. /* subroutine context */ struct block_sub { OP * retop; /* op to execute on exit from sub */ + I32 old_cxsubix; /* previous value of si_cxsubix */ /* Above here is the same for sub, format and eval. */ PAD *prevcomppad; /* the caller's PL_comppad */ CV * cv; @@ -597,6 +598,7 @@ struct block_sub { /* format context */ struct block_format { OP * retop; /* op to execute on exit from sub */ + I32 old_cxsubix; /* previous value of si_cxsubix */ /* Above here is the same for sub, format and eval. */ PAD *prevcomppad; /* the caller's PL_comppad */ CV * cv; @@ -663,6 +665,7 @@ struct block_format { /* eval context */ struct block_eval { OP * retop; /* op to execute on exit from eval */ + I32 old_cxsubix; /* previous value of si_cxsubix */ /* Above here is the same for sub, format and eval. */ SV * old_namesv; OP * old_eval_root; @@ -1026,6 +1029,7 @@ struct stackinfo { struct stackinfo * si_next; I32 si_cxix; /* current context index */ I32 si_cxmax; /* maximum allocated index */ + I32 si_cxsubix; /* topmost sub/eval/format */ I32 si_type; /* type of runlevel */ I32 si_markoff; /* offset where markstack begins for us. * currently used only with DEBUGGING, @@ -1072,6 +1076,7 @@ typedef struct stackinfo PERL_SI; } \ next->si_type = type; \ next->si_cxix = -1; \ + next->si_cxsubix = -1; \ PUSHSTACK_INIT_HWM(next); \ AvFILLp(next->si_stack) = 0; \ SWITCHSTACK(PL_curstack,next->si_stack); \ diff --git a/embed.fnc b/embed.fnc index a3e5fb2596..8c346c5eab 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3517,6 +3517,7 @@ Apx |void |leave_adjust_stacks|NN SV **from_sp|NN SV **to_sp \ |U8 gimme|int filter #ifndef PERL_NO_INLINE_FUNCTIONS +Aixp |U8 |gimme_V | Aixp |PERL_CONTEXT * |cx_pushblock|U8 type|U8 gimme|NN SV** sp|I32 saveix Aixp |void |cx_popblock|NN PERL_CONTEXT *cx Aixp |void |cx_topblock|NN PERL_CONTEXT *cx diff --git a/embed.h b/embed.h index f1c3f57aa2..53dd870983 100644 --- a/embed.h +++ b/embed.h @@ -979,6 +979,7 @@ #define cx_pushsub(a,b,c,d) Perl_cx_pushsub(aTHX_ a,b,c,d) #define cx_pushwhen(a) Perl_cx_pushwhen(aTHX_ a) #define cx_topblock(a) Perl_cx_topblock(aTHX_ a) +#define gimme_V() Perl_gimme_V(aTHX) #endif #if defined(DEBUGGING) #define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b) diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t index 1e2594703f..86280ac488 100644 --- a/ext/B/t/optree_concise.t +++ b/ext/B/t/optree_concise.t @@ -217,7 +217,7 @@ checkOptree ( name => 'cmdline invoke -basic works', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 7 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 6 <@> sort vK ->7 # 3 <0> pushmark s ->4 @@ -225,7 +225,7 @@ checkOptree ( name => 'cmdline invoke -basic works', # 4 <#> gv[*a] s ->5 EOT_EOT # 7 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 6 <@> sort vK ->7 # 3 <0> pushmark s ->4 @@ -241,7 +241,7 @@ checkOptree ( name => 'cmdline invoke -exec works', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -1 <0> enter +1 <0> enter v 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 3 <0> pushmark s 4 <#> gv[*a] s @@ -249,7 +249,7 @@ checkOptree ( name => 'cmdline invoke -exec works', 6 <@> sort vK 7 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> gv(*a) s @@ -290,7 +290,7 @@ checkOptree errs => ['Useless use of sort in void context at -e line 1.'], strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <#> gv[*a] s @@ -298,7 +298,7 @@ checkOptree # 6 <@> sort vK # 7 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> gv(*a) s diff --git a/ext/B/t/optree_constants.t b/ext/B/t/optree_constants.t index a8073164db..43afacc570 100644 --- a/ext/B/t/optree_constants.t +++ b/ext/B/t/optree_constants.t @@ -152,14 +152,14 @@ checkOptree ( name => 'myyes() as coderef', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 6 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3 # 5 <@> print vK ->6 # 3 <0> pushmark s ->4 # 4 <$> const[SPECIAL sv_yes] s*/FOLD ->5 EOT_EOT # 6 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3 # 5 <@> print vK ->6 # 3 <0> pushmark s ->4 @@ -176,14 +176,14 @@ checkOptree ( name => 'myno() as coderef', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 6 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3 # 5 <@> print vK ->6 # 3 <0> pushmark s ->4 # 4 <$> const[SPECIAL sv_no] s*/FOLD ->5 EOT_EOT # 6 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3 # 5 <@> print vK ->6 # 3 <0> pushmark s ->4 diff --git a/ext/B/t/optree_misc.t b/ext/B/t/optree_misc.t index f8ff3ce968..490abb33d4 100644 --- a/ext/B/t/optree_misc.t +++ b/ext/B/t/optree_misc.t @@ -89,7 +89,7 @@ EONT_EONT my $t = <<'EOT_EOT'; # 8 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 7 <2> sassign vKS/2 ->8 # 5 <@> index[t2] sK/2 ->6 @@ -101,7 +101,7 @@ my $t = <<'EOT_EOT'; EOT_EOT my $nt = <<'EONT_EONT'; # 8 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 7 <2> sassign vKS/2 ->8 # 5 <@> index[t1] sK/2 ->6 diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 15b5799ce0..0a498a9e52 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -331,7 +331,7 @@ checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> const[IV 1] s @@ -350,7 +350,7 @@ checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', # g <2> leaveloop vK/2 # h <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> const(IV 1) s @@ -602,14 +602,14 @@ checkOptree ( name => '-e use constant j => qq{junk}; print j', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 71 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> const[PV "junk"] s*/FOLD # 5 <@> print vK # 6 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 71 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> const(PV "junk") s*/FOLD diff --git a/ext/B/t/optree_sort.t b/ext/B/t/optree_sort.t index 0b5897d575..2c661f6765 100644 --- a/ext/B/t/optree_sort.t +++ b/ext/B/t/optree_sort.t @@ -46,7 +46,7 @@ checkOptree ( name => 'sort @a', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -1 <0> enter +1 <0> enter v 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 3 <0> pushmark s 4 <#> gv[*a] s @@ -54,7 +54,7 @@ checkOptree ( name => 'sort @a', 6 <@> sort vK 7 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <$> gv(*a) s @@ -98,7 +98,7 @@ checkOptree ( name => '@a = sort @a', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -1 <0> enter +1 <0> enter v 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 3 <0> pushmark s 4 <0> pushmark s @@ -107,7 +107,7 @@ checkOptree ( name => '@a = sort @a', 7 <@> sort lK/INPLACE 8 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <0> pushmark s @@ -155,7 +155,7 @@ checkOptree ( name => '@a = sort @a; reverse @a', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -1 <0> enter +1 <0> enter v 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 3 <0> pushmark s 4 <0> pushmark s @@ -169,7 +169,7 @@ b <1> rv2av[t7] lK/1 c <@> reverse[t8] vK/1 d <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <0> pushmark s @@ -219,7 +219,7 @@ checkOptree ( name => 'my @a; @a = sort @a', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -1 <0> enter +1 <0> enter v 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 3 <0> padav[@a:1,2] vM/LVINTRO 4 <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -229,7 +229,7 @@ checkOptree ( name => 'my @a; @a = sort @a', 8 <@> sort lK/INPLACE 9 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> padav[@a:1,2] vM/LVINTRO # 4 <;> nextstate(main 2 -e:1) v:>,<,%,{ diff --git a/ext/B/t/optree_varinit.t b/ext/B/t/optree_varinit.t index 5938048f3a..8312df029d 100644 --- a/ext/B/t/optree_varinit.t +++ b/ext/B/t/optree_varinit.t @@ -80,12 +80,12 @@ checkOptree ( name => 'my $a', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 4 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 3 <0> padsv[$a:1,2] vM/LVINTRO ->4 EOT_EOT # 4 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 3 <0> padsv[$a:1,2] vM/LVINTRO ->4 EONT_EONT @@ -96,13 +96,13 @@ checkOptree ( name => 'our $a', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 3 <@> leave[1 ref] vKP/REFC ->(end) -1 <0> enter ->2 +1 <0> enter v ->2 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 - <1> rv2sv vK/OURINTR,1 ->3 - <#> gv[*a] s ->- EOT_EOT # 3 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # - <1> rv2sv vK/OURINTR,1 ->3 # - <$> gv(*a) s ->- @@ -115,13 +115,13 @@ checkOptree ( name => 'local $c', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 4 <@> leave[1 ref] vKP/REFC ->(end) -1 <0> enter ->2 +1 <0> enter v ->2 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 - <1> ex-rv2sv vKM/LVINTRO,1 ->4 3 <#> gvsv[*c] s/LVINTRO ->4 EOT_EOT # 4 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # - <1> ex-rv2sv vKM/LVINTRO,1 ->4 # 3 <$> gvsv(*c) s/LVINTRO ->4 @@ -201,14 +201,14 @@ checkOptree ( name => 'my $a=undef', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 6 <@> leave[1 ref] vKP/REFC ->(end) -1 <0> enter ->2 +1 <0> enter v ->2 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 5 <2> sassign vKS/2 ->6 3 <0> undef s ->4 4 <0> padsv[$a:1,2] sRM*/LVINTRO ->5 EOT_EOT # 6 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 5 <2> sassign vKS/2 ->6 # 3 <0> undef s ->4 @@ -222,7 +222,7 @@ checkOptree ( name => 'our $a=undef', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 6 <@> leave[1 ref] vKP/REFC ->(end) -1 <0> enter ->2 +1 <0> enter v ->2 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 5 <2> sassign vKS/2 ->6 3 <0> undef s ->4 @@ -230,7 +230,7 @@ checkOptree ( name => 'our $a=undef', 4 <#> gvsv[*a] s/OURINTR ->5 EOT_EOT # 6 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 5 <2> sassign vKS/2 ->6 # 3 <0> undef s ->4 @@ -246,7 +246,7 @@ checkOptree ( name => 'local $c=undef', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 6 <@> leave[1 ref] vKP/REFC ->(end) -1 <0> enter ->2 +1 <0> enter v ->2 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 5 <2> sassign vKS/2 ->6 3 <0> undef s ->4 @@ -254,7 +254,7 @@ checkOptree ( name => 'local $c=undef', 4 <#> gvsv[*c] s/LVINTRO ->5 EOT_EOT # 6 <@> leave[1 ref] vKP/REFC ->(end) -# 1 <0> enter ->2 +# 1 <0> enter v ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 5 <2> sassign vKS/2 ->6 # 3 <0> undef s ->4 @@ -323,14 +323,14 @@ checkOptree ( name => 'my $a=()', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -1 <0> enter +1 <0> enter v 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 3 <0> stub sP 4 <0> padsv[$a:1,2] sRM*/LVINTRO 5 <2> sassign vKS/2 6 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> stub sP # 4 <0> padsv[$a:1,2] sRM*/LVINTRO @@ -344,14 +344,14 @@ checkOptree ( name => 'our $a=()', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -1 <0> enter +1 <0> enter v 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 3 <0> stub sP 4 <#> gvsv[*a] s/OURINTR 5 <2> sassign vKS/2 6 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> stub sP # 4 <$> gvsv(*a) s/OURINTR @@ -366,14 +366,14 @@ checkOptree ( name => 'local $c=()', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -1 <0> enter +1 <0> enter v 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 3 <0> stub sP 4 <#> gvsv[*c] s/LVINTRO 5 <2> sassign vKS/2 6 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> stub sP # 4 <$> gvsv(*c) s/LVINTRO @@ -387,14 +387,14 @@ checkOptree ( name => 'my ($a,$b)=()', bcopts => '-exec', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,range=2 # 5 <2> aassign[t3] vKS # 6 <@> leave[1 ref] vKP/REFC EOT_EOT -# 1 <0> enter +# 1 <0> enter v # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s # 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,range=2 diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index f3f781ac6b..fbcda76433 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -1465,7 +1465,7 @@ dumpindent is 4 at -e line 1. REFCNT = 1 | 2 +--enter OP(0xNNN) ===> 3 [nextstate 0xNNN] - | FLAGS = (UNKNOWN,SLABBED,MORESIB) + | FLAGS = (VOID,SLABBED,MORESIB) | 3 +--nextstate COP(0xNNN) ===> 4 [pushmark 0xNNN] | FLAGS = (VOID,SLABBED,MORESIB) diff --git a/inline.h b/inline.h index aa4e7b8fdf..f52d4e5620 100644 --- a/inline.h +++ b/inline.h @@ -2056,6 +2056,23 @@ Perl_sv_only_taint_gmagic(SV *sv) /* ------------------ cop.h ------------------------------------------- */ +/* implement GIMME_V() macro */ + +PERL_STATIC_INLINE U8 +Perl_gimme_V(pTHX) +{ + I32 cxix; + U8 gimme = (PL_op->op_flags & OPf_WANT); + + if (gimme) + return gimme; + cxix = PL_curstackinfo->si_cxsubix; + if (cxix < 0) + return G_VOID; + assert(cxstack[cxix].blk_gimme & G_WANT); + return (cxstack[cxix].blk_gimme & G_WANT); +} + /* Enter a block. Push a new base context and return its address. */ @@ -2134,6 +2151,8 @@ Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs) PERL_ARGS_ASSERT_CX_PUSHSUB; PERL_DTRACE_PROBE_ENTRY(cv); + cx->blk_sub.old_cxsubix = PL_curstackinfo->si_cxsubix; + PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack; cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); cx->blk_sub.prevcomppad = PL_comppad; @@ -2160,6 +2179,7 @@ Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx) CvDEPTH(cv) = cx->blk_sub.olddepth; cx->blk_sub.cv = NULL; SvREFCNT_dec(cv); + PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix; } @@ -2206,6 +2226,8 @@ Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv) { PERL_ARGS_ASSERT_CX_PUSHFORMAT; + cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix; + PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack; cx->blk_format.cv = cv; cx->blk_format.retop = retop; cx->blk_format.gv = gv; @@ -2239,6 +2261,7 @@ Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx) cx->blk_format.cv = NULL; --CvDEPTH(cv); SvREFCNT_dec_NN(cv); + PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix; } @@ -2247,6 +2270,8 @@ Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv) { PERL_ARGS_ASSERT_CX_PUSHEVAL; + cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix; + PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack; cx->blk_eval.retop = retop; cx->blk_eval.old_namesv = namesv; cx->blk_eval.old_eval_root = PL_eval_root; @@ -2282,6 +2307,7 @@ Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx) cx->blk_eval.old_namesv = NULL; SvREFCNT_dec_NN(sv); } + PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix; } diff --git a/op.c b/op.c index 944c57a406..29486a566c 100644 --- a/op.c +++ b/op.c @@ -5455,7 +5455,8 @@ Perl_op_scope(pTHX_ OP *o) dVAR; if (o) { if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { - o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); + o = op_prepend_elem(OP_LINESEQ, + newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o); OpTYPE_set(o, OP_LEAVE); } else if (o->op_type == OP_LINESEQ) { diff --git a/op.h b/op.h index c494386ed1..89440a2f41 100644 --- a/op.h +++ b/op.h @@ -85,7 +85,7 @@ Deprecated. Use C<GIMME_V> instead. =cut */ -#define GIMME_V OP_GIMME(PL_op, block_gimme()) +#define GIMME_V Perl_gimme_V(aTHX) /* Public flags */ diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 337e4c286f..713514dc9d 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -348,7 +348,11 @@ well. =item * -XXX +Added the C<<PL_curstackinfo->si_cxsubix>> field. This records the stack +index of the most recently pushed sub/format/eval context. It is set and +restored automatically by C<cx_pushsub()>, C<cx_popsub()> etc., but would +need to be manually managed if you do any unusual manipulation of the +context stack. =back diff --git a/pp_ctl.c b/pp_ctl.c index 064bdc002a..5bd9376b03 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -37,6 +37,11 @@ #define RUN_PP_CATCHABLY(thispp) \ STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END +#define dopopto_cursub() \ + (PL_curstackinfo->si_cxsubix >= 0 \ + ? PL_curstackinfo->si_cxsubix \ + : dopoptosub_at(cxstack, cxstack_ix)) + #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) PP(pp_wantarray) @@ -50,7 +55,7 @@ PP(pp_wantarray) if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF; } else { - cxix = dopoptosub(cxstack_ix); + cxix = dopopto_cursub(); if (cxix < 0) RETPUSHUNDEF; cx = &cxstack[cxix]; @@ -1384,10 +1389,12 @@ Perl_dowantarray(pTHX) return (gimme == G_VOID) ? G_SCALAR : gimme; } +/* note that this function has mostly been superseded by Perl_gimme_V */ + U8 Perl_block_gimme(pTHX) { - const I32 cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopopto_cursub(); U8 gimme; if (cxix < 0) return G_VOID; @@ -1402,7 +1409,7 @@ Perl_block_gimme(pTHX) I32 Perl_is_lvalue_sub(pTHX) { - const I32 cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopopto_cursub(); assert(cxix >= 0); /* We should only be called from inside subs */ if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) @@ -1860,7 +1867,7 @@ frame for the sub call itself. const PERL_CONTEXT * Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) { - I32 cxix = dopoptosub(cxstack_ix); + I32 cxix = dopopto_cursub(); const PERL_CONTEXT *cx; const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; @@ -2462,7 +2469,7 @@ PP(pp_return) { dSP; dMARK; PERL_CONTEXT *cx; - const I32 cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopopto_cursub(); assert(cxstack_ix >= 0); if (cxix < cxstack_ix) { @@ -2833,7 +2840,7 @@ PP(pp_goto) DIE(aTHX_ "Goto undefined subroutine"); } - cxix = dopoptosub(cxstack_ix); + cxix = dopopto_cursub(); if (cxix < 0) { DIE(aTHX_ "Can't goto subroutine outside a subroutine"); } @@ -2955,6 +2962,9 @@ PP(pp_goto) * this is a cx_popblock(), less all the stuff we already did * for cx_topblock() earlier */ PL_curcop = cx->blk_oldcop; + /* this is cx_popsub, less all the stuff we already did */ + PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix; + CX_POP(cx); /* Push a mark for the start of arglist */ diff --git a/proto.h b/proto.h index fe9b9a0367..f351644567 100644 --- a/proto.h +++ b/proto.h @@ -4868,6 +4868,10 @@ PERL_STATIC_INLINE void Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx); #define PERL_ARGS_ASSERT_CX_TOPBLOCK \ assert(cx) #endif +#ifndef PERL_NO_INLINE_FUNCTIONS +PERL_STATIC_INLINE U8 Perl_gimme_V(pTHX); +#define PERL_ARGS_ASSERT_GIMME_V +#endif #endif #if !defined(PERL_NO_UTF16_FILTER) # if defined(PERL_IN_TOKE_C) diff --git a/scope.c b/scope.c index 9b1393c69d..c6616440f6 100644 --- a/scope.c +++ b/scope.c @@ -82,6 +82,7 @@ Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) si->si_next = 0; si->si_cxmax = cxitems - 1; si->si_cxix = -1; + si->si_cxsubix = -1; si->si_type = PERLSI_UNDEF; Newx(si->si_cxstack, cxitems, PERL_CONTEXT); /* Without any kind of initialising CX_PUSHSUBST() diff --git a/sv.c b/sv.c index e088e5c419..0b878a4630 100644 --- a/sv.c +++ b/sv.c @@ -14690,6 +14690,7 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) nsi->si_stack = av_dup_inc(si->si_stack, param); nsi->si_cxix = si->si_cxix; + nsi->si_cxsubix = si->si_cxsubix; nsi->si_cxmax = si->si_cxmax; nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param); nsi->si_type = si->si_type; diff --git a/t/op/goto.t b/t/op/goto.t index 08b612b8a5..db08e1e2c1 100644 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -10,7 +10,7 @@ BEGIN { use warnings; use strict; -plan tests => 124; +plan tests => 125; our $TODO; my $deprecated = 0; @@ -884,3 +884,20 @@ eval { }; }; is $@,'', 'goto the first parameter of a binary expression [perl #132854]'; + +# v5.31.3-198-gd2cd363728 broke this. goto &XS_sub wasn't restoring +# cx->blk_sub.old_cxsubix. Would panic in pp_return + +{ + # isa is an XS sub + sub g198 { goto &UNIVERSAL::isa } + + sub f198 { + g198([], 1 ); + { + return 1; + } + } + eval { f198(); }; + is $@, "", "v5.31.3-198-gd2cd363728"; +} diff --git a/t/perf/benchmarks b/t/perf/benchmarks index 7795079c78..63eb62cfc3 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -158,6 +158,12 @@ code => '$x = f(1)', }, + 'call::sub::scalar' => { + desc => 'sub called in scalar context', + setup => 'my $x; my @a = 1..4; sub f { @a }', + code => '$x = f()', + }, + 'call::goto::empty' => { desc => 'goto &funtion with no args or body', setup => 'sub f { goto &g } sub g {}', -- Perl5 Master Repository
