peep.c

   1 /*    peep.c
   2  *
   3  *    Copyright (C) 1991-2022 by Larry Wall and others
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * Aragorn sped on up the hill. Every now and again he bent to the ground.
  12  * Hobbits go light, and their footprints are not easy even for a Ranger to
  13  * read, but not far from the top a spring crossed the path, and in the wet
  14  * earth he saw what he was seeking.
  15  * 'I read the signs aright,' he said to himself. 'Frodo ran to the hill-top.
  16  * I wonder what he saw there? But he returned by the same way, and went down
  17  * the hill again.'
  18  */
  19
  20 #include "EXTERN.h"
  21 #define PERL_IN_PEEP_C
  22 #include "perl.h"
  23
  24
  25 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
  26
  27
  28 static void
  29 S_scalar_slice_warning(pTHX_ const OP *o)
  30 {
  31     OP *kid;
  32     const bool is_hash = o->op_type == OP_HSLICE
  33                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
  34     SV *name;
  35
  36     if (!(o->op_private & OPpSLICEWARNING))
  37         return;
  38     if (PL_parser && PL_parser->error_count)
  39         /* This warning can be nonsensical when there is a syntax error. */
  40         return;
  41
  42     kid = cLISTOPo->op_first;
  43     kid = OpSIBLING(kid); /* get past pushmark */
  44     /* weed out false positives: any ops that can return lists */
  45     switch (kid->op_type) {
  46     case OP_BACKTICK:
  47     case OP_GLOB:
  48     case OP_READLINE:
  49     case OP_MATCH:
  50     case OP_RV2AV:
  51     case OP_EACH:
  52     case OP_VALUES:
  53     case OP_KEYS:
  54     case OP_SPLIT:
  55     case OP_LIST:
  56     case OP_SORT:
  57     case OP_REVERSE:
  58     case OP_ENTERSUB:
  59     case OP_CALLER:
  60     case OP_LSTAT:
  61     case OP_STAT:
  62     case OP_READDIR:
  63     case OP_SYSTEM:
  64     case OP_TMS:
  65     case OP_LOCALTIME:
  66     case OP_GMTIME:
  67     case OP_ENTEREVAL:
  68         return;
  69     }
  70
  71     /* Don't warn if we have a nulled list either. */
  72     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
  73         return;
  74
  75     assert(OpSIBLING(kid));
  76     name = op_varname(OpSIBLING(kid));
  77     if (!name) /* XS module fiddling with the op tree */
  78         return;
  79     warn_elem_scalar_context(kid, name, is_hash, true);
  80 }
  81
  82
  83 /* info returned by S_sprintf_is_multiconcatable() */
  84
  85 struct sprintf_ismc_info {
  86     SSize_t nargs;    /* num of args to sprintf (not including the format) */
  87     char  *start;     /* start of raw format string */
  88     char  *end;       /* bytes after end of raw format string */
  89     STRLEN total_len; /* total length (in bytes) of format string, not
  90                          including '%s' and  half of '%%' */
  91     STRLEN variant;   /* number of bytes by which total_len_p would grow
  92                          if upgraded to utf8 */
  93     bool   utf8;      /* whether the format is utf8 */
  94 };
  95
  96 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
  97  * i.e. its format argument is a const string with only '%s' and '%%'
  98  * formats, and the number of args is known, e.g.
  99  *    sprintf "a=%s f=%s", $a[0], scalar(f());
 100  * but not
 101  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
 102  *
 103  * If successful, the sprintf_ismc_info struct pointed to by info will be
 104  * populated.
 105  */
 106
 107 STATIC bool
 108 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
 109 {
 110     OP    *pm, *constop, *kid;
 111     SV    *sv;
 112     char  *s, *e, *p;
 113     SSize_t nargs, nformats;
 114     STRLEN cur, total_len, variant;
 115     bool   utf8;
 116
 117     /* if sprintf's behaviour changes, die here so that someone
 118      * can decide whether to enhance this function or skip optimising
 119      * under those new circumstances */
 120     assert(!(o->op_flags & OPf_STACKED));
 121     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
 122     assert(!(o->op_private & ~OPpARG4_MASK));
 123
 124     pm = cUNOPo->op_first;
 125     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
 126         return FALSE;
 127     constop = OpSIBLING(pm);
 128     if (!constop || constop->op_type != OP_CONST)
 129         return FALSE;
 130     sv = cSVOPx_sv(constop);
 131     if (SvMAGICAL(sv) || !SvPOK(sv))
 132         return FALSE;
 133
 134     s = SvPV(sv, cur);
 135     e = s + cur;
 136
 137     /* Scan format for %% and %s and work out how many %s there are.
 138      * Abandon if other format types are found.
 139      */
 140
 141     nformats  = 0;
 142     total_len = 0;
 143     variant   = 0;
 144
 145     for (p = s; p < e; p++) {
 146         if (*p != '%') {
 147             total_len++;
 148             if (!UTF8_IS_INVARIANT(*p))
 149                 variant++;
 150             continue;
 151         }
 152         p++;
 153         if (p >= e)
 154             return FALSE; /* lone % at end gives "Invalid conversion" */
 155         if (*p == '%')
 156             total_len++;
 157         else if (*p == 's')
 158             nformats++;
 159         else
 160             return FALSE;
 161     }
 162
 163     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
 164         return FALSE;
 165
 166     utf8 = cBOOL(SvUTF8(sv));
 167     if (utf8)
 168         variant = 0;
 169
 170     /* scan args; they must all be in scalar cxt */
 171
 172     nargs = 0;
 173     kid = OpSIBLING(constop);
 174
 175     while (kid) {
 176         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
 177             return FALSE;
 178         nargs++;
 179         kid = OpSIBLING(kid);
 180     }
 181
 182     if (nargs != nformats)
 183         return FALSE; /* e.g. sprintf("%s%s", $a); */
 184
 185
 186     info->nargs      = nargs;
 187     info->start      = s;
 188     info->end        = e;
 189     info->total_len  = total_len;
 190     info->variant    = variant;
 191     info->utf8       = utf8;
 192
 193     return TRUE;
 194 }
 195
 196 /* S_maybe_multiconcat():
 197  *
 198  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
 199  * convert it (and its children) into an OP_MULTICONCAT. See the code
 200  * comments just before pp_multiconcat() for the full details of what
 201  * OP_MULTICONCAT supports.
 202  *
 203  * Basically we're looking for an optree with a chain of OP_CONCATS down
 204  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
 205  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
 206  *
 207  *      $x = "$a$b-$c"
 208  *
 209  *  looks like
 210  *
 211  *      SASSIGN
 212  *         |
 213  *      STRINGIFY   -- PADSV[$x]
 214  *         |
 215  *         |
 216  *      ex-PUSHMARK -- CONCAT/S
 217  *                        |
 218  *                     CONCAT/S  -- PADSV[$d]
 219  *                        |
 220  *                     CONCAT    -- CONST["-"]
 221  *                        |
 222  *                     PADSV[$a] -- PADSV[$b]
 223  *
 224  * Note that at this stage the OP_SASSIGN may have already been optimised
 225  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
 226  */
 227
 228 STATIC void
 229 S_maybe_multiconcat(pTHX_ OP *o)
 230 {
 231     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
 232     OP *topop;       /* the top-most op in the concat tree (often equals o,
 233                         unless there are assign/stringify ops above it */
 234     OP *parentop;    /* the parent op of topop (or itself if no parent) */
 235     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
 236     OP *targetop;    /* the op corresponding to target=... or target.=... */
 237     OP *stringop;    /* the OP_STRINGIFY op, if any */
 238     OP *nextop;      /* used for recreating the op_next chain without consts */
 239     OP *kid;         /* general-purpose op pointer */
 240     UNOP_AUX_item *aux;
 241     UNOP_AUX_item *lenp;
 242     char *const_str, *p;
 243     struct sprintf_ismc_info sprintf_info;
 244
 245                      /* store info about each arg in args[];
 246                       * toparg is the highest used slot; argp is a general
 247                       * pointer to args[] slots */
 248     struct {
 249         void *p;      /* initially points to const sv (or null for op);
 250                          later, set to SvPV(constsv), with ... */
 251         STRLEN len;   /* ... len set to SvPV(..., len) */
 252     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
 253
 254     SSize_t nargs  = 0;
 255     SSize_t nconst = 0;
 256     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
 257     STRLEN variant;
 258     bool utf8 = FALSE;
 259     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
 260                                  the last-processed arg will the LHS of one,
 261                                  as args are processed in reverse order */
 262     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
 263     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
 264     U8 flags          = 0;   /* what will become the op_flags and ... */
 265     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
 266     bool is_sprintf = FALSE; /* we're optimising an sprintf */
 267     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
 268     bool prev_was_const = FALSE; /* previous arg was a const */
 269
 270     /* -----------------------------------------------------------------
 271      * Phase 1:
 272      *
 273      * Examine the optree non-destructively to determine whether it's
 274      * suitable to be converted into an OP_MULTICONCAT. Accumulate
 275      * information about the optree in args[].
 276      */
 277
 278     argp     = args;
 279     targmyop = NULL;
 280     targetop = NULL;
 281     stringop = NULL;
 282     topop    = o;
 283     parentop = o;
 284
 285     assert(   o->op_type == OP_SASSIGN
 286            || o->op_type == OP_CONCAT
 287            || o->op_type == OP_SPRINTF
 288            || o->op_type == OP_STRINGIFY);
 289
 290     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
 291
 292     /* first see if, at the top of the tree, there is an assign,
 293      * append and/or stringify */
 294
 295     if (topop->op_type == OP_SASSIGN) {
 296         /* expr = ..... */
 297         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
 298             return;
 299         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
 300             return;
 301         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
 302
 303         parentop = topop;
 304         topop = cBINOPo->op_first;
 305         targetop = OpSIBLING(topop);
 306         if (!targetop) /* probably some sort of syntax error */
 307             return;
 308
 309         /* don't optimise away assign in 'local $foo = ....' */
 310         if (   (targetop->op_private & OPpLVAL_INTRO)
 311             /* these are the common ops which do 'local', but
 312              * not all */
 313             && (   targetop->op_type == OP_GVSV
 314                 || targetop->op_type == OP_RV2SV
 315                 || targetop->op_type == OP_AELEM
 316                 || targetop->op_type == OP_HELEM
 317                 )
 318         )
 319             return;
 320     }
 321     else if (   topop->op_type == OP_CONCAT
 322              && (topop->op_flags & OPf_STACKED)
 323              && (!(topop->op_private & OPpCONCAT_NESTED))
 324             )
 325     {
 326         /* expr .= ..... */
 327
 328         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
 329          * decide what to do about it */
 330         assert(!(o->op_private & OPpTARGET_MY));
 331
 332         /* barf on unknown flags */
 333         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
 334         private_flags |= OPpMULTICONCAT_APPEND;
 335         targetop = cBINOPo->op_first;
 336         parentop = topop;
 337         topop    = OpSIBLING(targetop);
 338
 339         /* $x .= <FOO> gets optimised to rcatline instead */
 340         if (topop->op_type == OP_READLINE)
 341             return;
 342     }
 343
 344     if (targetop) {
 345         /* Can targetop (the LHS) if it's a padsv, be optimised
 346          * away and use OPpTARGET_MY instead?
 347          */
 348         if (    (targetop->op_type == OP_PADSV)
 349             && !(targetop->op_private & OPpDEREF)
 350             && !(targetop->op_private & OPpPAD_STATE)
 351                /* we don't support 'my $x .= ...' */
 352             && (   o->op_type == OP_SASSIGN
 353                 || !(targetop->op_private & OPpLVAL_INTRO))
 354         )
 355             is_targable = TRUE;
 356     }
 357
 358     if (topop->op_type == OP_STRINGIFY) {
 359         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
 360             return;
 361         stringop = topop;
 362
 363         /* barf on unknown flags */
 364         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
 365
 366         if ((topop->op_private & OPpTARGET_MY)) {
 367             if (o->op_type == OP_SASSIGN)
 368                 return; /* can't have two assigns */
 369             targmyop = topop;
 370         }
 371
 372         private_flags |= OPpMULTICONCAT_STRINGIFY;
 373         parentop = topop;
 374         topop = cBINOPx(topop)->op_first;
 375         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
 376         topop = OpSIBLING(topop);
 377     }
 378
 379     if (topop->op_type == OP_SPRINTF) {
 380         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
 381             return;
 382         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
 383             nargs     = sprintf_info.nargs;
 384             total_len = sprintf_info.total_len;
 385             variant   = sprintf_info.variant;
 386             utf8      = sprintf_info.utf8;
 387             is_sprintf = TRUE;
 388             private_flags |= OPpMULTICONCAT_FAKE;
 389             toparg = argp;
 390             /* we have an sprintf op rather than a concat optree.
 391              * Skip most of the code below which is associated with
 392              * processing that optree. We also skip phase 2, determining
 393              * whether its cost effective to optimise, since for sprintf,
 394              * multiconcat is *always* faster */
 395             goto create_aux;
 396         }
 397         /* note that even if the sprintf itself isn't multiconcatable,
 398          * the expression as a whole may be, e.g. in
 399          *    $x .= sprintf("%d",...)
 400          * the sprintf op will be left as-is, but the concat/S op may
 401          * be upgraded to multiconcat
 402          */
 403     }
 404     else if (topop->op_type == OP_CONCAT) {
 405         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
 406             return;
 407
 408         if ((topop->op_private & OPpTARGET_MY)) {
 409             if (o->op_type == OP_SASSIGN || targmyop)
 410                 return; /* can't have two assigns */
 411             targmyop = topop;
 412         }
 413     }
 414
 415     /* Is it safe to convert a sassign/stringify/concat op into
 416      * a multiconcat? */
 417     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
 418     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
 419     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
 420     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
 421     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
 422                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
 423     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
 424                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
 425
 426     /* Now scan the down the tree looking for a series of
 427      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
 428      * stacked). For example this tree:
 429      *
 430      *     |
 431      *   CONCAT/STACKED
 432      *     |
 433      *   CONCAT/STACKED -- EXPR5
 434      *     |
 435      *   CONCAT/STACKED -- EXPR4
 436      *     |
 437      *   CONCAT -- EXPR3
 438      *     |
 439      *   EXPR1  -- EXPR2
 440      *
 441      * corresponds to an expression like
 442      *
 443      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
 444      *
 445      * Record info about each EXPR in args[]: in particular, whether it is
 446      * a stringifiable OP_CONST and if so what the const sv is.
 447      *
 448      * The reason why the last concat can't be STACKED is the difference
 449      * between
 450      *
 451      *    ((($a .= $a) .= $a) .= $a) .= $a
 452      *
 453      * and
 454      *    $a . $a . $a . $a . $a
 455      *
 456      * The main difference between the optrees for those two constructs
 457      * is the presence of the last STACKED. As well as modifying $a,
 458      * the former sees the changed $a between each concat, so if $s is
 459      * initially 'a', the first returns 'a' x 16, while the latter returns
 460      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
 461      */
 462
 463     kid = topop;
 464
 465     for (;;) {
 466         OP *argop;
 467         SV *sv;
 468         bool last = FALSE;
 469
 470         if (    kid->op_type == OP_CONCAT
 471             && !kid_is_last
 472         ) {
 473             OP *k1, *k2;
 474             k1 = cUNOPx(kid)->op_first;
 475             k2 = OpSIBLING(k1);
 476             /* shouldn't happen except maybe after compile err? */
 477             if (!k2)
 478                 return;
 479
 480             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
 481             if (kid->op_private & OPpTARGET_MY)
 482                 kid_is_last = TRUE;
 483
 484             stacked_last = (kid->op_flags & OPf_STACKED);
 485             if (!stacked_last)
 486                 kid_is_last = TRUE;
 487
 488             kid   = k1;
 489             argop = k2;
 490         }
 491         else {
 492             argop = kid;
 493             last = TRUE;
 494         }
 495
 496         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
 497             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
 498         {
 499             /* At least two spare slots are needed to decompose both
 500              * concat args. If there are no slots left, continue to
 501              * examine the rest of the optree, but don't push new values
 502              * on args[]. If the optree as a whole is legal for conversion
 503              * (in particular that the last concat isn't STACKED), then
 504              * the first PERL_MULTICONCAT_MAXARG elements of the optree
 505              * can be converted into an OP_MULTICONCAT now, with the first
 506              * child of that op being the remainder of the optree -
 507              * which may itself later be converted to a multiconcat op
 508              * too.
 509              */
 510             if (last) {
 511                 /* the last arg is the rest of the optree */
 512                 argp++->p = NULL;
 513                 nargs++;
 514             }
 515         }
 516         else if (   argop->op_type == OP_CONST
 517             && ((sv = cSVOPx_sv(argop)))
 518             /* defer stringification until runtime of 'constant'
 519              * things that might stringify variantly, e.g. the radix
 520              * point of NVs, or overloaded RVs */
 521             && (SvPOK(sv) || SvIOK(sv))
 522             && (!SvGMAGICAL(sv))
 523         ) {
 524             if (argop->op_private & OPpCONST_STRICT)
 525                 no_bareword_allowed(argop);
 526             argp++->p = sv;
 527             utf8   |= cBOOL(SvUTF8(sv));
 528             nconst++;
 529             if (prev_was_const)
 530                 /* this const may be demoted back to a plain arg later;
 531                  * make sure we have enough arg slots left */
 532                 nadjconst++;
 533             prev_was_const = !prev_was_const;
 534         }
 535         else {
 536             argp++->p = NULL;
 537             nargs++;
 538             prev_was_const = FALSE;
 539         }
 540
 541         if (last)
 542             break;
 543     }
 544
 545     toparg = argp - 1;
 546
 547     if (stacked_last)
 548         return; /* we don't support ((A.=B).=C)...) */
 549
 550     /* look for two adjacent consts and don't fold them together:
 551      *     $o . "a" . "b"
 552      * should do
 553      *     $o->concat("a")->concat("b")
 554      * rather than
 555      *     $o->concat("ab")
 556      * (but $o .=  "a" . "b" should still fold)
 557      */
 558     {
 559         bool seen_nonconst = FALSE;
 560         for (argp = toparg; argp >= args; argp--) {
 561             if (argp->p == NULL) {
 562                 seen_nonconst = TRUE;
 563                 continue;
 564             }
 565             if (!seen_nonconst)
 566                 continue;
 567             if (argp[1].p) {
 568                 /* both previous and current arg were constants;
 569                  * leave the current OP_CONST as-is */
 570                 argp->p = NULL;
 571                 nconst--;
 572                 nargs++;
 573             }
 574         }
 575     }
 576
 577     /* -----------------------------------------------------------------
 578      * Phase 2:
 579      *
 580      * At this point we have determined that the optree *can* be converted
 581      * into a multiconcat. Having gathered all the evidence, we now decide
 582      * whether it *should*.
 583      */
 584
 585
 586     /* we need at least one concat action, e.g.:
 587      *
 588      *  Y . Z
 589      *  X = Y . Z
 590      *  X .= Y
 591      *
 592      * otherwise we could be doing something like $x = "foo", which
 593      * if treated as a concat, would fail to COW.
 594      */
 595     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
 596         return;
 597
 598     /* Benchmarking seems to indicate that we gain if:
 599      * * we optimise at least two actions into a single multiconcat
 600      *    (e.g concat+concat, sassign+concat);
 601      * * or if we can eliminate at least 1 OP_CONST;
 602      * * or if we can eliminate a padsv via OPpTARGET_MY
 603      */
 604
 605     if (
 606            /* eliminated at least one OP_CONST */
 607            nconst >= 1
 608            /* eliminated an OP_SASSIGN */
 609         || o->op_type == OP_SASSIGN
 610            /* eliminated an OP_PADSV */
 611         || (!targmyop && is_targable)
 612     )
 613         /* definitely a net gain to optimise */
 614         goto optimise;
 615
 616     /* ... if not, what else? */
 617
 618     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
 619      * multiconcat is faster (due to not creating a temporary copy of
 620      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
 621      * faster.
 622      */
 623     if (   nconst == 0
 624          && nargs == 2
 625          && targmyop
 626          && topop->op_type == OP_CONCAT
 627     ) {
 628         PADOFFSET t = targmyop->op_targ;
 629         OP *k1 = cBINOPx(topop)->op_first;
 630         OP *k2 = cBINOPx(topop)->op_last;
 631         if (   k2->op_type == OP_PADSV
 632             && k2->op_targ == t
 633             && (   k1->op_type != OP_PADSV
 634                 || k1->op_targ != t)
 635         )
 636             goto optimise;
 637     }
 638
 639     /* need at least two concats */
 640     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
 641         return;
 642
 643
 644
 645     /* -----------------------------------------------------------------
 646      * Phase 3:
 647      *
 648      * At this point the optree has been verified as ok to be optimised
 649      * into an OP_MULTICONCAT. Now start changing things.
 650      */
 651
 652    optimise:
 653
 654     /* stringify all const args and determine utf8ness */
 655
 656     variant = 0;
 657     for (argp = args; argp <= toparg; argp++) {
 658         SV *sv = (SV*)argp->p;
 659         if (!sv)
 660             continue; /* not a const op */
 661         if (utf8 && !SvUTF8(sv))
 662             sv_utf8_upgrade_nomg(sv);
 663         argp->p = SvPV_nomg(sv, argp->len);
 664         total_len += argp->len;
 665
 666         /* see if any strings would grow if converted to utf8 */
 667         if (!utf8) {
 668             variant += variant_under_utf8_count((U8 *) argp->p,
 669                                                 (U8 *) argp->p + argp->len);
 670         }
 671     }
 672
 673     /* create and populate aux struct */
 674
 675   create_aux:
 676
 677     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
 678                     sizeof(UNOP_AUX_item)
 679                     *  (
 680                            PERL_MULTICONCAT_HEADER_SIZE
 681                          + ((nargs + 1) * (variant ? 2 : 1))
 682                         )
 683                     );
 684     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
 685
 686     /* Extract all the non-const expressions from the concat tree then
 687      * dispose of the old tree, e.g. convert the tree from this:
 688      *
 689      *  o => SASSIGN
 690      *         |
 691      *       STRINGIFY   -- TARGET
 692      *         |
 693      *       ex-PUSHMARK -- CONCAT
 694      *                        |
 695      *                      CONCAT -- EXPR5
 696      *                        |
 697      *                      CONCAT -- EXPR4
 698      *                        |
 699      *                      CONCAT -- EXPR3
 700      *                        |
 701      *                      EXPR1  -- EXPR2
 702      *
 703      *
 704      * to:
 705      *
 706      *  o => MULTICONCAT
 707      *         |
 708      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
 709      *
 710      * except that if EXPRi is an OP_CONST, it's discarded.
 711      *
 712      * During the conversion process, EXPR ops are stripped from the tree
 713      * and unshifted onto o. Finally, any of o's remaining original
 714      * childen are discarded and o is converted into an OP_MULTICONCAT.
 715      *
 716      * In this middle of this, o may contain both: unshifted args on the
 717      * left, and some remaining original args on the right. lastkidop
 718      * is set to point to the right-most unshifted arg to delineate
 719      * between the two sets.
 720      */
 721
 722
 723     if (is_sprintf) {
 724         /* create a copy of the format with the %'s removed, and record
 725          * the sizes of the const string segments in the aux struct */
 726         char *q, *oldq;
 727         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
 728
 729         p    = sprintf_info.start;
 730         q    = const_str;
 731         oldq = q;
 732         for (; p < sprintf_info.end; p++) {
 733             if (*p == '%') {
 734                 p++;
 735                 if (*p != '%') {
 736                     (lenp++)->ssize = q - oldq;
 737                     oldq = q;
 738                     continue;
 739                 }
 740             }
 741             *q++ = *p;
 742         }
 743         lenp->ssize = q - oldq;
 744         assert((STRLEN)(q - const_str) == total_len);
 745
 746         /* Attach all the args (i.e. the kids of the sprintf) to o (which
 747          * may or may not be topop) The pushmark and const ops need to be
 748          * kept in case they're an op_next entry point.
 749          */
 750         lastkidop = cLISTOPx(topop)->op_last;
 751         kid = cUNOPx(topop)->op_first; /* pushmark */
 752         op_null(kid);
 753         op_null(OpSIBLING(kid));       /* const */
 754         if (o != topop) {
 755             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
 756             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
 757             lastkidop->op_next = o;
 758         }
 759     }
 760     else {
 761         p = const_str;
 762         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
 763
 764         lenp->ssize = -1;
 765
 766         /* Concatenate all const strings into const_str.
 767          * Note that args[] contains the RHS args in reverse order, so
 768          * we scan args[] from top to bottom to get constant strings
 769          * in L-R order
 770          */
 771         for (argp = toparg; argp >= args; argp--) {
 772             if (!argp->p)
 773                 /* not a const op */
 774                 (++lenp)->ssize = -1;
 775             else {
 776                 STRLEN l = argp->len;
 777                 Copy(argp->p, p, l, char);
 778                 p += l;
 779                 if (lenp->ssize == -1)
 780                     lenp->ssize = l;
 781                 else
 782                     lenp->ssize += l;
 783             }
 784         }
 785
 786         kid = topop;
 787         nextop = o;
 788         lastkidop = NULL;
 789
 790         for (argp = args; argp <= toparg; argp++) {
 791             /* only keep non-const args, except keep the first-in-next-chain
 792              * arg no matter what it is (but nulled if OP_CONST), because it
 793              * may be the entry point to this subtree from the previous
 794              * op_next.
 795              */
 796             bool last = (argp == toparg);
 797             OP *prev;
 798
 799             /* set prev to the sibling *before* the arg to be cut out,
 800              * e.g. when cutting EXPR:
 801              *
 802              *         |
 803              * kid=  CONCAT
 804              *         |
 805              * prev= CONCAT -- EXPR
 806              *         |
 807              */
 808             if (argp == args && kid->op_type != OP_CONCAT) {
 809                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
 810                  * so the expression to be cut isn't kid->op_last but
 811                  * kid itself */
 812                 OP *o1, *o2;
 813                 /* find the op before kid */
 814                 o1 = NULL;
 815                 o2 = cUNOPx(parentop)->op_first;
 816                 while (o2 && o2 != kid) {
 817                     o1 = o2;
 818                     o2 = OpSIBLING(o2);
 819                 }
 820                 assert(o2 == kid);
 821                 prev = o1;
 822                 kid  = parentop;
 823             }
 824             else if (kid == o && lastkidop)
 825                 prev = last ? lastkidop : OpSIBLING(lastkidop);
 826             else
 827                 prev = last ? NULL : cUNOPx(kid)->op_first;
 828
 829             if (!argp->p || last) {
 830                 /* cut RH op */
 831                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
 832                 /* and unshift to front of o */
 833                 op_sibling_splice(o, NULL, 0, aop);
 834                 /* record the right-most op added to o: later we will
 835                  * free anything to the right of it */
 836                 if (!lastkidop)
 837                     lastkidop = aop;
 838                 aop->op_next = nextop;
 839                 if (last) {
 840                     if (argp->p)
 841                         /* null the const at start of op_next chain */
 842                         op_null(aop);
 843                 }
 844                 else if (prev)
 845                     nextop = prev->op_next;
 846             }
 847
 848             /* the last two arguments are both attached to the same concat op */
 849             if (argp < toparg - 1)
 850                 kid = prev;
 851         }
 852     }
 853
 854     /* Populate the aux struct */
 855
 856     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
 857     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
 858     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
 859     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
 860     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
 861
 862     /* if variant > 0, calculate a variant const string and lengths where
 863      * the utf8 version of the string will take 'variant' more bytes than
 864      * the plain one. */
 865
 866     if (variant) {
 867         char              *p = const_str;
 868         STRLEN          ulen = total_len + variant;
 869         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
 870         UNOP_AUX_item *ulens = lens + (nargs + 1);
 871         char             *up = (char*)PerlMemShared_malloc(ulen);
 872         SSize_t            n;
 873
 874         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
 875         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
 876
 877         for (n = 0; n < (nargs + 1); n++) {
 878             SSize_t i;
 879             char * orig_up = up;
 880             for (i = (lens++)->ssize; i > 0; i--) {
 881                 U8 c = *p++;
 882                 append_utf8_from_native_byte(c, (U8**)&up);
 883             }
 884             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
 885         }
 886     }
 887
 888     if (stringop) {
 889         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
 890          * that op's first child - an ex-PUSHMARK - because the op_next of
 891          * the previous op may point to it (i.e. it's the entry point for
 892          * the o optree)
 893          */
 894         OP *pmop =
 895             (stringop == o)
 896                 ? op_sibling_splice(o, lastkidop, 1, NULL)
 897                 : op_sibling_splice(stringop, NULL, 1, NULL);
 898         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
 899         op_sibling_splice(o, NULL, 0, pmop);
 900         if (!lastkidop)
 901             lastkidop = pmop;
 902     }
 903
 904     /* Optimise
 905      *    target  = A.B.C...
 906      *    target .= A.B.C...
 907      */
 908
 909     if (targetop) {
 910         assert(!targmyop);
 911
 912         if (o->op_type == OP_SASSIGN) {
 913             /* Move the target subtree from being the last of o's children
 914              * to being the last of o's preserved children.
 915              * Note the difference between 'target = ...' and 'target .= ...':
 916              * for the former, target is executed last; for the latter,
 917              * first.
 918              */
 919             kid = OpSIBLING(lastkidop);
 920             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
 921             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
 922             lastkidop->op_next = kid->op_next;
 923             lastkidop = targetop;
 924         }
 925         else {
 926             /* Move the target subtree from being the first of o's
 927              * original children to being the first of *all* o's children.
 928              */
 929             if (lastkidop) {
 930                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
 931                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
 932             }
 933             else {
 934                 /* if the RHS of .= doesn't contain a concat (e.g.
 935                  * $x .= "foo"), it gets missed by the "strip ops from the
 936                  * tree and add to o" loop earlier */
 937                 assert(topop->op_type != OP_CONCAT);
 938                 if (stringop) {
 939                     /* in e.g. $x .= "$y", move the $y expression
 940                      * from being a child of OP_STRINGIFY to being the
 941                      * second child of the OP_CONCAT
 942                      */
 943                     assert(cUNOPx(stringop)->op_first == topop);
 944                     op_sibling_splice(stringop, NULL, 1, NULL);
 945                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
 946                 }
 947                 assert(topop == OpSIBLING(cBINOPo->op_first));
 948                 if (toparg->p)
 949                     op_null(topop);
 950                 lastkidop = topop;
 951             }
 952         }
 953
 954         if (is_targable) {
 955             /* optimise
 956              *  my $lex  = A.B.C...
 957              *     $lex  = A.B.C...
 958              *     $lex .= A.B.C...
 959              * The original padsv op is kept but nulled in case it's the
 960              * entry point for the optree (which it will be for
 961              * '$lex .=  ... '
 962              */
 963             private_flags |= OPpTARGET_MY;
 964             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
 965             o->op_targ = targetop->op_targ;
 966             targetop->op_targ = 0;
 967             op_null(targetop);
 968         }
 969         else
 970             flags |= OPf_STACKED;
 971     }
 972     else if (targmyop) {
 973         private_flags |= OPpTARGET_MY;
 974         if (o != targmyop) {
 975             o->op_targ = targmyop->op_targ;
 976             targmyop->op_targ = 0;
 977         }
 978     }
 979
 980     /* detach the emaciated husk of the sprintf/concat optree and free it */
 981     for (;;) {
 982         kid = op_sibling_splice(o, lastkidop, 1, NULL);
 983         if (!kid)
 984             break;
 985         op_free(kid);
 986     }
 987
 988     /* and convert o into a multiconcat */
 989
 990     o->op_flags        = (flags|OPf_KIDS|stacked_last
 991                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
 992     o->op_private      = private_flags;
 993     o->op_type         = OP_MULTICONCAT;
 994     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
 995     cUNOP_AUXo->op_aux = aux;
 996 }
 997
 998
 999 /*
1000 =for apidoc_section $optree_manipulation
1001
1002 =for apidoc optimize_optree
1003
1004 This function applies some optimisations to the optree in top-down order.
1005 It is called before the peephole optimizer, which processes ops in
1006 execution order. Note that finalize_optree() also does a top-down scan,
1007 but is called *after* the peephole optimizer.
1008
1009 =cut
1010 */
1011
1012 void
1013 Perl_optimize_optree(pTHX_ OP* o)
1014 {
1015     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
1016
1017     ENTER;
1018     SAVEVPTR(PL_curcop);
1019
1020     optimize_op(o);
1021
1022     LEAVE;
1023 }
1024
1025
1026 #define warn_implicit_snail_cvsig(o)  S_warn_implicit_snail_cvsig(aTHX_ o)
1027 static void
1028 S_warn_implicit_snail_cvsig(pTHX_ OP *o)
1029 {
1030     CV *cv = PL_compcv;
1031     while(cv && CvEVAL(cv))
1032         cv = CvOUTSIDE(cv);
1033
1034     if(cv && CvSIGNATURE(cv))
1035         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ARGS_ARRAY_WITH_SIGNATURES),
1036             "Implicit use of @_ in %s with signatured subroutine is experimental", OP_DESC(o));
1037 }
1038
1039
1040 #define OP_ZOOM(o)  (OP_TYPE_IS(o, OP_NULL) ? cUNOPx(o)->op_first : (o))
1041
1042 /* helper for optimize_optree() which optimises one op then recurses
1043  * to optimise any children.
1044  */
1045
1046 STATIC void
1047 S_optimize_op(pTHX_ OP* o)
1048 {
1049     OP *top_op = o;
1050
1051     PERL_ARGS_ASSERT_OPTIMIZE_OP;
1052
1053     while (1) {
1054         OP * next_kid = NULL;
1055
1056         assert(o->op_type != OP_FREED);
1057
1058         switch (o->op_type) {
1059         case OP_NEXTSTATE:
1060         case OP_DBSTATE:
1061             PL_curcop = ((COP*)o);              /* for warnings */
1062             break;
1063
1064
1065         case OP_CONCAT:
1066         case OP_SASSIGN:
1067         case OP_STRINGIFY:
1068         case OP_SPRINTF:
1069             S_maybe_multiconcat(aTHX_ o);
1070             break;
1071
1072         case OP_SUBST:
1073             if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
1074                 /* we can't assume that op_pmreplroot->op_sibparent == o
1075                  * and that it is thus possible to walk back up the tree
1076                  * past op_pmreplroot. So, although we try to avoid
1077                  * recursing through op trees, do it here. After all,
1078                  * there are unlikely to be many nested s///e's within
1079                  * the replacement part of a s///e.
1080                  */
1081                 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1082             }
1083             break;
1084
1085         case OP_RV2AV:
1086         {
1087             OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1088             CV *cv = PL_compcv;
1089             while(cv && CvEVAL(cv))
1090                 cv = CvOUTSIDE(cv);
1091
1092             if(cv && CvSIGNATURE(cv) &&
1093                     OP_TYPE_IS(first, OP_GV) && cGVOPx_gv(first) == PL_defgv) {
1094                 OP *parent = op_parent(o);
1095                 while(OP_TYPE_IS(parent, OP_NULL))
1096                     parent = op_parent(parent);
1097
1098                 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ARGS_ARRAY_WITH_SIGNATURES),
1099                     "Use of @_ in %s with signatured subroutine is experimental", OP_DESC(parent));
1100             }
1101             break;
1102         }
1103
1104         case OP_SHIFT:
1105         case OP_POP:
1106             if(!CvUNIQUE(PL_compcv) && !(o->op_flags & OPf_KIDS))
1107                 warn_implicit_snail_cvsig(o);
1108             break;
1109
1110         case OP_ENTERSUB:
1111             if(!(o->op_flags & OPf_STACKED))
1112                 warn_implicit_snail_cvsig(o);
1113             break;
1114
1115         case OP_GOTO:
1116         {
1117             OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1118             OP *ffirst;
1119             if(OP_TYPE_IS(first, OP_SREFGEN) &&
1120                     (ffirst = OP_ZOOM(cUNOPx(first)->op_first)) &&
1121                     OP_TYPE_IS(ffirst, OP_RV2CV))
1122                 warn_implicit_snail_cvsig(o);
1123             break;
1124         }
1125
1126         default:
1127             break;
1128         }
1129
1130         if (o->op_flags & OPf_KIDS)
1131             next_kid = cUNOPo->op_first;
1132
1133         /* if a kid hasn't been nominated to process, continue with the
1134          * next sibling, or if no siblings left, go back to the parent's
1135          * siblings and so on
1136          */
1137         while (!next_kid) {
1138             if (o == top_op)
1139                 return; /* at top; no parents/siblings to try */
1140             if (OpHAS_SIBLING(o))
1141                 next_kid = o->op_sibparent;
1142             else
1143                 o = o->op_sibparent; /*try parent's next sibling */
1144         }
1145
1146       /* this label not yet used. Goto here if any code above sets
1147        * next-kid
1148        get_next_op:
1149        */
1150         o = next_kid;
1151     }
1152 }
1153
1154 /*
1155 =for apidoc finalize_optree
1156
1157 This function finalizes the optree.  Should be called directly after
1158 the complete optree is built.  It does some additional
1159 checking which can't be done in the normal C<ck_>xxx functions and makes
1160 the tree thread-safe.
1161
1162 =cut
1163 */
1164
1165 void
1166 Perl_finalize_optree(pTHX_ OP* o)
1167 {
1168     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1169
1170     ENTER;
1171     SAVEVPTR(PL_curcop);
1172
1173     finalize_op(o);
1174
1175     LEAVE;
1176 }
1177
1178
1179 /*
1180 =for apidoc traverse_op_tree
1181
1182 Return the next op in a depth-first traversal of the op tree,
1183 returning NULL when the traversal is complete.
1184
1185 The initial call must supply the root of the tree as both top and o.
1186
1187 For now it's static, but it may be exposed to the API in the future.
1188
1189 =cut
1190 */
1191
1192 STATIC OP*
1193 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
1194     OP *sib;
1195
1196     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
1197
1198     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
1199         return cUNOPo->op_first;
1200     }
1201     else if ((sib = OpSIBLING(o))) {
1202         return sib;
1203     }
1204     else {
1205         OP *parent = o->op_sibparent;
1206         assert(!(o->op_moresib));
1207         while (parent && parent != top) {
1208             OP *sib = OpSIBLING(parent);
1209             if (sib)
1210                 return sib;
1211             parent = parent->op_sibparent;
1212         }
1213
1214         return NULL;
1215     }
1216 }
1217
1218 STATIC void
1219 S_finalize_op(pTHX_ OP* o)
1220 {
1221     OP * const top = o;
1222     PERL_ARGS_ASSERT_FINALIZE_OP;
1223
1224     do {
1225         assert(o->op_type != OP_FREED);
1226
1227         switch (o->op_type) {
1228         case OP_NEXTSTATE:
1229         case OP_DBSTATE:
1230             PL_curcop = ((COP*)o);              /* for warnings */
1231             break;
1232         case OP_EXEC:
1233             if (OpHAS_SIBLING(o)) {
1234                 OP *sib = OpSIBLING(o);
1235                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
1236                     && ckWARN(WARN_EXEC)
1237                     && OpHAS_SIBLING(sib))
1238                 {
1239                     const OPCODE type = OpSIBLING(sib)->op_type;
1240                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1241                         const line_t oldline = CopLINE(PL_curcop);
1242                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
1243                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1244                             "Statement unlikely to be reached");
1245                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1246                             "\t(Maybe you meant system() when you said exec()?)\n");
1247                         CopLINE_set(PL_curcop, oldline);
1248                     }
1249                 }
1250             }
1251             break;
1252
1253         case OP_GV:
1254             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1255                 GV * const gv = cGVOPo_gv;
1256                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1257                     /* XXX could check prototype here instead of just carping */
1258                     SV * const sv = sv_newmortal();
1259                     gv_efullname3(sv, gv, NULL);
1260                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1261                                 "%" SVf "() called too early to check prototype",
1262                                 SVfARG(sv));
1263                 }
1264             }
1265             break;
1266
1267         case OP_CONST:
1268             if (cSVOPo->op_private & OPpCONST_STRICT)
1269                 no_bareword_allowed(o);
1270 #ifdef USE_ITHREADS
1271             /* FALLTHROUGH */
1272         case OP_HINTSEVAL:
1273             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
1274 #endif
1275             break;
1276
1277 #ifdef USE_ITHREADS
1278             /* Relocate all the METHOP's SVs to the pad for thread safety. */
1279         case OP_METHOD_NAMED:
1280         case OP_METHOD_SUPER:
1281         case OP_METHOD_REDIR:
1282         case OP_METHOD_REDIR_SUPER:
1283             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
1284             break;
1285 #endif
1286
1287         case OP_HELEM: {
1288             UNOP *rop;
1289             SVOP *key_op;
1290             OP *kid;
1291
1292             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1293                 break;
1294
1295             rop = (UNOP*)((BINOP*)o)->op_first;
1296
1297             goto check_keys;
1298
1299             case OP_HSLICE:
1300                 S_scalar_slice_warning(aTHX_ o);
1301                 /* FALLTHROUGH */
1302
1303             case OP_KVHSLICE:
1304                 kid = OpSIBLING(cLISTOPo->op_first);
1305             if (/* I bet there's always a pushmark... */
1306                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
1307                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
1308             {
1309                 break;
1310             }
1311
1312             key_op = (SVOP*)(kid->op_type == OP_CONST
1313                              ? kid
1314                              : OpSIBLING(kLISTOP->op_first));
1315
1316             rop = (UNOP*)((LISTOP*)o)->op_last;
1317
1318         check_keys:
1319             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1320                 rop = NULL;
1321             check_hash_fields_and_hekify(rop, key_op, 1);
1322             break;
1323         }
1324         case OP_NULL:
1325             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
1326                 break;
1327             /* FALLTHROUGH */
1328         case OP_ASLICE:
1329             S_scalar_slice_warning(aTHX_ o);
1330             break;
1331
1332         case OP_SUBST: {
1333             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1334                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1335             break;
1336         }
1337         default:
1338             break;
1339         }
1340
1341 #ifdef DEBUGGING
1342         if (o->op_flags & OPf_KIDS) {
1343             OP *kid;
1344
1345             /* check that op_last points to the last sibling, and that
1346              * the last op_sibling/op_sibparent field points back to the
1347              * parent, and that the only ops with KIDS are those which are
1348              * entitled to them */
1349             U32 type = o->op_type;
1350             U32 family;
1351             bool has_last;
1352
1353             if (type == OP_NULL) {
1354                 type = o->op_targ;
1355                 /* ck_glob creates a null UNOP with ex-type GLOB
1356                  * (which is a list op. So pretend it wasn't a listop */
1357                 if (type == OP_GLOB)
1358                     type = OP_NULL;
1359             }
1360             family = PL_opargs[type] & OA_CLASS_MASK;
1361
1362             has_last = (   family == OA_BINOP
1363                         || family == OA_LISTOP
1364                         || family == OA_PMOP
1365                         || family == OA_LOOP
1366                        );
1367             assert(  has_last /* has op_first and op_last, or ...
1368                   ... has (or may have) op_first: */
1369                   || family == OA_UNOP
1370                   || family == OA_UNOP_AUX
1371                   || family == OA_LOGOP
1372                   || family == OA_BASEOP_OR_UNOP
1373                   || family == OA_FILESTATOP
1374                   || family == OA_LOOPEXOP
1375                   || family == OA_METHOP
1376                   || type == OP_CUSTOM
1377                   || type == OP_NULL /* new_logop does this */
1378                   );
1379
1380             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
1381                 if (!OpHAS_SIBLING(kid)) {
1382                     if (has_last)
1383                         assert(kid == cLISTOPo->op_last);
1384                     assert(kid->op_sibparent == o);
1385                 }
1386             }
1387         }
1388 #endif
1389     } while (( o = traverse_op_tree(top, o)) != NULL);
1390 }
1391
1392
1393 /*
1394    ---------------------------------------------------------
1395
1396    Common vars in list assignment
1397
1398    There now follows some enums and static functions for detecting
1399    common variables in list assignments. Here is a little essay I wrote
1400    for myself when trying to get my head around this. DAPM.
1401
1402    ----
1403
1404    First some random observations:
1405
1406    * If a lexical var is an alias of something else, e.g.
1407        for my $x ($lex, $pkg, $a[0]) {...}
1408      then the act of aliasing will increase the reference count of the SV
1409
1410    * If a package var is an alias of something else, it may still have a
1411      reference count of 1, depending on how the alias was created, e.g.
1412      in *a = *b, $a may have a refcount of 1 since the GP is shared
1413      with a single GvSV pointer to the SV. So If it's an alias of another
1414      package var, then RC may be 1; if it's an alias of another scalar, e.g.
1415      a lexical var or an array element, then it will have RC > 1.
1416
1417    * There are many ways to create a package alias; ultimately, XS code
1418      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
1419      run-time tracing mechanisms are unlikely to be able to catch all cases.
1420
1421    * When the LHS is all my declarations, the same vars can't appear directly
1422      on the RHS, but they can indirectly via closures, aliasing and lvalue
1423      subs. But those techniques all involve an increase in the lexical
1424      scalar's ref count.
1425
1426    * When the LHS is all lexical vars (but not necessarily my declarations),
1427      it is possible for the same lexicals to appear directly on the RHS, and
1428      without an increased ref count, since the stack isn't refcounted.
1429      This case can be detected at compile time by scanning for common lex
1430      vars with PL_generation.
1431
1432    * lvalue subs defeat common var detection, but they do at least
1433      return vars with a temporary ref count increment. Also, you can't
1434      tell at compile time whether a sub call is lvalue.
1435
1436
1437    So...
1438
1439    A: There are a few circumstances where there definitely can't be any
1440      commonality:
1441
1442        LHS empty:  () = (...);
1443        RHS empty:  (....) = ();
1444        RHS contains only constants or other 'can't possibly be shared'
1445            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
1446            i.e. they only contain ops not marked as dangerous, whose children
1447            are also not dangerous;
1448        LHS ditto;
1449        LHS contains a single scalar element: e.g. ($x) = (....); because
1450            after $x has been modified, it won't be used again on the RHS;
1451        RHS contains a single element with no aggregate on LHS: e.g.
1452            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
1453            won't be used again.
1454
1455    B: If LHS are all 'my' lexical var declarations (or safe ops, which
1456      we can ignore):
1457
1458        my ($a, $b, @c) = ...;
1459
1460        Due to closure and goto tricks, these vars may already have content.
1461        For the same reason, an element on the RHS may be a lexical or package
1462        alias of one of the vars on the left, or share common elements, for
1463        example:
1464
1465            my ($x,$y) = f(); # $x and $y on both sides
1466            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
1467
1468        and
1469
1470            my $ra = f();
1471            my @a = @$ra;  # elements of @a on both sides
1472            sub f { @a = 1..4; \@a }
1473
1474
1475        First, just consider scalar vars on LHS:
1476
1477            RHS is safe only if (A), or in addition,
1478                * contains only lexical *scalar* vars, where neither side's
1479                  lexicals have been flagged as aliases
1480
1481            If RHS is not safe, then it's always legal to check LHS vars for
1482            RC==1, since the only RHS aliases will always be associated
1483            with an RC bump.
1484
1485            Note that in particular, RHS is not safe if:
1486
1487                * it contains package scalar vars; e.g.:
1488
1489                    f();
1490                    my ($x, $y) = (2, $x_alias);
1491                    sub f { $x = 1; *x_alias = \$x; }
1492
1493                * It contains other general elements, such as flattened or
1494                * spliced or single array or hash elements, e.g.
1495
1496                    f();
1497                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
1498
1499                    sub f {
1500                        ($x, $y) = (1,2);
1501                        use feature 'refaliasing';
1502                        \($a[0], $a[1]) = \($y,$x);
1503                    }
1504
1505                  It doesn't matter if the array/hash is lexical or package.
1506
1507                * it contains a function call that happens to be an lvalue
1508                  sub which returns one or more of the above, e.g.
1509
1510                    f();
1511                    my ($x,$y) = f();
1512
1513                    sub f : lvalue {
1514                        ($x, $y) = (1,2);
1515                        *x1 = \$x;
1516                        $y, $x1;
1517                    }
1518
1519                    (so a sub call on the RHS should be treated the same
1520                    as having a package var on the RHS).
1521
1522                * any other "dangerous" thing, such an op or built-in that
1523                  returns one of the above, e.g. pp_preinc
1524
1525
1526            If RHS is not safe, what we can do however is at compile time flag
1527            that the LHS are all my declarations, and at run time check whether
1528            all the LHS have RC == 1, and if so skip the full scan.
1529
1530        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
1531
1532            Here the issue is whether there can be elements of @a on the RHS
1533            which will get prematurely freed when @a is cleared prior to
1534            assignment. This is only a problem if the aliasing mechanism
1535            is one which doesn't increase the refcount - only if RC == 1
1536            will the RHS element be prematurely freed.
1537
1538            Because the array/hash is being INTROed, it or its elements
1539            can't directly appear on the RHS:
1540
1541                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
1542
1543            but can indirectly, e.g.:
1544
1545                my $r = f();
1546                my (@a) = @$r;
1547                sub f { @a = 1..3; \@a }
1548
1549            So if the RHS isn't safe as defined by (A), we must always
1550            mortalise and bump the ref count of any remaining RHS elements
1551            when assigning to a non-empty LHS aggregate.
1552
1553            Lexical scalars on the RHS aren't safe if they've been involved in
1554            aliasing, e.g.
1555
1556                use feature 'refaliasing';
1557
1558                f();
1559                \(my $lex) = \$pkg;
1560                my @a = ($lex,3); # equivalent to ($a[0],3)
1561
1562                sub f {
1563                    @a = (1,2);
1564                    \$pkg = \$a[0];
1565                }
1566
1567            Similarly with lexical arrays and hashes on the RHS:
1568
1569                f();
1570                my @b;
1571                my @a = (@b);
1572
1573                sub f {
1574                    @a = (1,2);
1575                    \$b[0] = \$a[1];
1576                    \$b[1] = \$a[0];
1577                }
1578
1579
1580
1581    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
1582        my $a; ($a, my $b) = (....);
1583
1584        The difference between (B) and (C) is that it is now physically
1585        possible for the LHS vars to appear on the RHS too, where they
1586        are not reference counted; but in this case, the compile-time
1587        PL_generation sweep will detect such common vars.
1588
1589        So the rules for (C) differ from (B) in that if common vars are
1590        detected, the runtime "test RC==1" optimisation can no longer be used,
1591        and a full mark and sweep is required
1592
1593    D: As (C), but in addition the LHS may contain package vars.
1594
1595        Since package vars can be aliased without a corresponding refcount
1596        increase, all bets are off. It's only safe if (A). E.g.
1597
1598            my ($x, $y) = (1,2);
1599
1600            for $x_alias ($x) {
1601                ($x_alias, $y) = (3, $x); # whoops
1602            }
1603
1604        Ditto for LHS aggregate package vars.
1605
1606    E: Any other dangerous ops on LHS, e.g.
1607            (f(), $a[0], @$r) = (...);
1608
1609        this is similar to (E) in that all bets are off. In addition, it's
1610        impossible to determine at compile time whether the LHS
1611        contains a scalar or an aggregate, e.g.
1612
1613            sub f : lvalue { @a }
1614            (f()) = 1..3;
1615
1616 * ---------------------------------------------------------
1617 */
1618
1619 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
1620  * that at least one of the things flagged was seen.
1621  */
1622
1623 enum {
1624     AAS_MY_SCALAR       = 0x001, /* my $scalar */
1625     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
1626     AAS_LEX_SCALAR      = 0x004, /* $lexical */
1627     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
1628     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
1629     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
1630     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
1631     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
1632                                          that's flagged OA_DANGEROUS */
1633     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
1634                                         not in any of the categories above */
1635     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
1636 };
1637
1638 /* helper function for S_aassign_scan().
1639  * check a PAD-related op for commonality and/or set its generation number.
1640  * Returns a boolean indicating whether its shared */
1641
1642 static bool
1643 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
1644 {
1645     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
1646         /* lexical used in aliasing */
1647         return TRUE;
1648
1649     if (rhs)
1650         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
1651     else
1652         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
1653
1654     return FALSE;
1655 }
1656
1657 /*
1658   Helper function for OPpASSIGN_COMMON* detection in rpeep().
1659   It scans the left or right hand subtree of the aassign op, and returns a
1660   set of flags indicating what sorts of things it found there.
1661   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
1662   set PL_generation on lexical vars; if the latter, we see if
1663   PL_generation matches.
1664   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
1665   This fn will increment it by the number seen. It's not intended to
1666   be an accurate count (especially as many ops can push a variable
1667   number of SVs onto the stack); rather it's used as to test whether there
1668   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
1669 */
1670
1671 static int
1672 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
1673 {
1674     OP *top_op           = o;
1675     OP *effective_top_op = o;
1676     int all_flags = 0;
1677
1678     while (1) {
1679         bool top = o == effective_top_op;
1680         int flags = 0;
1681         OP* next_kid = NULL;
1682
1683         /* first, look for a solitary @_ on the RHS */
1684         if (   rhs
1685             && top
1686             && (o->op_flags & OPf_KIDS)
1687             && OP_TYPE_IS_OR_WAS(o, OP_LIST)
1688         ) {
1689             OP *kid = cUNOPo->op_first;
1690             if (   (   kid->op_type == OP_PUSHMARK
1691                     || kid->op_type == OP_PADRANGE) /* ex-pushmark */
1692                 && ((kid = OpSIBLING(kid)))
1693                 && !OpHAS_SIBLING(kid)
1694                 && kid->op_type == OP_RV2AV
1695                 && !(kid->op_flags & OPf_REF)
1696                 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
1697                 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
1698                 && ((kid = cUNOPx(kid)->op_first))
1699                 && kid->op_type == OP_GV
1700                 && cGVOPx_gv(kid) == PL_defgv
1701             )
1702                 flags = AAS_DEFAV;
1703         }
1704
1705         switch (o->op_type) {
1706         case OP_GVSV:
1707             (*scalars_p)++;
1708             all_flags |= AAS_PKG_SCALAR;
1709             goto do_next;
1710
1711         case OP_PADAV:
1712         case OP_PADHV:
1713             (*scalars_p) += 2;
1714             /* if !top, could be e.g. @a[0,1] */
1715             all_flags |=  (top && (o->op_flags & OPf_REF))
1716                             ? ((o->op_private & OPpLVAL_INTRO)
1717                                 ? AAS_MY_AGG : AAS_LEX_AGG)
1718                             : AAS_DANGEROUS;
1719             goto do_next;
1720
1721         case OP_PADSV:
1722             {
1723                 int comm = S_aassign_padcheck(aTHX_ o, rhs)
1724                             ?  AAS_LEX_SCALAR_COMM : 0;
1725                 (*scalars_p)++;
1726                 all_flags |= (o->op_private & OPpLVAL_INTRO)
1727                     ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
1728                 goto do_next;
1729
1730             }
1731
1732         case OP_RV2AV:
1733         case OP_RV2HV:
1734             (*scalars_p) += 2;
1735             if (cUNOPx(o)->op_first->op_type != OP_GV)
1736                 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
1737             /* @pkg, %pkg */
1738             /* if !top, could be e.g. @a[0,1] */
1739             else if (top && (o->op_flags & OPf_REF))
1740                 all_flags |= AAS_PKG_AGG;
1741             else
1742                 all_flags |= AAS_DANGEROUS;
1743             goto do_next;
1744
1745         case OP_RV2SV:
1746             (*scalars_p)++;
1747             if (cUNOPx(o)->op_first->op_type != OP_GV) {
1748                 (*scalars_p) += 2;
1749                 all_flags |= AAS_DANGEROUS; /* ${expr} */
1750             }
1751             else
1752                 all_flags |= AAS_PKG_SCALAR; /* $pkg */
1753             goto do_next;
1754
1755         case OP_SPLIT:
1756             if (o->op_private & OPpSPLIT_ASSIGN) {
1757                 /* the assign in @a = split() has been optimised away
1758                  * and the @a attached directly to the split op
1759                  * Treat the array as appearing on the RHS, i.e.
1760                  *    ... = (@a = split)
1761                  * is treated like
1762                  *    ... = @a;
1763                  */
1764
1765                 if (o->op_flags & OPf_STACKED) {
1766                     /* @{expr} = split() - the array expression is tacked
1767                      * on as an extra child to split - process kid */
1768                     next_kid = cLISTOPo->op_last;
1769                     goto do_next;
1770                 }
1771
1772                 /* ... else array is directly attached to split op */
1773                 (*scalars_p) += 2;
1774                 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
1775                                 ? ((o->op_private & OPpLVAL_INTRO)
1776                                     ? AAS_MY_AGG : AAS_LEX_AGG)
1777                                 : AAS_PKG_AGG;
1778                 goto do_next;
1779             }
1780             (*scalars_p)++;
1781             /* other args of split can't be returned */
1782             all_flags |= AAS_SAFE_SCALAR;
1783             goto do_next;
1784
1785         case OP_UNDEF:
1786             /* undef on LHS following a var is significant, e.g.
1787              *    my $x = 1;
1788              *    @a = (($x, undef) = (2 => $x));
1789              *    # @a shoul be (2,1) not (2,2)
1790              *
1791              * undef on RHS counts as a scalar:
1792              *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
1793              */
1794             if ((!rhs && *scalars_p) || rhs)
1795                 (*scalars_p)++;
1796             flags = AAS_SAFE_SCALAR;
1797             break;
1798
1799         case OP_PUSHMARK:
1800         case OP_STUB:
1801             /* these are all no-ops; they don't push a potentially common SV
1802              * onto the stack, so they are neither AAS_DANGEROUS nor
1803              * AAS_SAFE_SCALAR */
1804             goto do_next;
1805
1806         case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
1807             break;
1808
1809         case OP_NULL:
1810         case OP_LIST:
1811             /* these do nothing, but may have children */
1812             break;
1813
1814         default:
1815             if (PL_opargs[o->op_type] & OA_DANGEROUS) {
1816                 (*scalars_p) += 2;
1817                 flags = AAS_DANGEROUS;
1818                 break;
1819             }
1820
1821             if (   (PL_opargs[o->op_type] & OA_TARGLEX)
1822                 && (o->op_private & OPpTARGET_MY))
1823             {
1824                 (*scalars_p)++;
1825                 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
1826                                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
1827                 goto do_next;
1828             }
1829
1830             /* if its an unrecognised, non-dangerous op, assume that it
1831              * is the cause of at least one safe scalar */
1832             (*scalars_p)++;
1833             flags = AAS_SAFE_SCALAR;
1834             break;
1835         }
1836
1837         all_flags |= flags;
1838
1839         /* by default, process all kids next
1840          * XXX this assumes that all other ops are "transparent" - i.e. that
1841          * they can return some of their children. While this true for e.g.
1842          * sort and grep, it's not true for e.g. map. We really need a
1843          * 'transparent' flag added to regen/opcodes
1844          */
1845         if (o->op_flags & OPf_KIDS) {
1846             next_kid = cUNOPo->op_first;
1847             /* these ops do nothing but may have children; but their
1848              * children should also be treated as top-level */
1849             if (   o == effective_top_op
1850                 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
1851             )
1852                 effective_top_op = next_kid;
1853         }
1854
1855
1856         /* If next_kid is set, someone in the code above wanted us to process
1857          * that kid and all its remaining siblings.  Otherwise, work our way
1858          * back up the tree */
1859       do_next:
1860         while (!next_kid) {
1861             if (o == top_op)
1862                 return all_flags; /* at top; no parents/siblings to try */
1863             if (OpHAS_SIBLING(o)) {
1864                 next_kid = o->op_sibparent;
1865                 if (o == effective_top_op)
1866                     effective_top_op = next_kid;
1867             }
1868             else if (o == effective_top_op)
1869               effective_top_op = o->op_sibparent;
1870             o = o->op_sibparent; /* try parent's next sibling */
1871         }
1872         o = next_kid;
1873     } /* while */
1874 }
1875
1876 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
1877  * that potentially represent a series of one or more aggregate derefs
1878  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
1879  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
1880  * additional ops left in too).
1881  *
1882  * The caller will have already verified that the first few ops in the
1883  * chain following 'start' indicate a multideref candidate, and will have
1884  * set 'orig_o' to the point further on in the chain where the first index
1885  * expression (if any) begins.  'orig_action' specifies what type of
1886  * beginning has already been determined by the ops between start..orig_o
1887  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
1888  *
1889  * 'hints' contains any hints flags that need adding (currently just
1890  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
1891  */
1892
1893 STATIC void
1894 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
1895 {
1896     int pass;
1897     UNOP_AUX_item *arg_buf = NULL;
1898     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
1899     int index_skip         = -1;    /* don't output index arg on this action */
1900
1901     /* similar to regex compiling, do two passes; the first pass
1902      * determines whether the op chain is convertible and calculates the
1903      * buffer size; the second pass populates the buffer and makes any
1904      * changes necessary to ops (such as moving consts to the pad on
1905      * threaded builds).
1906      *
1907      * NB: for things like Coverity, note that both passes take the same
1908      * path through the logic tree (except for 'if (pass)' bits), since
1909      * both passes are following the same op_next chain; and in
1910      * particular, if it would return early on the second pass, it would
1911      * already have returned early on the first pass.
1912      */
1913     for (pass = 0; pass < 2; pass++) {
1914         OP *o                = orig_o;
1915         UV action            = orig_action;
1916         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
1917         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
1918         int action_count     = 0;     /* number of actions seen so far */
1919         int action_ix        = 0;     /* action_count % (actions per IV) */
1920         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
1921         bool is_last         = FALSE; /* no more derefs to follow */
1922         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
1923         UV action_word       = 0;     /* all actions so far */
1924         UNOP_AUX_item *arg     = arg_buf;
1925         UNOP_AUX_item *action_ptr = arg_buf;
1926
1927         arg++; /* reserve slot for first action word */
1928
1929         switch (action) {
1930         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1931         case MDEREF_HV_gvhv_helem:
1932             next_is_hash = TRUE;
1933             /* FALLTHROUGH */
1934         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1935         case MDEREF_AV_gvav_aelem:
1936             if (pass) {
1937 #ifdef USE_ITHREADS
1938                 arg->pad_offset = cPADOPx(start)->op_padix;
1939                 /* stop it being swiped when nulled */
1940                 cPADOPx(start)->op_padix = 0;
1941 #else
1942                 arg->sv = cSVOPx(start)->op_sv;
1943                 cSVOPx(start)->op_sv = NULL;
1944 #endif
1945             }
1946             arg++;
1947             break;
1948
1949         case MDEREF_HV_padhv_helem:
1950         case MDEREF_HV_padsv_vivify_rv2hv_helem:
1951             next_is_hash = TRUE;
1952             /* FALLTHROUGH */
1953         case MDEREF_AV_padav_aelem:
1954         case MDEREF_AV_padsv_vivify_rv2av_aelem:
1955             if (pass) {
1956                 arg->pad_offset = start->op_targ;
1957                 /* we skip setting op_targ = 0 for now, since the intact
1958                  * OP_PADXV is needed by check_hash_fields_and_hekify */
1959                 reset_start_targ = TRUE;
1960             }
1961             arg++;
1962             break;
1963
1964         case MDEREF_HV_pop_rv2hv_helem:
1965             next_is_hash = TRUE;
1966             /* FALLTHROUGH */
1967         case MDEREF_AV_pop_rv2av_aelem:
1968             break;
1969
1970         default:
1971             NOT_REACHED; /* NOTREACHED */
1972             return;
1973         }
1974
1975         while (!is_last) {
1976             /* look for another (rv2av/hv; get index;
1977              * aelem/helem/exists/delele) sequence */
1978
1979             OP *kid;
1980             bool is_deref;
1981             bool ok;
1982             UV index_type = MDEREF_INDEX_none;
1983
1984             if (action_count) {
1985                 /* if this is not the first lookup, consume the rv2av/hv  */
1986
1987                 /* for N levels of aggregate lookup, we normally expect
1988                  * that the first N-1 [ah]elem ops will be flagged as
1989                  * /DEREF (so they autovivifiy if necessary), and the last
1990                  * lookup op not to be.
1991                  * For other things (like @{$h{k1}{k2}}) extra scope or
1992                  * leave ops can appear, so abandon the effort in that
1993                  * case */
1994                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
1995                     return;
1996
1997                 /* rv2av or rv2hv sKR/1 */
1998
1999                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
2000                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
2001                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
2002                     return;
2003
2004                 /* at this point, we wouldn't expect any of these
2005                  * possible private flags:
2006                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
2007                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
2008                  */
2009                 ASSUME(!(o->op_private &
2010                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
2011
2012                 hints = (o->op_private & OPpHINT_STRICT_REFS);
2013
2014                 /* make sure the type of the previous /DEREF matches the
2015                  * type of the next lookup */
2016                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
2017                 top_op = o;
2018
2019                 action = next_is_hash
2020                             ? MDEREF_HV_vivify_rv2hv_helem
2021                             : MDEREF_AV_vivify_rv2av_aelem;
2022                 o = o->op_next;
2023             }
2024
2025             /* if this is the second pass, and we're at the depth where
2026              * previously we encountered a non-simple index expression,
2027              * stop processing the index at this point */
2028             if (action_count != index_skip) {
2029
2030                 /* look for one or more simple ops that return an array
2031                  * index or hash key */
2032
2033                 switch (o->op_type) {
2034                 case OP_PADSV:
2035                     /* it may be a lexical var index */
2036                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
2037                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
2038                     ASSUME(!(o->op_private &
2039                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
2040
2041                     if (   OP_GIMME(o,0) == G_SCALAR
2042                         && !(o->op_flags & (OPf_REF|OPf_MOD))
2043                         && o->op_private == 0)
2044                     {
2045                         if (pass)
2046                             arg->pad_offset = o->op_targ;
2047                         arg++;
2048                         index_type = MDEREF_INDEX_padsv;
2049                         o = o->op_next;
2050                     }
2051                     break;
2052
2053                 case OP_CONST:
2054                     if (next_is_hash) {
2055                         /* it's a constant hash index */
2056                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
2057                             /* "use constant foo => FOO; $h{+foo}" for
2058                              * some weird FOO, can leave you with constants
2059                              * that aren't simple strings. It's not worth
2060                              * the extra hassle for those edge cases */
2061                             break;
2062
2063                         {
2064                             UNOP *rop = NULL;
2065                             OP * helem_op = o->op_next;
2066
2067                             ASSUME(   helem_op->op_type == OP_HELEM
2068                                    || helem_op->op_type == OP_NULL
2069                                    || pass == 0);
2070                             if (helem_op->op_type == OP_HELEM) {
2071                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
2072                                 if (   helem_op->op_private & OPpLVAL_INTRO
2073                                     || rop->op_type != OP_RV2HV
2074                                 )
2075                                     rop = NULL;
2076                             }
2077                             /* on first pass just check; on second pass
2078                              * hekify */
2079                             check_hash_fields_and_hekify(rop, cSVOPo, pass);
2080                         }
2081
2082                         if (pass) {
2083 #ifdef USE_ITHREADS
2084                             /* Relocate sv to the pad for thread safety */
2085                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2086                             arg->pad_offset = o->op_targ;
2087                             o->op_targ = 0;
2088 #else
2089                             arg->sv = cSVOPx_sv(o);
2090 #endif
2091                         }
2092                     }
2093                     else {
2094                         /* it's a constant array index */
2095                         IV iv;
2096                         SV *ix_sv = cSVOPo->op_sv;
2097                         if (!SvIOK(ix_sv))
2098                             break;
2099                         iv = SvIV(ix_sv);
2100
2101                         if (   action_count == 0
2102                             && iv >= -128
2103                             && iv <= 127
2104                             && (   action == MDEREF_AV_padav_aelem
2105                                 || action == MDEREF_AV_gvav_aelem)
2106                         )
2107                             maybe_aelemfast = TRUE;
2108
2109                         if (pass) {
2110                             arg->iv = iv;
2111                             SvREFCNT_dec_NN(cSVOPo->op_sv);
2112                         }
2113                     }
2114                     if (pass)
2115                         /* we've taken ownership of the SV */
2116                         cSVOPo->op_sv = NULL;
2117                     arg++;
2118                     index_type = MDEREF_INDEX_const;
2119                     o = o->op_next;
2120                     break;
2121
2122                 case OP_GV:
2123                     /* it may be a package var index */
2124
2125                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
2126                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
2127                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
2128                         || o->op_private != 0
2129                     )
2130                         break;
2131
2132                     kid = o->op_next;
2133                     if (kid->op_type != OP_RV2SV)
2134                         break;
2135
2136                     ASSUME(!(kid->op_flags &
2137                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
2138                              |OPf_SPECIAL|OPf_PARENS)));
2139                     ASSUME(!(kid->op_private &
2140                                     ~(OPpARG1_MASK
2141                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
2142                                      |OPpDEREF|OPpLVAL_INTRO)));
2143                     if(   (kid->op_flags &~ OPf_PARENS)
2144                             != (OPf_WANT_SCALAR|OPf_KIDS)
2145                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
2146                     )
2147                         break;
2148
2149                     if (pass) {
2150 #ifdef USE_ITHREADS
2151                         arg->pad_offset = cPADOPx(o)->op_padix;
2152                         /* stop it being swiped when nulled */
2153                         cPADOPx(o)->op_padix = 0;
2154 #else
2155                         arg->sv = cSVOPx(o)->op_sv;
2156                         cSVOPo->op_sv = NULL;
2157 #endif
2158                     }
2159                     arg++;
2160                     index_type = MDEREF_INDEX_gvsv;
2161                     o = kid->op_next;
2162                     break;
2163
2164                 } /* switch */
2165             } /* action_count != index_skip */
2166
2167             action |= index_type;
2168
2169
2170             /* at this point we have either:
2171              *   * detected what looks like a simple index expression,
2172              *     and expect the next op to be an [ah]elem, or
2173              *     an nulled  [ah]elem followed by a delete or exists;
2174              *  * found a more complex expression, so something other
2175              *    than the above follows.
2176              */
2177
2178             /* possibly an optimised away [ah]elem (where op_next is
2179              * exists or delete) */
2180             if (o->op_type == OP_NULL)
2181                 o = o->op_next;
2182
2183             /* at this point we're looking for an OP_AELEM, OP_HELEM,
2184              * OP_EXISTS or OP_DELETE */
2185
2186             /* if a custom array/hash access checker is in scope,
2187              * abandon optimisation attempt */
2188             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
2189                && PL_check[o->op_type] != Perl_ck_null)
2190                 return;
2191             /* similarly for customised exists and delete */
2192             if (  (o->op_type == OP_EXISTS)
2193                && PL_check[o->op_type] != Perl_ck_exists)
2194                 return;
2195             if (  (o->op_type == OP_DELETE)
2196                && PL_check[o->op_type] != Perl_ck_delete)
2197                 return;
2198
2199             if (   o->op_type != OP_AELEM
2200                 || (o->op_private &
2201                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
2202                 )
2203                 maybe_aelemfast = FALSE;
2204
2205             /* look for aelem/helem/exists/delete. If it's not the last elem
2206              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
2207              * flags; if it's the last, then it mustn't have
2208              * OPpDEREF_AV/HV, but may have lots of other flags, like
2209              * OPpLVAL_INTRO etc
2210              */
2211
2212             if (   index_type == MDEREF_INDEX_none
2213                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
2214                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
2215             )
2216                 ok = FALSE;
2217             else {
2218                 /* we have aelem/helem/exists/delete with valid simple index */
2219
2220                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
2221                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
2222                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
2223
2224                 /* This doesn't make much sense but is legal:
2225                  *    @{ local $x[0][0] } = 1
2226                  * Since scope exit will undo the autovivification,
2227                  * don't bother in the first place. The OP_LEAVE
2228                  * assertion is in case there are other cases of both
2229                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
2230                  * exit that would undo the local - in which case this
2231                  * block of code would need rethinking.
2232                  */
2233                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
2234 #ifdef DEBUGGING
2235                     OP *n = o->op_next;
2236                     while (n && (  n->op_type == OP_NULL
2237                                 || n->op_type == OP_LIST
2238                                 || n->op_type == OP_SCALAR))
2239                         n = n->op_next;
2240                     assert(n && n->op_type == OP_LEAVE);
2241 #endif
2242                     o->op_private &= ~OPpDEREF;
2243                     is_deref = FALSE;
2244                 }
2245
2246                 if (is_deref) {
2247                     ASSUME(!(o->op_flags &
2248                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
2249                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
2250
2251                     ok =    (o->op_flags &~ OPf_PARENS)
2252                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
2253                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
2254                 }
2255                 else if (o->op_type == OP_EXISTS) {
2256                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
2257                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
2258                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
2259                     ok =  !(o->op_private & ~OPpARG1_MASK);
2260                 }
2261                 else if (o->op_type == OP_DELETE) {
2262                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
2263                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
2264                     ASSUME(!(o->op_private &
2265                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
2266                     /* don't handle slices or 'local delete'; the latter
2267                      * is fairly rare, and has a complex runtime */
2268                     ok =  !(o->op_private & ~OPpARG1_MASK);
2269                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
2270                         /* skip handling run-tome error */
2271                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
2272                 }
2273                 else {
2274                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
2275                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
2276                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
2277                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
2278                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
2279                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
2280                 }
2281             }
2282
2283             if (ok) {
2284                 if (!first_elem_op)
2285                     first_elem_op = o;
2286                 top_op = o;
2287                 if (is_deref) {
2288                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
2289                     o = o->op_next;
2290                 }
2291                 else {
2292                     is_last = TRUE;
2293                     action |= MDEREF_FLAG_last;
2294                 }
2295             }
2296             else {
2297                 /* at this point we have something that started
2298                  * promisingly enough (with rv2av or whatever), but failed
2299                  * to find a simple index followed by an
2300                  * aelem/helem/exists/delete. If this is the first action,
2301                  * give up; but if we've already seen at least one
2302                  * aelem/helem, then keep them and add a new action with
2303                  * MDEREF_INDEX_none, which causes it to do the vivify
2304                  * from the end of the previous lookup, and do the deref,
2305                  * but stop at that point. So $a[0][expr] will do one
2306                  * av_fetch, vivify and deref, then continue executing at
2307                  * expr */
2308                 if (!action_count)
2309                     return;
2310                 is_last = TRUE;
2311                 index_skip = action_count;
2312                 action |= MDEREF_FLAG_last;
2313                 if (index_type != MDEREF_INDEX_none)
2314                     arg--;
2315             }
2316
2317             action_word |= (action << (action_ix * MDEREF_SHIFT));
2318             action_ix++;
2319             action_count++;
2320             /* if there's no space for the next action, reserve a new slot
2321              * for it *before* we start adding args for that action */
2322             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
2323                 if (pass)
2324                     action_ptr->uv = action_word;
2325                 action_word = 0;
2326                 action_ptr = arg;
2327                 arg++;
2328                 action_ix = 0;
2329             }
2330         } /* while !is_last */
2331
2332         /* success! */
2333
2334         if (!action_ix)
2335             /* slot reserved for next action word not now needed */
2336             arg--;
2337         else if (pass)
2338             action_ptr->uv = action_word;
2339
2340         if (pass) {
2341             OP *mderef;
2342             OP *p, *q;
2343
2344             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
2345             if (index_skip == -1) {
2346                 mderef->op_flags = o->op_flags
2347                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
2348                 if (o->op_type == OP_EXISTS)
2349                     mderef->op_private = OPpMULTIDEREF_EXISTS;
2350                 else if (o->op_type == OP_DELETE)
2351                     mderef->op_private = OPpMULTIDEREF_DELETE;
2352                 else
2353                     mderef->op_private = o->op_private
2354                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
2355             }
2356             /* accumulate strictness from every level (although I don't think
2357              * they can actually vary) */
2358             mderef->op_private |= hints;
2359
2360             /* integrate the new multideref op into the optree and the
2361              * op_next chain.
2362              *
2363              * In general an op like aelem or helem has two child
2364              * sub-trees: the aggregate expression (a_expr) and the
2365              * index expression (i_expr):
2366              *
2367              *     aelem
2368              *       |
2369              *     a_expr - i_expr
2370              *
2371              * The a_expr returns an AV or HV, while the i-expr returns an
2372              * index. In general a multideref replaces most or all of a
2373              * multi-level tree, e.g.
2374              *
2375              *     exists
2376              *       |
2377              *     ex-aelem
2378              *       |
2379              *     rv2av  - i_expr1
2380              *       |
2381              *     helem
2382              *       |
2383              *     rv2hv  - i_expr2
2384              *       |
2385              *     aelem
2386              *       |
2387              *     a_expr - i_expr3
2388              *
2389              * With multideref, all the i_exprs will be simple vars or
2390              * constants, except that i_expr1 may be arbitrary in the case
2391              * of MDEREF_INDEX_none.
2392              *
2393              * The bottom-most a_expr will be either:
2394              *   1) a simple var (so padXv or gv+rv2Xv);
2395              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
2396              *      so a simple var with an extra rv2Xv;
2397              *   3) or an arbitrary expression.
2398              *
2399              * 'start', the first op in the execution chain, will point to
2400              *   1),2): the padXv or gv op;
2401              *   3):    the rv2Xv which forms the last op in the a_expr
2402              *          execution chain, and the top-most op in the a_expr
2403              *          subtree.
2404              *
2405              * For all cases, the 'start' node is no longer required,
2406              * but we can't free it since one or more external nodes
2407              * may point to it. E.g. consider
2408              *     $h{foo} = $a ? $b : $c
2409              * Here, both the op_next and op_other branches of the
2410              * cond_expr point to the gv[*h] of the hash expression, so
2411              * we can't free the 'start' op.
2412              *
2413              * For expr->[...], we need to save the subtree containing the
2414              * expression; for the other cases, we just need to save the
2415              * start node.
2416              * So in all cases, we null the start op and keep it around by
2417              * making it the child of the multideref op; for the expr->
2418              * case, the expr will be a subtree of the start node.
2419              *
2420              * So in the simple 1,2 case the  optree above changes to
2421              *
2422              *     ex-exists
2423              *       |
2424              *     multideref
2425              *       |
2426              *     ex-gv (or ex-padxv)
2427              *
2428              *  with the op_next chain being
2429              *
2430              *  -> ex-gv -> multideref -> op-following-ex-exists ->
2431              *
2432              *  In the 3 case, we have
2433              *
2434              *     ex-exists
2435              *       |
2436              *     multideref
2437              *       |
2438              *     ex-rv2xv
2439              *       |
2440              *    rest-of-a_expr
2441              *      subtree
2442              *
2443              *  and
2444              *
2445              *  -> rest-of-a_expr subtree ->
2446              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
2447              *
2448              *
2449              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
2450              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
2451              * multideref attached as the child, e.g.
2452              *
2453              *     exists
2454              *       |
2455              *     ex-aelem
2456              *       |
2457              *     ex-rv2av  - i_expr1
2458              *       |
2459              *     multideref
2460              *       |
2461              *     ex-whatever
2462              *
2463              */
2464
2465             /* if we free this op, don't free the pad entry */
2466             if (reset_start_targ)
2467                 start->op_targ = 0;
2468
2469
2470             /* Cut the bit we need to save out of the tree and attach to
2471              * the multideref op, then free the rest of the tree */
2472
2473             /* find parent of node to be detached (for use by splice) */
2474             p = first_elem_op;
2475             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
2476                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
2477             {
2478                 /* there is an arbitrary expression preceding us, e.g.
2479                  * expr->[..]? so we need to save the 'expr' subtree */
2480                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
2481                     p = cUNOPx(p)->op_first;
2482                 ASSUME(   start->op_type == OP_RV2AV
2483                        || start->op_type == OP_RV2HV);
2484             }
2485             else {
2486                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
2487                  * above for exists/delete. */
2488                 while (   (p->op_flags & OPf_KIDS)
2489                        && cUNOPx(p)->op_first != start
2490                 )
2491                     p = cUNOPx(p)->op_first;
2492             }
2493             ASSUME(cUNOPx(p)->op_first == start);
2494
2495             /* detach from main tree, and re-attach under the multideref */
2496             op_sibling_splice(mderef, NULL, 0,
2497                     op_sibling_splice(p, NULL, 1, NULL));
2498             op_null(start);
2499
2500             start->op_next = mderef;
2501
2502             mderef->op_next = index_skip == -1 ? o->op_next : o;
2503
2504             /* excise and free the original tree, and replace with
2505              * the multideref op */
2506             p = op_sibling_splice(top_op, NULL, -1, mderef);
2507             while (p) {
2508                 q = OpSIBLING(p);
2509                 op_free(p);
2510                 p = q;
2511             }
2512             op_null(top_op);
2513         }
2514         else {
2515             Size_t size = arg - arg_buf;
2516
2517             if (maybe_aelemfast && action_count == 1)
2518                 return;
2519
2520             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
2521                                 sizeof(UNOP_AUX_item) * (size + 1));
2522             /* for dumping etc: store the length in a hidden first slot;
2523              * we set the op_aux pointer to the second slot */
2524             arg_buf->uv = size;
2525             arg_buf++;
2526         }
2527     } /* for (pass = ...) */
2528 }
2529
2530 /* See if the ops following o are such that o will always be executed in
2531  * boolean context: that is, the SV which o pushes onto the stack will
2532  * only ever be consumed by later ops via SvTRUE(sv) or similar.
2533  * If so, set a suitable private flag on o. Normally this will be
2534  * bool_flag; but see below why maybe_flag is needed too.
2535  *
2536  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
2537  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
2538  * already be taken, so you'll have to give that op two different flags.
2539  *
2540  * More explanation of 'maybe_flag' and 'safe_and' parameters.
2541  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
2542  * those underlying ops) short-circuit, which means that rather than
2543  * necessarily returning a truth value, they may return the LH argument,
2544  * which may not be boolean. For example in $x = (keys %h || -1), keys
2545  * should return a key count rather than a boolean, even though its
2546  * sort-of being used in boolean context.
2547  *
2548  * So we only consider such logical ops to provide boolean context to
2549  * their LH argument if they themselves are in void or boolean context.
2550  * However, sometimes the context isn't known until run-time. In this
2551  * case the op is marked with the maybe_flag flag it.
2552  *
2553  * Consider the following.
2554  *
2555  *     sub f { ....;  if (%h) { .... } }
2556  *
2557  * This is actually compiled as
2558  *
2559  *     sub f { ....;  %h && do { .... } }
2560  *
2561  * Here we won't know until runtime whether the final statement (and hence
2562  * the &&) is in void context and so is safe to return a boolean value.
2563  * So mark o with maybe_flag rather than the bool_flag.
2564  * Note that there is cost associated with determining context at runtime
2565  * (e.g. a call to block_gimme()), so it may not be worth setting (at
2566  * compile time) and testing (at runtime) maybe_flag if the scalar verses
2567  * boolean costs savings are marginal.
2568  *
2569  * However, we can do slightly better with && (compared to || and //):
2570  * this op only returns its LH argument when that argument is false. In
2571  * this case, as long as the op promises to return a false value which is
2572  * valid in both boolean and scalar contexts, we can mark an op consumed
2573  * by && with bool_flag rather than maybe_flag.
2574  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
2575  * than &PL_sv_no for a false result in boolean context, then it's safe. An
2576  * op which promises to handle this case is indicated by setting safe_and
2577  * to true.
2578  */
2579
2580 static void
2581 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
2582 {
2583     OP *lop;
2584     U8 flag = 0;
2585
2586     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
2587
2588     /* OPpTARGET_MY and boolean context probably don't mix well.
2589      * If someone finds a valid use case, maybe add an extra flag to this
2590      * function which indicates its safe to do so for this op? */
2591     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
2592              && (o->op_private & OPpTARGET_MY)));
2593
2594     lop = o->op_next;
2595
2596     while (lop) {
2597         switch (lop->op_type) {
2598         case OP_NULL:
2599         case OP_SCALAR:
2600             break;
2601
2602         /* these two consume the stack argument in the scalar case,
2603          * and treat it as a boolean in the non linenumber case */
2604         case OP_FLIP:
2605         case OP_FLOP:
2606             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
2607                 || (lop->op_private & OPpFLIP_LINENUM))
2608             {
2609                 lop = NULL;
2610                 break;
2611             }
2612             /* FALLTHROUGH */
2613         /* these never leave the original value on the stack */
2614         case OP_NOT:
2615         case OP_XOR:
2616         case OP_COND_EXPR:
2617         case OP_GREPWHILE:
2618             flag = bool_flag;
2619             lop = NULL;
2620             break;
2621
2622         /* OR DOR and AND evaluate their arg as a boolean, but then may
2623          * leave the original scalar value on the stack when following the
2624          * op_next route. If not in void context, we need to ensure
2625          * that whatever follows consumes the arg only in boolean context
2626          * too.
2627          */
2628         case OP_AND:
2629             if (safe_and) {
2630                 flag = bool_flag;
2631                 lop = NULL;
2632                 break;
2633             }
2634             /* FALLTHROUGH */
2635         case OP_OR:
2636         case OP_DOR:
2637             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
2638                 flag = bool_flag;
2639                 lop = NULL;
2640             }
2641             else if (!(lop->op_flags & OPf_WANT)) {
2642                 /* unknown context - decide at runtime */
2643                 flag = maybe_flag;
2644                 lop = NULL;
2645             }
2646             break;
2647
2648         default:
2649             lop = NULL;
2650             break;
2651         }
2652
2653         if (lop)
2654             lop = lop->op_next;
2655     }
2656
2657     o->op_private |= flag;
2658 }
2659
2660 /* mechanism for deferring recursion in rpeep() */
2661
2662 #define MAX_DEFERRED 4
2663
2664 #define DEFER(o) \
2665   STMT_START { \
2666     if (defer_ix == (MAX_DEFERRED-1)) { \
2667         OP **defer = defer_queue[defer_base]; \
2668         CALL_RPEEP(*defer); \
2669         op_prune_chain_head(defer); \
2670         defer_base = (defer_base + 1) % MAX_DEFERRED; \
2671         defer_ix--; \
2672     } \
2673     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
2674   } STMT_END
2675
2676 #define IS_AND_OP(o)   (o->op_type == OP_AND)
2677 #define IS_OR_OP(o)    (o->op_type == OP_OR)
2678
2679 /* A peephole optimizer.  We visit the ops in the order they're to execute.
2680  * See the comments at the top of this file for more details about when
2681  * peep() is called */
2682
2683 void
2684 Perl_rpeep(pTHX_ OP *o)
2685 {
2686     OP* oldop = NULL;
2687     OP* oldoldop = NULL;
2688     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
2689     int defer_base = 0;
2690     int defer_ix = -1;
2691
2692     if (!o || o->op_opt)
2693         return;
2694
2695     assert(o->op_type != OP_FREED);
2696
2697     ENTER;
2698     SAVEOP();
2699     SAVEVPTR(PL_curcop);
2700     for (;; o = o->op_next) {
2701         if (o && o->op_opt)
2702             o = NULL;
2703         if (!o) {
2704             while (defer_ix >= 0) {
2705                 OP **defer =
2706                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
2707                 CALL_RPEEP(*defer);
2708                 op_prune_chain_head(defer);
2709             }
2710             break;
2711         }
2712
2713       redo:
2714
2715         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
2716         assert(!oldoldop || oldoldop->op_next == oldop);
2717         assert(!oldop    || oldop->op_next    == o);
2718
2719         /* By default, this op has now been optimised. A couple of cases below
2720            clear this again.  */
2721         o->op_opt = 1;
2722         PL_op = o;
2723
2724         /* look for a series of 1 or more aggregate derefs, e.g.
2725          *   $a[1]{foo}[$i]{$k}
2726          * and replace with a single OP_MULTIDEREF op.
2727          * Each index must be either a const, or a simple variable,
2728          *
2729          * First, look for likely combinations of starting ops,
2730          * corresponding to (global and lexical variants of)
2731          *     $a[...]   $h{...}
2732          *     $r->[...] $r->{...}
2733          *     (preceding expression)->[...]
2734          *     (preceding expression)->{...}
2735          * and if so, call maybe_multideref() to do a full inspection
2736          * of the op chain and if appropriate, replace with an
2737          * OP_MULTIDEREF
2738          */
2739         {
2740             UV action;
2741             OP *o2 = o;
2742             U8 hints = 0;
2743
2744             switch (o2->op_type) {
2745             case OP_GV:
2746                 /* $pkg[..]   :   gv[*pkg]
2747                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
2748
2749                 /* Fail if there are new op flag combinations that we're
2750                  * not aware of, rather than:
2751                  *  * silently failing to optimise, or
2752                  *  * silently optimising the flag away.
2753                  * If this ASSUME starts failing, examine what new flag
2754                  * has been added to the op, and decide whether the
2755                  * optimisation should still occur with that flag, then
2756                  * update the code accordingly. This applies to all the
2757                  * other ASSUMEs in the block of code too.
2758                  */
2759                 ASSUME(!(o2->op_flags &
2760                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
2761                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
2762
2763                 o2 = o2->op_next;
2764
2765                 if (o2->op_type == OP_RV2AV) {
2766                     action = MDEREF_AV_gvav_aelem;
2767                     goto do_deref;
2768                 }
2769
2770                 if (o2->op_type == OP_RV2HV) {
2771                     action = MDEREF_HV_gvhv_helem;
2772                     goto do_deref;
2773                 }
2774
2775                 if (o2->op_type != OP_RV2SV)
2776                     break;
2777
2778                 /* at this point we've seen gv,rv2sv, so the only valid
2779                  * construct left is $pkg->[] or $pkg->{} */
2780
2781                 ASSUME(!(o2->op_flags & OPf_STACKED));
2782                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
2783                             != (OPf_WANT_SCALAR|OPf_MOD))
2784                     break;
2785
2786                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
2787                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
2788                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
2789                     break;
2790                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
2791                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
2792                     break;
2793
2794                 o2 = o2->op_next;
2795                 if (o2->op_type == OP_RV2AV) {
2796                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
2797                     goto do_deref;
2798                 }
2799                 if (o2->op_type == OP_RV2HV) {
2800                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
2801                     goto do_deref;
2802                 }
2803                 break;
2804
2805             case OP_PADSV:
2806                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
2807
2808                 ASSUME(!(o2->op_flags &
2809                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
2810                 if ((o2->op_flags &
2811                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
2812                      != (OPf_WANT_SCALAR|OPf_MOD))
2813                     break;
2814
2815                 ASSUME(!(o2->op_private &
2816                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
2817                 /* skip if state or intro, or not a deref */
2818                 if (      o2->op_private != OPpDEREF_AV
2819                        && o2->op_private != OPpDEREF_HV)
2820                     break;
2821
2822                 o2 = o2->op_next;
2823                 if (o2->op_type == OP_RV2AV) {
2824                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
2825                     goto do_deref;
2826                 }
2827                 if (o2->op_type == OP_RV2HV) {
2828                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
2829                     goto do_deref;
2830                 }
2831                 break;
2832
2833             case OP_PADAV:
2834             case OP_PADHV:
2835                 /*    $lex[..]:  padav[@lex:1,2] sR *
2836                  * or $lex{..}:  padhv[%lex:1,2] sR */
2837                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
2838                                             OPf_REF|OPf_SPECIAL)));
2839                 if ((o2->op_flags &
2840                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
2841                      != (OPf_WANT_SCALAR|OPf_REF))
2842                     break;
2843                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
2844                     break;
2845                 /* OPf_PARENS isn't currently used in this case;
2846                  * if that changes, let us know! */
2847                 ASSUME(!(o2->op_flags & OPf_PARENS));
2848
2849                 /* at this point, we wouldn't expect any of the remaining
2850                  * possible private flags:
2851                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
2852                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
2853                  *
2854                  * OPpSLICEWARNING shouldn't affect runtime
2855                  */
2856                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
2857
2858                 action = o2->op_type == OP_PADAV
2859                             ? MDEREF_AV_padav_aelem
2860                             : MDEREF_HV_padhv_helem;
2861                 o2 = o2->op_next;
2862                 S_maybe_multideref(aTHX_ o, o2, action, 0);
2863                 break;
2864
2865
2866             case OP_RV2AV:
2867             case OP_RV2HV:
2868                 action = o2->op_type == OP_RV2AV
2869                             ? MDEREF_AV_pop_rv2av_aelem
2870                             : MDEREF_HV_pop_rv2hv_helem;
2871                 /* FALLTHROUGH */
2872             do_deref:
2873                 /* (expr)->[...]:  rv2av sKR/1;
2874                  * (expr)->{...}:  rv2hv sKR/1; */
2875
2876                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
2877
2878                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
2879                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
2880                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
2881                     break;
2882
2883                 /* at this point, we wouldn't expect any of these
2884                  * possible private flags:
2885                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
2886                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
2887                  */
2888                 ASSUME(!(o2->op_private &
2889                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
2890                      |OPpOUR_INTRO)));
2891                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
2892
2893                 o2 = o2->op_next;
2894
2895                 S_maybe_multideref(aTHX_ o, o2, action, hints);
2896                 break;
2897
2898             default:
2899                 break;
2900             }
2901         }
2902
2903
2904         switch (o->op_type) {
2905         case OP_DBSTATE:
2906             PL_curcop = ((COP*)o);              /* for warnings */
2907             break;
2908         case OP_NEXTSTATE:
2909             PL_curcop = ((COP*)o);              /* for warnings */
2910
2911             /* Optimise a "return ..." at the end of a sub to just be "...".
2912              * This saves 2 ops. Before:
2913              * 1  <;> nextstate(main 1 -e:1) v ->2
2914              * 4  <@> return K ->5
2915              * 2    <0> pushmark s ->3
2916              * -    <1> ex-rv2sv sK/1 ->4
2917              * 3      <#> gvsv[*cat] s ->4
2918              *
2919              * After:
2920              * -  <@> return K ->-
2921              * -    <0> pushmark s ->2
2922              * -    <1> ex-rv2sv sK/1 ->-
2923              * 2      <$> gvsv(*cat) s ->3
2924              */
2925             {
2926                 OP *next = o->op_next;
2927                 OP *sibling = OpSIBLING(o);
2928                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
2929                     && OP_TYPE_IS(sibling, OP_RETURN)
2930                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
2931                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
2932                        ||OP_TYPE_IS(sibling->op_next->op_next,
2933                                     OP_LEAVESUBLV))
2934                     && cUNOPx(sibling)->op_first == next
2935                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
2936                     && next->op_next
2937                 ) {
2938                     /* Look through the PUSHMARK's siblings for one that
2939                      * points to the RETURN */
2940                     OP *top = OpSIBLING(next);
2941                     while (top && top->op_next) {
2942                         if (top->op_next == sibling) {
2943                             top->op_next = sibling->op_next;
2944                             o->op_next = next->op_next;
2945                             break;
2946                         }
2947                         top = OpSIBLING(top);
2948                     }
2949                 }
2950             }
2951
2952             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
2953              *
2954              * This latter form is then suitable for conversion into padrange
2955              * later on. Convert:
2956              *
2957              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
2958              *
2959              * into:
2960              *
2961              *   nextstate1 ->     listop     -> nextstate3
2962              *                 /            \
2963              *         pushmark -> padop1 -> padop2
2964              */
2965             if (o->op_next && (
2966                     o->op_next->op_type == OP_PADSV
2967                  || o->op_next->op_type == OP_PADAV
2968                  || o->op_next->op_type == OP_PADHV
2969                 )
2970                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
2971                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
2972                 && o->op_next->op_next->op_next && (
2973                     o->op_next->op_next->op_next->op_type == OP_PADSV
2974                  || o->op_next->op_next->op_next->op_type == OP_PADAV
2975                  || o->op_next->op_next->op_next->op_type == OP_PADHV
2976                 )
2977                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
2978                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
2979                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
2980                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
2981             ) {
2982                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
2983
2984                 pad1 =    o->op_next;
2985                 ns2  = pad1->op_next;
2986                 pad2 =  ns2->op_next;
2987                 ns3  = pad2->op_next;
2988
2989                 /* we assume here that the op_next chain is the same as
2990                  * the op_sibling chain */
2991                 assert(OpSIBLING(o)    == pad1);
2992                 assert(OpSIBLING(pad1) == ns2);
2993                 assert(OpSIBLING(ns2)  == pad2);
2994                 assert(OpSIBLING(pad2) == ns3);
2995
2996                 /* excise and delete ns2 */
2997                 op_sibling_splice(NULL, pad1, 1, NULL);
2998                 op_free(ns2);
2999
3000                 /* excise pad1 and pad2 */
3001                 op_sibling_splice(NULL, o, 2, NULL);
3002
3003                 /* create new listop, with children consisting of:
3004                  * a new pushmark, pad1, pad2. */
3005                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
3006                 newop->op_flags |= OPf_PARENS;
3007                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
3008
3009                 /* insert newop between o and ns3 */
3010                 op_sibling_splice(NULL, o, 0, newop);
3011
3012                 /*fixup op_next chain */
3013                 newpm = cUNOPx(newop)->op_first; /* pushmark */
3014                 o    ->op_next = newpm;
3015                 newpm->op_next = pad1;
3016                 pad1 ->op_next = pad2;
3017                 pad2 ->op_next = newop; /* listop */
3018                 newop->op_next = ns3;
3019
3020                 /* Ensure pushmark has this flag if padops do */
3021                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
3022                     newpm->op_flags |= OPf_MOD;
3023                 }
3024
3025                 break;
3026             }
3027
3028             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
3029                to carry two labels. For now, take the easier option, and skip
3030                this optimisation if the first NEXTSTATE has a label.  */
3031             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
3032                 OP *nextop = o->op_next;
3033                 while (nextop) {
3034                     switch (nextop->op_type) {
3035                         case OP_NULL:
3036                         case OP_SCALAR:
3037                         case OP_LINESEQ:
3038                         case OP_SCOPE:
3039                             nextop = nextop->op_next;
3040                             continue;
3041                     }
3042                     break;
3043                 }
3044
3045                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
3046                     op_null(o);
3047                     if (oldop)
3048                         oldop->op_next = nextop;
3049                     o = nextop;
3050                     /* Skip (old)oldop assignment since the current oldop's
3051                        op_next already points to the next op.  */
3052                     goto redo;
3053                 }
3054             }
3055             break;
3056
3057         case OP_CONCAT:
3058             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
3059                 if (o->op_next->op_private & OPpTARGET_MY) {
3060                     if (o->op_flags & OPf_STACKED) /* chained concats */
3061                         break; /* ignore_optimization */
3062                     else {
3063                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
3064                         o->op_targ = o->op_next->op_targ;
3065                         o->op_next->op_targ = 0;
3066                         o->op_private |= OPpTARGET_MY;
3067                     }
3068                 }
3069                 op_null(o->op_next);
3070             }
3071             break;
3072         case OP_STUB:
3073             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3074                 break; /* Scalar stub must produce undef.  List stub is noop */
3075             }
3076             goto nothin;
3077         case OP_NULL:
3078             if (o->op_targ == OP_NEXTSTATE
3079                 || o->op_targ == OP_DBSTATE)
3080             {
3081                 PL_curcop = ((COP*)o);
3082             }
3083             /* XXX: We avoid setting op_seq here to prevent later calls
3084                to rpeep() from mistakenly concluding that optimisation
3085                has already occurred. This doesn't fix the real problem,
3086                though (See 20010220.007 (#5874)). AMS 20010719 */
3087             /* op_seq functionality is now replaced by op_opt */
3088             o->op_opt = 0;
3089             /* FALLTHROUGH */
3090         case OP_SCALAR:
3091         case OP_LINESEQ:
3092         case OP_SCOPE:
3093         nothin:
3094             if (oldop) {
3095                 oldop->op_next = o->op_next;
3096                 o->op_opt = 0;
3097                 continue;
3098             }
3099             break;
3100
3101         case OP_PUSHMARK:
3102
3103             /* Given
3104                  5 repeat/DOLIST
3105                  3   ex-list
3106                  1     pushmark
3107                  2     scalar or const
3108                  4   const[0]
3109                convert repeat into a stub with no kids.
3110              */
3111             if (o->op_next->op_type == OP_CONST
3112              || (  o->op_next->op_type == OP_PADSV
3113                 && !(o->op_next->op_private & OPpLVAL_INTRO))
3114              || (  o->op_next->op_type == OP_GV
3115                 && o->op_next->op_next->op_type == OP_RV2SV
3116                 && !(o->op_next->op_next->op_private
3117                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
3118             {
3119                 const OP *kid = o->op_next->op_next;
3120                 if (o->op_next->op_type == OP_GV)
3121                    kid = kid->op_next;
3122                 /* kid is now the ex-list.  */
3123                 if (kid->op_type == OP_NULL
3124                  && (kid = kid->op_next)->op_type == OP_CONST
3125                     /* kid is now the repeat count.  */
3126                  && kid->op_next->op_type == OP_REPEAT
3127                  && kid->op_next->op_private & OPpREPEAT_DOLIST
3128                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
3129                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
3130                  && oldop)
3131                 {
3132                     o = kid->op_next; /* repeat */
3133                     oldop->op_next = o;
3134                     op_free(cBINOPo->op_first);
3135                     op_free(cBINOPo->op_last );
3136                     o->op_flags &=~ OPf_KIDS;
3137                     /* stub is a baseop; repeat is a binop */
3138                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
3139                     OpTYPE_set(o, OP_STUB);
3140                     o->op_private = 0;
3141                     break;
3142                 }
3143             }
3144
3145             /* Convert a series of PAD ops for my vars plus support into a
3146              * single padrange op. Basically
3147              *
3148              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
3149              *
3150              * becomes, depending on circumstances, one of
3151              *
3152              *    padrange  ----------------------------------> (list) -> rest
3153              *    padrange  --------------------------------------------> rest
3154              *
3155              * where all the pad indexes are sequential and of the same type
3156              * (INTRO or not).
3157              * We convert the pushmark into a padrange op, then skip
3158              * any other pad ops, and possibly some trailing ops.
3159              * Note that we don't null() the skipped ops, to make it
3160              * easier for Deparse to undo this optimisation (and none of
3161              * the skipped ops are holding any resourses). It also makes
3162              * it easier for find_uninit_var(), as it can just ignore
3163              * padrange, and examine the original pad ops.
3164              */
3165         {
3166             OP *p;
3167             OP *followop = NULL; /* the op that will follow the padrange op */
3168             U8 count = 0;
3169             U8 intro = 0;
3170             PADOFFSET base = 0; /* init only to stop compiler whining */
3171             bool gvoid = 0;     /* init only to stop compiler whining */
3172             bool defav = 0;  /* seen (...) = @_ */
3173             bool reuse = 0;  /* reuse an existing padrange op */
3174
3175             /* look for a pushmark -> gv[_] -> rv2av */
3176
3177             {
3178                 OP *rv2av, *q;
3179                 p = o->op_next;
3180                 if (   p->op_type == OP_GV
3181                     && cGVOPx_gv(p) == PL_defgv
3182                     && (rv2av = p->op_next)
3183                     && rv2av->op_type == OP_RV2AV
3184                     && !(rv2av->op_flags & OPf_REF)
3185                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
3186                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
3187                 ) {
3188                     q = rv2av->op_next;
3189                     if (q->op_type == OP_NULL)
3190                         q = q->op_next;
3191                     if (q->op_type == OP_PUSHMARK) {
3192                         defav = 1;
3193                         p = q;
3194                     }
3195                 }
3196             }
3197             if (!defav) {
3198                 p = o;
3199             }
3200
3201             /* scan for PAD ops */
3202
3203             for (p = p->op_next; p; p = p->op_next) {
3204                 if (p->op_type == OP_NULL)
3205                     continue;
3206
3207                 if ((     p->op_type != OP_PADSV
3208                        && p->op_type != OP_PADAV
3209                        && p->op_type != OP_PADHV
3210                     )
3211                       /* any private flag other than INTRO? e.g. STATE */
3212                    || (p->op_private & ~OPpLVAL_INTRO)
3213                 )
3214                     break;
3215
3216                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
3217                  * instead */
3218                 if (   p->op_type == OP_PADAV
3219                     && p->op_next
3220                     && p->op_next->op_type == OP_CONST
3221                     && p->op_next->op_next
3222                     && p->op_next->op_next->op_type == OP_AELEM
3223                 )
3224                     break;
3225
3226                 /* for 1st padop, note what type it is and the range
3227                  * start; for the others, check that it's the same type
3228                  * and that the targs are contiguous */
3229                 if (count == 0) {
3230                     intro = (p->op_private & OPpLVAL_INTRO);
3231                     base = p->op_targ;
3232                     gvoid = OP_GIMME(p,0) == G_VOID;
3233                 }
3234                 else {
3235                     if ((p->op_private & OPpLVAL_INTRO) != intro)
3236                         break;
3237                     /* Note that you'd normally  expect targs to be
3238                      * contiguous in my($a,$b,$c), but that's not the case
3239                      * when external modules start doing things, e.g.
3240                      * Function::Parameters */
3241                     if (p->op_targ != base + count)
3242                         break;
3243                     assert(p->op_targ == base + count);
3244                     /* Either all the padops or none of the padops should
3245                        be in void context.  Since we only do the optimisa-
3246                        tion for av/hv when the aggregate itself is pushed
3247                        on to the stack (one item), there is no need to dis-
3248                        tinguish list from scalar context.  */
3249                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
3250                         break;
3251                 }
3252
3253                 /* for AV, HV, only when we're not flattening */
3254                 if (   p->op_type != OP_PADSV
3255                     && !gvoid
3256                     && !(p->op_flags & OPf_REF)
3257                 )
3258                     break;
3259
3260                 if (count >= OPpPADRANGE_COUNTMASK)
3261                     break;
3262
3263                 /* there's a biggest base we can fit into a
3264                  * SAVEt_CLEARPADRANGE in pp_padrange.
3265                  * (The sizeof() stuff will be constant-folded, and is
3266                  * intended to avoid getting "comparison is always false"
3267                  * compiler warnings. See the comments above
3268                  * MEM_WRAP_CHECK for more explanation on why we do this
3269                  * in a weird way to avoid compiler warnings.)
3270                  */
3271                 if (   intro
3272                     && (8*sizeof(base) >
3273                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
3274                         ? (Size_t)base
3275                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
3276                         ) >
3277                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
3278                 )
3279                     break;
3280
3281                 /* Success! We've got another valid pad op to optimise away */
3282                 count++;
3283                 followop = p->op_next;
3284             }
3285
3286             if (count < 1 || (count == 1 && !defav))
3287                 break;
3288
3289             /* pp_padrange in specifically compile-time void context
3290              * skips pushing a mark and lexicals; in all other contexts
3291              * (including unknown till runtime) it pushes a mark and the
3292              * lexicals. We must be very careful then, that the ops we
3293              * optimise away would have exactly the same effect as the
3294              * padrange.
3295              * In particular in void context, we can only optimise to
3296              * a padrange if we see the complete sequence
3297              *     pushmark, pad*v, ...., list
3298              * which has the net effect of leaving the markstack as it
3299              * was.  Not pushing onto the stack (whereas padsv does touch
3300              * the stack) makes no difference in void context.
3301              */
3302             assert(followop);
3303             if (gvoid) {
3304                 if (followop->op_type == OP_LIST
3305                         && OP_GIMME(followop,0) == G_VOID
3306                    )
3307                 {
3308                     followop = followop->op_next; /* skip OP_LIST */
3309
3310                     /* consolidate two successive my(...);'s */
3311
3312                     if (   oldoldop
3313                         && oldoldop->op_type == OP_PADRANGE
3314                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
3315                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
3316                         && !(oldoldop->op_flags & OPf_SPECIAL)
3317                     ) {
3318                         U8 old_count;
3319                         assert(oldoldop->op_next == oldop);
3320                         assert(   oldop->op_type == OP_NEXTSTATE
3321                                || oldop->op_type == OP_DBSTATE);
3322                         assert(oldop->op_next == o);
3323
3324                         old_count
3325                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
3326
3327                        /* Do not assume pad offsets for $c and $d are con-
3328                           tiguous in
3329                             my ($a,$b,$c);
3330                             my ($d,$e,$f);
3331                         */
3332                         if (  oldoldop->op_targ + old_count == base
3333                            && old_count < OPpPADRANGE_COUNTMASK - count) {
3334                             base = oldoldop->op_targ;
3335                             count += old_count;
3336                             reuse = 1;
3337                         }
3338                     }
3339
3340                     /* if there's any immediately following singleton
3341                      * my var's; then swallow them and the associated
3342                      * nextstates; i.e.
3343                      *    my ($a,$b); my $c; my $d;
3344                      * is treated as
3345                      *    my ($a,$b,$c,$d);
3346                      */
3347
3348                     while (    ((p = followop->op_next))
3349                             && (  p->op_type == OP_PADSV
3350                                || p->op_type == OP_PADAV
3351                                || p->op_type == OP_PADHV)
3352                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
3353                             && (p->op_private & OPpLVAL_INTRO) == intro
3354                             && !(p->op_private & ~OPpLVAL_INTRO)
3355                             && p->op_next
3356                             && (   p->op_next->op_type == OP_NEXTSTATE
3357                                 || p->op_next->op_type == OP_DBSTATE)
3358                             && count < OPpPADRANGE_COUNTMASK
3359                             && base + count == p->op_targ
3360                     ) {
3361                         count++;
3362                         followop = p->op_next;
3363                     }
3364                 }
3365                 else
3366                     break;
3367             }
3368
3369             if (reuse) {
3370                 assert(oldoldop->op_type == OP_PADRANGE);
3371                 oldoldop->op_next = followop;
3372                 oldoldop->op_private = (intro | count);
3373                 o = oldoldop;
3374                 oldop = NULL;
3375                 oldoldop = NULL;
3376             }
3377             else {
3378                 /* Convert the pushmark into a padrange.
3379                  * To make Deparse easier, we guarantee that a padrange was
3380                  * *always* formerly a pushmark */
3381                 assert(o->op_type == OP_PUSHMARK);
3382                 o->op_next = followop;
3383                 OpTYPE_set(o, OP_PADRANGE);
3384                 o->op_targ = base;
3385                 /* bit 7: INTRO; bit 6..0: count */
3386                 o->op_private = (intro | count);
3387                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
3388                               | gvoid * OPf_WANT_VOID
3389                               | (defav ? OPf_SPECIAL : 0));
3390             }
3391             break;
3392         }
3393
3394         case OP_RV2AV:
3395             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
3396                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
3397             break;
3398
3399         case OP_RV2HV:
3400         case OP_PADHV:
3401             /*'keys %h' in void or scalar context: skip the OP_KEYS
3402              * and perform the functionality directly in the RV2HV/PADHV
3403              * op
3404              */
3405             if (o->op_flags & OPf_REF) {
3406                 OP *k = o->op_next;
3407                 U8 want = (k->op_flags & OPf_WANT);
3408                 if (   k
3409                     && k->op_type == OP_KEYS
3410                     && (   want == OPf_WANT_VOID
3411                         || want == OPf_WANT_SCALAR)
3412                     && !(k->op_private & OPpMAYBE_LVSUB)
3413                     && !(k->op_flags & OPf_MOD)
3414                 ) {
3415                     o->op_next     = k->op_next;
3416                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
3417                     o->op_flags   |= want;
3418                     o->op_private |= (o->op_type == OP_PADHV ?
3419                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
3420                     /* for keys(%lex), hold onto the OP_KEYS's targ
3421                      * since padhv doesn't have its own targ to return
3422                      * an int with */
3423                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
3424                         op_null(k);
3425                 }
3426             }
3427
3428             /* see if %h is used in boolean context */
3429             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
3430                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
3431
3432
3433             if (o->op_type != OP_PADHV)
3434                 break;
3435             /* FALLTHROUGH */
3436         case OP_PADAV:
3437             if (   o->op_type == OP_PADAV
3438                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
3439             )
3440                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
3441             /* FALLTHROUGH */
3442         case OP_PADSV:
3443             /* Skip over state($x) in void context.  */
3444             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
3445              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
3446             {
3447                 oldop->op_next = o->op_next;
3448                 goto redo_nextstate;
3449             }
3450             if (o->op_type != OP_PADAV)
3451                 break;
3452             /* FALLTHROUGH */
3453         case OP_GV:
3454             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
3455                 OP* const pop = (o->op_type == OP_PADAV) ?
3456                             o->op_next : o->op_next->op_next;
3457                 IV i;
3458                 if (pop && pop->op_type == OP_CONST &&
3459                     ((PL_op = pop->op_next)) &&
3460                     pop->op_next->op_type == OP_AELEM &&
3461                     !(pop->op_next->op_private &
3462                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
3463                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
3464                 {
3465                     GV *gv;
3466                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
3467                         no_bareword_allowed(pop);
3468                     if (o->op_type == OP_GV)
3469                         op_null(o->op_next);
3470                     op_null(pop->op_next);
3471                     op_null(pop);
3472                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
3473                     o->op_next = pop->op_next->op_next;
3474                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
3475                     o->op_private = (U8)i;
3476                     if (o->op_type == OP_GV) {
3477                         gv = cGVOPo_gv;
3478                         GvAVn(gv);
3479                         o->op_type = OP_AELEMFAST;
3480                     }
3481                     else
3482                         o->op_type = OP_AELEMFAST_LEX;
3483                 }
3484                 if (o->op_type != OP_GV)
3485                     break;
3486             }
3487
3488             /* Remove $foo from the op_next chain in void context.  */
3489             if (oldop
3490              && (  o->op_next->op_type == OP_RV2SV
3491                 || o->op_next->op_type == OP_RV2AV
3492                 || o->op_next->op_type == OP_RV2HV  )
3493              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
3494              && !(o->op_next->op_private & OPpLVAL_INTRO))
3495             {
3496                 oldop->op_next = o->op_next->op_next;
3497                 /* Reprocess the previous op if it is a nextstate, to
3498                    allow double-nextstate optimisation.  */
3499               redo_nextstate:
3500                 if (oldop->op_type == OP_NEXTSTATE) {
3501                     oldop->op_opt = 0;
3502                     o = oldop;
3503                     oldop = oldoldop;
3504                     oldoldop = NULL;
3505                     goto redo;
3506                 }
3507                 o = oldop->op_next;
3508                 goto redo;
3509             }
3510             else if (o->op_next->op_type == OP_RV2SV) {
3511                 if (!(o->op_next->op_private & OPpDEREF)) {
3512                     op_null(o->op_next);
3513                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
3514                                                                | OPpOUR_INTRO);
3515                     o->op_next = o->op_next->op_next;
3516                     OpTYPE_set(o, OP_GVSV);
3517                 }
3518             }
3519             else if (o->op_next->op_type == OP_READLINE
3520                     && o->op_next->op_next->op_type == OP_CONCAT
3521                     && (o->op_next->op_next->op_flags & OPf_STACKED))
3522             {
3523                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
3524                 OpTYPE_set(o, OP_RCATLINE);
3525                 o->op_flags |= OPf_STACKED;
3526                 op_null(o->op_next->op_next);
3527                 op_null(o->op_next);
3528             }
3529
3530             break;
3531
3532         case OP_NOT:
3533             break;
3534
3535         case OP_AND:
3536         case OP_OR:
3537         case OP_DOR:
3538         case OP_CMPCHAIN_AND:
3539         case OP_PUSHDEFER:
3540             while (cLOGOP->op_other->op_type == OP_NULL)
3541                 cLOGOP->op_other = cLOGOP->op_other->op_next;
3542             while (o->op_next && (   o->op_type == o->op_next->op_type
3543                                   || o->op_next->op_type == OP_NULL))
3544                 o->op_next = o->op_next->op_next;
3545
3546             /* If we're an OR and our next is an AND in void context, we'll
3547                follow its op_other on short circuit, same for reverse.
3548                We can't do this with OP_DOR since if it's true, its return
3549                value is the underlying value which must be evaluated
3550                by the next op. */
3551             if (o->op_next &&
3552                 (
3553                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
3554                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
3555                 )
3556                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
3557             ) {
3558                 o->op_next = ((LOGOP*)o->op_next)->op_other;
3559             }
3560             DEFER(cLOGOP->op_other);
3561             o->op_opt = 1;
3562             break;
3563
3564         case OP_GREPWHILE:
3565             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
3566                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
3567             /* FALLTHROUGH */
3568         case OP_COND_EXPR:
3569         case OP_MAPWHILE:
3570         case OP_ANDASSIGN:
3571         case OP_ORASSIGN:
3572         case OP_DORASSIGN:
3573         case OP_RANGE:
3574         case OP_ONCE:
3575         case OP_ARGDEFELEM:
3576             while (cLOGOP->op_other->op_type == OP_NULL)
3577                 cLOGOP->op_other = cLOGOP->op_other->op_next;
3578             DEFER(cLOGOP->op_other);
3579             break;
3580
3581         case OP_ENTERLOOP:
3582         case OP_ENTERITER:
3583             while (cLOOP->op_redoop->op_type == OP_NULL)
3584                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
3585             while (cLOOP->op_nextop->op_type == OP_NULL)
3586                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
3587             while (cLOOP->op_lastop->op_type == OP_NULL)
3588                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
3589             /* a while(1) loop doesn't have an op_next that escapes the
3590              * loop, so we have to explicitly follow the op_lastop to
3591              * process the rest of the code */
3592             DEFER(cLOOP->op_lastop);
3593             break;
3594
3595         case OP_ENTERTRY:
3596             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
3597             DEFER(cLOGOPo->op_other);
3598             break;
3599
3600         case OP_ENTERTRYCATCH:
3601             assert(cLOGOPo->op_other->op_type == OP_CATCH);
3602             /* catch body is the ->op_other of the OP_CATCH */
3603             DEFER(cLOGOPx(cLOGOPo->op_other)->op_other);
3604             break;
3605
3606         case OP_SUBST:
3607             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
3608                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
3609             assert(!(cPMOP->op_pmflags & PMf_ONCE));
3610             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
3611                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
3612                 cPMOP->op_pmstashstartu.op_pmreplstart
3613                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
3614             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
3615             break;
3616
3617         case OP_SORT: {
3618             OP *oright;
3619
3620             if (o->op_flags & OPf_SPECIAL) {
3621                 /* first arg is a code block */
3622                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
3623                 OP * kid          = cUNOPx(nullop)->op_first;
3624
3625                 assert(nullop->op_type == OP_NULL);
3626                 assert(kid->op_type == OP_SCOPE
3627                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
3628                 /* since OP_SORT doesn't have a handy op_other-style
3629                  * field that can point directly to the start of the code
3630                  * block, store it in the otherwise-unused op_next field
3631                  * of the top-level OP_NULL. This will be quicker at
3632                  * run-time, and it will also allow us to remove leading
3633                  * OP_NULLs by just messing with op_nexts without
3634                  * altering the basic op_first/op_sibling layout. */
3635                 kid = kLISTOP->op_first;
3636                 assert(
3637                       (kid->op_type == OP_NULL
3638                       && (  kid->op_targ == OP_NEXTSTATE
3639                          || kid->op_targ == OP_DBSTATE  ))
3640                     || kid->op_type == OP_STUB
3641                     || kid->op_type == OP_ENTER
3642                     || (PL_parser && PL_parser->error_count));
3643                 nullop->op_next = kid->op_next;
3644                 DEFER(nullop->op_next);
3645             }
3646
3647             /* check that RHS of sort is a single plain array */
3648             oright = cUNOPo->op_first;
3649             if (!oright || oright->op_type != OP_PUSHMARK)
3650                 break;
3651
3652             if (o->op_private & OPpSORT_INPLACE)
3653                 break;
3654
3655             /* reverse sort ... can be optimised.  */
3656             if (!OpHAS_SIBLING(cUNOPo)) {
3657                 /* Nothing follows us on the list. */
3658                 OP * const reverse = o->op_next;
3659
3660                 if (reverse->op_type == OP_REVERSE &&
3661                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
3662                     OP * const pushmark = cUNOPx(reverse)->op_first;
3663                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
3664                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
3665                         /* reverse -> pushmark -> sort */
3666                         o->op_private |= OPpSORT_REVERSE;
3667                         op_null(reverse);
3668                         pushmark->op_next = oright->op_next;
3669                         op_null(oright);
3670                     }
3671                 }
3672             }
3673
3674             break;
3675         }
3676
3677         case OP_REVERSE: {
3678             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
3679             OP *gvop = NULL;
3680             LISTOP *enter, *exlist;
3681
3682             if (o->op_private & OPpSORT_INPLACE)
3683                 break;
3684
3685             enter = (LISTOP *) o->op_next;
3686             if (!enter)
3687                 break;
3688             if (enter->op_type == OP_NULL) {
3689                 enter = (LISTOP *) enter->op_next;
3690                 if (!enter)
3691                     break;
3692             }
3693             /* for $a (...) will have OP_GV then OP_RV2GV here.
3694                for (...) just has an OP_GV.  */
3695             if (enter->op_type == OP_GV) {
3696                 gvop = (OP *) enter;
3697                 enter = (LISTOP *) enter->op_next;
3698                 if (!enter)
3699                     break;
3700                 if (enter->op_type == OP_RV2GV) {
3701                   enter = (LISTOP *) enter->op_next;
3702                   if (!enter)
3703                     break;
3704                 }
3705             }
3706
3707             if (enter->op_type != OP_ENTERITER)
3708                 break;
3709
3710             iter = enter->op_next;
3711             if (!iter || iter->op_type != OP_ITER)
3712                 break;
3713
3714             expushmark = enter->op_first;
3715             if (!expushmark || expushmark->op_type != OP_NULL
3716                 || expushmark->op_targ != OP_PUSHMARK)
3717                 break;
3718
3719             exlist = (LISTOP *) OpSIBLING(expushmark);
3720             if (!exlist || exlist->op_type != OP_NULL
3721                 || exlist->op_targ != OP_LIST)
3722                 break;
3723
3724             if (exlist->op_last != o) {
3725                 /* Mmm. Was expecting to point back to this op.  */
3726                 break;
3727             }
3728             theirmark = exlist->op_first;
3729             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
3730                 break;
3731
3732             if (OpSIBLING(theirmark) != o) {
3733                 /* There's something between the mark and the reverse, eg
3734                    for (1, reverse (...))
3735                    so no go.  */
3736                 break;
3737             }
3738
3739             ourmark = ((LISTOP *)o)->op_first;
3740             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
3741                 break;
3742
3743             ourlast = ((LISTOP *)o)->op_last;
3744             if (!ourlast || ourlast->op_next != o)
3745                 break;
3746
3747             rv2av = OpSIBLING(ourmark);
3748             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
3749                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
3750                 /* We're just reversing a single array.  */
3751                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
3752                 enter->op_flags |= OPf_STACKED;
3753             }
3754
3755             /* We don't have control over who points to theirmark, so sacrifice
3756                ours.  */
3757             theirmark->op_next = ourmark->op_next;
3758             theirmark->op_flags = ourmark->op_flags;
3759             ourlast->op_next = gvop ? gvop : (OP *) enter;
3760             op_null(ourmark);
3761             op_null(o);
3762             enter->op_private |= OPpITER_REVERSED;
3763             iter->op_private |= OPpITER_REVERSED;
3764
3765             oldoldop = NULL;
3766             oldop    = ourlast;
3767             o        = oldop->op_next;
3768             goto redo;
3769             NOT_REACHED; /* NOTREACHED */
3770             break;
3771         }
3772
3773         case OP_QR:
3774         case OP_MATCH:
3775             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
3776                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
3777             }
3778             break;
3779
3780         case OP_RUNCV:
3781             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
3782              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
3783             {
3784                 SV *sv;
3785                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
3786                 else {
3787                     sv = newRV((SV *)PL_compcv);
3788                     sv_rvweaken(sv);
3789                     SvREADONLY_on(sv);
3790                 }
3791                 OpTYPE_set(o, OP_CONST);
3792                 o->op_flags |= OPf_SPECIAL;
3793                 cSVOPo->op_sv = sv;
3794             }
3795             break;
3796
3797         case OP_SASSIGN:
3798             if (OP_GIMME(o,0) == G_VOID
3799              || (  o->op_next->op_type == OP_LINESEQ
3800                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
3801                    || (  o->op_next->op_next->op_type == OP_RETURN
3802                       && !CvLVALUE(PL_compcv)))))
3803             {
3804                 OP *right = cBINOP->op_first;
3805                 if (right) {
3806                     /*   sassign
3807                     *      RIGHT
3808                     *      substr
3809                     *         pushmark
3810                     *         arg1
3811                     *         arg2
3812                     *         ...
3813                     * becomes
3814                     *
3815                     *  ex-sassign
3816                     *     substr
3817                     *        pushmark
3818                     *        RIGHT
3819                     *        arg1
3820                     *        arg2
3821                     *        ...
3822                     */
3823                     OP *left = OpSIBLING(right);
3824                     if (left->op_type == OP_SUBSTR
3825                          && (left->op_private & 7) < 4) {
3826                         op_null(o);
3827                         /* cut out right */
3828                         op_sibling_splice(o, NULL, 1, NULL);
3829                         /* and insert it as second child of OP_SUBSTR */
3830                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
3831                                     right);
3832                         left->op_private |= OPpSUBSTR_REPL_FIRST;
3833                         left->op_flags =
3834                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
3835                     }
3836                 }
3837             }
3838             break;
3839
3840         case OP_AASSIGN: {
3841             int l, r, lr, lscalars, rscalars;
3842
3843             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
3844                Note that we do this now rather than in newASSIGNOP(),
3845                since only by now are aliased lexicals flagged as such
3846
3847                See the essay "Common vars in list assignment" above for
3848                the full details of the rationale behind all the conditions
3849                below.
3850
3851                PL_generation sorcery:
3852                To detect whether there are common vars, the global var
3853                PL_generation is incremented for each assign op we scan.
3854                Then we run through all the lexical variables on the LHS,
3855                of the assignment, setting a spare slot in each of them to
3856                PL_generation.  Then we scan the RHS, and if any lexicals
3857                already have that value, we know we've got commonality.
3858                Also, if the generation number is already set to
3859                PERL_INT_MAX, then the variable is involved in aliasing, so
3860                we also have potential commonality in that case.
3861              */
3862
3863             PL_generation++;
3864             /* scan LHS */
3865             lscalars = 0;
3866             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, &lscalars);
3867             /* scan RHS */
3868             rscalars = 0;
3869             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
3870             lr = (l|r);
3871
3872
3873             /* After looking for things which are *always* safe, this main
3874              * if/else chain selects primarily based on the type of the
3875              * LHS, gradually working its way down from the more dangerous
3876              * to the more restrictive and thus safer cases */
3877
3878             if (   !l                      /* () = ....; */
3879                 || !r                      /* .... = (); */
3880                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
3881                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
3882                 || (lscalars < 2)          /* (undef, $x) = ... */
3883             ) {
3884                 NOOP; /* always safe */
3885             }
3886             else if (l & AAS_DANGEROUS) {
3887                 /* always dangerous */
3888                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
3889                 o->op_private |= OPpASSIGN_COMMON_AGG;
3890             }
3891             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
3892                 /* package vars are always dangerous - too many
3893                  * aliasing possibilities */
3894                 if (l & AAS_PKG_SCALAR)
3895                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
3896                 if (l & AAS_PKG_AGG)
3897                     o->op_private |= OPpASSIGN_COMMON_AGG;
3898             }
3899             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
3900                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
3901             {
3902                 /* LHS contains only lexicals and safe ops */
3903
3904                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
3905                     o->op_private |= OPpASSIGN_COMMON_AGG;
3906
3907                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
3908                     if (lr & AAS_LEX_SCALAR_COMM)
3909                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
3910                     else if (   !(l & AAS_LEX_SCALAR)
3911                              && (r & AAS_DEFAV))
3912                     {
3913                         /* falsely mark
3914                          *    my (...) = @_
3915                          * as scalar-safe for performance reasons.
3916                          * (it will still have been marked _AGG if necessary */
3917                         NOOP;
3918                     }
3919                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
3920                         /* if there are only lexicals on the LHS and no
3921                          * common ones on the RHS, then we assume that the
3922                          * only way those lexicals could also get
3923                          * on the RHS is via some sort of dereffing or
3924                          * closure, e.g.
3925                          *    $r = \$lex;
3926                          *    ($lex, $x) = (1, $$r)
3927                          * and in this case we assume the var must have
3928                          *  a bumped ref count. So if its ref count is 1,
3929                          *  it must only be on the LHS.
3930                          */
3931                         o->op_private |= OPpASSIGN_COMMON_RC1;
3932                 }
3933             }
3934
3935             /* ... = ($x)
3936              * may have to handle aggregate on LHS, but we can't
3937              * have common scalars. */
3938             if (rscalars < 2)
3939                 o->op_private &=
3940                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
3941
3942             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
3943                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
3944             break;
3945         }
3946
3947         case OP_REF:
3948         case OP_BLESSED:
3949             /* if the op is used in boolean context, set the TRUEBOOL flag
3950              * which enables an optimisation at runtime which avoids creating
3951              * a stack temporary for known-true package names */
3952             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
3953                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
3954             break;
3955
3956         case OP_LENGTH:
3957             /* see if the op is used in known boolean context,
3958              * but not if OA_TARGLEX optimisation is enabled */
3959             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
3960                 && !(o->op_private & OPpTARGET_MY)
3961             )
3962                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
3963             break;
3964
3965         case OP_POS:
3966             /* see if the op is used in known boolean context */
3967             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
3968                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
3969             break;
3970
3971         case OP_CUSTOM: {
3972             Perl_cpeep_t cpeep =
3973                 XopENTRYCUSTOM(o, xop_peep);
3974             if (cpeep)
3975                 cpeep(aTHX_ o, oldop);
3976             break;
3977         }
3978
3979         }
3980         /* did we just null the current op? If so, re-process it to handle
3981          * eliding "empty" ops from the chain */
3982         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
3983             o->op_opt = 0;
3984             o = oldop;
3985         }
3986         else {
3987             oldoldop = oldop;
3988             oldop = o;
3989         }
3990     }
3991     LEAVE;
3992 }
3993
3994 void
3995 Perl_peep(pTHX_ OP *o)
3996 {
3997     CALL_RPEEP(o);
3998 }
3999
4000 /*
4001  * ex: set ts=8 sts=4 sw=4 et:
4002  */