Skip to content

Remove defunct OPs in Perl_scalar/Perl_scalarvoid #23890

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 1 commit into
base: blead
Choose a base branch
from
+132 −10
Open

Remove defunct OPs in Perl_scalar/Perl_scalarvoid #23890

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
12 changes: 11 additions & 1 deletion lib/B/Deparse.pm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@
# This is based on the module of the same name by Malcolm Beattie,
# but essentially none of his code remains.

package B::Deparse 1.88;
package B::Deparse 1.89;
use strict;
use builtin qw( true false );
use Carp;
Expand Down Expand Up @@ -2419,6 +2419,16 @@ sub pp_nextstate {

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

my $text = join("", @text);

if ($text eq '' && class($op->sibling) ne 'NULL'
&& $op->sibling->name eq 'unstack' &&
($op->flags & OPf_WANT_VOID)) {
# An OP in void context was optimized away.
# Substitute in an empty list for deparsing.
return "()";
}

return join("", @text);
}

Expand Down
7 changes: 1 addition & 6 deletions lib/B/Deparse.t
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -122,7 +122,7 @@ BEGIN { $/ = "\n"; $\ = "\n"; }
LINE: while (defined($_ = readline ARGV)) {
chomp $_;
our(@F) = split(' ', $_, 0);
'???';
();
}
EOF
$b =~ s/our\\\(\\\@F\\\)/our[( ]\@F\\)?/; # accept both our @F and our(@F)
Expand Down Expand Up @@ -683,7 +683,6 @@ tr/\x{345}/\x{370}/;
# Constants in a block
# CONTEXT no warnings;
{
'???';
2;
}
####
Expand All @@ -692,7 +691,6 @@ tr/\x{345}/\x{370}/;
(1,2,3);
0;
>>>>
'???', '???', '???';
0;
####
# Lexical and simple arithmetic
Expand Down Expand Up @@ -1271,7 +1269,6 @@ if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
>>>>
x();
x();
'???';
x();
x();
x();
Expand All @@ -1294,11 +1291,9 @@ do {
do {
x()
};
'???';
do {
t()
};
'???';
!1;
####
# TODO constant deparsing has been backed out for 5.12
Expand Down
117 changes: 114 additions & 3 deletions op.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2047,7 +2047,8 @@ Perl_scalar(pTHX_ OP *o)
kid = cLISTOPo->op_first;
scalar(kid);
kid = OpSIBLING(kid);
do_kids:
do_kids: {
OP * prev_kid = NULL;
while (kid) {
OP *sib = OpSIBLING(kid);
/* Apply void context to all kids except the last, which
Expand All @@ -2069,16 +2070,69 @@ Perl_scalar(pTHX_ OP *o)
)
)
{

if (OP_TYPE_IS(o, OP_LIST) && !op_parent(o)) {
/* Is the list now just an obvious scalar pushop?
* <@> list sKP ->6
* <0> pushmark v ->4
* <$> const(IV 3) s ->5
*/
OP* first = cLISTOPo->op_first;
assert(OP_TYPE_IS(first, OP_PUSHMARK));
OP* sib1 = OpSIBLING(first);
assert(sib1);
OP* sib2 = OpSIBLING(sib1);
if (!sib2) {
if (
PL_opargs[sib1->op_type] & OA_RETSCALAR
){
assert(sib1->op_next == sib1);
/* Yup. The PUSHMARK and LIST are redundant.
* They can be stripped out. */
op_sibling_splice(o,first,1,NULL);
op_free(o);
return sib1;
}
}
}

/* tail call optimise calling scalar() on the last kid */
assert(kid);
next_kid = kid;
goto do_next;
}
else if (kid->op_type == OP_LEAVEWHEN)
scalar(kid);
else
else {
scalarvoid(kid);

if (OP_TYPE_IS(kid, OP_NULL) && !(kid->op_flags & OPf_KIDS)
&& prev_kid
) {
/* This OP is now defunct. Strip it out. */
if (kid->op_next == kid || kid->op_next == sib) {
if (prev_kid->op_next == kid)
prev_kid->op_next = kid->op_next;

prev_kid->op_sibparent = kid->op_sibparent;
op_free(kid); kid = NULL;

/* A NEXTSTATE with no sibling OPs is redundant
* if another NEXTSTATE follows it. Null it out
* rather than removing it, in case anything needs
* to probe it for file/line/hints info. */
if (OP_TYPE_IS(prev_kid, OP_NEXTSTATE) && sib
&& OP_TYPE_IS(sib, OP_NEXTSTATE)) {
op_null(prev_kid);
}
}
}
}
if (kid)
prev_kid = kid;
kid = sib;
}
}
NOT_REACHED; /* NOTREACHED */
break;

Expand Down Expand Up @@ -2523,8 +2577,40 @@ Perl_scalarvoid(pTHX_ OP *arg)
* siblings and so on
*/
while (!next_kid) {
if (o == arg)
if (o == arg) {
/* at top; no parents/siblings to try */

if (OP_TYPE_IS(o, OP_NULL) && o->op_targ == OP_LIST) {
/* Remove any LIST KIDS that are wholly defunct */
OP *kid = cLISTOPo->op_first;
OP *prev_kid = NULL;
for (; kid; ) {
if (OP_TYPE_IS(kid, OP_NULL) && !(kid->op_flags & OPf_KIDS)
&& kid->op_targ != OP_NEXTSTATE
&& kid->op_targ != OP_DBSTATE
&& kid->op_targ != OP_PUSHMARK
) {
/* This OP_NULL kid can serve no runtime purpose.
* Splice it out and free its slab slot for reuse. */
OP *sib = OpSIBLING(kid);
if (prev_kid) {
assert(prev_kid->op_next != kid);
op_sibling_splice(o,prev_kid,1,NULL);
op_free(kid);
} else {
assert(op_parent(kid)->op_next != kid);
op_sibling_splice(o,NULL,1,NULL);
op_free(kid);
}
kid = sib;
} else {
prev_kid = kid;
kid = OpSIBLING(kid);
}
}
}
return arg; /* at top; no parents/siblings to try */
}
if (OpHAS_SIBLING(o))
next_kid = o->op_sibparent;
else
Expand Down Expand Up @@ -2705,19 +2791,44 @@ S_voidnonfinal(pTHX_ OP *o)
type == OP_LEAVE || type == OP_LEAVETRY)
{
OP *kid = cLISTOPo->op_first, *sib;
OP *prev_kid = NULL;
if(type == OP_LEAVE) {
/* Don't put the OP_ENTER in void context */
assert(kid->op_type == OP_ENTER);
prev_kid = kid;
kid = OpSIBLING(kid);
}

for (; kid; kid = sib) {
if ((sib = OpSIBLING(kid))
&& ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
|| ( sib->op_targ != OP_NEXTSTATE
&& sib->op_targ != OP_DBSTATE )))
{
/* Note: if kid is an OP_NEXTSTATE, it will be nulled-out,
but it cannot be spliced out as things stand, because
Perl_leaveeval() depends on it being there. */
scalarvoid(kid);

if (OP_TYPE_IS(kid, OP_NULL) &&
!(kid->op_flags & OPf_KIDS) &&
/* Perl_leaveeval needs an ex-nextstate for its
feature state information */
kid->op_targ != OP_NEXTSTATE &&
kid->op_targ != OP_DBSTATE
){
/* This kid is no longer needed. */
if (prev_kid) {
assert(prev_kid->op_next != kid);
op_sibling_splice(o,prev_kid,1,NULL);
} else {
assert(op_parent(kid)->op_next != kid);
op_sibling_splice(o,NULL,1,NULL);
}
op_free(kid);
}
}
prev_kid = kid;
}
PL_curcop = &PL_compiling;
}
Expand Down
6 changes: 6 additions & 0 deletions pod/perldelta.pod
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -363,6 +363,12 @@ well.

=item *

Simple individual OPs or LISTs rendered redundant by the application of scalar
or void context during compilation are now more likely to be spliced out of
the compiling optree and freed. [GH #23890]

=item *

XXX

=back
Expand Down
Loading