Optimization: Remove needless list/pushmark pairs from the OP execution

This is an optimization for OP trees that involve list OPs in list
context. In list context, the list OP's first child, a pushmark, will do
what its name claims and push a mark to the mark stack, indicating the
start of a list of parameters to another OP. Then the list's other
child OPs will do their stack pushing. Finally, the list OP will be
executed and do nothing but undo what the pushmark has done. This is
because the main effect of the list OP only really kicks in if it's
not in array context (actually, it should probably only kick in if
it's in scalar context, but I don't know of any valid examples of
list OPs in void contexts).

This optimization is quite a measurable speed-up for array or hash
slicing and some other situations. Another (contrived) example is
that (1,2,(3,4)) now actually is the same, performance-wise as
(1,2,3,4), albeit that's rarely relevant.

The price to pay for this is a slightly convoluted (by standards other
than the perl core) bit of optimization logic that has to do minor
look-ahead on certain OPs in the peephole optimizer.

A number of tests failed after the first attack on this problem. The
failures were in two categories:

a) Tests that are sensitive to details of the OP tree structure and did
verbatim text comparisons of B::Concise output (ouch). These are just
patched according to the new red in this commit.

b) Test that validly failed because certain conditions in op.c were
expecting OP_LISTs where there are now OP_NULLs (with op_targ=OP_LIST).
For these, the respective conditions in op.c were adjusted.

The change includes modifying B::Deparse to handle the new OP tree
structure in the face of nulled OP_LISTs.

Author: tsee

embed.fnc

@@ -1870,6 +1870,7 @@ sR	|OP*	|newDEFSVOP
 sR	|OP*	|search_const	|NN OP *o
 sR	|OP*	|new_logop	|I32 type|I32 flags|NN OP **firstp|NN OP **otherp
 s	|void	|simplify_sort	|NN OP *o
+s	|void	|null_listop_in_list_context |NN OP* o
 s	|SV*	|gv_ename	|NN GV *gv
 sRn	|bool	|scalar_mod_type|NULLOK const OP *o|I32 type
 s	|OP *	|my_kid		|NULLOK OP *o|NULLOK OP *attrs|NN OP **imopsp

embed.h

@@ -1478,6 +1478,7 @@
 #define new_logop(a,b,c,d)	S_new_logop(aTHX_ a,b,c,d)
 #define no_bareword_allowed(a)	S_no_bareword_allowed(aTHX_ a)
 #define no_fh_allowed(a)	S_no_fh_allowed(aTHX_ a)
+#define null_listop_in_list_context(a)	S_null_listop_in_list_context(aTHX_ a)
 #define op_integerize(a)	S_op_integerize(aTHX_ a)
 #define op_std_init(a)		S_op_std_init(aTHX_ a)
 #define pmtrans(a,b,c)		S_pmtrans(aTHX_ a,b,c)

ext/B/t/f_map.t

@@ -101,20 +101,18 @@ checkOptree(note   => q{},
 # 8      <0> enter l
 # 9      <;> nextstate(main 475 (eval 10):1) v:{
 # a      <0> pushmark s
-# b      <0> pushmark s
-# c      <#> gvsv[*_] s
-# d      <#> gv[*getkey] s/EARLYCV
-# e      <1> entersub[t5] lKS/TARG
-# f      <#> gvsv[*_] s
-# g      <@> list lK
-# h      <@> leave lKP
+# b      <#> gvsv[*_] s
+# c      <#> gv[*getkey] s/EARLYCV
+# d      <1> entersub[t5] lKS/TARG
+# e      <#> gvsv[*_] s
+# f      <@> leave lKP
 #            goto 7
-# i  <0> pushmark s
-# j  <#> gv[*hash] s
-# k  <1> rv2hv[t2] lKRM*/1         < 5.019006
-# k  <1> rv2hv lKRM*/1             >=5.019006
-# l  <2> aassign[t10] KS/COMMON
-# m  <1> leavesub[1 ref] K/REFC,1
+# g  <0> pushmark s
+# h  <#> gv[*hash] s
+# i  <1> rv2hv[t2] lKRM*/1         < 5.019006
+# i  <1> rv2hv lKRM*/1             >=5.019006
+# j  <2> aassign[t10] KS/COMMON
+# k  <1> leavesub[1 ref] K/REFC,1
 EOT_EOT
 # 1  <;> nextstate(main 560 (eval 15):1) v:{
 # 2  <0> pushmark s
@@ -127,20 +125,18 @@ EOT_EOT
 # 8      <0> enter l
 # 9      <;> nextstate(main 559 (eval 15):1) v:{
 # a      <0> pushmark s
-# b      <0> pushmark s
-# c      <$> gvsv(*_) s
-# d      <$> gv(*getkey) s/EARLYCV
-# e      <1> entersub[t2] lKS/TARG
-# f      <$> gvsv(*_) s
-# g      <@> list lK
-# h      <@> leave lKP
+# b      <$> gvsv(*_) s
+# c      <$> gv(*getkey) s/EARLYCV
+# d      <1> entersub[t2] lKS/TARG
+# e      <$> gvsv(*_) s
+# f      <@> leave lKP
 #            goto 7
-# i  <0> pushmark s
-# j  <$> gv(*hash) s
-# k  <1> rv2hv[t1] lKRM*/1         < 5.019006
-# k  <1> rv2hv lKRM*/1             >=5.019006
-# l  <2> aassign[t5] KS/COMMON
-# m  <1> leavesub[1 ref] K/REFC,1
+# g  <0> pushmark s
+# h  <$> gv(*hash) s
+# i  <1> rv2hv[t1] lKRM*/1         < 5.019006
+# i  <1> rv2hv lKRM*/1             >=5.019006
+# j  <2> aassign[t5] KS/COMMON
+# k  <1> leavesub[1 ref] K/REFC,1
 EONT_EONT
 
 

ext/B/t/optree_samples.t

@@ -475,20 +475,18 @@ checkOptree ( name	=> '%h = map { getkey($_) => $_ } @a',
 # 8      <0> enter l
 # 9      <;> nextstate(main 500 (eval 22):1) v:{
 # a      <0> pushmark s
-# b      <0> pushmark s
-# c      <#> gvsv[*_] s
-# d      <#> gv[*getkey] s/EARLYCV
-# e      <1> entersub[t5] lKS/TARG
-# f      <#> gvsv[*_] s
-# g      <@> list lK
-# h      <@> leave lKP
+# b      <#> gvsv[*_] s
+# c      <#> gv[*getkey] s/EARLYCV
+# d      <1> entersub[t5] lKS/TARG
+# e      <#> gvsv[*_] s
+# f      <@> leave lKP
 #            goto 7
-# i  <0> pushmark s
-# j  <#> gv[*h] s
-# k  <1> rv2hv[t2] lKRM*/1         < 5.019006
-# k  <1> rv2hv lKRM*/1             >=5.019006
-# l  <2> aassign[t10] KS/COMMON
-# m  <1> leavesub[1 ref] K/REFC,1
+# g  <0> pushmark s
+# h  <#> gv[*h] s
+# i  <1> rv2hv[t2] lKRM*/1         < 5.019006
+# i  <1> rv2hv lKRM*/1             >=5.019006
+# j  <2> aassign[t10] KS/COMMON
+# k  <1> leavesub[1 ref] K/REFC,1
 EOT_EOT
 # 1  <;> nextstate(main 501 (eval 22):1) v:{
 # 2  <0> pushmark s
@@ -501,20 +499,18 @@ EOT_EOT
 # 8      <0> enter l
 # 9      <;> nextstate(main 500 (eval 22):1) v:{
 # a      <0> pushmark s
-# b      <0> pushmark s
-# c      <$> gvsv(*_) s
-# d      <$> gv(*getkey) s/EARLYCV
-# e      <1> entersub[t2] lKS/TARG
-# f      <$> gvsv(*_) s
-# g      <@> list lK
-# h      <@> leave lKP
+# b      <$> gvsv(*_) s
+# c      <$> gv(*getkey) s/EARLYCV
+# d      <1> entersub[t2] lKS/TARG
+# e      <$> gvsv(*_) s
+# f      <@> leave lKP
 #            goto 7
-# i  <0> pushmark s
-# j  <$> gv(*h) s
-# k  <1> rv2hv[t1] lKRM*/1         < 5.019006
-# k  <1> rv2hv lKRM*/1             >=5.019006
-# l  <2> aassign[t5] KS/COMMON
-# m  <1> leavesub[1 ref] K/REFC,1
+# g  <0> pushmark s
+# h  <$> gv(*h) s
+# i  <1> rv2hv[t1] lKRM*/1         < 5.019006
+# i  <1> rv2hv lKRM*/1             >=5.019006
+# j  <2> aassign[t5] KS/COMMON
+# k  <1> leavesub[1 ref] K/REFC,1
 EONT_EONT
 
 checkOptree ( name	=> '%h=(); for $_(@a){$h{getkey($_)} = $_}',

lib/B/Deparse.pm

@@ -3212,13 +3212,23 @@ sub pp_leavetry {
     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
 }
 
+sub _op_is_or_was {
+  my ($op, $expect_type) = @_;
+  my $type = $op->type;
+  return($type == $expect_type
+         || ($type == OP_NULL && $op->targ == $expect_type));
+}
+
 sub pp_null {
     my $self = shift;
     my($op, $cx) = @_;
     if (class($op) eq "OP") {
 	# old value is lost
 	return $self->{'ex_const'} if $op->targ == OP_CONST;
-    } elsif ($op->first->name eq "pushmark") {
+    } elsif ($op->first->name eq 'pushmark'
+             or $op->first->name eq 'null'
+                && $op->first->targ == OP_PUSHMARK
+                && _op_is_or_was($op, OP_LIST)) {
 	return $self->pp_list($op, $cx);
     } elsif ($op->first->name eq "enter") {
 	return $self->pp_leave($op, $cx);

op.c

@@ -1228,6 +1228,11 @@ S_scalar_slice_warning(pTHX_ const OP *o)
     case OP_RVALUES:
 	return;
     }
+
+    /* Don't warn if we have a nulled list either. */
+    if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
+        return;
+
     assert(kid->op_sibling);
     name = S_op_varname(aTHX_ kid->op_sibling);
     if (!name) /* XS module fiddling with the op tree */
@@ -1953,10 +1958,13 @@ S_finalize_op(pTHX_ OP* o)
 	S_scalar_slice_warning(aTHX_ o);
 
     case OP_KVHSLICE:
+        kid = cLISTOPo->op_first->op_sibling;
 	if (/* I bet there's always a pushmark... */
-	        (kid = cLISTOPo->op_first->op_sibling)->op_type != OP_LIST
-	      && kid->op_type != OP_CONST)
+	    OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
+	    && OP_TYPE_ISNT_NN(kid, OP_CONST))
+        {
 	    break;
+        }
 
 	key_op = (SVOP*)(kid->op_type == OP_CONST
 				? kid
@@ -5803,7 +5811,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 			   (state $a, my $b, our $c, $d, undef) = ... */
 		    }
 		} else if (lop->op_type == OP_UNDEF ||
-			   lop->op_type == OP_PUSHMARK) {
+                           OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
 		    /* undef may be interesting in
 		       (state $a, undef, state $c) */
 		} else {
@@ -9661,7 +9669,7 @@ Perl_ck_sassign(pTHX_ OP *o)
 	/* For state variable assignment, kkid is a list op whose op_last
 	   is a padsv. */
 	if ((kkid->op_type == OP_PADSV ||
-	     (kkid->op_type == OP_LIST &&
+	     (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
 	      (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
 	     )
 	    )
@@ -11144,6 +11152,26 @@ S_inplace_aassign(pTHX_ OP *o) {
 #define IS_AND_OP(o)   (o->op_type == OP_AND)
 #define IS_OR_OP(o)    (o->op_type == OP_OR)
 
+STATIC void
+S_null_listop_in_list_context(pTHX_ OP *o)
+{
+    PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
+
+    /* This is an OP_LIST in list context. That means we
+     * can ditch the OP_LIST and the OP_PUSHMARK within. */
+
+    OP *kid = cLISTOPo->op_first;
+    /* Find the end of the chain of OPs executed within the OP_LIST. */
+    while (kid->op_next != o) {
+        assert(kid);
+        kid = kid->op_next;
+    }
+
+    kid->op_next = o->op_next; /* patch list out of exec chain */
+    op_null(cUNOPo->op_first); /* NULL the pushmark */
+    op_null(o); /* NULL the list */
+}
+
 /* A peephole optimizer.  We visit the ops in the order they're to execute.
  * See the comments at the top of this file for more details about when
  * peep() is called */
@@ -11176,6 +11204,44 @@ Perl_rpeep(pTHX_ OP *o)
 	   clear this again.  */
 	o->op_opt = 1;
 	PL_op = o;
+
+
+        /* The following will have the OP_LIST and OP_PUSHMARK
+         * patched out later IF the OP_LIST is in list context.
+         * So in that case, we can set the this OP's op_next
+         * to skip to after the OP_PUSHMARK:
+         *   a THIS -> b
+         *   d list -> e
+         *   b   pushmark -> c
+         *   c   whatever -> d
+         *   e whatever
+         * will eventually become:
+         *   a THIS -> c
+         *   - ex-list -> -
+         *   -   ex-pushmark -> -
+         *   c   whatever -> e
+         *   e whatever
+         */
+        {
+            OP *sibling;
+            OP *other_pushmark;
+            if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
+                && (sibling = o->op_sibling)
+                && sibling->op_type == OP_LIST
+                /* This KIDS check is likely superfluous since OP_LIST
+                 * would otherwise be an OP_STUB. */
+                && sibling->op_flags & OPf_KIDS
+                && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
+                && (other_pushmark = cLISTOPx(sibling)->op_first)
+                /* Pointer equality also effectively checks that it's a
+                 * pushmark. */
+                && other_pushmark == o->op_next)
+            {
+                o->op_next = other_pushmark->op_next;
+                null_listop_in_list_context(sibling);
+            }
+        }
+
 	switch (o->op_type) {
 	case OP_DBSTATE:
 	    PL_curcop = ((COP*)o);		/* for warnings */
@@ -11538,7 +11604,7 @@ Perl_rpeep(pTHX_ OP *o)
              */
             assert(followop);
             if (gimme == OPf_WANT_VOID) {
-                if (followop->op_type == OP_LIST
+                if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
                         && gimme == (followop->op_flags & OPf_WANT)
                         && (   followop->op_next->op_type == OP_NEXTSTATE
                             || followop->op_next->op_type == OP_DBSTATE))

proto.h

@@ -6123,6 +6123,11 @@ STATIC OP*	S_no_fh_allowed(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_NO_FH_ALLOWED	\
 	assert(o)
 
+STATIC void	S_null_listop_in_list_context(pTHX_ OP* o)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT	\
+	assert(o)
+
 PERL_STATIC_INLINE OP*	S_op_integerize(pTHX_ OP *o)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_OP_INTEGERIZE	\