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