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