peep.c

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