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