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