op.c: Rmv redundant line in tr/// table

[perl5.git] / op.c

#line 2 "op.c"
/*    op.c
 *
 *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
 *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
 *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
 *  youngest of the Old Took's daughters); and Mr. Drogo was his second
 *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
 *  either way, as the saying is, if you follow me.'       --the Gaffer
 *
 *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
 */

/* This file contains the functions that create, manipulate and optimize
 * the OP structures that hold a compiled perl program.
 *
 * Note that during the build of miniperl, a temporary copy of this file
 * is made, called opmini.c.
 *
 * A Perl program is compiled into a tree of OP nodes. Each op contains:
 *  * structural OP pointers to its children and siblings (op_sibling,
 *    op_first etc) that define the tree structure;
 *  * execution order OP pointers (op_next, plus sometimes op_other,
 *    op_lastop  etc) that define the execution sequence plus variants;
 *  * a pointer to the C "pp" function that would execute the op;
 *  * any data specific to that op.
 * For example, an OP_CONST op points to the pp_const() function and to an
 * SV containing the constant value. When pp_const() is executed, its job
 * is to push that SV onto the stack.
 *
 * OPs are mainly created by the newFOO() functions, which are mainly
 * called from the parser (in perly.y) as the code is parsed. For example
 * the Perl code $a + $b * $c would cause the equivalent of the following
 * to be called (oversimplifying a bit):
 *
 *  newBINOP(OP_ADD, flags,
 *	newSVREF($a),
 *	newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
 *  )
 *
 * As the parser reduces low-level rules, it creates little op subtrees;
 * as higher-level rules are resolved, these subtrees get joined together
 * as branches on a bigger subtree, until eventually a top-level rule like
 * a subroutine definition is reduced, at which point there is one large
 * parse tree left.
 *
 * The execution order pointers (op_next) are generated as the subtrees
 * are joined together. Consider this sub-expression: A*B + C/D: at the
 * point when it's just been parsed, the op tree looks like:
 *
 *   [+]
 *    |
 *   [*]------[/]
 *    |        |
 *    A---B    C---D
 *
 * with the intended execution order being:
 *
 *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
 *
 * At this point all the nodes' op_next pointers will have been set,
 * except that:
 *    * we don't know what the [NEXT] node will be yet;
 *    * we don't know what the [PREV] node will be yet, but when it gets
 *      created and needs its op_next set, it needs to be set to point to
 *      A, which is non-obvious.
 * To handle both those cases, we temporarily set the top node's
 * op_next to point to the first node to be executed in this subtree (A in
 * this case). This means that initially a subtree's op_next chain,
 * starting from the top node, will visit each node in execution sequence
 * then point back at the top node.
 * When we embed this subtree in a larger tree, its top op_next is used
 * to get the start node, then is set to point to its new neighbour.
 * For example the two separate [*],A,B and [/],C,D subtrees would
 * initially have had:
 *   [*] => A;  A => B;  B => [*]
 * and
 *   [/] => C;  C => D;  D => [/]
 * When these two subtrees were joined together to make the [+] subtree,
 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
 * set to point to [/]'s op_next, i.e. C.
 *
 * This op_next linking is done by the LINKLIST() macro and its underlying
 * op_linklist() function. Given a top-level op, if its op_next is
 * non-null, it's already been linked, so leave it. Otherwise link it with
 * its children as described above, possibly recursively if any of the
 * children have a null op_next.
 *
 * In summary: given a subtree, its top-level node's op_next will either
 * be:
 *   NULL: the subtree hasn't been LINKLIST()ed yet;
 *   fake: points to the start op for this subtree;
 *   real: once the subtree has been embedded into a larger tree
 */

/*

Here's an older description from Larry.

Perl's compiler is essentially a 3-pass compiler with interleaved phases:

    A bottom-up pass
    A top-down pass
    An execution-order pass

The bottom-up pass is represented by all the "newOP" routines and
the ck_ routines.  The bottom-upness is actually driven by yacc.
So at the point that a ck_ routine fires, we have no idea what the
context is, either upward in the syntax tree, or either forward or
backward in the execution order.  (The bottom-up parser builds that
part of the execution order it knows about, but if you follow the "next"
links around, you'll find it's actually a closed loop through the
top level node.)

Whenever the bottom-up parser gets to a node that supplies context to
its components, it invokes that portion of the top-down pass that applies
to that part of the subtree (and marks the top node as processed, so
if a node further up supplies context, it doesn't have to take the
plunge again).  As a particular subcase of this, as the new node is
built, it takes all the closed execution loops of its subcomponents
and links them into a new closed loop for the higher level node.  But
it's still not the real execution order.

The actual execution order is not known till we get a grammar reduction
to a top-level unit like a subroutine or file that will be called by
"name" rather than via a "next" pointer.  At that point, we can call
into peep() to do that code's portion of the 3rd pass.  It has to be
recursive, but it's recursive on basic blocks, not on tree nodes.
*/

/* To implement user lexical pragmas, there needs to be a way at run time to
   get the compile time state of %^H for that block.  Storing %^H in every
   block (or even COP) would be very expensive, so a different approach is
   taken.  The (running) state of %^H is serialised into a tree of HE-like
   structs.  Stores into %^H are chained onto the current leaf as a struct
   refcounted_he * with the key and the value.  Deletes from %^H are saved
   with a value of PL_sv_placeholder.  The state of %^H at any point can be
   turned back into a regular HV by walking back up the tree from that point's
   leaf, ignoring any key you've already seen (placeholder or not), storing
   the rest into the HV structure, then removing the placeholders. Hence
   memory is only used to store the %^H deltas from the enclosing COP, rather
   than the entire %^H on each COP.

   To cause actions on %^H to write out the serialisation records, it has
   magic type 'H'. This magic (itself) does nothing, but its presence causes
   the values to gain magic type 'h', which has entries for set and clear.
   C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
   record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
   saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
   it will be correctly restored when any inner compiling scope is exited.
*/

#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
#include "keywords.h"
#include "feature.h"
#include "regcomp.h"
#include "invlist_inline.h"

#define CALL_PEEP(o) PL_peepp(aTHX_ o)
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)

static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";

/* remove any leading "empty" ops from the op_next chain whose first
 * node's address is stored in op_p. Store the updated address of the
 * first node in op_p.
 */

STATIC void
S_prune_chain_head(OP** op_p)
{
    while (*op_p
        && (   (*op_p)->op_type == OP_NULL
            || (*op_p)->op_type == OP_SCOPE
            || (*op_p)->op_type == OP_SCALAR
            || (*op_p)->op_type == OP_LINESEQ)
    )
        *op_p = (*op_p)->op_next;
}


/* See the explanatory comments above struct opslab in op.h. */

#ifdef PERL_DEBUG_READONLY_OPS
#  define PERL_SLAB_SIZE 128
#  define PERL_MAX_SLAB_SIZE 4096
#  include <sys/mman.h>
#endif

#ifndef PERL_SLAB_SIZE
#  define PERL_SLAB_SIZE 64
#endif
#ifndef PERL_MAX_SLAB_SIZE
#  define PERL_MAX_SLAB_SIZE 2048
#endif

/* rounds up to nearest pointer */
#define SIZE_TO_PSIZE(x)	(((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
#define DIFF(o,p)		((size_t)((I32 **)(p) - (I32**)(o)))

/* requires double parens and aTHX_ */
#define DEBUG_S_warn(args)					       \
    DEBUG_S( 								\
	PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
    )


/* malloc a new op slab (suitable for attaching to PL_compcv).
 * sz is in units of pointers */

static OPSLAB *
S_new_slab(pTHX_ OPSLAB *head, size_t sz)
{
    OPSLAB *slab;

    /* opslot_offset is only U16 */
    assert(sz  < U16_MAX);

#ifdef PERL_DEBUG_READONLY_OPS
    slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
				   PROT_READ|PROT_WRITE,
				   MAP_ANON|MAP_PRIVATE, -1, 0);
    DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
			  (unsigned long) sz, slab));
    if (slab == MAP_FAILED) {
	perror("mmap failed");
	abort();
    }
#else
    slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
#endif
    slab->opslab_size = (U16)sz;

#ifndef WIN32
    /* The context is unused in non-Windows */
    PERL_UNUSED_CONTEXT;
#endif
    slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
    slab->opslab_head = head ? head : slab;
    DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
        (unsigned int)slab->opslab_size, (void*)slab,
        (void*)(slab->opslab_head)));
    return slab;
}


/* Returns a sz-sized block of memory (suitable for holding an op) from
 * a free slot in the chain of op slabs attached to PL_compcv.
 * Allocates a new slab if necessary.
 * if PL_compcv isn't compiling, malloc() instead.
 */

void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
    OPSLAB *head_slab; /* first slab in the chain */
    OPSLAB *slab2;
    OPSLOT *slot;
    OP *o;
    size_t opsz;

    /* We only allocate ops from the slab during subroutine compilation.
       We find the slab via PL_compcv, hence that must be non-NULL. It could
       also be pointing to a subroutine which is now fully set up (CvROOT()
       pointing to the top of the optree for that sub), or a subroutine
       which isn't using the slab allocator. If our sanity checks aren't met,
       don't use a slab, but allocate the OP directly from the heap.  */
    if (!PL_compcv || CvROOT(PL_compcv)
     || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
    {
	o = (OP*)PerlMemShared_calloc(1, sz);
        goto gotit;
    }

    /* While the subroutine is under construction, the slabs are accessed via
       CvSTART(), to avoid needing to expand PVCV by one pointer for something
       unneeded at runtime. Once a subroutine is constructed, the slabs are
       accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
       allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
       details.  */
    if (!CvSTART(PL_compcv)) {
	CvSTART(PL_compcv) =
	    (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
	CvSLABBED_on(PL_compcv);
	head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
    }
    else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;

    opsz = SIZE_TO_PSIZE(sz);
    sz = opsz + OPSLOT_HEADER_P;

    /* The slabs maintain a free list of OPs. In particular, constant folding
       will free up OPs, so it makes sense to re-use them where possible. A
       freed up slot is used in preference to a new allocation.  */
    if (head_slab->opslab_freed) {
	OP **too = &head_slab->opslab_freed;
	o = *too;
        DEBUG_S_warn((aTHX_ "found free op at %p, slab %p, head slab %p",
            (void*)o,
            (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
            (void*)head_slab));

	while (o && OpSLOT(o)->opslot_size < sz) {
	    DEBUG_S_warn((aTHX_ "Alas! too small"));
	    o = *(too = &o->op_next);
	    if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
	}
	if (o) {
            DEBUG_S_warn((aTHX_ "realloced  op at %p, slab %p, head slab %p",
                (void*)o,
                (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
                (void*)head_slab));
	    *too = o->op_next;
	    Zero(o, opsz, I32 *);
	    o->op_slabbed = 1;
	    goto gotit;
	}
    }

#define INIT_OPSLOT(s) \
	    slot->opslot_offset = DIFF(slab2, slot) ;	\
	    slot->opslot_size = s;                      \
	    slab2->opslab_free_space -= s;		\
	    o = &slot->opslot_op;			\
	    o->op_slabbed = 1

    /* The partially-filled slab is next in the chain. */
    slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
    if (slab2->opslab_free_space  < sz) {
	/* Remaining space is too small. */
	/* If we can fit a BASEOP, add it to the free chain, so as not
	   to waste it. */
	if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
	    slot = &slab2->opslab_slots;
	    INIT_OPSLOT(slab2->opslab_free_space);
	    o->op_type = OP_FREED;
	    o->op_next = head_slab->opslab_freed;
	    head_slab->opslab_freed = o;
	}

	/* Create a new slab.  Make this one twice as big. */
	slab2 = S_new_slab(aTHX_ head_slab,
			    slab2->opslab_size  > PERL_MAX_SLAB_SIZE / 2
                                ? PERL_MAX_SLAB_SIZE
                                : slab2->opslab_size * 2);
	slab2->opslab_next = head_slab->opslab_next;
	head_slab->opslab_next = slab2;
    }
    assert(slab2->opslab_size >= sz);

    /* Create a new op slot */
    slot = (OPSLOT *)
                ((I32 **)&slab2->opslab_slots
                                + slab2->opslab_free_space - sz);
    assert(slot >= &slab2->opslab_slots);
    INIT_OPSLOT(sz);
    DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
        (void*)o, (void*)slab2, (void*)head_slab));

  gotit:
    /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
    assert(!o->op_moresib);
    assert(!o->op_sibparent);

    return (void *)o;
}

#undef INIT_OPSLOT

#ifdef PERL_DEBUG_READONLY_OPS
void
Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
{
    PERL_ARGS_ASSERT_SLAB_TO_RO;

    if (slab->opslab_readonly) return;
    slab->opslab_readonly = 1;
    for (; slab; slab = slab->opslab_next) {
	/*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
			      (unsigned long) slab->opslab_size, slab));*/
	if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
	    Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
			     (unsigned long)slab->opslab_size, errno);
    }
}

void
Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
{
    OPSLAB *slab2;

    PERL_ARGS_ASSERT_SLAB_TO_RW;

    if (!slab->opslab_readonly) return;
    slab2 = slab;
    for (; slab2; slab2 = slab2->opslab_next) {
	/*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
			      (unsigned long) size, slab2));*/
	if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
		     PROT_READ|PROT_WRITE)) {
	    Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
			     (unsigned long)slab2->opslab_size, errno);
	}
    }
    slab->opslab_readonly = 0;
}

#else
#  define Slab_to_rw(op)    NOOP
#endif

/* This cannot possibly be right, but it was copied from the old slab
   allocator, to which it was originally added, without explanation, in
   commit 083fcd5. */
#ifdef NETWARE
#    define PerlMemShared PerlMem
#endif

/* make freed ops die if they're inadvertently executed */
#ifdef DEBUGGING
static OP *
S_pp_freed(pTHX)
{
    DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
}
#endif


/* Return the block of memory used by an op to the free list of
 * the OP slab associated with that op.
 */

void
Perl_Slab_Free(pTHX_ void *op)
{
    OP * const o = (OP *)op;
    OPSLAB *slab;

    PERL_ARGS_ASSERT_SLAB_FREE;

#ifdef DEBUGGING
    o->op_ppaddr = S_pp_freed;
#endif

    if (!o->op_slabbed) {
        if (!o->op_static)
	    PerlMemShared_free(op);
	return;
    }

    slab = OpSLAB(o);
    /* If this op is already freed, our refcount will get screwy. */
    assert(o->op_type != OP_FREED);
    o->op_type = OP_FREED;
    o->op_next = slab->opslab_freed;
    slab->opslab_freed = o;
    DEBUG_S_warn((aTHX_ "freeing    op at %p, slab %p, head slab %p",
        (void*)o,
        (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
        (void*)slab));
    OpslabREFCNT_dec_padok(slab);
}

void
Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
{
    const bool havepad = !!PL_comppad;
    PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
    if (havepad) {
	ENTER;
	PAD_SAVE_SETNULLPAD();
    }
    opslab_free(slab);
    if (havepad) LEAVE;
}

/* Free a chain of OP slabs. Should only be called after all ops contained
 * in it have been freed. At this point, its reference count should be 1,
 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
 * and just directly calls opslab_free().
 * (Note that the reference count which PL_compcv held on the slab should
 * have been removed once compilation of the sub was complete).
 *
 *
 */

void
Perl_opslab_free(pTHX_ OPSLAB *slab)
{
    OPSLAB *slab2;
    PERL_ARGS_ASSERT_OPSLAB_FREE;
    PERL_UNUSED_CONTEXT;
    DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
    assert(slab->opslab_refcnt == 1);
    do {
	slab2 = slab->opslab_next;
#ifdef DEBUGGING
	slab->opslab_refcnt = ~(size_t)0;
#endif
#ifdef PERL_DEBUG_READONLY_OPS
	DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
					       (void*)slab));
	if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
	    perror("munmap failed");
	    abort();
	}
#else
	PerlMemShared_free(slab);
#endif
        slab = slab2;
    } while (slab);
}

/* like opslab_free(), but first calls op_free() on any ops in the slab
 * not marked as OP_FREED
 */

void
Perl_opslab_force_free(pTHX_ OPSLAB *slab)
{
    OPSLAB *slab2;
#ifdef DEBUGGING
    size_t savestack_count = 0;
#endif
    PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
    slab2 = slab;
    do {
        OPSLOT *slot = (OPSLOT*)
                    ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
        OPSLOT *end  = (OPSLOT*)
                        ((I32**)slab2 + slab2->opslab_size);
	for (; slot < end;
                slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
        {
	    if (slot->opslot_op.op_type != OP_FREED
	     && !(slot->opslot_op.op_savefree
#ifdef DEBUGGING
		  && ++savestack_count
#endif
		 )
	    ) {
		assert(slot->opslot_op.op_slabbed);
		op_free(&slot->opslot_op);
		if (slab->opslab_refcnt == 1) goto free;
	    }
	}
    } while ((slab2 = slab2->opslab_next));
    /* > 1 because the CV still holds a reference count. */
    if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
#ifdef DEBUGGING
	assert(savestack_count == slab->opslab_refcnt-1);
#endif
	/* Remove the CV’s reference count. */
	slab->opslab_refcnt--;
	return;
    }
   free:
    opslab_free(slab);
}

#ifdef PERL_DEBUG_READONLY_OPS
OP *
Perl_op_refcnt_inc(pTHX_ OP *o)
{
    if(o) {
        OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
        if (slab && slab->opslab_readonly) {
            Slab_to_rw(slab);
            ++o->op_targ;
            Slab_to_ro(slab);
        } else {
            ++o->op_targ;
        }
    }
    return o;

}

PADOFFSET
Perl_op_refcnt_dec(pTHX_ OP *o)
{
    PADOFFSET result;
    OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;

    PERL_ARGS_ASSERT_OP_REFCNT_DEC;

    if (slab && slab->opslab_readonly) {
        Slab_to_rw(slab);
        result = --o->op_targ;
        Slab_to_ro(slab);
    } else {
        result = --o->op_targ;
    }
    return result;
}
#endif
/*
 * In the following definition, the ", (OP*)0" is just to make the compiler
 * think the expression is of the right type: croak actually does a Siglongjmp.
 */
#define CHECKOP(type,o) \
    ((PL_op_mask && PL_op_mask[type])				\
     ? ( op_free((OP*)o),					\
	 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),	\
	 (OP*)0 )						\
     : PL_check[type](aTHX_ (OP*)o))

#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)

#define OpTYPE_set(o,type) \
    STMT_START {				\
	o->op_type = (OPCODE)type;		\
	o->op_ppaddr = PL_ppaddr[type];		\
    } STMT_END

STATIC OP *
S_no_fh_allowed(pTHX_ OP *o)
{
    PERL_ARGS_ASSERT_NO_FH_ALLOWED;

    yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
		 OP_DESC(o)));
    return o;
}

STATIC OP *
S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
{
    PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
    yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
    return o;
}

STATIC OP *
S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
{
    PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;

    yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
    return o;
}

STATIC void
S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
{
    PERL_ARGS_ASSERT_BAD_TYPE_PV;

    yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
		 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
}

/* remove flags var, its unused in all callers, move to to right end since gv
  and kid are always the same */
STATIC void
S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
{
    SV * const namesv = cv_name((CV *)gv, NULL, 0);
    PERL_ARGS_ASSERT_BAD_TYPE_GV;

    yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
		 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
}

STATIC void
S_no_bareword_allowed(pTHX_ OP *o)
{
    PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;

    qerror(Perl_mess(aTHX_
		     "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
		     SVfARG(cSVOPo_sv)));
    o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
}

/* "register" allocation */

PADOFFSET
Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
{
    PADOFFSET off;
    const bool is_our = (PL_parser->in_my == KEY_our);

    PERL_ARGS_ASSERT_ALLOCMY;

    if (flags & ~SVf_UTF8)
	Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
		   (UV)flags);

    /* complain about "my $<special_var>" etc etc */
    if (   len
        && !(  is_our
            || isALPHA(name[1])
            || (   (flags & SVf_UTF8)
                && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
            || (name[1] == '_' && len > 2)))
    {
        const char * const type =
              PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
              PL_parser->in_my == KEY_state  ? "\"state\""     : "\"my\"";

	if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
	 && isASCII(name[1])
	 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
	    /* diag_listed_as: Can't use global %s in %s */
	    yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
			      name[0], toCTRL(name[1]),
                              (int)(len - 2), name + 2,
			      type));
	} else {
	    yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
                              (int) len, name,
			      type), flags & SVf_UTF8);
	}
    }

    /* allocate a spare slot and store the name in that slot */

    off = pad_add_name_pvn(name, len,
		       (is_our ? padadd_OUR :
		        PL_parser->in_my == KEY_state ? padadd_STATE : 0),
		    PL_parser->in_my_stash,
		    (is_our
		        /* $_ is always in main::, even with our */
			? (PL_curstash && !memEQs(name,len,"$_")
			    ? PL_curstash
			    : PL_defstash)
			: NULL
		    )
    );
    /* anon sub prototypes contains state vars should always be cloned,
     * otherwise the state var would be shared between anon subs */

    if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
	CvCLONE_on(PL_compcv);

    return off;
}

/*
=head1 Optree Manipulation Functions

=for apidoc alloccopstash

Available only under threaded builds, this function allocates an entry in
C<PL_stashpad> for the stash passed to it.

=cut
*/

#ifdef USE_ITHREADS
PADOFFSET
Perl_alloccopstash(pTHX_ HV *hv)
{
    PADOFFSET off = 0, o = 1;
    bool found_slot = FALSE;

    PERL_ARGS_ASSERT_ALLOCCOPSTASH;

    if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;

    for (; o < PL_stashpadmax; ++o) {
	if (PL_stashpad[o] == hv) return PL_stashpadix = o;
	if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
	    found_slot = TRUE, off = o;
    }
    if (!found_slot) {
	Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
	Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
	off = PL_stashpadmax;
	PL_stashpadmax += 10;
    }

    PL_stashpad[PL_stashpadix = off] = hv;
    return off;
}
#endif

/* free the body of an op without examining its contents.
 * Always use this rather than FreeOp directly */

static void
S_op_destroy(pTHX_ OP *o)
{
    FreeOp(o);
}

/* Destructor */

/*
=for apidoc op_free

Free an op and its children. Only use this when an op is no longer linked
to from any optree.

=cut
*/

void
Perl_op_free(pTHX_ OP *o)
{
    dVAR;
    OPCODE type;
    OP *top_op = o;
    OP *next_op = o;
    bool went_up = FALSE; /* whether we reached the current node by
                            following the parent pointer from a child, and
                            so have already seen this node */

    if (!o || o->op_type == OP_FREED)
        return;

    if (o->op_private & OPpREFCOUNTED) {
        /* if base of tree is refcounted, just decrement */
        switch (o->op_type) {
        case OP_LEAVESUB:
        case OP_LEAVESUBLV:
        case OP_LEAVEEVAL:
        case OP_LEAVE:
        case OP_SCOPE:
        case OP_LEAVEWRITE:
            {
                PADOFFSET refcnt;
                OP_REFCNT_LOCK;
                refcnt = OpREFCNT_dec(o);
                OP_REFCNT_UNLOCK;
                if (refcnt) {
                    /* Need to find and remove any pattern match ops from
                     * the list we maintain for reset().  */
                    find_and_forget_pmops(o);
                    return;
                }
            }
            break;
        default:
            break;
        }
    }

    while (next_op) {
        o = next_op;

        /* free child ops before ourself, (then free ourself "on the
         * way back up") */

        if (!went_up && o->op_flags & OPf_KIDS) {
            next_op = cUNOPo->op_first;
            continue;
        }

        /* find the next node to visit, *then* free the current node
         * (can't rely on o->op_* fields being valid after o has been
         * freed) */

        /* The next node to visit will be either the sibling, or the
         * parent if no siblings left, or NULL if we've worked our way
         * back up to the top node in the tree */
        next_op = (o == top_op) ? NULL : o->op_sibparent;
        went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */

        /* Now process the current node */

        /* Though ops may be freed twice, freeing the op after its slab is a
           big no-no. */
        assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
        /* During the forced freeing of ops after compilation failure, kidops
           may be freed before their parents. */
        if (!o || o->op_type == OP_FREED)
            continue;

        type = o->op_type;

        /* an op should only ever acquire op_private flags that we know about.
         * If this fails, you may need to fix something in regen/op_private.
         * Don't bother testing if:
         *   * the op_ppaddr doesn't match the op; someone may have
         *     overridden the op and be doing strange things with it;
         *   * we've errored, as op flags are often left in an
         *     inconsistent state then. Note that an error when
         *     compiling the main program leaves PL_parser NULL, so
         *     we can't spot faults in the main code, only
         *     evaled/required code */
#ifdef DEBUGGING
        if (   o->op_ppaddr == PL_ppaddr[type]
            && PL_parser
            && !PL_parser->error_count)
        {
            assert(!(o->op_private & ~PL_op_private_valid[type]));
        }
#endif


        /* Call the op_free hook if it has been set. Do it now so that it's called
         * at the right time for refcounted ops, but still before all of the kids
         * are freed. */
        CALL_OPFREEHOOK(o);

        if (type == OP_NULL)
            type = (OPCODE)o->op_targ;

        if (o->op_slabbed)
            Slab_to_rw(OpSLAB(o));

        /* COP* is not cleared by op_clear() so that we may track line
         * numbers etc even after null() */
        if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
            cop_free((COP*)o);
        }

        op_clear(o);
        FreeOp(o);
        if (PL_op == o)
            PL_op = NULL;
    }
}


/* S_op_clear_gv(): free a GV attached to an OP */

STATIC
#ifdef USE_ITHREADS
void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
#else
void S_op_clear_gv(pTHX_ OP *o, SV**svp)
#endif
{

    GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
            || o->op_type == OP_MULTIDEREF)
#ifdef USE_ITHREADS
                && PL_curpad
                ? ((GV*)PAD_SVl(*ixp)) : NULL;
#else
                ? (GV*)(*svp) : NULL;
#endif
    /* It's possible during global destruction that the GV is freed
       before the optree. Whilst the SvREFCNT_inc is happy to bump from
       0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
       will trigger an assertion failure, because the entry to sv_clear
       checks that the scalar is not already freed.  A check of for
       !SvIS_FREED(gv) turns out to be invalid, because during global
       destruction the reference count can be forced down to zero
       (with SVf_BREAK set).  In which case raising to 1 and then
       dropping to 0 triggers cleanup before it should happen.  I
       *think* that this might actually be a general, systematic,
       weakness of the whole idea of SVf_BREAK, in that code *is*
       allowed to raise and lower references during global destruction,
       so any *valid* code that happens to do this during global
       destruction might well trigger premature cleanup.  */
    bool still_valid = gv && SvREFCNT(gv);

    if (still_valid)
        SvREFCNT_inc_simple_void(gv);
#ifdef USE_ITHREADS
    if (*ixp > 0) {
        pad_swipe(*ixp, TRUE);
        *ixp = 0;
    }
#else
    SvREFCNT_dec(*svp);
    *svp = NULL;
#endif
    if (still_valid) {
        int try_downgrade = SvREFCNT(gv) == 2;
        SvREFCNT_dec_NN(gv);
        if (try_downgrade)
            gv_try_downgrade(gv);
    }
}


void
Perl_op_clear(pTHX_ OP *o)
{

    dVAR;

    PERL_ARGS_ASSERT_OP_CLEAR;

    switch (o->op_type) {
    case OP_NULL:	/* Was holding old type, if any. */
        /* FALLTHROUGH */
    case OP_ENTERTRY:
    case OP_ENTEREVAL:	/* Was holding hints. */
    case OP_ARGDEFELEM:	/* Was holding signature index. */
	o->op_targ = 0;
	break;
    default:
	if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
	    break;
	/* FALLTHROUGH */
    case OP_GVSV:
    case OP_GV:
    case OP_AELEMFAST:
#ifdef USE_ITHREADS
            S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
#else
            S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
#endif
	break;
    case OP_METHOD_REDIR:
    case OP_METHOD_REDIR_SUPER:
#ifdef USE_ITHREADS
	if (cMETHOPx(o)->op_rclass_targ) {
	    pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
	    cMETHOPx(o)->op_rclass_targ = 0;
	}
#else
	SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
	cMETHOPx(o)->op_rclass_sv = NULL;
#endif
        /* FALLTHROUGH */
    case OP_METHOD_NAMED:
    case OP_METHOD_SUPER:
        SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
        cMETHOPx(o)->op_u.op_meth_sv = NULL;
#ifdef USE_ITHREADS
        if (o->op_targ) {
            pad_swipe(o->op_targ, 1);
            o->op_targ = 0;
        }
#endif
        break;
    case OP_CONST:
    case OP_HINTSEVAL:
	SvREFCNT_dec(cSVOPo->op_sv);
	cSVOPo->op_sv = NULL;
#ifdef USE_ITHREADS
	/** Bug #15654
	  Even if op_clear does a pad_free for the target of the op,
	  pad_free doesn't actually remove the sv that exists in the pad;
	  instead it lives on. This results in that it could be reused as
	  a target later on when the pad was reallocated.
	**/
        if(o->op_targ) {
          pad_swipe(o->op_targ,1);
          o->op_targ = 0;
        }
#endif
	break;
    case OP_DUMP:
    case OP_GOTO:
    case OP_NEXT:
    case OP_LAST:
    case OP_REDO:
	if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
	    break;
	/* FALLTHROUGH */
    case OP_TRANS:
    case OP_TRANSR:
	if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
            && (o->op_private & OPpTRANS_USE_SVOP))
        {
#ifdef USE_ITHREADS
	    if (cPADOPo->op_padix > 0) {
		pad_swipe(cPADOPo->op_padix, TRUE);
		cPADOPo->op_padix = 0;
	    }
#else
	    SvREFCNT_dec(cSVOPo->op_sv);
	    cSVOPo->op_sv = NULL;
#endif
	}
	else {
	    PerlMemShared_free(cPVOPo->op_pv);
	    cPVOPo->op_pv = NULL;
	}
	break;
    case OP_SUBST:
	op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
	goto clear_pmop;

    case OP_SPLIT:
        if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
            && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
        {
            if (o->op_private & OPpSPLIT_LEX)
                pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
            else
#ifdef USE_ITHREADS
                pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
#else
                SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
#endif
        }
	/* FALLTHROUGH */
    case OP_MATCH:
    case OP_QR:
    clear_pmop:
	if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
	    op_free(cPMOPo->op_code_list);
	cPMOPo->op_code_list = NULL;
	forget_pmop(cPMOPo);
	cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
        /* we use the same protection as the "SAFE" version of the PM_ macros
         * here since sv_clean_all might release some PMOPs
         * after PL_regex_padav has been cleared
         * and the clearing of PL_regex_padav needs to
         * happen before sv_clean_all
         */
#ifdef USE_ITHREADS
	if(PL_regex_pad) {        /* We could be in destruction */
	    const IV offset = (cPMOPo)->op_pmoffset;
	    ReREFCNT_dec(PM_GETRE(cPMOPo));
	    PL_regex_pad[offset] = &PL_sv_undef;
            sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
			   sizeof(offset));
        }
#else
	ReREFCNT_dec(PM_GETRE(cPMOPo));
	PM_SETRE(cPMOPo, NULL);
#endif

	break;

    case OP_ARGCHECK:
        PerlMemShared_free(cUNOP_AUXo->op_aux);
        break;

    case OP_MULTICONCAT:
        {
            UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
            /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
             * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
             * utf8 shared strings */
            char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
            char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
            if (p1)
                PerlMemShared_free(p1);
            if (p2 && p1 != p2)
                PerlMemShared_free(p2);
            PerlMemShared_free(aux);
        }
        break;

    case OP_MULTIDEREF:
        {
            UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
            UV actions = items->uv;
            bool last = 0;
            bool is_hash = FALSE;

            while (!last) {
                switch (actions & MDEREF_ACTION_MASK) {

                case MDEREF_reload:
                    actions = (++items)->uv;
                    continue;

                case MDEREF_HV_padhv_helem:
                    is_hash = TRUE;
                    /* FALLTHROUGH */
                case MDEREF_AV_padav_aelem:
                    pad_free((++items)->pad_offset);
                    goto do_elem;

                case MDEREF_HV_gvhv_helem:
                    is_hash = TRUE;
                    /* FALLTHROUGH */
                case MDEREF_AV_gvav_aelem:
#ifdef USE_ITHREADS
                    S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
#else
                    S_op_clear_gv(aTHX_ o, &((++items)->sv));
#endif
                    goto do_elem;

                case MDEREF_HV_gvsv_vivify_rv2hv_helem:
                    is_hash = TRUE;
                    /* FALLTHROUGH */
                case MDEREF_AV_gvsv_vivify_rv2av_aelem:
#ifdef USE_ITHREADS
                    S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
#else
                    S_op_clear_gv(aTHX_ o, &((++items)->sv));
#endif
                    goto do_vivify_rv2xv_elem;

                case MDEREF_HV_padsv_vivify_rv2hv_helem:
                    is_hash = TRUE;
                    /* FALLTHROUGH */
                case MDEREF_AV_padsv_vivify_rv2av_aelem:
                    pad_free((++items)->pad_offset);
                    goto do_vivify_rv2xv_elem;

                case MDEREF_HV_pop_rv2hv_helem:
                case MDEREF_HV_vivify_rv2hv_helem:
                    is_hash = TRUE;
                    /* FALLTHROUGH */
                do_vivify_rv2xv_elem:
                case MDEREF_AV_pop_rv2av_aelem:
                case MDEREF_AV_vivify_rv2av_aelem:
                do_elem:
                    switch (actions & MDEREF_INDEX_MASK) {
                    case MDEREF_INDEX_none:
                        last = 1;
                        break;
                    case MDEREF_INDEX_const:
                        if (is_hash) {
#ifdef USE_ITHREADS
                            /* see RT #15654 */
                            pad_swipe((++items)->pad_offset, 1);
#else
                            SvREFCNT_dec((++items)->sv);
#endif
                        }
                        else
                            items++;
                        break;
                    case MDEREF_INDEX_padsv:
                        pad_free((++items)->pad_offset);
                        break;
                    case MDEREF_INDEX_gvsv:
#ifdef USE_ITHREADS
                        S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
#else
                        S_op_clear_gv(aTHX_ o, &((++items)->sv));
#endif
                        break;
                    }

                    if (actions & MDEREF_FLAG_last)
                        last = 1;
                    is_hash = FALSE;

                    break;

                default:
                    assert(0);
                    last = 1;
                    break;

                } /* switch */

                actions >>= MDEREF_SHIFT;
            } /* while */

            /* start of malloc is at op_aux[-1], where the length is
             * stored */
            PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
        }
        break;
    }

    if (o->op_targ > 0) {
	pad_free(o->op_targ);
	o->op_targ = 0;
    }
}

STATIC void
S_cop_free(pTHX_ COP* cop)
{
    PERL_ARGS_ASSERT_COP_FREE;

    CopFILE_free(cop);
    if (! specialWARN(cop->cop_warnings))
	PerlMemShared_free(cop->cop_warnings);
    cophh_free(CopHINTHASH_get(cop));
    if (PL_curcop == cop)
       PL_curcop = NULL;
}

STATIC void
S_forget_pmop(pTHX_ PMOP *const o)
{
    HV * const pmstash = PmopSTASH(o);

    PERL_ARGS_ASSERT_FORGET_PMOP;

    if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
	MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
	if (mg) {
	    PMOP **const array = (PMOP**) mg->mg_ptr;
	    U32 count = mg->mg_len / sizeof(PMOP**);
	    U32 i = count;

	    while (i--) {
		if (array[i] == o) {
		    /* Found it. Move the entry at the end to overwrite it.  */
		    array[i] = array[--count];
		    mg->mg_len = count * sizeof(PMOP**);
		    /* Could realloc smaller at this point always, but probably
		       not worth it. Probably worth free()ing if we're the
		       last.  */
		    if(!count) {
			Safefree(mg->mg_ptr);
			mg->mg_ptr = NULL;
		    }
		    break;
		}
	    }
	}
    }
    if (PL_curpm == o)
	PL_curpm = NULL;
}


STATIC void
S_find_and_forget_pmops(pTHX_ OP *o)
{
    OP* top_op = o;

    PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;

    while (1) {
        switch (o->op_type) {
        case OP_SUBST:
        case OP_SPLIT:
        case OP_MATCH:
        case OP_QR:
            forget_pmop((PMOP*)o);
        }

        if (o->op_flags & OPf_KIDS) {
            o = cUNOPo->op_first;
            continue;
        }

        while (1) {
            if (o == top_op)
                return; /* at top; no parents/siblings to try */
            if (OpHAS_SIBLING(o)) {
                o = o->op_sibparent; /* process next sibling */
                break;
            }
            o = o->op_sibparent; /*try parent's next sibling */
        }
    }
}


/*
=for apidoc op_null

Neutralizes an op when it is no longer needed, but is still linked to from
other ops.

=cut
*/

void
Perl_op_null(pTHX_ OP *o)
{
    dVAR;

    PERL_ARGS_ASSERT_OP_NULL;

    if (o->op_type == OP_NULL)
	return;
    op_clear(o);
    o->op_targ = o->op_type;
    OpTYPE_set(o, OP_NULL);
}

void
Perl_op_refcnt_lock(pTHX)
  PERL_TSA_ACQUIRE(PL_op_mutex)
{
#ifdef USE_ITHREADS
    dVAR;
#endif
    PERL_UNUSED_CONTEXT;
    OP_REFCNT_LOCK;
}

void
Perl_op_refcnt_unlock(pTHX)
  PERL_TSA_RELEASE(PL_op_mutex)
{
#ifdef USE_ITHREADS
    dVAR;
#endif
    PERL_UNUSED_CONTEXT;
    OP_REFCNT_UNLOCK;
}


/*
=for apidoc op_sibling_splice

A general function for editing the structure of an existing chain of
op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
you to delete zero or more sequential nodes, replacing them with zero or
more different nodes.  Performs the necessary op_first/op_last
housekeeping on the parent node and op_sibling manipulation on the
children.  The last deleted node will be marked as as the last node by
updating the op_sibling/op_sibparent or op_moresib field as appropriate.

Note that op_next is not manipulated, and nodes are not freed; that is the
responsibility of the caller.  It also won't create a new list op for an
empty list etc; use higher-level functions like op_append_elem() for that.

C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
the splicing doesn't affect the first or last op in the chain.

C<start> is the node preceding the first node to be spliced.  Node(s)
following it will be deleted, and ops will be inserted after it.  If it is
C<NULL>, the first node onwards is deleted, and nodes are inserted at the
beginning.

C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
If -1 or greater than or equal to the number of remaining kids, all
remaining kids are deleted.

C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
If C<NULL>, no nodes are inserted.

The head of the chain of deleted ops is returned, or C<NULL> if no ops were
deleted.

For example:

    action                    before      after         returns
    ------                    -----       -----         -------

                              P           P
    splice(P, A, 2, X-Y-Z)    |           |             B-C
                              A-B-C-D     A-X-Y-Z-D

                              P           P
    splice(P, NULL, 1, X-Y)   |           |             A
                              A-B-C-D     X-Y-B-C-D

                              P           P
    splice(P, NULL, 3, NULL)  |           |             A-B-C
                              A-B-C-D     D

                              P           P
    splice(P, B, 0, X-Y)      |           |             NULL
                              A-B-C-D     A-B-X-Y-C-D


For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.

=cut
*/

OP *
Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
{
    OP *first;
    OP *rest;
    OP *last_del = NULL;
    OP *last_ins = NULL;

    if (start)
        first = OpSIBLING(start);
    else if (!parent)
        goto no_parent;
    else
        first = cLISTOPx(parent)->op_first;

    assert(del_count >= -1);

    if (del_count && first) {
        last_del = first;
        while (--del_count && OpHAS_SIBLING(last_del))
            last_del = OpSIBLING(last_del);
        rest = OpSIBLING(last_del);
        OpLASTSIB_set(last_del, NULL);
    }
    else
        rest = first;

    if (insert) {
        last_ins = insert;
        while (OpHAS_SIBLING(last_ins))
            last_ins = OpSIBLING(last_ins);
        OpMAYBESIB_set(last_ins, rest, NULL);
    }
    else
        insert = rest;

    if (start) {
        OpMAYBESIB_set(start, insert, NULL);
    }
    else {
        assert(parent);
        cLISTOPx(parent)->op_first = insert;
        if (insert)
            parent->op_flags |= OPf_KIDS;
        else
            parent->op_flags &= ~OPf_KIDS;
    }

    if (!rest) {
        /* update op_last etc */
        U32 type;
        OP *lastop;

        if (!parent)
            goto no_parent;

        /* ought to use OP_CLASS(parent) here, but that can't handle
         * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
         * either */
        type = parent->op_type;
        if (type == OP_CUSTOM) {
            dTHX;
            type = XopENTRYCUSTOM(parent, xop_class);
        }
        else {
            if (type == OP_NULL)
                type = parent->op_targ;
            type = PL_opargs[type] & OA_CLASS_MASK;
        }

        lastop = last_ins ? last_ins : start ? start : NULL;
        if (   type == OA_BINOP
            || type == OA_LISTOP
            || type == OA_PMOP
            || type == OA_LOOP
        )
            cLISTOPx(parent)->op_last = lastop;

        if (lastop)
            OpLASTSIB_set(lastop, parent);
    }
    return last_del ? first : NULL;

  no_parent:
    Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
}

/*
=for apidoc op_parent

Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.

=cut
*/

OP *
Perl_op_parent(OP *o)
{
    PERL_ARGS_ASSERT_OP_PARENT;
    while (OpHAS_SIBLING(o))
        o = OpSIBLING(o);
    return o->op_sibparent;
}

/* replace the sibling following start with a new UNOP, which becomes
 * the parent of the original sibling; e.g.
 *
 *  op_sibling_newUNOP(P, A, unop-args...)
 *
 *  P              P
 *  |      becomes |
 *  A-B-C          A-U-C
 *                   |
 *                   B
 *
 * where U is the new UNOP.
 *
 * parent and start args are the same as for op_sibling_splice();
 * type and flags args are as newUNOP().
 *
 * Returns the new UNOP.
 */

STATIC OP *
S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
{
    OP *kid, *newop;

    kid = op_sibling_splice(parent, start, 1, NULL);
    newop = newUNOP(type, flags, kid);
    op_sibling_splice(parent, start, 0, newop);
    return newop;
}


/* lowest-level newLOGOP-style function - just allocates and populates
 * the struct. Higher-level stuff should be done by S_new_logop() /
 * newLOGOP(). This function exists mainly to avoid op_first assignment
 * being spread throughout this file.
 */

LOGOP *
Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
    dVAR;
    LOGOP *logop;
    OP *kid = first;
    NewOp(1101, logop, 1, LOGOP);
    OpTYPE_set(logop, type);
    logop->op_first = first;
    logop->op_other = other;
    if (first)
        logop->op_flags = OPf_KIDS;
    while (kid && OpHAS_SIBLING(kid))
        kid = OpSIBLING(kid);
    if (kid)
        OpLASTSIB_set(kid, (OP*)logop);
    return logop;
}


/* Contextualizers */

/*
=for apidoc op_contextualize

Applies a syntactic context to an op tree representing an expression.
C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
or C<G_VOID> to specify the context to apply.  The modified op tree
is returned.

=cut
*/

OP *
Perl_op_contextualize(pTHX_ OP *o, I32 context)
{
    PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
    switch (context) {
	case G_SCALAR: return scalar(o);
	case G_ARRAY:  return list(o);
	case G_VOID:   return scalarvoid(o);
	default:
	    Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
		       (long) context);
    }
}

/*

=for apidoc op_linklist
This function is the implementation of the L</LINKLIST> macro.  It should
not be called directly.

=cut
*/


OP *
Perl_op_linklist(pTHX_ OP *o)
{

    OP **prevp;
    OP *kid;
    OP * top_op = o;

    PERL_ARGS_ASSERT_OP_LINKLIST;

    while (1) {
        /* Descend down the tree looking for any unprocessed subtrees to
         * do first */
        if (!o->op_next) {
            if (o->op_flags & OPf_KIDS) {
                o = cUNOPo->op_first;
                continue;
            }
            o->op_next = o; /* leaf node; link to self initially */
        }

        /* if we're at the top level, there either weren't any children
         * to process, or we've worked our way back to the top. */
        if (o == top_op)
            return o->op_next;

        /* o is now processed. Next, process any sibling subtrees */

        if (OpHAS_SIBLING(o)) {
            o = OpSIBLING(o);
            continue;
        }

        /* Done all the subtrees at this level. Go back up a level and
         * link the parent in with all its (processed) children.
         */

        o = o->op_sibparent;
        assert(!o->op_next);
        prevp = &(o->op_next);
        kid   = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
        while (kid) {
            *prevp = kid->op_next;
            prevp = &(kid->op_next);
            kid = OpSIBLING(kid);
        }
        *prevp = o;
    }
}


static OP *
S_scalarkids(pTHX_ OP *o)
{
    if (o && o->op_flags & OPf_KIDS) {
        OP *kid;
        for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
	    scalar(kid);
    }
    return o;
}

STATIC OP *
S_scalarboolean(pTHX_ OP *o)
{
    PERL_ARGS_ASSERT_SCALARBOOLEAN;

    if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
         !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
        (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
         cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
         !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
	if (ckWARN(WARN_SYNTAX)) {
	    const line_t oldline = CopLINE(PL_curcop);

	    if (PL_parser && PL_parser->copline != NOLINE) {
		/* This ensures that warnings are reported at the first line
                   of the conditional, not the last.  */
		CopLINE_set(PL_curcop, PL_parser->copline);
            }
	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
	    CopLINE_set(PL_curcop, oldline);
	}
    }
    return scalar(o);
}

static SV *
S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
{
    assert(o);
    assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
	   o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
    {
	const char funny  = o->op_type == OP_PADAV
			 || o->op_type == OP_RV2AV ? '@' : '%';
	if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
	    GV *gv;
	    if (cUNOPo->op_first->op_type != OP_GV
	     || !(gv = cGVOPx_gv(cUNOPo->op_first)))
		return NULL;
	    return varname(gv, funny, 0, NULL, 0, subscript_type);
	}
	return
	    varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
    }
}

static SV *
S_op_varname(pTHX_ const OP *o)
{
    return S_op_varname_subscript(aTHX_ o, 1);
}

static void
S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
{ /* or not so pretty :-) */
    if (o->op_type == OP_CONST) {
	*retsv = cSVOPo_sv;
	if (SvPOK(*retsv)) {
	    SV *sv = *retsv;
	    *retsv = sv_newmortal();
	    pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
		      PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
	}
	else if (!SvOK(*retsv))
	    *retpv = "undef";
    }
    else *retpv = "...";
}

static void
S_scalar_slice_warning(pTHX_ const OP *o)
{
    OP *kid;
    const bool h = o->op_type == OP_HSLICE
		|| (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
    const char lbrack =
	h ? '{' : '[';
    const char rbrack =
	h ? '}' : ']';
    SV *name;
    SV *keysv = NULL; /* just to silence compiler warnings */
    const char *key = NULL;

    if (!(o->op_private & OPpSLICEWARNING))
	return;
    if (PL_parser && PL_parser->error_count)
	/* This warning can be nonsensical when there is a syntax error. */
	return;

    kid = cLISTOPo->op_first;
    kid = OpSIBLING(kid); /* get past pushmark */
    /* weed out false positives: any ops that can return lists */
    switch (kid->op_type) {
    case OP_BACKTICK:
    case OP_GLOB:
    case OP_READLINE:
    case OP_MATCH:
    case OP_RV2AV:
    case OP_EACH:
    case OP_VALUES:
    case OP_KEYS:
    case OP_SPLIT:
    case OP_LIST:
    case OP_SORT:
    case OP_REVERSE:
    case OP_ENTERSUB:
    case OP_CALLER:
    case OP_LSTAT:
    case OP_STAT:
    case OP_READDIR:
    case OP_SYSTEM:
    case OP_TMS:
    case OP_LOCALTIME:
    case OP_GMTIME:
    case OP_ENTEREVAL:
	return;
    }

    /* Don't warn if we have a nulled list either. */
    if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
        return;

    assert(OpSIBLING(kid));
    name = S_op_varname(aTHX_ OpSIBLING(kid));
    if (!name) /* XS module fiddling with the op tree */
	return;
    S_op_pretty(aTHX_ kid, &keysv, &key);
    assert(SvPOK(name));
    sv_chop(name,SvPVX(name)+1);
    if (key)
       /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
		   "Scalar value @%" SVf "%c%s%c better written as $%" SVf
		   "%c%s%c",
		    SVfARG(name), lbrack, key, rbrack, SVfARG(name),
		    lbrack, key, rbrack);
    else
       /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
		   "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
		    SVf "%c%" SVf "%c",
		    SVfARG(name), lbrack, SVfARG(keysv), rbrack,
		    SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}



/* apply scalar context to the o subtree */

OP *
Perl_scalar(pTHX_ OP *o)
{
    OP * top_op = o;

    while (1) {
        OP *next_kid = NULL; /* what op (if any) to process next */
        OP *kid;

        /* assumes no premature commitment */
        if (!o || (PL_parser && PL_parser->error_count)
             || (o->op_flags & OPf_WANT)
             || o->op_type == OP_RETURN)
        {
            goto do_next;
        }

        o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;

        switch (o->op_type) {
        case OP_REPEAT:
            scalar(cBINOPo->op_first);
            /* convert what initially looked like a list repeat into a
             * scalar repeat, e.g. $s = (1) x $n
             */
            if (o->op_private & OPpREPEAT_DOLIST) {
                kid = cLISTOPx(cUNOPo->op_first)->op_first;
                assert(kid->op_type == OP_PUSHMARK);
                if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
                    op_null(cLISTOPx(cUNOPo->op_first)->op_first);
                    o->op_private &=~ OPpREPEAT_DOLIST;
                }
            }
            break;

        case OP_OR:
        case OP_AND:
        case OP_COND_EXPR:
            /* impose scalar context on everything except the condition */
            next_kid = OpSIBLING(cUNOPo->op_first);
            break;

        default:
            if (o->op_flags & OPf_KIDS)
                next_kid = cUNOPo->op_first; /* do all kids */
            break;

        /* the children of these ops are usually a list of statements,
         * except the leaves, whose first child is a corresponding enter
         */
        case OP_SCOPE:
        case OP_LINESEQ:
        case OP_LIST:
            kid = cLISTOPo->op_first;
            goto do_kids;
        case OP_LEAVE:
        case OP_LEAVETRY:
            kid = cLISTOPo->op_first;
            scalar(kid);
            kid = OpSIBLING(kid);
        do_kids:
            while (kid) {
                OP *sib = OpSIBLING(kid);
                /* Apply void context to all kids except the last, which
                 * is scalar (ignoring a trailing ex-nextstate in determining
                 * if it's the last kid). E.g.
                 *      $scalar = do { void; void; scalar }
                 * Except that 'when's are always scalar, e.g.
                 *      $scalar = do { given(..) {
                    *                 when (..) { scalar }
                    *                 when (..) { scalar }
                    *                 ...
                    *                }}
                    */
                if (!sib
                     || (  !OpHAS_SIBLING(sib)
                         && sib->op_type == OP_NULL
                         && (   sib->op_targ == OP_NEXTSTATE
                             || sib->op_targ == OP_DBSTATE  )
                        )
                )
                {
                    /* tail call optimise calling scalar() on the last kid */
                    next_kid = kid;
                    goto do_next;
                }
                else if (kid->op_type == OP_LEAVEWHEN)
                    scalar(kid);
                else
                    scalarvoid(kid);
                kid = sib;
            }
            NOT_REACHED; /* NOTREACHED */
            break;

        case OP_SORT:
            Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
            break;

        case OP_KVHSLICE:
        case OP_KVASLICE:
        {
            /* Warn about scalar context */
            const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
            const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
            SV *name;
            SV *keysv;
            const char *key = NULL;

            /* This warning can be nonsensical when there is a syntax error. */
            if (PL_parser && PL_parser->error_count)
                break;

            if (!ckWARN(WARN_SYNTAX)) break;

            kid = cLISTOPo->op_first;
            kid = OpSIBLING(kid); /* get past pushmark */
            assert(OpSIBLING(kid));
            name = S_op_varname(aTHX_ OpSIBLING(kid));
            if (!name) /* XS module fiddling with the op tree */
                break;
            S_op_pretty(aTHX_ kid, &keysv, &key);
            assert(SvPOK(name));
            sv_chop(name,SvPVX(name)+1);
            if (key)
      /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
                Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                           "%%%" SVf "%c%s%c in scalar context better written "
                           "as $%" SVf "%c%s%c",
                            SVfARG(name), lbrack, key, rbrack, SVfARG(name),
                            lbrack, key, rbrack);
            else
      /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
                Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                           "%%%" SVf "%c%" SVf "%c in scalar context better "
                           "written as $%" SVf "%c%" SVf "%c",
                            SVfARG(name), lbrack, SVfARG(keysv), rbrack,
                            SVfARG(name), lbrack, SVfARG(keysv), rbrack);
        }
        } /* switch */

        /* If next_kid is set, someone in the code above wanted us to process
         * that kid and all its remaining siblings.  Otherwise, work our way
         * back up the tree */
      do_next:
        while (!next_kid) {
            if (o == top_op)
                return top_op; /* at top; no parents/siblings to try */
            if (OpHAS_SIBLING(o))
                next_kid = o->op_sibparent;
            else {
                o = o->op_sibparent; /*try parent's next sibling */
                switch (o->op_type) {
                case OP_SCOPE:
                case OP_LINESEQ:
                case OP_LIST:
                case OP_LEAVE:
                case OP_LEAVETRY:
                    /* should really restore PL_curcop to its old value, but
                     * setting it to PL_compiling is better than do nothing */
                    PL_curcop = &PL_compiling;
                }
            }
        }
        o = next_kid;
    } /* while */
}


/* apply void context to the optree arg */

OP *
Perl_scalarvoid(pTHX_ OP *arg)
{
    dVAR;
    OP *kid;
    SV* sv;
    OP *o = arg;

    PERL_ARGS_ASSERT_SCALARVOID;

    while (1) {
        U8 want;
        SV *useless_sv = NULL;
        const char* useless = NULL;
        OP * next_kid = NULL;

        if (o->op_type == OP_NEXTSTATE
            || o->op_type == OP_DBSTATE
            || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
                                          || o->op_targ == OP_DBSTATE)))
            PL_curcop = (COP*)o;                /* for warning below */

        /* assumes no premature commitment */
        want = o->op_flags & OPf_WANT;
        if ((want && want != OPf_WANT_SCALAR)
            || (PL_parser && PL_parser->error_count)
            || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
        {
            goto get_next_op;
        }

        if ((o->op_private & OPpTARGET_MY)
            && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
        {
            /* newASSIGNOP has already applied scalar context, which we
               leave, as if this op is inside SASSIGN.  */
            goto get_next_op;
        }

        o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;

        switch (o->op_type) {
        default:
            if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
                break;
            /* FALLTHROUGH */
        case OP_REPEAT:
            if (o->op_flags & OPf_STACKED)
                break;
            if (o->op_type == OP_REPEAT)
                scalar(cBINOPo->op_first);
            goto func_ops;
	case OP_CONCAT:
            if ((o->op_flags & OPf_STACKED) &&
		    !(o->op_private & OPpCONCAT_NESTED))
                break;
	    goto func_ops;
        case OP_SUBSTR:
            if (o->op_private == 4)
                break;
            /* FALLTHROUGH */
        case OP_WANTARRAY:
        case OP_GV:
        case OP_SMARTMATCH:
        case OP_AV2ARYLEN:
        case OP_REF:
        case OP_REFGEN:
        case OP_SREFGEN:
        case OP_DEFINED:
        case OP_HEX:
        case OP_OCT:
        case OP_LENGTH:
        case OP_VEC:
        case OP_INDEX:
        case OP_RINDEX:
        case OP_SPRINTF:
        case OP_KVASLICE:
        case OP_KVHSLICE:
        case OP_UNPACK:
        case OP_PACK:
        case OP_JOIN:
        case OP_LSLICE:
        case OP_ANONLIST:
        case OP_ANONHASH:
        case OP_SORT:
        case OP_REVERSE:
        case OP_RANGE:
        case OP_FLIP:
        case OP_FLOP:
        case OP_CALLER:
        case OP_FILENO:
        case OP_EOF:
        case OP_TELL:
        case OP_GETSOCKNAME:
        case OP_GETPEERNAME:
        case OP_READLINK:
        case OP_TELLDIR:
        case OP_GETPPID:
        case OP_GETPGRP:
        case OP_GETPRIORITY:
        case OP_TIME:
        case OP_TMS:
        case OP_LOCALTIME:
        case OP_GMTIME:
        case OP_GHBYNAME:
        case OP_GHBYADDR:
        case OP_GHOSTENT:
        case OP_GNBYNAME:
        case OP_GNBYADDR:
        case OP_GNETENT:
        case OP_GPBYNAME:
        case OP_GPBYNUMBER:
        case OP_GPROTOENT:
        case OP_GSBYNAME:
        case OP_GSBYPORT:
        case OP_GSERVENT:
        case OP_GPWNAM:
        case OP_GPWUID:
        case OP_GGRNAM:
        case OP_GGRGID:
        case OP_GETLOGIN:
        case OP_PROTOTYPE:
        case OP_RUNCV:
        func_ops:
            useless = OP_DESC(o);
            break;

        case OP_GVSV:
        case OP_PADSV:
        case OP_PADAV:
        case OP_PADHV:
        case OP_PADANY:
        case OP_AELEM:
        case OP_AELEMFAST:
        case OP_AELEMFAST_LEX:
        case OP_ASLICE:
        case OP_HELEM:
        case OP_HSLICE:
            if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
                /* Otherwise it's "Useless use of grep iterator" */
                useless = OP_DESC(o);
            break;

        case OP_SPLIT:
            if (!(o->op_private & OPpSPLIT_ASSIGN))
                useless = OP_DESC(o);
            break;

        case OP_NOT:
            kid = cUNOPo->op_first;
            if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
                kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
                goto func_ops;
            }
            useless = "negative pattern binding (!~)";
            break;

        case OP_SUBST:
            if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
                useless = "non-destructive substitution (s///r)";
            break;

        case OP_TRANSR:
            useless = "non-destructive transliteration (tr///r)";
            break;

        case OP_RV2GV:
        case OP_RV2SV:
        case OP_RV2AV:
        case OP_RV2HV:
            if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
                (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
                useless = "a variable";
            break;

        case OP_CONST:
            sv = cSVOPo_sv;
            if (cSVOPo->op_private & OPpCONST_STRICT)
                no_bareword_allowed(o);
            else {
                if (ckWARN(WARN_VOID)) {
                    NV nv;
                    /* don't warn on optimised away booleans, eg
                     * use constant Foo, 5; Foo || print; */
                    if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
                        useless = NULL;
                    /* the constants 0 and 1 are permitted as they are
                       conventionally used as dummies in constructs like
                       1 while some_condition_with_side_effects;  */
                    else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
                        useless = NULL;
                    else if (SvPOK(sv)) {
                        SV * const dsv = newSVpvs("");
                        useless_sv
                            = Perl_newSVpvf(aTHX_
                                            "a constant (%s)",
                                            pv_pretty(dsv, SvPVX_const(sv),
                                                      SvCUR(sv), 32, NULL, NULL,
                                                      PERL_PV_PRETTY_DUMP
                                                      | PERL_PV_ESCAPE_NOCLEAR
                                                      | PERL_PV_ESCAPE_UNI_DETECT));
                        SvREFCNT_dec_NN(dsv);
                    }
                    else if (SvOK(sv)) {
                        useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
                    }
                    else
                        useless = "a constant (undef)";
                }
            }
            op_null(o);         /* don't execute or even remember it */
            break;

        case OP_POSTINC:
            OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
            break;

        case OP_POSTDEC:
            OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
            break;

        case OP_I_POSTINC:
            OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
            break;

        case OP_I_POSTDEC:
            OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
            break;

        case OP_SASSIGN: {
            OP *rv2gv;
            UNOP *refgen, *rv2cv;
            LISTOP *exlist;

            if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
                break;

            rv2gv = ((BINOP *)o)->op_last;
            if (!rv2gv || rv2gv->op_type != OP_RV2GV)
                break;

            refgen = (UNOP *)((BINOP *)o)->op_first;

            if (!refgen || (refgen->op_type != OP_REFGEN
                            && refgen->op_type != OP_SREFGEN))
                break;

            exlist = (LISTOP *)refgen->op_first;
            if (!exlist || exlist->op_type != OP_NULL
                || exlist->op_targ != OP_LIST)
                break;

            if (exlist->op_first->op_type != OP_PUSHMARK
                && exlist->op_first != exlist->op_last)
                break;

            rv2cv = (UNOP*)exlist->op_last;

            if (rv2cv->op_type != OP_RV2CV)
                break;

            assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
            assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
            assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);

            o->op_private |= OPpASSIGN_CV_TO_GV;
            rv2gv->op_private |= OPpDONT_INIT_GV;
            rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;

            break;
        }

        case OP_AASSIGN: {
            inplace_aassign(o);
            break;
        }

        case OP_OR:
        case OP_AND:
            kid = cLOGOPo->op_first;
            if (kid->op_type == OP_NOT
                && (kid->op_flags & OPf_KIDS)) {
                if (o->op_type == OP_AND) {
                    OpTYPE_set(o, OP_OR);
                } else {
                    OpTYPE_set(o, OP_AND);
                }
                op_null(kid);
            }
            /* FALLTHROUGH */

        case OP_DOR:
        case OP_COND_EXPR:
        case OP_ENTERGIVEN:
        case OP_ENTERWHEN:
            next_kid = OpSIBLING(cUNOPo->op_first);
        break;

        case OP_NULL:
            if (o->op_flags & OPf_STACKED)
                break;
            /* FALLTHROUGH */
        case OP_NEXTSTATE:
        case OP_DBSTATE:
        case OP_ENTERTRY:
        case OP_ENTER:
            if (!(o->op_flags & OPf_KIDS))
                break;
            /* FALLTHROUGH */
        case OP_SCOPE:
        case OP_LEAVE:
        case OP_LEAVETRY:
        case OP_LEAVELOOP:
        case OP_LINESEQ:
        case OP_LEAVEGIVEN:
        case OP_LEAVEWHEN:
        kids:
            next_kid = cLISTOPo->op_first;
            break;
        case OP_LIST:
            /* If the first kid after pushmark is something that the padrange
               optimisation would reject, then null the list and the pushmark.
            */
            if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
                && (  !(kid = OpSIBLING(kid))
                      || (  kid->op_type != OP_PADSV
                            && kid->op_type != OP_PADAV
                            && kid->op_type != OP_PADHV)
                      || kid->op_private & ~OPpLVAL_INTRO
                      || !(kid = OpSIBLING(kid))
                      || (  kid->op_type != OP_PADSV
                            && kid->op_type != OP_PADAV
                            && kid->op_type != OP_PADHV)
                      || kid->op_private & ~OPpLVAL_INTRO)
            ) {
                op_null(cUNOPo->op_first); /* NULL the pushmark */
                op_null(o); /* NULL the list */
            }
            goto kids;
        case OP_ENTEREVAL:
            scalarkids(o);
            break;
        case OP_SCALAR:
            scalar(o);
            break;
        }

        if (useless_sv) {
            /* mortalise it, in case warnings are fatal.  */
            Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
                           "Useless use of %" SVf " in void context",
                           SVfARG(sv_2mortal(useless_sv)));
        }
        else if (useless) {
            Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
                           "Useless use of %s in void context",
                           useless);
        }

      get_next_op:
        /* if a kid hasn't been nominated to process, continue with the
         * next sibling, or if no siblings left, go back to the parent's
         * siblings and so on
         */
        while (!next_kid) {
            if (o == arg)
                return arg; /* at top; no parents/siblings to try */
            if (OpHAS_SIBLING(o))
                next_kid = o->op_sibparent;
            else
                o = o->op_sibparent; /*try parent's next sibling */
        }
        o = next_kid;
    }

    return arg;
}


static OP *
S_listkids(pTHX_ OP *o)
{
    if (o && o->op_flags & OPf_KIDS) {
        OP *kid;
	for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
	    list(kid);
    }
    return o;
}


/* apply list context to the o subtree */

OP *
Perl_list(pTHX_ OP *o)
{
    OP * top_op = o;

    while (1) {
        OP *next_kid = NULL; /* what op (if any) to process next */

        OP *kid;

        /* assumes no premature commitment */
        if (!o || (o->op_flags & OPf_WANT)
             || (PL_parser && PL_parser->error_count)
             || o->op_type == OP_RETURN)
        {
            goto do_next;
        }

        if ((o->op_private & OPpTARGET_MY)
            && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
        {
            goto do_next;				/* As if inside SASSIGN */
        }

        o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;

        switch (o->op_type) {
        case OP_REPEAT:
            if (o->op_private & OPpREPEAT_DOLIST
             && !(o->op_flags & OPf_STACKED))
            {
                list(cBINOPo->op_first);
                kid = cBINOPo->op_last;
                /* optimise away (.....) x 1 */
                if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
                 && SvIVX(kSVOP_sv) == 1)
                {
                    op_null(o); /* repeat */
                    op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
                    /* const (rhs): */
                    op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
                }
            }
            break;

        case OP_OR:
        case OP_AND:
        case OP_COND_EXPR:
            /* impose list context on everything except the condition */
            next_kid = OpSIBLING(cUNOPo->op_first);
            break;

        default:
            if (!(o->op_flags & OPf_KIDS))
                break;
            /* possibly flatten 1..10 into a constant array */
            if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
                list(cBINOPo->op_first);
                gen_constant_list(o);
                goto do_next;
            }
            next_kid = cUNOPo->op_first; /* do all kids */
            break;

        case OP_LIST:
            if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
                op_null(cUNOPo->op_first); /* NULL the pushmark */
                op_null(o); /* NULL the list */
            }
            if (o->op_flags & OPf_KIDS)
                next_kid = cUNOPo->op_first; /* do all kids */
            break;

        /* the children of these ops are usually a list of statements,
         * except the leaves, whose first child is a corresponding enter
         */
        case OP_SCOPE:
        case OP_LINESEQ:
            kid = cLISTOPo->op_first;
            goto do_kids;
        case OP_LEAVE:
        case OP_LEAVETRY:
            kid = cLISTOPo->op_first;
            list(kid);
            kid = OpSIBLING(kid);
        do_kids:
            while (kid) {
                OP *sib = OpSIBLING(kid);
                /* Apply void context to all kids except the last, which
                 * is list. E.g.
                 *      @a = do { void; void; list }
                 * Except that 'when's are always list context, e.g.
                 *      @a = do { given(..) {
                    *                 when (..) { list }
                    *                 when (..) { list }
                    *                 ...
                    *                }}
                    */
                if (!sib) {
                    /* tail call optimise calling list() on the last kid */
                    next_kid = kid;
                    goto do_next;
                }
                else if (kid->op_type == OP_LEAVEWHEN)
                    list(kid);
                else
                    scalarvoid(kid);
                kid = sib;
            }
            NOT_REACHED; /* NOTREACHED */
            break;

        }

        /* If next_kid is set, someone in the code above wanted us to process
         * that kid and all its remaining siblings.  Otherwise, work our way
         * back up the tree */
      do_next:
        while (!next_kid) {
            if (o == top_op)
                return top_op; /* at top; no parents/siblings to try */
            if (OpHAS_SIBLING(o))
                next_kid = o->op_sibparent;
            else {
                o = o->op_sibparent; /*try parent's next sibling */
                switch (o->op_type) {
                case OP_SCOPE:
                case OP_LINESEQ:
                case OP_LIST:
                case OP_LEAVE:
                case OP_LEAVETRY:
                    /* should really restore PL_curcop to its old value, but
                     * setting it to PL_compiling is better than do nothing */
                    PL_curcop = &PL_compiling;
                }
            }


        }
        o = next_kid;
    } /* while */
}


static OP *
S_scalarseq(pTHX_ OP *o)
{
    if (o) {
	const OPCODE type = o->op_type;

	if (type == OP_LINESEQ || type == OP_SCOPE ||
	    type == OP_LEAVE || type == OP_LEAVETRY)
	{
     	    OP *kid, *sib;
	    for (kid = cLISTOPo->op_first; kid; kid = sib) {
		if ((sib = OpSIBLING(kid))
		 && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
		    || (  sib->op_targ != OP_NEXTSTATE
		       && sib->op_targ != OP_DBSTATE  )))
		{
		    scalarvoid(kid);
		}
	    }
	    PL_curcop = &PL_compiling;
	}
	o->op_flags &= ~OPf_PARENS;
	if (PL_hints & HINT_BLOCK_SCOPE)
	    o->op_flags |= OPf_PARENS;
    }
    else
	o = newOP(OP_STUB, 0);
    return o;
}

STATIC OP *
S_modkids(pTHX_ OP *o, I32 type)
{
    if (o && o->op_flags & OPf_KIDS) {
        OP *kid;
        for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
	    op_lvalue(kid, type);
    }
    return o;
}


/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
 * const fields. Also, convert CONST keys to HEK-in-SVs.
 * rop    is the op that retrieves the hash;
 * key_op is the first key
 * real   if false, only check (and possibly croak); don't update op
 */

STATIC void
S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
{
    PADNAME *lexname;
    GV **fields;
    bool check_fields;

    /* find the padsv corresponding to $lex->{} or @{$lex}{} */
    if (rop) {
        if (rop->op_first->op_type == OP_PADSV)
            /* @$hash{qw(keys here)} */
            rop = (UNOP*)rop->op_first;
        else {
            /* @{$hash}{qw(keys here)} */
            if (rop->op_first->op_type == OP_SCOPE
                && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
                {
                    rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
                }
            else
                rop = NULL;
        }
    }

    lexname = NULL; /* just to silence compiler warnings */
    fields  = NULL; /* just to silence compiler warnings */

    check_fields =
            rop
         && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
             SvPAD_TYPED(lexname))
         && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
         && isGV(*fields) && GvHV(*fields);

    for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
        SV **svp, *sv;
        if (key_op->op_type != OP_CONST)
            continue;
        svp = cSVOPx_svp(key_op);

        /* make sure it's not a bareword under strict subs */
        if (key_op->op_private & OPpCONST_BARE &&
            key_op->op_private & OPpCONST_STRICT)
        {
            no_bareword_allowed((OP*)key_op);
        }

        /* Make the CONST have a shared SV */
        if (   !SvIsCOW_shared_hash(sv = *svp)
            && SvTYPE(sv) < SVt_PVMG
            && SvOK(sv)
            && !SvROK(sv)
            && real)
        {
            SSize_t keylen;
            const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
            SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
            SvREFCNT_dec_NN(sv);
            *svp = nsv;
        }

        if (   check_fields
            && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
        {
            Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
                        "in variable %" PNf " of type %" HEKf,
                        SVfARG(*svp), PNfARG(lexname),
                        HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
        }
    }
}

/* info returned by S_sprintf_is_multiconcatable() */

struct sprintf_ismc_info {
    SSize_t nargs;    /* num of args to sprintf (not including the format) */
    char  *start;     /* start of raw format string */
    char  *end;       /* bytes after end of raw format string */
    STRLEN total_len; /* total length (in bytes) of format string, not
                         including '%s' and  half of '%%' */
    STRLEN variant;   /* number of bytes by which total_len_p would grow
                         if upgraded to utf8 */
    bool   utf8;      /* whether the format is utf8 */
};


/* is the OP_SPRINTF o suitable for converting into a multiconcat op?
 * i.e. its format argument is a const string with only '%s' and '%%'
 * formats, and the number of args is known, e.g.
 *    sprintf "a=%s f=%s", $a[0], scalar(f());
 * but not
 *    sprintf "i=%d a=%s f=%s", $i, @a, f();
 *
 * If successful, the sprintf_ismc_info struct pointed to by info will be
 * populated.
 */

STATIC bool
S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
{
    OP    *pm, *constop, *kid;
    SV    *sv;
    char  *s, *e, *p;
    SSize_t nargs, nformats;
    STRLEN cur, total_len, variant;
    bool   utf8;

    /* if sprintf's behaviour changes, die here so that someone
     * can decide whether to enhance this function or skip optimising
     * under those new circumstances */
    assert(!(o->op_flags & OPf_STACKED));
    assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
    assert(!(o->op_private & ~OPpARG4_MASK));

    pm = cUNOPo->op_first;
    if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
        return FALSE;
    constop = OpSIBLING(pm);
    if (!constop || constop->op_type != OP_CONST)
        return FALSE;
    sv = cSVOPx_sv(constop);
    if (SvMAGICAL(sv) || !SvPOK(sv))
        return FALSE;

    s = SvPV(sv, cur);
    e = s + cur;

    /* Scan format for %% and %s and work out how many %s there are.
     * Abandon if other format types are found.
     */

    nformats  = 0;
    total_len = 0;
    variant   = 0;

    for (p = s; p < e; p++) {
        if (*p != '%') {
            total_len++;
            if (!UTF8_IS_INVARIANT(*p))
                variant++;
            continue;
        }
        p++;
        if (p >= e)
            return FALSE; /* lone % at end gives "Invalid conversion" */
        if (*p == '%')
            total_len++;
        else if (*p == 's')
            nformats++;
        else
            return FALSE;
    }

    if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
        return FALSE;

    utf8 = cBOOL(SvUTF8(sv));
    if (utf8)
        variant = 0;

    /* scan args; they must all be in scalar cxt */

    nargs = 0;
    kid = OpSIBLING(constop);

    while (kid) {
        if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
            return FALSE;
        nargs++;
        kid = OpSIBLING(kid);
    }

    if (nargs != nformats)
        return FALSE; /* e.g. sprintf("%s%s", $a); */


    info->nargs      = nargs;
    info->start      = s;
    info->end        = e;
    info->total_len  = total_len;
    info->variant    = variant;
    info->utf8       = utf8;

    return TRUE;
}



/* S_maybe_multiconcat():
 *
 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
 * convert it (and its children) into an OP_MULTICONCAT. See the code
 * comments just before pp_multiconcat() for the full details of what
 * OP_MULTICONCAT supports.
 *
 * Basically we're looking for an optree with a chain of OP_CONCATS down
 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
 *
 *      $x = "$a$b-$c"
 *
 *  looks like
 *
 *      SASSIGN
 *         |
 *      STRINGIFY   -- PADSV[$x]
 *         |
 *         |
 *      ex-PUSHMARK -- CONCAT/S
 *                        |
 *                     CONCAT/S  -- PADSV[$d]
 *                        |
 *                     CONCAT    -- CONST["-"]
 *                        |
 *                     PADSV[$a] -- PADSV[$b]
 *
 * Note that at this stage the OP_SASSIGN may have already been optimised
 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
 */

STATIC void
S_maybe_multiconcat(pTHX_ OP *o)
{
    dVAR;
    OP *lastkidop;   /* the right-most of any kids unshifted onto o */
    OP *topop;       /* the top-most op in the concat tree (often equals o,
                        unless there are assign/stringify ops above it */
    OP *parentop;    /* the parent op of topop (or itself if no parent) */
    OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
    OP *targetop;    /* the op corresponding to target=... or target.=... */
    OP *stringop;    /* the OP_STRINGIFY op, if any */
    OP *nextop;      /* used for recreating the op_next chain without consts */
    OP *kid;         /* general-purpose op pointer */
    UNOP_AUX_item *aux;
    UNOP_AUX_item *lenp;
    char *const_str, *p;
    struct sprintf_ismc_info sprintf_info;

                     /* store info about each arg in args[];
                      * toparg is the highest used slot; argp is a general
                      * pointer to args[] slots */
    struct {
        void *p;      /* initially points to const sv (or null for op);
                         later, set to SvPV(constsv), with ... */
        STRLEN len;   /* ... len set to SvPV(..., len) */
    } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];

    SSize_t nargs  = 0;
    SSize_t nconst = 0;
    SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
    STRLEN variant;
    bool utf8 = FALSE;
    bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
                                 the last-processed arg will the LHS of one,
                                 as args are processed in reverse order */
    U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
    STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
    U8 flags          = 0;   /* what will become the op_flags and ... */
    U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
    bool is_sprintf = FALSE; /* we're optimising an sprintf */
    bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
    bool prev_was_const = FALSE; /* previous arg was a const */

    /* -----------------------------------------------------------------
     * Phase 1:
     *
     * Examine the optree non-destructively to determine whether it's
     * suitable to be converted into an OP_MULTICONCAT. Accumulate
     * information about the optree in args[].
     */

    argp     = args;
    targmyop = NULL;
    targetop = NULL;
    stringop = NULL;
    topop    = o;
    parentop = o;

    assert(   o->op_type == OP_SASSIGN
           || o->op_type == OP_CONCAT
           || o->op_type == OP_SPRINTF
           || o->op_type == OP_STRINGIFY);

    Zero(&sprintf_info, 1, struct sprintf_ismc_info);

    /* first see if, at the top of the tree, there is an assign,
     * append and/or stringify */

    if (topop->op_type == OP_SASSIGN) {
        /* expr = ..... */
        if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
            return;
        if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
            return;
        assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */

        parentop = topop;
        topop = cBINOPo->op_first;
        targetop = OpSIBLING(topop);
        if (!targetop) /* probably some sort of syntax error */
            return;
    }
    else if (   topop->op_type == OP_CONCAT
             && (topop->op_flags & OPf_STACKED)
             && (!(topop->op_private & OPpCONCAT_NESTED))
            )
    {
        /* expr .= ..... */

        /* OPpTARGET_MY shouldn't be able to be set here. If it is,
         * decide what to do about it */
        assert(!(o->op_private & OPpTARGET_MY));

        /* barf on unknown flags */
        assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
        private_flags |= OPpMULTICONCAT_APPEND;
        targetop = cBINOPo->op_first;
        parentop = topop;
        topop    = OpSIBLING(targetop);

        /* $x .= <FOO> gets optimised to rcatline instead */
        if (topop->op_type == OP_READLINE)
            return;
    }

    if (targetop) {
        /* Can targetop (the LHS) if it's a padsv, be be optimised
         * away and use OPpTARGET_MY instead?
         */
        if (    (targetop->op_type == OP_PADSV)
            && !(targetop->op_private & OPpDEREF)
            && !(targetop->op_private & OPpPAD_STATE)
               /* we don't support 'my $x .= ...' */
            && (   o->op_type == OP_SASSIGN
                || !(targetop->op_private & OPpLVAL_INTRO))
        )
            is_targable = TRUE;
    }

    if (topop->op_type == OP_STRINGIFY) {
        if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
            return;
        stringop = topop;

        /* barf on unknown flags */
        assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));

        if ((topop->op_private & OPpTARGET_MY)) {
            if (o->op_type == OP_SASSIGN)
                return; /* can't have two assigns */
            targmyop = topop;
        }

        private_flags |= OPpMULTICONCAT_STRINGIFY;
        parentop = topop;
        topop = cBINOPx(topop)->op_first;
        assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
        topop = OpSIBLING(topop);
    }

    if (topop->op_type == OP_SPRINTF) {
        if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
            return;
        if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
            nargs     = sprintf_info.nargs;
            total_len = sprintf_info.total_len;
            variant   = sprintf_info.variant;
            utf8      = sprintf_info.utf8;
            is_sprintf = TRUE;
            private_flags |= OPpMULTICONCAT_FAKE;
            toparg = argp;
            /* we have an sprintf op rather than a concat optree.
             * Skip most of the code below which is associated with
             * processing that optree. We also skip phase 2, determining
             * whether its cost effective to optimise, since for sprintf,
             * multiconcat is *always* faster */
            goto create_aux;
        }
        /* note that even if the sprintf itself isn't multiconcatable,
         * the expression as a whole may be, e.g. in
         *    $x .= sprintf("%d",...)
         * the sprintf op will be left as-is, but the concat/S op may
         * be upgraded to multiconcat
         */
    }
    else if (topop->op_type == OP_CONCAT) {
        if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
            return;

        if ((topop->op_private & OPpTARGET_MY)) {
            if (o->op_type == OP_SASSIGN || targmyop)
                return; /* can't have two assigns */
            targmyop = topop;
        }
    }

    /* Is it safe to convert a sassign/stringify/concat op into
     * a multiconcat? */
    assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
    assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
    assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
    assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
    STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
                       == STRUCT_OFFSET(UNOP_AUX, op_aux));
    STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
                       == STRUCT_OFFSET(UNOP_AUX, op_aux));

    /* Now scan the down the tree looking for a series of
     * CONCAT/OPf_STACKED ops on the LHS (with the last one not
     * stacked). For example this tree:
     *
     *     |
     *   CONCAT/STACKED
     *     |
     *   CONCAT/STACKED -- EXPR5
     *     |
     *   CONCAT/STACKED -- EXPR4
     *     |
     *   CONCAT -- EXPR3
     *     |
     *   EXPR1  -- EXPR2
     *
     * corresponds to an expression like
     *
     *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
     *
     * Record info about each EXPR in args[]: in particular, whether it is
     * a stringifiable OP_CONST and if so what the const sv is.
     *
     * The reason why the last concat can't be STACKED is the difference
     * between
     *
     *    ((($a .= $a) .= $a) .= $a) .= $a
     *
     * and
     *    $a . $a . $a . $a . $a
     *
     * The main difference between the optrees for those two constructs
     * is the presence of the last STACKED. As well as modifying $a,
     * the former sees the changed $a between each concat, so if $s is
     * initially 'a', the first returns 'a' x 16, while the latter returns
     * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
     */

    kid = topop;

    for (;;) {
        OP *argop;
        SV *sv;
        bool last = FALSE;

        if (    kid->op_type == OP_CONCAT
            && !kid_is_last
        ) {
            OP *k1, *k2;
            k1 = cUNOPx(kid)->op_first;
            k2 = OpSIBLING(k1);
            /* shouldn't happen except maybe after compile err? */
            if (!k2)
                return;

            /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
            if (kid->op_private & OPpTARGET_MY)
                kid_is_last = TRUE;

            stacked_last = (kid->op_flags & OPf_STACKED);
            if (!stacked_last)
                kid_is_last = TRUE;

            kid   = k1;
            argop = k2;
        }
        else {
            argop = kid;
            last = TRUE;
        }

        if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
            || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
        {
            /* At least two spare slots are needed to decompose both
             * concat args. If there are no slots left, continue to
             * examine the rest of the optree, but don't push new values
             * on args[]. If the optree as a whole is legal for conversion
             * (in particular that the last concat isn't STACKED), then
             * the first PERL_MULTICONCAT_MAXARG elements of the optree
             * can be converted into an OP_MULTICONCAT now, with the first
             * child of that op being the remainder of the optree -
             * which may itself later be converted to a multiconcat op
             * too.
             */
            if (last) {
                /* the last arg is the rest of the optree */
                argp++->p = NULL;
                nargs++;
            }
        }
        else if (   argop->op_type == OP_CONST
            && ((sv = cSVOPx_sv(argop)))
            /* defer stringification until runtime of 'constant'
             * things that might stringify variantly, e.g. the radix
             * point of NVs, or overloaded RVs */
            && (SvPOK(sv) || SvIOK(sv))
            && (!SvGMAGICAL(sv))
        ) {
            if (argop->op_private & OPpCONST_STRICT)
                no_bareword_allowed(argop);
            argp++->p = sv;
            utf8   |= cBOOL(SvUTF8(sv));
            nconst++;
            if (prev_was_const)
                /* this const may be demoted back to a plain arg later;
                 * make sure we have enough arg slots left */
                nadjconst++;
            prev_was_const = !prev_was_const;
        }
        else {
            argp++->p = NULL;
            nargs++;
            prev_was_const = FALSE;
        }

        if (last)
            break;
    }

    toparg = argp - 1;

    if (stacked_last)
        return; /* we don't support ((A.=B).=C)...) */

    /* look for two adjacent consts and don't fold them together:
     *     $o . "a" . "b"
     * should do
     *     $o->concat("a")->concat("b")
     * rather than
     *     $o->concat("ab")
     * (but $o .=  "a" . "b" should still fold)
     */
    {
        bool seen_nonconst = FALSE;
        for (argp = toparg; argp >= args; argp--) {
            if (argp->p == NULL) {
                seen_nonconst = TRUE;
                continue;
            }
            if (!seen_nonconst)
                continue;
            if (argp[1].p) {
                /* both previous and current arg were constants;
                 * leave the current OP_CONST as-is */
                argp->p = NULL;
                nconst--;
                nargs++;
            }
        }
    }

    /* -----------------------------------------------------------------
     * Phase 2:
     *
     * At this point we have determined that the optree *can* be converted
     * into a multiconcat. Having gathered all the evidence, we now decide
     * whether it *should*.
     */


    /* we need at least one concat action, e.g.:
     *
     *  Y . Z
     *  X = Y . Z
     *  X .= Y
     *
     * otherwise we could be doing something like $x = "foo", which
     * if treated as as a concat, would fail to COW.
     */
    if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
        return;

    /* Benchmarking seems to indicate that we gain if:
     * * we optimise at least two actions into a single multiconcat
     *    (e.g concat+concat, sassign+concat);
     * * or if we can eliminate at least 1 OP_CONST;
     * * or if we can eliminate a padsv via OPpTARGET_MY
     */

    if (
           /* eliminated at least one OP_CONST */
           nconst >= 1
           /* eliminated an OP_SASSIGN */
        || o->op_type == OP_SASSIGN
           /* eliminated an OP_PADSV */
        || (!targmyop && is_targable)
    )
        /* definitely a net gain to optimise */
        goto optimise;

    /* ... if not, what else? */

    /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
     * multiconcat is faster (due to not creating a temporary copy of
     * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
     * faster.
     */
    if (   nconst == 0
         && nargs == 2
         && targmyop
         && topop->op_type == OP_CONCAT
    ) {
        PADOFFSET t = targmyop->op_targ;
        OP *k1 = cBINOPx(topop)->op_first;
        OP *k2 = cBINOPx(topop)->op_last;
        if (   k2->op_type == OP_PADSV
            && k2->op_targ == t
            && (   k1->op_type != OP_PADSV
                || k1->op_targ != t)
        )
            goto optimise;
    }

    /* need at least two concats */
    if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
        return;



    /* -----------------------------------------------------------------
     * Phase 3:
     *
     * At this point the optree has been verified as ok to be optimised
     * into an OP_MULTICONCAT. Now start changing things.
     */

   optimise:

    /* stringify all const args and determine utf8ness */

    variant = 0;
    for (argp = args; argp <= toparg; argp++) {
        SV *sv = (SV*)argp->p;
        if (!sv)
            continue; /* not a const op */
        if (utf8 && !SvUTF8(sv))
            sv_utf8_upgrade_nomg(sv);
        argp->p = SvPV_nomg(sv, argp->len);
        total_len += argp->len;

        /* see if any strings would grow if converted to utf8 */
        if (!utf8) {
            variant += variant_under_utf8_count((U8 *) argp->p,
                                                (U8 *) argp->p + argp->len);
        }
    }

    /* create and populate aux struct */

  create_aux:

    aux = (UNOP_AUX_item*)PerlMemShared_malloc(
                    sizeof(UNOP_AUX_item)
                    *  (
                           PERL_MULTICONCAT_HEADER_SIZE
                         + ((nargs + 1) * (variant ? 2 : 1))
                        )
                    );
    const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);

    /* Extract all the non-const expressions from the concat tree then
     * dispose of the old tree, e.g. convert the tree from this:
     *
     *  o => SASSIGN
     *         |
     *       STRINGIFY   -- TARGET
     *         |
     *       ex-PUSHMARK -- CONCAT
     *                        |
     *                      CONCAT -- EXPR5
     *                        |
     *                      CONCAT -- EXPR4
     *                        |
     *                      CONCAT -- EXPR3
     *                        |
     *                      EXPR1  -- EXPR2
     *
     *
     * to:
     *
     *  o => MULTICONCAT
     *         |
     *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
     *
     * except that if EXPRi is an OP_CONST, it's discarded.
     *
     * During the conversion process, EXPR ops are stripped from the tree
     * and unshifted onto o. Finally, any of o's remaining original
     * childen are discarded and o is converted into an OP_MULTICONCAT.
     *
     * In this middle of this, o may contain both: unshifted args on the
     * left, and some remaining original args on the right. lastkidop
     * is set to point to the right-most unshifted arg to delineate
     * between the two sets.
     */


    if (is_sprintf) {
        /* create a copy of the format with the %'s removed, and record
         * the sizes of the const string segments in the aux struct */
        char *q, *oldq;
        lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;

        p    = sprintf_info.start;
        q    = const_str;
        oldq = q;
        for (; p < sprintf_info.end; p++) {
            if (*p == '%') {
                p++;
                if (*p != '%') {
                    (lenp++)->ssize = q - oldq;
                    oldq = q;
                    continue;
                }
            }
            *q++ = *p;
        }
        lenp->ssize = q - oldq;
        assert((STRLEN)(q - const_str) == total_len);

        /* Attach all the args (i.e. the kids of the sprintf) to o (which
         * may or may not be topop) The pushmark and const ops need to be
         * kept in case they're an op_next entry point.
         */
        lastkidop = cLISTOPx(topop)->op_last;
        kid = cUNOPx(topop)->op_first; /* pushmark */
        op_null(kid);
        op_null(OpSIBLING(kid));       /* const */
        if (o != topop) {
            kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
            op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
            lastkidop->op_next = o;
        }
    }
    else {
        p = const_str;
        lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;

        lenp->ssize = -1;

        /* Concatenate all const strings into const_str.
         * Note that args[] contains the RHS args in reverse order, so
         * we scan args[] from top to bottom to get constant strings
         * in L-R order
         */
        for (argp = toparg; argp >= args; argp--) {
            if (!argp->p)
                /* not a const op */
                (++lenp)->ssize = -1;
            else {
                STRLEN l = argp->len;
                Copy(argp->p, p, l, char);
                p += l;
                if (lenp->ssize == -1)
                    lenp->ssize = l;
                else
                    lenp->ssize += l;
            }
        }

        kid = topop;
        nextop = o;
        lastkidop = NULL;

        for (argp = args; argp <= toparg; argp++) {
            /* only keep non-const args, except keep the first-in-next-chain
             * arg no matter what it is (but nulled if OP_CONST), because it
             * may be the entry point to this subtree from the previous
             * op_next.
             */
            bool last = (argp == toparg);
            OP *prev;

            /* set prev to the sibling *before* the arg to be cut out,
             * e.g. when cutting EXPR:
             *
             *         |
             * kid=  CONCAT
             *         |
             * prev= CONCAT -- EXPR
             *         |
             */
            if (argp == args && kid->op_type != OP_CONCAT) {
                /* in e.g. '$x .= f(1)' there's no RHS concat tree
                 * so the expression to be cut isn't kid->op_last but
                 * kid itself */
                OP *o1, *o2;
                /* find the op before kid */
                o1 = NULL;
                o2 = cUNOPx(parentop)->op_first;
                while (o2 && o2 != kid) {
                    o1 = o2;
                    o2 = OpSIBLING(o2);
                }
                assert(o2 == kid);
                prev = o1;
                kid  = parentop;
            }
            else if (kid == o && lastkidop)
                prev = last ? lastkidop : OpSIBLING(lastkidop);
            else
                prev = last ? NULL : cUNOPx(kid)->op_first;

            if (!argp->p || last) {
                /* cut RH op */
                OP *aop = op_sibling_splice(kid, prev, 1, NULL);
                /* and unshift to front of o */
                op_sibling_splice(o, NULL, 0, aop);
                /* record the right-most op added to o: later we will
                 * free anything to the right of it */
                if (!lastkidop)
                    lastkidop = aop;
                aop->op_next = nextop;
                if (last) {
                    if (argp->p)
                        /* null the const at start of op_next chain */
                        op_null(aop);
                }
                else if (prev)
                    nextop = prev->op_next;
            }

            /* the last two arguments are both attached to the same concat op */
            if (argp < toparg - 1)
                kid = prev;
        }
    }

    /* Populate the aux struct */

    aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
    aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
    aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
    aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
    aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;

    /* if variant > 0, calculate a variant const string and lengths where
     * the utf8 version of the string will take 'variant' more bytes than
     * the plain one. */

    if (variant) {
        char              *p = const_str;
        STRLEN          ulen = total_len + variant;
        UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
        UNOP_AUX_item *ulens = lens + (nargs + 1);
        char             *up = (char*)PerlMemShared_malloc(ulen);
        SSize_t            n;

        aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
        aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;

        for (n = 0; n < (nargs + 1); n++) {
            SSize_t i;
            char * orig_up = up;
            for (i = (lens++)->ssize; i > 0; i--) {
                U8 c = *p++;
                append_utf8_from_native_byte(c, (U8**)&up);
            }
            (ulens++)->ssize = (i < 0) ? i : up - orig_up;
        }
    }

    if (stringop) {
        /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
         * that op's first child - an ex-PUSHMARK - because the op_next of
         * the previous op may point to it (i.e. it's the entry point for
         * the o optree)
         */
        OP *pmop =
            (stringop == o)
                ? op_sibling_splice(o, lastkidop, 1, NULL)
                : op_sibling_splice(stringop, NULL, 1, NULL);
        assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
        op_sibling_splice(o, NULL, 0, pmop);
        if (!lastkidop)
            lastkidop = pmop;
    }

    /* Optimise
     *    target  = A.B.C...
     *    target .= A.B.C...
     */

    if (targetop) {
        assert(!targmyop);

        if (o->op_type == OP_SASSIGN) {
            /* Move the target subtree from being the last of o's children
             * to being the last of o's preserved children.
             * Note the difference between 'target = ...' and 'target .= ...':
             * for the former, target is executed last; for the latter,
             * first.
             */
            kid = OpSIBLING(lastkidop);
            op_sibling_splice(o, kid, 1, NULL); /* cut target op */
            op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
            lastkidop->op_next = kid->op_next;
            lastkidop = targetop;
        }
        else {
            /* Move the target subtree from being the first of o's
             * original children to being the first of *all* o's children.
             */
            if (lastkidop) {
                op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
                op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
            }
            else {
                /* if the RHS of .= doesn't contain a concat (e.g.
                 * $x .= "foo"), it gets missed by the "strip ops from the
                 * tree and add to o" loop earlier */
                assert(topop->op_type != OP_CONCAT);
                if (stringop) {
                    /* in e.g. $x .= "$y", move the $y expression
                     * from being a child of OP_STRINGIFY to being the
                     * second child of the OP_CONCAT
                     */
                    assert(cUNOPx(stringop)->op_first == topop);
                    op_sibling_splice(stringop, NULL, 1, NULL);
                    op_sibling_splice(o, cUNOPo->op_first, 0, topop);
                }
                assert(topop == OpSIBLING(cBINOPo->op_first));
                if (toparg->p)
                    op_null(topop);
                lastkidop = topop;
            }
        }

        if (is_targable) {
            /* optimise
             *  my $lex  = A.B.C...
             *     $lex  = A.B.C...
             *     $lex .= A.B.C...
             * The original padsv op is kept but nulled in case it's the
             * entry point for the optree (which it will be for
             * '$lex .=  ... '
             */
            private_flags |= OPpTARGET_MY;
            private_flags |= (targetop->op_private & OPpLVAL_INTRO);
            o->op_targ = targetop->op_targ;
            targetop->op_targ = 0;
            op_null(targetop);
        }
        else
            flags |= OPf_STACKED;
    }
    else if (targmyop) {
        private_flags |= OPpTARGET_MY;
        if (o != targmyop) {
            o->op_targ = targmyop->op_targ;
            targmyop->op_targ = 0;
        }
    }

    /* detach the emaciated husk of the sprintf/concat optree and free it */
    for (;;) {
        kid = op_sibling_splice(o, lastkidop, 1, NULL);
        if (!kid)
            break;
        op_free(kid);
    }

    /* and convert o into a multiconcat */

    o->op_flags        = (flags|OPf_KIDS|stacked_last
                         |(o->op_flags & (OPf_WANT|OPf_PARENS)));
    o->op_private      = private_flags;
    o->op_type         = OP_MULTICONCAT;
    o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
    cUNOP_AUXo->op_aux = aux;
}


/* do all the final processing on an optree (e.g. running the peephole
 * optimiser on it), then attach it to cv (if cv is non-null)
 */

static void
S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
{
    OP **startp;

    /* XXX for some reason, evals, require and main optrees are
     * never attached to their CV; instead they just hang off
     * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
     * and get manually freed when appropriate */
    if (cv)
        startp = &CvSTART(cv);
    else
        startp = PL_in_eval? &PL_eval_start : &PL_main_start;

    *startp = start;
    optree->op_private |= OPpREFCOUNTED;
    OpREFCNT_set(optree, 1);
    optimize_optree(optree);
    CALL_PEEP(*startp);
    finalize_optree(optree);
    S_prune_chain_head(startp);

    if (cv) {
        /* now that optimizer has done its work, adjust pad values */
        pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
                 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
    }
}


/*
=for apidoc optimize_optree

This function applies some optimisations to the optree in top-down order.
It is called before the peephole optimizer, which processes ops in
execution order. Note that finalize_optree() also does a top-down scan,
but is called *after* the peephole optimizer.

=cut
*/

void
Perl_optimize_optree(pTHX_ OP* o)
{
    PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;

    ENTER;
    SAVEVPTR(PL_curcop);

    optimize_op(o);

    LEAVE;
}


/* helper for optimize_optree() which optimises one op then recurses
 * to optimise any children.
 */

STATIC void
S_optimize_op(pTHX_ OP* o)
{
    OP *top_op = o;

    PERL_ARGS_ASSERT_OPTIMIZE_OP;

    while (1) {
        OP * next_kid = NULL;

        assert(o->op_type != OP_FREED);

        switch (o->op_type) {
        case OP_NEXTSTATE:
        case OP_DBSTATE:
            PL_curcop = ((COP*)o);		/* for warnings */
            break;


        case OP_CONCAT:
        case OP_SASSIGN:
        case OP_STRINGIFY:
        case OP_SPRINTF:
            S_maybe_multiconcat(aTHX_ o);
            break;

        case OP_SUBST:
            if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
                /* we can't assume that op_pmreplroot->op_sibparent == o
                 * and that it is thus possible to walk back up the tree
                 * past op_pmreplroot. So, although we try to avoid
                 * recursing through op trees, do it here. After all,
                 * there are unlikely to be many nested s///e's within
                 * the replacement part of a s///e.
                 */
                optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
            }
            break;

        default:
            break;
        }

        if (o->op_flags & OPf_KIDS)
            next_kid = cUNOPo->op_first;

        /* if a kid hasn't been nominated to process, continue with the
         * next sibling, or if no siblings left, go back to the parent's
         * siblings and so on
         */
        while (!next_kid) {
            if (o == top_op)
                return; /* at top; no parents/siblings to try */
            if (OpHAS_SIBLING(o))
                next_kid = o->op_sibparent;
            else
                o = o->op_sibparent; /*try parent's next sibling */
        }

      /* this label not yet used. Goto here if any code above sets
       * next-kid
       get_next_op:
       */
        o = next_kid;
    }
}


/*
=for apidoc finalize_optree

This function finalizes the optree.  Should be called directly after
the complete optree is built.  It does some additional
checking which can't be done in the normal C<ck_>xxx functions and makes
the tree thread-safe.

=cut
*/
void
Perl_finalize_optree(pTHX_ OP* o)
{
    PERL_ARGS_ASSERT_FINALIZE_OPTREE;

    ENTER;
    SAVEVPTR(PL_curcop);

    finalize_op(o);

    LEAVE;
}

#ifdef USE_ITHREADS
/* Relocate sv to the pad for thread safety.
 * Despite being a "constant", the SV is written to,
 * for reference counts, sv_upgrade() etc. */
PERL_STATIC_INLINE void
S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
{
    PADOFFSET ix;
    PERL_ARGS_ASSERT_OP_RELOCATE_SV;
    if (!*svp) return;
    ix = pad_alloc(OP_CONST, SVf_READONLY);
    SvREFCNT_dec(PAD_SVl(ix));
    PAD_SETSV(ix, *svp);
    /* XXX I don't know how this isn't readonly already. */
    if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
    *svp = NULL;
    *targp = ix;
}
#endif

/*
=for apidoc traverse_op_tree

Return the next op in a depth-first traversal of the op tree,
returning NULL when the traversal is complete.

The initial call must supply the root of the tree as both top and o.

For now it's static, but it may be exposed to the API in the future.

=cut
*/

STATIC OP*
S_traverse_op_tree(pTHX_ OP *top, OP *o) {
    OP *sib;

    PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;

    if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
        return cUNOPo->op_first;
    }
    else if ((sib = OpSIBLING(o))) {
        return sib;
    }
    else {
        OP *parent = o->op_sibparent;
        assert(!(o->op_moresib));
        while (parent && parent != top) {
            OP *sib = OpSIBLING(parent);
            if (sib)
                return sib;
            parent = parent->op_sibparent;
        }

        return NULL;
    }
}

STATIC void
S_finalize_op(pTHX_ OP* o)
{
    OP * const top = o;
    PERL_ARGS_ASSERT_FINALIZE_OP;

    do {
        assert(o->op_type != OP_FREED);

        switch (o->op_type) {
        case OP_NEXTSTATE:
        case OP_DBSTATE:
            PL_curcop = ((COP*)o);		/* for warnings */
            break;
        case OP_EXEC:
            if (OpHAS_SIBLING(o)) {
                OP *sib = OpSIBLING(o);
                if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
                    && ckWARN(WARN_EXEC)
                    && OpHAS_SIBLING(sib))
                {
		    const OPCODE type = OpSIBLING(sib)->op_type;
		    if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
			const line_t oldline = CopLINE(PL_curcop);
			CopLINE_set(PL_curcop, CopLINE((COP*)sib));
			Perl_warner(aTHX_ packWARN(WARN_EXEC),
			    "Statement unlikely to be reached");
			Perl_warner(aTHX_ packWARN(WARN_EXEC),
			    "\t(Maybe you meant system() when you said exec()?)\n");
			CopLINE_set(PL_curcop, oldline);
		    }
                }
            }
            break;

        case OP_GV:
            if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
                GV * const gv = cGVOPo_gv;
                if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
                    /* XXX could check prototype here instead of just carping */
                    SV * const sv = sv_newmortal();
                    gv_efullname3(sv, gv, NULL);
                    Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
                                "%" SVf "() called too early to check prototype",
                                SVfARG(sv));
                }
            }
            break;

        case OP_CONST:
            if (cSVOPo->op_private & OPpCONST_STRICT)
                no_bareword_allowed(o);
#ifdef USE_ITHREADS
            /* FALLTHROUGH */
        case OP_HINTSEVAL:
            op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
#endif
            break;

#ifdef USE_ITHREADS
            /* Relocate all the METHOP's SVs to the pad for thread safety. */
        case OP_METHOD_NAMED:
        case OP_METHOD_SUPER:
        case OP_METHOD_REDIR:
        case OP_METHOD_REDIR_SUPER:
            op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
            break;
#endif

        case OP_HELEM: {
            UNOP *rop;
            SVOP *key_op;
            OP *kid;

            if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
                break;

            rop = (UNOP*)((BINOP*)o)->op_first;

            goto check_keys;

            case OP_HSLICE:
                S_scalar_slice_warning(aTHX_ o);
                /* FALLTHROUGH */

            case OP_KVHSLICE:
                kid = OpSIBLING(cLISTOPo->op_first);
	    if (/* I bet there's always a pushmark... */
	        OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
	        && OP_TYPE_ISNT_NN(kid, OP_CONST))
            {
	        break;
            }

            key_op = (SVOP*)(kid->op_type == OP_CONST
                             ? kid
                             : OpSIBLING(kLISTOP->op_first));

            rop = (UNOP*)((LISTOP*)o)->op_last;

        check_keys:
            if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
                rop = NULL;
            S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
            break;
        }
        case OP_NULL:
            if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
                break;
            /* FALLTHROUGH */
        case OP_ASLICE:
            S_scalar_slice_warning(aTHX_ o);
            break;

        case OP_SUBST: {
            if (cPMOPo->op_pmreplrootu.op_pmreplroot)
                finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
            break;
        }
        default:
            break;
        }

#ifdef DEBUGGING
        if (o->op_flags & OPf_KIDS) {
            OP *kid;

            /* check that op_last points to the last sibling, and that
             * the last op_sibling/op_sibparent field points back to the
             * parent, and that the only ops with KIDS are those which are
             * entitled to them */
            U32 type = o->op_type;
            U32 family;
            bool has_last;

            if (type == OP_NULL) {
                type = o->op_targ;
                /* ck_glob creates a null UNOP with ex-type GLOB
                 * (which is a list op. So pretend it wasn't a listop */
                if (type == OP_GLOB)
                    type = OP_NULL;
            }
            family = PL_opargs[type] & OA_CLASS_MASK;

            has_last = (   family == OA_BINOP
                        || family == OA_LISTOP
                        || family == OA_PMOP
                        || family == OA_LOOP
                       );
            assert(  has_last /* has op_first and op_last, or ...
                  ... has (or may have) op_first: */
                  || family == OA_UNOP
                  || family == OA_UNOP_AUX