This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove use of dVAR in core
[perl5.git] / op.c
1 #line 2 "op.c"
2 /*    op.c
3  *
4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11
12 /*
13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
17  *  either way, as the saying is, if you follow me.'       --the Gaffer
18  *
19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains the functions that create, manipulate and optimize
23  * the OP structures that hold a compiled perl program.
24  *
25  * Note that during the build of miniperl, a temporary copy of this file
26  * is made, called opmini.c.
27  *
28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
29  *  * structural OP pointers to its children and siblings (op_sibling,
30  *    op_first etc) that define the tree structure;
31  *  * execution order OP pointers (op_next, plus sometimes op_other,
32  *    op_lastop  etc) that define the execution sequence plus variants;
33  *  * a pointer to the C "pp" function that would execute the op;
34  *  * any data specific to that op.
35  * For example, an OP_CONST op points to the pp_const() function and to an
36  * SV containing the constant value. When pp_const() is executed, its job
37  * is to push that SV onto the stack.
38  *
39  * OPs are mainly created by the newFOO() functions, which are mainly
40  * called from the parser (in perly.y) as the code is parsed. For example
41  * the Perl code $a + $b * $c would cause the equivalent of the following
42  * to be called (oversimplifying a bit):
43  *
44  *  newBINOP(OP_ADD, flags,
45  *      newSVREF($a),
46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
47  *  )
48  *
49  * As the parser reduces low-level rules, it creates little op subtrees;
50  * as higher-level rules are resolved, these subtrees get joined together
51  * as branches on a bigger subtree, until eventually a top-level rule like
52  * a subroutine definition is reduced, at which point there is one large
53  * parse tree left.
54  *
55  * The execution order pointers (op_next) are generated as the subtrees
56  * are joined together. Consider this sub-expression: A*B + C/D: at the
57  * point when it's just been parsed, the op tree looks like:
58  *
59  *   [+]
60  *    |
61  *   [*]------[/]
62  *    |        |
63  *    A---B    C---D
64  *
65  * with the intended execution order being:
66  *
67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
68  *
69  * At this point all the nodes' op_next pointers will have been set,
70  * except that:
71  *    * we don't know what the [NEXT] node will be yet;
72  *    * we don't know what the [PREV] node will be yet, but when it gets
73  *      created and needs its op_next set, it needs to be set to point to
74  *      A, which is non-obvious.
75  * To handle both those cases, we temporarily set the top node's
76  * op_next to point to the first node to be executed in this subtree (A in
77  * this case). This means that initially a subtree's op_next chain,
78  * starting from the top node, will visit each node in execution sequence
79  * then point back at the top node.
80  * When we embed this subtree in a larger tree, its top op_next is used
81  * to get the start node, then is set to point to its new neighbour.
82  * For example the two separate [*],A,B and [/],C,D subtrees would
83  * initially have had:
84  *   [*] => A;  A => B;  B => [*]
85  * and
86  *   [/] => C;  C => D;  D => [/]
87  * When these two subtrees were joined together to make the [+] subtree,
88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89  * set to point to [/]'s op_next, i.e. C.
90  *
91  * This op_next linking is done by the LINKLIST() macro and its underlying
92  * op_linklist() function. Given a top-level op, if its op_next is
93  * non-null, it's already been linked, so leave it. Otherwise link it with
94  * its children as described above, possibly recursively if any of the
95  * children have a null op_next.
96  *
97  * In summary: given a subtree, its top-level node's op_next will either
98  * be:
99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
100  *   fake: points to the start op for this subtree;
101  *   real: once the subtree has been embedded into a larger tree
102  */
103
104 /*
105
106 Here's an older description from Larry.
107
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
109
110     A bottom-up pass
111     A top-down pass
112     An execution-order pass
113
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines.  The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order.  (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
121 top level node.)
122
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again).  As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node.  But
130 it's still not the real execution order.
131
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer.  At that point, we can call
135 into peep() to do that code's portion of the 3rd pass.  It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
137 */
138
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140    get the compile time state of %^H for that block.  Storing %^H in every
141    block (or even COP) would be very expensive, so a different approach is
142    taken.  The (running) state of %^H is serialised into a tree of HE-like
143    structs.  Stores into %^H are chained onto the current leaf as a struct
144    refcounted_he * with the key and the value.  Deletes from %^H are saved
145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
146    turned back into a regular HV by walking back up the tree from that point's
147    leaf, ignoring any key you've already seen (placeholder or not), storing
148    the rest into the HV structure, then removing the placeholders. Hence
149    memory is only used to store the %^H deltas from the enclosing COP, rather
150    than the entire %^H on each COP.
151
152    To cause actions on %^H to write out the serialisation records, it has
153    magic type 'H'. This magic (itself) does nothing, but its presence causes
154    the values to gain magic type 'h', which has entries for set and clear.
155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158    it will be correctly restored when any inner compiling scope is exited.
159 */
160
161 #include "EXTERN.h"
162 #define PERL_IN_OP_C
163 #include "perl.h"
164 #include "keywords.h"
165 #include "feature.h"
166 #include "regcomp.h"
167 #include "invlist_inline.h"
168
169 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
170 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
171 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
172
173 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
174
175 /* remove any leading "empty" ops from the op_next chain whose first
176  * node's address is stored in op_p. Store the updated address of the
177  * first node in op_p.
178  */
179
180 STATIC void
181 S_prune_chain_head(OP** op_p)
182 {
183     while (*op_p
184         && (   (*op_p)->op_type == OP_NULL
185             || (*op_p)->op_type == OP_SCOPE
186             || (*op_p)->op_type == OP_SCALAR
187             || (*op_p)->op_type == OP_LINESEQ)
188     )
189         *op_p = (*op_p)->op_next;
190 }
191
192
193 /* See the explanatory comments above struct opslab in op.h. */
194
195 #ifdef PERL_DEBUG_READONLY_OPS
196 #  define PERL_SLAB_SIZE 128
197 #  define PERL_MAX_SLAB_SIZE 4096
198 #  include <sys/mman.h>
199 #endif
200
201 #ifndef PERL_SLAB_SIZE
202 #  define PERL_SLAB_SIZE 64
203 #endif
204 #ifndef PERL_MAX_SLAB_SIZE
205 #  define PERL_MAX_SLAB_SIZE 2048
206 #endif
207
208 /* rounds up to nearest pointer */
209 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
210 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
211
212 /* requires double parens and aTHX_ */
213 #define DEBUG_S_warn(args)                                             \
214     DEBUG_S(                                                            \
215         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
216     )
217
218
219 /* malloc a new op slab (suitable for attaching to PL_compcv).
220  * sz is in units of pointers */
221
222 static OPSLAB *
223 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
224 {
225     OPSLAB *slab;
226
227     /* opslot_offset is only U16 */
228     assert(sz  < U16_MAX);
229
230 #ifdef PERL_DEBUG_READONLY_OPS
231     slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
232                                    PROT_READ|PROT_WRITE,
233                                    MAP_ANON|MAP_PRIVATE, -1, 0);
234     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
235                           (unsigned long) sz, slab));
236     if (slab == MAP_FAILED) {
237         perror("mmap failed");
238         abort();
239     }
240 #else
241     slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
242 #endif
243     slab->opslab_size = (U16)sz;
244
245 #ifndef WIN32
246     /* The context is unused in non-Windows */
247     PERL_UNUSED_CONTEXT;
248 #endif
249     slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
250     slab->opslab_head = head ? head : slab;
251     DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
252         (unsigned int)slab->opslab_size, (void*)slab,
253         (void*)(slab->opslab_head)));
254     return slab;
255 }
256
257 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
258 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
259 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
260
261 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
262 static void
263 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
264     U16 sz = OpSLOT(o)->opslot_size;
265     U16 index = OPSLOT_SIZE_TO_INDEX(sz);
266
267     assert(sz >= OPSLOT_SIZE_BASE);
268     /* make sure the array is large enough to include ops this large */
269     if (!slab->opslab_freed) {
270         /* we don't have a free list array yet, make a new one */
271         slab->opslab_freed_size = index+1;
272         slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
273
274         if (!slab->opslab_freed)
275             croak_no_mem();
276     }
277     else if (index >= slab->opslab_freed_size) {
278         /* It's probably not worth doing exponential expansion here, the number of op sizes
279            is small.
280         */
281         /* We already have a list that isn't large enough, expand it */
282         size_t newsize = index+1;
283         OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
284
285         if (!p)
286             croak_no_mem();
287
288         Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
289
290         slab->opslab_freed = p;
291         slab->opslab_freed_size = newsize;
292     }
293
294     o->op_next = slab->opslab_freed[index];
295     slab->opslab_freed[index] = o;
296 }
297
298 /* Returns a sz-sized block of memory (suitable for holding an op) from
299  * a free slot in the chain of op slabs attached to PL_compcv.
300  * Allocates a new slab if necessary.
301  * if PL_compcv isn't compiling, malloc() instead.
302  */
303
304 void *
305 Perl_Slab_Alloc(pTHX_ size_t sz)
306 {
307     OPSLAB *head_slab; /* first slab in the chain */
308     OPSLAB *slab2;
309     OPSLOT *slot;
310     OP *o;
311     size_t opsz;
312
313     /* We only allocate ops from the slab during subroutine compilation.
314        We find the slab via PL_compcv, hence that must be non-NULL. It could
315        also be pointing to a subroutine which is now fully set up (CvROOT()
316        pointing to the top of the optree for that sub), or a subroutine
317        which isn't using the slab allocator. If our sanity checks aren't met,
318        don't use a slab, but allocate the OP directly from the heap.  */
319     if (!PL_compcv || CvROOT(PL_compcv)
320      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
321     {
322         o = (OP*)PerlMemShared_calloc(1, sz);
323         goto gotit;
324     }
325
326     /* While the subroutine is under construction, the slabs are accessed via
327        CvSTART(), to avoid needing to expand PVCV by one pointer for something
328        unneeded at runtime. Once a subroutine is constructed, the slabs are
329        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
330        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
331        details.  */
332     if (!CvSTART(PL_compcv)) {
333         CvSTART(PL_compcv) =
334             (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
335         CvSLABBED_on(PL_compcv);
336         head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
337     }
338     else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
339
340     opsz = SIZE_TO_PSIZE(sz);
341     sz = opsz + OPSLOT_HEADER_P;
342
343     /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
344        will free up OPs, so it makes sense to re-use them where possible. A
345        freed up slot is used in preference to a new allocation.  */
346     if (head_slab->opslab_freed &&
347         OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) {
348         U16 base_index;
349
350         /* look for a large enough size with any freed ops */
351         for (base_index = OPSLOT_SIZE_TO_INDEX(sz);
352              base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
353              ++base_index) {
354         }
355
356         if (base_index < head_slab->opslab_freed_size) {
357             /* found a freed op */
358             o = head_slab->opslab_freed[base_index];
359
360             DEBUG_S_warn((aTHX_ "realloced  op at %p, slab %p, head slab %p",
361                 (void*)o,
362                 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
363                 (void*)head_slab));
364             head_slab->opslab_freed[base_index] = o->op_next;
365             Zero(o, opsz, I32 *);
366             o->op_slabbed = 1;
367             goto gotit;
368         }
369     }
370
371 #define INIT_OPSLOT(s) \
372             slot->opslot_offset = DIFF(slab2, slot) ;   \
373             slot->opslot_size = s;                      \
374             slab2->opslab_free_space -= s;              \
375             o = &slot->opslot_op;                       \
376             o->op_slabbed = 1
377
378     /* The partially-filled slab is next in the chain. */
379     slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
380     if (slab2->opslab_free_space  < sz) {
381         /* Remaining space is too small. */
382         /* If we can fit a BASEOP, add it to the free chain, so as not
383            to waste it. */
384         if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
385             slot = &slab2->opslab_slots;
386             INIT_OPSLOT(slab2->opslab_free_space);
387             o->op_type = OP_FREED;
388             link_freed_op(head_slab, o);
389         }
390
391         /* Create a new slab.  Make this one twice as big. */
392         slab2 = S_new_slab(aTHX_ head_slab,
393                             slab2->opslab_size  > PERL_MAX_SLAB_SIZE / 2
394                                 ? PERL_MAX_SLAB_SIZE
395                                 : slab2->opslab_size * 2);
396         slab2->opslab_next = head_slab->opslab_next;
397         head_slab->opslab_next = slab2;
398     }
399     assert(slab2->opslab_size >= sz);
400
401     /* Create a new op slot */
402     slot = (OPSLOT *)
403                 ((I32 **)&slab2->opslab_slots
404                                 + slab2->opslab_free_space - sz);
405     assert(slot >= &slab2->opslab_slots);
406     INIT_OPSLOT(sz);
407     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
408         (void*)o, (void*)slab2, (void*)head_slab));
409
410   gotit:
411     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
412     assert(!o->op_moresib);
413     assert(!o->op_sibparent);
414
415     return (void *)o;
416 }
417
418 #undef INIT_OPSLOT
419
420 #ifdef PERL_DEBUG_READONLY_OPS
421 void
422 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
423 {
424     PERL_ARGS_ASSERT_SLAB_TO_RO;
425
426     if (slab->opslab_readonly) return;
427     slab->opslab_readonly = 1;
428     for (; slab; slab = slab->opslab_next) {
429         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
430                               (unsigned long) slab->opslab_size, slab));*/
431         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
432             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
433                              (unsigned long)slab->opslab_size, errno);
434     }
435 }
436
437 void
438 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
439 {
440     OPSLAB *slab2;
441
442     PERL_ARGS_ASSERT_SLAB_TO_RW;
443
444     if (!slab->opslab_readonly) return;
445     slab2 = slab;
446     for (; slab2; slab2 = slab2->opslab_next) {
447         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
448                               (unsigned long) size, slab2));*/
449         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
450                      PROT_READ|PROT_WRITE)) {
451             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
452                              (unsigned long)slab2->opslab_size, errno);
453         }
454     }
455     slab->opslab_readonly = 0;
456 }
457
458 #else
459 #  define Slab_to_rw(op)    NOOP
460 #endif
461
462 /* This cannot possibly be right, but it was copied from the old slab
463    allocator, to which it was originally added, without explanation, in
464    commit 083fcd5. */
465 #ifdef NETWARE
466 #    define PerlMemShared PerlMem
467 #endif
468
469 /* make freed ops die if they're inadvertently executed */
470 #ifdef DEBUGGING
471 static OP *
472 S_pp_freed(pTHX)
473 {
474     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
475 }
476 #endif
477
478
479 /* Return the block of memory used by an op to the free list of
480  * the OP slab associated with that op.
481  */
482
483 void
484 Perl_Slab_Free(pTHX_ void *op)
485 {
486     OP * const o = (OP *)op;
487     OPSLAB *slab;
488
489     PERL_ARGS_ASSERT_SLAB_FREE;
490
491 #ifdef DEBUGGING
492     o->op_ppaddr = S_pp_freed;
493 #endif
494
495     if (!o->op_slabbed) {
496         if (!o->op_static)
497             PerlMemShared_free(op);
498         return;
499     }
500
501     slab = OpSLAB(o);
502     /* If this op is already freed, our refcount will get screwy. */
503     assert(o->op_type != OP_FREED);
504     o->op_type = OP_FREED;
505     link_freed_op(slab, o);
506     DEBUG_S_warn((aTHX_ "freeing    op at %p, slab %p, head slab %p",
507         (void*)o,
508         (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
509         (void*)slab));
510     OpslabREFCNT_dec_padok(slab);
511 }
512
513 void
514 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
515 {
516     const bool havepad = !!PL_comppad;
517     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
518     if (havepad) {
519         ENTER;
520         PAD_SAVE_SETNULLPAD();
521     }
522     opslab_free(slab);
523     if (havepad) LEAVE;
524 }
525
526 /* Free a chain of OP slabs. Should only be called after all ops contained
527  * in it have been freed. At this point, its reference count should be 1,
528  * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
529  * and just directly calls opslab_free().
530  * (Note that the reference count which PL_compcv held on the slab should
531  * have been removed once compilation of the sub was complete).
532  *
533  *
534  */
535
536 void
537 Perl_opslab_free(pTHX_ OPSLAB *slab)
538 {
539     OPSLAB *slab2;
540     PERL_ARGS_ASSERT_OPSLAB_FREE;
541     PERL_UNUSED_CONTEXT;
542     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
543     assert(slab->opslab_refcnt == 1);
544     PerlMemShared_free(slab->opslab_freed);
545     do {
546         slab2 = slab->opslab_next;
547 #ifdef DEBUGGING
548         slab->opslab_refcnt = ~(size_t)0;
549 #endif
550 #ifdef PERL_DEBUG_READONLY_OPS
551         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
552                                                (void*)slab));
553         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
554             perror("munmap failed");
555             abort();
556         }
557 #else
558         PerlMemShared_free(slab);
559 #endif
560         slab = slab2;
561     } while (slab);
562 }
563
564 /* like opslab_free(), but first calls op_free() on any ops in the slab
565  * not marked as OP_FREED
566  */
567
568 void
569 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
570 {
571     OPSLAB *slab2;
572 #ifdef DEBUGGING
573     size_t savestack_count = 0;
574 #endif
575     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
576     slab2 = slab;
577     do {
578         OPSLOT *slot = (OPSLOT*)
579                     ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
580         OPSLOT *end  = (OPSLOT*)
581                         ((I32**)slab2 + slab2->opslab_size);
582         for (; slot < end;
583                 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
584         {
585             if (slot->opslot_op.op_type != OP_FREED
586              && !(slot->opslot_op.op_savefree
587 #ifdef DEBUGGING
588                   && ++savestack_count
589 #endif
590                  )
591             ) {
592                 assert(slot->opslot_op.op_slabbed);
593                 op_free(&slot->opslot_op);
594                 if (slab->opslab_refcnt == 1) goto free;
595             }
596         }
597     } while ((slab2 = slab2->opslab_next));
598     /* > 1 because the CV still holds a reference count. */
599     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
600 #ifdef DEBUGGING
601         assert(savestack_count == slab->opslab_refcnt-1);
602 #endif
603         /* Remove the CV’s reference count. */
604         slab->opslab_refcnt--;
605         return;
606     }
607    free:
608     opslab_free(slab);
609 }
610
611 #ifdef PERL_DEBUG_READONLY_OPS
612 OP *
613 Perl_op_refcnt_inc(pTHX_ OP *o)
614 {
615     if(o) {
616         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
617         if (slab && slab->opslab_readonly) {
618             Slab_to_rw(slab);
619             ++o->op_targ;
620             Slab_to_ro(slab);
621         } else {
622             ++o->op_targ;
623         }
624     }
625     return o;
626
627 }
628
629 PADOFFSET
630 Perl_op_refcnt_dec(pTHX_ OP *o)
631 {
632     PADOFFSET result;
633     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
634
635     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
636
637     if (slab && slab->opslab_readonly) {
638         Slab_to_rw(slab);
639         result = --o->op_targ;
640         Slab_to_ro(slab);
641     } else {
642         result = --o->op_targ;
643     }
644     return result;
645 }
646 #endif
647 /*
648  * In the following definition, the ", (OP*)0" is just to make the compiler
649  * think the expression is of the right type: croak actually does a Siglongjmp.
650  */
651 #define CHECKOP(type,o) \
652     ((PL_op_mask && PL_op_mask[type])                           \
653      ? ( op_free((OP*)o),                                       \
654          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
655          (OP*)0 )                                               \
656      : PL_check[type](aTHX_ (OP*)o))
657
658 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
659
660 #define OpTYPE_set(o,type) \
661     STMT_START {                                \
662         o->op_type = (OPCODE)type;              \
663         o->op_ppaddr = PL_ppaddr[type];         \
664     } STMT_END
665
666 STATIC OP *
667 S_no_fh_allowed(pTHX_ OP *o)
668 {
669     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
670
671     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
672                  OP_DESC(o)));
673     return o;
674 }
675
676 STATIC OP *
677 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
678 {
679     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
680     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
681     return o;
682 }
683
684 STATIC OP *
685 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
686 {
687     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
688
689     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
690     return o;
691 }
692
693 STATIC void
694 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
695 {
696     PERL_ARGS_ASSERT_BAD_TYPE_PV;
697
698     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
699                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
700 }
701
702 STATIC void
703 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
704 {
705     SV * const namesv = cv_name((CV *)gv, NULL, 0);
706     PERL_ARGS_ASSERT_BAD_TYPE_GV;
707
708     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
709                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
710 }
711
712 STATIC void
713 S_no_bareword_allowed(pTHX_ OP *o)
714 {
715     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
716
717     qerror(Perl_mess(aTHX_
718                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
719                      SVfARG(cSVOPo_sv)));
720     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
721 }
722
723 /* "register" allocation */
724
725 PADOFFSET
726 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
727 {
728     PADOFFSET off;
729     const bool is_our = (PL_parser->in_my == KEY_our);
730
731     PERL_ARGS_ASSERT_ALLOCMY;
732
733     if (flags & ~SVf_UTF8)
734         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
735                    (UV)flags);
736
737     /* complain about "my $<special_var>" etc etc */
738     if (   len
739         && !(  is_our
740             || isALPHA(name[1])
741             || (   (flags & SVf_UTF8)
742                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
743             || (name[1] == '_' && len > 2)))
744     {
745         const char * const type =
746               PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
747               PL_parser->in_my == KEY_state  ? "\"state\""     : "\"my\"";
748
749         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
750          && isASCII(name[1])
751          && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
752             /* diag_listed_as: Can't use global %s in %s */
753             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
754                               name[0], toCTRL(name[1]),
755                               (int)(len - 2), name + 2,
756                               type));
757         } else {
758             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
759                               (int) len, name,
760                               type), flags & SVf_UTF8);
761         }
762     }
763
764     /* allocate a spare slot and store the name in that slot */
765
766     off = pad_add_name_pvn(name, len,
767                        (is_our ? padadd_OUR :
768                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
769                     PL_parser->in_my_stash,
770                     (is_our
771                         /* $_ is always in main::, even with our */
772                         ? (PL_curstash && !memEQs(name,len,"$_")
773                             ? PL_curstash
774                             : PL_defstash)
775                         : NULL
776                     )
777     );
778     /* anon sub prototypes contains state vars should always be cloned,
779      * otherwise the state var would be shared between anon subs */
780
781     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
782         CvCLONE_on(PL_compcv);
783
784     return off;
785 }
786
787 /*
788 =head1 Optree Manipulation Functions
789
790 =for apidoc alloccopstash
791
792 Available only under threaded builds, this function allocates an entry in
793 C<PL_stashpad> for the stash passed to it.
794
795 =cut
796 */
797
798 #ifdef USE_ITHREADS
799 PADOFFSET
800 Perl_alloccopstash(pTHX_ HV *hv)
801 {
802     PADOFFSET off = 0, o = 1;
803     bool found_slot = FALSE;
804
805     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
806
807     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
808
809     for (; o < PL_stashpadmax; ++o) {
810         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
811         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
812             found_slot = TRUE, off = o;
813     }
814     if (!found_slot) {
815         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
816         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
817         off = PL_stashpadmax;
818         PL_stashpadmax += 10;
819     }
820
821     PL_stashpad[PL_stashpadix = off] = hv;
822     return off;
823 }
824 #endif
825
826 /* free the body of an op without examining its contents.
827  * Always use this rather than FreeOp directly */
828
829 static void
830 S_op_destroy(pTHX_ OP *o)
831 {
832     FreeOp(o);
833 }
834
835 /* Destructor */
836
837 /*
838 =for apidoc op_free
839
840 Free an op and its children. Only use this when an op is no longer linked
841 to from any optree.
842
843 =cut
844 */
845
846 void
847 Perl_op_free(pTHX_ OP *o)
848 {
849     OPCODE type;
850     OP *top_op = o;
851     OP *next_op = o;
852     bool went_up = FALSE; /* whether we reached the current node by
853                             following the parent pointer from a child, and
854                             so have already seen this node */
855
856     if (!o || o->op_type == OP_FREED)
857         return;
858
859     if (o->op_private & OPpREFCOUNTED) {
860         /* if base of tree is refcounted, just decrement */
861         switch (o->op_type) {
862         case OP_LEAVESUB:
863         case OP_LEAVESUBLV:
864         case OP_LEAVEEVAL:
865         case OP_LEAVE:
866         case OP_SCOPE:
867         case OP_LEAVEWRITE:
868             {
869                 PADOFFSET refcnt;
870                 OP_REFCNT_LOCK;
871                 refcnt = OpREFCNT_dec(o);
872                 OP_REFCNT_UNLOCK;
873                 if (refcnt) {
874                     /* Need to find and remove any pattern match ops from
875                      * the list we maintain for reset().  */
876                     find_and_forget_pmops(o);
877                     return;
878                 }
879             }
880             break;
881         default:
882             break;
883         }
884     }
885
886     while (next_op) {
887         o = next_op;
888
889         /* free child ops before ourself, (then free ourself "on the
890          * way back up") */
891
892         if (!went_up && o->op_flags & OPf_KIDS) {
893             next_op = cUNOPo->op_first;
894             continue;
895         }
896
897         /* find the next node to visit, *then* free the current node
898          * (can't rely on o->op_* fields being valid after o has been
899          * freed) */
900
901         /* The next node to visit will be either the sibling, or the
902          * parent if no siblings left, or NULL if we've worked our way
903          * back up to the top node in the tree */
904         next_op = (o == top_op) ? NULL : o->op_sibparent;
905         went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
906
907         /* Now process the current node */
908
909         /* Though ops may be freed twice, freeing the op after its slab is a
910            big no-no. */
911         assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
912         /* During the forced freeing of ops after compilation failure, kidops
913            may be freed before their parents. */
914         if (!o || o->op_type == OP_FREED)
915             continue;
916
917         type = o->op_type;
918
919         /* an op should only ever acquire op_private flags that we know about.
920          * If this fails, you may need to fix something in regen/op_private.
921          * Don't bother testing if:
922          *   * the op_ppaddr doesn't match the op; someone may have
923          *     overridden the op and be doing strange things with it;
924          *   * we've errored, as op flags are often left in an
925          *     inconsistent state then. Note that an error when
926          *     compiling the main program leaves PL_parser NULL, so
927          *     we can't spot faults in the main code, only
928          *     evaled/required code */
929 #ifdef DEBUGGING
930         if (   o->op_ppaddr == PL_ppaddr[type]
931             && PL_parser
932             && !PL_parser->error_count)
933         {
934             assert(!(o->op_private & ~PL_op_private_valid[type]));
935         }
936 #endif
937
938
939         /* Call the op_free hook if it has been set. Do it now so that it's called
940          * at the right time for refcounted ops, but still before all of the kids
941          * are freed. */
942         CALL_OPFREEHOOK(o);
943
944         if (type == OP_NULL)
945             type = (OPCODE)o->op_targ;
946
947         if (o->op_slabbed)
948             Slab_to_rw(OpSLAB(o));
949
950         /* COP* is not cleared by op_clear() so that we may track line
951          * numbers etc even after null() */
952         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
953             cop_free((COP*)o);
954         }
955
956         op_clear(o);
957         FreeOp(o);
958         if (PL_op == o)
959             PL_op = NULL;
960     }
961 }
962
963
964 /* S_op_clear_gv(): free a GV attached to an OP */
965
966 STATIC
967 #ifdef USE_ITHREADS
968 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
969 #else
970 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
971 #endif
972 {
973
974     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
975             || o->op_type == OP_MULTIDEREF)
976 #ifdef USE_ITHREADS
977                 && PL_curpad
978                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
979 #else
980                 ? (GV*)(*svp) : NULL;
981 #endif
982     /* It's possible during global destruction that the GV is freed
983        before the optree. Whilst the SvREFCNT_inc is happy to bump from
984        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
985        will trigger an assertion failure, because the entry to sv_clear
986        checks that the scalar is not already freed.  A check of for
987        !SvIS_FREED(gv) turns out to be invalid, because during global
988        destruction the reference count can be forced down to zero
989        (with SVf_BREAK set).  In which case raising to 1 and then
990        dropping to 0 triggers cleanup before it should happen.  I
991        *think* that this might actually be a general, systematic,
992        weakness of the whole idea of SVf_BREAK, in that code *is*
993        allowed to raise and lower references during global destruction,
994        so any *valid* code that happens to do this during global
995        destruction might well trigger premature cleanup.  */
996     bool still_valid = gv && SvREFCNT(gv);
997
998     if (still_valid)
999         SvREFCNT_inc_simple_void(gv);
1000 #ifdef USE_ITHREADS
1001     if (*ixp > 0) {
1002         pad_swipe(*ixp, TRUE);
1003         *ixp = 0;
1004     }
1005 #else
1006     SvREFCNT_dec(*svp);
1007     *svp = NULL;
1008 #endif
1009     if (still_valid) {
1010         int try_downgrade = SvREFCNT(gv) == 2;
1011         SvREFCNT_dec_NN(gv);
1012         if (try_downgrade)
1013             gv_try_downgrade(gv);
1014     }
1015 }
1016
1017
1018 void
1019 Perl_op_clear(pTHX_ OP *o)
1020 {
1021
1022
1023     PERL_ARGS_ASSERT_OP_CLEAR;
1024
1025     switch (o->op_type) {
1026     case OP_NULL:       /* Was holding old type, if any. */
1027         /* FALLTHROUGH */
1028     case OP_ENTERTRY:
1029     case OP_ENTEREVAL:  /* Was holding hints. */
1030     case OP_ARGDEFELEM: /* Was holding signature index. */
1031         o->op_targ = 0;
1032         break;
1033     default:
1034         if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1035             break;
1036         /* FALLTHROUGH */
1037     case OP_GVSV:
1038     case OP_GV:
1039     case OP_AELEMFAST:
1040 #ifdef USE_ITHREADS
1041             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1042 #else
1043             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1044 #endif
1045         break;
1046     case OP_METHOD_REDIR:
1047     case OP_METHOD_REDIR_SUPER:
1048 #ifdef USE_ITHREADS
1049         if (cMETHOPx(o)->op_rclass_targ) {
1050             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1051             cMETHOPx(o)->op_rclass_targ = 0;
1052         }
1053 #else
1054         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1055         cMETHOPx(o)->op_rclass_sv = NULL;
1056 #endif
1057         /* FALLTHROUGH */
1058     case OP_METHOD_NAMED:
1059     case OP_METHOD_SUPER:
1060         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1061         cMETHOPx(o)->op_u.op_meth_sv = NULL;
1062 #ifdef USE_ITHREADS
1063         if (o->op_targ) {
1064             pad_swipe(o->op_targ, 1);
1065             o->op_targ = 0;
1066         }
1067 #endif
1068         break;
1069     case OP_CONST:
1070     case OP_HINTSEVAL:
1071         SvREFCNT_dec(cSVOPo->op_sv);
1072         cSVOPo->op_sv = NULL;
1073 #ifdef USE_ITHREADS
1074         /** Bug #15654
1075           Even if op_clear does a pad_free for the target of the op,
1076           pad_free doesn't actually remove the sv that exists in the pad;
1077           instead it lives on. This results in that it could be reused as
1078           a target later on when the pad was reallocated.
1079         **/
1080         if(o->op_targ) {
1081           pad_swipe(o->op_targ,1);
1082           o->op_targ = 0;
1083         }
1084 #endif
1085         break;
1086     case OP_DUMP:
1087     case OP_GOTO:
1088     case OP_NEXT:
1089     case OP_LAST:
1090     case OP_REDO:
1091         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1092             break;
1093         /* FALLTHROUGH */
1094     case OP_TRANS:
1095     case OP_TRANSR:
1096         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1097             && (o->op_private & OPpTRANS_USE_SVOP))
1098         {
1099 #ifdef USE_ITHREADS
1100             if (cPADOPo->op_padix > 0) {
1101                 pad_swipe(cPADOPo->op_padix, TRUE);
1102                 cPADOPo->op_padix = 0;
1103             }
1104 #else
1105             SvREFCNT_dec(cSVOPo->op_sv);
1106             cSVOPo->op_sv = NULL;
1107 #endif
1108         }
1109         else {
1110             PerlMemShared_free(cPVOPo->op_pv);
1111             cPVOPo->op_pv = NULL;
1112         }
1113         break;
1114     case OP_SUBST:
1115         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1116         goto clear_pmop;
1117
1118     case OP_SPLIT:
1119         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1120             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1121         {
1122             if (o->op_private & OPpSPLIT_LEX)
1123                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1124             else
1125 #ifdef USE_ITHREADS
1126                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1127 #else
1128                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1129 #endif
1130         }
1131         /* FALLTHROUGH */
1132     case OP_MATCH:
1133     case OP_QR:
1134     clear_pmop:
1135         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1136             op_free(cPMOPo->op_code_list);
1137         cPMOPo->op_code_list = NULL;
1138         forget_pmop(cPMOPo);
1139         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1140         /* we use the same protection as the "SAFE" version of the PM_ macros
1141          * here since sv_clean_all might release some PMOPs
1142          * after PL_regex_padav has been cleared
1143          * and the clearing of PL_regex_padav needs to
1144          * happen before sv_clean_all
1145          */
1146 #ifdef USE_ITHREADS
1147         if(PL_regex_pad) {        /* We could be in destruction */
1148             const IV offset = (cPMOPo)->op_pmoffset;
1149             ReREFCNT_dec(PM_GETRE(cPMOPo));
1150             PL_regex_pad[offset] = &PL_sv_undef;
1151             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1152                            sizeof(offset));
1153         }
1154 #else
1155         ReREFCNT_dec(PM_GETRE(cPMOPo));
1156         PM_SETRE(cPMOPo, NULL);
1157 #endif
1158
1159         break;
1160
1161     case OP_ARGCHECK:
1162         PerlMemShared_free(cUNOP_AUXo->op_aux);
1163         break;
1164
1165     case OP_MULTICONCAT:
1166         {
1167             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1168             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1169              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1170              * utf8 shared strings */
1171             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1172             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1173             if (p1)
1174                 PerlMemShared_free(p1);
1175             if (p2 && p1 != p2)
1176                 PerlMemShared_free(p2);
1177             PerlMemShared_free(aux);
1178         }
1179         break;
1180
1181     case OP_MULTIDEREF:
1182         {
1183             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1184             UV actions = items->uv;
1185             bool last = 0;
1186             bool is_hash = FALSE;
1187
1188             while (!last) {
1189                 switch (actions & MDEREF_ACTION_MASK) {
1190
1191                 case MDEREF_reload:
1192                     actions = (++items)->uv;
1193                     continue;
1194
1195                 case MDEREF_HV_padhv_helem:
1196                     is_hash = TRUE;
1197                     /* FALLTHROUGH */
1198                 case MDEREF_AV_padav_aelem:
1199                     pad_free((++items)->pad_offset);
1200                     goto do_elem;
1201
1202                 case MDEREF_HV_gvhv_helem:
1203                     is_hash = TRUE;
1204                     /* FALLTHROUGH */
1205                 case MDEREF_AV_gvav_aelem:
1206 #ifdef USE_ITHREADS
1207                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1208 #else
1209                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1210 #endif
1211                     goto do_elem;
1212
1213                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1214                     is_hash = TRUE;
1215                     /* FALLTHROUGH */
1216                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1217 #ifdef USE_ITHREADS
1218                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1219 #else
1220                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1221 #endif
1222                     goto do_vivify_rv2xv_elem;
1223
1224                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1225                     is_hash = TRUE;
1226                     /* FALLTHROUGH */
1227                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1228                     pad_free((++items)->pad_offset);
1229                     goto do_vivify_rv2xv_elem;
1230
1231                 case MDEREF_HV_pop_rv2hv_helem:
1232                 case MDEREF_HV_vivify_rv2hv_helem:
1233                     is_hash = TRUE;
1234                     /* FALLTHROUGH */
1235                 do_vivify_rv2xv_elem:
1236                 case MDEREF_AV_pop_rv2av_aelem:
1237                 case MDEREF_AV_vivify_rv2av_aelem:
1238                 do_elem:
1239                     switch (actions & MDEREF_INDEX_MASK) {
1240                     case MDEREF_INDEX_none:
1241                         last = 1;
1242                         break;
1243                     case MDEREF_INDEX_const:
1244                         if (is_hash) {
1245 #ifdef USE_ITHREADS
1246                             /* see RT #15654 */
1247                             pad_swipe((++items)->pad_offset, 1);
1248 #else
1249                             SvREFCNT_dec((++items)->sv);
1250 #endif
1251                         }
1252                         else
1253                             items++;
1254                         break;
1255                     case MDEREF_INDEX_padsv:
1256                         pad_free((++items)->pad_offset);
1257                         break;
1258                     case MDEREF_INDEX_gvsv:
1259 #ifdef USE_ITHREADS
1260                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1261 #else
1262                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1263 #endif
1264                         break;
1265                     }
1266
1267                     if (actions & MDEREF_FLAG_last)
1268                         last = 1;
1269                     is_hash = FALSE;
1270
1271                     break;
1272
1273                 default:
1274                     assert(0);
1275                     last = 1;
1276                     break;
1277
1278                 } /* switch */
1279
1280                 actions >>= MDEREF_SHIFT;
1281             } /* while */
1282
1283             /* start of malloc is at op_aux[-1], where the length is
1284              * stored */
1285             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1286         }
1287         break;
1288     }
1289
1290     if (o->op_targ > 0) {
1291         pad_free(o->op_targ);
1292         o->op_targ = 0;
1293     }
1294 }
1295
1296 STATIC void
1297 S_cop_free(pTHX_ COP* cop)
1298 {
1299     PERL_ARGS_ASSERT_COP_FREE;
1300
1301     CopFILE_free(cop);
1302     if (! specialWARN(cop->cop_warnings))
1303         PerlMemShared_free(cop->cop_warnings);
1304     cophh_free(CopHINTHASH_get(cop));
1305     if (PL_curcop == cop)
1306        PL_curcop = NULL;
1307 }
1308
1309 STATIC void
1310 S_forget_pmop(pTHX_ PMOP *const o)
1311 {
1312     HV * const pmstash = PmopSTASH(o);
1313
1314     PERL_ARGS_ASSERT_FORGET_PMOP;
1315
1316     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1317         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1318         if (mg) {
1319             PMOP **const array = (PMOP**) mg->mg_ptr;
1320             U32 count = mg->mg_len / sizeof(PMOP**);
1321             U32 i = count;
1322
1323             while (i--) {
1324                 if (array[i] == o) {
1325                     /* Found it. Move the entry at the end to overwrite it.  */
1326                     array[i] = array[--count];
1327                     mg->mg_len = count * sizeof(PMOP**);
1328                     /* Could realloc smaller at this point always, but probably
1329                        not worth it. Probably worth free()ing if we're the
1330                        last.  */
1331                     if(!count) {
1332                         Safefree(mg->mg_ptr);
1333                         mg->mg_ptr = NULL;
1334                     }
1335                     break;
1336                 }
1337             }
1338         }
1339     }
1340     if (PL_curpm == o)
1341         PL_curpm = NULL;
1342 }
1343
1344
1345 STATIC void
1346 S_find_and_forget_pmops(pTHX_ OP *o)
1347 {
1348     OP* top_op = o;
1349
1350     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1351
1352     while (1) {
1353         switch (o->op_type) {
1354         case OP_SUBST:
1355         case OP_SPLIT:
1356         case OP_MATCH:
1357         case OP_QR:
1358             forget_pmop((PMOP*)o);
1359         }
1360
1361         if (o->op_flags & OPf_KIDS) {
1362             o = cUNOPo->op_first;
1363             continue;
1364         }
1365
1366         while (1) {
1367             if (o == top_op)
1368                 return; /* at top; no parents/siblings to try */
1369             if (OpHAS_SIBLING(o)) {
1370                 o = o->op_sibparent; /* process next sibling */
1371                 break;
1372             }
1373             o = o->op_sibparent; /*try parent's next sibling */
1374         }
1375     }
1376 }
1377
1378
1379 /*
1380 =for apidoc op_null
1381
1382 Neutralizes an op when it is no longer needed, but is still linked to from
1383 other ops.
1384
1385 =cut
1386 */
1387
1388 void
1389 Perl_op_null(pTHX_ OP *o)
1390 {
1391
1392     PERL_ARGS_ASSERT_OP_NULL;
1393
1394     if (o->op_type == OP_NULL)
1395         return;
1396     op_clear(o);
1397     o->op_targ = o->op_type;
1398     OpTYPE_set(o, OP_NULL);
1399 }
1400
1401 void
1402 Perl_op_refcnt_lock(pTHX)
1403   PERL_TSA_ACQUIRE(PL_op_mutex)
1404 {
1405 #ifdef USE_ITHREADS
1406 #endif
1407     PERL_UNUSED_CONTEXT;
1408     OP_REFCNT_LOCK;
1409 }
1410
1411 void
1412 Perl_op_refcnt_unlock(pTHX)
1413   PERL_TSA_RELEASE(PL_op_mutex)
1414 {
1415 #ifdef USE_ITHREADS
1416 #endif
1417     PERL_UNUSED_CONTEXT;
1418     OP_REFCNT_UNLOCK;
1419 }
1420
1421
1422 /*
1423 =for apidoc op_sibling_splice
1424
1425 A general function for editing the structure of an existing chain of
1426 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1427 you to delete zero or more sequential nodes, replacing them with zero or
1428 more different nodes.  Performs the necessary op_first/op_last
1429 housekeeping on the parent node and op_sibling manipulation on the
1430 children.  The last deleted node will be marked as the last node by
1431 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1432
1433 Note that op_next is not manipulated, and nodes are not freed; that is the
1434 responsibility of the caller.  It also won't create a new list op for an
1435 empty list etc; use higher-level functions like op_append_elem() for that.
1436
1437 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1438 the splicing doesn't affect the first or last op in the chain.
1439
1440 C<start> is the node preceding the first node to be spliced.  Node(s)
1441 following it will be deleted, and ops will be inserted after it.  If it is
1442 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1443 beginning.
1444
1445 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1446 If -1 or greater than or equal to the number of remaining kids, all
1447 remaining kids are deleted.
1448
1449 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1450 If C<NULL>, no nodes are inserted.
1451
1452 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1453 deleted.
1454
1455 For example:
1456
1457     action                    before      after         returns
1458     ------                    -----       -----         -------
1459
1460                               P           P
1461     splice(P, A, 2, X-Y-Z)    |           |             B-C
1462                               A-B-C-D     A-X-Y-Z-D
1463
1464                               P           P
1465     splice(P, NULL, 1, X-Y)   |           |             A
1466                               A-B-C-D     X-Y-B-C-D
1467
1468                               P           P
1469     splice(P, NULL, 3, NULL)  |           |             A-B-C
1470                               A-B-C-D     D
1471
1472                               P           P
1473     splice(P, B, 0, X-Y)      |           |             NULL
1474                               A-B-C-D     A-B-X-Y-C-D
1475
1476
1477 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1478 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1479
1480 =cut
1481 */
1482
1483 OP *
1484 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1485 {
1486     OP *first;
1487     OP *rest;
1488     OP *last_del = NULL;
1489     OP *last_ins = NULL;
1490
1491     if (start)
1492         first = OpSIBLING(start);
1493     else if (!parent)
1494         goto no_parent;
1495     else
1496         first = cLISTOPx(parent)->op_first;
1497
1498     assert(del_count >= -1);
1499
1500     if (del_count && first) {
1501         last_del = first;
1502         while (--del_count && OpHAS_SIBLING(last_del))
1503             last_del = OpSIBLING(last_del);
1504         rest = OpSIBLING(last_del);
1505         OpLASTSIB_set(last_del, NULL);
1506     }
1507     else
1508         rest = first;
1509
1510     if (insert) {
1511         last_ins = insert;
1512         while (OpHAS_SIBLING(last_ins))
1513             last_ins = OpSIBLING(last_ins);
1514         OpMAYBESIB_set(last_ins, rest, NULL);
1515     }
1516     else
1517         insert = rest;
1518
1519     if (start) {
1520         OpMAYBESIB_set(start, insert, NULL);
1521     }
1522     else {
1523         assert(parent);
1524         cLISTOPx(parent)->op_first = insert;
1525         if (insert)
1526             parent->op_flags |= OPf_KIDS;
1527         else
1528             parent->op_flags &= ~OPf_KIDS;
1529     }
1530
1531     if (!rest) {
1532         /* update op_last etc */
1533         U32 type;
1534         OP *lastop;
1535
1536         if (!parent)
1537             goto no_parent;
1538
1539         /* ought to use OP_CLASS(parent) here, but that can't handle
1540          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1541          * either */
1542         type = parent->op_type;
1543         if (type == OP_CUSTOM) {
1544             dTHX;
1545             type = XopENTRYCUSTOM(parent, xop_class);
1546         }
1547         else {
1548             if (type == OP_NULL)
1549                 type = parent->op_targ;
1550             type = PL_opargs[type] & OA_CLASS_MASK;
1551         }
1552
1553         lastop = last_ins ? last_ins : start ? start : NULL;
1554         if (   type == OA_BINOP
1555             || type == OA_LISTOP
1556             || type == OA_PMOP
1557             || type == OA_LOOP
1558         )
1559             cLISTOPx(parent)->op_last = lastop;
1560
1561         if (lastop)
1562             OpLASTSIB_set(lastop, parent);
1563     }
1564     return last_del ? first : NULL;
1565
1566   no_parent:
1567     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1568 }
1569
1570 /*
1571 =for apidoc op_parent
1572
1573 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1574
1575 =cut
1576 */
1577
1578 OP *
1579 Perl_op_parent(OP *o)
1580 {
1581     PERL_ARGS_ASSERT_OP_PARENT;
1582     while (OpHAS_SIBLING(o))
1583         o = OpSIBLING(o);
1584     return o->op_sibparent;
1585 }
1586
1587 /* replace the sibling following start with a new UNOP, which becomes
1588  * the parent of the original sibling; e.g.
1589  *
1590  *  op_sibling_newUNOP(P, A, unop-args...)
1591  *
1592  *  P              P
1593  *  |      becomes |
1594  *  A-B-C          A-U-C
1595  *                   |
1596  *                   B
1597  *
1598  * where U is the new UNOP.
1599  *
1600  * parent and start args are the same as for op_sibling_splice();
1601  * type and flags args are as newUNOP().
1602  *
1603  * Returns the new UNOP.
1604  */
1605
1606 STATIC OP *
1607 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1608 {
1609     OP *kid, *newop;
1610
1611     kid = op_sibling_splice(parent, start, 1, NULL);
1612     newop = newUNOP(type, flags, kid);
1613     op_sibling_splice(parent, start, 0, newop);
1614     return newop;
1615 }
1616
1617
1618 /* lowest-level newLOGOP-style function - just allocates and populates
1619  * the struct. Higher-level stuff should be done by S_new_logop() /
1620  * newLOGOP(). This function exists mainly to avoid op_first assignment
1621  * being spread throughout this file.
1622  */
1623
1624 LOGOP *
1625 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1626 {
1627     LOGOP *logop;
1628     OP *kid = first;
1629     NewOp(1101, logop, 1, LOGOP);
1630     OpTYPE_set(logop, type);
1631     logop->op_first = first;
1632     logop->op_other = other;
1633     if (first)
1634         logop->op_flags = OPf_KIDS;
1635     while (kid && OpHAS_SIBLING(kid))
1636         kid = OpSIBLING(kid);
1637     if (kid)
1638         OpLASTSIB_set(kid, (OP*)logop);
1639     return logop;
1640 }
1641
1642
1643 /* Contextualizers */
1644
1645 /*
1646 =for apidoc op_contextualize
1647
1648 Applies a syntactic context to an op tree representing an expression.
1649 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1650 or C<G_VOID> to specify the context to apply.  The modified op tree
1651 is returned.
1652
1653 =cut
1654 */
1655
1656 OP *
1657 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1658 {
1659     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1660     switch (context) {
1661         case G_SCALAR: return scalar(o);
1662         case G_ARRAY:  return list(o);
1663         case G_VOID:   return scalarvoid(o);
1664         default:
1665             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1666                        (long) context);
1667     }
1668 }
1669
1670 /*
1671
1672 =for apidoc op_linklist
1673 This function is the implementation of the L</LINKLIST> macro.  It should
1674 not be called directly.
1675
1676 =cut
1677 */
1678
1679
1680 OP *
1681 Perl_op_linklist(pTHX_ OP *o)
1682 {
1683
1684     OP **prevp;
1685     OP *kid;
1686     OP * top_op = o;
1687
1688     PERL_ARGS_ASSERT_OP_LINKLIST;
1689
1690     while (1) {
1691         /* Descend down the tree looking for any unprocessed subtrees to
1692          * do first */
1693         if (!o->op_next) {
1694             if (o->op_flags & OPf_KIDS) {
1695                 o = cUNOPo->op_first;
1696                 continue;
1697             }
1698             o->op_next = o; /* leaf node; link to self initially */
1699         }
1700
1701         /* if we're at the top level, there either weren't any children
1702          * to process, or we've worked our way back to the top. */
1703         if (o == top_op)
1704             return o->op_next;
1705
1706         /* o is now processed. Next, process any sibling subtrees */
1707
1708         if (OpHAS_SIBLING(o)) {
1709             o = OpSIBLING(o);
1710             continue;
1711         }
1712
1713         /* Done all the subtrees at this level. Go back up a level and
1714          * link the parent in with all its (processed) children.
1715          */
1716
1717         o = o->op_sibparent;
1718         assert(!o->op_next);
1719         prevp = &(o->op_next);
1720         kid   = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1721         while (kid) {
1722             *prevp = kid->op_next;
1723             prevp = &(kid->op_next);
1724             kid = OpSIBLING(kid);
1725         }
1726         *prevp = o;
1727     }
1728 }
1729
1730
1731 static OP *
1732 S_scalarkids(pTHX_ OP *o)
1733 {
1734     if (o && o->op_flags & OPf_KIDS) {
1735         OP *kid;
1736         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1737             scalar(kid);
1738     }
1739     return o;
1740 }
1741
1742 STATIC OP *
1743 S_scalarboolean(pTHX_ OP *o)
1744 {
1745     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1746
1747     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1748          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1749         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1750          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1751          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1752         if (ckWARN(WARN_SYNTAX)) {
1753             const line_t oldline = CopLINE(PL_curcop);
1754
1755             if (PL_parser && PL_parser->copline != NOLINE) {
1756                 /* This ensures that warnings are reported at the first line
1757                    of the conditional, not the last.  */
1758                 CopLINE_set(PL_curcop, PL_parser->copline);
1759             }
1760             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1761             CopLINE_set(PL_curcop, oldline);
1762         }
1763     }
1764     return scalar(o);
1765 }
1766
1767 static SV *
1768 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1769 {
1770     assert(o);
1771     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1772            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1773     {
1774         const char funny  = o->op_type == OP_PADAV
1775                          || o->op_type == OP_RV2AV ? '@' : '%';
1776         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1777             GV *gv;
1778             if (cUNOPo->op_first->op_type != OP_GV
1779              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1780                 return NULL;
1781             return varname(gv, funny, 0, NULL, 0, subscript_type);
1782         }
1783         return
1784             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1785     }
1786 }
1787
1788 static SV *
1789 S_op_varname(pTHX_ const OP *o)
1790 {
1791     return S_op_varname_subscript(aTHX_ o, 1);
1792 }
1793
1794 static void
1795 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1796 { /* or not so pretty :-) */
1797     if (o->op_type == OP_CONST) {
1798         *retsv = cSVOPo_sv;
1799         if (SvPOK(*retsv)) {
1800             SV *sv = *retsv;
1801             *retsv = sv_newmortal();
1802             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1803                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1804         }
1805         else if (!SvOK(*retsv))
1806             *retpv = "undef";
1807     }
1808     else *retpv = "...";
1809 }
1810
1811 static void
1812 S_scalar_slice_warning(pTHX_ const OP *o)
1813 {
1814     OP *kid;
1815     const bool h = o->op_type == OP_HSLICE
1816                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1817     const char lbrack =
1818         h ? '{' : '[';
1819     const char rbrack =
1820         h ? '}' : ']';
1821     SV *name;
1822     SV *keysv = NULL; /* just to silence compiler warnings */
1823     const char *key = NULL;
1824
1825     if (!(o->op_private & OPpSLICEWARNING))
1826         return;
1827     if (PL_parser && PL_parser->error_count)
1828         /* This warning can be nonsensical when there is a syntax error. */
1829         return;
1830
1831     kid = cLISTOPo->op_first;
1832     kid = OpSIBLING(kid); /* get past pushmark */
1833     /* weed out false positives: any ops that can return lists */
1834     switch (kid->op_type) {
1835     case OP_BACKTICK:
1836     case OP_GLOB:
1837     case OP_READLINE:
1838     case OP_MATCH:
1839     case OP_RV2AV:
1840     case OP_EACH:
1841     case OP_VALUES:
1842     case OP_KEYS:
1843     case OP_SPLIT:
1844     case OP_LIST:
1845     case OP_SORT:
1846     case OP_REVERSE:
1847     case OP_ENTERSUB:
1848     case OP_CALLER:
1849     case OP_LSTAT:
1850     case OP_STAT:
1851     case OP_READDIR:
1852     case OP_SYSTEM:
1853     case OP_TMS:
1854     case OP_LOCALTIME:
1855     case OP_GMTIME:
1856     case OP_ENTEREVAL:
1857         return;
1858     }
1859
1860     /* Don't warn if we have a nulled list either. */
1861     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1862         return;
1863
1864     assert(OpSIBLING(kid));
1865     name = S_op_varname(aTHX_ OpSIBLING(kid));
1866     if (!name) /* XS module fiddling with the op tree */
1867         return;
1868     S_op_pretty(aTHX_ kid, &keysv, &key);
1869     assert(SvPOK(name));
1870     sv_chop(name,SvPVX(name)+1);
1871     if (key)
1872        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1873         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1874                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1875                    "%c%s%c",
1876                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1877                     lbrack, key, rbrack);
1878     else
1879        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1880         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1881                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1882                     SVf "%c%" SVf "%c",
1883                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1884                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1885 }
1886
1887
1888
1889 /* apply scalar context to the o subtree */
1890
1891 OP *
1892 Perl_scalar(pTHX_ OP *o)
1893 {
1894     OP * top_op = o;
1895
1896     while (1) {
1897         OP *next_kid = NULL; /* what op (if any) to process next */
1898         OP *kid;
1899
1900         /* assumes no premature commitment */
1901         if (!o || (PL_parser && PL_parser->error_count)
1902              || (o->op_flags & OPf_WANT)
1903              || o->op_type == OP_RETURN)
1904         {
1905             goto do_next;
1906         }
1907
1908         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1909
1910         switch (o->op_type) {
1911         case OP_REPEAT:
1912             scalar(cBINOPo->op_first);
1913             /* convert what initially looked like a list repeat into a
1914              * scalar repeat, e.g. $s = (1) x $n
1915              */
1916             if (o->op_private & OPpREPEAT_DOLIST) {
1917                 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1918                 assert(kid->op_type == OP_PUSHMARK);
1919                 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1920                     op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1921                     o->op_private &=~ OPpREPEAT_DOLIST;
1922                 }
1923             }
1924             break;
1925
1926         case OP_OR:
1927         case OP_AND:
1928         case OP_COND_EXPR:
1929             /* impose scalar context on everything except the condition */
1930             next_kid = OpSIBLING(cUNOPo->op_first);
1931             break;
1932
1933         default:
1934             if (o->op_flags & OPf_KIDS)
1935                 next_kid = cUNOPo->op_first; /* do all kids */
1936             break;
1937
1938         /* the children of these ops are usually a list of statements,
1939          * except the leaves, whose first child is a corresponding enter
1940          */
1941         case OP_SCOPE:
1942         case OP_LINESEQ:
1943         case OP_LIST:
1944             kid = cLISTOPo->op_first;
1945             goto do_kids;
1946         case OP_LEAVE:
1947         case OP_LEAVETRY:
1948             kid = cLISTOPo->op_first;
1949             scalar(kid);
1950             kid = OpSIBLING(kid);
1951         do_kids:
1952             while (kid) {
1953                 OP *sib = OpSIBLING(kid);
1954                 /* Apply void context to all kids except the last, which
1955                  * is scalar (ignoring a trailing ex-nextstate in determining
1956                  * if it's the last kid). E.g.
1957                  *      $scalar = do { void; void; scalar }
1958                  * Except that 'when's are always scalar, e.g.
1959                  *      $scalar = do { given(..) {
1960                     *                 when (..) { scalar }
1961                     *                 when (..) { scalar }
1962                     *                 ...
1963                     *                }}
1964                     */
1965                 if (!sib
1966                      || (  !OpHAS_SIBLING(sib)
1967                          && sib->op_type == OP_NULL
1968                          && (   sib->op_targ == OP_NEXTSTATE
1969                              || sib->op_targ == OP_DBSTATE  )
1970                         )
1971                 )
1972                 {
1973                     /* tail call optimise calling scalar() on the last kid */
1974                     next_kid = kid;
1975                     goto do_next;
1976                 }
1977                 else if (kid->op_type == OP_LEAVEWHEN)
1978                     scalar(kid);
1979                 else
1980                     scalarvoid(kid);
1981                 kid = sib;
1982             }
1983             NOT_REACHED; /* NOTREACHED */
1984             break;
1985
1986         case OP_SORT:
1987             Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1988             break;
1989
1990         case OP_KVHSLICE:
1991         case OP_KVASLICE:
1992         {
1993             /* Warn about scalar context */
1994             const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1995             const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1996             SV *name;
1997             SV *keysv;
1998             const char *key = NULL;
1999
2000             /* This warning can be nonsensical when there is a syntax error. */
2001             if (PL_parser && PL_parser->error_count)
2002                 break;
2003
2004             if (!ckWARN(WARN_SYNTAX)) break;
2005
2006             kid = cLISTOPo->op_first;
2007             kid = OpSIBLING(kid); /* get past pushmark */
2008             assert(OpSIBLING(kid));
2009             name = S_op_varname(aTHX_ OpSIBLING(kid));
2010             if (!name) /* XS module fiddling with the op tree */
2011                 break;
2012             S_op_pretty(aTHX_ kid, &keysv, &key);
2013             assert(SvPOK(name));
2014             sv_chop(name,SvPVX(name)+1);
2015             if (key)
2016       /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2017                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2018                            "%%%" SVf "%c%s%c in scalar context better written "
2019                            "as $%" SVf "%c%s%c",
2020                             SVfARG(name), lbrack, key, rbrack, SVfARG(name),
2021                             lbrack, key, rbrack);
2022             else
2023       /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2024                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2025                            "%%%" SVf "%c%" SVf "%c in scalar context better "
2026                            "written as $%" SVf "%c%" SVf "%c",
2027                             SVfARG(name), lbrack, SVfARG(keysv), rbrack,
2028                             SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2029         }
2030         } /* switch */
2031
2032         /* If next_kid is set, someone in the code above wanted us to process
2033          * that kid and all its remaining siblings.  Otherwise, work our way
2034          * back up the tree */
2035       do_next:
2036         while (!next_kid) {
2037             if (o == top_op)
2038                 return top_op; /* at top; no parents/siblings to try */
2039             if (OpHAS_SIBLING(o))
2040                 next_kid = o->op_sibparent;
2041             else {
2042                 o = o->op_sibparent; /*try parent's next sibling */
2043                 switch (o->op_type) {
2044                 case OP_SCOPE:
2045                 case OP_LINESEQ:
2046                 case OP_LIST:
2047                 case OP_LEAVE:
2048                 case OP_LEAVETRY:
2049                     /* should really restore PL_curcop to its old value, but
2050                      * setting it to PL_compiling is better than do nothing */
2051                     PL_curcop = &PL_compiling;
2052                 }
2053             }
2054         }
2055         o = next_kid;
2056     } /* while */
2057 }
2058
2059
2060 /* apply void context to the optree arg */
2061
2062 OP *
2063 Perl_scalarvoid(pTHX_ OP *arg)
2064 {
2065     OP *kid;
2066     SV* sv;
2067     OP *o = arg;
2068
2069     PERL_ARGS_ASSERT_SCALARVOID;
2070
2071     while (1) {
2072         U8 want;
2073         SV *useless_sv = NULL;
2074         const char* useless = NULL;
2075         OP * next_kid = NULL;
2076
2077         if (o->op_type == OP_NEXTSTATE
2078             || o->op_type == OP_DBSTATE
2079             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2080                                           || o->op_targ == OP_DBSTATE)))
2081             PL_curcop = (COP*)o;                /* for warning below */
2082
2083         /* assumes no premature commitment */
2084         want = o->op_flags & OPf_WANT;
2085         if ((want && want != OPf_WANT_SCALAR)
2086             || (PL_parser && PL_parser->error_count)
2087             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2088         {
2089             goto get_next_op;
2090         }
2091
2092         if ((o->op_private & OPpTARGET_MY)
2093             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2094         {
2095             /* newASSIGNOP has already applied scalar context, which we
2096                leave, as if this op is inside SASSIGN.  */
2097             goto get_next_op;
2098         }
2099
2100         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2101
2102         switch (o->op_type) {
2103         default:
2104             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2105                 break;
2106             /* FALLTHROUGH */
2107         case OP_REPEAT:
2108             if (o->op_flags & OPf_STACKED)
2109                 break;
2110             if (o->op_type == OP_REPEAT)
2111                 scalar(cBINOPo->op_first);
2112             goto func_ops;
2113         case OP_CONCAT:
2114             if ((o->op_flags & OPf_STACKED) &&
2115                     !(o->op_private & OPpCONCAT_NESTED))
2116                 break;
2117             goto func_ops;
2118         case OP_SUBSTR:
2119             if (o->op_private == 4)
2120                 break;
2121             /* FALLTHROUGH */
2122         case OP_WANTARRAY:
2123         case OP_GV:
2124         case OP_SMARTMATCH:
2125         case OP_AV2ARYLEN:
2126         case OP_REF:
2127         case OP_REFGEN:
2128         case OP_SREFGEN:
2129         case OP_DEFINED:
2130         case OP_HEX:
2131         case OP_OCT:
2132         case OP_LENGTH:
2133         case OP_VEC:
2134         case OP_INDEX:
2135         case OP_RINDEX:
2136         case OP_SPRINTF:
2137         case OP_KVASLICE:
2138         case OP_KVHSLICE:
2139         case OP_UNPACK:
2140         case OP_PACK:
2141         case OP_JOIN:
2142         case OP_LSLICE:
2143         case OP_ANONLIST:
2144         case OP_ANONHASH:
2145         case OP_SORT:
2146         case OP_REVERSE:
2147         case OP_RANGE:
2148         case OP_FLIP:
2149         case OP_FLOP:
2150         case OP_CALLER:
2151         case OP_FILENO:
2152         case OP_EOF:
2153         case OP_TELL:
2154         case OP_GETSOCKNAME:
2155         case OP_GETPEERNAME:
2156         case OP_READLINK:
2157         case OP_TELLDIR:
2158         case OP_GETPPID:
2159         case OP_GETPGRP:
2160         case OP_GETPRIORITY:
2161         case OP_TIME:
2162         case OP_TMS:
2163         case OP_LOCALTIME:
2164         case OP_GMTIME:
2165         case OP_GHBYNAME:
2166         case OP_GHBYADDR:
2167         case OP_GHOSTENT:
2168         case OP_GNBYNAME:
2169         case OP_GNBYADDR:
2170         case OP_GNETENT:
2171         case OP_GPBYNAME:
2172         case OP_GPBYNUMBER:
2173         case OP_GPROTOENT:
2174         case OP_GSBYNAME:
2175         case OP_GSBYPORT:
2176         case OP_GSERVENT:
2177         case OP_GPWNAM:
2178         case OP_GPWUID:
2179         case OP_GGRNAM:
2180         case OP_GGRGID:
2181         case OP_GETLOGIN:
2182         case OP_PROTOTYPE:
2183         case OP_RUNCV:
2184         func_ops:
2185             useless = OP_DESC(o);
2186             break;
2187
2188         case OP_GVSV:
2189         case OP_PADSV:
2190         case OP_PADAV:
2191         case OP_PADHV:
2192         case OP_PADANY:
2193         case OP_AELEM:
2194         case OP_AELEMFAST:
2195         case OP_AELEMFAST_LEX:
2196         case OP_ASLICE:
2197         case OP_HELEM:
2198         case OP_HSLICE:
2199             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2200                 /* Otherwise it's "Useless use of grep iterator" */
2201                 useless = OP_DESC(o);
2202             break;
2203
2204         case OP_SPLIT:
2205             if (!(o->op_private & OPpSPLIT_ASSIGN))
2206                 useless = OP_DESC(o);
2207             break;
2208
2209         case OP_NOT:
2210             kid = cUNOPo->op_first;
2211             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2212                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2213                 goto func_ops;
2214             }
2215             useless = "negative pattern binding (!~)";
2216             break;
2217
2218         case OP_SUBST:
2219             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2220                 useless = "non-destructive substitution (s///r)";
2221             break;
2222
2223         case OP_TRANSR:
2224             useless = "non-destructive transliteration (tr///r)";
2225             break;
2226
2227         case OP_RV2GV:
2228         case OP_RV2SV:
2229         case OP_RV2AV:
2230         case OP_RV2HV:
2231             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2232                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2233                 useless = "a variable";
2234             break;
2235
2236         case OP_CONST:
2237             sv = cSVOPo_sv;
2238             if (cSVOPo->op_private & OPpCONST_STRICT)
2239                 no_bareword_allowed(o);
2240             else {
2241                 if (ckWARN(WARN_VOID)) {
2242                     NV nv;
2243                     /* don't warn on optimised away booleans, eg
2244                      * use constant Foo, 5; Foo || print; */
2245                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2246                         useless = NULL;
2247                     /* the constants 0 and 1 are permitted as they are
2248                        conventionally used as dummies in constructs like
2249                        1 while some_condition_with_side_effects;  */
2250                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2251                         useless = NULL;
2252                     else if (SvPOK(sv)) {
2253                         SV * const dsv = newSVpvs("");
2254                         useless_sv
2255                             = Perl_newSVpvf(aTHX_
2256                                             "a constant (%s)",
2257                                             pv_pretty(dsv, SvPVX_const(sv),
2258                                                       SvCUR(sv), 32, NULL, NULL,
2259                                                       PERL_PV_PRETTY_DUMP
2260                                                       | PERL_PV_ESCAPE_NOCLEAR
2261                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2262                         SvREFCNT_dec_NN(dsv);
2263                     }
2264                     else if (SvOK(sv)) {
2265                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2266                     }
2267                     else
2268                         useless = "a constant (undef)";
2269                 }
2270             }
2271             op_null(o);         /* don't execute or even remember it */
2272             break;
2273
2274         case OP_POSTINC:
2275             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2276             break;
2277
2278         case OP_POSTDEC:
2279             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2280             break;
2281
2282         case OP_I_POSTINC:
2283             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2284             break;
2285
2286         case OP_I_POSTDEC:
2287             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2288             break;
2289
2290         case OP_SASSIGN: {
2291             OP *rv2gv;
2292             UNOP *refgen, *rv2cv;
2293             LISTOP *exlist;
2294
2295             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2296                 break;
2297
2298             rv2gv = ((BINOP *)o)->op_last;
2299             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2300                 break;
2301
2302             refgen = (UNOP *)((BINOP *)o)->op_first;
2303
2304             if (!refgen || (refgen->op_type != OP_REFGEN
2305                             && refgen->op_type != OP_SREFGEN))
2306                 break;
2307
2308             exlist = (LISTOP *)refgen->op_first;
2309             if (!exlist || exlist->op_type != OP_NULL
2310                 || exlist->op_targ != OP_LIST)
2311                 break;
2312
2313             if (exlist->op_first->op_type != OP_PUSHMARK
2314                 && exlist->op_first != exlist->op_last)
2315                 break;
2316
2317             rv2cv = (UNOP*)exlist->op_last;
2318
2319             if (rv2cv->op_type != OP_RV2CV)
2320                 break;
2321
2322             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2323             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2324             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2325
2326             o->op_private |= OPpASSIGN_CV_TO_GV;
2327             rv2gv->op_private |= OPpDONT_INIT_GV;
2328             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2329
2330             break;
2331         }
2332
2333         case OP_AASSIGN: {
2334             inplace_aassign(o);
2335             break;
2336         }
2337
2338         case OP_OR:
2339         case OP_AND:
2340             kid = cLOGOPo->op_first;
2341             if (kid->op_type == OP_NOT
2342                 && (kid->op_flags & OPf_KIDS)) {
2343                 if (o->op_type == OP_AND) {
2344                     OpTYPE_set(o, OP_OR);
2345                 } else {
2346                     OpTYPE_set(o, OP_AND);
2347                 }
2348                 op_null(kid);
2349             }
2350             /* FALLTHROUGH */
2351
2352         case OP_DOR:
2353         case OP_COND_EXPR:
2354         case OP_ENTERGIVEN:
2355         case OP_ENTERWHEN:
2356             next_kid = OpSIBLING(cUNOPo->op_first);
2357         break;
2358
2359         case OP_NULL:
2360             if (o->op_flags & OPf_STACKED)
2361                 break;
2362             /* FALLTHROUGH */
2363         case OP_NEXTSTATE:
2364         case OP_DBSTATE:
2365         case OP_ENTERTRY:
2366         case OP_ENTER:
2367             if (!(o->op_flags & OPf_KIDS))
2368                 break;
2369             /* FALLTHROUGH */
2370         case OP_SCOPE:
2371         case OP_LEAVE:
2372         case OP_LEAVETRY:
2373         case OP_LEAVELOOP:
2374         case OP_LINESEQ:
2375         case OP_LEAVEGIVEN:
2376         case OP_LEAVEWHEN:
2377         kids:
2378             next_kid = cLISTOPo->op_first;
2379             break;
2380         case OP_LIST:
2381             /* If the first kid after pushmark is something that the padrange
2382                optimisation would reject, then null the list and the pushmark.
2383             */
2384             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2385                 && (  !(kid = OpSIBLING(kid))
2386                       || (  kid->op_type != OP_PADSV
2387                             && kid->op_type != OP_PADAV
2388                             && kid->op_type != OP_PADHV)
2389                       || kid->op_private & ~OPpLVAL_INTRO
2390                       || !(kid = OpSIBLING(kid))
2391                       || (  kid->op_type != OP_PADSV
2392                             && kid->op_type != OP_PADAV
2393                             && kid->op_type != OP_PADHV)
2394                       || kid->op_private & ~OPpLVAL_INTRO)
2395             ) {
2396                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2397                 op_null(o); /* NULL the list */
2398             }
2399             goto kids;
2400         case OP_ENTEREVAL:
2401             scalarkids(o);
2402             break;
2403         case OP_SCALAR:
2404             scalar(o);
2405             break;
2406         }
2407
2408         if (useless_sv) {
2409             /* mortalise it, in case warnings are fatal.  */
2410             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2411                            "Useless use of %" SVf " in void context",
2412                            SVfARG(sv_2mortal(useless_sv)));
2413         }
2414         else if (useless) {
2415             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2416                            "Useless use of %s in void context",
2417                            useless);
2418         }
2419
2420       get_next_op:
2421         /* if a kid hasn't been nominated to process, continue with the
2422          * next sibling, or if no siblings left, go back to the parent's
2423          * siblings and so on
2424          */
2425         while (!next_kid) {
2426             if (o == arg)
2427                 return arg; /* at top; no parents/siblings to try */
2428             if (OpHAS_SIBLING(o))
2429                 next_kid = o->op_sibparent;
2430             else
2431                 o = o->op_sibparent; /*try parent's next sibling */
2432         }
2433         o = next_kid;
2434     }
2435
2436     return arg;
2437 }
2438
2439
2440 static OP *
2441 S_listkids(pTHX_ OP *o)
2442 {
2443     if (o && o->op_flags & OPf_KIDS) {
2444         OP *kid;
2445         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2446             list(kid);
2447     }
2448     return o;
2449 }
2450
2451
2452 /* apply list context to the o subtree */
2453
2454 OP *
2455 Perl_list(pTHX_ OP *o)
2456 {
2457     OP * top_op = o;
2458
2459     while (1) {
2460         OP *next_kid = NULL; /* what op (if any) to process next */
2461
2462         OP *kid;
2463
2464         /* assumes no premature commitment */
2465         if (!o || (o->op_flags & OPf_WANT)
2466              || (PL_parser && PL_parser->error_count)
2467              || o->op_type == OP_RETURN)
2468         {
2469             goto do_next;
2470         }
2471
2472         if ((o->op_private & OPpTARGET_MY)
2473             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2474         {
2475             goto do_next;                               /* As if inside SASSIGN */
2476         }
2477
2478         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2479
2480         switch (o->op_type) {
2481         case OP_REPEAT:
2482             if (o->op_private & OPpREPEAT_DOLIST
2483              && !(o->op_flags & OPf_STACKED))
2484             {
2485                 list(cBINOPo->op_first);
2486                 kid = cBINOPo->op_last;
2487                 /* optimise away (.....) x 1 */
2488                 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2489                  && SvIVX(kSVOP_sv) == 1)
2490                 {
2491                     op_null(o); /* repeat */
2492                     op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2493                     /* const (rhs): */
2494                     op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2495                 }
2496             }
2497             break;
2498
2499         case OP_OR:
2500         case OP_AND:
2501         case OP_COND_EXPR:
2502             /* impose list context on everything except the condition */
2503             next_kid = OpSIBLING(cUNOPo->op_first);
2504             break;
2505
2506         default:
2507             if (!(o->op_flags & OPf_KIDS))
2508                 break;
2509             /* possibly flatten 1..10 into a constant array */
2510             if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2511                 list(cBINOPo->op_first);
2512                 gen_constant_list(o);
2513                 goto do_next;
2514             }
2515             next_kid = cUNOPo->op_first; /* do all kids */
2516             break;
2517
2518         case OP_LIST:
2519             if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2520                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2521                 op_null(o); /* NULL the list */
2522             }
2523             if (o->op_flags & OPf_KIDS)
2524                 next_kid = cUNOPo->op_first; /* do all kids */
2525             break;
2526
2527         /* the children of these ops are usually a list of statements,
2528          * except the leaves, whose first child is a corresponding enter
2529          */
2530         case OP_SCOPE:
2531         case OP_LINESEQ:
2532             kid = cLISTOPo->op_first;
2533             goto do_kids;
2534         case OP_LEAVE:
2535         case OP_LEAVETRY:
2536             kid = cLISTOPo->op_first;
2537             list(kid);
2538             kid = OpSIBLING(kid);
2539         do_kids:
2540             while (kid) {
2541                 OP *sib = OpSIBLING(kid);
2542                 /* Apply void context to all kids except the last, which
2543                  * is list. E.g.
2544                  *      @a = do { void; void; list }
2545                  * Except that 'when's are always list context, e.g.
2546                  *      @a = do { given(..) {
2547                     *                 when (..) { list }
2548                     *                 when (..) { list }
2549                     *                 ...
2550                     *                }}
2551                     */
2552                 if (!sib) {
2553                     /* tail call optimise calling list() on the last kid */
2554                     next_kid = kid;
2555                     goto do_next;
2556                 }
2557                 else if (kid->op_type == OP_LEAVEWHEN)
2558                     list(kid);
2559                 else
2560                     scalarvoid(kid);
2561                 kid = sib;
2562             }
2563             NOT_REACHED; /* NOTREACHED */
2564             break;
2565
2566         }
2567
2568         /* If next_kid is set, someone in the code above wanted us to process
2569          * that kid and all its remaining siblings.  Otherwise, work our way
2570          * back up the tree */
2571       do_next:
2572         while (!next_kid) {
2573             if (o == top_op)
2574                 return top_op; /* at top; no parents/siblings to try */
2575             if (OpHAS_SIBLING(o))
2576                 next_kid = o->op_sibparent;
2577             else {
2578                 o = o->op_sibparent; /*try parent's next sibling */
2579                 switch (o->op_type) {
2580                 case OP_SCOPE:
2581                 case OP_LINESEQ:
2582                 case OP_LIST:
2583                 case OP_LEAVE:
2584                 case OP_LEAVETRY:
2585                     /* should really restore PL_curcop to its old value, but
2586                      * setting it to PL_compiling is better than do nothing */
2587                     PL_curcop = &PL_compiling;
2588                 }
2589             }
2590
2591
2592         }
2593         o = next_kid;
2594     } /* while */
2595 }
2596
2597
2598 static OP *
2599 S_scalarseq(pTHX_ OP *o)
2600 {
2601     if (o) {
2602         const OPCODE type = o->op_type;
2603
2604         if (type == OP_LINESEQ || type == OP_SCOPE ||
2605             type == OP_LEAVE || type == OP_LEAVETRY)
2606         {
2607             OP *kid, *sib;
2608             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2609                 if ((sib = OpSIBLING(kid))
2610                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2611                     || (  sib->op_targ != OP_NEXTSTATE
2612                        && sib->op_targ != OP_DBSTATE  )))
2613                 {
2614                     scalarvoid(kid);
2615                 }
2616             }
2617             PL_curcop = &PL_compiling;
2618         }
2619         o->op_flags &= ~OPf_PARENS;
2620         if (PL_hints & HINT_BLOCK_SCOPE)
2621             o->op_flags |= OPf_PARENS;
2622     }
2623     else
2624         o = newOP(OP_STUB, 0);
2625     return o;
2626 }
2627
2628 STATIC OP *
2629 S_modkids(pTHX_ OP *o, I32 type)
2630 {
2631     if (o && o->op_flags & OPf_KIDS) {
2632         OP *kid;
2633         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2634             op_lvalue(kid, type);
2635     }
2636     return o;
2637 }
2638
2639
2640 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2641  * const fields. Also, convert CONST keys to HEK-in-SVs.
2642  * rop    is the op that retrieves the hash;
2643  * key_op is the first key
2644  * real   if false, only check (and possibly croak); don't update op
2645  */
2646
2647 STATIC void
2648 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2649 {
2650     PADNAME *lexname;
2651     GV **fields;
2652     bool check_fields;
2653
2654     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2655     if (rop) {
2656         if (rop->op_first->op_type == OP_PADSV)
2657             /* @$hash{qw(keys here)} */
2658             rop = (UNOP*)rop->op_first;
2659         else {
2660             /* @{$hash}{qw(keys here)} */
2661             if (rop->op_first->op_type == OP_SCOPE
2662                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2663                 {
2664                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2665                 }
2666             else
2667                 rop = NULL;
2668         }
2669     }
2670
2671     lexname = NULL; /* just to silence compiler warnings */
2672     fields  = NULL; /* just to silence compiler warnings */
2673
2674     check_fields =
2675             rop
2676          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2677              SvPAD_TYPED(lexname))
2678          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2679          && isGV(*fields) && GvHV(*fields);
2680
2681     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2682         SV **svp, *sv;
2683         if (key_op->op_type != OP_CONST)
2684             continue;
2685         svp = cSVOPx_svp(key_op);
2686
2687         /* make sure it's not a bareword under strict subs */
2688         if (key_op->op_private & OPpCONST_BARE &&
2689             key_op->op_private & OPpCONST_STRICT)
2690         {
2691             no_bareword_allowed((OP*)key_op);
2692         }
2693
2694         /* Make the CONST have a shared SV */
2695         if (   !SvIsCOW_shared_hash(sv = *svp)
2696             && SvTYPE(sv) < SVt_PVMG
2697             && SvOK(sv)
2698             && !SvROK(sv)
2699             && real)
2700         {
2701             SSize_t keylen;
2702             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2703             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2704             SvREFCNT_dec_NN(sv);
2705             *svp = nsv;
2706         }
2707
2708         if (   check_fields
2709             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2710         {
2711             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2712                         "in variable %" PNf " of type %" HEKf,
2713                         SVfARG(*svp), PNfARG(lexname),
2714                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2715         }
2716     }
2717 }
2718
2719 /* info returned by S_sprintf_is_multiconcatable() */
2720
2721 struct sprintf_ismc_info {
2722     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2723     char  *start;     /* start of raw format string */
2724     char  *end;       /* bytes after end of raw format string */
2725     STRLEN total_len; /* total length (in bytes) of format string, not
2726                          including '%s' and  half of '%%' */
2727     STRLEN variant;   /* number of bytes by which total_len_p would grow
2728                          if upgraded to utf8 */
2729     bool   utf8;      /* whether the format is utf8 */
2730 };
2731
2732
2733 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2734  * i.e. its format argument is a const string with only '%s' and '%%'
2735  * formats, and the number of args is known, e.g.
2736  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2737  * but not
2738  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2739  *
2740  * If successful, the sprintf_ismc_info struct pointed to by info will be
2741  * populated.
2742  */
2743
2744 STATIC bool
2745 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2746 {
2747     OP    *pm, *constop, *kid;
2748     SV    *sv;
2749     char  *s, *e, *p;
2750     SSize_t nargs, nformats;
2751     STRLEN cur, total_len, variant;
2752     bool   utf8;
2753
2754     /* if sprintf's behaviour changes, die here so that someone
2755      * can decide whether to enhance this function or skip optimising
2756      * under those new circumstances */
2757     assert(!(o->op_flags & OPf_STACKED));
2758     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2759     assert(!(o->op_private & ~OPpARG4_MASK));
2760
2761     pm = cUNOPo->op_first;
2762     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2763         return FALSE;
2764     constop = OpSIBLING(pm);
2765     if (!constop || constop->op_type != OP_CONST)
2766         return FALSE;
2767     sv = cSVOPx_sv(constop);
2768     if (SvMAGICAL(sv) || !SvPOK(sv))
2769         return FALSE;
2770
2771     s = SvPV(sv, cur);
2772     e = s + cur;
2773
2774     /* Scan format for %% and %s and work out how many %s there are.
2775      * Abandon if other format types are found.
2776      */
2777
2778     nformats  = 0;
2779     total_len = 0;
2780     variant   = 0;
2781
2782     for (p = s; p < e; p++) {
2783         if (*p != '%') {
2784             total_len++;
2785             if (!UTF8_IS_INVARIANT(*p))
2786                 variant++;
2787             continue;
2788         }
2789         p++;
2790         if (p >= e)
2791             return FALSE; /* lone % at end gives "Invalid conversion" */
2792         if (*p == '%')
2793             total_len++;
2794         else if (*p == 's')
2795             nformats++;
2796         else
2797             return FALSE;
2798     }
2799
2800     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2801         return FALSE;
2802
2803     utf8 = cBOOL(SvUTF8(sv));
2804     if (utf8)
2805         variant = 0;
2806
2807     /* scan args; they must all be in scalar cxt */
2808
2809     nargs = 0;
2810     kid = OpSIBLING(constop);
2811
2812     while (kid) {
2813         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2814             return FALSE;
2815         nargs++;
2816         kid = OpSIBLING(kid);
2817     }
2818
2819     if (nargs != nformats)
2820         return FALSE; /* e.g. sprintf("%s%s", $a); */
2821
2822
2823     info->nargs      = nargs;
2824     info->start      = s;
2825     info->end        = e;
2826     info->total_len  = total_len;
2827     info->variant    = variant;
2828     info->utf8       = utf8;
2829
2830     return TRUE;
2831 }
2832
2833
2834
2835 /* S_maybe_multiconcat():
2836  *
2837  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2838  * convert it (and its children) into an OP_MULTICONCAT. See the code
2839  * comments just before pp_multiconcat() for the full details of what
2840  * OP_MULTICONCAT supports.
2841  *
2842  * Basically we're looking for an optree with a chain of OP_CONCATS down
2843  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2844  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2845  *
2846  *      $x = "$a$b-$c"
2847  *
2848  *  looks like
2849  *
2850  *      SASSIGN
2851  *         |
2852  *      STRINGIFY   -- PADSV[$x]
2853  *         |
2854  *         |
2855  *      ex-PUSHMARK -- CONCAT/S
2856  *                        |
2857  *                     CONCAT/S  -- PADSV[$d]
2858  *                        |
2859  *                     CONCAT    -- CONST["-"]
2860  *                        |
2861  *                     PADSV[$a] -- PADSV[$b]
2862  *
2863  * Note that at this stage the OP_SASSIGN may have already been optimised
2864  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2865  */
2866
2867 STATIC void
2868 S_maybe_multiconcat(pTHX_ OP *o)
2869 {
2870     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2871     OP *topop;       /* the top-most op in the concat tree (often equals o,
2872                         unless there are assign/stringify ops above it */
2873     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2874     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2875     OP *targetop;    /* the op corresponding to target=... or target.=... */
2876     OP *stringop;    /* the OP_STRINGIFY op, if any */
2877     OP *nextop;      /* used for recreating the op_next chain without consts */
2878     OP *kid;         /* general-purpose op pointer */
2879     UNOP_AUX_item *aux;
2880     UNOP_AUX_item *lenp;
2881     char *const_str, *p;
2882     struct sprintf_ismc_info sprintf_info;
2883
2884                      /* store info about each arg in args[];
2885                       * toparg is the highest used slot; argp is a general
2886                       * pointer to args[] slots */
2887     struct {
2888         void *p;      /* initially points to const sv (or null for op);
2889                          later, set to SvPV(constsv), with ... */
2890         STRLEN len;   /* ... len set to SvPV(..., len) */
2891     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2892
2893     SSize_t nargs  = 0;
2894     SSize_t nconst = 0;
2895     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2896     STRLEN variant;
2897     bool utf8 = FALSE;
2898     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2899                                  the last-processed arg will the LHS of one,
2900                                  as args are processed in reverse order */
2901     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2902     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2903     U8 flags          = 0;   /* what will become the op_flags and ... */
2904     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2905     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2906     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2907     bool prev_was_const = FALSE; /* previous arg was a const */
2908
2909     /* -----------------------------------------------------------------
2910      * Phase 1:
2911      *
2912      * Examine the optree non-destructively to determine whether it's
2913      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2914      * information about the optree in args[].
2915      */
2916
2917     argp     = args;
2918     targmyop = NULL;
2919     targetop = NULL;
2920     stringop = NULL;
2921     topop    = o;
2922     parentop = o;
2923
2924     assert(   o->op_type == OP_SASSIGN
2925            || o->op_type == OP_CONCAT
2926            || o->op_type == OP_SPRINTF
2927            || o->op_type == OP_STRINGIFY);
2928
2929     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2930
2931     /* first see if, at the top of the tree, there is an assign,
2932      * append and/or stringify */
2933
2934     if (topop->op_type == OP_SASSIGN) {
2935         /* expr = ..... */
2936         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2937             return;
2938         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2939             return;
2940         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2941
2942         parentop = topop;
2943         topop = cBINOPo->op_first;
2944         targetop = OpSIBLING(topop);
2945         if (!targetop) /* probably some sort of syntax error */
2946             return;
2947
2948         /* don't optimise away assign in 'local $foo = ....' */
2949         if (   (targetop->op_private & OPpLVAL_INTRO)
2950             /* these are the common ops which do 'local', but
2951              * not all */
2952             && (   targetop->op_type == OP_GVSV
2953                 || targetop->op_type == OP_RV2SV
2954                 || targetop->op_type == OP_AELEM
2955                 || targetop->op_type == OP_HELEM
2956                 )
2957         )
2958             return;
2959     }
2960     else if (   topop->op_type == OP_CONCAT
2961              && (topop->op_flags & OPf_STACKED)
2962              && (!(topop->op_private & OPpCONCAT_NESTED))
2963             )
2964     {
2965         /* expr .= ..... */
2966
2967         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2968          * decide what to do about it */
2969         assert(!(o->op_private & OPpTARGET_MY));
2970
2971         /* barf on unknown flags */
2972         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2973         private_flags |= OPpMULTICONCAT_APPEND;
2974         targetop = cBINOPo->op_first;
2975         parentop = topop;
2976         topop    = OpSIBLING(targetop);
2977
2978         /* $x .= <FOO> gets optimised to rcatline instead */
2979         if (topop->op_type == OP_READLINE)
2980             return;
2981     }
2982
2983     if (targetop) {
2984         /* Can targetop (the LHS) if it's a padsv, be optimised
2985          * away and use OPpTARGET_MY instead?
2986          */
2987         if (    (targetop->op_type == OP_PADSV)
2988             && !(targetop->op_private & OPpDEREF)
2989             && !(targetop->op_private & OPpPAD_STATE)
2990                /* we don't support 'my $x .= ...' */
2991             && (   o->op_type == OP_SASSIGN
2992                 || !(targetop->op_private & OPpLVAL_INTRO))
2993         )
2994             is_targable = TRUE;
2995     }
2996
2997     if (topop->op_type == OP_STRINGIFY) {
2998         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2999             return;
3000         stringop = topop;
3001
3002         /* barf on unknown flags */
3003         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3004
3005         if ((topop->op_private & OPpTARGET_MY)) {
3006             if (o->op_type == OP_SASSIGN)
3007                 return; /* can't have two assigns */
3008             targmyop = topop;
3009         }
3010
3011         private_flags |= OPpMULTICONCAT_STRINGIFY;
3012         parentop = topop;
3013         topop = cBINOPx(topop)->op_first;
3014         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3015         topop = OpSIBLING(topop);
3016     }
3017
3018     if (topop->op_type == OP_SPRINTF) {
3019         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3020             return;
3021         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3022             nargs     = sprintf_info.nargs;
3023             total_len = sprintf_info.total_len;
3024             variant   = sprintf_info.variant;
3025             utf8      = sprintf_info.utf8;
3026             is_sprintf = TRUE;
3027             private_flags |= OPpMULTICONCAT_FAKE;
3028             toparg = argp;
3029             /* we have an sprintf op rather than a concat optree.
3030              * Skip most of the code below which is associated with
3031              * processing that optree. We also skip phase 2, determining
3032              * whether its cost effective to optimise, since for sprintf,
3033              * multiconcat is *always* faster */
3034             goto create_aux;
3035         }
3036         /* note that even if the sprintf itself isn't multiconcatable,
3037          * the expression as a whole may be, e.g. in
3038          *    $x .= sprintf("%d",...)
3039          * the sprintf op will be left as-is, but the concat/S op may
3040          * be upgraded to multiconcat
3041          */
3042     }
3043     else if (topop->op_type == OP_CONCAT) {
3044         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3045             return;
3046
3047         if ((topop->op_private & OPpTARGET_MY)) {
3048             if (o->op_type == OP_SASSIGN || targmyop)
3049                 return; /* can't have two assigns */
3050             targmyop = topop;
3051         }
3052     }
3053
3054     /* Is it safe to convert a sassign/stringify/concat op into
3055      * a multiconcat? */
3056     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
3057     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
3058     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3059     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
3060     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
3061                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
3062     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
3063                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
3064
3065     /* Now scan the down the tree looking for a series of
3066      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3067      * stacked). For example this tree:
3068      *
3069      *     |
3070      *   CONCAT/STACKED
3071      *     |
3072      *   CONCAT/STACKED -- EXPR5
3073      *     |
3074      *   CONCAT/STACKED -- EXPR4
3075      *     |
3076      *   CONCAT -- EXPR3
3077      *     |
3078      *   EXPR1  -- EXPR2
3079      *
3080      * corresponds to an expression like
3081      *
3082      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3083      *
3084      * Record info about each EXPR in args[]: in particular, whether it is
3085      * a stringifiable OP_CONST and if so what the const sv is.
3086      *
3087      * The reason why the last concat can't be STACKED is the difference
3088      * between
3089      *
3090      *    ((($a .= $a) .= $a) .= $a) .= $a
3091      *
3092      * and
3093      *    $a . $a . $a . $a . $a
3094      *
3095      * The main difference between the optrees for those two constructs
3096      * is the presence of the last STACKED. As well as modifying $a,
3097      * the former sees the changed $a between each concat, so if $s is
3098      * initially 'a', the first returns 'a' x 16, while the latter returns
3099      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3100      */
3101
3102     kid = topop;
3103
3104     for (;;) {
3105         OP *argop;
3106         SV *sv;
3107         bool last = FALSE;
3108
3109         if (    kid->op_type == OP_CONCAT
3110             && !kid_is_last
3111         ) {
3112             OP *k1, *k2;
3113             k1 = cUNOPx(kid)->op_first;
3114             k2 = OpSIBLING(k1);
3115             /* shouldn't happen except maybe after compile err? */
3116             if (!k2)
3117                 return;
3118
3119             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
3120             if (kid->op_private & OPpTARGET_MY)
3121                 kid_is_last = TRUE;
3122
3123             stacked_last = (kid->op_flags & OPf_STACKED);
3124             if (!stacked_last)
3125                 kid_is_last = TRUE;
3126
3127             kid   = k1;
3128             argop = k2;
3129         }
3130         else {
3131             argop = kid;
3132             last = TRUE;
3133         }
3134
3135         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
3136             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3137         {
3138             /* At least two spare slots are needed to decompose both
3139              * concat args. If there are no slots left, continue to
3140              * examine the rest of the optree, but don't push new values
3141              * on args[]. If the optree as a whole is legal for conversion
3142              * (in particular that the last concat isn't STACKED), then
3143              * the first PERL_MULTICONCAT_MAXARG elements of the optree
3144              * can be converted into an OP_MULTICONCAT now, with the first
3145              * child of that op being the remainder of the optree -
3146              * which may itself later be converted to a multiconcat op
3147              * too.
3148              */
3149             if (last) {
3150                 /* the last arg is the rest of the optree */
3151                 argp++->p = NULL;
3152                 nargs++;
3153             }
3154         }
3155         else if (   argop->op_type == OP_CONST
3156             && ((sv = cSVOPx_sv(argop)))
3157             /* defer stringification until runtime of 'constant'
3158              * things that might stringify variantly, e.g. the radix
3159              * point of NVs, or overloaded RVs */
3160             && (SvPOK(sv) || SvIOK(sv))
3161             && (!SvGMAGICAL(sv))
3162         ) {
3163             if (argop->op_private & OPpCONST_STRICT)
3164                 no_bareword_allowed(argop);
3165             argp++->p = sv;
3166             utf8   |= cBOOL(SvUTF8(sv));
3167             nconst++;
3168             if (prev_was_const)
3169                 /* this const may be demoted back to a plain arg later;
3170                  * make sure we have enough arg slots left */
3171                 nadjconst++;
3172             prev_was_const = !prev_was_const;
3173         }
3174         else {
3175             argp++->p = NULL;
3176             nargs++;
3177             prev_was_const = FALSE;
3178         }
3179
3180         if (last)
3181             break;
3182     }
3183
3184     toparg = argp - 1;
3185
3186     if (stacked_last)
3187         return; /* we don't support ((A.=B).=C)...) */
3188
3189     /* look for two adjacent consts and don't fold them together:
3190      *     $o . "a" . "b"
3191      * should do
3192      *     $o->concat("a")->concat("b")
3193      * rather than
3194      *     $o->concat("ab")
3195      * (but $o .=  "a" . "b" should still fold)
3196      */
3197     {
3198         bool seen_nonconst = FALSE;
3199         for (argp = toparg; argp >= args; argp--) {
3200             if (argp->p == NULL) {
3201                 seen_nonconst = TRUE;
3202                 continue;
3203             }
3204             if (!seen_nonconst)
3205                 continue;
3206             if (argp[1].p) {
3207                 /* both previous and current arg were constants;
3208                  * leave the current OP_CONST as-is */
3209                 argp->p = NULL;
3210                 nconst--;
3211                 nargs++;
3212             }
3213         }
3214     }
3215
3216     /* -----------------------------------------------------------------
3217      * Phase 2:
3218      *
3219      * At this point we have determined that the optree *can* be converted
3220      * into a multiconcat. Having gathered all the evidence, we now decide
3221      * whether it *should*.
3222      */
3223
3224
3225     /* we need at least one concat action, e.g.:
3226      *
3227      *  Y . Z
3228      *  X = Y . Z
3229      *  X .= Y
3230      *
3231      * otherwise we could be doing something like $x = "foo", which
3232      * if treated as a concat, would fail to COW.
3233      */
3234     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3235         return;
3236
3237     /* Benchmarking seems to indicate that we gain if:
3238      * * we optimise at least two actions into a single multiconcat
3239      *    (e.g concat+concat, sassign+concat);
3240      * * or if we can eliminate at least 1 OP_CONST;
3241      * * or if we can eliminate a padsv via OPpTARGET_MY
3242      */
3243
3244     if (
3245            /* eliminated at least one OP_CONST */
3246            nconst >= 1
3247            /* eliminated an OP_SASSIGN */
3248         || o->op_type == OP_SASSIGN
3249            /* eliminated an OP_PADSV */
3250         || (!targmyop && is_targable)
3251     )
3252         /* definitely a net gain to optimise */
3253         goto optimise;
3254
3255     /* ... if not, what else? */
3256
3257     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3258      * multiconcat is faster (due to not creating a temporary copy of
3259      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3260      * faster.
3261      */
3262     if (   nconst == 0
3263          && nargs == 2
3264          && targmyop
3265          && topop->op_type == OP_CONCAT
3266     ) {
3267         PADOFFSET t = targmyop->op_targ;
3268         OP *k1 = cBINOPx(topop)->op_first;
3269         OP *k2 = cBINOPx(topop)->op_last;
3270         if (   k2->op_type == OP_PADSV
3271             && k2->op_targ == t
3272             && (   k1->op_type != OP_PADSV
3273                 || k1->op_targ != t)
3274         )
3275             goto optimise;
3276     }
3277
3278     /* need at least two concats */
3279     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3280         return;
3281
3282
3283
3284     /* -----------------------------------------------------------------
3285      * Phase 3:
3286      *
3287      * At this point the optree has been verified as ok to be optimised
3288      * into an OP_MULTICONCAT. Now start changing things.
3289      */
3290
3291    optimise:
3292
3293     /* stringify all const args and determine utf8ness */
3294
3295     variant = 0;
3296     for (argp = args; argp <= toparg; argp++) {
3297         SV *sv = (SV*)argp->p;
3298         if (!sv)
3299             continue; /* not a const op */
3300         if (utf8 && !SvUTF8(sv))
3301             sv_utf8_upgrade_nomg(sv);
3302         argp->p = SvPV_nomg(sv, argp->len);
3303         total_len += argp->len;
3304
3305         /* see if any strings would grow if converted to utf8 */
3306         if (!utf8) {
3307             variant += variant_under_utf8_count((U8 *) argp->p,
3308                                                 (U8 *) argp->p + argp->len);
3309         }
3310     }
3311
3312     /* create and populate aux struct */
3313
3314   create_aux:
3315
3316     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3317                     sizeof(UNOP_AUX_item)
3318                     *  (
3319                            PERL_MULTICONCAT_HEADER_SIZE
3320                          + ((nargs + 1) * (variant ? 2 : 1))
3321                         )
3322                     );
3323     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3324
3325     /* Extract all the non-const expressions from the concat tree then
3326      * dispose of the old tree, e.g. convert the tree from this:
3327      *
3328      *  o => SASSIGN
3329      *         |
3330      *       STRINGIFY   -- TARGET
3331      *         |
3332      *       ex-PUSHMARK -- CONCAT
3333      *                        |
3334      *                      CONCAT -- EXPR5
3335      *                        |
3336      *                      CONCAT -- EXPR4
3337      *                        |
3338      *                      CONCAT -- EXPR3
3339      *                        |
3340      *                      EXPR1  -- EXPR2
3341      *
3342      *
3343      * to:
3344      *
3345      *  o => MULTICONCAT
3346      *         |
3347      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3348      *
3349      * except that if EXPRi is an OP_CONST, it's discarded.
3350      *
3351      * During the conversion process, EXPR ops are stripped from the tree
3352      * and unshifted onto o. Finally, any of o's remaining original
3353      * childen are discarded and o is converted into an OP_MULTICONCAT.
3354      *
3355      * In this middle of this, o may contain both: unshifted args on the
3356      * left, and some remaining original args on the right. lastkidop
3357      * is set to point to the right-most unshifted arg to delineate
3358      * between the two sets.
3359      */
3360
3361
3362     if (is_sprintf) {
3363         /* create a copy of the format with the %'s removed, and record
3364          * the sizes of the const string segments in the aux struct */
3365         char *q, *oldq;
3366         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3367
3368         p    = sprintf_info.start;
3369         q    = const_str;
3370         oldq = q;
3371         for (; p < sprintf_info.end; p++) {
3372             if (*p == '%') {
3373                 p++;
3374                 if (*p != '%') {
3375                     (lenp++)->ssize = q - oldq;
3376                     oldq = q;
3377                     continue;
3378                 }
3379             }
3380             *q++ = *p;
3381         }
3382         lenp->ssize = q - oldq;
3383         assert((STRLEN)(q - const_str) == total_len);
3384
3385         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3386          * may or may not be topop) The pushmark and const ops need to be
3387          * kept in case they're an op_next entry point.
3388          */
3389         lastkidop = cLISTOPx(topop)->op_last;
3390         kid = cUNOPx(topop)->op_first; /* pushmark */
3391         op_null(kid);
3392         op_null(OpSIBLING(kid));       /* const */
3393         if (o != topop) {
3394             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3395             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3396             lastkidop->op_next = o;
3397         }
3398     }
3399     else {
3400         p = const_str;
3401         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3402
3403         lenp->ssize = -1;
3404
3405         /* Concatenate all const strings into const_str.
3406          * Note that args[] contains the RHS args in reverse order, so
3407          * we scan args[] from top to bottom to get constant strings
3408          * in L-R order
3409          */
3410         for (argp = toparg; argp >= args; argp--) {
3411             if (!argp->p)
3412                 /* not a const op */
3413                 (++lenp)->ssize = -1;
3414             else {
3415                 STRLEN l = argp->len;
3416                 Copy(argp->p, p, l, char);
3417                 p += l;
3418                 if (lenp->ssize == -1)
3419                     lenp->ssize = l;
3420                 else
3421                     lenp->ssize += l;
3422             }
3423         }
3424
3425         kid = topop;
3426         nextop = o;
3427         lastkidop = NULL;
3428
3429         for (argp = args; argp <= toparg; argp++) {
3430             /* only keep non-const args, except keep the first-in-next-chain
3431              * arg no matter what it is (but nulled if OP_CONST), because it
3432              * may be the entry point to this subtree from the previous
3433              * op_next.
3434              */
3435             bool last = (argp == toparg);
3436             OP *prev;
3437
3438             /* set prev to the sibling *before* the arg to be cut out,
3439              * e.g. when cutting EXPR:
3440              *
3441              *         |
3442              * kid=  CONCAT
3443              *         |
3444              * prev= CONCAT -- EXPR
3445              *         |
3446              */
3447             if (argp == args && kid->op_type != OP_CONCAT) {
3448                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3449                  * so the expression to be cut isn't kid->op_last but
3450                  * kid itself */
3451                 OP *o1, *o2;
3452                 /* find the op before kid */
3453                 o1 = NULL;
3454                 o2 = cUNOPx(parentop)->op_first;
3455                 while (o2 && o2 != kid) {
3456                     o1 = o2;
3457                     o2 = OpSIBLING(o2);
3458                 }
3459                 assert(o2 == kid);
3460                 prev = o1;
3461                 kid  = parentop;
3462             }
3463             else if (kid == o && lastkidop)
3464                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3465             else
3466                 prev = last ? NULL : cUNOPx(kid)->op_first;
3467
3468             if (!argp->p || last) {
3469                 /* cut RH op */
3470                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3471                 /* and unshift to front of o */
3472                 op_sibling_splice(o, NULL, 0, aop);
3473                 /* record the right-most op added to o: later we will
3474                  * free anything to the right of it */
3475                 if (!lastkidop)
3476                     lastkidop = aop;
3477                 aop->op_next = nextop;
3478                 if (last) {
3479                     if (argp->p)
3480                         /* null the const at start of op_next chain */
3481                         op_null(aop);
3482                 }
3483                 else if (prev)
3484                     nextop = prev->op_next;
3485             }
3486
3487             /* the last two arguments are both attached to the same concat op */
3488             if (argp < toparg - 1)
3489                 kid = prev;
3490         }
3491     }
3492
3493     /* Populate the aux struct */
3494
3495     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3496     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3497     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3498     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3499     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3500
3501     /* if variant > 0, calculate a variant const string and lengths where
3502      * the utf8 version of the string will take 'variant' more bytes than
3503      * the plain one. */
3504
3505     if (variant) {
3506         char              *p = const_str;
3507         STRLEN          ulen = total_len + variant;
3508         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3509         UNOP_AUX_item *ulens = lens + (nargs + 1);
3510         char             *up = (char*)PerlMemShared_malloc(ulen);
3511         SSize_t            n;
3512
3513         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3514         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3515
3516         for (n = 0; n < (nargs + 1); n++) {
3517             SSize_t i;
3518             char * orig_up = up;
3519             for (i = (lens++)->ssize; i > 0; i--) {
3520                 U8 c = *p++;
3521                 append_utf8_from_native_byte(c, (U8**)&up);
3522             }
3523             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3524         }
3525     }
3526
3527     if (stringop) {
3528         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3529          * that op's first child - an ex-PUSHMARK - because the op_next of
3530          * the previous op may point to it (i.e. it's the entry point for
3531          * the o optree)
3532          */
3533         OP *pmop =
3534             (stringop == o)
3535                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3536                 : op_sibling_splice(stringop, NULL, 1, NULL);
3537         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3538         op_sibling_splice(o, NULL, 0, pmop);
3539         if (!lastkidop)
3540             lastkidop = pmop;
3541     }
3542
3543     /* Optimise
3544      *    target  = A.B.C...
3545      *    target .= A.B.C...
3546      */
3547
3548     if (targetop) {
3549         assert(!targmyop);
3550
3551         if (o->op_type == OP_SASSIGN) {
3552             /* Move the target subtree from being the last of o's children
3553              * to being the last of o's preserved children.
3554              * Note the difference between 'target = ...' and 'target .= ...':
3555              * for the former, target is executed last; for the latter,
3556              * first.
3557              */
3558             kid = OpSIBLING(lastkidop);
3559             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3560             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3561             lastkidop->op_next = kid->op_next;
3562             lastkidop = targetop;
3563         }
3564         else {
3565             /* Move the target subtree from being the first of o's
3566              * original children to being the first of *all* o's children.
3567              */
3568             if (lastkidop) {
3569                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3570                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3571             }
3572             else {
3573                 /* if the RHS of .= doesn't contain a concat (e.g.
3574                  * $x .= "foo"), it gets missed by the "strip ops from the
3575                  * tree and add to o" loop earlier */
3576                 assert(topop->op_type != OP_CONCAT);
3577                 if (stringop) {
3578                     /* in e.g. $x .= "$y", move the $y expression
3579                      * from being a child of OP_STRINGIFY to being the
3580                      * second child of the OP_CONCAT
3581                      */
3582                     assert(cUNOPx(stringop)->op_first == topop);
3583                     op_sibling_splice(stringop, NULL, 1, NULL);
3584                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3585                 }
3586                 assert(topop == OpSIBLING(cBINOPo->op_first));
3587                 if (toparg->p)
3588                     op_null(topop);
3589                 lastkidop = topop;
3590             }
3591         }
3592
3593         if (is_targable) {
3594             /* optimise
3595              *  my $lex  = A.B.C...
3596              *     $lex  = A.B.C...
3597              *     $lex .= A.B.C...
3598              * The original padsv op is kept but nulled in case it's the
3599              * entry point for the optree (which it will be for
3600              * '$lex .=  ... '
3601              */
3602             private_flags |= OPpTARGET_MY;
3603             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3604             o->op_targ = targetop->op_targ;
3605             targetop->op_targ = 0;
3606             op_null(targetop);
3607         }
3608         else
3609             flags |= OPf_STACKED;
3610     }
3611     else if (targmyop) {
3612         private_flags |= OPpTARGET_MY;
3613         if (o != targmyop) {
3614             o->op_targ = targmyop->op_targ;
3615             targmyop->op_targ = 0;
3616         }
3617     }
3618
3619     /* detach the emaciated husk of the sprintf/concat optree and free it */
3620     for (;;) {
3621         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3622         if (!kid)
3623             break;
3624         op_free(kid);
3625     }
3626
3627     /* and convert o into a multiconcat */
3628
3629     o->op_flags        = (flags|OPf_KIDS|stacked_last
3630                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3631     o->op_private      = private_flags;
3632     o->op_type         = OP_MULTICONCAT;
3633     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3634     cUNOP_AUXo->op_aux = aux;
3635 }
3636
3637
3638 /* do all the final processing on an optree (e.g. running the peephole
3639  * optimiser on it), then attach it to cv (if cv is non-null)
3640  */
3641
3642 static void
3643 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3644 {
3645     OP **startp;
3646
3647     /* XXX for some reason, evals, require and main optrees are
3648      * never attached to their CV; instead they just hang off
3649      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3650      * and get manually freed when appropriate */
3651     if (cv)
3652         startp = &CvSTART(cv);
3653     else
3654         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3655
3656     *startp = start;
3657     optree->op_private |= OPpREFCOUNTED;
3658     OpREFCNT_set(optree, 1);
3659     optimize_optree(optree);
3660     CALL_PEEP(*startp);
3661     finalize_optree(optree);
3662     S_prune_chain_head(startp);
3663
3664     if (cv) {
3665         /* now that optimizer has done its work, adjust pad values */
3666         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3667                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3668     }
3669 }
3670
3671
3672 /*
3673 =for apidoc optimize_optree
3674
3675 This function applies some optimisations to the optree in top-down order.
3676 It is called before the peephole optimizer, which processes ops in
3677 execution order. Note that finalize_optree() also does a top-down scan,
3678 but is called *after* the peephole optimizer.
3679
3680 =cut
3681 */
3682
3683 void
3684 Perl_optimize_optree(pTHX_ OP* o)
3685 {
3686     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3687
3688     ENTER;
3689     SAVEVPTR(PL_curcop);
3690
3691     optimize_op(o);
3692
3693     LEAVE;
3694 }
3695
3696
3697 /* helper for optimize_optree() which optimises one op then recurses
3698  * to optimise any children.
3699  */
3700
3701 STATIC void
3702 S_optimize_op(pTHX_ OP* o)
3703 {
3704     OP *top_op = o;
3705
3706     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3707
3708     while (1) {
3709         OP * next_kid = NULL;
3710
3711         assert(o->op_type != OP_FREED);
3712
3713         switch (o->op_type) {
3714         case OP_NEXTSTATE:
3715         case OP_DBSTATE:
3716             PL_curcop = ((COP*)o);              /* for warnings */
3717             break;
3718
3719
3720         case OP_CONCAT:
3721         case OP_SASSIGN:
3722         case OP_STRINGIFY:
3723         case OP_SPRINTF:
3724             S_maybe_multiconcat(aTHX_ o);
3725             break;
3726
3727         case OP_SUBST:
3728             if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3729                 /* we can't assume that op_pmreplroot->op_sibparent == o
3730                  * and that it is thus possible to walk back up the tree
3731                  * past op_pmreplroot. So, although we try to avoid
3732                  * recursing through op trees, do it here. After all,
3733                  * there are unlikely to be many nested s///e's within
3734                  * the replacement part of a s///e.
3735                  */
3736                 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3737             }
3738             break;
3739
3740         default:
3741             break;
3742         }
3743
3744         if (o->op_flags & OPf_KIDS)
3745             next_kid = cUNOPo->op_first;
3746
3747         /* if a kid hasn't been nominated to process, continue with the
3748          * next sibling, or if no siblings left, go back to the parent's
3749          * siblings and so on
3750          */
3751         while (!next_kid) {
3752             if (o == top_op)
3753                 return; /* at top; no parents/siblings to try */
3754             if (OpHAS_SIBLING(o))
3755                 next_kid = o->op_sibparent;
3756             else
3757                 o = o->op_sibparent; /*try parent's next sibling */
3758         }
3759
3760       /* this label not yet used. Goto here if any code above sets
3761        * next-kid
3762        get_next_op:
3763        */
3764         o = next_kid;
3765     }
3766 }
3767
3768
3769 /*
3770 =for apidoc finalize_optree
3771
3772 This function finalizes the optree.  Should be called directly after
3773 the complete optree is built.  It does some additional
3774 checking which can't be done in the normal C<ck_>xxx functions and makes
3775 the tree thread-safe.
3776
3777 =cut
3778 */
3779 void
3780 Perl_finalize_optree(pTHX_ OP* o)
3781 {
3782     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3783
3784     ENTER;
3785     SAVEVPTR(PL_curcop);
3786
3787     finalize_op(o);
3788
3789     LEAVE;
3790 }
3791
3792 #ifdef USE_ITHREADS
3793 /* Relocate sv to the pad for thread safety.
3794  * Despite being a "constant", the SV is written to,
3795  * for reference counts, sv_upgrade() etc. */
3796 PERL_STATIC_INLINE void
3797 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3798 {
3799     PADOFFSET ix;
3800     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3801     if (!*svp) return;
3802     ix = pad_alloc(OP_CONST, SVf_READONLY);
3803     SvREFCNT_dec(PAD_SVl(ix));
3804     PAD_SETSV(ix, *svp);
3805     /* XXX I don't know how this isn't readonly already. */
3806     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3807     *svp = NULL;
3808     *targp = ix;
3809 }
3810 #endif
3811
3812 /*
3813 =for apidoc traverse_op_tree
3814
3815 Return the next op in a depth-first traversal of the op tree,
3816 returning NULL when the traversal is complete.
3817
3818 The initial call must supply the root of the tree as both top and o.
3819
3820 For now it's static, but it may be exposed to the API in the future.
3821
3822 =cut
3823 */
3824
3825 STATIC OP*
3826 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3827     OP *sib;
3828
3829     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3830
3831     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3832         return cUNOPo->op_first;
3833     }
3834     else if ((sib = OpSIBLING(o))) {
3835         return sib;
3836     }
3837     else {
3838         OP *parent = o->op_sibparent;
3839         assert(!(o->op_moresib));
3840         while (parent && parent != top) {
3841             OP *sib = OpSIBLING(parent);
3842             if (sib)
3843                 return sib;
3844             parent = parent->op_sibparent;
3845         }
3846
3847         return NULL;
3848     }
3849 }
3850
3851 STATIC void
3852 S_finalize_op(pTHX_ OP* o)
3853 {
3854     OP * const top = o;
3855     PERL_ARGS_ASSERT_FINALIZE_OP;
3856
3857     do {
3858         assert(o->op_type != OP_FREED);
3859
3860         switch (o->op_type) {
3861         case OP_NEXTSTATE:
3862         case OP_DBSTATE:
3863             PL_curcop = ((COP*)o);              /* for warnings */
3864             break;
3865         case OP_EXEC:
3866             if (OpHAS_SIBLING(o)) {
3867                 OP *sib = OpSIBLING(o);
3868                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3869                     && ckWARN(WARN_EXEC)
3870                     && OpHAS_SIBLING(sib))
3871                 {
3872                     const OPCODE type = OpSIBLING(sib)->op_type;
3873                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3874                         const line_t oldline = CopLINE(PL_curcop);
3875                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3876                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3877                             "Statement unlikely to be reached");
3878                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3879                             "\t(Maybe you meant system() when you said exec()?)\n");
3880                         CopLINE_set(PL_curcop, oldline);
3881                     }
3882                 }
3883             }
3884             break;
3885
3886         case OP_GV:
3887             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3888                 GV * const gv = cGVOPo_gv;
3889                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3890                     /* XXX could check prototype here instead of just carping */
3891                     SV * const sv = sv_newmortal();
3892                     gv_efullname3(sv, gv, NULL);
3893                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3894                                 "%" SVf "() called too early to check prototype",
3895                                 SVfARG(sv));
3896                 }
3897             }
3898             break;
3899
3900         case OP_CONST:
3901             if (cSVOPo->op_private & OPpCONST_STRICT)
3902                 no_bareword_allowed(o);
3903 #ifdef USE_ITHREADS
3904             /* FALLTHROUGH */
3905         case OP_HINTSEVAL:
3906             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3907 #endif
3908             break;
3909
3910 #ifdef USE_ITHREADS
3911             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3912         case OP_METHOD_NAMED:
3913         case OP_METHOD_SUPER:
3914         case OP_METHOD_REDIR:
3915         case OP_METHOD_REDIR_SUPER:
3916             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3917             break;
3918 #endif
3919
3920         case OP_HELEM: {
3921             UNOP *rop;
3922             SVOP *key_op;
3923             OP *kid;
3924
3925             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3926                 break;
3927
3928             rop = (UNOP*)((BINOP*)o)->op_first;
3929
3930             goto check_keys;
3931
3932             case OP_HSLICE:
3933                 S_scalar_slice_warning(aTHX_ o);
3934                 /* FALLTHROUGH */
3935
3936             case OP_KVHSLICE:
3937                 kid = OpSIBLING(cLISTOPo->op_first);
3938             if (/* I bet there's always a pushmark... */
3939                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3940                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3941             {
3942                 break;
3943             }
3944
3945             key_op = (SVOP*)(kid->op_type == OP_CONST
3946                              ? kid
3947                              : OpSIBLING(kLISTOP->op_first));
3948
3949             rop = (UNOP*)((LISTOP*)o)->op_last;
3950
3951         check_keys:
3952             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3953                 rop = NULL;
3954             S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3955             break;
3956         }
3957         case OP_NULL:
3958             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3959                 break;
3960             /* FALLTHROUGH */
3961         case OP_ASLICE:
3962             S_scalar_slice_warning(aTHX_ o);
3963             break;
3964
3965         case OP_SUBST: {
3966             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3967                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3968             break;
3969         }
3970         default:
3971             break;
3972         }
3973
3974 #ifdef DEBUGGING
3975         if (o->op_flags & OPf_KIDS) {
3976             OP *kid;
3977
3978             /* check that op_last points to the last sibling, and that
3979              * the last op_sibling/op_sibparent field points back to the
3980              * parent, and that the only ops with KIDS are those which are
3981              * entitled to them */
3982             U32 type = o->op_type;
3983             U32 family;
3984             bool has_last;
3985
3986             if (type == OP_NULL) {
3987                 type = o->op_targ;
3988                 /* ck_glob creates a null UNOP with ex-type GLOB
3989                  * (which is a list op. So pretend it wasn't a listop */
3990                 if (type == OP_GLOB)
3991                     type = OP_NULL;
3992             }
3993             family = PL_opargs[type] & OA_CLASS_MASK;
3994
3995             has_last = (   family == OA_BINOP
3996                         || family == OA_LISTOP
3997                         || family == OA_PMOP
3998                         || family == OA_LOOP
3999                        );
4000             assert(  has_last /* has op_first and op_last, or ...
4001                   ... has (or may have) op_first: */
4002                   || family == OA_UNOP
4003                   || family == OA_UNOP_AUX
4004                   || family == OA_LOGOP
4005                   || family == OA_BASEOP_OR_UNOP
4006                   || family == OA_FILESTATOP
4007                   || family == OA_LOOPEXOP
4008                   || family == OA_METHOP
4009                   || type == OP_CUSTOM
4010                   || type == OP_NULL /* new_logop does this */
4011                   );
4012
4013             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4014                 if (!OpHAS_SIBLING(kid)) {
4015                     if (has_last)
4016                         assert(kid == cLISTOPo->op_last);
4017                     assert(kid->op_sibparent == o);
4018                 }
4019             }
4020         }
4021 #endif
4022     } while (( o = traverse_op_tree(top, o)) != NULL);
4023 }
4024
4025 static void
4026 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4027 {
4028     CV *cv = PL_compcv;
4029     PadnameLVALUE_on(pn);
4030     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4031         cv = CvOUTSIDE(cv);
4032         /* RT #127786: cv can be NULL due to an eval within the DB package
4033          * called from an anon sub - anon subs don't have CvOUTSIDE() set
4034          * unless they contain an eval, but calling eval within DB
4035          * pretends the eval was done in the caller's scope.
4036          */
4037         if (!cv)
4038             break;
4039         assert(CvPADLIST(cv));
4040         pn =
4041            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4042         assert(PadnameLEN(pn));
4043         PadnameLVALUE_on(pn);
4044     }
4045 }
4046
4047 static bool
4048 S_vivifies(const OPCODE type)
4049 {
4050     switch(type) {
4051     case OP_RV2AV:     case   OP_ASLICE:
4052     case OP_RV2HV:     case OP_KVASLICE:
4053     case OP_RV2SV:     case   OP_HSLICE:
4054     case OP_AELEMFAST: case OP_KVHSLICE:
4055     case OP_HELEM:
4056     case OP_AELEM:
4057         return 1;
4058     }
4059     return 0;
4060 }
4061
4062
4063 /* apply lvalue reference (aliasing) context to the optree o.
4064  * E.g. in
4065  *     \($x,$y) = (...)
4066  * o would be the list ($x,$y) and type would be OP_AASSIGN.
4067  * It may descend and apply this to children too, for example in
4068  * \( $cond ? $x, $y) = (...)
4069  */
4070
4071 static void
4072 S_lvref(pTHX_ OP *o, I32 type)
4073 {
4074     OP *kid;
4075     OP * top_op = o;
4076
4077     while (1) {
4078         switch (o->op_type) {
4079         case OP_COND_EXPR:
4080             o = OpSIBLING(cUNOPo->op_first);
4081             continue;
4082
4083         case OP_PUSHMARK:
4084             goto do_next;
4085
4086         case OP_RV2AV:
4087             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4088             o->op_flags |= OPf_STACKED;
4089             if (o->op_flags & OPf_PARENS) {
4090                 if (o->op_private & OPpLVAL_INTRO) {
4091                      yyerror(Perl_form(aTHX_ "Can't modify reference to "
4092                           "localized parenthesized array in list assignment"));
4093                     goto do_next;
4094                 }
4095               slurpy:
4096                 OpTYPE_set(o, OP_LVAVREF);
4097                 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4098                 o->op_flags |= OPf_MOD|OPf_REF;
4099                 goto do_next;
4100             }
4101             o->op_private |= OPpLVREF_AV;
4102             goto checkgv;
4103
4104         case OP_RV2CV:
4105             kid = cUNOPo->op_first;
4106             if (kid->op_type == OP_NULL)
4107                 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4108                     ->op_first;
4109             o->op_private = OPpLVREF_CV;
4110             if (kid->op_type == OP_GV)
4111                 o->op_flags |= OPf_STACKED;
4112             else if (kid->op_type == OP_PADCV) {
4113                 o->op_targ = kid->op_targ;
4114                 kid->op_targ = 0;
4115                 op_free(cUNOPo->op_first);
4116                 cUNOPo->op_first = NULL;
4117                 o->op_flags &=~ OPf_KIDS;
4118             }
4119             else goto badref;
4120             break;
4121
4122         case OP_RV2HV:
4123             if (o->op_flags & OPf_PARENS) {
4124               parenhash:
4125                 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4126                                      "parenthesized hash in list assignment"));
4127                     goto do_next;
4128             }
4129             o->op_private |= OPpLVREF_HV;
4130             /* FALLTHROUGH */
4131         case OP_RV2SV:
4132           checkgv:
4133             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4134             o->op_flags |= OPf_STACKED;
4135             break;
4136
4137         case OP_PADHV:
4138             if (o->op_flags & OPf_PARENS) goto parenhash;
4139             o->op_private |= OPpLVREF_HV;
4140             /* FALLTHROUGH */
4141         case OP_PADSV:
4142             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4143             break;
4144
4145         case OP_PADAV:
4146             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4147             if (o->op_flags & OPf_PARENS) goto slurpy;
4148             o->op_private |= OPpLVREF_AV;
4149             break;
4150
4151         case OP_AELEM:
4152         case OP_HELEM:
4153             o->op_private |= OPpLVREF_ELEM;
4154             o->op_flags   |= OPf_STACKED;
4155             break;
4156
4157         case OP_ASLICE:
4158         case OP_HSLICE:
4159             OpTYPE_set(o, OP_LVREFSLICE);
4160             o->op_private &= OPpLVAL_INTRO;
4161             goto do_next;
4162
4163         case OP_NULL:
4164             if (o->op_flags & OPf_SPECIAL)              /* do BLOCK */
4165                 goto badref;
4166             else if (!(o->op_flags & OPf_KIDS))
4167                 goto do_next;
4168
4169             /* the code formerly only recursed into the first child of
4170              * a non ex-list OP_NULL. if we ever encounter such a null op with
4171              * more than one child, need to decide whether its ok to process
4172              * *all* its kids or not */
4173             assert(o->op_targ == OP_LIST
4174                     || !(OpHAS_SIBLING(cBINOPo->op_first)));
4175             /* FALLTHROUGH */
4176         case OP_LIST:
4177             o = cLISTOPo->op_first;
4178             continue;
4179
4180         case OP_STUB:
4181             if (o->op_flags & OPf_PARENS)
4182                 goto do_next;
4183             /* FALLTHROUGH */
4184         default:
4185           badref:
4186             /* diag_listed_as: Can't modify reference to %s in %s assignment */
4187             yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4188                          o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4189                           ? "do block"
4190                           : OP_DESC(o),
4191                          PL_op_desc[type]));
4192             goto do_next;
4193         }
4194
4195         OpTYPE_set(o, OP_LVREF);
4196         o->op_private &=
4197             OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4198         if (type == OP_ENTERLOOP)
4199             o->op_private |= OPpLVREF_ITER;
4200
4201       do_next:
4202         while (1) {
4203             if (o == top_op)
4204                 return; /* at top; no parents/siblings to try */
4205             if (OpHAS_SIBLING(o)) {
4206                 o = o->op_sibparent;
4207                 break;
4208             }
4209             o = o->op_sibparent; /*try parent's next sibling */
4210         }
4211     } /* while */
4212 }
4213
4214
4215 PERL_STATIC_INLINE bool
4216 S_potential_mod_type(I32 type)
4217 {
4218     /* Types that only potentially result in modification.  */
4219     return type == OP_GREPSTART || type == OP_ENTERSUB
4220         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
4221 }
4222
4223
4224 /*
4225 =for apidoc op_lvalue
4226
4227 Propagate lvalue ("modifiable") context to an op and its children.
4228 C<type> represents the context type, roughly based on the type of op that
4229 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4230 because it has no op type of its own (it is signalled by a flag on
4231 the lvalue op).
4232
4233 This function detects things that can't be modified, such as C<$x+1>, and
4234 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
4235 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4236
4237 It also flags things that need to behave specially in an lvalue context,
4238 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4239
4240 =cut
4241
4242 Perl_op_lvalue_flags() is a non-API lower-level interface to
4243 op_lvalue().  The flags param has these bits:
4244     OP_LVALUE_NO_CROAK:  return rather than croaking on error
4245
4246 */
4247
4248 OP *
4249 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4250 {
4251     OP *top_op = o;
4252
4253     if (!o || (PL_parser && PL_parser->error_count))
4254         return o;
4255
4256     while (1) {
4257     OP *kid;
4258     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4259     int localize = -1;
4260     OP *next_kid = NULL;
4261
4262     if ((o->op_private & OPpTARGET_MY)
4263         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4264     {
4265         goto do_next;
4266     }
4267
4268     /* elements of a list might be in void context because the list is
4269        in scalar context or because they are attribute sub calls */
4270     if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4271         goto do_next;
4272
4273     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4274
4275     switch (o->op_type) {
4276     case OP_UNDEF:
4277         PL_modcount++;
4278         goto do_next;
4279
4280     case OP_STUB:
4281         if ((o->op_flags & OPf_PARENS))
4282             break;
4283         goto nomod;
4284
4285     case OP_ENTERSUB:
4286         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4287             !(o->op_flags & OPf_STACKED)) {
4288             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
4289             assert(cUNOPo->op_first->op_type == OP_NULL);
4290             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4291             break;
4292         }
4293         else {                          /* lvalue subroutine call */
4294             o->op_private |= OPpLVAL_INTRO;
4295             PL_modcount = RETURN_UNLIMITED_NUMBER;
4296             if (S_potential_mod_type(type)) {
4297                 o->op_private |= OPpENTERSUB_INARGS;
4298                 break;
4299             }
4300             else {                      /* Compile-time error message: */
4301                 OP *kid = cUNOPo->op_first;
4302                 CV *cv;
4303                 GV *gv;
4304                 SV *namesv;
4305
4306                 if (kid->op_type != OP_PUSHMARK) {
4307                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4308                         Perl_croak(aTHX_
4309                                 "panic: unexpected lvalue entersub "
4310                                 "args: type/targ %ld:%" UVuf,
4311                                 (long)kid->op_type, (UV)kid->op_targ);
4312                     kid = kLISTOP->op_first;
4313                 }
4314                 while (OpHAS_SIBLING(kid))
4315                     kid = OpSIBLING(kid);
4316                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4317                     break;      /* Postpone until runtime */
4318                 }
4319
4320                 kid = kUNOP->op_first;
4321                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4322                     kid = kUNOP->op_first;
4323                 if (kid->op_type == OP_NULL)
4324                     Perl_croak(aTHX_
4325                                "Unexpected constant lvalue entersub "
4326                                "entry via type/targ %ld:%" UVuf,
4327                                (long)kid->op_type, (UV)kid->op_targ);
4328                 if (kid->op_type != OP_GV) {
4329                     break;
4330                 }
4331
4332                 gv = kGVOP_gv;
4333                 cv = isGV(gv)
4334                     ? GvCV(gv)
4335                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4336                         ? MUTABLE_CV(SvRV(gv))
4337                         : NULL;
4338                 if (!cv)
4339                     break;
4340                 if (CvLVALUE(cv))
4341                     break;
4342                 if (flags & OP_LVALUE_NO_CROAK)
4343                     return NULL;
4344
4345                 namesv = cv_name(cv, NULL, 0);
4346                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4347                                      "subroutine call of &%" SVf " in %s",
4348                                      SVfARG(namesv), PL_op_desc[type]),
4349                            SvUTF8(namesv));
4350                 goto do_next;
4351             }
4352         }
4353         /* FALLTHROUGH */
4354     default:
4355       nomod:
4356         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4357         /* grep, foreach, subcalls, refgen */
4358         if (S_potential_mod_type(type))
4359             break;
4360         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4361                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4362                       ? "do block"
4363                       : OP_DESC(o)),
4364                      type ? PL_op_desc[type] : "local"));
4365         goto do_next;
4366
4367     case OP_PREINC:
4368     case OP_PREDEC:
4369     case OP_POW:
4370     case OP_MULTIPLY:
4371     case OP_DIVIDE:
4372     case OP_MODULO:
4373     case OP_ADD:
4374     case OP_SUBTRACT:
4375     case OP_CONCAT:
4376     case OP_LEFT_SHIFT:
4377     case OP_RIGHT_SHIFT:
4378     case OP_BIT_AND:
4379     case OP_BIT_XOR:
4380     case OP_BIT_OR:
4381     case OP_I_MULTIPLY:
4382     case OP_I_DIVIDE:
4383     case OP_I_MODULO:
4384     case OP_I_ADD:
4385     case OP_I_SUBTRACT:
4386         if (!(o->op_flags & OPf_STACKED))
4387             goto nomod;
4388         PL_modcount++;
4389         break;
4390
4391     case OP_REPEAT:
4392         if (o->op_flags & OPf_STACKED) {
4393             PL_modcount++;
4394             break;
4395         }
4396         if (!(o->op_private & OPpREPEAT_DOLIST))
4397             goto nomod;
4398         else {
4399             const I32 mods = PL_modcount;
4400             /* we recurse rather than iterate here because we need to
4401              * calculate and use the delta applied to PL_modcount by the
4402              * first child. So in something like
4403              *     ($x, ($y) x 3) = split;
4404              * split knows that 4 elements are wanted
4405              */
4406             modkids(cBINOPo->op_first, type);
4407             if (type != OP_AASSIGN)
4408                 goto nomod;
4409             kid = cBINOPo->op_last;
4410             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4411                 const IV iv = SvIV(kSVOP_sv);
4412                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4413                     PL_modcount =
4414                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4415             }
4416             else
4417                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4418         }
4419         break;
4420
4421     case OP_COND_EXPR:
4422         localize = 1;
4423         next_kid = OpSIBLING(cUNOPo->op_first);
4424         break;
4425
4426     case OP_RV2AV:
4427     case OP_RV2HV:
4428         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4429            PL_modcount = RETURN_UNLIMITED_NUMBER;
4430            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4431               fiable since some contexts need to know.  */
4432            o->op_flags |= OPf_MOD;
4433            goto do_next;
4434         }
4435         /* FALLTHROUGH */
4436     case OP_RV2GV:
4437         if (scalar_mod_type(o, type))
4438             goto nomod;
4439         ref(cUNOPo->op_first, o->op_type);
4440         /* FALLTHROUGH */
4441     case OP_ASLICE:
4442     case OP_HSLICE:
4443         localize = 1;
4444         /* FALLTHROUGH */
4445     case OP_AASSIGN:
4446         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4447         if (type == OP_LEAVESUBLV && (
4448                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4449              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4450            ))
4451             o->op_private |= OPpMAYBE_LVSUB;
4452         /* FALLTHROUGH */
4453     case OP_NEXTSTATE:
4454     case OP_DBSTATE:
4455        PL_modcount = RETURN_UNLIMITED_NUMBER;
4456         break;
4457
4458     case OP_KVHSLICE:
4459     case OP_KVASLICE:
4460     case OP_AKEYS:
4461         if (type == OP_LEAVESUBLV)
4462             o->op_private |= OPpMAYBE_LVSUB;
4463         goto nomod;
4464
4465     case OP_AVHVSWITCH:
4466         if (type == OP_LEAVESUBLV
4467          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4468             o->op_private |= OPpMAYBE_LVSUB;
4469         goto nomod;
4470
4471     case OP_AV2ARYLEN:
4472         PL_hints |= HINT_BLOCK_SCOPE;
4473         if (type == OP_LEAVESUBLV)
4474             o->op_private |= OPpMAYBE_LVSUB;
4475         PL_modcount++;
4476         break;
4477
4478     case OP_RV2SV:
4479         ref(cUNOPo->op_first, o->op_type);
4480         localize = 1;
4481         /* FALLTHROUGH */
4482     case OP_GV:
4483         PL_hints |= HINT_BLOCK_SCOPE;
4484         /* FALLTHROUGH */
4485     case OP_SASSIGN:
4486     case OP_ANDASSIGN:
4487     case OP_ORASSIGN:
4488     case OP_DORASSIGN:
4489         PL_modcount++;
4490         break;
4491
4492     case OP_AELEMFAST:
4493     case OP_AELEMFAST_LEX:
4494         localize = -1;
4495         PL_modcount++;
4496         break;
4497
4498     case OP_PADAV:
4499     case OP_PADHV:
4500        PL_modcount = RETURN_UNLIMITED_NUMBER;
4501         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4502         {
4503            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4504               fiable since some contexts need to know.  */
4505             o->op_flags |= OPf_MOD;
4506             goto do_next;
4507         }
4508         if (scalar_mod_type(o, type))
4509             goto nomod;
4510         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4511           && type == OP_LEAVESUBLV)
4512             o->op_private |= OPpMAYBE_LVSUB;
4513         /* FALLTHROUGH */
4514     case OP_PADSV:
4515         PL_modcount++;
4516         if (!type) /* local() */
4517             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4518                               PNfARG(PAD_COMPNAME(o->op_targ)));
4519         if (!(o->op_private & OPpLVAL_INTRO)
4520          || (  type != OP_SASSIGN && type != OP_AASSIGN
4521             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4522             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4523         break;
4524
4525     case OP_PUSHMARK:
4526         localize = 0;
4527         break;
4528
4529     case OP_KEYS:
4530         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4531             goto nomod;
4532         goto lvalue_func;
4533     case OP_SUBSTR:
4534         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4535             goto nomod;
4536         /* FALLTHROUGH */
4537     case OP_POS:
4538     case OP_VEC:
4539       lvalue_func:
4540         if (type == OP_LEAVESUBLV)
4541             o->op_private |= OPpMAYBE_LVSUB;
4542         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4543             /* we recurse rather than iterate here because the child
4544              * needs to be processed with a different 'type' parameter */
4545
4546             /* substr and vec */
4547             /* If this op is in merely potential (non-fatal) modifiable
4548                context, then apply OP_ENTERSUB context to
4549                the kid op (to avoid croaking).  Other-
4550                wise pass this op’s own type so the correct op is mentioned
4551                in error messages.  */
4552             op_lvalue(OpSIBLING(cBINOPo->op_first),
4553                       S_potential_mod_type(type)
4554                         ? (I32)OP_ENTERSUB
4555                         : o->op_type);
4556         }
4557         break;
4558
4559     case OP_AELEM:
4560     case OP_HELEM:
4561         ref(cBINOPo->op_first, o->op_type);
4562         if (type == OP_ENTERSUB &&
4563              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4564             o->op_private |= OPpLVAL_DEFER;
4565         if (type == OP_LEAVESUBLV)
4566             o->op_private |= OPpMAYBE_LVSUB;
4567         localize = 1;
4568         PL_modcount++;
4569         break;
4570
4571     case OP_LEAVE:
4572     case OP_LEAVELOOP:
4573         o->op_private |= OPpLVALUE;
4574         /* FALLTHROUGH */
4575     case OP_SCOPE:
4576     case OP_ENTER:
4577     case OP_LINESEQ:
4578         localize = 0;
4579         if (o->op_flags & OPf_KIDS)
4580             next_kid = cLISTOPo->op_last;
4581         break;
4582
4583     case OP_NULL:
4584         localize = 0;
4585         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4586             goto nomod;
4587         else if (!(o->op_flags & OPf_KIDS))
4588             break;
4589
4590         if (o->op_targ != OP_LIST) {
4591             OP *sib = OpSIBLING(cLISTOPo->op_first);
4592             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4593              * that looks like
4594              *
4595              *   null
4596              *      arg
4597              *      trans
4598              *
4599              * compared with things like OP_MATCH which have the argument
4600              * as a child:
4601              *
4602              *   match
4603              *      arg
4604              *
4605              * so handle specially to correctly get "Can't modify" croaks etc
4606              */
4607
4608             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4609             {
4610                 /* this should trigger a "Can't modify transliteration" err */
4611                 op_lvalue(sib, type);
4612             }
4613             next_kid = cBINOPo->op_first;
4614             /* we assume OP_NULLs which aren't ex-list have no more than 2
4615              * children. If this assumption is wrong, increase the scan
4616              * limit below */
4617             assert(   !OpHAS_SIBLING(next_kid)
4618                    || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4619             break;
4620         }
4621         /* FALLTHROUGH */
4622     case OP_LIST:
4623         localize = 0;
4624         next_kid = cLISTOPo->op_first;
4625         break;
4626
4627     case OP_COREARGS:
4628         goto do_next;
4629
4630     case OP_AND:
4631     case OP_OR:
4632         if (type == OP_LEAVESUBLV
4633          || !S_vivifies(cLOGOPo->op_first->op_type))
4634             next_kid = cLOGOPo->op_first;
4635         else if (type == OP_LEAVESUBLV
4636          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4637             next_kid = OpSIBLING(cLOGOPo->op_first);
4638         goto nomod;
4639
4640     case OP_SREFGEN:
4641         if (type == OP_NULL) { /* local */
4642           local_refgen:
4643             if (!FEATURE_MYREF_IS_ENABLED)
4644                 Perl_croak(aTHX_ "The experimental declared_refs "
4645                                  "feature is not enabled");
4646             Perl_ck_warner_d(aTHX_
4647                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4648                     "Declaring references is experimental");
4649             next_kid = cUNOPo->op_first;
4650             goto do_next;
4651         }
4652         if (type != OP_AASSIGN && type != OP_SASSIGN
4653          && type != OP_ENTERLOOP)
4654             goto nomod;
4655         /* Don’t bother applying lvalue context to the ex-list.  */
4656         kid = cUNOPx(cUNOPo->op_first)->op_first;
4657         assert (!OpHAS_SIBLING(kid));
4658         goto kid_2lvref;
4659     case OP_REFGEN:
4660         if (type == OP_NULL) /* local */
4661             goto local_refgen;
4662         if (type != OP_AASSIGN) goto nomod;
4663         kid = cUNOPo->op_first;
4664       kid_2lvref:
4665         {
4666             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4667             S_lvref(aTHX_ kid, type);
4668             if (!PL_parser || PL_parser->error_count == ec) {
4669                 if (!FEATURE_REFALIASING_IS_ENABLED)
4670                     Perl_croak(aTHX_
4671                        "Experimental aliasing via reference not enabled");
4672                 Perl_ck_warner_d(aTHX_
4673                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4674                                 "Aliasing via reference is experimental");
4675             }
4676         }
4677         if (o->op_type == OP_REFGEN)
4678             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4679         op_null(o);
4680         goto do_next;
46