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