op.c

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