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