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