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