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