From 27b3b6ce865a76e462853790a54ddc8933acad90 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Fri, 16 Sep 2022 17:36:43 +0100 Subject: [PATCH 1/5] Modernise t/op/sub.t with strict+warnings --- t/op/sub.t | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/t/op/sub.t b/t/op/sub.t index 09f5609b499a..77b492fb4ca4 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -1,4 +1,4 @@ -#!./perl -w +#!./perl BEGIN { chdir 't' if -d 't'; @@ -6,10 +6,12 @@ BEGIN { set_up_inc('../lib'); } -plan(tests => 63); +use strict; +use warnings; sub empty_sub {} +my @test; is(empty_sub,undef,"Is empty"); is(empty_sub(1,2,3),undef,"Is still empty"); @test = empty_sub(); @@ -19,6 +21,7 @@ is(scalar(@test), 0, 'Didnt return anything'); # [perl #91844] return should always copy { + my %foo; $foo{bar} = 7; for my $x ($foo{bar}) { # Pity test.pl doesnt have isn't. @@ -151,6 +154,7 @@ is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist'; # another XSUB if this fails. ok !exists $INC{"re.pm"}, 're.pm not loaded yet'; { + my @str; sub re::regmust{} bless \&re::regmust; DESTROY { @@ -166,6 +170,7 @@ ok !exists $INC{"re.pm"}, 're.pm not loaded yet'; 'XSUB clobbering sub whose DESTROY assigns to the glob'; } { + my @str; no warnings 'redefine'; sub foo {} bless \&foo, 'newATTRSUBbug'; @@ -433,3 +438,5 @@ fresh_perl_like( {}, "GH Issue #16944 - Syntax error with sub and shift causes segfault" ); + +done_testing; From be5bc69294a4379dd2d66bdb2957624789220424 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Wed, 27 Jul 2022 17:44:26 +0100 Subject: [PATCH 2/5] Pass ->op_private from ENTERSUB op into cx_pushsub() explicitly Avoids the incredibly subtle and hard-to-find "action-at-a-distance" by having that function read it directly out of PL_op. See footnote in https://github.com/Perl/perl5/issues/19997#issuecomment-1196987459 Also avoids having it be miscalculated and fixed elsewhere, by passing zero in directly. --- cop.h | 8 ++++---- embed.fnc | 2 +- embed.h | 2 +- inline.h | 6 +++--- pp_ctl.c | 6 +----- pp_hot.c | 4 ++-- pp_sort.c | 2 +- proto.h | 2 +- 8 files changed, 14 insertions(+), 18 deletions(-) diff --git a/cop.h b/cop.h index cb30e5feeb83..dbbfc1f1f485 100644 --- a/cop.h +++ b/cop.h @@ -743,13 +743,13 @@ struct block_format { # define CX_POP(cx) cxstack_ix--; #endif -#define CX_PUSHSUB_GET_LVALUE_MASK(func) \ +#define CX_PUSHSUB_GET_LVALUE_MASK(func, op_private) \ /* If the context is indeterminate, then only the lvalue */ \ /* flags that the caller also has are applicable. */ \ ( \ (PL_op->op_flags & OPf_WANT) \ ? OPpENTERSUB_LVAL_MASK \ - : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \ + : !(op_private & OPpENTERSUB_LVAL_MASK) \ ? 0 : (U8)func(aTHX) \ ) @@ -1274,7 +1274,7 @@ See L. PUSHSTACKi(PERLSI_MULTICALL); \ cx = cx_pushblock((CXt_SUB|CXp_MULTICALL|flags), (U8)gimme, \ PL_stack_sp, PL_savestack_ix); \ - cx_pushsub(cx, cv, NULL, 0); \ + cx_pushsub(cx, cv, NULL, 0, 0); \ SAVEOP(); \ if (!(flags & CXp_SUB_RE_FAKE)) \ CvDEPTH(cv)++; \ @@ -1317,7 +1317,7 @@ See L. assert(CxMULTICALL(cx)); \ cx_popsub_common(cx); \ cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \ - cx_pushsub(cx, cv, NULL, 0); \ + cx_pushsub(cx, cv, NULL, 0, 0); \ if (!(flags & CXp_SUB_RE_FAKE)) \ CvDEPTH(cv)++; \ if (CvDEPTH(cv) >= 2) \ diff --git a/embed.fnc b/embed.fnc index 4d533195ccbe..54d7ea899458 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3811,7 +3811,7 @@ Cixp |PERL_CONTEXT * |cx_pushblock|U8 type|U8 gimme|NN SV** sp|I32 saveix Cixp |void |cx_popblock|NN PERL_CONTEXT *cx Cixp |void |cx_topblock|NN PERL_CONTEXT *cx Cixp |void |cx_pushsub |NN PERL_CONTEXT *cx|NN CV *cv \ - |NULLOK OP *retop|bool hasargs + |NULLOK OP *retop|bool hasargs|U8 op_private Cixp |void |cx_popsub_common|NN PERL_CONTEXT *cx Cixp |void |cx_popsub_args |NN PERL_CONTEXT *cx Cixp |void |cx_popsub |NN PERL_CONTEXT *cx diff --git a/embed.h b/embed.h index 87ef4be37577..2c5e48f60f6e 100644 --- a/embed.h +++ b/embed.h @@ -789,7 +789,7 @@ #define cx_pushgiven(a,b) Perl_cx_pushgiven(aTHX_ a,b) #define cx_pushloop_for(a,b,c) Perl_cx_pushloop_for(aTHX_ a,b,c) #define cx_pushloop_plain(a) Perl_cx_pushloop_plain(aTHX_ a) -#define cx_pushsub(a,b,c,d) Perl_cx_pushsub(aTHX_ a,b,c,d) +#define cx_pushsub(a,b,c,d,e) Perl_cx_pushsub(aTHX_ a,b,c,d,e) #define cx_pushtry(a,b) Perl_cx_pushtry(aTHX_ a,b) #define cx_pushwhen(a) Perl_cx_pushwhen(aTHX_ a) #define cx_topblock(a) Perl_cx_topblock(aTHX_ a) diff --git a/inline.h b/inline.h index 597b0709f850..ff567bb243d0 100644 --- a/inline.h +++ b/inline.h @@ -2753,9 +2753,9 @@ Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx) PERL_STATIC_INLINE void -Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs) +Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs, U8 op_private) { - U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub); + U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub, op_private); PERL_ARGS_ASSERT_CX_PUSHSUB; @@ -2768,7 +2768,7 @@ Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs) cx->cx_type |= (hasargs) ? CXp_HASARGS : 0; cx->blk_sub.retop = retop; SvREFCNT_inc_simple_void_NN(cv); - cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF); + cx->blk_u16 = op_private & (phlags|OPpDEREF); } diff --git a/pp_ctl.c b/pp_ctl.c index 680072f0fcf7..91779ba8fe0f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2155,11 +2155,7 @@ PP(pp_dbstate) } else { cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix); - cx_pushsub(cx, cv, PL_op->op_next, 0); - /* OP_DBSTATE's op_private holds hint bits rather than - * the lvalue-ish flags seen in OP_ENTERSUB. So cancel - * any CxLVAL() flags that have now been mis-calculated */ - cx->blk_u16 = 0; + cx_pushsub(cx, cv, PL_op->op_next, 0, 0); SAVEI32(PL_debug); PL_debug = 0; diff --git a/pp_hot.c b/pp_hot.c index e64dbd093d6b..62d484cd305f 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -5336,7 +5336,7 @@ PP(pp_entersub) gimme = GIMME_V; cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix); hasargs = cBOOL(PL_op->op_flags & OPf_STACKED); - cx_pushsub(cx, cv, PL_op->op_next, hasargs); + cx_pushsub(cx, cv, PL_op->op_next, hasargs, PL_op->op_private); padlist = CvPADLIST(cv); if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) @@ -5395,7 +5395,7 @@ PP(pp_entersub) PUTBACK; if (UNLIKELY(((PL_op->op_private - & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) + & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub, PL_op->op_private) ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && !CvLVALUE(cv))) DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf, diff --git a/pp_sort.c b/pp_sort.c index 8cc90a1ade7f..1c5098805642 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -878,7 +878,7 @@ PP(pp_sort) cx = cx_pushblock(CXt_NULL, gimme, PL_stack_base, old_savestack_ix); if (!(flags & OPf_SPECIAL)) { cx->cx_type = CXt_SUB|CXp_MULTICALL; - cx_pushsub(cx, cv, NULL, hasargs); + cx_pushsub(cx, cv, NULL, hasargs, 0); if (!is_xsub) { PADLIST * const padlist = CvPADLIST(cv); diff --git a/proto.h b/proto.h index 047adabfda2c..f100b39776d9 100644 --- a/proto.h +++ b/proto.h @@ -4974,7 +4974,7 @@ PERL_STATIC_INLINE void Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx); assert(cx) #endif #ifndef PERL_NO_INLINE_FUNCTIONS -PERL_STATIC_INLINE void Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs); +PERL_STATIC_INLINE void Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs, U8 op_private); #define PERL_ARGS_ASSERT_CX_PUSHSUB \ assert(cx); assert(cv) #endif From ccb2f67701ca7cf95bdbe41012ea3e0c230bf560 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Mon, 1 Aug 2022 16:35:59 +0100 Subject: [PATCH 3/5] Add tests to B::Deparse for SUBREF->(ARGS) deparsing --- lib/B/Deparse.t | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 535719e966b2..cd993b5b1b95 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -1871,6 +1871,21 @@ last (foo()); next (foo()); redo (foo()); #### +# function call via subref +$a->(); +$a->(1, 2); +$b = $a->(); +$b = $a->(1, 2); +() = $a->(); +() = $a->(1, 2); +>>>> +&$a(); +&$a(1, 2); +$b = &$a(); +$b = &$a(1, 2); +() = &$a(); +() = &$a(1, 2); +#### # require vstring require v5.16; #### From ca648b64bb0a85d796d2fbc2d4459f1ef0a0ec70 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Fri, 16 Sep 2022 17:39:16 +0100 Subject: [PATCH 4/5] Ensure that $ref->(@args) evaluates in obvious LtR order On visual inspection it would appear that the LHS expression that gives the code reference should be evaluated first, before the arguments. This was previously not the case, because of the order values were placed on the stack. By using the OPf_SPECIAL flag on OP_ENTERSUB to mean "expect to find the CV first, rather than last" and swapping the optree order for this syntax, we can ensure this becomes the case. Fixes https://github.com/Perl/perl5/issues/19997 --- lib/B/Deparse.pm | 17 +++++++-- op.c | 91 +++++++++++++++++++++++++++++++++++------------- op.h | 2 ++ perly.act | 8 ++--- perly.h | 2 +- perly.tab | 2 +- perly.y | 6 ++-- pp_hot.c | 25 ++++++++++++- t/op/sub.t | 9 +++++ 9 files changed, 124 insertions(+), 38 deletions(-) diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 3d1d8b36cc47..c2e9111faf94 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -5145,8 +5145,18 @@ sub pp_entersub { } $kid = $op->first; $kid = $kid->first->sibling; # skip ex-list, pushmark - for (; not null $kid->sibling; $kid = $kid->sibling) { - push @exprs, $kid; + if ($op->flags & OPf_SPECIAL) { + # CV OP is first + my $cvop = $kid; + for ($kid = $kid->sibling; not null $kid; $kid = $kid->sibling) { + push @exprs, $kid; + } + $kid = $cvop; + } + else { + for (; not null $kid->sibling; $kid = $kid->sibling) { + push @exprs, $kid; + } } my $simple = 0; my $proto = undef; @@ -5254,7 +5264,8 @@ sub pp_entersub { if ($prefix or $amper) { if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as && if ($op->flags & OPf_STACKED) { - return $prefix . $amper . $kid . "(" . $args . ")"; + $args = "($args)" if !($op->flags & OPf_SPECIAL); + return $prefix . $amper . $kid . $args; } else { return $prefix . $amper. $kid; } diff --git a/op.c b/op.c index b54399192bd3..c1a0c02a709e 100644 --- a/op.c +++ b/op.c @@ -478,6 +478,40 @@ S_pp_freed(pTHX) #endif +/* skip an op we presume to be an OP_PUSHMARK */ +#define SKIP_PUSHMARK(o) \ + (assert((o)->op_type == OP_PUSHMARK), (o) = OpSIBLING(o)) + +/* Extracts the CV op and first argument op out of an OP_ENTERSUB + * Sets *cvopp to the op that generates the CV for the call, and + * *aopp to the first op that generates arguments. */ +static void +S_extract_entersub_subtrees(const OP *entersubop, OP **cvopp, OP **aopp) +{ + bool cvop_is_first = entersubop->op_flags & OPf_SPECIAL; + + OP *aop = cUNOPx(entersubop)->op_first; + if(!OpHAS_SIBLING(aop)) + aop = cUNOPx(aop)->op_first; + SKIP_PUSHMARK(aop); + + OP *cvop; + + if(cvop_is_first) { + cvop = aop; + aop = OpSIBLING(aop); + } + else { + for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) + ; + /* Maybe there are no arguments at all? */ + if(aop == cvop) aop = NULL; + } + + if(cvopp) *cvopp = cvop; + if(aopp) *aopp = aop; +} + /* Return the block of memory used by an op to the free list of * the OP slab associated with that op. */ @@ -13633,14 +13667,13 @@ or a call where the callee has no prototype. OP * Perl_ck_entersub_args_list(pTHX_ OP *entersubop) { - OP *aop; - PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; - aop = cUNOPx(entersubop)->op_first; - if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; - for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { + bool cvop_is_first = entersubop->op_flags & OPf_SPECIAL; + + OP *aop; + S_extract_entersub_subtrees(entersubop, NULL, &aop); + for (; cvop_is_first ? cBOOL(aop): aop && OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { /* skip the extra attributes->import() call implicitly added in * something like foo(my $x : bar) */ @@ -13692,7 +13725,13 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) I32 arg = 0; I32 contextclass = 0; const char *e = NULL; + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; + /* Currently only $expr->(...) syntax will generate OP_ENTERSUB with + * OPf_SPECIAL. If other forms do it too this function will need updating + */ + assert(!(entersubop->op_flags & OPf_SPECIAL)); + if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " "flags=%lx", (unsigned long) SvFLAGS(protosv)); @@ -13708,7 +13747,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) aop = cUNOPx(aop)->op_first; } prev = aop; - aop = OpSIBLING(aop); + SKIP_PUSHMARK(aop); for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; while (aop != cvop) { OP* o3 = aop; @@ -13943,19 +13982,18 @@ Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, OP * Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE; + + bool cvop_is_first = entersubop->op_flags & OPf_SPECIAL; + IV cvflags = SvIVX(protosv); int opnum = cvflags & 0xffff; OP *aop = cUNOPx(entersubop)->op_first; - PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE; - if (!opnum) { OP *cvop; - if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; - aop = OpSIBLING(aop); - for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ; - if (aop != cvop) { + S_extract_entersub_subtrees(entersubop, &cvop, &aop); + if (aop) { SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, SVfARG(namesv)), SvUTF8(namesv)); @@ -13991,12 +14029,18 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) } first = prev = aop; - aop = OpSIBLING(aop); - /* find last sibling */ - for (cvop = aop; - OpHAS_SIBLING(cvop); - prev = cvop, cvop = OpSIBLING(cvop)) - ; + SKIP_PUSHMARK(aop); + if(cvop_is_first) { + cvop = aop; + aop = OpSIBLING(aop); + } + else { + /* find last sibling */ + for (cvop = aop; + OpHAS_SIBLING(cvop); + prev = cvop, cvop = OpSIBLING(cvop)) + ; + } if (!(cvop->op_private & OPpENTERSUB_NOPAREN) /* Usually, OPf_SPECIAL on an op with no args means that it had * parens, but these have their own meaning for that flag: */ @@ -14240,11 +14284,8 @@ Perl_ck_subr(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SUBR; - aop = cUNOPx(o)->op_first; - if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; - aop = OpSIBLING(aop); - for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; + S_extract_entersub_subtrees(o, &cvop, &aop); + cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; diff --git a/op.h b/op.h index ec3e1204a371..3e4a41e3fd84 100644 --- a/op.h +++ b/op.h @@ -161,6 +161,8 @@ Deprecated. Use C instead. /* On OP_DUMP, has no label */ /* On OP_UNSTACK, in a C-style for loop */ /* On OP_READLINE, it's for <<>>, not <> */ + /* On OP_ENTERSUB, expect to find the CV first + on the stack rather than last */ /* There is no room in op_flags for this one, so it has its own bit- field member (op_folded) instead. The flag is only used to tell op_convert_list to set op_folded. */ diff --git a/perly.act b/perly.act index bf9f5e97ef80..64024b5e302f 100644 --- a/perly.act +++ b/perly.act @@ -1263,9 +1263,9 @@ case 2: case 164: #line 1075 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, (ps[-1].val.opval), - newCVREF(0, scalar((ps[-4].val.opval))))); + { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + op_append_elem(OP_LIST, + newCVREF(0, scalar((ps[-4].val.opval))), (ps[-1].val.opval))); if (parser->expect == XBLOCK) parser->expect = XOPERATOR; } @@ -2083,6 +2083,6 @@ case 2: /* Generated from: - * 963e49faa7d19d5de631a5b22e01030327621687cee61ec2c63cb7c2602c5e3a perly.y + * 7de6ffb1afc76e7a9c0686158a2ed6e2a1b523997913ebb69f84c706a105652e perly.y * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ diff --git a/perly.h b/perly.h index a01d778b4424..e8b108f7892c 100644 --- a/perly.h +++ b/perly.h @@ -220,6 +220,6 @@ int yyparse (void); /* Generated from: - * 963e49faa7d19d5de631a5b22e01030327621687cee61ec2c63cb7c2602c5e3a perly.y + * 7de6ffb1afc76e7a9c0686158a2ed6e2a1b523997913ebb69f84c706a105652e perly.y * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ diff --git a/perly.tab b/perly.tab index 00541430b021..c80c03d5ec95 100644 --- a/perly.tab +++ b/perly.tab @@ -1152,6 +1152,6 @@ static const toketypes yy_type_tab[] = }; /* Generated from: - * 963e49faa7d19d5de631a5b22e01030327621687cee61ec2c63cb7c2602c5e3a perly.y + * 7de6ffb1afc76e7a9c0686158a2ed6e2a1b523997913ebb69f84c706a105652e perly.y * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ diff --git a/perly.y b/perly.y index d755fffc6ca3..15f3161e990a 100644 --- a/perly.y +++ b/perly.y @@ -1072,9 +1072,9 @@ subscripted: gelem PERLY_BRACE_OPEN expr PERLY_SEMICOLON PERLY_BRACE_CLOSE parser->expect = XOPERATOR; } | term[code_reference] ARROW PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE /* $subref->(@args) */ - { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, $expr, - newCVREF(0, scalar($code_reference)))); + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + op_append_elem(OP_LIST, + newCVREF(0, scalar($code_reference)), $expr)); if (parser->expect == XBLOCK) parser->expect = XOPERATOR; } diff --git a/pp_hot.c b/pp_hot.c index 62d484cd305f..a058b2974044 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -5162,11 +5162,34 @@ Perl_clear_defarray(pTHX_ AV* av, bool abandon) PP(pp_entersub) { - dSP; dPOPss; + dSP; + SV *sv; GV *gv; CV *cv; PERL_CONTEXT *cx; I32 old_savestack_ix; + bool cvop_is_first = PL_op->op_flags & OPf_SPECIAL; + + if(UNLIKELY(cvop_is_first)) { + /* We don't want to POPMARK */ + SV **mark = PL_stack_base + TOPMARK; + SV **svp = mark + 1; + + sv = *svp; + + /* TODO: This is currently horribly inefficient. It can likely be made + * a lot better by adjusting the code lower down instead + * For now we'll just move all the stack args down one position + */ + PERL_UNUSED_RESULT(POPs); + + while(svp <= SP) { + svp[0] = svp[1]; + svp++; + } + } + else + sv = POPs; if (UNLIKELY(!sv)) goto do_die; diff --git a/t/op/sub.t b/t/op/sub.t index 77b492fb4ca4..3df88a3c072c 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -439,4 +439,13 @@ fresh_perl_like( "GH Issue #16944 - Syntax error with sub and shift causes segfault" ); +# GH #19997 - evaluation order +{ + my $ord; + my @args; + (do { $ord .= "(sub)"; sub { @args = @_ } })->(do { $ord .= "(args)"; (1, 2) }); + is $ord, "(sub)(args)", 'evaluation order is LtR'; + ok eq_array(\@args, [1, 2]), 'args to invoked subref'; +} + done_testing; From 3c356ccb517565f825e5c06820c5a03a118d9171 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Sat, 17 Sep 2022 11:37:18 +0100 Subject: [PATCH 5/5] Use Move() instead of a manual while() loop to hopefully be more efficient --- pp_hot.c | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/pp_hot.c b/pp_hot.c index a058b2974044..29f0516c5459 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -5177,16 +5177,12 @@ PP(pp_entersub) sv = *svp; - /* TODO: This is currently horribly inefficient. It can likely be made - * a lot better by adjusting the code lower down instead - * For now we'll just move all the stack args down one position - */ - PERL_UNUSED_RESULT(POPs); + /* Move all the stack args down one position to where everyone expects + * them */ + Size_t count = SP - mark; + Move(svp+1, svp, count, SV *); - while(svp <= SP) { - svp[0] = svp[1]; - svp++; - } + PERL_UNUSED_RESULT(POPs); } else sv = POPs;