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