Fix entersub evaluation order

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<perlcall/LIGHTWEIGHT CALLBACKS>.
         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<perlcall/LIGHTWEIGHT CALLBACKS>.
         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)  						\

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

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)

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);
 }
 
 

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;
 	}

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;
 ####

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;
 

op.h

@@ -161,6 +161,8 @@ Deprecated.  Use C<GIMME_V> 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.  */

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;
 			}

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;

pp_hot.c

@@ -5162,11 +5162,30 @@ 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;
+
+        /* Move all the stack args down one position to where everyone expects
+         * them */
+        Size_t count = SP - mark;
+        Move(svp+1, svp, count, SV *);
+
+        PERL_UNUSED_RESULT(POPs);
+    }
+    else
+        sv = POPs;
 
     if (UNLIKELY(!sv))
         goto do_die;
@@ -5336,7 +5355,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 +5414,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,