In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/362d2cd85ebfe95231952e6fccbaadc26915db9d?hp=ec121dacb4d1d7f6aa78abbd19bf388858bf5095>
- Log -----------------------------------------------------------------
commit 362d2cd85ebfe95231952e6fccbaadc26915db9d
Merge: ec121dacb4 625e589c31
Author: David Mitchell <da...@iabyn.com>
Date: Mon Jun 24 11:40:30 2019 +0100
[MERGE] make optree-walking mostly non-recursive
This branch updates many of the functions in op.c which recursively
walk an op tree during compilation. This avoids SEGVs from stack
overflow when the op tree is deeply nested, such as
$n == 1 ? "one" : $n == 2 ? "two" : ....
(especially in code which is auto-generated)
This is particularly noticeable where the code is compiled within a
separate thread, as threads tend to have small stacks by default.
Some functions already avoided recursion by mallocing a buffer
containing a list of ops to visit, but this could be leaked if the code
died during compilation.
Making the functions non-recursive is a lot easier now that the last
node in each OpSIBLING chain holds a pointer back to the parent node.
Where the function needs to recursively visit *every* node, its just a
case of following each child link, then every OpSIBLING link then the
parent link. Where the recursion is more selective, it becomes more
tricky. In some cases I have followed the policy that a node has N kids
and kids I..N need visiting, then start at I and iterate as usual; but
if just kids I and J needs visiting (but not J+1..N), then do old-style
recursion on nodes I and J. These cases are hopefully rare.
commit 625e589c312fe504e4ad66b1777068806658eb77
Author: David Mitchell <da...@iabyn.com>
Date: Fri Jun 14 11:26:37 2019 +0100
Perl_op_lvalue_flags(): make mostly non-recursive
Recursion is left in a few places where is necessary to call itself
with a different value for 'type'.
commit 17803dc3b050d83067247976120f5eb6bfaca010
Author: David Mitchell <da...@iabyn.com>
Date: Wed Jun 12 12:03:52 2019 +0100
Perl_op_lvalue_flags() add blank lines
... between switch cases for readability.
commit 05ba7c096a1637812610fe686e02f626fa5a39f0
Author: David Mitchell <da...@iabyn.com>
Date: Wed Jun 12 11:57:54 2019 +0100
Perl_op_lvalue_flags(): skip OPf_WANT_VOID ops.
Currently this function asserts that its 'o' argument is non-VOID;
later when recursing an OP_LIST, it skips any kids which are VOID.
This commit changes it so that the assert becomes a return, and
OP_LIST doesn't check whether its kids are VOID.
Doing it this way makes it easier to shortly make Perl_op_lvalue_flags()
non-recursive.
The only functional difference is that on debugging builds,
Perl_op_lvalue_flags() will no longer fail an assert if inadvertently
called with a VOID op.
commit e709958e34204643641c90201e2734d0b3014d99
Author: David Mitchell <da...@iabyn.com>
Date: Thu Jun 6 13:32:25 2019 +0100
Perl_op_lvalue_flags(): fixup documentation
First, move the apidoc text for op_lvalue() to be directly above
Perl_op_lvalue_flags() (it had wandered).
Secondly, add a brief non-API note explaining what the extra 'flags'
parameter does
commit 42f273ac0f2bcf1f5deaee77ed5d539e461c001d
Author: David Mitchell <da...@iabyn.com>
Date: Thu Jun 6 13:01:41 2019 +0100
reindent op.c:S_lvref()
... after the previous commit wrapped most if it in a while loop. Also
put a blank line after each switch case for readability.
commit 2ebbb0d7de1e4a19c6f3f8ad35cc403688d6ff9a
Author: David Mitchell <da...@iabyn.com>
Date: Thu Jun 6 13:00:18 2019 +0100
make op.c:S_lvref() non-recursive
commit 11912a83439c49b325f56b244ad4ac16e21e331e
Author: David Mitchell <da...@iabyn.com>
Date: Tue Jun 4 13:41:21 2019 +0100
document what op.c:S_lvref() does
commit 74ed399efffedf3c45f2d9edc9eb669aa6ac9ec5
Author: David Mitchell <da...@iabyn.com>
Date: Tue Jun 4 13:33:22 2019 +0100
op.c: S_lvref(): handle all kids on OP_NULL
For an OP_NULL, his function formerly recursed into *all* its kids
if was an ex-list, otherwise only the first one.
To simplify making this function non-recursive, make it so that it
unconditionally recurses into all the kids.
However for now, also add an assertion that a non ex-list OP_NULL
will only have one child at most. If we find some code which violates
this, then we can nmake a more informed decision as to whether
non ex-list OP_NULL's should have all, or only their first child
examined.
commit 4ef0eb8d1c25055f5231b8c51fcbecd3000356ae
Author: David Mitchell <da...@iabyn.com>
Date: Fri May 31 16:59:53 2019 +0100
Clarify purpose of S_looks_like_bool()
commit f0d08550371fd1ddd8c85e309492802884a5a804
Author: David Mitchell <da...@iabyn.com>
Date: Fri May 31 16:53:42 2019 +0100
make op.c:S_find_and_forget_pmops() non-recursive
For every CV that's freed which has a shared optree (e.g. a closure
or between threads), the whole optree is walked looking for PMOPs.
Make that walk non-recursive.
Contrived code that triggers a stack overflow:
{
my $outer;
my $e = 'sub { $outer && '
. join('&&', ('$x') x 100_000)
. " }";
#print $e, "\n";
eval $e;
}
Even after this commit, that code still SEGVs due to a separate stack
blow in Perl_rpeep().
commit b0a7849dfb8094e767cc24bc20d8a8f704e899dd
Author: David Mitchell <da...@iabyn.com>
Date: Fri May 31 16:02:19 2019 +0100
Perl_doref(): reindent
Previous commit added a while loop.
commit e9b0092a1019a24f6bb26933c7b796c2b733d11f
Author: David Mitchell <da...@iabyn.com>
Date: Fri May 31 11:58:11 2019 +0100
Perl_doref(): make non-recursive
This stops the following code from SEGVing for example:
my $e = "\$r";
$e = "+do{$e}" for 1..70_000;
$e = "push \@{$e}, 1";
eval $e;
Similarly with a long
$a[0][0][0][0].....
This commit causes a slight change in behaviour, in that scalar(o)
is now only called once at the end of the top-level doref() call,
rather than at the end of processing each child. This should make no
functional difference, apart from speeding up compiling infinitesimally.
commit fe4e86b8d83215d20fe96e969c5fb5cb133fe090
Author: David Mitchell <da...@iabyn.com>
Date: Fri May 31 10:27:25 2019 +0100
document what Perl_doref does
commit e0f9da3349f858d1a43f62c82fd92e0db93e5dd2
Author: David Mitchell <da...@iabyn.com>
Date: Thu May 30 14:22:09 2019 +0100
make op.c:S_aassign_scan() non-recursive
With this commit and some previous ones, the following code no longer
blows the stack:
my $e = "1";
$e = "do { \$x; $e}" for 1..100_000;
$e = "\@x = $e";
eval $e;
commit 7d3bb7a6857f9a9b7f94fc0a8a3a3444becc928f
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 29 15:57:06 2019 +0100
make Perl_op_linklist() non-recursive
commit 5e21b4fc704f9e7028aca7bf5faf3f7d05b05726
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 29 15:03:42 2019 +0100
Perl_op_linklist(): use OPf_KIDS flags
This function just blindly assumes that cUNOPo->op_first is a valid
indication that the op has at least one child. This is successful *most*
of the time. Putting in an assertion caused t/op/lvref.t to fail.
Instead, check the OPf_KIDS flag.
commit 67ba1548076ba1059a495f5009a93fa143eddd77
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 29 09:49:19 2019 +0100
Perl_scalarvoid(): add comment saying what it does
It applies void context, which isn't all that obvious just from the
name.
commit e10c181fa2af9f0e0494e73284666abf73cadb3f
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 17:37:43 2019 +0100
op.c: S_search_const: remove recursion
There are a couple of places where this function recurses, but they
are both effectively tail recursion and can be easily eliminated.
commit 3e8db509ed7c1a6949798699d358c58de4d6f20f
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 17:25:33 2019 +0100
op.c: add code comments to S_search_const()
plus a few blank lines for readability.
commit f7c7511ff191e5730bac67c11df9c39c20e59258
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 15:39:50 2019 +0100
op.c: S_assignment_type(): make truly trinary
Commit 4fec880468dad87517895b935b19a8d51e98b5a6 converted the
static boolean function S_is_list_assignment() into a 3-valued
function: S_assignment_type().
However, much of the code body still did things like 'return TRUE'.
Replace these with 'return ASSIGN_LIST' etc. These have the same
physical values, so there's no functional change here. But it makes the
code more consistent and readable.
commit db18005b26986d1d422fcb53989eece313134db5
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 29 11:03:26 2019 +0100
Perl_scalar() tail-call optimise
The part of this function that scans the children of e.g.
$scalar = do { void; void; scalar }
applying scalar context only to the last child: tail call optimise that
call to Perl_scalar().
It also adds some extra 'warnings' tests. An earlier attempt at this
patch caused some unrelated tests to start emitting spurious 'useless in
void context' messages, which are covered by the new tests.
This also showed up that the current method for updating PL_curcop
while descending optrees in Perl_scalar/scalarvoid/S_scalarseq is a bit
broken. It gets updated every time a newstate op is seen, but haphazardly
(and sometimes wrongly) restored to &PL_compiling when going back up the
tree. One of the tests is TODO based on PL_curcop being wrong and so the
'no warnings "void"' leaking into an outer scope.
This commit maintains the status quo.
commit adb47cec409f1c82a623f7e218f477cb4829f2a6
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 29 10:32:41 2019 +0100
Perl_scalar(): doc and reorganise complex bool
The if statement that scans children applying void context to all except
the last child:
1) document what it does;
2) reorganise it (without changing its logical meaning) to make it
simpler to understand, and to make the next commit easier.
commit 78ae974aca2ba74ca8f136e91bcf526c6b5fbc84
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 15:25:48 2019 +0100
Perl_scalar(): indent block
.. that has just been wrapped in a while loop.
Whitespace-only change.
commit 86e988be1f8cc30bfe52e03b6c22ad3140e1fb20
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 15:23:44 2019 +0100
make Perl_scalar() mostly non-recursive
Where it just recursively calls scalar() on all its children, instead
iteratively walk the sub-tree, using o->op_sibparent to work back
upwards.
Where it is more complex, such as OP_REPEAT imposing scalar context on its
first arg but not its second, recurse as before.
commit 06c2b1fcb02816b3d9e6fc4273ddeecb05d7d2a5
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 12:23:10 2019 +0100
fix type in Perl_list()
commit 31a5e5cf9b38c340f7be60d6aebacd70d2157599
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 12:22:19 2019 +0100
Perl_scalar(): re-order a few switch cases
Just a cosmetic change.
commit b8e5030a901da7b16e64012bb6e23055d2993dc8
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 12:19:23 2019 +0100
Perl_scalar(): remove redundant switch labels
Remove some explicit cases that just do the same as 'default:'
commit 8623f87f95670c440e6004c79e5edb58006b6fd7
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 12:17:12 2019 +0100
Document what Perl_scalar() does
and add blank lines for e.g. better readability between switch() cases.
Also remove a lying /* FALLTHROUGH */
commit f23e164367e8b9494783181262bf4a1a16d26961
Author: David Mitchell <da...@iabyn.com>
Date: Tue Jun 18 15:11:12 2019 +0100
Perl_list() tail-call optimise
The part of this function that scans the children of e.g.
@a = do { void; void; list }
applying list context only to the last child, tail call optimise that
call to list().
(See also a few commits later entitled "Perl_scalar() tail-call
optimise" for a discourse on setting PL_curcop (in)correctly.)
commit 9d15d64eb1a348ee92a700e57145d4f6f01bf21f
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 29 11:22:48 2019 +0100
Perl_list(): doc and reorganise complex bool
The if statement that scans children applying void context to all except
the last child:
1) document what it does;
2) reorganise it (without changing its logical meaning) to make the next
commit easier.
commit a58b51cf64e253ea780c850d5aaac696a8ec5fca
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 11:25:22 2019 +0100
reindent Perl_list()
The previous commit wrapped most of the body of this function in a while
loop.
commit 8ef9070b464ddfe6efb0d4b1661fd51fedebfba5
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 10:57:46 2019 +0100
make Perl_list() mostly non-recursive
Where it just recursively calls list() on all its children, instead
iteratively walk the sub-tree, using o->op_sibparent to work back
upwards.
Where it is more complex, such as OP_REPEAT imposing list context on its
first arg but not its second, recurse as before.
commit 7d3088ba743b45313e7f3bf445e3b42a197251d9
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 10:08:45 2019 +0100
Perl_list(): re-order a few switch cases
Just a cosmetic change.
commit 384f4b4d7c080019f40e5d3d6481dc6e58f5a7c2
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 28 09:57:04 2019 +0100
Perl_list(): re-order recursion in OP_LIST
Call list() on an OP_LIST's children, *after* potentially nulling out
the OP_LIST and an OP_PUSHMARK. This will make removing recursion
easier. Should be no functional difference.
commit 054d8a908712a56d5f8bbd3948fceeaea63434f3
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 22 11:31:06 2019 +0100
Perl_list(): add blank lines
... between switch cases for readability.
commit 2a45276d6b8bc80148dfa02f02ce12024d491573
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 22 11:27:20 2019 +0100
Perl_list(): simplify some branches
Remove some explicit cases that just do the same as 'default:'
Also, remove OP_FLOP as a special case and just let it do the default.
This is the same behaviour (apply list() to its one child), except
that it also now does a harmless but (always false) check whether it's
child is an OP_FLOP too.
commit 0f194c83b0f19f7917e6f8b1218d49858220cda6
Author: David Mitchell <da...@iabyn.com>
Date: Fri May 17 13:01:35 2019 +0100
make S_gen_constant_list() void return
Its gen_constant_list(o) returns an OP*, but the thing it returns is
currently always o.
So just assume it returns it arg.
This will shortly make making Perl_list() non-recursive easier.
commit 7cd3586545b8386aed3a9220f193a8a2054f01dc
Author: David Mitchell <da...@iabyn.com>
Date: Fri May 17 12:58:38 2019 +0100
Document what Perl_list() and its helper do
commit d3f5b0a08053f885ee584142cbe1f9a31cffd409
Author: David Mitchell <da...@iabyn.com>
Date: Wed May 15 11:06:49 2019 +0100
remove DEFER_OP macros from op.c
the previous commit removed the last use of them
commit 6eebe43d5f2ac9b216b560316068531384f5a3dd
Author: David Mitchell <da...@iabyn.com>
Date: Tue May 14 16:47:06 2019 +0100
S_optimize_op(): remove anti-recursion deferring
S_optimize_op() used to recursively work its way down an optree
marking ops as being in the appropriate context.
This commit removes the deferred mechanism, and instead makes use of the
newish OP_PARENT mechanism to iterate over the optree, following each
kid, then back up via the parent pointer to the next sibling etc.
commit 73cdf3a836756ebe82b64077bf38de0bf44736dc
Author: David Mitchell <da...@iabyn.com>
Date: Mon Apr 8 14:17:59 2019 +0100
Make op_free() non-recursive
Stop using the DEFER mechanism (which could leak if something croaks)
and instead tree walk using the new OP_PARENT link to allow walking
back up the tree.
The freeing is done depth-first: children are freed before their
parents.
commit 2a56a87fe357165c2bf7fc0d0f54565fef60bb9a
Author: David Mitchell <da...@iabyn.com>
Date: Fri Apr 5 15:38:24 2019 +0100
scalarvoid(): remove anti-recursion deferring
Perl_scalarvoid() used to recursively work its way down an optree
marking ops as being in the appropriate context.
Around 5.22.0 the code was changed to avoid recursion, and instead to
malloc a buffer (if necessary) to maintain a list of deferred child ops
that need visiting. This stopped perl crashing if the optree (and thus
the recursion) was too deep, but it introduced a potential leak.
For example
use warnings FATAL => qw(void);
$a = "abc";
length $a ;
The fatal warning causes scalarvoid() to leak the deferred buffer.
This commit removes the deferred mechanism, and instead makes use of the
newish OP_PARENT mechanism to iterate over the optree, following each
kid, then back up via the parent pointer to the next sibling etc.
-----------------------------------------------------------------------
Summary of changes:
embed.fnc | 2 +-
op.c | 1625 ++++++++++++++++++++++++++++++++---------------------
proto.h | 2 +-
t/lib/warnings/op | 42 ++
t/op/cond.t | 15 +
t/op/list.t | 9 +-
6 files changed, 1056 insertions(+), 639 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index b8d429a2fc..0cd09172b4 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -636,7 +636,7 @@ Afpd |char* |form |NN const char* pat|...
Ap |char* |vform |NN const char* pat|NULLOK va_list* args
Ap |void |free_tmps
#if defined(PERL_IN_OP_C)
-S |OP* |gen_constant_list|NULLOK OP* o
+S |void |gen_constant_list|NULLOK OP* o
#endif
#if !defined(HAS_GETENV_LEN)
: Used in hv.c
diff --git a/op.c b/op.c
index 7aa002cadd..7081f7dceb 100644
--- a/op.c
+++ b/op.c
@@ -171,44 +171,6 @@ recursive, but it's recursive on basic blocks, not on tree
nodes.
static const char array_passed_to_stat[] = "Array passed to stat will be
coerced to a scalar";
-/* Used to avoid recursion through the op tree in scalarvoid() and
- op_free()
-*/
-
-#define dDEFER_OP \
- SSize_t defer_stack_alloc = 0; \
- SSize_t defer_ix = -1; \
- OP **defer_stack = NULL;
-#define DEFER_OP_CLEANUP Safefree(defer_stack)
-#define DEFERRED_OP_STEP 100
-#define DEFER_OP(o) \
- STMT_START { \
- if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
- defer_stack_alloc += DEFERRED_OP_STEP; \
- assert(defer_stack_alloc > 0); \
- Renew(defer_stack, defer_stack_alloc, OP *); \
- } \
- defer_stack[++defer_ix] = o; \
- } STMT_END
-#define DEFER_REVERSE(count) \
- STMT_START { \
- UV cnt = (count); \
- if (cnt > 1) { \
- OP **top = defer_stack + defer_ix; \
- /* top - (cnt) + 1 isn't safe here */ \
- OP **bottom = top - (cnt - 1); \
- OP *tmp; \
- assert(bottom >= defer_stack); \
- while (top > bottom) { \
- tmp = *top; \
- *top-- = *bottom; \
- *bottom++ = tmp; \
- } \
- } \
- } STMT_END;
-
-#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP
*)NULL)
-
/* remove any leading "empty" ops from the op_next chain whose first
* node's address is stored in op_p. Store the updated address of the
* first node in op_p.
@@ -807,8 +769,8 @@ S_op_destroy(pTHX_ OP *o)
/*
=for apidoc op_free
-Free an op. Only use this when an op is no longer linked to from any
-optree.
+Free an op and its children. Only use this when an op is no longer linked
+to from any optree.
=cut
*/
@@ -818,13 +780,68 @@ Perl_op_free(pTHX_ OP *o)
{
dVAR;
OPCODE type;
- dDEFER_OP;
+ OP *top_op = o;
+ OP *next_op = o;
+ bool went_up = FALSE; /* whether we reached the current node by
+ following the parent pointer from a child, and
+ so have already seen this node */
- do {
+ if (!o || o->op_type == OP_FREED)
+ return;
+
+ if (o->op_private & OPpREFCOUNTED) {
+ /* if base of tree is refcounted, just decrement */
+ switch (o->op_type) {
+ case OP_LEAVESUB:
+ case OP_LEAVESUBLV:
+ case OP_LEAVEEVAL:
+ case OP_LEAVE:
+ case OP_SCOPE:
+ case OP_LEAVEWRITE:
+ {
+ PADOFFSET refcnt;
+ OP_REFCNT_LOCK;
+ refcnt = OpREFCNT_dec(o);
+ OP_REFCNT_UNLOCK;
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from
+ * the list we maintain for reset(). */
+ find_and_forget_pmops(o);
+ return;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ }
+
+ while (next_op) {
+ o = next_op;
+
+ /* free child ops before ourself, (then free ourself "on the
+ * way back up") */
+
+ if (!went_up && o->op_flags & OPf_KIDS) {
+ next_op = cUNOPo->op_first;
+ continue;
+ }
+
+ /* find the next node to visit, *then* free the current node
+ * (can't rely on o->op_* fields being valid after o has been
+ * freed) */
+
+ /* The next node to visit will be either the sibling, or the
+ * parent if no siblings left, or NULL if we've worked our way
+ * back up to the top node in the tree */
+ next_op = (o == top_op) ? NULL : o->op_sibparent;
+ went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
+
+ /* Now process the current node */
/* Though ops may be freed twice, freeing the op after its slab is a
big no-no. */
- assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
+ assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
/* During the forced freeing of ops after compilation failure, kidops
may be freed before their parents. */
if (!o || o->op_type == OP_FREED)
@@ -843,7 +860,7 @@ Perl_op_free(pTHX_ OP *o)
* we can't spot faults in the main code, only
* evaled/required code */
#ifdef DEBUGGING
- if ( o->op_ppaddr == PL_ppaddr[o->op_type]
+ if ( o->op_ppaddr == PL_ppaddr[type]
&& PL_parser
&& !PL_parser->error_count)
{
@@ -851,54 +868,12 @@ Perl_op_free(pTHX_ OP *o)
}
#endif
- if (o->op_private & OPpREFCOUNTED) {
- switch (type) {
- case OP_LEAVESUB:
- case OP_LEAVESUBLV:
- case OP_LEAVEEVAL:
- case OP_LEAVE:
- case OP_SCOPE:
- case OP_LEAVEWRITE:
- {
- PADOFFSET refcnt;
- OP_REFCNT_LOCK;
- refcnt = OpREFCNT_dec(o);
- OP_REFCNT_UNLOCK;
- if (refcnt) {
- /* Need to find and remove any pattern match ops from the
list
- we maintain for reset(). */
- find_and_forget_pmops(o);
- continue;
- }
- }
- break;
- default:
- break;
- }
- }
/* Call the op_free hook if it has been set. Do it now so that it's
called
* at the right time for refcounted ops, but still before all of the
kids
* are freed. */
CALL_OPFREEHOOK(o);
- if (o->op_flags & OPf_KIDS) {
- OP *kid, *nextkid;
- assert(cUNOPo->op_first); /* OPf_KIDS implies op_first non-null */
- for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = OpSIBLING(kid); /* Get before next freeing kid */
- if (kid->op_type == OP_FREED)
- /* During the forced freeing of ops after
- compilation failure, kidops may be freed before
- their parents. */
- continue;
- if (!(kid->op_flags & OPf_KIDS))
- /* If it has no kids, just free it now */
- op_free(kid);
- else
- DEFER_OP(kid);
- }
- }
if (type == OP_NULL)
type = (OPCODE)o->op_targ;
@@ -915,11 +890,10 @@ Perl_op_free(pTHX_ OP *o)
FreeOp(o);
if (PL_op == o)
PL_op = NULL;
- } while ( (o = POP_DEFERRED_OP()) );
-
- DEFER_OP_CLEANUP;
+ }
}
+
/* S_op_clear_gv(): free a GV attached to an OP */
STATIC
@@ -1301,27 +1275,41 @@ S_forget_pmop(pTHX_ PMOP *const o)
PL_curpm = NULL;
}
+
STATIC void
S_find_and_forget_pmops(pTHX_ OP *o)
{
+ OP* top_op = o;
+
PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
- if (o->op_flags & OPf_KIDS) {
- OP *kid = cUNOPo->op_first;
- while (kid) {
- switch (kid->op_type) {
- case OP_SUBST:
- case OP_SPLIT:
- case OP_MATCH:
- case OP_QR:
- forget_pmop((PMOP*)kid);
- }
- find_and_forget_pmops(kid);
- kid = OpSIBLING(kid);
- }
+ while (1) {
+ switch (o->op_type) {
+ case OP_SUBST:
+ case OP_SPLIT:
+ case OP_MATCH:
+ case OP_QR:
+ forget_pmop((PMOP*)o);
+ }
+
+ if (o->op_flags & OPf_KIDS) {
+ o = cUNOPo->op_first;
+ continue;
+ }
+
+ while (1) {
+ if (o == top_op)
+ return; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o)) {
+ o = o->op_sibparent; /* process next sibling */
+ break;
+ }
+ o = o->op_sibparent; /*try parent's next sibling */
+ }
}
}
+
/*
=for apidoc op_null
@@ -1626,39 +1614,58 @@ not be called directly.
=cut
*/
+
OP *
Perl_op_linklist(pTHX_ OP *o)
{
- OP *first;
+
+ OP **prevp;
+ OP *kid;
+ OP * top_op = o;
PERL_ARGS_ASSERT_OP_LINKLIST;
- if (o->op_next)
- return o->op_next;
+ while (1) {
+ /* Descend down the tree looking for any unprocessed subtrees to
+ * do first */
+ if (!o->op_next) {
+ if (o->op_flags & OPf_KIDS) {
+ o = cUNOPo->op_first;
+ continue;
+ }
+ o->op_next = o; /* leaf node; link to self initially */
+ }
- /* establish postfix order */
- first = cUNOPo->op_first;
- if (first) {
- OP *kid;
- o->op_next = LINKLIST(first);
- kid = first;
- for (;;) {
- OP *sibl = OpSIBLING(kid);
- if (sibl) {
- kid->op_next = LINKLIST(sibl);
- kid = sibl;
- } else {
- kid->op_next = o;
- break;
- }
- }
- }
- else
- o->op_next = o;
+ /* if we're at the top level, there either weren't any children
+ * to process, or we've worked our way back to the top. */
+ if (o == top_op)
+ return o->op_next;
+
+ /* o is now processed. Next, process any sibling subtrees */
+
+ if (OpHAS_SIBLING(o)) {
+ o = OpSIBLING(o);
+ continue;
+ }
- return o->op_next;
+ /* Done all the subtrees at this level. Go back up a level and
+ * link the parent in with all its (processed) children.
+ */
+
+ o = o->op_sibparent;
+ assert(!o->op_next);
+ prevp = &(o->op_next);
+ kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
+ while (kid) {
+ *prevp = kid->op_next;
+ prevp = &(kid->op_next);
+ kid = OpSIBLING(kid);
+ }
+ *prevp = o;
+ }
}
+
static OP *
S_scalarkids(pTHX_ OP *o)
{
@@ -1815,122 +1822,181 @@ S_scalar_slice_warning(pTHX_ const OP *o)
SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}
+
+
+/* apply scalar context to the o subtree */
+
OP *
Perl_scalar(pTHX_ OP *o)
{
- OP *kid;
+ OP * top_op = o;
- /* assumes no premature commitment */
- if (!o || (PL_parser && PL_parser->error_count)
- || (o->op_flags & OPf_WANT)
- || o->op_type == OP_RETURN)
- {
- return o;
- }
+ while (1) {
+ OP *next_kid = NULL; /* what op (if any) to process next */
+ OP *kid;
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
+ /* assumes no premature commitment */
+ if (!o || (PL_parser && PL_parser->error_count)
+ || (o->op_flags & OPf_WANT)
+ || o->op_type == OP_RETURN)
+ {
+ goto do_next;
+ }
- switch (o->op_type) {
- case OP_REPEAT:
- scalar(cBINOPo->op_first);
- if (o->op_private & OPpREPEAT_DOLIST) {
- kid = cLISTOPx(cUNOPo->op_first)->op_first;
- assert(kid->op_type == OP_PUSHMARK);
- if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
- op_null(cLISTOPx(cUNOPo->op_first)->op_first);
- o->op_private &=~ OPpREPEAT_DOLIST;
- }
- }
- break;
- case OP_OR:
- case OP_AND:
- case OP_COND_EXPR:
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
- scalar(kid);
- break;
- /* FALLTHROUGH */
- case OP_SPLIT:
- case OP_MATCH:
- case OP_QR:
- case OP_SUBST:
- case OP_NULL:
- default:
- if (o->op_flags & OPf_KIDS) {
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
- scalar(kid);
- }
- break;
- case OP_LEAVE:
- case OP_LEAVETRY:
- kid = cLISTOPo->op_first;
- scalar(kid);
- kid = OpSIBLING(kid);
- do_kids:
- while (kid) {
- OP *sib = OpSIBLING(kid);
- if (sib && kid->op_type != OP_LEAVEWHEN
- && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
- || ( sib->op_targ != OP_NEXTSTATE
- && sib->op_targ != OP_DBSTATE )))
- scalarvoid(kid);
- else
- scalar(kid);
- kid = sib;
- }
- PL_curcop = &PL_compiling;
- break;
- case OP_SCOPE:
- case OP_LINESEQ:
- case OP_LIST:
- kid = cLISTOPo->op_first;
- goto do_kids;
- case OP_SORT:
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in
scalar context");
- break;
- case OP_KVHSLICE:
- case OP_KVASLICE:
- {
- /* Warn about scalar context */
- const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
- const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
- SV *name;
- SV *keysv;
- const char *key = NULL;
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
- /* This warning can be nonsensical when there is a syntax error. */
- if (PL_parser && PL_parser->error_count)
- break;
+ switch (o->op_type) {
+ case OP_REPEAT:
+ scalar(cBINOPo->op_first);
+ /* convert what initially looked like a list repeat into a
+ * scalar repeat, e.g. $s = (1) x $n
+ */
+ if (o->op_private & OPpREPEAT_DOLIST) {
+ kid = cLISTOPx(cUNOPo->op_first)->op_first;
+ assert(kid->op_type == OP_PUSHMARK);
+ if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
+ op_null(cLISTOPx(cUNOPo->op_first)->op_first);
+ o->op_private &=~ OPpREPEAT_DOLIST;
+ }
+ }
+ break;
+
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ /* impose scalar context on everything except the condition */
+ next_kid = OpSIBLING(cUNOPo->op_first);
+ break;
- if (!ckWARN(WARN_SYNTAX)) break;
+ default:
+ if (o->op_flags & OPf_KIDS)
+ next_kid = cUNOPo->op_first; /* do all kids */
+ break;
- kid = cLISTOPo->op_first;
- kid = OpSIBLING(kid); /* get past pushmark */
- assert(OpSIBLING(kid));
- name = S_op_varname(aTHX_ OpSIBLING(kid));
- if (!name) /* XS module fiddling with the op tree */
- break;
- S_op_pretty(aTHX_ kid, &keysv, &key);
- assert(SvPOK(name));
- sv_chop(name,SvPVX(name)+1);
- if (key)
- /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%%%" SVf "%c%s%c in scalar context better written "
- "as $%" SVf "%c%s%c",
- SVfARG(name), lbrack, key, rbrack, SVfARG(name),
- lbrack, key, rbrack);
- else
- /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%%%" SVf "%c%" SVf "%c in scalar context better "
- "written as $%" SVf "%c%" SVf "%c",
- SVfARG(name), lbrack, SVfARG(keysv), rbrack,
- SVfARG(name), lbrack, SVfARG(keysv), rbrack);
- }
- }
- return o;
+ /* the children of these ops are usually a list of statements,
+ * except the leaves, whose first child is a corresponding enter
+ */
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ kid = cLISTOPo->op_first;
+ goto do_kids;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ kid = cLISTOPo->op_first;
+ scalar(kid);
+ kid = OpSIBLING(kid);
+ do_kids:
+ while (kid) {
+ OP *sib = OpSIBLING(kid);
+ /* Apply void context to all kids except the last, which
+ * is scalar (ignoring a trailing ex-nextstate in determining
+ * if it's the last kid). E.g.
+ * $scalar = do { void; void; scalar }
+ * Except that 'when's are always scalar, e.g.
+ * $scalar = do { given(..) {
+ * when (..) { scalar }
+ * when (..) { scalar }
+ * ...
+ * }}
+ */
+ if (!sib
+ || ( !OpHAS_SIBLING(sib)
+ && sib->op_type == OP_NULL
+ && ( sib->op_targ == OP_NEXTSTATE
+ || sib->op_targ == OP_DBSTATE )
+ )
+ )
+ {
+ /* tail call optimise calling scalar() on the last kid */
+ next_kid = kid;
+ goto do_next;
+ }
+ else if (kid->op_type == OP_LEAVEWHEN)
+ scalar(kid);
+ else
+ scalarvoid(kid);
+ kid = sib;
+ }
+ NOT_REACHED; /* NOTREACHED */
+ break;
+
+ case OP_SORT:
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in
scalar context");
+ break;
+
+ case OP_KVHSLICE:
+ case OP_KVASLICE:
+ {
+ /* Warn about scalar context */
+ const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
+ const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
+ SV *name;
+ SV *keysv;
+ const char *key = NULL;
+
+ /* This warning can be nonsensical when there is a syntax error. */
+ if (PL_parser && PL_parser->error_count)
+ break;
+
+ if (!ckWARN(WARN_SYNTAX)) break;
+
+ kid = cLISTOPo->op_first;
+ kid = OpSIBLING(kid); /* get past pushmark */
+ assert(OpSIBLING(kid));
+ name = S_op_varname(aTHX_ OpSIBLING(kid));
+ if (!name) /* XS module fiddling with the op tree */
+ break;
+ S_op_pretty(aTHX_ kid, &keysv, &key);
+ assert(SvPOK(name));
+ sv_chop(name,SvPVX(name)+1);
+ if (key)
+ /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%%%" SVf "%c%s%c in scalar context better written "
+ "as $%" SVf "%c%s%c",
+ SVfARG(name), lbrack, key, rbrack, SVfARG(name),
+ lbrack, key, rbrack);
+ else
+ /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%%%" SVf "%c%" SVf "%c in scalar context better "
+ "written as $%" SVf "%c%" SVf "%c",
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack,
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack);
+ }
+ } /* switch */
+
+ /* If next_kid is set, someone in the code above wanted us to process
+ * that kid and all its remaining siblings. Otherwise, work our way
+ * back up the tree */
+ do_next:
+ while (!next_kid) {
+ if (o == top_op)
+ return top_op; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else {
+ o = o->op_sibparent; /*try parent's next sibling */
+ switch (o->op_type) {
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ /* should really restore PL_curcop to its old value, but
+ * setting it to PL_compiling is better than do nothing */
+ PL_curcop = &PL_compiling;
+ }
+ }
+ }
+ o = next_kid;
+ } /* while */
}
+
+/* apply void context to the optree arg */
+
OP *
Perl_scalarvoid(pTHX_ OP *arg)
{
@@ -1938,14 +2004,14 @@ Perl_scalarvoid(pTHX_ OP *arg)
OP *kid;
SV* sv;
OP *o = arg;
- dDEFER_OP;
PERL_ARGS_ASSERT_SCALARVOID;
- do {
+ while (1) {
U8 want;
SV *useless_sv = NULL;
const char* useless = NULL;
+ OP * next_kid = NULL;
if (o->op_type == OP_NEXTSTATE
|| o->op_type == OP_DBSTATE
@@ -1959,7 +2025,7 @@ Perl_scalarvoid(pTHX_ OP *arg)
|| (PL_parser && PL_parser->error_count)
|| o->op_type == OP_RETURN || o->op_type == OP_REQUIRE ||
o->op_type == OP_LEAVEWHEN)
{
- continue;
+ goto get_next_op;
}
if ((o->op_private & OPpTARGET_MY)
@@ -1967,7 +2033,7 @@ Perl_scalarvoid(pTHX_ OP *arg)
{
/* newASSIGNOP has already applied scalar context, which we
leave, as if this op is inside SASSIGN. */
- continue;
+ goto get_next_op;
}
o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
@@ -2226,11 +2292,7 @@ Perl_scalarvoid(pTHX_ OP *arg)
case OP_COND_EXPR:
case OP_ENTERGIVEN:
case OP_ENTERWHEN:
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
- if (!(kid->op_flags & OPf_KIDS))
- scalarvoid(kid);
- else
- DEFER_OP(kid);
+ next_kid = OpSIBLING(cUNOPo->op_first);
break;
case OP_NULL:
@@ -2252,11 +2314,7 @@ Perl_scalarvoid(pTHX_ OP *arg)
case OP_LEAVEGIVEN:
case OP_LEAVEWHEN:
kids:
- for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
- if (!(kid->op_flags & OPf_KIDS))
- scalarvoid(kid);
- else
- DEFER_OP(kid);
+ next_kid = cLISTOPo->op_first;
break;
case OP_LIST:
/* If the first kid after pushmark is something that the padrange
@@ -2297,13 +2355,27 @@ Perl_scalarvoid(pTHX_ OP *arg)
"Useless use of %s in void context",
useless);
}
- } while ( (o = POP_DEFERRED_OP()) );
- DEFER_OP_CLEANUP;
+ get_next_op:
+ /* if a kid hasn't been nominated to process, continue with the
+ * next sibling, or if no siblings left, go back to the parent's
+ * siblings and so on
+ */
+ while (!next_kid) {
+ if (o == arg)
+ return arg; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else
+ o = o->op_sibparent; /*try parent's next sibling */
+ }
+ o = next_kid;
+ }
return arg;
}
+
static OP *
S_listkids(pTHX_ OP *o)
{
@@ -2315,97 +2387,153 @@ S_listkids(pTHX_ OP *o)
return o;
}
+
+/* apply list context to the o subtree */
+
OP *
Perl_list(pTHX_ OP *o)
{
- OP *kid;
+ OP * top_op = o;
- /* assumes no premature commitment */
- if (!o || (o->op_flags & OPf_WANT)
- || (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN)
- {
- return o;
- }
+ while (1) {
+ OP *next_kid = NULL; /* what op (if any) to process next */
- if ((o->op_private & OPpTARGET_MY)
- && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
- {
- return o; /* As if inside SASSIGN */
- }
+ OP *kid;
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
+ /* assumes no premature commitment */
+ if (!o || (o->op_flags & OPf_WANT)
+ || (PL_parser && PL_parser->error_count)
+ || o->op_type == OP_RETURN)
+ {
+ goto do_next;
+ }
- switch (o->op_type) {
- case OP_FLOP:
- list(cBINOPo->op_first);
- break;
- case OP_REPEAT:
- if (o->op_private & OPpREPEAT_DOLIST
- && !(o->op_flags & OPf_STACKED))
- {
- list(cBINOPo->op_first);
- kid = cBINOPo->op_last;
- if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
- && SvIVX(kSVOP_sv) == 1)
- {
- op_null(o); /* repeat */
- op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
- /* const (rhs): */
- op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
- }
- }
- break;
- case OP_OR:
- case OP_AND:
- case OP_COND_EXPR:
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
- list(kid);
- break;
- default:
- case OP_MATCH:
- case OP_QR:
- case OP_SUBST:
- case OP_NULL:
- if (!(o->op_flags & OPf_KIDS))
- break;
- if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
- list(cBINOPo->op_first);
- return gen_constant_list(o);
- }
- listkids(o);
- break;
- case OP_LIST:
- listkids(o);
- if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
- op_null(cUNOPo->op_first); /* NULL the pushmark */
- op_null(o); /* NULL the list */
- }
- break;
- case OP_LEAVE:
- case OP_LEAVETRY:
- kid = cLISTOPo->op_first;
- list(kid);
- kid = OpSIBLING(kid);
- do_kids:
- while (kid) {
- OP *sib = OpSIBLING(kid);
- if (sib && kid->op_type != OP_LEAVEWHEN)
- scalarvoid(kid);
- else
- list(kid);
- kid = sib;
- }
- PL_curcop = &PL_compiling;
- break;
- case OP_SCOPE:
- case OP_LINESEQ:
- kid = cLISTOPo->op_first;
- goto do_kids;
- }
- return o;
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
+ {
+ goto do_next; /* As if inside SASSIGN
*/
+ }
+
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
+
+ switch (o->op_type) {
+ case OP_REPEAT:
+ if (o->op_private & OPpREPEAT_DOLIST
+ && !(o->op_flags & OPf_STACKED))
+ {
+ list(cBINOPo->op_first);
+ kid = cBINOPo->op_last;
+ /* optimise away (.....) x 1 */
+ if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
+ && SvIVX(kSVOP_sv) == 1)
+ {
+ op_null(o); /* repeat */
+ op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
+ /* const (rhs): */
+ op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
+ }
+ }
+ break;
+
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ /* impose list context on everything except the condition */
+ next_kid = OpSIBLING(cUNOPo->op_first);
+ break;
+
+ default:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ /* possibly flatten 1..10 into a constant array */
+ if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
+ list(cBINOPo->op_first);
+ gen_constant_list(o);
+ goto do_next;
+ }
+ next_kid = cUNOPo->op_first; /* do all kids */
+ break;
+
+ case OP_LIST:
+ if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+ }
+ if (o->op_flags & OPf_KIDS)
+ next_kid = cUNOPo->op_first; /* do all kids */
+ break;
+
+ /* the children of these ops are usually a list of statements,
+ * except the leaves, whose first child is a corresponding enter
+ */
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ kid = cLISTOPo->op_first;
+ goto do_kids;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ kid = cLISTOPo->op_first;
+ list(kid);
+ kid = OpSIBLING(kid);
+ do_kids:
+ while (kid) {
+ OP *sib = OpSIBLING(kid);
+ /* Apply void context to all kids except the last, which
+ * is list. E.g.
+ * @a = do { void; void; list }
+ * Except that 'when's are always list context, e.g.
+ * @a = do { given(..) {
+ * when (..) { list }
+ * when (..) { list }
+ * ...
+ * }}
+ */
+ if (!sib) {
+ /* tail call optimise calling list() on the last kid */
+ next_kid = kid;
+ goto do_next;
+ }
+ else if (kid->op_type == OP_LEAVEWHEN)
+ list(kid);
+ else
+ scalarvoid(kid);
+ kid = sib;
+ }
+ NOT_REACHED; /* NOTREACHED */
+ break;
+
+ }
+
+ /* If next_kid is set, someone in the code above wanted us to process
+ * that kid and all its remaining siblings. Otherwise, work our way
+ * back up the tree */
+ do_next:
+ while (!next_kid) {
+ if (o == top_op)
+ return top_op; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else {
+ o = o->op_sibparent; /*try parent's next sibling */
+ switch (o->op_type) {
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ /* should really restore PL_curcop to its old value, but
+ * setting it to PL_compiling is better than do nothing */
+ PL_curcop = &PL_compiling;
+ }
+ }
+
+
+ }
+ o = next_kid;
+ } /* while */
}
+
static OP *
S_scalarseq(pTHX_ OP *o)
{
@@ -3492,17 +3620,20 @@ Perl_optimize_optree(pTHX_ OP* o)
}
-/* helper for optimize_optree() which optimises on op then recurses
+/* helper for optimize_optree() which optimises one op then recurses
* to optimise any children.
*/
STATIC void
S_optimize_op(pTHX_ OP* o)
{
- dDEFER_OP;
+ OP *top_op = o;
PERL_ARGS_ASSERT_OPTIMIZE_OP;
- do {
+
+ while (1) {
+ OP * next_kid = NULL;
+
assert(o->op_type != OP_FREED);
switch (o->op_type) {
@@ -3520,26 +3651,44 @@ S_optimize_op(pTHX_ OP* o)
break;
case OP_SUBST:
- if (cPMOPo->op_pmreplrootu.op_pmreplroot)
- DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
+ /* we can't assume that op_pmreplroot->op_sibparent == o
+ * and that it is thus possible to walk back up the tree
+ * past op_pmreplroot. So, although we try to avoid
+ * recursing through op trees, do it here. After all,
+ * there are unlikely to be many nested s///e's within
+ * the replacement part of a s///e.
+ */
+ optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ }
break;
default:
break;
}
- if (o->op_flags & OPf_KIDS) {
- OP *kid;
- IV child_count = 0;
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
- DEFER_OP(kid);
- ++child_count;
- }
- DEFER_REVERSE(child_count);
+ if (o->op_flags & OPf_KIDS)
+ next_kid = cUNOPo->op_first;
+
+ /* if a kid hasn't been nominated to process, continue with the
+ * next sibling, or if no siblings left, go back to the parent's
+ * siblings and so on
+ */
+ while (!next_kid) {
+ if (o == top_op)
+ return; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else
+ o = o->op_sibparent; /*try parent's next sibling */
}
- } while ( ( o = POP_DEFERRED_OP() ) );
- DEFER_OP_CLEANUP;
+ /* this label not yet used. Goto here if any code above sets
+ * next-kid
+ get_next_op:
+ */
+ o = next_kid;
+ }
}
@@ -3799,25 +3948,6 @@ S_finalize_op(pTHX_ OP* o)
} while (( o = traverse_op_tree(top, o)) != NULL);
}
-/*
-=for apidoc op_lvalue
-
-Propagate lvalue ("modifiable") context to an op and its children.
-C<type> represents the context type, roughly based on the type of op that
-would do the modifying, although C<local()> is represented by C<OP_NULL>,
-because it has no op type of its own (it is signalled by a flag on
-the lvalue op).
-
-This function detects things that can't be modified, such as C<$x+1>, and
-generates errors for them. For example, C<$x+1 = 2> would cause it to be
-called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
-
-It also flags things that need to behave specially in an lvalue context,
-such as C<$$x = 5> which might have to vivify a reference in C<$x>.
-
-=cut
-*/
-
static void
S_mark_padname_lvalue(pTHX_ PADNAME *pn)
{
@@ -3855,126 +3985,160 @@ S_vivifies(const OPCODE type)
return 0;
}
+
+/* apply lvalue reference (aliasing) context to the optree o.
+ * E.g. in
+ * \($x,$y) = (...)
+ * o would be the list ($x,$y) and type would be OP_AASSIGN.
+ * It may descend and apply this to children too, for example in
+ * \( $cond ? $x, $y) = (...)
+ */
+
static void
S_lvref(pTHX_ OP *o, I32 type)
-{
- dVAR;
- OP *kid;
- switch (o->op_type) {
- case OP_COND_EXPR:
- for (kid = OpSIBLING(cUNOPo->op_first); kid;
- kid = OpSIBLING(kid))
- S_lvref(aTHX_ kid, type);
- /* FALLTHROUGH */
- case OP_PUSHMARK:
- return;
- case OP_RV2AV:
- if (cUNOPo->op_first->op_type != OP_GV) goto badref;
- o->op_flags |= OPf_STACKED;
- if (o->op_flags & OPf_PARENS) {
- if (o->op_private & OPpLVAL_INTRO) {
- yyerror(Perl_form(aTHX_ "Can't modify reference to "
- "localized parenthesized array in list assignment"));
- return;
- }
- slurpy:
- OpTYPE_set(o, OP_LVAVREF);
- o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
- o->op_flags |= OPf_MOD|OPf_REF;
- return;
- }
- o->op_private |= OPpLVREF_AV;
- goto checkgv;
- case OP_RV2CV:
- kid = cUNOPo->op_first;
- if (kid->op_type == OP_NULL)
- kid = cUNOPx(OpSIBLING(kUNOP->op_first))
- ->op_first;
- o->op_private = OPpLVREF_CV;
- if (kid->op_type == OP_GV)
- o->op_flags |= OPf_STACKED;
- else if (kid->op_type == OP_PADCV) {
- o->op_targ = kid->op_targ;
- kid->op_targ = 0;
- op_free(cUNOPo->op_first);
- cUNOPo->op_first = NULL;
- o->op_flags &=~ OPf_KIDS;
- }
- else goto badref;
- break;
- case OP_RV2HV:
- if (o->op_flags & OPf_PARENS) {
- parenhash:
- yyerror(Perl_form(aTHX_ "Can't modify reference to "
- "parenthesized hash in list assignment"));
- return;
- }
- o->op_private |= OPpLVREF_HV;
- /* FALLTHROUGH */
- case OP_RV2SV:
- checkgv:
- if (cUNOPo->op_first->op_type != OP_GV) goto badref;
- o->op_flags |= OPf_STACKED;
- break;
- case OP_PADHV:
- if (o->op_flags & OPf_PARENS) goto parenhash;
- o->op_private |= OPpLVREF_HV;
- /* FALLTHROUGH */
- case OP_PADSV:
- PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
- break;
- case OP_PADAV:
- PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
- if (o->op_flags & OPf_PARENS) goto slurpy;
- o->op_private |= OPpLVREF_AV;
- break;
- case OP_AELEM:
- case OP_HELEM:
- o->op_private |= OPpLVREF_ELEM;
- o->op_flags |= OPf_STACKED;
- break;
- case OP_ASLICE:
- case OP_HSLICE:
- OpTYPE_set(o, OP_LVREFSLICE);
- o->op_private &= OPpLVAL_INTRO;
- return;
- case OP_NULL:
- if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
- goto badref;
- else if (!(o->op_flags & OPf_KIDS))
- return;
- if (o->op_targ != OP_LIST) {
- S_lvref(aTHX_ cBINOPo->op_first, type);
- return;
- }
- /* FALLTHROUGH */
- case OP_LIST:
- for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
- assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
- S_lvref(aTHX_ kid, type);
- }
- return;
- case OP_STUB:
- if (o->op_flags & OPf_PARENS)
- return;
- /* FALLTHROUGH */
- default:
- badref:
- /* diag_listed_as: Can't modify reference to %s in %s assignment */
- yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
- o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
- ? "do block"
- : OP_DESC(o),
- PL_op_desc[type]));
- return;
- }
- OpTYPE_set(o, OP_LVREF);
- o->op_private &=
- OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
- if (type == OP_ENTERLOOP)
- o->op_private |= OPpLVREF_ITER;
+{
+ dVAR;
+ OP *kid;
+ OP * top_op = o;
+
+ while (1) {
+ switch (o->op_type) {
+ case OP_COND_EXPR:
+ o = OpSIBLING(cUNOPo->op_first);
+ continue;
+
+ case OP_PUSHMARK:
+ goto do_next;
+
+ case OP_RV2AV:
+ if (cUNOPo->op_first->op_type != OP_GV) goto badref;
+ o->op_flags |= OPf_STACKED;
+ if (o->op_flags & OPf_PARENS) {
+ if (o->op_private & OPpLVAL_INTRO) {
+ yyerror(Perl_form(aTHX_ "Can't modify reference to "
+ "localized parenthesized array in list assignment"));
+ goto do_next;
+ }
+ slurpy:
+ OpTYPE_set(o, OP_LVAVREF);
+ o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
+ o->op_flags |= OPf_MOD|OPf_REF;
+ goto do_next;
+ }
+ o->op_private |= OPpLVREF_AV;
+ goto checkgv;
+
+ case OP_RV2CV:
+ kid = cUNOPo->op_first;
+ if (kid->op_type == OP_NULL)
+ kid = cUNOPx(OpSIBLING(kUNOP->op_first))
+ ->op_first;
+ o->op_private = OPpLVREF_CV;
+ if (kid->op_type == OP_GV)
+ o->op_flags |= OPf_STACKED;
+ else if (kid->op_type == OP_PADCV) {
+ o->op_targ = kid->op_targ;
+ kid->op_targ = 0;
+ op_free(cUNOPo->op_first);
+ cUNOPo->op_first = NULL;
+ o->op_flags &=~ OPf_KIDS;
+ }
+ else goto badref;
+ break;
+
+ case OP_RV2HV:
+ if (o->op_flags & OPf_PARENS) {
+ parenhash:
+ yyerror(Perl_form(aTHX_ "Can't modify reference to "
+ "parenthesized hash in list assignment"));
+ goto do_next;
+ }
+ o->op_private |= OPpLVREF_HV;
+ /* FALLTHROUGH */
+ case OP_RV2SV:
+ checkgv:
+ if (cUNOPo->op_first->op_type != OP_GV) goto badref;
+ o->op_flags |= OPf_STACKED;
+ break;
+
+ case OP_PADHV:
+ if (o->op_flags & OPf_PARENS) goto parenhash;
+ o->op_private |= OPpLVREF_HV;
+ /* FALLTHROUGH */
+ case OP_PADSV:
+ PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
+ break;
+
+ case OP_PADAV:
+ PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
+ if (o->op_flags & OPf_PARENS) goto slurpy;
+ o->op_private |= OPpLVREF_AV;
+ break;
+
+ case OP_AELEM:
+ case OP_HELEM:
+ o->op_private |= OPpLVREF_ELEM;
+ o->op_flags |= OPf_STACKED;
+ break;
+
+ case OP_ASLICE:
+ case OP_HSLICE:
+ OpTYPE_set(o, OP_LVREFSLICE);
+ o->op_private &= OPpLVAL_INTRO;
+ goto do_next;
+
+ case OP_NULL:
+ if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
+ goto badref;
+ else if (!(o->op_flags & OPf_KIDS))
+ goto do_next;
+
+ /* the code formerly only recursed into the first child of
+ * a non ex-list OP_NULL. if we ever encounter such a null op with
+ * more than one child, need to decide whether its ok to process
+ * *all* its kids or not */
+ assert(o->op_targ == OP_LIST
+ || !(OpHAS_SIBLING(cBINOPo->op_first)));
+ /* FALLTHROUGH */
+ case OP_LIST:
+ o = cLISTOPo->op_first;
+ continue;
+
+ case OP_STUB:
+ if (o->op_flags & OPf_PARENS)
+ goto do_next;
+ /* FALLTHROUGH */
+ default:
+ badref:
+ /* diag_listed_as: Can't modify reference to %s in %s assignment */
+ yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
+ o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
+ ? "do block"
+ : OP_DESC(o),
+ PL_op_desc[type]));
+ goto do_next;
+ }
+
+ OpTYPE_set(o, OP_LVREF);
+ o->op_private &=
+ OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
+ if (type == OP_ENTERLOOP)
+ o->op_private |= OPpLVREF_ITER;
+
+ do_next:
+ while (1) {
+ if (o == top_op)
+ return; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o)) {
+ o = o->op_sibparent;
+ break;
+ }
+ o = o->op_sibparent; /*try parent's next sibling */
+ }
+ } /* while */
}
+
PERL_STATIC_INLINE bool
S_potential_mod_type(I32 type)
{
@@ -3983,35 +4147,69 @@ S_potential_mod_type(I32 type)
|| type == OP_REFGEN || type == OP_LEAVESUBLV;
}
+
+/*
+=for apidoc op_lvalue
+
+Propagate lvalue ("modifiable") context to an op and its children.
+C<type> represents the context type, roughly based on the type of op that
+would do the modifying, although C<local()> is represented by C<OP_NULL>,
+because it has no op type of its own (it is signalled by a flag on
+the lvalue op).
+
+This function detects things that can't be modified, such as C<$x+1>, and
+generates errors for them. For example, C<$x+1 = 2> would cause it to be
+called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
+
+It also flags things that need to behave specially in an lvalue context,
+such as C<$$x = 5> which might have to vivify a reference in C<$x>.
+
+=cut
+
+Perl_op_lvalue_flags() is a non-API lower-level interface to
+op_lvalue(). The flags param has these bits:
+ OP_LVALUE_NO_CROAK: return rather than croaking on error
+
+*/
+
OP *
Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
dVAR;
- OP *kid;
- /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
- int localize = -1;
+ OP *top_op = o;
if (!o || (PL_parser && PL_parser->error_count))
return o;
+ while (1) {
+ OP *kid;
+ /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
+ int localize = -1;
+ OP *next_kid = NULL;
+
if ((o->op_private & OPpTARGET_MY)
&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
{
- return o;
+ goto do_next;
}
- assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
+ /* elements of a list might be in void context because the list is
+ in scalar context or because they are attribute sub calls */
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
+ goto do_next;
if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
switch (o->op_type) {
case OP_UNDEF:
PL_modcount++;
- return o;
+ goto do_next;
+
case OP_STUB:
if ((o->op_flags & OPf_PARENS))
break;
goto nomod;
+
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
@@ -4077,7 +4275,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
"subroutine call of &%" SVf " in %s",
SVfARG(namesv), PL_op_desc[type]),
SvUTF8(namesv));
- return o;
+ goto do_next;
}
}
/* FALLTHROUGH */
@@ -4092,7 +4290,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
? "do block"
: OP_DESC(o)),
type ? PL_op_desc[type] : "local"));
- return o;
+ goto do_next;
case OP_PREINC:
case OP_PREDEC:
@@ -4127,6 +4325,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
goto nomod;
else {
const I32 mods = PL_modcount;
+ /* we recurse rather than iterate here because we need to
+ * calculate and use the delta applied to PL_modcount by the
+ * first child. So in something like
+ * ($x, ($y) x 3) = split;
+ * split knows that 4 elements are wanted
+ */
modkids(cBINOPo->op_first, type);
if (type != OP_AASSIGN)
goto nomod;
@@ -4144,8 +4348,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
case OP_COND_EXPR:
localize = 1;
- for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
- op_lvalue(kid, type);
+ next_kid = OpSIBLING(cUNOPo->op_first);
... 921 lines suppressed ...
--
Perl5 Master Repository
