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