Skip to content

Commit cc16f93

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 03f24b8 commit cc16f93

File tree

2 files changed

+114
-9
lines changed

2 files changed

+114
-9
lines changed

‎lib/B/Deparse.t‎

Lines changed: 0 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -142,7 +142,6 @@ BEGIN { $/ = "\n"; $\ = "\n"; }
142142
LINE: while (defined($_ = readline ARGV)) {
143143
chomp $_;
144144
our(@F) = split(' ', $_, 0);
145-
'???';
146145
}
147146
EOF
148147
$b =~ s/our\\\(\\\@F\\\)/our[( ]\@F\\)?/; # accept both our @F and our(@F)
@@ -601,7 +600,6 @@ tr/\x{345}/\x{370}/;
601600
# Constants in a block
602601
# CONTEXT no warnings;
603602
{
604-
'???';
605603
2;
606604
}
607605
####
@@ -610,7 +608,6 @@ tr/\x{345}/\x{370}/;
610608
(1,2,3);
611609
0;
612610
>>>>
613-
'???', '???', '???';
614611
0;
615612
####
616613
# Lexical and simple arithmetic
@@ -1189,7 +1186,6 @@ if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
11891186
>>>>
11901187
x();
11911188
x();
1192-
'???';
11931189
x();
11941190
x();
11951191
x();
@@ -1212,11 +1208,9 @@ do {
12121208
do {
12131209
x()
12141210
};
1215-
'???';
12161211
do {
12171212
t()
12181213
};
1219-
'???';
12201214
!1;
12211215
####
12221216
# 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
@@ -2037,7 +2037,8 @@ Perl_scalar(pTHX_ OP *o)
20372037
kid = cLISTOPo->op_first;
20382038
scalar(kid);
20392039
kid = OpSIBLING(kid);
2040-
do_kids:
2040+
do_kids: {
2041+
OP * prev_kid = NULL;
20412042
while (kid) {
20422043
OP *sib = OpSIBLING(kid);
20432044
/* Apply void context to all kids except the last, which
@@ -2059,16 +2060,69 @@ Perl_scalar(pTHX_ OP *o)
20592060
)
20602061
)
20612062
{
2063+
2064+
if (OP_TYPE_IS(o, OP_LIST) && !op_parent(o)) {
2065+
/* Is the list now just an obvious scalar pushop?
2066+
* <@> list sKP ->6
2067+
* <0> pushmark v ->4
2068+
* <$> const(IV 3) s ->5
2069+
*/
2070+
OP* first = cLISTOPo->op_first;
2071+
assert(OP_TYPE_IS(first, OP_PUSHMARK));
2072+
OP* sib1 = OpSIBLING(first);
2073+
assert(sib1);
2074+
OP* sib2 = OpSIBLING(sib1);
2075+
if (!sib2) {
2076+
if (
2077+
PL_opargs[sib1->op_type] & OA_RETSCALAR
2078+
){
2079+
assert(sib1->op_next == sib1);
2080+
/* Yup. The PUSHMARK and LIST are redundant.
2081+
* They can be stripped out. */
2082+
op_sibling_splice(o,first,1,NULL);
2083+
op_free(o);
2084+
return sib1;
2085+
}
2086+
}
2087+
}
2088+
20622089
/* tail call optimise calling scalar() on the last kid */
2090+
assert(kid);
20632091
next_kid = kid;
20642092
goto do_next;
20652093
}
20662094
else if (kid->op_type == OP_LEAVEWHEN)
20672095
scalar(kid);
2068-
else
2096+
else {
20692097
scalarvoid(kid);
2098+
2099+
if (OP_TYPE_IS(kid, OP_NULL) && !(kid->op_flags & OPf_KIDS)
2100+
&& prev_kid
2101+
) {
2102+
/* This OP is now defunct. Strip it out. */
2103+
if (kid->op_next == kid || kid->op_next == sib) {
2104+
if (prev_kid->op_next == kid)
2105+
prev_kid->op_next = kid->op_next;
2106+
2107+
prev_kid->op_sibparent = kid->op_sibparent;
2108+
op_free(kid); kid = NULL;
2109+
2110+
/* A NEXTSTATE with no sibling OPs is redundant
2111+
* if another NEXTSTATE follows it. Null it out
2112+
* rather than removing it, in case anything needs
2113+
* to probe it for file/line/hints info. */
2114+
if (OP_TYPE_IS(prev_kid, OP_NEXTSTATE) && sib
2115+
&& OP_TYPE_IS(sib, OP_NEXTSTATE)) {
2116+
op_null(prev_kid);
2117+
}
2118+
}
2119+
}
2120+
}
2121+
if (kid)
2122+
prev_kid = kid;
20702123
kid = sib;
20712124
}
2125+
}
20722126
NOT_REACHED; /* NOTREACHED */
20732127
break;
20742128

@@ -2510,8 +2564,40 @@ Perl_scalarvoid(pTHX_ OP *arg)
25102564
* siblings and so on
25112565
*/
25122566
while (!next_kid) {
2513-
if (o == arg)
2567+
if (o == arg) {
2568+
/* at top; no parents/siblings to try */
2569+
2570+
if (OP_TYPE_IS(o, OP_NULL) && o->op_targ == OP_LIST) {
2571+
/* Remove any LIST KIDS that are wholly defunct */
2572+
OP *kid = cLISTOPo->op_first;
2573+
OP *prev_kid = NULL;
2574+
for (; kid; ) {
2575+
if (OP_TYPE_IS(kid, OP_NULL) && !(kid->op_flags & OPf_KIDS)
2576+
&& kid->op_targ != OP_NEXTSTATE
2577+
&& kid->op_targ != OP_DBSTATE
2578+
&& kid->op_targ != OP_PUSHMARK
2579+
) {
2580+
/* This OP_NULL kid can serve no runtime purpose.
2581+
* Splice it out and free its slab slot for reuse. */
2582+
OP *sib = OpSIBLING(kid);
2583+
if (prev_kid) {
2584+
assert(prev_kid->op_next != kid);
2585+
op_sibling_splice(o,prev_kid,1,NULL);
2586+
op_free(kid);
2587+
} else {
2588+
assert(op_parent(kid)->op_next != kid);
2589+
op_sibling_splice(o,NULL,1,NULL);
2590+
op_free(kid);
2591+
}
2592+
kid = sib;
2593+
} else {
2594+
prev_kid = kid;
2595+
kid = OpSIBLING(kid);
2596+
}
2597+
}
2598+
}
25142599
return arg; /* at top; no parents/siblings to try */
2600+
}
25152601
if (OpHAS_SIBLING(o))
25162602
next_kid = o->op_sibparent;
25172603
else
@@ -2692,19 +2778,44 @@ S_voidnonfinal(pTHX_ OP *o)
26922778
type == OP_LEAVE || type == OP_LEAVETRY)
26932779
{
26942780
OP *kid = cLISTOPo->op_first, *sib;
2781+
OP *prev_kid = NULL;
26952782
if(type == OP_LEAVE) {
26962783
/* Don't put the OP_ENTER in void context */
26972784
assert(kid->op_type == OP_ENTER);
2785+
prev_kid = kid;
26982786
kid = OpSIBLING(kid);
26992787
}
2788+
27002789
for (; kid; kid = sib) {
27012790
if ((sib = OpSIBLING(kid))
27022791
&& ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
27032792
|| ( sib->op_targ != OP_NEXTSTATE
27042793
&& sib->op_targ != OP_DBSTATE )))
27052794
{
2795+
/* Note: if kid is an OP_NEXTSTATE, it will be nulled-out,
2796+
but it cannot be spliced out as things stand, because
2797+
Perl_leaveeval() depends on it being there. */
27062798
scalarvoid(kid);
2799+
2800+
if (OP_TYPE_IS(kid, OP_NULL) &&
2801+
!(kid->op_flags & OPf_KIDS) &&
2802+
/* Perl_leaveeval needs an ex-nextstate for its
2803+
feature state information */
2804+
kid->op_targ != OP_NEXTSTATE &&
2805+
kid->op_targ != OP_DBSTATE
2806+
){
2807+
/* This kid is no longer needed. */
2808+
if (prev_kid) {
2809+
assert(prev_kid->op_next != kid);
2810+
op_sibling_splice(o,prev_kid,1,NULL);
2811+
} else {
2812+
assert(op_parent(kid)->op_next != kid);
2813+
op_sibling_splice(o,NULL,1,NULL);
2814+
}
2815+
op_free(kid);
2816+
}
27072817
}
2818+
prev_kid = kid;
27082819
}
27092820
PL_curcop = &PL_compiling;
27102821
}

0 commit comments

Comments
 (0)