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