From 35c3d59c66dc9276c7b1f8610e944ab41c1bbb6e Mon Sep 17 00:00:00 2001 From: Richard Leach Date: Fri, 20 Dec 2024 17:33:13 +0000 Subject: [PATCH 1/2] op.c/peep.c - Optimise away empty else{} blocks This is a replacement for https://github.com/Perl/perl5/pull/22745, which aimed to prevent the associated `OP_STUB` from being created in `Perl_newCONDOP` and subsequently removed in peep.c. However, doing that turned out to be unavoidable, since it is not safe to omit the `OP_STUB` if it is in scalar context, but `Perl_newCONDOP` runs before context is applied. This commit: * Re-adds the logic in `Perl_op_scope` to not wrap a bare `OP_STUB` in an `ENTER/LEAVE` pair. * Removes any relevant `OP_STUB`s in non-scalar context in `Perl_rpeep`. * Adds B::Deparse support * Adds a test based on the failures seen in https://github.com/Perl/perl5/issues/22866 --- lib/B/Deparse.pm | 25 +++++++++++++++++-------- lib/B/Deparse.t | 4 ++++ op.c | 5 +++++ peep.c | 15 +++++++++++++++ t/op/cond.t | 10 ++++++++++ t/perf/opcount.t | 6 ++++++ 6 files changed, 57 insertions(+), 8 deletions(-) diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 668ab90c7e3c..686055d80611 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -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.85; +package B::Deparse 1.86; use strict; use Carp; use B qw(class main_root main_start main_cv svref_2object opnumber perlstring @@ -4034,13 +4034,22 @@ sub pp_cond_expr { my $true = $cond->sibling; my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; - unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and - (is_scope($false) || is_ifelse_cont($false)) - and $self->{'expand'} < 7) { - $cond = $self->deparse($cond, 8); - $true = $self->deparse($true, 6); - $false = $self->deparse($false, 8); - return $self->maybe_parens("$cond ? $true : $false", $cx, 8); + + if (class($false) eq "NULL") { # Empty else {} block was optimised away + unless ($cx < 1 and (is_scope($true) and $true->name ne "null")) { + $cond = $self->deparse($cond, 8); + $true = $self->deparse($true, 6); + return $self->maybe_parens("$cond ? $true : ()", $cx, 8); + } + } else { # Both true and false branches are present + unless ($cx < 1 and (is_scope($true) and $true->name ne "null") + and (is_scope($false) || is_ifelse_cont($false)) + and $self->{'expand'} < 7) { + $cond = $self->deparse($cond, 8); + $true = $self->deparse($true, 6); + $false = $self->deparse($false, 8); + return $self->maybe_parens("$cond ? $true : $false", $cx, 8); + } } $cond = $self->deparse($cond, 1); diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 6d270234b2ff..2e46e365eeb6 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -3455,3 +3455,7 @@ $_ = (!$p) =~ s/1//r; my($x, $y, $z); $z = 1 + ($x ^^ $y); $z = ($x ^^= $y); +#### +# Else block of a ternary is optimised away +my $x; +my(@y) = $x ? [1, 2] : (); diff --git a/op.c b/op.c index f616532c491c..68b799f09a85 100644 --- a/op.c +++ b/op.c @@ -4524,6 +4524,11 @@ Perl_op_scope(pTHX_ OP *o) { if (o) { if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { + + /* This also makes eliding empty if/else blocks simpler. */ + if (OP_TYPE_IS(o, OP_STUB) && (o->op_flags & OPf_PARENS)) + return o; + o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o); OpTYPE_set(o, OP_LEAVE); diff --git a/peep.c b/peep.c index 5980ea1c2fca..2d658fab2d8b 100644 --- a/peep.c +++ b/peep.c @@ -3588,6 +3588,21 @@ Perl_rpeep(pTHX_ OP *o) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); /* FALLTHROUGH */ case OP_COND_EXPR: + if (o->op_type == OP_COND_EXPR) { + /* Is there an empty "else" block or ternary false branch? + If so, optimise away the OP_STUB if safe to do so. */ + if (o->op_next->op_type == OP_STUB && + ((o->op_next->op_flags & OPf_WANT) != OPf_WANT_SCALAR) + ) { + OP *stub = o->op_next; + assert(stub == OpSIBLING(OpSIBLING( cLOGOP->op_first ))); + assert(!(stub->op_flags & OPf_KIDS)); + o->op_next = stub->op_next; + op_sibling_splice(o, OpSIBLING(cLOGOP->op_first), 1, NULL); + op_free(stub); + } + } + /* FALLTHROUGH */ case OP_MAPWHILE: case OP_ANDASSIGN: case OP_ORASSIGN: diff --git a/t/op/cond.t b/t/op/cond.t index ae381c996712..cd3227a1a09b 100644 --- a/t/op/cond.t +++ b/t/op/cond.t @@ -27,5 +27,15 @@ is( !$x ? 0 : 1, 1, 'run time, false'); is $@, "", "SEGV in Perl_scalar"; } +# [GH #22866] The OP_STUB associated with an empty list should not +# be optimised away if it's in scalar context (as it pushes PL_sv_undef +# to the stack. In that event, these cases will trigger an assert under +# DEBUGGING builds. + +{ + my $x; + $x = ( $x ) ? "JAPH" : (); + $x = ( $x ) ? () : "JAPH"; +} done_testing(); diff --git a/t/perf/opcount.t b/t/perf/opcount.t index 8695e162d16e..1e0921ca39ad 100644 --- a/t/perf/opcount.t +++ b/t/perf/opcount.t @@ -1106,4 +1106,10 @@ test_opcount(0, "substr with const zero offset (gv)", sassign => 1 }); +test_opcount(0, "Empty else{} blocks are optimised away", + sub { my $x; ($x) ? 1 : () }, + { + stub => 0 + }); + done_testing(); From 326e2e29f2d41285d51b39aa39d800b1f9009335 Mon Sep 17 00:00:00 2001 From: Richard Leach Date: Fri, 20 Dec 2024 21:08:41 +0000 Subject: [PATCH 2/2] op.h/op.c/peep.c - Optimise away empty if{} blocks This commit optimises away the OP_STUB associated with an empty `true` branch of an `OP_COND_EXPR`. The `OPf_SPECIAL` flag has been brought into use on the `OP_COND_EXPR` to indicate that it is the `else`, not the `if`, block that has been optimised away. This is purely for the benefit of B::Deparse. --- lib/B/Deparse.pm | 42 +++++++++++++++++++------ lib/B/Deparse.t | 81 +++++++++++++++++++++++++++++++++++++++++++++++- op.h | 2 ++ peep.c | 30 ++++++++++++++++-- t/perf/opcount.t | 6 ++++ 5 files changed, 148 insertions(+), 13 deletions(-) diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 686055d80611..cffcac22b7a5 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -4034,12 +4034,23 @@ sub pp_cond_expr { my $true = $cond->sibling; my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; - - if (class($false) eq "NULL") { # Empty else {} block was optimised away - unless ($cx < 1 and (is_scope($true) and $true->name ne "null")) { - $cond = $self->deparse($cond, 8); - $true = $self->deparse($true, 6); - return $self->maybe_parens("$cond ? $true : ()", $cx, 8); + my $no_true = 0; + + if (class($false) eq "NULL") { # Empty true or false block was optimised away + if (!($op->flags & OPf_SPECIAL)) { # It was an empty true block + my $temp = $false; $false = $true; $true = $temp; + $no_true = 1; + unless ($cx < 1 and (is_scope($false) and $false->name ne "null")) { + $cond = $self->deparse($cond, 8); + $false = $self->deparse($false, 6); + return $self->maybe_parens("$cond ? () : $false", $cx, 8); + } + } else { # Must have been an empty false block + unless ($cx < 1 and (is_scope($true) and $true->name ne "null")) { + $cond = $self->deparse($cond, 8); + $true = $self->deparse($true, 6); + return $self->maybe_parens("$cond ? $true : ()", $cx, 8); + } } } else { # Both true and false branches are present unless ($cx < 1 and (is_scope($true) and $true->name ne "null") @@ -4053,8 +4064,10 @@ sub pp_cond_expr { } $cond = $self->deparse($cond, 1); - $true = $self->deparse($true, 0); - my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}"; + $true = ($no_true) ? "\b" : $self->deparse($true, 0); + my $head = ($no_true) + ? $self->keyword("if") . " ($cond) {\n\t();\n\b}" + : $self->keyword("if") . " ($cond) {\n\t$true\n\b}"; my @elsifs; my $elsif; while (!null($false) and is_ifelse_cont($false)) { @@ -4069,13 +4082,24 @@ sub pp_cond_expr { $newcond = $newcond->first->sibling; } $newcond = $self->deparse($newcond, 1); - $newtrue = $self->deparse($newtrue, 0); + + if (null($false) && ! ($newop->flags & OPf_SPECIAL)) { + # An empty elsif "true" block has been optimised away + my $temp = $false; $false = $newtrue; $newtrue = $temp; + $newtrue = "();"; + } else { + $newtrue = $self->deparse($newtrue, 0); + } + $elsif ||= $self->keyword("elsif"); push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}"; } if (!null($false)) { $false = $cuddle . $self->keyword("else") . " {\n\t" . $self->deparse($false, 0) . "\n\b}\cK"; + } elsif ($op->flags & OPf_SPECIAL) { + $false = $cuddle . $self->keyword("else") . " {\n\t" . + "();\n\b}\cK"; } else { $false = "\cK"; } diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 2e46e365eeb6..2742bf40354d 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -3456,6 +3456,85 @@ my($x, $y, $z); $z = 1 + ($x ^^ $y); $z = ($x ^^= $y); #### -# Else block of a ternary is optimised away +# Empty ? branch of a ternary is optimised away +my $x; +my(@y) = $x ? () : [1, 2]; +#### +# Empty : branch of a ternary is optimised away my $x; my(@y) = $x ? [1, 2] : (); +#### +# Empty if {} block is optimised away +my($x, $y); +if ($x) { + (); +} +else { + $y = 1; +} +#### +# Empty else {} block is optimised away +my($x, $y); +if ($x) { + $y = 1; +} +else { + (); +} +#### +# Empty else {} preceded by an valid elsif +my($x, $y); +if ($x) { + $y = 1; +} +elsif ($y) { + $y = 2; +} +else { + (); +} +#### +# Empty elsif {} with valid else +my($x, $y); +if ($x) { + $y = 1; +} +elsif ($y) { + (); +} else { + $y = 2; +} +#### +# Deparse of empty elsif sandwich (filling) +my($x, $y); +if ($x) { + $y = 1; +} +elsif ($y) { + $y = 3; +} +elsif ($y) { + (); +} +elsif ($y) { + $y = 4; +} else { + $y = 2; +} +#### +# Deparse of empty elsif sandwich (bread) +my($x, $y); +if ($x) { + $y = 1; +} +elsif ($y) { + (); +} +elsif ($y) { + $y = 3; +} +elsif ($y) { + (); +} else { + $y = 2; +} diff --git a/op.h b/op.h index 33bea989456f..ba24ff767172 100644 --- a/op.h +++ b/op.h @@ -164,6 +164,8 @@ Deprecated. Use C instead. /* On OP_RETURN, module_true is in effect */ /* On OP_NEXT/OP_LAST/OP_REDO, there is no * loop label */ + /* On OP_COND_EXPR, indicates that an empty + * "else" condition was optimized away. */ /* 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. */ diff --git a/peep.c b/peep.c index 2d658fab2d8b..99c7cb6bd9f7 100644 --- a/peep.c +++ b/peep.c @@ -3589,14 +3589,38 @@ Perl_rpeep(pTHX_ OP *o) /* FALLTHROUGH */ case OP_COND_EXPR: if (o->op_type == OP_COND_EXPR) { + OP *stub = cLOGOP->op_other; + /* Is there an empty "if" block or ternary true branch? + If so, optimise away the OP_STUB if safe to do so. */ + if (stub->op_type == OP_STUB && + ((stub->op_flags & OPf_WANT) != OPf_WANT_SCALAR) + ) { + OP *trueop = OpSIBLING( cLOGOP->op_first ); + + assert((stub == trueop ) || (OP_TYPE_IS(trueop, OP_SCOPE) && + ((stub == cUNOPx(trueop)->op_first)) && !OpSIBLING(stub)) + ); + assert(!(stub->op_flags & OPf_KIDS)); + + cLOGOP->op_other = (stub->op_next == trueop) ? + stub->op_next->op_next : + stub->op_next; + + op_sibling_splice(o, cLOGOP->op_first, 1, NULL); + + if (stub != trueop) op_free(stub); + op_free(trueop); + } else + /* Is there an empty "else" block or ternary false branch? If so, optimise away the OP_STUB if safe to do so. */ - if (o->op_next->op_type == OP_STUB && - ((o->op_next->op_flags & OPf_WANT) != OPf_WANT_SCALAR) + stub = o->op_next; + if (stub->op_type == OP_STUB && + ((stub->op_flags & OPf_WANT) != OPf_WANT_SCALAR) ) { - OP *stub = o->op_next; assert(stub == OpSIBLING(OpSIBLING( cLOGOP->op_first ))); assert(!(stub->op_flags & OPf_KIDS)); + o->op_flags |= OPf_SPECIAL; /* For B::Deparse */ o->op_next = stub->op_next; op_sibling_splice(o, OpSIBLING(cLOGOP->op_first), 1, NULL); op_free(stub); diff --git a/t/perf/opcount.t b/t/perf/opcount.t index 1e0921ca39ad..19604f314f89 100644 --- a/t/perf/opcount.t +++ b/t/perf/opcount.t @@ -1106,6 +1106,12 @@ test_opcount(0, "substr with const zero offset (gv)", sassign => 1 }); +test_opcount(0, "Empty if{} blocks are optimised away", + sub { my $x; ($x) ? () : 1 }, + { + stub => 0 + }); + test_opcount(0, "Empty else{} blocks are optimised away", sub { my $x; ($x) ? 1 : () }, {