In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/bec5a1ba1ddeb36f189da30307757fead2933e93?hp=12e1fa63201ac1c5e2c5ecb94649c3ac6af7b057>
- Log ----------------------------------------------------------------- commit bec5a1ba1ddeb36f189da30307757fead2933e93 Merge: 12e1fa6320 b243b19395 Author: David Mitchell <[email protected]> Date: Fri Jan 6 16:28:50 2017 +0000 [MERGE] redo boolean context Overhaul the stuff that flags an op as being in boolean context (currently just padhv and rv2hv). Make the mechanism in rpeep() general, so that other ops can be easily added in future, and add a generic testing framework for such ops in t/perf/optree.t. This alters the amount on situations recognised as being in boolean context (mainly increasing them). commit b243b19395066bedc2a6dc3051cd0678692aa7d5 Author: David Mitchell <[email protected]> Date: Fri Jan 6 11:35:11 2017 +0000 In A && B, stop special-casing boolean-ness of A Some ops, (currently PADHV and RV2HV) can be flagged as being in boolean context, and if so, may return a simple truth value which may be more efficient to calculate than a full scalar value. (This was originally motivated by code like if (%h) {...}, where the scalar context %h returned a bucket ratio string, which involved counting how many HvARRAY buckets were non-empty, which was slow in large hashes. It's been made less important since %h in scalar context now just returns a key count, which is quick to calculate.) There is an issue with the A argument of A||B, A//B and A&&B, in that, although A checked by the logop in boolean context, depending on its truth value the original A may be passed through to the next op. So in something like $x = (%h || -1), it's not sufficient for %h to return a truth value; it must return a full scalar value which may get assigned to $x. So in general, we only mark the A op as being in boolean context if the logop is in void context, or if the returned A would only be consumed in boolean context; so !(A||B) would be ok for example. However, && is a special case of this, since it will return the original A only if A was false. Before this commit, && was special-cased to mark A as being in boolean context regardless of the context of (A&&B). The downside of this is that the A op can't just return &PL_sv_no as a false value; it has to return something that is usable in scalar context too. For example with %h, it returns sv_2mortal(newSViv(0))), which stringifies to "0" while &PL_sv_no stringifies to "". This commit removes that special case and makes && behave like || and // again. The upside is that some ops in boolean context will be able to more cheaply return a false value (e.g. just &PL_sv_no verses sv_2mortal(newSViv(0))). The main downside is that && in unknown context (typically an 'if (%h} {...}' as the last statement in a sub) will have to check at runtime whether the caller context is slower. It will also have to return a scalar value for something like $y = (%h && $x), but that's a relatively uncommon occurrence, and now that %h in scalar context doesn't have to count used buckets, the extra cost in these rare cases is minor. M op.c M pp.c M pp_hot.c M t/perf/optree.t commit 9d692a7f83cf8fe36c59aaa07bca533887350e9b Author: David Mitchell <[email protected]> Date: Wed Jan 4 23:50:14 2017 +0000 add xor, grep, flip, flop to boolean cxt detection The code that detects whether certain ops (currently just PADHV and RV2HV) are called in boolean context only recognises a few ops as providing boolean context: NOT, OR, DOR, AND, COND_EXPR. This commit expands this by adding GREPWHILE, FLIP, FLOP, XOR too (in the case of XOR it only applies to the RHS arg - the LHS is not simple to detect). This means that in something like @AofH_nonempty = grep %$_, @AofH the test for each hash being non-empty will now be done in boolean rather than full scalar context, so may be faster. Similarly (although less excitingly) these hash key counts are also boolean now: %hash .. $other; $other .. %hash; $other xor %hash; (I basically did a grep for 'SvTRUE' in pp*.c to see what other ops might be imposing boolean context.) Since this has been added to the general boolean context detection mechanism, it will also apply for any future ops with are 'booleanised'. M op.c M t/perf/optree.t commit 2ee1faad3521a3f4af605ff9c9242b912259f946 Author: David Mitchell <[email protected]> Date: Wed Jan 4 21:22:21 2017 +0000 reindent block in rpeep() (whitespace-only change) The code for the case OP_PADAV/OP_PADSV was too far left. M op.c commit b0e8c18f9f49fea18c28b17e25b09dc7e7244da8 Author: David Mitchell <[email protected]> Date: Wed Jan 4 20:27:55 2017 +0000 re-implement boolean context detection When certain ops are used in a boolean context (currently just PADHV and RV2SV, implementing '%hash'), one of the private flags OPpTRUEBOOL or OPpMAYBE_TRUEBOOL is set on the op to indicate this; at runtime, the pp function can then just return a boolean value rather than a full scalar value (in the case of %hash, an element count). However, the code which sets these flags has had a complex history, and is a bit messy. It also sets the flags incorrectly (but safely) in many cases: principally indicating boolean context when it's in fact void, or scalar context when it's in fact boolean. Both these permutations make the code potentially slower (but still correct). [ As a side-note: in 5.25, a bare %hash in scalar context changed from returning a bucket count etc, to just returning a key count, which is quicker to calculate. So the boolean optimisation for %hash is not nearly as important now: it's now just the overhead of creating a temp to return a count verses returning &PL_sv_yes, rather than counting keys. However the improved and generalised boolean context detection added by this commit will be useful in future to apply boolean context to other ops. ] In particular, this wasn't being optimised (i.e. a 'not' of a hash within an if): if (!%hash) { ...} This commit fixes all these cases (and uncomments a load of failing tests in t/perf/optree.t which were added in the previous commit.) It makes the code below nearly 3 times faster: my $c; my %h = 1..10; for my $i (1..10_000_000) { if (!%h) { $c++ }; } It restructures the relevant code in rpeep() so that rather than switching on logops like OP_OR, then seeing if that op is preceded by PADHV/RV2HV, it instead switches on PADHV/RV2HV then sees if succeeding ops impose boolean context on that op - that is to say, in all possible execution paths after the PADHV/RV2HV pushes a scalar onto the stack, will that scalar only ever be used for a boolean test? (*). The scanning of succeeding ops is extracted out into a static function. This will make it very easy in future to apply boolean context to other ops too, or to expand the definition of boolean context (e.g. adding 'xor'). (*) Although in theory an expression like (A && B) can return A if A is false, if A happens to be %hash, and as long as pp_padhv() etc return a boolean false value that is also usable in scalar context (so it returns 0 rather than PL_sv_no), then we can pretend that OP_AND's LH arg is never used as a scalar. M op.c M pp.c M pp_hot.c M t/perf/optree.t commit 7adc03cc2c3385edc73d0522a46a24e1eeda3a27 Author: David Mitchell <[email protected]> Date: Wed Jan 4 19:07:46 2017 +0000 add testing framework for boolean context Some ops (currently just padhv and rv2hv) are optimised when found to be in boolean context - by setting a private flag on the op indicating definite or maybe boolean context. At run time, the op can just return true / false rather than a real value, which may be cheaper. This commit adds a bunch of tests in nested loops to optree.t to check that the right private flags are set for the various permutations of if (%h || $x) { ...} etc. It's written in such a way that its easy to add new ops to it. At the moment many permutations are actually commented out, as these (fairly comprehensive) tests show up a number of deficiencies in the current implementation. These should be fixed in the next commit. M t/perf/benchmarks M t/perf/optree.t commit 7bb1f299d1f77bc5ec7502eca5cdb98a9bdc9550 Author: David Mitchell <[email protected]> Date: Wed Jan 4 09:16:51 2017 +0000 t/perf/optree.t: add use warnings, strict M t/perf/optree.t ----------------------------------------------------------------------- Summary of changes: op.c | 160 ++++++++++++++++++++--------------- pp.c | 2 +- pp_hot.c | 2 +- t/perf/benchmarks | 12 +++ t/perf/optree.t | 245 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 5 files changed, 345 insertions(+), 76 deletions(-) diff --git a/op.c b/op.c index 339a9ce267..919e8ed514 100644 --- a/op.c +++ b/op.c @@ -13383,6 +13383,79 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) } /* for (pass = ...) */ } +/* See if the ops following o are such that o will always be executed in + * boolean context: that is, the SV which o pushes onto the stack will + * only ever be used by later ops with SvTRUE(sv) or similar. + * If so, set a suitable private flag on o. Normally this will be + * bool_flag; but if it's only possible to determine booleaness at run + * time (e.g. sub f { ....; (%h || $y) }), then set maybe_flag instead. + */ + +static void +S_check_for_bool_cxt(pTHX_ OP*o, U8 bool_flag, U8 maybe_flag) +{ + OP *lop; + + assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR); + + lop = o->op_next; + + while (lop) { + switch (lop->op_type) { + case OP_NULL: + case OP_SCALAR: + break; + + /* these two consume the stack argument in the scalar case, + * and treat it as a boolean in the non linenumber case */ + case OP_FLIP: + case OP_FLOP: + if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST) + || (lop->op_private & OPpFLIP_LINENUM)) + { + lop = NULL; + break; + } + /* FALLTHROUGH */ + /* these never leave the original value on the stack */ + case OP_NOT: + case OP_XOR: + case OP_COND_EXPR: + case OP_GREPWHILE: + o->op_private |= bool_flag; + lop = NULL; + break; + + /* OR DOR and AND evaluate their arg as a boolean, but then may + * leave the original scalar value on the stack when following the + * op_next route. If not in void context, we need to ensure + * that whatever follows consumes the arg only in boolean context + * too. + */ + case OP_OR: + case OP_DOR: + case OP_AND: + if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) { + o->op_private |= bool_flag; + lop = NULL; + } + else if (!(lop->op_flags & OPf_WANT)) { + /* unknown context - decide at runtime */ + o->op_private |= maybe_flag; + lop = NULL; + } + break; + + default: + lop = NULL; + break; + } + + if (lop) + lop = lop->op_next; + } +} + /* mechanism for deferring recursion in rpeep() */ @@ -13418,8 +13491,6 @@ Perl_rpeep(pTHX_ OP *o) OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ int defer_base = 0; int defer_ix = -1; - OP *fop; - OP *sop; if (!o || o->op_opt) return; @@ -14114,19 +14185,26 @@ Perl_rpeep(pTHX_ OP *o) break; } + case OP_RV2HV: + case OP_PADHV: + /* see if %h is used in boolean context */ + if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) + S_check_for_bool_cxt(aTHX_ o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); + if (o->op_type != OP_PADHV) + break; + /* FALLTHROUGH */ case OP_PADAV: case OP_PADSV: - case OP_PADHV: - /* Skip over state($x) in void context. */ - if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) - && (o->op_flags & OPf_WANT) == OPf_WANT_VOID) - { - oldop->op_next = o->op_next; - goto redo_nextstate; - } - if (o->op_type != OP_PADAV) - break; - /* FALLTHROUGH */ + /* Skip over state($x) in void context. */ + if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) + && (o->op_flags & OPf_WANT) == OPf_WANT_VOID) + { + oldop->op_next = o->op_next; + goto redo_nextstate; + } + if (o->op_type != OP_PADAV) + break; + /* FALLTHROUGH */ case OP_GV: if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { OP* const pop = (o->op_type == OP_PADAV) ? @@ -14206,25 +14284,12 @@ Perl_rpeep(pTHX_ OP *o) break; -#define HV_OR_SCALARHV(op) \ - ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \ - ? (op) \ - : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \ - && ( cUNOPx(op)->op_first->op_type == OP_PADHV \ - || cUNOPx(op)->op_first->op_type == OP_RV2HV) \ - ? cUNOPx(op)->op_first \ - : NULL) - case OP_NOT: - if ((fop = HV_OR_SCALARHV(cUNOP->op_first))) - fop->op_private |= OPpTRUEBOOL; break; case OP_AND: case OP_OR: case OP_DOR: - fop = cLOGOP->op_first; - sop = OpSIBLING(fop); while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; while (o->op_next && ( o->op_type == o->op_next->op_type @@ -14246,53 +14311,10 @@ Perl_rpeep(pTHX_ OP *o) o->op_next = ((LOGOP*)o->op_next)->op_other; } DEFER(cLOGOP->op_other); - o->op_opt = 1; - fop = HV_OR_SCALARHV(fop); - if (sop) sop = HV_OR_SCALARHV(sop); - if (fop || sop - ){ - OP * nop = o; - OP * lop = o; - if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) { - while (nop && nop->op_next) { - switch (nop->op_next->op_type) { - case OP_NOT: - case OP_AND: - case OP_OR: - case OP_DOR: - lop = nop = nop->op_next; - break; - case OP_NULL: - nop = nop->op_next; - break; - default: - nop = NULL; - break; - } - } - } - if (fop) { - if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID - || o->op_type == OP_AND ) - fop->op_private |= OPpTRUEBOOL; - else if (!(lop->op_flags & OPf_WANT)) - fop->op_private |= OPpMAYBE_TRUEBOOL; - } - if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID - && sop) - sop->op_private |= OPpTRUEBOOL; - } - - break; case OP_COND_EXPR: - if ((fop = HV_OR_SCALARHV(cLOGOP->op_first))) - fop->op_private |= OPpTRUEBOOL; -#undef HV_OR_SCALARHV - /* GERONIMO! */ /* FALLTHROUGH */ - case OP_MAPWHILE: case OP_GREPWHILE: case OP_ANDASSIGN: diff --git a/pp.c b/pp.c index c015bfe8a6..adda6c9945 100644 --- a/pp.c +++ b/pp.c @@ -150,7 +150,7 @@ PP(pp_padhv) && block_gimme() == G_VOID )) && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)) ) - SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0))); + SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : &PL_sv_no); else if (gimme == G_SCALAR) { SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG)); SETs(sv); diff --git a/pp_hot.c b/pp_hot.c index ec3afe4dd9..aeaecfc3df 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1039,7 +1039,7 @@ PP(pp_rv2av) || ( PL_op->op_private & OPpMAYBE_TRUEBOOL && block_gimme() == G_VOID )) && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied))) - SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0))); + SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : &PL_sv_no); else if (gimme == G_SCALAR) { dTARG; TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv)); diff --git a/t/perf/benchmarks b/t/perf/benchmarks index ac698500e3..233f1fbdc5 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -301,6 +301,18 @@ code => 'exists $h{$k1}{$k2}', }, + 'expr::hash::bool_empty' => { + desc => 'empty lexical hash in boolean context', + setup => 'my %h;', + code => '!%h', + }, + 'expr::hash::bool_full' => { + desc => 'non-empty lexical hash in boolean context', + setup => 'my %h = 1..10;', + code => '!%h', + }, + + ( map { sprintf('expr::hash::notexists_lex_keylen%04d',$_) => { diff --git a/t/perf/optree.t b/t/perf/optree.t index 49959ce666..61eefd1a4c 100644 --- a/t/perf/optree.t +++ b/t/perf/optree.t @@ -3,6 +3,9 @@ # Use B to test that optimisations are not inadvertently removed, # by examining particular nodes in the optree. +use warnings; +use strict; + BEGIN { chdir 't'; require './test.pl'; @@ -10,13 +13,15 @@ BEGIN { @INC = '../lib'; } -plan 59; +plan 695; use v5.10; # state use B qw(svref_2object OPpASSIGN_COMMON_SCALAR OPpASSIGN_COMMON_RC1 OPpASSIGN_COMMON_AGG + OPpTRUEBOOL + OPpMAYBE_TRUEBOOL ); @@ -80,11 +85,18 @@ for my $test ( [ "---", '@a = (split(//, @a), 1)', 'split(@a)' ], [ "--A", 'my @a; my $ar = @a; @a = (@$ar = split())', 'a/ar split' ], ) { + my ($exp, $code, $desc) = @$test; - my $sub = eval "sub { $code }" - or die - "aassign eval('$code') failed: this test needs to be rewritten:\n" - . $@; + my $sub; + { + # package vars used in code snippets + our (@a, %a, @b, %b, $c, $p, $q, $x, $y, @y, @z); + + $sub = eval "sub { $code }" + or die + "aassign eval('$code') failed: this test needs" + . "to be rewritten:\n$@" + } my $last_expr = svref_2object($sub)->ROOT->first->last; if ($last_expr->name ne 'aassign') { @@ -183,3 +195,226 @@ for(['@pkgary' , '@_' ], # stringify with join kid --> join is svref_2object(sub { "@_" })->ROOT->first->last->name, 'join', 'qq"@_" optimised from stringify(join(...)) to join(...)'; + + +# Check that certain ops, when in boolean context, have the +# right private "is boolean" or "maybe boolean" flags set. +# +# A maybe flag is set when the context at the end of a chain of and/or/dor +# ops isn't known till runtime, e.g. +# sub f { ....; ((%h || $x) || $y)) } +# If f() is called in void context, then %h can return a boolean value; +# if in scalar context, %h must return a key count. +# +# With (op && other), its ok to treat op as in bool cxt even when the && +# is in scalar cxt, as long as whatever op returns as a false boolean value +# matches what it returns as a false scalar value (IV(0) in the case of +# rv2hv etc). This is because in (A && B), A is returned only when A is +# false. + +for my $ops ( + # op code op path flag maybe flag + [ 'rv2hv', '%pkg', [], OPpTRUEBOOL, OPpMAYBE_TRUEBOOL ], + [ 'rv2hv', 'scalar(%pkg)', [0], OPpTRUEBOOL, OPpMAYBE_TRUEBOOL ], + [ 'padhv', '%lex', [], OPpTRUEBOOL, OPpMAYBE_TRUEBOOL ], + [ 'padhv', 'scalar(%lex)', [0], OPpTRUEBOOL, OPpMAYBE_TRUEBOOL ], +) { + my ($op_name, $op_code, $post_op_path, $bool_flag, $maybe_flag) = @$ops; + + for my $test ( + # 1st column: what to expect for each $context (void, scalar, unknown), + # 0: expect no flag + # 1: expect bool flag + # 2: expect maybe bool flag + # 9: skip test + # 2nd column: path though the op subtree to the flagged op: + # 0 is first child, 1 is second child etc. + # Will have @$post_op_path from above appended. + # 3rd column: code to execute: %s holds the code for the op + # + # [V S U] PATH CODE + + # INNER PLAIN + + [ [0,0,0], [], '%s' ], + [ [1,9,2], [0,0], 'if (%s) {$x}' ], + [ [1,9,1], [0,0], 'if (%s) {$x} else {$y}' ], + [ [1,9,2], [0,0], 'unless (%s) {$x}' ], + + # INNER NOT + + [ [1,1,1], [0], '!%s' ], + [ [1,9,1], [0,0,0], 'if (!%s) {$x}' ], + [ [1,9,1], [0,0,0], 'if (!%s) {$x} else {$y}' ], + [ [1,9,1], [0,0,0], 'unless (!%s) {$x}' ], + + # INNER COND + + [ [1,1,1], [0,0,], '%s ? $p : $q' ], + [ [1,9,1], [0,0,0,0], 'if (%s ? $p : $q) {$x}' ], + [ [1,9,1], [0,0,0,0], 'if (%s ? $p : $q) {$x} else {$y}' ], + [ [1,9,1], [0,0,0,0], 'unless (%s ? $p : $q) {$x}' ], + + + # INNER OR LHS + + [ [1,0,2], [0,0], '%s || $x' ], + [ [1,1,1], [0,0,0], '!(%s || $x)' ], + [ [1,0,2], [0,1,0,0], '$y && (%s || $x)' ], + [ [1,9,2], [0,0,0,0], 'if (%s || $x) {$x}' ], + [ [1,9,1], [0,0,0,0], 'if (%s || $x) {$x} else {$y}' ], + [ [1,9,2], [0,0,0,0], 'unless (%s || $x) {$x}' ], + + # INNER OR RHS + + [ [0,0,0], [0,1], '$x || %s' ], + [ [1,1,1], [0,0,1], '!($x || %s)' ], + [ [0,0,0], [0,1,0,1], '$y && ($x || %s)' ], + [ [1,9,2], [0,0,0,1], 'if ($x || %s) {$x}' ], + [ [1,9,1], [0,0,0,1], 'if ($x || %s) {$x} else {$y}' ], + [ [1,9,2], [0,0,0,1], 'unless ($x || %s) {$x}' ], + + # INNER DOR LHS + + [ [1,0,2], [0,0], '%s // $x' ], + [ [1,1,1], [0,0,0], '!(%s // $x)' ], + [ [1,0,2], [0,1,0,0], '$y && (%s // $x)' ], + [ [1,9,2], [0,0,0,0], 'if (%s // $x) {$x}' ], + [ [1,9,1], [0,0,0,0], 'if (%s // $x) {$x} else {$y}' ], + [ [1,9,2], [0,0,0,0], 'unless (%s // $x) {$x}' ], + + # INNER DOR RHS + + [ [0,0,0], [0,1], '$x // %s' ], + [ [1,1,1], [0,0,1], '!($x // %s)' ], + [ [0,0,0], [0,1,0,1], '$y && ($x // %s)' ], + [ [1,9,2], [0,0,0,1], 'if ($x // %s) {$x}' ], + [ [1,9,1], [0,0,0,1], 'if ($x // %s) {$x} else {$y}' ], + [ [1,9,2], [0,0,0,1], 'unless ($x // %s) {$x}' ], + + # INNER AND LHS + + [ [1,0,2], [0,0], '%s && $x' ], + [ [1,1,1], [0,0,0], '!(%s && $x)' ], + [ [1,0,2], [0,1,0,0], '$y || (%s && $x)' ], + [ [1,9,2], [0,0,0,0], 'if (%s && $x) {$x}' ], + [ [1,9,1], [0,0,0,0], 'if (%s && $x) {$x} else {$y}' ], + [ [1,9,2], [0,0,0,0], 'unless (%s && $x) {$x}' ], + + # INNER AND RHS + + [ [0,0,0], [0,1], '$x && %s' ], + [ [1,1,1], [0,0,1], '!($x && %s)' ], + [ [0,0,0], [0,1,0,1], '$y || ($x && %s)' ], + [ [1,9,2], [0,0,0,1], 'if ($x && %s) {$x}' ], + [ [1,9,1], [0,0,0,1], 'if ($x && %s) {$x} else {$y}' ], + [ [1,9,2], [0,0,0,1], 'unless ($x && %s) {$x}' ], + + # INNER XOR LHS + + # LHS of XOR is currently too hard to detect as + # being in boolean context + + # INNER XOR RHS + + [ [1,1,1], [1], '($x xor %s)' ], + [ [1,1,1], [0,1], '!($x xor %s)' ], + [ [1,1,1], [0,1,1], '$y || ($x xor %s)' ], + [ [1,9,1], [0,0,1], 'if ($x xor %s) {$x}' ], + [ [1,9,1], [0,0,1], 'if ($x xor %s) {$x} else {$y}' ], + [ [1,9,1], [0,0,1], 'unless ($x xor %s) {$x}' ], + + # GREP + + [ [1,1,1], [0,1,0], 'grep %s,1,2' ], + [ [1,1,1], [0,1,0,0], 'grep !%s,1,2' ], + [ [1,1,1], [0,1,0,0,1],'grep $y || %s,1,2' ], + + # FLIP + + [ [1,1,1], [0,0,0,0], '%s..$x' ], + [ [1,1,1], [0,0,0,0,0], '!%s..$x' ], + [ [1,1,1], [0,0,0,0,0,1], '($y || %s)..$x' ], + + # FLOP + + [ [1,1,1], [0,0,0,1], '$x..%s' ], + [ [1,1,1], [0,0,0,1,0], '$x..!%s' ], + [ [1,1,1], [0,0,0,1,0,1], '$x..($y || %s)' ], + + ) { + my ($expects, $op_path, $code_fmt) = @$test; + + for my $context (0,1,2) { + # 0: void + # 1: scalar + # 2: unknown + # 9: skip test (principally if() can't be in scalar context) + + next if $expects->[$context] == 9; + + my $base_code = sprintf $code_fmt, $op_code; + my $code = $base_code; + my @op_path = @$op_path; + push @op_path, @$post_op_path; + + # where to find the expression in the top-level lineseq + my $seq_offset = -1; + + if ($context == 0) { + $seq_offset -= 2; + $code .= "; 1"; + } + elsif ($context == 1) { + $code = "\$r = ($code)"; + unshift @op_path, 0; + } + + + my $sub; + { + our (%pkg); + my (%lex, $p, $q, $r, $x, $y); + + no warnings 'void'; + $sub = eval "sub { $code }" + or die + "eval'$code' failed: this test needs to be rewritten;\n" + . "Errors were:\n$@"; + } + + # find the expression subtree in the main lineseq of the sub + my $expr = svref_2object($sub)->ROOT->first; + my @ops; + my $next = $expr->first; + while ($$next) { + push @ops, $next; + $next = $next->sibling; + } + $expr = $ops[$seq_offset]; + + # search through the expr subtree looking for the named op - + # this assumes that for all the code examples above, the + # op is always in the LH branch + while (defined (my $p = shift @op_path)) { + $expr = $expr->first; + $expr = $expr->sibling while $p--; + } + + if (!$expr || $expr->name ne $op_name) { + die "Can't find $op_name op in optree for '$code'; " + . "this test needs to be rewritten" + } + + my $exp = $expects->[$context]; + $exp = $exp == 0 ? 0 + : $exp == 1 ? $bool_flag + : $maybe_flag; + + my $got = ($expr->private & ($bool_flag | $maybe_flag)); + my $cxt_name = ('void ', 'scalar ', 'unknown')[$context]; + is $got, $exp, "boolean: $op_name $cxt_name '$base_code'"; + } + } +} + -- Perl5 Master Repository
