In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c1a6686e7b19b19f65ba89a90c0f0bf57606197f?hp=0283ad960acb937e9387b3323f1f7852c2adb0fa>
- Log ----------------------------------------------------------------- commit c1a6686e7b19b19f65ba89a90c0f0bf57606197f Merge: 0283ad960a cd5acddbd8 Author: David Mitchell <[email protected]> Date: Thu Jul 27 11:30:50 2017 +0100 [MERGE] various boolean-related optimisations This branch contains about 50 commits, which collectively optimise various aspects of perl's behaviour when detailing with boolean values or ops that are called in boolean context. The main changes are: * A &PL_sv_zero variable has been added. This is a new per-interpreter immortal SV, very similar to &PL_sv_no, except that it has a string value of "0" rather than "". As well as being directly usable in cases where code might otherwise need to do newSViv(0), it has a more subtle use in ops that handle boolean context directly. For example in sub f { ....; if (%h) { .... } } the 'if' statement is compiled using OP_AND, so is equivalent to %h && do { .... } If %h is empty, then the result of the boolean expression should be 0 rather than &PL_sv_no, and this value gets returned to the caller, which may expect a scalar result: and what it expects won't be known until run time. So by returning &PL_sv_yes and &PL_sv_zero rather than yes and no, we increase the number of places where it is safe to return a boolean value. A downside of &PL_sv_zero is that if assigned to a variable, that variable gets int, num and string values rather than just an int value. * SvTRUE() is now more efficient. This macro is called in places like pp_and, pp_not etc. It has a long list of conditions which it goes through to determine the truthiness of an SV, such as whether it has a string value, and if so whether the length is zero, or the length is 1 and the string's value is "0". It turns out that the immortals like &PL_sv_yes fare really badly here: they have to go through nearly every check to finally determine their value. To get round this, I have made it very quick to check whether an SV is one of the immortals, and if so whether it is true. This has been done by ensuring that PL_sv_undef, PL_sv_no, PL_sv_zero and PL_sv_yes are all contiguous in memory, so that a quick single address comparison is enough to determine immortality, and then comparing the address against &PL_sv_yes is enough to determine whether its true. In particular in non-multiplicity builds, PL_sv_undef etc have been replaced with the array PL_sv_immortals[4], with PL_sv_undef #defed to PL_sv_immortals[0] etc. Also, the SvOK() macro has been made more efficient by restoring the POK flag on REGEXP svs and and PVLVs which hold a regex. This removes the two extra checks that SvOK() had to do each time. This has been done by changing the way that PVLV's-holding-a-regex are implemented. The downside of this change is that ReANY() now includes a single conditional. To ameliorate that, places like pp_match() have been tweaked to only fetch ReANY() once where possible. * the OP_KEYS op is now optimised away in void and scalar context. Since a hash in scalar context was changed so that it no longer returns a bucket count but instead just a key count, '%h' and 'keys %h' in void/boolean/scalar context are now very similar. So for 'keys %h', rather than calling pp_padhv+pp_keys, just call pp_padhv with a OPpPADHV_ISKEYS flag set. Similarly for pp_rv2hv. As well as skipping an extra op call, this brings the existing boolean-context optimisations of '%h' to 'keys %h' too. In particular, 'keys %tied' in boolean context now calls SCALAR() if available, or FIRSTKEY() otherwise, rather than iterating through the whole hash. I have also given OP_RV2HV a targ so that it can return integer values more efficiently. * Various integer-returning ops are now flagged when in boolean context, which means at runtime they can just return &PL_sv_yes/&PL_sv_zero rather than setting a targ to an integer value, or for ops without targs, having to create a new integer-valued mortal. As well as being quicker to return a value, this works well with SvTRUE() which now recognises immortals quickly. Also for ops like length() and pos(), it doesn't need to convert between byte and char offsets; the fact that the offset is non-zero is sufficient. These ops are: OP_AASSIGN OP_GREPWHILE OP_LENGTH OP_PADAV OP_POS OP_RV2AV OP_SUBST Also, index() doesn't return a boolean value, but for no match it returns -1. So for code like if (index(...) != -1) { ... } optimise away the OP_CONST and the OP_EQ and flag the index op to return a boolean value. * Speed up OP_ITER OP_ITER is called for every iteration of a for loop or similar. Its job is iterate the loop variable once, then return &PL_sv_yes or &PL_sv_no depending on whether it's the last iteration. OP_ITER is always followed by OP_AND, which examines the truth value on the stack, and returns op_next or op_other accordingly. Now, pp_iter() just asserts that PL_op->op_next is an OP_AND, and returns PL_op->op_next->op_next or PL_op->op_next->op_other directly, skipping the PL_sv_yes/no push/pop and eliminating the call to pp_and(). As part of these changes, I have moved pp_padav(), pp_padhv() from pp.c to pp_hot.c, moved some common code into a new function S_padhv_rv2hv_common(), created a new (non-API) function Perl_hv_pushkv() which pushes a hash's keys or values or both onto the stack, and reduced the number of callers of Perl_do_kv() (which was acting as both a pp function for several ops and as a general-purpose function too). Of the 360 or so tests in t/perf/benchmarks, the following number of tests had their COND field changed from 100% to the following ranges: 36 @ 96.55% .. 99.99% 245 @ 100.00% .. 100.99% 28 @ 101.00% .. 109.99% 7 @ 110.00% .. 119.99% 10 @ 120.00% .. 129.99% 29 @ 130.00% .. 199.99% 4 @ 200.00% .. 299.99% 1 @ 314.29% so about 10% of tests became marginally slower - usually due to one extra conditional in an op to test for a private BOOL flag or ReANY(); about 70% of tests were almost unaffected, while 20% of tests showed improvement, most with considerable improvement, and a few with spectacular improvement. (The 314% is for an empty @lexical tested in boolean context). commit cd5acddbd85c06fdc2c3069243a4796b290e5742 Author: David Mitchell <[email protected]> Date: Tue Jul 25 15:10:53 2017 +0100 t/perf/benchmarks: rename some keys() entries move and rename expr::hash::bool_empty_keys expr::hash::bool_full_keys to func::keys::lex::bool_cxt_empty func::keys::lex::bool_cxt and add func::keys::pkg::bool_cxt_empty func::keys::pkg::bool_cxt since its really testing the keys() function in boolean context rather than a hash in boolean context. M t/perf/benchmarks commit 6f2dc9a6b978e866e22c46235932d018da8262ba Author: David Mitchell <[email protected]> Date: Sun Jul 23 16:31:38 2017 +0100 make scalar(keys(%lexical)) less slow. A recent commit in this branch made OP_PADHV / OP_RV2HV in void/scalar context, followed by OP_KEYS, optimise away the OP_KEYS op and set the OPpPADHV_ISKEYS or OPpRV2HV_ISKEYS flag on the OP_PADHV / OP_RV2HV op. However, in scalar but non-boolean context with OP_PADHV, this actually makes it slower, because the OP_KEYS op has a target, while the OP_PADHV op doesn't, thus it has to create a new mortal each time to return the integer value. This commit fixes that by, in the case of scalar padhv, retaining the OP_KEYS node (although still not keeping it in the execution path), then at runtime using that op's otherwise unused target. This only works on PERL_OP_PARENT builds (now the default) as the OP_KEYS is the parent of the OP_PADHV, so would be hard to find at runtime otherwise. This commit also fixes pp_padhv/pp_rv2hv in void context - formerly it was needlessly pushing a scalar-valued count like scalar context. M lib/B/Deparse.pm M op.c M pp_hot.c M t/perf/benchmarks commit 8dc9003ff3914e78971f561eaece965e9ceeb49e Author: David Mitchell <[email protected]> Date: Fri Jul 21 14:32:57 2017 +0100 hv_pushkv(): handle keys() and values() too The newish function hv_pushkv() currently just pushes all key/value pairs on the stack. i.e. it does the equivalent of the perl code '() = %h'. Extend it so that it can handle 'keys %h' and values %h' too. This is basically moving the remaining list-context functionality out of do_kv() and into hv_pushkv(). The rationale for this is that hv_pushkv() is a pure HV-related function, while do_kv() is a pp function for several ops including OP_KEYS/VALUES, and expects PL_op->op_flags/op_private to be valid. M doop.c M embed.fnc M embed.h M hv.c M pp_hot.c M proto.h M t/perf/benchmarks commit a16ac36c3b97d0d80762b2900667f3759f354d9f Author: David Mitchell <[email protected]> Date: Thu Jul 20 08:58:02 2017 +0100 t/op/tie.t: add tests for scalar(keys(%tied)) Test what methods it calls. Currently it calls FIRSTKEY() and then NEXTKEY() x n, regardless of whether SCALAR() is present, although that might change. This test codifies the current behaviour for now. M t/op/tie.t commit e80717e766f2b07e86266e546391d45f27bd6fb3 Author: David Mitchell <[email protected]> Date: Wed Jul 19 17:48:03 2017 +0100 S_padhv_rv2hv_common(): reorganise code There are three main booleans in play here: * whether the hash is tied; * whether we're in boolean context; * whether we're implementing 'keys %h' Reorganise the if-tree logic for these up to 8 permutations to make the code simpler. In particular, make it so that all these are done in only one place: * call HvUSEDKEYS(); * call magic_scalarpack(); * push an integer return value, either as TARG or mortal The functionality should be unchanged, except that now 'scalar(%h)', where %h isn't tied, will return an integer value using the targ if available rather than always creating a new mortal. M pp_hot.c commit e1ad5d4c666831a6890bdfd5b332e1bf64677f89 Author: David Mitchell <[email protected]> Date: Wed Jul 19 17:06:28 2017 +0100 S_padhv_rv2hv_common(): unroll hv_scalar() calls This function makes a couple of calls to hv_scalar(), which does one of two things depending on whether hash is tied or not. Since in S_padhv_rv2hv_common() we've already determined whether the hash is tied, just include the relevant part(s) of hv_scalar() directly. The code will be reorganised shortly. M pp_hot.c commit 3cd2c7d486f06a3e4bc31c2f5afc51e5224fcac5 Author: David Mitchell <[email protected]> Date: Wed Jul 19 16:50:14 2017 +0100 simplify keys(%tied_hash) in boolean context. Previously something like if (keys %tied_hash) { ... } would have called FIRSTKEY(), followed by NEXTKEY() x N. Now, it just calls SCALAR() once if present, and if not, falls back to calling just FIRSTKEY() once. i.e. it only needs to determine whether at least one key is present. The behaviour of of 'keys(%tied) in boolean context now matches that of '(%tied) in boolean context. See http://nntp.perl.org/group/perl.perl5.porters/245463. M pp_hot.c M t/op/tie.t commit 0b5aba47e85e02bdba9d9d90643d7928ac50cc80 Author: David Mitchell <[email protected]> Date: Wed Jul 19 14:31:27 2017 +0100 S_pushav(): tail call optimise Make it return PL_op->op_next so that (some of) its callers can be tail-call optimised, if the compiler supports such a thing. M pp_hot.c commit 327c9b9e72d9a0e72c98bd828f179f9807a64cef Author: David Mitchell <[email protected]> Date: Wed Jul 19 14:21:28 2017 +0100 pp_padav(): use S_pushav() The previous commit harmonised the two functions, so its ok to use S_pushav() now. M pp_hot.c commit ea710183d400fe5d3e69cf573c0c9c6540ce4c5a Author: David Mitchell <[email protected]> Date: Wed Jul 19 14:04:36 2017 +0100 harmonise S_pushav() and pp_padav() These two functions contain a similar block of code to push an array onto the stack. However they have some slight differences, which this commit removes. This will allow padav() to call S_pushav() in the next commit. The two differences are: 1) S_pushav() when pushing elements of a magical array, calls mg_get() on each element. This is to ensure that e.g. in sub f { /..../; @+ } when the elements of @+ are returned, they are set *before* the current pattern goes out of scope. However, since probably v5.11.5-132-gfd69380 and v5.13.0-22-g2d961f6, the mg_get is no longer required. 2) S_pushav() uses the SvRMAGICAL() test to decide whether its unsafe to access AvARRAY directly; pp_padav() uses SvMAGICAL(). The latter seems too severe, so I've changed it to SvRMAGICAL(). M pp_hot.c commit 87c9dcef06a83be89762b31d506a075cd0c79990 Author: David Mitchell <[email protected]> Date: Wed Jul 19 09:11:33 2017 +0100 Perl_hv_pushkv(): unroll hv_iterkeysv() Do our own mortal stack extending and handling. M hv.c commit af3b1cba4fa1f9302496ccf5135bf61703227009 Author: David Mitchell <[email protected]> Date: Mon Jul 17 17:51:57 2017 +0100 create Perl_hv_pushkv() function ...and make pp_padhv(), pp_rv2hv() use it rather than using Perl_do_kv() Both pp_padhv() and pp_rv2hv() (via S_padhv_rv2hv_common()), outsource to Perl_do_kv(), the list-context pushing/flattening of a hash onto the stack. Perl_do_kv() is a big function that handles all the actions of keys, values etc. Instead, create a new function which does just the pushing of a hash onto the stack. At the same time, split it out into two loops, one for tied, one for normal: the untied one can skip extending the stack on each iteration, and use a cheaper HeVAL() instead of calling hv_iterval(). M doop.c M embed.fnc M embed.h M hv.c M pp_hot.c M proto.h M t/perf/benchmarks commit e84e4286916d8a219c8a63468807b41df9cde7fe Author: David Mitchell <[email protected]> Date: Mon Jul 17 16:33:38 2017 +0100 Give OP_RV2HV a targ OP_RV2AV already has one; its not clear why OP_RV2HV didn't. Having one means that in scalar context it can return an int value without having to create a mortal. Ditto when its doing 'keys %h' via OPpRV2HV_ISKEYS. M ext/B/t/f_map.t M ext/B/t/f_sort.t M ext/B/t/optree_samples.t M opcode.h M pp_hot.c M regen/opcodes commit aa36782f823c559475544c99a66db74997ce1edf Author: David Mitchell <[email protected]> Date: Mon Jul 17 15:52:38 2017 +0100 add S_padhv_rv2hv_common() function This STATIC INLINE function extracts out a chunk of common code from pp_padhv() and pp_rv2hv() (well, from pp_rv2av() actually, since that handles OP_RV2HV too). Should be no functional changes, except that now in void context, 'keys %h' doesn't leave any rubbish on the stack. M pp_hot.c commit e855b461ca460cbac6d017d10587057f51474a68 Author: David Mitchell <[email protected]> Date: Mon Jul 17 13:47:12 2017 +0100 move pp_padav(), pp_padhv() from pp.c to pp_hot.c Just a cut+paste; no code or functional changes. As well as being hot code, pp_padav() and pp_padhv() also have a lot of code in common with pp_rv2av() (which also implements pp_rv2hv()). Having all three functions in the same file will allow the next few commits to move some of that common code into static inline functions. M pp.c M pp_hot.c commit e3ad3bbc29184edf8de9c3acf6b85e79e632b069 Author: David Mitchell <[email protected]> Date: Sat Jul 15 22:26:04 2017 +0100 pp_grepwhile: no need to extend the stack when returning from grep in scalar context, no need to extend the stack by one when pushing the result count, since the last grep iteration will have pushed its result which we've just popped. M pp_hot.c commit 3773545d7938a87216a5f326c367a8c445193939 Author: David Mitchell <[email protected]> Date: Sat Jul 15 22:12:41 2017 +0100 change sv_setsv(sv,NULL) to sv_set_undef(sv) There are still a few core occurrences of sv_setsv(sv, NULL); which is equivalent to sv_setsv(sv, &PL_sv_undef); but which can now be done more efficiently with sv_set_undef(sv); M mg.c M pp_hot.c commit 7c114860c0fa8ade5e00a4b609d2fbd11d5a494c Author: David Mitchell <[email protected]> Date: Sat Jul 15 13:27:09 2017 +0100 pp_iter(): jump directly to op after OP_AND AN OP_ITER's op_next field always points to an OP_AND node. Rather than pushing &PL_sv_yes or &PL_sv_no and then passing control to the OP_AND, make pp_iter() return the OP_AND's op_next or op_other directly, depending on whether this is the last iteration or not. For an empty body, this cuts about 20% off the time of an iteration. It's possible that some weird optree-munging XS module may break this assumption. For now I've just added asserts that the next op is OP_AND with an op_ppaddr of Perl_pp_and; if that assertion fails, it may be necessary to convert pp_iter()s' asserts into conditional statements. In the longer term it might be worthwhile converting OP_ITER from a BASEOP into a LOGOP and eliminate the OP_AND from the optree altogether. Alternatively, perhaps pp_iter could just tail call Perl_op_leavesub directly after the last iteration? M pp_hot.c commit 7e8d786b02d3ef1f946a5ac354c2780774902e15 Author: David Mitchell <[email protected]> Date: Fri Jul 14 17:29:43 2017 +0100 optimise (index() == -1) Unusually, index() and rindex() return -1 on failure. So it's reasonably common to see code like if (index(...) != -1) { ... } and variants. For such code, this commit optimises away to OP_EQ and OP_CONST, and sets a couple of private flags on the index op instead, indicating: OPpTRUEBOOL return a boolean which is a comparison of what the return would have been, against -1 OPpINDEX_BOOLNEG negate the boolean result Its also supports OPpTRUEBOOL in conjunction with the existing OPpTARGET_MY flag, so for example in $lexical = (index(...) == -1) the padmy, sassign, eq and const ops are all optimised away. M embed.h M lib/B/Deparse.pm M lib/B/Deparse.t M lib/B/Op_private.pm M op.c M opcode.h M pp.c M proto.h M regen/op_private M regen/opcodes M t/op/index.t M t/perf/benchmarks M t/perf/opcount.t commit 12dc5f9406fbb8389be8b9f9406ad247ca07f210 Author: David Mitchell <[email protected]> Date: Fri Jul 14 15:23:29 2017 +0100 pp_readline,close,getc: explain NULL stack arg add code comments to explain why these functions can sometimes be called with a NULL pointer on the stack. (feature introduced by v5.15.2-112-g30901a8) M pp_hot.c M pp_sys.c commit a9372a4640d52f451e21d4f26b1105811563d003 Author: David Mitchell <[email protected]> Date: Fri Jul 14 14:56:03 2017 +0100 t/perf/optree.t: reformat a table whitespace-only change, plus alphabetically sort the lines of ops being tested). M t/perf/optree.t commit f961b1eba1e87173b5720f83913c4830be29a28e Author: David Mitchell <[email protected]> Date: Fri Jul 14 14:50:19 2017 +0100 regen/opcodes: move 'method' entry next to others there's a block of method_foo ops, and method was apart from them. No functional difference and part from auto-allocated op numbers. M opcode.h M opnames.h M regen/opcodes commit 7b394f128b8d5e84ca0e485c98c8f135baf53b4f Author: David Mitchell <[email protected]> Date: Thu Jul 13 09:40:49 2017 +0100 add boolean context support to several ops For some ops which return integer values and which have a reasonable likelihood of being used in a boolean context, set the OPpTRUEBOOL flag on the op as appropriate, and at runtime return &PL_sv_yes / &PL_sv_zero rather than an integer value. This is especially beneficial where the op doesn't have a targ, so has to create a mortal SV to return the integer value. Similarly, its a win where it may be expensive to calculate an integer return value, such as pos() or length() converting between byte and char offset. Ops done: OP_SUBST OP_AASSIGN OP_POS OP_LENGTH OP_GREPWHILE M lib/B/Op_private.pm M op.c M opcode.h M pp.c M pp_hot.c M regen/op_private M t/perf/benchmarks M t/perf/optree.t commit a247dbb235b6ada82425a663c4ebd4f426e4947f Author: David Mitchell <[email protected]> Date: Fri Jul 14 11:50:16 2017 +0100 S_check_for_bool_cxt(): avoid OPpTARGET_MY + bool Where an op allows the OA_TARGLEX optimisation (which eliminates the assign op in '$lex = foo' and just sets the targ directly - which may be a padtmp or $lex - the op doesn't care), disallow setting a boolean context flag on that op. Because if the op does something like if (OPpTRUEBOOL) SETs(cond ? &PL_sv_yes : &PL_sv_no) skipping assigning to TARG, then $lex won't get set. M op.c commit 5febd2ff83ad8541c2fd1f43266e321d057ef865 Author: David Mitchell <[email protected]> Date: Fri Jul 14 11:27:28 2017 +0100 pp_length: code tidy and simplify assert The STATIC_ASSERT_STMT() is basically checking that shifting the HINT_BYTES byte left 26 places gives you SVf_UTF8, so just assert that. There's no need to assert the current values of HINT_BYTES and SVf_UTF8. Other than that, this commit tides up the code a bit (only whitespace changes and unnecessary brace removal), and adds/updates some code comments. M pp.c commit f446eca7ef7f31dd356f4dba9401fc3326be139c Author: David Mitchell <[email protected]> Date: Fri Jul 14 11:18:52 2017 +0100 pp_length: only call sv_len_utf8_nomg() if needed after doing get magic, if the result is SVf_POK and non-utf8, just use SvCUR(sv). M pp.c commit 5b7508176e5e4ba4f0e051ad3d5cc45dbbe3ab24 Author: David Mitchell <[email protected]> Date: Fri Jul 14 09:47:58 2017 +0100 pp_length: use TARGi rather rather than sv_setiv() TARGi(i,1) is equivalent to sv_setiv_mg(TARG,i), except that it inlines some simple common cases. Also add a couple of test for length on an overloaded utf8 string. I don't think it was being tested for properly. M lib/overload.t M pp.c commit 7caeb7be934ab798a490d6205914121a6a935f01 Author: David Mitchell <[email protected]> Date: Thu Jul 13 14:09:55 2017 +0100 t/perf/optree.t: better diagnostics when it fails to the find the op its looking for, dump the optree. Also, include the grep tests in parentheses, otherwise the condition can be interpreted as the whole expression if the condition includes parentheses; e.g. condition: ($a==$_) becomes grep ($a==$_), 1, 2 so do this instead becomes grep (($a==$_), 1, 2) M t/perf/optree.t commit 7be75ccf16313d987eb5a6e9ff6aec9fea4ef3d4 Author: David Mitchell <[email protected]> Date: Tue Jul 11 13:43:26 2017 +0100 optimise @array in boolean context It's quicker to return (and to test for) &PL_sv_zero or &PL_sv_yes, than setting a targ to an integer value or, in the vase of padav, creating a mortal sv and setting it to an integer value. In fact for padav, even in the scalar but non-boolean case, return &PL_sv_zero if the value is zero rather than creating and setting a mortal. M lib/B/Op_private.pm M op.c M opcode.h M pp.c M pp_hot.c M regen/op_private M t/perf/benchmarks M t/perf/optree.t commit 748f2c65599942147442f443949449a965f6d608 Author: David Mitchell <[email protected]> Date: Mon Jul 10 15:48:02 2017 +0100 optimise away OP_KEYS op in scalar/void context In something like if (keys %h) { ... } the 'keys %h' is implemented as the op sequences gv[*h] s rv2hv lKRM/1 keys[t2] sK/1 or padhv[%h:1,6] lRM keys[t2] sK/1 It turns out that (%h) in scalar and void context now behaves very similarly to (keys %h) (except that it reset the iterator), so in these cases, convert the two ops rv2hv/padhv, keys into the single op rv2hv/padhv with a private flag indicating that the op is handling the 'keys' action by itself. As well as one less op to execute, this brings the boolean-context optimisation already present in padhv/rv2sv to keys. So if (keys %h) { ... } is no longer slower than if (%h) { ... } M ext/B/t/f_map.t M ext/B/t/f_sort.t M ext/B/t/optree_samples.t M lib/B/Deparse.pm M lib/B/Deparse.t M lib/B/Op_private.pm M op.c M opcode.h M pp.c M pp_hot.c M regen/op_private M t/perf/benchmarks commit 4fa080dbc664ee90dd374a9a49ac0a4932421bd7 Author: David Mitchell <[email protected]> Date: Mon Jul 10 13:13:03 2017 +0100 OP_VALUES: reserve OPpMAYBE_LVSUB bit This op doesn't use that bit, but it calls the function Perl_do_kv(), which is called by several different ops which *do* use that bit. So ensure no-one in future thinks that bit is spare in OP_VALUES. M doop.c M lib/B/Op_private.pm M opcode.h M regen/op_private commit 94184451ad29bb516512af1a14112b587a045451 Author: David Mitchell <[email protected]> Date: Mon Jul 10 12:39:25 2017 +0100 use OPpAVHVSWITCH_MASK Use this symbolic constant rather than the literal constant '3'. M doop.c M op.c commit a223205704cce2b45732f255cf3856f1301b3850 Author: David Mitchell <[email protected]> Date: Mon Jul 10 12:34:13 2017 +0100 Perl_do_kv(): add asserts and more code comments This function can be called directly or indirectly by several ops. Update its code comments to explain this in detail, and assert which ops can call it. Also remove a redundant comment about OP_RKEYS/OP_RVALUES; these ops have been removed. Also, reformat the 'dokv = ' expressions. Finally, add some code comments to pp_avhvswitch explaining what its for. Apart from the op_type asserts, there should be no functional changes. M doop.c M pp.c commit f4c975aa030b7ad74a7efda242fb8b771ea41c14 Author: David Mitchell <[email protected]> Date: Sat Jul 8 15:47:23 2017 +0100 make callers of SvTRUE() more efficient Where its obvious that the args can't be null, use SvTRUE_NN() instead. Avoid possible multiple evaluations of the arg by assigning to a local var first if necessary. M gv.c M hv.c M pp.c M pp_ctl.c M pp_hot.c M pp_sys.c M regexec.c M universal.c commit 775f2c0793edf33325b9ef09b476245658cfd66b Author: David Mitchell <[email protected]> Date: Sat Jul 8 14:17:15 2017 +0100 add some SvTRUE() benchmarks Add a few not (!) expressions which exercise SvTRUE() for various types of operand. M t/perf/benchmarks commit 1a436fbe3c7e36cfac949d9e21c6191cb2a33362 Author: David Mitchell <[email protected]> Date: Sat Jul 8 11:23:18 2017 +0100 SvTRUE(): inline ROK, outline NOK SvTRUE (and its variants) are wrappers around sv_2bool(), which attempt to test for the common cases without the overhead of a function call. This commit changes the definition of common: SvROK() becomes common: it's very common to test whether a variable is undef or a ref; SvNOK becomes uncommon: these days perl prefers IV values over NV values in SVs whenever possible, so testing the truth value of an NV is less common. M sv.c M sv.h commit 78a2798452edb43e37dcaaf3698916d31575b58f Author: David Mitchell <[email protected]> Date: Wed Jul 12 14:48:34 2017 +0100 SvTRUE(): special-case immortals Immortal SVs like PL_sv_no will often be used as an argument to SvTRUE(); however it turns out that SvTRUE() is very inefficient at determining the truth value of such SVs. For example, for PL_sv_yes it does all the following test-and-branches to decide that it is indeed true: SvOK() SvPOK() SvANY() xpv_cur > 1 xpv_cur sv_u.svu_pv != '0' After the previous commit it is now much cheaper to test whether an SV is one of the four "interpreter" immortals PL_sv_yes, PL_sv_undef, PL_sv_no, PL_sv_zero. So this commit adds an extra check at the beginning of SvTRUE(): if it's an immortal, return whether it's a true immortal (i.e. PL_sv_yes). SvTRUE_nomg_NN(&PL_sv_yes) now only requires one test-and-branch plus an address comparison. The other immortals are similarly improved. Non-immortals now require one extra test-and-branch. M sv.h commit 7c123f9da96361fa49e1d9227644d5ee5af4cd0d Author: David Mitchell <[email protected]> Date: Wed Jul 12 14:07:16 2017 +0100 Make immortal SVs contiguous Ensure that PL_sv_yes, PL_sv_undef, PL_sv_no and PL_sv_zero are allocated adjacently in memory. This allows the SvIMMORTAL() test to be more efficient, and will (in the next commit) allow SvTRUE() to be more efficient. In MULTIPLICITY builds the constraint is already met by virtue of them being adjacent items in the interpreter struct. For non-MULTIPLICITY builds, they were just 4 global vars with no guarantees of where they would be allocated. For this case, PL_sv_undef are deleted as global vars and replaced with a new global var PL_sv_immortals[4], with #define PL_sv_yes (PL_sv_immortals[0]) etc in their place. M embedvar.h M intrpvar.h M makedef.pl M perl.h M sv.c M sv.h commit 56c6304063762154ca57e85c0fe6f60069dacd77 Author: David Mitchell <[email protected]> Date: Wed Jul 5 17:16:34 2017 +0100 SvTRUE(): handle get magic more efficiently SvTRUE() and SvTRUE_NN() are wrappers around sv_2bool() which handle the common cases directly and only fallback to sv_2bool() for the hard ones. Those macros were considering get magic as hard and falling back; instead, just call the get magic and continue. M sv.h commit 90c94eb809e27525ede5f7656ca0b5e2e119b75b Author: David Mitchell <[email protected]> Date: Wed Jul 5 17:09:12 2017 +0100 rationalise SvTRUE() macro variants define the plain, _nomg and _NN variants in terms of each other, e.g. #define SvTRUE(sv) (LIKELY(sv) && SvTRUE_NN(sv)) rather than duplicating common code text. There should be no functional changes, and the macros should (in theory) continue to expand to the same text. M sv.h commit 196a02af144b943f8fe763deb4c7db0a06348e57 Author: David Mitchell <[email protected]> Date: Fri Jul 21 17:07:51 2017 +0100 add, and use, some RXp_FOO() variants of RX_FOO() For various RX_FOO() macros, add a RXp_FOO() variant, in such a way that the original macro is now defined in terms of #define RX_FOO(rx_sv) (RXp_FOO(ReANY(rx_sv))) (This is a pre-existing convention; this commit just makes a larger subset of the RX_() macros have an RXp_() variant). Then use those macros in various pp_hot.c and regexec.c functions like pp_match() and regexec_flags(), which already, or added via this commit, have this line near the start: regexp *prog = ReANY(rx); This avoids having to do multiple ReANY()'s, which is important as this macro now includes a conditional in its expression (to cope with PVLV-as-REGEX).. M pp_hot.c M regexec.c M regexp.h commit ea0673eedc20f778f2cefa666a956a24320bcad3 Author: David Mitchell <[email protected]> Date: Mon Jul 24 14:58:58 2017 +0100 rename RX_HAS_CUTGROUP() to RXp_HAS_CUTGROUP() It takes a private/internal regexp* pointer rather than a public REGEXP pointer, so rename it to match the other RXp_ macros. Most RXp_ macros are a variant of an RX_ macro; however, I didn't add an RX_HAS_CUTGROUP() macro - someone can always add that if needed. (There's only one use of RXp_HAS_CUTGROUP in core). M regexec.c M regexp.h commit a885a8e06d234bd9fabda920d61f1e6dd668b5c8 Author: David Mitchell <[email protected]> Date: Mon Jul 24 14:54:53 2017 +0100 reformat RX_() macros The previous commit caused the formatting of these macros to become messy. Realign them, replacing tabs with spaces, and split some long macros over multiple lines. Whitespace-only change (if you count splitting a macro with \ as whitespace). M regexp.h commit 55922dbec2982825f2821bdc2dae4ec2b4cb5cd2 Author: David Mitchell <[email protected]> Date: Mon Jul 24 14:19:29 2017 +0100 RX_FOO(prog) becomes RX_FOO(rx_sv) There are a family of RX_() macros which take an SV of type REGEXP as an argument. For historical reasons (regexeps didn't use to be SVs), the name of the parameter is 'prog', which is also by convention used to name the actual regexp struct in some places. So e.g. at the top of re_intuit_start(), you see struct regexp *const prog = ReANY(rx); This is confusing. So for this class of macro, rename the parameter from 'prog' to 'rx_sv'. This makes it clearer that the arg should be a REGEXP* rather than an regexp*. Note that there are some RXp_() macros which do take a regexp* as an arg; I've left their parameter name as 'prog'. M regexp.h commit df6b4bd56551f2d39f7c0019c23f27181d8c39c4 Author: David Mitchell <[email protected]> Date: Fri Jul 7 14:13:32 2017 +0100 give REGEXP SVs the POK flag again Commit v5.17.5-99-g8d919b0 stopped SVt_REGEXP SVs (and PVLVs acting as regexes) from having the POK and pPOK flags set. This made things like SvOK() and SvTRUE() slower, because as well as the quick single test for any I/N/P/R flags, SvOK() also has to test for (SvTYPE(sv) == SVt_REGEXP || (SvFLAGS(sv) & (SVTYPEMASK|SVp_POK|SVpgv_GP|SVf_FAKE)) == (SVt_PVLV|SVf_FAKE)) This commit fixes the issue fixed by g8d919b0 in a slightly different way, which is less invasive and allows the POK flag. Background: PVLV are basically PVMGs with a few extra fields. They are intended to be a superset of all scalar types, so any scalar value can be assigned to a PVLV SV. However, once REGEXPs were made into first-class scalar SVs, this assumption broke - there are a whole bunch of fields in a regex SV body which can't be copied to to a PVLV. So this broke: sub f { my $r = qr/abc/; # $r is reference to an SVt_REGEXP $_[0] = $$r; } f($h{foo}); # the hash access is deferred - a temporary PVLV is # passed instead The basic idea behind the g8d919b0 fix was, for an LV-acting-as-regex, to attach both a PVLV body and a regex body to the SV head. This commit keeps this basic concept; it just changes how the extra body is attached. The original fix changed SVt_REGEXP SVs so that sv.sv_u.svu_pv no longer pointed to the regexp's string representation; instead this pointer was stored in a union made out of the xpv_len field. Doing this necessitated not turning the POK flag on for any REGEXP SVs. This freed up the sv_u to point to the regex body, while the sv_any field could continue to point to the PVLV body. An ReANY() macro was introduced that returned the sv_u field rather than the sv_any field. This commit changes it so that instead, on regexp SVs (and LV-as-regexp SVs), sv_u always points to the string buffer (so they can have POK set again), but on specifically LV-as-regex SVs, the xpv_len_u union of the PVLV body points to the regexp body. This means that SVt_REGEXP SVs are now completely "normal" again, and SVt_PVLV SVs are normal except in the one case where they hold a regex, in which case rather than storing the string buffer's length, the PVLV body stores a pointer to the regex body. M ext/B/B/Concise.pm M ext/Devel-Peek/t/Peek.t M inline.h M op.c M perl.h M regcomp.c M regexp.h M sv.c M sv.h commit e8f01ee5fa8087b34dfe31b2c53eef0ba8718922 Author: David Mitchell <[email protected]> Date: Wed Jul 5 16:26:51 2017 +0100 sv_2bool_flags(): assume ROK implies SvRV If the SvROK flag is set, the SV must have a valid non-nnull SvRV() pointer, so don;t bother to check that whether its null. M sv.c commit a5bf735cf20c7f70ccb9686bb726d979d5043c77 Author: David Mitchell <[email protected]> Date: Tue Jul 4 12:46:20 2017 +0100 S_check_for_bool_cxt(): special-case OP_AND Re-instate the special-casing, which was removed by v5.25.8-172-gb243b19, of OP_AND in boolean-context determination. This is because the special-case allowed things to be more efficient sometimes, but required returning a false value as sv_2mortal(newSViv(0))) rather than &PL_sv_no. Now that PL_sv_zero has been added we can use that instead, cheaply. This commit adds an extra arg to S_check_for_bool_cxt() to indicate whether the op supports the special-casing of OP_AND. M op.c M pp.c M pp_hot.c M t/perf/optree.t commit 725c44f93c35f696d7175c36a6d2ec5987b5a4d1 Author: David Mitchell <[email protected]> Date: Tue Jul 4 09:45:29 2017 +0100 use the new PL_sv_zero in obvious places In places that do things like mPUSHi(0) or newSViv(0), replace them with PUSHs(&PL_sv_zero) and &PL_sv_zero, etc. This avoids the cost of creating and/or mortalising an SV, and/or setting its value to 0. This commit causes a subtle change to tainting in various places as a side-effect. For example, grep in scalar context retunrs 0 if it has no args. Formerly the zero value could in theory get tainted: @a = (); $x = ( ($^X . ""), grep { 1 } @a); It used to be the case that $x would be tainted; now its not. In practice this doesn't matter - the zero value was only getting tainted as a side-effect of tainting's "if anything in the statement uses a tainted value, taint everything" mechanism, which gives (documented) false positives. This commit merely removes some such false positives, and makes the behaviour similar to functions which return &PL_sv_undef/no/yes, which are also immune to side-effect tainting. M gv.c M hv.c M pp_ctl.c M pp_sys.c commit b043c4bf3fff5c679dad74f1a0c13ac539a97815 Author: David Mitchell <[email protected]> Date: Sat Jul 8 16:27:35 2017 +0100 make B.pm, Concise.pm support PL_sv_zero M ext/B/B.pm M ext/B/B.xs M ext/B/B/Concise.pm commit 99243e56c7ce90651e6fad30f5caff10ed3951ad Author: David Mitchell <[email protected]> Date: Wed Jul 5 16:44:38 2017 +0100 dist/threads/: support PL_sv_zero and bump version from 2.16 to 2.17 M dist/threads/lib/threads.pm M dist/threads/threads.xs commit 5a6c28370397ad3d5c138df5778833dc4b11c3be Author: David Mitchell <[email protected]> Date: Mon Jul 3 17:07:28 2017 +0100 add PL_sv_zero it's like PL_sv_no, except that its string value is "0" rather than "". It can be used for example where pp function wants to push a zero return value on the stack. The next commit will start to use it. Also update the SvIMMORTAL() to be more efficient: it now checks whether the SV's address is in a range rather than individually checking against &PL_sv_undef, &PL_sv_no etc. M dump.c M embedvar.h M globvar.sym M intrpvar.h M perl.c M perl.h M sv.c M sv.h ----------------------------------------------------------------------- Summary of changes: dist/threads/lib/threads.pm | 4 +- dist/threads/threads.xs | 6 + doop.c | 60 +++-- dump.c | 15 +- embed.fnc | 1 + embed.h | 2 + embedvar.h | 2 + ext/B/B.pm | 5 +- ext/B/B.xs | 3 +- ext/B/B/Concise.pm | 9 +- ext/B/t/f_map.t | 32 +-- ext/B/t/f_sort.t | 6 +- ext/B/t/optree_samples.t | 16 +- ext/Devel-Peek/t/Peek.t | 9 +- globvar.sym | 1 + gv.c | 8 +- hv.c | 78 +++++- inline.h | 4 +- intrpvar.h | 16 +- lib/B/Deparse.pm | 53 +++- lib/B/Deparse.t | 42 +++ lib/B/Op_private.pm | 26 +- lib/overload.t | 12 +- makedef.pl | 4 + mg.c | 11 +- op.c | 199 +++++++++++++- opcode.h | 621 ++++++++++++++++++++++---------------------- opnames.h | 58 ++--- perl.c | 5 + perl.h | 8 +- pp.c | 206 ++++++--------- pp_ctl.c | 18 +- pp_hot.c | 387 ++++++++++++++++++++------- pp_sys.c | 16 +- proto.h | 8 + regcomp.c | 21 +- regen/op_private | 40 ++- regen/opcodes | 12 +- regexec.c | 22 +- regexp.h | 170 ++++++------ sv.c | 92 ++++--- sv.h | 56 ++-- t/op/index.t | 67 ++++- t/op/tie.t | 68 +++++ t/perf/benchmarks | 313 ++++++++++++++++++++++ t/perf/opcount.t | 33 ++- t/perf/optree.t | 94 +++++-- universal.c | 16 +- 48 files changed, 2078 insertions(+), 877 deletions(-) diff --git a/dist/threads/lib/threads.pm b/dist/threads/lib/threads.pm index 2c37a61907..b20087ba84 100644 --- a/dist/threads/lib/threads.pm +++ b/dist/threads/lib/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '2.16'; +our $VERSION = '2.17'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -134,7 +134,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 2.16 +This document describes threads version 2.17 =head1 WARNING diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs index c519ad4f4d..b70c15fb37 100644 --- a/dist/threads/threads.xs +++ b/dist/threads/threads.xs @@ -1360,6 +1360,9 @@ ithread_join(...) ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); +# ifdef PL_sv_zero + ptr_table_store(PL_ptr_table, &other_perl->Isv_zero, &PL_sv_zero); +# endif params = (AV *)sv_dup((SV*)params_copy, clone_params); S_ithread_set(aTHX_ current_thread); Perl_clone_params_del(clone_params); @@ -1788,6 +1791,9 @@ ithread_error(...) ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); +# ifdef PL_sv_zero + ptr_table_store(PL_ptr_table, &other_perl->Isv_zero, &PL_sv_zero); +# endif err = sv_dup(thread->err, clone_params); S_ithread_set(aTHX_ current_thread); Perl_clone_params_del(clone_params); diff --git a/doop.c b/doop.c index 47d7fce2ab..5234e26a65 100644 --- a/doop.c +++ b/doop.c @@ -1241,24 +1241,38 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) } -/* used for: pp_keys(), pp_values() */ +/* Perl_do_kv() may be: + * * called directly as the pp function for pp_keys() and pp_values(); + * * It may also be called directly when the op is OP_AVHVSWITCH, to + * implement CORE::keys(), CORE::values(). + * + * In all cases it expects an HV on the stack and returns a list of keys, + * values, or key-value pairs, depending on PL_op. + */ OP * Perl_do_kv(pTHX) { dSP; HV * const keys = MUTABLE_HV(POPs); - HE *entry; - SSize_t extend_size; const U8 gimme = GIMME_V; - const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV); - /* op_type is OP_RKEYS/OP_RVALUES if pp_rkeys delegated to here */ - const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS) - || ( PL_op->op_type == OP_AVHVSWITCH - && (PL_op->op_private & 3) + OP_EACH == OP_KEYS ); - const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES) - || ( PL_op->op_type == OP_AVHVSWITCH - && (PL_op->op_private & 3) + OP_EACH == OP_VALUES ); + + const I32 dokeys = (PL_op->op_type == OP_KEYS) + || ( PL_op->op_type == OP_AVHVSWITCH + && (PL_op->op_private & OPpAVHVSWITCH_MASK) + + OP_EACH == OP_KEYS); + + const I32 dovalues = (PL_op->op_type == OP_VALUES) + || ( PL_op->op_type == OP_AVHVSWITCH + && (PL_op->op_private & OPpAVHVSWITCH_MASK) + + OP_EACH == OP_VALUES); + + assert( PL_op->op_type == OP_KEYS + || PL_op->op_type == OP_VALUES + || PL_op->op_type == OP_AVHVSWITCH); + + assert(!( PL_op->op_type == OP_VALUES + && (PL_op->op_private & OPpMAYBE_LVSUB))); (void)hv_iterinit(keys); /* always reset iterator regardless */ @@ -1277,6 +1291,11 @@ Perl_do_kv(pTHX) IV i; dTARGET; + /* note that in 'scalar(keys %h)' the OP_KEYS is usually + * optimised away and the action is performed directly by the + * padhv or rv2hv op. We now only get here via OP_AVHVSWITCH + * and \&CORE::keys + */ if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) { i = HvUSEDKEYS(keys); } @@ -1296,22 +1315,9 @@ Perl_do_kv(pTHX) Perl_croak(aTHX_ "Can't modify keys in list assignment"); } - /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */ - assert(HvUSEDKEYS(keys) <= (SSize_t_MAX >> 1)); - extend_size = (SSize_t)HvUSEDKEYS(keys) * (dokeys + dovalues); - EXTEND(SP, extend_size); - - while ((entry = hv_iternext(keys))) { - if (dokeys) { - SV* const sv = hv_iterkeysv(entry); - XPUSHs(sv); - } - if (dovalues) { - SV *const sv = hv_iterval(keys,entry); - XPUSHs(sv); - } - } - RETURN; + PUTBACK; + hv_pushkv(keys, (dokeys | (dovalues << 1))); + return NORMAL; } /* diff --git a/dump.c b/dump.c index c4bb3ce09c..fa5f0baf91 100644 --- a/dump.c +++ b/dump.c @@ -369,7 +369,9 @@ Perl_sv_peek(pTHX_ SV *sv) sv_catpv(t, "WILD"); goto finish; } - else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) { + else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes + || sv == &PL_sv_zero || sv == &PL_sv_placeholder) + { if (sv == &PL_sv_undef) { sv_catpv(t, "SV_UNDEF"); if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| @@ -398,6 +400,17 @@ Perl_sv_peek(pTHX_ SV *sv) SvNVX(sv) == 1.0) goto finish; } + else if (sv == &PL_sv_zero) { + sv_catpv(t, "SV_ZERO"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 1 && + SvPVX_const(sv) && *SvPVX_const(sv) == '0' && + SvNVX(sv) == 0.0) + goto finish; + } else { sv_catpv(t, "SV_PLACEHOLDER"); if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| diff --git a/embed.fnc b/embed.fnc index 8dc61d857e..2dd73bfde0 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2943,6 +2943,7 @@ Apod |void |hv_assert |NN HV *hv #endif ApdR |SV* |hv_scalar |NN HV *hv +p |void |hv_pushkv |NN HV *hv|U32 flags ApdRM |SV* |hv_bucket_ratio|NN HV *hv ApoR |I32* |hv_riter_p |NN HV *hv ApoR |HE** |hv_eiter_p |NN HV *hv diff --git a/embed.h b/embed.h index 0cdf036e90..a41020d6e0 100644 --- a/embed.h +++ b/embed.h @@ -1171,6 +1171,7 @@ #define ck_delete(a) Perl_ck_delete(aTHX_ a) #define ck_each(a) Perl_ck_each(aTHX_ a) #define ck_eof(a) Perl_ck_eof(aTHX_ a) +#define ck_eq(a) Perl_ck_eq(aTHX_ a) #define ck_eval(a) Perl_ck_eval(aTHX_ a) #define ck_exec(a) Perl_ck_exec(aTHX_ a) #define ck_exists(a) Perl_ck_exists(aTHX_ a) @@ -1260,6 +1261,7 @@ #define gv_try_downgrade(a) Perl_gv_try_downgrade(aTHX_ a) #define hv_ename_add(a,b,c,d) Perl_hv_ename_add(aTHX_ a,b,c,d) #define hv_ename_delete(a,b,c,d) Perl_hv_ename_delete(aTHX_ a,b,c,d) +#define hv_pushkv(a,b) Perl_hv_pushkv(aTHX_ a,b) #define init_argv_symbols(a,b) Perl_init_argv_symbols(aTHX_ a,b) #define init_constants() Perl_init_constants(aTHX) #define init_debugger() Perl_init_debugger(aTHX) diff --git a/embedvar.h b/embedvar.h index 1e3f9a2ed9..7d284b894b 100644 --- a/embedvar.h +++ b/embedvar.h @@ -317,11 +317,13 @@ #define PL_sv_arenaroot (vTHX->Isv_arenaroot) #define PL_sv_consts (vTHX->Isv_consts) #define PL_sv_count (vTHX->Isv_count) +#define PL_sv_immortals (vTHX->Isv_immortals) #define PL_sv_no (vTHX->Isv_no) #define PL_sv_root (vTHX->Isv_root) #define PL_sv_serial (vTHX->Isv_serial) #define PL_sv_undef (vTHX->Isv_undef) #define PL_sv_yes (vTHX->Isv_yes) +#define PL_sv_zero (vTHX->Isv_zero) #define PL_sys_intern (vTHX->Isys_intern) #define PL_taint_warn (vTHX->Itaint_warn) #define PL_tainted (vTHX->Itainted) diff --git a/ext/B/B.pm b/ext/B/B.pm index 5ea96fa221..daa576435e 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.68'; + $B::VERSION = '1.69'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -80,7 +80,8 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs # Nullsv *must* come first in the following so that the condition # ($$sv == 0) can continue to be used to test (sv == Nullsv). @B::specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no - (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD); + (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD + &PL_sv_zero); { # Stop "-w" from complaining about the lack of a real B::OBJECT class diff --git a/ext/B/B.xs b/ext/B/B.xs index f6fdd1e902..74edd38720 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -77,7 +77,7 @@ static const size_t opsizes[] = { #define MY_CXT_KEY "B::_guts" XS_VERSION typedef struct { - SV * x_specialsv_list[7]; + SV * x_specialsv_list[8]; int x_walkoptree_debug; /* Flag for walkoptree debug hook */ } my_cxt_t; @@ -95,6 +95,7 @@ static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) { cxt->x_specialsv_list[4] = (SV *) pWARN_ALL; cxt->x_specialsv_list[5] = (SV *) pWARN_NONE; cxt->x_specialsv_list[6] = (SV *) pWARN_STD; + cxt->x_specialsv_list[7] = &PL_sv_zero; } diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index e5f1066281..6465a3c131 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "1.000"; +our $VERSION = "1.001"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -727,15 +727,16 @@ sub concise_sv { } } if (class($sv) eq "SPECIAL") { - $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; + $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no", + '', '', '', "sv_zero"]->[$$sv]; } elsif ($preferpv - && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) { + && ($sv->FLAGS & SVf_POK)) { $hr->{svval} .= cstring($sv->PV); } elsif ($sv->FLAGS & SVf_NOK) { $hr->{svval} .= $sv->NV; } elsif ($sv->FLAGS & SVf_IOK) { $hr->{svval} .= $sv->int_value; - } elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") { + } elsif ($sv->FLAGS & SVf_POK) { $hr->{svval} .= cstring($sv->PV); } elsif (class($sv) eq "HV") { $hr->{svval} .= 'HASH'; diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index a1cbc38c01..221f2926e2 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -108,7 +108,7 @@ checkOptree(note => q{}, # goto 7 # g <0> pushmark s # h <#> gv[*hash] s -# i <1> rv2hv lKRM*/1 +# i <1> rv2hv[t2] lKRM* # j <2> aassign[t10] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -130,7 +130,7 @@ EOT_EOT # goto 7 # g <0> pushmark s # h <$> gv(*hash) s -# i <1> rv2hv lKRM*/1 +# i <1> rv2hv[t1] lKRM* # j <2> aassign[t5] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -157,7 +157,7 @@ checkOptree(note => q{}, # 4 <0> pushmark s # 5 <0> pushmark s # 6 <#> gv[*hash] s -# 7 <1> rv2hv lKRM*/1 +# 7 <1> rv2hv[t2] lKRM* # 8 <2> aassign[t3] vKS # 9 <;> nextstate(main 476 (eval 10):1) v:{ # a <0> pushmark sM @@ -171,7 +171,7 @@ checkOptree(note => q{}, # g <;> nextstate(main 475 (eval 10):1) v:{ # h <#> gvsv[*_] s # i <#> gv[*hash] s -# j <1> rv2hv sKR/1 +# j <1> rv2hv sKR # k <0> pushmark s # l <#> gvsv[*_] s # m <#> gv[*getkey] s/EARLYCV @@ -190,7 +190,7 @@ EOT_EOT # 4 <0> pushmark s # 5 <0> pushmark s # 6 <$> gv(*hash) s -# 7 <1> rv2hv lKRM*/1 +# 7 <1> rv2hv[t1] lKRM* # 8 <2> aassign[t2] vKS # 9 <;> nextstate(main 560 (eval 15):1) v:{ # a <0> pushmark sM @@ -204,7 +204,7 @@ EOT_EOT # g <;> nextstate(main 559 (eval 15):1) v:{ # h <$> gvsv(*_) s # i <$> gv(*hash) s -# j <1> rv2hv sKR/1 +# j <1> rv2hv sKR # k <0> pushmark s # l <$> gvsv(*_) s # m <$> gv(*getkey) s/EARLYCV @@ -243,7 +243,7 @@ checkOptree(note => q{}, # goto 7 # b <0> pushmark s # c <#> gv[*hash] s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t2] lKRM* # e <2> aassign[t10] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -260,7 +260,7 @@ EOT_EOT # goto 7 # b <0> pushmark s # c <$> gv(*hash) s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t1] lKRM* # e <2> aassign[t6] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -289,7 +289,7 @@ checkOptree(note => q{}, # goto 7 # b <0> pushmark s # c <#> gv[*hash] s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t2] lKRM* # e <2> aassign[t10] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -306,7 +306,7 @@ EOT_EOT # goto 7 # b <0> pushmark s # c <$> gv(*hash) s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t1] lKRM* # e <2> aassign[t6] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -335,7 +335,7 @@ checkOptree(note => q{}, # goto 7 # b <0> pushmark s # c <#> gv[*hash] s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t2] lKRM* # e <2> aassign[t9] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -352,7 +352,7 @@ EOT_EOT # goto 7 # b <0> pushmark s # c <$> gv(*hash) s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t1] lKRM* # e <2> aassign[t5] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -381,7 +381,7 @@ checkOptree(note => q{}, # goto 7 # b <0> pushmark s # c <#> gv[*hash] s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t2] lKRM* # e <2> aassign[t8] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -398,7 +398,7 @@ EOT_EOT # goto 7 # b <0> pushmark s # c <$> gv(*hash) s -# d <1> rv2hv lKRM*/1 +# d <1> rv2hv[t1] lKRM* # e <2> aassign[t5] KS/COM_AGG # f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -426,7 +426,7 @@ checkOptree(note => q{}, # goto 7 # a <0> pushmark s # b <#> gv[*hash] s -# c <1> rv2hv lKRM*/1 +# c <1> rv2hv[t2] lKRM* # d <2> aassign[t6] KS/COM_AGG # e <#> gv[*array] s # f <1> rv2av[t8] K/1 @@ -445,7 +445,7 @@ EOT_EOT # goto 7 # a <0> pushmark s # b <$> gv(*hash) s -# c <1> rv2hv lKRM*/1 +# c <1> rv2hv[t1] lKRM* # d <2> aassign[t4] KS/COM_AGG # e <$> gv(*array) s # f <1> rv2av[t5] K/1 diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t index fe0927829f..45dcd93ed5 100644 --- a/ext/B/t/f_sort.t +++ b/ext/B/t/f_sort.t @@ -280,8 +280,7 @@ checkOptree(note => q{}, # 2 <0> pushmark s # 3 <0> pushmark s # 4 <#> gv[*age] s -# 5 <1> rv2hv[t9] lKRM/1 < 5.019006 -# 5 <1> rv2hv lKRM/1 >=5.019006 +# 5 <1> rv2hv[t9] lKRM # 6 <1> keys[t10] lK/1 < 5.019002 # 6 <1> keys[t10] lKM/1 >=5.019002 # 7 <@> sort lKS* @@ -295,8 +294,7 @@ EOT_EOT # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*age) s -# 5 <1> rv2hv[t3] lKRM/1 < 5.019006 -# 5 <1> rv2hv lKRM/1 >=5.019006 +# 5 <1> rv2hv[t3] lKRM # 6 <1> keys[t4] lK/1 < 5.019002 # 6 <1> keys[t4] lKM/1 >=5.019002 # 7 <@> sort lKS* diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 1330a47302..7374626663 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -483,8 +483,7 @@ checkOptree ( name => '%h = map { getkey($_) => $_ } @a', # goto 7 # g <0> pushmark s # h <#> gv[*h] s -# i <1> rv2hv[t2] lKRM*/1 < 5.019006 -# i <1> rv2hv lKRM*/1 >=5.019006 +# i <1> rv2hv[t2] lKRM* # j <2> aassign[t10] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EOT_EOT @@ -507,8 +506,7 @@ EOT_EOT # goto 7 # g <0> pushmark s # h <$> gv(*h) s -# i <1> rv2hv[t1] lKRM*/1 < 5.019006 -# i <1> rv2hv lKRM*/1 >=5.019006 +# i <1> rv2hv[t1] lKRM* # j <2> aassign[t5] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -521,8 +519,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # 2 <0> pushmark s # 3 <0> pushmark s # 4 <#> gv[*h] s -# 5 <1> rv2hv[t2] lKRM*/1 < 5.019006 -# 5 <1> rv2hv lKRM*/1 >=5.019006 +# 5 <1> rv2hv[t2] lKRM* # 6 <2> aassign[t3] vKS # 7 <;> nextstate(main 506 (eval 24):1) v:{ # 8 <0> pushmark sM @@ -536,7 +533,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # e <;> nextstate(main 505 (eval 24):1) v:{ # f <#> gvsv[*_] s # g <#> gv[*h] s -# h <1> rv2hv sKR/1 +# h <1> rv2hv sKR # i <0> pushmark s # j <#> gvsv[*_] s # k <#> gv[*getkey] s/EARLYCV @@ -552,8 +549,7 @@ EOT_EOT # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*h) s -# 5 <1> rv2hv[t1] lKRM*/1 < 5.019006 -# 5 <1> rv2hv lKRM*/1 >=5.019006 +# 5 <1> rv2hv[t1] lKRM* # 6 <2> aassign[t2] vKS # 7 <;> nextstate(main 506 (eval 24):1) v:{ # 8 <0> pushmark sM @@ -567,7 +563,7 @@ EOT_EOT # e <;> nextstate(main 505 (eval 24):1) v:{ # f <$> gvsv(*_) s # g <$> gv(*h) s -# h <1> rv2hv sKR/1 +# h <1> rv2hv sKR # i <0> pushmark s # j <$> gvsv(*_) s # k <$> gv(*getkey) s/EARLYCV diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 2b1ed5d562..db9354bd0e 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -359,8 +359,7 @@ do_test('reference to regexp', RV = $ADDR SV = REGEXP\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) # $] < 5.017006 - FLAGS = \\(OBJECT,FAKE\\) # $] >= 5.017006 + FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) PV = $ADDR "\\(\\?\\^:tic\\)" CUR = 8 LEN = 0 # $] < 5.017006 @@ -387,7 +386,7 @@ do_test('reference to regexp', . ($] < 5.019003 ? '' : ' SV = REGEXP\($ADDR\) at $ADDR REFCNT = 2 - FLAGS = \(\) + FLAGS = \(POK,pPOK\) PV = $ADDR "\(\?\^:tic\)" CUR = 8 COMPFLAGS = 0x0 \(\) @@ -1162,7 +1161,7 @@ do_test('UTF-8 in a regular expression', RV = $ADDR SV = REGEXP\($ADDR\) at $ADDR REFCNT = 1 - FLAGS = \(OBJECT,FAKE,UTF8\) + FLAGS = \(OBJECT,POK,FAKE,pPOK,UTF8\) PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\] CUR = 13 STASH = $ADDR "Regexp" @@ -1186,7 +1185,7 @@ do_test('UTF-8 in a regular expression', . ($] < 5.019003 ? '' : ' SV = REGEXP\($ADDR\) at $ADDR REFCNT = 2 - FLAGS = \(UTF8\) + FLAGS = \(POK,pPOK,UTF8\) PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\] CUR = 13 COMPFLAGS = 0x0 \(\) diff --git a/globvar.sym b/globvar.sym index c82dc8f1c8..a91d520306 100644 --- a/globvar.sym +++ b/globvar.sym @@ -3,6 +3,7 @@ # *** Usual globals initialized at runtime should be added in *var*.h. PL_No +PL_Zero PL_Yes PL_bincompat_options PL_bitcount diff --git a/gv.c b/gv.c index 5da09dfe77..39782bcb5e 100644 --- a/gv.c +++ b/gv.c @@ -3180,11 +3180,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case abs_amg: if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { - SV* const nullsv=sv_2mortal(newSViv(0)); + SV* const nullsv=&PL_sv_zero; if (off1==lt_amg) { SV* const lessp = amagic_call(left,nullsv, lt_amg,AMGf_noright); - logic = SvTRUE(lessp); + logic = SvTRUE_NN(lessp); } else { SV* const lessp = amagic_call(left,nullsv, ncmp_amg,AMGf_noright); @@ -3204,7 +3204,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case neg_amg: if ((cv = cvp[off=subtr_amg])) { right = left; - left = sv_2mortal(newSViv(0)); + left = &PL_sv_zero; lr = 1; } break; @@ -3557,7 +3557,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case dec_amg: SvSetSV(left,res); return left; case not_amg: - ans=!SvTRUE(res); break; + ans=!SvTRUE_NN(res); break; default: ans=0; break; } diff --git a/hv.c b/hv.c index 3da7910d50..20b4eceb98 100644 --- a/hv.c +++ b/hv.c @@ -509,7 +509,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* This cast somewhat evil, but I'm merely using NULL/ not NULL to return the boolean exists. And I know hv is not NULL. */ - return SvTRUE(svret) ? (void *)hv : NULL; + return SvTRUE_NN(svret) ? (void *)hv : NULL; } #ifdef ENV_IS_CASELESS else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { @@ -967,6 +967,75 @@ Perl_hv_scalar(pTHX_ HV *hv) return sv; } + +/* +hv_pushkv(): push all the keys and/or values of a hash onto the stack. +The rough Perl equivalents: + () = %hash; + () = keys %hash; + () = values %hash; + +Resets the hash's iterator. + +flags : 1 = push keys + 2 = push values + 1|2 = push keys and values + XXX use symbolic flag constants at some point? +I might unroll the non-tied hv_iternext() in here at some point - DAPM +*/ + +void +Perl_hv_pushkv(pTHX_ HV *hv, U32 flags) +{ + HE *entry; + bool tied = SvRMAGICAL(hv) && mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied); + dSP; + + PERL_ARGS_ASSERT_HV_PUSHKV; + assert(flags); /* must be pushing at least one of keys and values */ + + (void)hv_iterinit(hv); + + if (tied) { + SSize_t ext = (flags == 3) ? 2 : 1; + while ((entry = hv_iternext(hv))) { + EXTEND(SP, ext); + if (flags & 1) + PUSHs(hv_iterkeysv(entry)); + if (flags & 2) + PUSHs(hv_iterval(hv, entry)); + } + } + else { + Size_t nkeys = HvUSEDKEYS(hv); + SSize_t ext; + + if (!nkeys) + return; + + /* 2*nkeys() should never be big enough to truncate or wrap */ + assert(nkeys <= (SSize_t_MAX >> 1)); + ext = nkeys * ((flags == 3) ? 2 : 1); + + EXTEND_MORTAL(nkeys); + EXTEND(SP, ext); + + while ((entry = hv_iternext(hv))) { + if (flags & 1) { + SV *keysv = newSVhek(HeKEY_hek(entry)); + SvTEMP_on(keysv); + PL_tmps_stack[++PL_tmps_ix] = keysv; + PUSHs(keysv); + } + if (flags & 2) + PUSHs(HeVAL(entry)); + } + } + + PUTBACK; +} + + /* =for apidoc hv_bucket_ratio @@ -995,12 +1064,13 @@ Perl_hv_bucket_ratio(pTHX_ HV *hv) return magic_scalarpack(hv, mg); } - sv = sv_newmortal(); - if (HvUSEDKEYS((HV *)hv)) + if (HvUSEDKEYS((HV *)hv)) { + sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv) + 1); + } else - sv_setiv(sv, 0); + sv = &PL_sv_zero; return sv; } diff --git a/inline.h b/inline.h index dc74d1d93d..96a68ea75b 100644 --- a/inline.h +++ b/inline.h @@ -153,8 +153,10 @@ S_POPMARK(pTHX) PERL_STATIC_INLINE struct regexp * S_ReANY(const REGEXP * const re) { + XPV* const p = (XPV*)SvANY(re); assert(isREGEXP(re)); - return re->sv_u.svu_rx; + return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx + : (struct regexp *)p; } /* ------------------------------- sv.h ------------------------------- */ diff --git a/intrpvar.h b/intrpvar.h index c6070eab43..e2468bf3fe 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -158,12 +158,26 @@ C<&PL_sv_no>. This is the C<true> SV. See C<L</PL_sv_no>>. Always refer to this as C<&PL_sv_yes>. +=for apidoc Amn|SV|PL_sv_zero +This readonly SV has a zero numeric value and a C<"0"> string value. It's +similar to C<L</PL_sv_no>> except for its string value. Can be used as a +cheap alternative to C<mXPUSHi(0)> for example. Always refer to this as +C<&PL_sv_zero>. Introduced in 5.28. + =cut */ +#ifdef MULTIPLICITY +PERLVAR(I, sv_yes, SV) PERLVAR(I, sv_undef, SV) PERLVAR(I, sv_no, SV) -PERLVAR(I, sv_yes, SV) +PERLVAR(I, sv_zero, SV) +#else +/* store the immortals as an array to ensure they are contiguous in + * memory: makes SvIMMORTAL_INTERP(sv) possible */ +PERLVARA(I, sv_immortals, 4, SV) +#endif + PERLVAR(I, padname_undef, PADNAME) PERLVAR(I, padname_const, PADNAME) PERLVAR(I, Sv, SV *) /* used to hold temporary values */ diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index b22683ac49..fe4e24960d 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -18,6 +18,8 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE OPpSPLIT_ASSIGN OPpSPLIT_LEX + OPpPADHV_ISKEYS OPpRV2HV_ISKEYS + OPpTRUEBOOL OPpINDEX_BOOLNEG SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG SVs_PADTMP SVpad_TYPED CVf_METHOD CVf_LVALUE @@ -48,7 +50,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring MDEREF_SHIFT ); -$VERSION = '1.41'; +$VERSION = '1.42'; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -3317,9 +3319,35 @@ sub pp_substr { } maybe_local(@_, listop(@_, "substr")) } + +sub pp_index { + # Also handles pp_rindex. + # + # The body of this function includes an unrolled maybe_targmy(), + # since the two parts of that sub's actions need to have have the + # '== -1' bit in between + + my($self, $op, $cx) = @_; + + my $lex = ($op->private & OPpTARGET_MY); + my $bool = ($op->private & OPpTRUEBOOL); + + my $val = $self->listop($op, ($bool ? 14 : $lex ? 7 : $cx), $op->name); + + # (index() == -1) has op_eq and op_const optimised away + if ($bool) { + $val .= ($op->private & OPpINDEX_BOOLNEG) ? " == -1" : " != -1"; + $val = "($val)" if ($op->flags & OPf_PARENS); + } + if ($lex) { + my $var = $self->padname($op->targ); + $val = $self->maybe_parens("$var = $val", $cx, 7); + } + $val; +} + +sub pp_rindex { pp_index(@_); } sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) } -sub pp_index { maybe_targmy(@_, \&listop, "index") } -sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") } sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } sub pp_formline { listop(@_, "formline") } # see also deparse_format sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } @@ -4084,7 +4112,17 @@ sub pp_padsv { } sub pp_padav { pp_padsv(@_) } -sub pp_padhv { pp_padsv(@_) } + +sub pp_padhv { + my $op = $_[1]; + my $keys = ''; + # with OPpPADHV_ISKEYS the keys op is optimised away, except + # in scalar context the old op is kept (but not executed) so its targ + # can be used. + $keys = 'keys ' if ( ($op->private & OPpPADHV_ISKEYS) + && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR)); + $keys . pp_padsv(@_); +} sub gv_or_padgv { my $self = shift; @@ -4167,9 +4205,14 @@ sub rv2x { } sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } -sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) } sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } +sub pp_rv2hv { + my $op = $_[1]; + (($op->private & OPpRV2HV_ISKEYS) ? 'keys ' : '') + . maybe_local(@_, rv2x(@_, "%")) +} + # skip rv2av sub pp_av2arylen { my $self = shift; diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 57c523c6cb..0ee9e9ef38 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -2661,3 +2661,45 @@ our(@oa, %oh); @oa = %oh{'foo', 'bar'}; @oa = delete @oh{'foo', 'bar'}; @oa = delete %oh{'foo', 'bar'}; +#### +# keys optimised away in void and scalar context +no warnings; +; +our %h1; +my($x, %h2); +%h1; +keys %h1; +$x = %h1; +$x = keys %h1; +%h2; +keys %h2; +$x = %h2; +$x = keys %h2; +#### +# eq,const optimised away for (index() == -1) +my($a, $b); +our $c; +$c = index($a, $b) == 2; +$c = rindex($a, $b) == 2; +$c = index($a, $b) == -1; +$c = rindex($a, $b) == -1; +$c = index($a, $b) != -1; +$c = rindex($a, $b) != -1; +$c = (index($a, $b) == -1); +$c = (rindex($a, $b) == -1); +$c = (index($a, $b) != -1); +$c = (rindex($a, $b) != -1); +#### +# eq,const,sassign,madmy optimised away for (index() == -1) +my($a, $b); +my $c; +$c = index($a, $b) == 2; +$c = rindex($a, $b) == 2; +$c = index($a, $b) == -1; +$c = rindex($a, $b) == -1; +$c = index($a, $b) != -1; +$c = rindex($a, $b) != -1; +$c = (index($a, $b) == -1); +$c = (rindex($a, $b) == -1); +$c = (index($a, $b) != -1); +$c = (rindex($a, $b) != -1); diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index 034f366523..fbac993d0e 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -130,13 +130,14 @@ $bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir $bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize f ... [41 chars truncated] $bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv); $bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate); +$bits{$_}{6} = 'OPpINDEX_BOOLNEG' for qw(index rindex); $bits{$_}{1} = 'OPpITER_REVERSED' for qw(enteriter iter); $bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop); $bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem multideref); $bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av r ... [24 chars truncated] $bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign); $bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign); -$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec); +$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec); $bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(padhv ref rv2hv); $bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray); $bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open); @@ -156,7 +157,7 @@ $bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr); $bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr); $bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr); $bits{$_}{1} = 'OPpTRANS_TO_UTF' for qw(trans transr); -$bits{$_}{5} = 'OPpTRUEBOOL' for qw(padhv ref rv2hv); +$bits{$_}{5} = 'OPpTRUEBOOL' for qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst); my @bf = ( { @@ -244,7 +245,7 @@ my @bf = ( }, ); -@{$bits{aassign}}{6,5,4,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', $bf[1], $bf[1]); +@{$bits{aassign}}{6,5,4,2,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', 'OPpASSIGN_TRUEBOOL', $bf[1], $bf[1]); $bits{abs}{0} = $bf[0]; @{$bits{accept}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{add}}{1,0} = ($bf[1], $bf[1]); @@ -457,6 +458,7 @@ $bits{or}{0} = $bf[0]; $bits{orassign}{0} = $bf[0]; $bits{ord}{0} = $bf[0]; @{$bits{pack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{padhv}{0} = 'OPpPADHV_ISKEYS'; @{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]); @{$bits{padsv}}{5,4} = ($bf[8], $bf[8]); @{$bits{pipe_op}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @@ -496,7 +498,7 @@ $bits{rmdir}{0} = $bf[0]; $bits{rv2av}{0} = $bf[0]; @{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]); @{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[8], $bf[8], 'OPpDONT_INIT_GV', $bf[0]); -$bits{rv2hv}{0} = $bf[0]; +$bits{rv2hv}{0} = 'OPpRV2HV_ISKEYS'; @{$bits{rv2sv}}{5,4,0} = ($bf[8], $bf[8], $bf[0]); @{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]); @{$bits{sbit_and}}{1,0} = ($bf[1], $bf[1]); @@ -595,6 +597,7 @@ our %defines = ( OPpASSIGN_COMMON_RC1 => 32, OPpASSIGN_COMMON_SCALAR => 64, OPpASSIGN_CV_TO_GV => 128, + OPpASSIGN_TRUEBOOL => 4, OPpAVHVSWITCH_MASK => 3, OPpCONST_BARE => 64, OPpCONST_ENTERED => 16, @@ -629,6 +632,7 @@ our %defines = ( OPpFT_STACKING => 8, OPpHINT_STRICT_REFS => 2, OPpHUSH_VMSISH => 32, + OPpINDEX_BOOLNEG => 64, OPpITER_DEF => 8, OPpITER_REVERSED => 2, OPpKVSLICE => 32, @@ -654,6 +658,7 @@ our %defines = ( OPpOPEN_OUT_CRLF => 128, OPpOPEN_OUT_RAW => 64, OPpOUR_INTRO => 64, + OPpPADHV_ISKEYS => 1, OPpPADRANGE_COUNTMASK => 127, OPpPADRANGE_COUNTSHIFT => 7, OPpPAD_STATE => 64, @@ -661,6 +666,7 @@ our %defines = ( OPpREFCOUNTED => 64, OPpREPEAT_DOLIST => 64, OPpREVERSE_INPLACE => 8, + OPpRV2HV_ISKEYS => 1, OPpSLICE => 64, OPpSLICEWARNING => 4, OPpSORT_DESCEND => 16, @@ -695,6 +701,7 @@ our %labels = ( OPpASSIGN_COMMON_RC1 => 'COM_RC1', OPpASSIGN_COMMON_SCALAR => 'COM_SCALAR', OPpASSIGN_CV_TO_GV => 'CV2GV', + OPpASSIGN_TRUEBOOL => 'BOOL', OPpCONST_BARE => 'BARE', OPpCONST_ENTERED => 'ENTERED', OPpCONST_NOVER => 'NOVER', @@ -727,6 +734,7 @@ our %labels = ( OPpFT_STACKING => 'FTSTACKING', OPpHINT_STRICT_REFS => 'STRICT', OPpHUSH_VMSISH => 'HUSH', + OPpINDEX_BOOLNEG => 'NEG', OPpITER_DEF => 'DEF', OPpITER_REVERSED => 'REVERSED', OPpKVSLICE => 'KVSLICE', @@ -751,11 +759,13 @@ our %labels = ( OPpOPEN_OUT_CRLF => 'OUTCR', OPpOPEN_OUT_RAW => 'OUTBIN', OPpOUR_INTRO => 'OURINTR', + OPpPADHV_ISKEYS => 'KEYS', OPpPAD_STATE => 'STATE', OPpPV_IS_UTF8 => 'UTF', OPpREFCOUNTED => 'REFC', OPpREPEAT_DOLIST => 'DOLIST', OPpREVERSE_INPLACE => 'INPLACE', + OPpRV2HV_ISKEYS => 'KEYS', OPpSLICE => 'SLICE', OPpSLICEWARNING => 'SLICEWARN', OPpSORT_DESCEND => 'DESC', @@ -798,6 +808,7 @@ our %ops_using = ( OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftso ... [39 chars truncated] OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)], OPpHUSH_VMSISH => [qw(dbstate nextstate)], + OPpINDEX_BOOLNEG => [qw(index rindex)], OPpITER_DEF => [qw(enteriter)], OPpITER_REVERSED => [qw(enteriter iter)], OPpKVSLICE => [qw(delete)], @@ -806,28 +817,32 @@ our %ops_using = ( OPpLVAL_DEFER => [qw(aelem helem multideref)], OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2 ... [23 chars truncated] OPpLVREF_ELEM => [qw(lvref refassign)], - OPpMAYBE_LVSUB => [qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr vec)], + OPpMAYBE_LVSUB => [qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec)], OPpMAYBE_TRUEBOOL => [qw(padhv ref rv2hv)], OPpMULTIDEREF_DELETE => [qw(multideref)], OPpOFFBYONE => [qw(caller runcv wantarray)], OPpOPEN_IN_CRLF => [qw(backtick open)], OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)], + OPpPADHV_ISKEYS => [qw(padhv)], OPpPAD_STATE => [qw(lvavref lvref padav padhv padsv pushmark refassign)], OPpPV_IS_UTF8 => [qw(dump goto last next redo)], OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)], OPpREPEAT_DOLIST => [qw(repeat)], OPpREVERSE_INPLACE => [qw(reverse)], + OPpRV2HV_ISKEYS => [qw(rv2hv)], OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)], OPpSORT_DESCEND => [qw(sort)], OPpSPLIT_ASSIGN => [qw(split)], OPpSUBSTR_REPL_FIRST => [qw(substr)], OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtra ... [294 chars truncated] OPpTRANS_COMPLEMENT => [qw(trans transr)], + OPpTRUEBOOL => [qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst)], ); $ops_using{OPpASSIGN_COMMON_RC1} = $ops_using{OPpASSIGN_COMMON_AGG}; $ops_using{OPpASSIGN_COMMON_SCALAR} = $ops_using{OPpASSIGN_COMMON_AGG}; $ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS}; +$ops_using{OPpASSIGN_TRUEBOOL} = $ops_using{OPpASSIGN_COMMON_AGG}; $ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE}; $ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE}; $ops_using{OPpCONST_SHORTCIRCUIT} = $ops_using{OPpCONST_BARE}; @@ -865,6 +880,5 @@ $ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_COMPLEMENT}; $ops_using{OPpTRANS_IDENTICAL} = $ops_using{OPpTRANS_COMPLEMENT}; $ops_using{OPpTRANS_SQUASH} = $ops_using{OPpTRANS_COMPLEMENT}; $ops_using{OPpTRANS_TO_UTF} = $ops_using{OPpTRANS_COMPLEMENT}; -$ops_using{OPpTRUEBOOL} = $ops_using{OPpMAYBE_TRUEBOOL}; # ex: set ro: diff --git a/lib/overload.t b/lib/overload.t index d778776ef7..b684c4ca33 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -48,7 +48,7 @@ package main; $| = 1; BEGIN { require './test.pl'; require './charset_tools.pl' } -plan tests => 5215; +plan tests => 5217; use Scalar::Util qw(tainted); @@ -2816,6 +2816,16 @@ package bitops2 { 'experimental "bitwise" ops with nomethod' } +package length_utf8 { + use overload '""' => sub { "\x{100}" }; + my $o = bless []; +print length $o, "\n"; + + ::is length($o), 1, "overloaded utf8 length"; + ::is "$o", "\x{100}", "overloaded utf8 value"; +} + + { # undefining the overload stash -- KEEP THIS TEST LAST package ant; use overload '+' => 'onion'; diff --git a/makedef.pl b/makedef.pl index 9761954079..6e9ea5f0fb 100644 --- a/makedef.pl +++ b/makedef.pl @@ -482,6 +482,10 @@ unless ($define{'MULTIPLICITY'}) { ++$skip{$_} foreach qw( PL_interp_size PL_interp_size_5_18_0 + PL_sv_yes + PL_sv_undef + PL_sv_no + PL_sv_zero ); } diff --git a/mg.c b/mg.c index 498a141599..3b341d52d1 100644 --- a/mg.c +++ b/mg.c @@ -710,7 +710,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) } } } - sv_setsv(sv, NULL); + sv_set_undef(sv); return 0; } @@ -849,7 +849,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\005': /* ^E */ if (nextchar != '\0') { if (strEQ(remaining, "NCODING")) - sv_setsv(sv, NULL); + sv_set_undef(sv); break; } @@ -960,7 +960,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvROK_on(sv); sv_rvweaken(sv); } - else sv_setsv_nomg(sv, NULL); + else + sv_set_undef(sv); } break; case '\017': /* ^O & ^OPEN */ @@ -2061,7 +2062,7 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) if (obj) { sv_setiv(sv, AvFILL(obj)); } else { - sv_setsv(sv, NULL); + sv_set_undef(sv); } return 0; } @@ -2139,7 +2140,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) sv_setuv(sv, i); return 0; } - sv_setsv(sv,NULL); + sv_set_undef(sv); return 0; } diff --git a/op.c b/op.c index fedaf67cc7..69cc69325a 100644 --- a/op.c +++ b/op.c @@ -3092,7 +3092,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; case OP_AVHVSWITCH: if (type == OP_LEAVESUBLV - && (o->op_private & 3) + OP_EACH == OP_KEYS) + && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS) o->op_private |= OPpMAYBE_LVSUB; goto nomod; case OP_AV2ARYLEN: @@ -9471,6 +9471,8 @@ Perl_oopsHV(pTHX_ OP *o) case OP_RV2SV: case OP_RV2AV: OpTYPE_set(o, OP_RV2HV); + /* rv2hv steals the bottom bit for its own uses */ + o->op_private &= ~OPpARG1_MASK; ref(o, OP_RV2HV); break; @@ -9813,6 +9815,53 @@ Perl_ck_eof(pTHX_ OP *o) return o; } + +/* for OP_EQ, OP_NE, OP_I_EQ, OP_I_NE */ + +OP * +Perl_ck_eq(pTHX_ OP *o) +{ + OP *indexop, *constop, *start; + SV *sv; + PERL_ARGS_ASSERT_CK_EQ; + + /* convert (index(...) == -1) and variations into + * (r)index/BOOL(,NEG) + */ + + indexop = cUNOPo->op_first; + constop = OpSIBLING(indexop); + start = NULL; + if (indexop->op_type == OP_CONST) { + constop = indexop; + indexop = OpSIBLING(constop); + start = constop; + } + + if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX) + return o; + + if (constop->op_type != OP_CONST) + return o; + + sv = cSVOPx_sv(constop); + if (!(sv && SvIOK_notUV(sv) && SvIVX(sv) == -1)) + return o; + + assert(!(indexop->op_private & OPpTARGET_MY)); + indexop->op_flags &= ~OPf_PARENS; + indexop->op_flags |= (o->op_flags & OPf_PARENS); + indexop->op_private |= OPpTRUEBOOL; + if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) + indexop->op_private |= OPpINDEX_BOOLNEG; + /* cut out the index op and free the eq,const ops */ + (void)op_sibling_splice(o, start, 1, NULL); + op_free(o); + + return indexop; +} + + OP * Perl_ck_eval(pTHX_ OP *o) { @@ -9925,6 +9974,10 @@ Perl_ck_rvconst(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_RVCONST; + if (o->op_type == OP_RV2HV) + /* rv2hv steals the bottom bit for its own uses */ + o->op_private &= ~OPpARG1_MASK; + o->op_private |= (PL_hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { @@ -10428,7 +10481,9 @@ Perl_ck_index(pTHX_ OP *o) if (kid && kid->op_type == OP_CONST) { const bool save_taint = TAINT_get; SV *sv = kSVOP->op_sv; - if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) { + if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv)) + && SvOK(sv) && !SvROK(sv)) + { sv = newSV(0); sv_copypv(sv, kSVOP->op_sv); SvREFCNT_dec_NN(kSVOP->op_sv); @@ -13488,19 +13543,68 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) /* 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. + * only ever be consumed by later ops via 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. + * bool_flag; but see below why maybe_flag is needed too. + * + * Typically the two flags you pass will be the generic OPpTRUEBOOL and + * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may + * already be taken, so you'll have to give that op two different flags. + * + * More explanation of 'maybe_flag' and 'safe_and' parameters. + * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use + * those underlying ops) short-circuit, which means that rather than + * necessarily returning a truth value, they may return the LH argument, + * which may not be boolean. For example in $x = (keys %h || -1), keys + * should return a key count rather than a boolean, even though its + * sort-of being used in boolean context. + * + * So we only consider such logical ops to provide boolean context to + * their LH argument if they themselves are in void or boolean context. + * However, sometimes the context isn't known until run-time. In this + * case the op is marked with the maybe_flag flag it. + * + * Consider the following. + * + * sub f { ....; if (%h) { .... } } + * + * This is actually compiled as + * + * sub f { ....; %h && do { .... } } + * + * Here we won't know until runtime whether the final statement (and hence + * the &&) is in void context and so is safe to return a boolean value. + * So mark o with maybe_flag rather than the bool_flag. + * Note that there is cost associated with determining context at runtime + * (e.g. a call to block_gimme()), so it may not be worth setting (at + * compile time) and testing (at runtime) maybe_flag if the scalar verses + * boolean costs savings are marginal. + * + * However, we can do slightly better with && (compared to || and //): + * this op only returns its LH argument when that argument is false. In + * this case, as long as the op promises to return a false value which is + * valid in both boolean and scalar contexts, we can mark an op consumed + * by && with bool_flag rather than maybe_flag. + * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather + * than &PL_sv_no for a false result in boolean context, then it's safe. An + * op which promises to handle this case is indicated by setting safe_and + * to true. */ static void -S_check_for_bool_cxt(OP*o, U8 bool_flag, U8 maybe_flag) +S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag) { OP *lop; + U8 flag = 0; assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR); + /* OPpTARGET_MY and boolean context probably don't mix well. + * If someone finds a valid use case, maybe add an extra flag to this + * function which indicates its safe to do so for this op? */ + assert(!( (PL_opargs[o->op_type] & OA_TARGLEX) + && (o->op_private & OPpTARGET_MY))); + lop = o->op_next; while (lop) { @@ -13525,7 +13629,7 @@ S_check_for_bool_cxt(OP*o, U8 bool_flag, U8 maybe_flag) case OP_XOR: case OP_COND_EXPR: case OP_GREPWHILE: - o->op_private |= bool_flag; + flag = bool_flag; lop = NULL; break; @@ -13535,16 +13639,22 @@ S_check_for_bool_cxt(OP*o, U8 bool_flag, U8 maybe_flag) * that whatever follows consumes the arg only in boolean context * too. */ + case OP_AND: + if (safe_and) { + flag = bool_flag; + lop = NULL; + break; + } + /* FALLTHROUGH */ case OP_OR: case OP_DOR: - case OP_AND: if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) { - o->op_private |= bool_flag; + flag = bool_flag; lop = NULL; } else if (!(lop->op_flags & OPf_WANT)) { /* unknown context - decide at runtime */ - o->op_private |= maybe_flag; + flag = maybe_flag; lop = NULL; } break; @@ -13557,6 +13667,8 @@ S_check_for_bool_cxt(OP*o, U8 bool_flag, U8 maybe_flag) if (lop) lop = lop->op_next; } + + o->op_private |= flag; } @@ -14288,15 +14400,54 @@ Perl_rpeep(pTHX_ OP *o) break; } + case OP_RV2AV: + if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) + S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); + break; + case OP_RV2HV: case OP_PADHV: + /*'keys %h' in void or scalar context: skip the OP_KEYS + * and perform the functionality directly in the RV2HV/PADHV + * op + */ + if (o->op_flags & OPf_REF) { + OP *k = o->op_next; + U8 want = (k->op_flags & OPf_WANT); + if ( k + && k->op_type == OP_KEYS + && ( want == OPf_WANT_VOID + || want == OPf_WANT_SCALAR) + && !(k->op_private & OPpMAYBE_LVSUB) + && !(k->op_flags & OPf_MOD) + ) { + o->op_next = k->op_next; + o->op_flags &= ~(OPf_REF|OPf_WANT); + o->op_flags |= want; + o->op_private |= (o->op_type == OP_PADHV ? + OPpRV2HV_ISKEYS : OPpRV2HV_ISKEYS); + /* for keys(%lex), hold onto the OP_KEYS's targ + * since padhv doesn't have its own targ to return + * an int with */ + if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR)) + op_null(k); + } + } + /* see if %h is used in boolean context */ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) - S_check_for_bool_cxt(o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); + S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); + + if (o->op_type != OP_PADHV) break; /* FALLTHROUGH */ case OP_PADAV: + if ( o->op_type == OP_PADAV + && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR + ) + S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); + /* FALLTHROUGH */ case OP_PADSV: /* Skip over state($x) in void context. */ if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) @@ -14417,9 +14568,12 @@ Perl_rpeep(pTHX_ OP *o) o->op_opt = 1; break; + case OP_GREPWHILE: + if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) + S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); + /* FALLTHROUGH */ case OP_COND_EXPR: case OP_MAPWHILE: - case OP_GREPWHILE: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: @@ -14451,6 +14605,8 @@ Perl_rpeep(pTHX_ OP *o) break; case OP_SUBST: + if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) + S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); assert(!(cPMOP->op_pmflags & PMf_ONCE)); while (cPMOP->op_pmstashstartu.op_pmreplstart && cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) @@ -14784,13 +14940,30 @@ Perl_rpeep(pTHX_ OP *o) o->op_private &= ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1); + if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) + S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0); break; } case OP_REF: /* see if ref() is used in boolean context */ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) - S_check_for_bool_cxt(o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); + S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); + break; + + case OP_LENGTH: + /* see if the op is used in known boolean context, + * but not if OA_TARGLEX optimisation is enabled */ + if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR + && !(o->op_private & OPpTARGET_MY) + ) + S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); + break; + + case OP_POS: + /* see if the op is used in known boolean context */ + if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) + S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); break; case OP_CUSTOM: { diff --git a/opcode.h b/opcode.h index f3ba953016..23595c14f5 100644 --- a/opcode.h +++ b/opcode.h @@ -329,7 +329,6 @@ EXTCONST char* const PL_op_name[] = { "andassign", "orassign", "dorassign", - "method", "entersub", "leavesub", "leavesublv", @@ -358,6 +357,7 @@ EXTCONST char* const PL_op_name[] = { "dump", "goto", "exit", + "method", "method_named", "method_super", "method_redir", @@ -733,7 +733,6 @@ EXTCONST char* const PL_op_desc[] = { "logical and assignment (&&=)", "logical or assignment (||=)", "defined or assignment (//=)", - "method lookup", "subroutine entry", "subroutine exit", "lvalue subroutine return", @@ -762,6 +761,7 @@ EXTCONST char* const PL_op_desc[] = { "dump", "goto", "exit", + "method lookup", "method with known name", "super with known name", "redirect method with known name", @@ -1151,7 +1151,6 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_andassign, /* implemented by Perl_pp_and */ Perl_pp_orassign, /* implemented by Perl_pp_or */ Perl_pp_dorassign, /* implemented by Perl_pp_defined */ - Perl_pp_method, Perl_pp_entersub, Perl_pp_leavesub, Perl_pp_leavesublv, @@ -1180,6 +1179,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_dump, /* implemented by Perl_pp_goto */ Perl_pp_goto, Perl_pp_exit, + Perl_pp_method, Perl_pp_method_named, Perl_pp_method_super, Perl_pp_method_redir, @@ -1460,10 +1460,10 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_cmp, /* i_le */ Perl_ck_cmp, /* ge */ Perl_ck_cmp, /* i_ge */ - Perl_ck_null, /* eq */ - Perl_ck_null, /* i_eq */ - Perl_ck_null, /* ne */ - Perl_ck_null, /* i_ne */ + Perl_ck_eq, /* eq */ + Perl_ck_eq, /* i_eq */ + Perl_ck_eq, /* ne */ + Perl_ck_eq, /* i_ne */ Perl_ck_null, /* ncmp */ Perl_ck_null, /* i_ncmp */ Perl_ck_null, /* slt */ @@ -1565,7 +1565,6 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_null, /* andassign */ Perl_ck_null, /* orassign */ Perl_ck_null, /* dorassign */ - Perl_ck_method, /* method */ Perl_ck_subr, /* entersub */ Perl_ck_null, /* leavesub */ Perl_ck_null, /* leavesublv */ @@ -1594,6 +1593,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_null, /* dump */ Perl_ck_null, /* goto */ Perl_ck_fun, /* exit */ + Perl_ck_method, /* method */ Perl_ck_null, /* method_named */ Perl_ck_null, /* method_super */ Perl_ck_null, /* method_redir */ @@ -1938,7 +1938,7 @@ EXTCONST U32 PL_opargs[] = { 0x00004b08, /* keys */ 0x00001b00, /* delete */ 0x00001b04, /* exists */ - 0x00000140, /* rv2hv */ + 0x00000148, /* rv2hv */ 0x00014204, /* helem */ 0x00024401, /* hslice */ 0x00024401, /* kvhslice */ @@ -1973,7 +1973,6 @@ EXTCONST U32 PL_opargs[] = { 0x00000304, /* andassign */ 0x00000304, /* orassign */ 0x00000304, /* dorassign */ - 0x00000e40, /* method */ 0x00002141, /* entersub */ 0x00000100, /* leavesub */ 0x00000100, /* leavesublv */ @@ -2002,6 +2001,7 @@ EXTCONST U32 PL_opargs[] = { 0x00000d44, /* dump */ 0x00000d04, /* goto */ 0x00009b04, /* exit */ + 0x00000e40, /* method */ 0x00000e40, /* method_named */ 0x00000e40, /* method_super */ 0x00000e40, /* method_redir */ @@ -2199,6 +2199,8 @@ END_EXTERN_C #define OPpARG1_MASK 0x01 #define OPpCOREARGS_DEREF1 0x01 #define OPpENTERSUB_INARGS 0x01 +#define OPpPADHV_ISKEYS 0x01 +#define OPpRV2HV_ISKEYS 0x01 #define OPpSORT_NUMERIC 0x01 #define OPpTRANS_FROM_UTF 0x01 #define OPpARGELEM_AV 0x02 @@ -2213,6 +2215,7 @@ END_EXTERN_C #define OPpARG2_MASK 0x03 #define OPpAVHVSWITCH_MASK 0x03 #define OPpARGELEM_HV 0x04 +#define OPpASSIGN_TRUEBOOL 0x04 #define OPpCONST_SHORTCIRCUIT 0x04 #define OPpDONT_INIT_GV 0x04 #define OPpENTERSUB_HASTARG 0x04 @@ -2276,6 +2279,7 @@ END_EXTERN_C #define OPpENTERSUB_DB 0x40 #define OPpEXISTS_SUB 0x40 #define OPpFLIP_LINENUM 0x40 +#define OPpINDEX_BOOLNEG 0x40 #define OPpLIST_GUESSED 0x40 #define OPpLVAL_DEFER 0x40 #define OPpOPEN_OUT_RAW 0x40 @@ -2373,6 +2377,7 @@ EXTCONST char PL_op_private_labels[] = { 'I','N','P','L','A','C','E','\0', 'I','N','T','\0', 'I','T','E','R','\0', + 'K','E','Y','S','\0', 'K','V','S','L','I','C','E','\0', 'L','E','X','\0', 'L','I','N','E','N','U','M','\0', @@ -2381,6 +2386,7 @@ EXTCONST char PL_op_private_labels[] = { 'L','V','I','N','T','R','O','\0', 'L','V','S','U','B','\0', 'M','A','R','K','\0', + 'N','E','G','\0', 'N','O','(',')','\0', 'N','O','I','N','I','T','\0', 'N','O','V','E','R','\0', @@ -2428,14 +2434,14 @@ EXTCONST char PL_op_private_labels[] = { EXTCONST I16 PL_op_private_bitfields[] = { 0, 8, -1, 0, 8, -1, - 0, 547, -1, + 0, 556, -1, 0, 8, -1, 0, 8, -1, - 0, 554, -1, - 0, 543, -1, - 1, -1, 0, 520, 1, 33, 2, 283, -1, + 0, 563, -1, + 0, 552, -1, + 1, -1, 0, 529, 1, 33, 2, 283, -1, 4, -1, 1, 164, 2, 171, 3, 178, -1, - 4, -1, 0, 520, 1, 33, 2, 283, 3, 110, -1, + 4, -1, 0, 529, 1, 33, 2, 283, 3, 110, -1, }; @@ -2455,20 +2461,20 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 12, /* gelem */ 13, /* padsv */ 16, /* padav */ - 20, /* padhv */ + 21, /* padhv */ -1, /* padany */ - 26, /* rv2gv */ - 33, /* rv2sv */ - 38, /* av2arylen */ - 40, /* rv2cv */ + 28, /* rv2gv */ + 35, /* rv2sv */ + 40, /* av2arylen */ + 42, /* rv2cv */ -1, /* anoncode */ 0, /* prototype */ 0, /* refgen */ 0, /* srefgen */ - 47, /* ref */ - 50, /* bless */ - 51, /* backtick */ - 50, /* glob */ + 49, /* ref */ + 52, /* bless */ + 53, /* backtick */ + 52, /* glob */ 0, /* readline */ -1, /* rcatline */ 0, /* regcmaybe */ @@ -2476,20 +2482,20 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 0, /* regcomp */ -1, /* match */ -1, /* qr */ - -1, /* subst */ + 58, /* subst */ 0, /* substcont */ - 56, /* trans */ - 56, /* transr */ - 63, /* sassign */ - 66, /* aassign */ + 59, /* trans */ + 59, /* transr */ + 66, /* sassign */ + 69, /* aassign */ 0, /* chop */ 0, /* schop */ - 71, /* chomp */ - 71, /* schomp */ + 75, /* chomp */ + 75, /* schomp */ 0, /* defined */ 0, /* undef */ 0, /* study */ - 38, /* pos */ + 77, /* pos */ 0, /* preinc */ 0, /* i_preinc */ 0, /* predec */ @@ -2498,22 +2504,22 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 0, /* i_postinc */ 0, /* postdec */ 0, /* i_postdec */ - 73, /* pow */ - 73, /* multiply */ - 73, /* i_multiply */ - 73, /* divide */ - 73, /* i_divide */ - 73, /* modulo */ - 73, /* i_modulo */ - 75, /* repeat */ - 73, /* add */ - 73, /* i_add */ - 73, /* subtract */ - 73, /* i_subtract */ - 73, /* concat */ - 77, /* stringify */ - 73, /* left_shift */ - 73, /* right_shift */ + 80, /* pow */ + 80, /* multiply */ + 80, /* i_multiply */ + 80, /* divide */ + 80, /* i_divide */ + 80, /* modulo */ + 80, /* i_modulo */ + 82, /* repeat */ + 80, /* add */ + 80, /* i_add */ + 80, /* subtract */ + 80, /* i_subtract */ + 80, /* concat */ + 84, /* stringify */ + 80, /* left_shift */ + 80, /* right_shift */ 12, /* lt */ 12, /* i_lt */ 12, /* gt */ @@ -2538,9 +2544,9 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 12, /* bit_and */ 12, /* bit_xor */ 12, /* bit_or */ - 73, /* nbit_and */ - 73, /* nbit_xor */ - 73, /* nbit_or */ + 80, /* nbit_and */ + 80, /* nbit_xor */ + 80, /* nbit_or */ 12, /* sbit_and */ 12, /* sbit_xor */ 12, /* sbit_or */ @@ -2548,114 +2554,114 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 0, /* i_negate */ 0, /* not */ 0, /* complement */ - 71, /* ncomplement */ - 71, /* scomplement */ + 75, /* ncomplement */ + 75, /* scomplement */ 12, /* smartmatch */ - 77, /* atan2 */ - 71, /* sin */ - 71, /* cos */ - 77, /* rand */ - 77, /* srand */ - 71, /* exp */ - 71, /* log */ - 71, /* sqrt */ - 71, /* int */ - 71, /* hex */ - 71, /* oct */ - 71, /* abs */ - 71, /* length */ - 79, /* substr */ - 82, /* vec */ - 77, /* index */ - 77, /* rindex */ - 50, /* sprintf */ - 50, /* formline */ - 71, /* ord */ - 71, /* chr */ - 77, /* crypt */ + 84, /* atan2 */ + 75, /* sin */ + 75, /* cos */ + 84, /* rand */ + 84, /* srand */ + 75, /* exp */ + 75, /* log */ + 75, /* sqrt */ + 75, /* int */ + 75, /* hex */ + 75, /* oct */ + 75, /* abs */ + 86, /* length */ + 89, /* substr */ + 92, /* vec */ + 94, /* index */ + 94, /* rindex */ + 52, /* sprintf */ + 52, /* formline */ + 75, /* ord */ + 75, /* chr */ + 84, /* crypt */ 0, /* ucfirst */ 0, /* lcfirst */ 0, /* uc */ 0, /* lc */ 0, /* quotemeta */ - 84, /* rv2av */ - 90, /* aelemfast */ - 90, /* aelemfast_lex */ - 91, /* aelem */ - 96, /* aslice */ - 99, /* kvaslice */ + 98, /* rv2av */ + 105, /* aelemfast */ + 105, /* aelemfast_lex */ + 106, /* aelem */ + 111, /* aslice */ + 114, /* kvaslice */ 0, /* aeach */ 0, /* avalues */ - 38, /* akeys */ + 40, /* akeys */ 0, /* each */ - 0, /* values */ - 38, /* keys */ - 100, /* delete */ - 104, /* exists */ - 106, /* rv2hv */ - 91, /* helem */ - 96, /* hslice */ - 99, /* kvhslice */ - 114, /* multideref */ - 50, /* unpack */ - 50, /* pack */ - 121, /* split */ - 50, /* join */ - 126, /* list */ + 40, /* values */ + 40, /* keys */ + 115, /* delete */ + 119, /* exists */ + 121, /* rv2hv */ + 106, /* helem */ + 111, /* hslice */ + 114, /* kvhslice */ + 129, /* multideref */ + 52, /* unpack */ + 52, /* pack */ + 136, /* split */ + 52, /* join */ + 141, /* list */ 12, /* lslice */ - 50, /* anonlist */ - 50, /* anonhash */ - 50, /* splice */ - 77, /* push */ + 52, /* anonlist */ + 52, /* anonhash */ + 52, /* splice */ + 84, /* push */ 0, /* pop */ 0, /* shift */ - 77, /* unshift */ - 128, /* sort */ - 135, /* reverse */ + 84, /* unshift */ + 143, /* sort */ + 150, /* reverse */ 0, /* grepstart */ - 0, /* grepwhile */ + 152, /* grepwhile */ 0, /* mapstart */ 0, /* mapwhile */ 0, /* range */ - 137, /* flip */ - 137, /* flop */ + 154, /* flip */ + 154, /* flop */ 0, /* and */ 0, /* or */ 12, /* xor */ 0, /* dor */ - 139, /* cond_expr */ + 156, /* cond_expr */ 0, /* andassign */ 0, /* orassign */ 0, /* dorassign */ - 0, /* method */ - 141, /* entersub */ - 148, /* leavesub */ - 148, /* leavesublv */ + 158, /* entersub */ + 165, /* leavesub */ + 165, /* leavesublv */ 0, /* argcheck */ - 150, /* argelem */ + 167, /* argelem */ 0, /* argdefelem */ - 152, /* caller */ - 50, /* warn */ - 50, /* die */ - 50, /* reset */ + 169, /* caller */ + 52, /* warn */ + 52, /* die */ + 52, /* reset */ -1, /* lineseq */ - 154, /* nextstate */ - 154, /* dbstate */ + 171, /* nextstate */ + 171, /* dbstate */ -1, /* unstack */ -1, /* enter */ - 155, /* leave */ + 172, /* leave */ -1, /* scope */ - 157, /* enteriter */ - 161, /* iter */ + 174, /* enteriter */ + 178, /* iter */ -1, /* enterloop */ - 162, /* leaveloop */ + 179, /* leaveloop */ -1, /* return */ - 164, /* last */ - 164, /* next */ - 164, /* redo */ - 164, /* dump */ - 164, /* goto */ - 50, /* exit */ + 181, /* last */ + 181, /* next */ + 181, /* redo */ + 181, /* dump */ + 181, /* goto */ + 52, /* exit */ + 0, /* method */ 0, /* method_named */ 0, /* method_super */ 0, /* method_redir */ @@ -2666,143 +2672,143 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 0, /* leavewhen */ -1, /* break */ -1, /* continue */ - 166, /* open */ - 50, /* close */ - 50, /* pipe_op */ - 50, /* fileno */ - 50, /* umask */ - 50, /* binmode */ - 50, /* tie */ + 183, /* open */ + 52, /* close */ + 52, /* pipe_op */ + 52, /* fileno */ + 52, /* umask */ + 52, /* binmode */ + 52, /* tie */ 0, /* untie */ 0, /* tied */ - 50, /* dbmopen */ **** PATCH TRUNCATED AT 2000 LINES -- 3470 NOT SHOWN **** -- Perl5 Master Repository
