op.c

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