Skip to content

Commit 9a9c29f

Browse files
richardleachrichardleach
committed
Remove defunct OPs in Perl_scalar/Perl_scalarvoid
`my $x = (1,2,3);` produces the following OP tree in blead: 2 <;> nextstate(main 1 -e:1) v:{ ->3 6 <1> padsv_store[$x:1,2] vKS/LVINTRO ->7 5 <@> list sKP ->6 3 <0> pushmark v ->4 - <0> ex-const v ->- - <0> ex-const v ->4 4 <$> const(IV 3) s ->5 - <0> ex-padsv sRM*/LVINTRO ->6 This is functionally equivalent to `my $x = 3;`: 2 <;> nextstate(main 1 -e:1) v:{ ->3 4 <1> padsv_store[$x:1,2] vKS/LVINTRO ->5 3 <$> const(IV 3) s ->4 - <0> ex-padsv sRM*/LVINTRO ->4 Construction of the first tree typically generates "Useless use of X in scalar context" warnings, but special cases such as the constants `0` and `1` are excluded from these warnings. This commit modifies the functions responsible for assigning scalar or void context to OPs to remove: * `OP_NULL` nodes with no kids and a following sibling. * `OP_LIST` nodes with only a single-scalar-pushing kid OP. This transforms the first OP tree above into the second. Besides having a "cleaner-looking" optree that's easier to follow when debuggging Perl code or porting, there are other practical benefits: * If the op_next chain hasn't been built, LINKLIST won't have to traverse these OP nodes and link them in. Subsequent compiler steps then won't re-traverse the same nodes to optimize them out of the op_next chain. * Anything traversing - or cloning - the full optree has fewer defunct OP nodes to visit. * OP slabs may contain a higher proportion of live OPs, reducing TLB pressure (on systems or workloads where that matters).
1 parent c7edb9f commit 9a9c29f

File tree

4 files changed

+132
-10
lines changed

4 files changed

+132
-10
lines changed

‎lib/B/Deparse.pm‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@
77
# This is based on the module of the same name by Malcolm Beattie,
88
# but essentially none of his code remains.
99

10-
package B::Deparse 1.88;
10+
package B::Deparse 1.89;
1111
use strict;
1212
use builtin qw( true false );
1313
use Carp;
@@ -2419,6 +2419,16 @@ sub pp_nextstate {
24192419

24202420
push @text, $op->label . ": " if $op->label;
24212421

2422+
my $text = join("", @text);
2423+
2424+
if ($text eq '' && class($op->sibling) ne 'NULL'
2425+
&& $op->sibling->name eq 'unstack' &&
2426+
($op->flags & OPf_WANT_VOID)) {
2427+
# An OP in void context was optimized away.
2428+
# Substitute in an empty list for deparsing.
2429+
return "()";
2430+
}
2431+
24222432
return join("", @text);
24232433
}
24242434

‎lib/B/Deparse.t‎

Lines changed: 1 addition & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -122,7 +122,7 @@ BEGIN { $/ = "\n"; $\ = "\n"; }
122122
LINE: while (defined($_ = readline ARGV)) {
123123
chomp $_;
124124
our(@F) = split(' ', $_, 0);
125-
'???';
125+
();
126126
}
127127
EOF
128128
$b =~ s/our\\\(\\\@F\\\)/our[( ]\@F\\)?/; # accept both our @F and our(@F)
@@ -683,7 +683,6 @@ tr/\x{345}/\x{370}/;
683683
# Constants in a block
684684
# CONTEXT no warnings;
685685
{
686-
'???';
687686
2;
688687
}
689688
####
@@ -692,7 +691,6 @@ tr/\x{345}/\x{370}/;
692691
(1,2,3);
693692
0;
694693
>>>>
695-
'???', '???', '???';
696694
0;
697695
####
698696
# Lexical and simple arithmetic
@@ -1271,7 +1269,6 @@ if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
12711269
>>>>
12721270
x();
12731271
x();
1274-
'???';
12751272
x();
12761273
x();
12771274
x();
@@ -1294,11 +1291,9 @@ do {
12941291
do {
12951292
x()
12961293
};
1297-
'???';
12981294
do {
12991295
t()
13001296
};
1301-
'???';
13021297
!1;
13031298
####
13041299
# TODO constant deparsing has been backed out for 5.12

‎op.c‎

Lines changed: 114 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2047,7 +2047,8 @@ Perl_scalar(pTHX_ OP *o)
20472047
kid = cLISTOPo->op_first;
20482048
scalar(kid);
20492049
kid = OpSIBLING(kid);
2050-
do_kids:
2050+
do_kids: {
2051+
OP * prev_kid = NULL;
20512052
while (kid) {
20522053
OP *sib = OpSIBLING(kid);
20532054
/* Apply void context to all kids except the last, which
@@ -2069,16 +2070,69 @@ Perl_scalar(pTHX_ OP *o)
20692070
)
20702071
)
20712072
{
2073+
2074+
if (OP_TYPE_IS(o, OP_LIST) && !op_parent(o)) {
2075+
/* Is the list now just an obvious scalar pushop?
2076+
* <@> list sKP ->6
2077+
* <0> pushmark v ->4
2078+
* <$> const(IV 3) s ->5
2079+
*/
2080+
OP* first = cLISTOPo->op_first;
2081+
assert(OP_TYPE_IS(first, OP_PUSHMARK));
2082+
OP* sib1 = OpSIBLING(first);
2083+
assert(sib1);
2084+
OP* sib2 = OpSIBLING(sib1);
2085+
if (!sib2) {
2086+
if (
2087+
PL_opargs[sib1->op_type] & OA_RETSCALAR
2088+
){
2089+
assert(sib1->op_next == sib1);
2090+
/* Yup. The PUSHMARK and LIST are redundant.
2091+
* They can be stripped out. */
2092+
op_sibling_splice(o,first,1,NULL);
2093+
op_free(o);
2094+
return sib1;
2095+
}
2096+
}
2097+
}
2098+
20722099
/* tail call optimise calling scalar() on the last kid */
2100+
assert(kid);
20732101
next_kid = kid;
20742102
goto do_next;
20752103
}
20762104
else if (kid->op_type == OP_LEAVEWHEN)
20772105
scalar(kid);
2078-
else
2106+
else {
20792107
scalarvoid(kid);
2108+
2109+
if (OP_TYPE_IS(kid, OP_NULL) && !(kid->op_flags & OPf_KIDS)
2110+
&& prev_kid
2111+
) {
2112+
/* This OP is now defunct. Strip it out. */
2113+
if (kid->op_next == kid || kid->op_next == sib) {
2114+
if (prev_kid->op_next == kid)
2115+
prev_kid->op_next = kid->op_next;
2116+
2117+
prev_kid->op_sibparent = kid->op_sibparent;
2118+
op_free(kid); kid = NULL;
2119+
2120+
/* A NEXTSTATE with no sibling OPs is redundant
2121+
* if another NEXTSTATE follows it. Null it out
2122+
* rather than removing it, in case anything needs
2123+
* to probe it for file/line/hints info. */
2124+
if (OP_TYPE_IS(prev_kid, OP_NEXTSTATE) && sib
2125+
&& OP_TYPE_IS(sib, OP_NEXTSTATE)) {
2126+
op_null(prev_kid);
2127+
}
2128+
}
2129+
}
2130+
}
2131+
if (kid)
2132+
prev_kid = kid;
20802133
kid = sib;
20812134
}
2135+
}
20822136
NOT_REACHED; /* NOTREACHED */
20832137
break;
20842138

@@ -2523,8 +2577,40 @@ Perl_scalarvoid(pTHX_ OP *arg)
25232577
* siblings and so on
25242578
*/
25252579
while (!next_kid) {
2526-
if (o == arg)
2580+
if (o == arg) {
2581+
/* at top; no parents/siblings to try */
2582+
2583+
if (OP_TYPE_IS(o, OP_NULL) && o->op_targ == OP_LIST) {
2584+
/* Remove any LIST KIDS that are wholly defunct */
2585+
OP *kid = cLISTOPo->op_first;
2586+
OP *prev_kid = NULL;
2587+
for (; kid; ) {
2588+
if (OP_TYPE_IS(kid, OP_NULL) && !(kid->op_flags & OPf_KIDS)
2589+
&& kid->op_targ != OP_NEXTSTATE
2590+
&& kid->op_targ != OP_DBSTATE
2591+
&& kid->op_targ != OP_PUSHMARK
2592+
) {
2593+
/* This OP_NULL kid can serve no runtime purpose.
2594+
* Splice it out and free its slab slot for reuse. */
2595+
OP *sib = OpSIBLING(kid);
2596+
if (prev_kid) {
2597+
assert(prev_kid->op_next != kid);
2598+
op_sibling_splice(o,prev_kid,1,NULL);
2599+
op_free(kid);
2600+
} else {
2601+
assert(op_parent(kid)->op_next != kid);
2602+
op_sibling_splice(o,NULL,1,NULL);
2603+
op_free(kid);
2604+
}
2605+
kid = sib;
2606+
} else {
2607+
prev_kid = kid;
2608+
kid = OpSIBLING(kid);
2609+
}
2610+
}
2611+
}
25272612
return arg; /* at top; no parents/siblings to try */
2613+
}
25282614
if (OpHAS_SIBLING(o))
25292615
next_kid = o->op_sibparent;
25302616
else
@@ -2705,19 +2791,44 @@ S_voidnonfinal(pTHX_ OP *o)
27052791
type == OP_LEAVE || type == OP_LEAVETRY)
27062792
{
27072793
OP *kid = cLISTOPo->op_first, *sib;
2794+
OP *prev_kid = NULL;
27082795
if(type == OP_LEAVE) {
27092796
/* Don't put the OP_ENTER in void context */
27102797
assert(kid->op_type == OP_ENTER);
2798+
prev_kid = kid;
27112799
kid = OpSIBLING(kid);
27122800
}
2801+
27132802
for (; kid; kid = sib) {
27142803
if ((sib = OpSIBLING(kid))
27152804
&& ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
27162805
|| ( sib->op_targ != OP_NEXTSTATE
27172806
&& sib->op_targ != OP_DBSTATE )))
27182807
{
2808+
/* Note: if kid is an OP_NEXTSTATE, it will be nulled-out,
2809+
but it cannot be spliced out as things stand, because
2810+
Perl_leaveeval() depends on it being there. */
27192811
scalarvoid(kid);
2812+
2813+
if (OP_TYPE_IS(kid, OP_NULL) &&
2814+
!(kid->op_flags & OPf_KIDS) &&
2815+
/* Perl_leaveeval needs an ex-nextstate for its
2816+
feature state information */
2817+
kid->op_targ != OP_NEXTSTATE &&
2818+
kid->op_targ != OP_DBSTATE
2819+
){
2820+
/* This kid is no longer needed. */
2821+
if (prev_kid) {
2822+
assert(prev_kid->op_next != kid);
2823+
op_sibling_splice(o,prev_kid,1,NULL);
2824+
} else {
2825+
assert(op_parent(kid)->op_next != kid);
2826+
op_sibling_splice(o,NULL,1,NULL);
2827+
}
2828+
op_free(kid);
2829+
}
27202830
}
2831+
prev_kid = kid;
27212832
}
27222833
PL_curcop = &PL_compiling;
27232834
}

‎pod/perldelta.pod‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -363,6 +363,12 @@ well.
363363

364364
=item *
365365

366+
Simple individual OPs or LISTs rendered redundant by the application of scalar
367+
or void context during compilation are now more likely to be spliced out of
368+
the compiling optree and freed. [GH #23890]
369+
370+
=item *
371+
366372
XXX
367373

368374
=back

0 commit comments

Comments
 (0)