diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 668ab90c7e3c..cffcac22b7a5 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,18 +4034,40 @@ 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); + 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") + 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); - $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)) { @@ -4060,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 6d270234b2ff..2742bf40354d 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -3455,3 +3455,86 @@ $_ = (!$p) =~ s/1//r; my($x, $y, $z); $z = 1 + ($x ^^ $y); $z = ($x ^^= $y); +#### +# 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.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/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 5980ea1c2fca..99c7cb6bd9f7 100644 --- a/peep.c +++ b/peep.c @@ -3588,6 +3588,45 @@ 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) { + 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. */ + stub = o->op_next; + if (stub->op_type == OP_STUB && + ((stub->op_flags & OPf_WANT) != OPf_WANT_SCALAR) + ) { + 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); + } + } + /* 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..19604f314f89 100644 --- a/t/perf/opcount.t +++ b/t/perf/opcount.t @@ -1106,4 +1106,16 @@ 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 : () }, + { + stub => 0 + }); + done_testing();