#define PERL_NO_GET_CONTEXT 1
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#ifndef newSTUB
# define newSTUB(gv, fake) THX_newSTUB(aTHX_ gv, fake)
static CV *THX_newSTUB(pTHX_ GV *gv, bool fake)
{
	CV *cv = (CV*)newSV_type(SVt_PVCV);
	GV *cvgv;
	assert(!GvCVu(gv));
	GvCV_set(gv, cv);
	GvCVGEN(gv) = 0;
	if(!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
		gv_method_changed(gv);
	if(SvFAKE(gv)) {
		cvgv = gv_fetchsv((SV*)gv, GV_ADDMULTI, SVt_PVCV);
		SvFAKE_off(cvgv);
	} else
		cvgv = gv;
	CvGV_set(cv, cvgv);
	CvFILE_set_from_cop(cv, PL_curcop);
	CvSTASH_set(cv, PL_curstash);
	GvMULTI_on(gv);
	return cv;
}
#endif /* !newSTUB */

#define SvREADONLY_fully_on(sv) (SvFLAGS(sv) |= SVf_READONLY|SVf_PROTECT)
#define SvREADONLY_fully_off(sv) (SvFLAGS(sv) &= ~(SVf_READONLY|SVf_PROTECT))
#define SvREADONLY_slightly_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
#define SvREADONLY_slightly_off(sv) (SvFLAGS(sv) &= ~SVf_READONLY)

#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
#define sv_is_undef(sv) (!sv_is_glob(sv) && !sv_is_regexp(sv) && !SvOK(sv))

#define Q_OPp_CONSTRUCT_READONLY   0x01
#define Q_OPp_FIXED_INDEX          0x02
#define Q_OPp_PAD_TUPLE            0x04
#define Q_OPp_SLOTVAL_MASK         0x38
#define Q_OPp_SLOTVAL_RV2SV_LAX    0x08
#define Q_OPp_SLOTVAL_RV2SV_STRICT 0x10
#define Q_OPp_SLOTVAL_RV2AV        0x18
#define Q_OPp_SLOTVAL_RV2HV        0x20
#define Q_OPp_SLOTVAL_RV2CV        0x28
#define Q_OPp_SLOTVAL_RV2GV        0x30

#define Q_CKf_FOLD              0x0100
#define Q_CKf_NOT_SCALAR_RETURN 0x0200
#define Q_ARGf_TUPLE            0x0400
#define Q_ARGf_INDEX            0x0800
#define Q_ARGf_REF              0x1000
#define Q_ARGf_REF_LIST         0x2000
#define Q_BTf_NO_REGISTER_XOP   0x4000
#define Q_BTf_SLOTVAL_RET       0x8000

#define Q_ARGf_LIST Q_ARGf_REF_LIST

typedef struct {
	UNOP unop;
	SSize_t index;
} Q_TUPLE_OP;

#define Q_POPs_TUPLE_ARG \
	(LIKELY(PL_op->op_private & Q_OPp_PAD_TUPLE) ? \
		PAD_SV(PL_op->op_targ) : POPs)

#define Q_POPs_INDEX_ARG \
	(LIKELY(PL_op->op_private & Q_OPp_FIXED_INDEX) ? NULL : POPs)
#define Q_GET_INDEX_VAL(ixsv) \
	(LIKELY(PL_op->op_private & Q_OPp_FIXED_INDEX) ? \
		((Q_TUPLE_OP*)PL_op)->index : index_from_arg(ixsv))

#define tuple_from_arg(arg) THX_tuple_from_arg(aTHX_ arg)
PERL_STATIC_INLINE SV *THX_tuple_from_arg(pTHX_ SV *arg)
{
	SV *tuple;
	SvGETMAGIC(arg);
	if(!LIKELY(SvROK(arg) && (tuple = SvRV(arg)) &&
			SvTYPE(tuple) == SVt_PVOBJ))
		croak("tuple argument is not a tuple reference");
	return tuple;
}

#define slotval_from_arg(arg) THX_slotval_from_arg(aTHX_ arg)
PERL_STATIC_INLINE SV *THX_slotval_from_arg(pTHX_ SV *arg)
{
	SvGETMAGIC(arg);
	if(LIKELY(SvROK(arg))) {
		return SvRV(arg);
	} else if(LIKELY(sv_is_undef(arg))) {
		return NULL;
	} else {
		croak("slot value is neither a reference nor undefined");
	}
}

#define slotval_as_ret(slotval) THX_slotval_as_ret(aTHX_ slotval)
PERL_STATIC_INLINE SV *THX_slotval_as_ret(pTHX_ SV *slotval)
{
	if(!LIKELY(slotval)) {
		return &PL_sv_undef;
	} else {
		SV *refsv = sv_2mortal(newRV_inc(slotval));
		SvREADONLY_fully_on(refsv);
		return refsv;
	}
}

#define tuple_as_ret_takeref(tuple) THX_tuple_as_ret_takeref(aTHX_ tuple)
PERL_STATIC_INLINE SV *THX_tuple_as_ret_takeref(pTHX_ SV *tuple)
{
	SV *refsv = sv_2mortal(newRV_noinc(tuple));
	SvREADONLY_fully_on(refsv);
	return refsv;
}

#define tuple_as_ret(tuple) tuple_as_ret_takeref(SvREFCNT_inc(tuple))

#define index_from_arg(arg) THX_index_from_arg(aTHX_ arg)
PERL_STATIC_INLINE SSize_t THX_index_from_arg(pTHX_ SV *arg)
{
	IV ixiv = SvIV(arg);
	return UNLIKELY(((IV)(SSize_t)ixiv) != ixiv) ? -1 : ((SSize_t)ixiv);
}

static OP *THX_pp_tuple(pTHX)
{
	dMARK; dSP;
	SSize_t len = SP - MARK, i;
	SV *tuple;
	for(i = 0; i != len; i++) MARK[1+i] = slotval_from_arg(MARK[1+i]);
	tuple = newSV_type(SVt_PVOBJ);
	if(LIKELY(len != 0)) {
		SV **fields;
		Newx(fields, len, SV*);
		Copy(MARK+1, fields, len, SV*);
		for(i = 0; i != len; i++) SvREFCNT_inc(fields[i]);
		ObjectFIELDS(tuple) = fields;
		ObjectMAXFIELD(tuple) = len - 1;
	}
	if(PL_op->op_private & Q_OPp_CONSTRUCT_READONLY)
		SvREADONLY_fully_on(tuple);
	SP = MARK;
	if(UNLIKELY(len == 0)) EXTEND(SP, 1);
	if(PL_op->op_private & Q_OPp_PAD_TUPLE) {
		SV **padentry = &PAD_SVl(PL_op->op_targ), *targ = *padentry;
		if(PL_op->op_flags & OPf_SPECIAL) save_clearsv(padentry);
		TAINT_NOT;
		sv_setrv_noinc_mg(targ, tuple);
		PUSHs(targ);
	} else {
		PUSHs(tuple_as_ret_takeref(tuple));
	}
	PUTBACK;
	return NORMAL;
}

static OP *THX_pp_tuple_mutable(pTHX)
{
	dSP;
	SV *tuple = tuple_from_arg(Q_POPs_TUPLE_ARG);
	XPUSHs(boolSV(!SvREADONLY(tuple)));
	PUTBACK;
	return NORMAL;
}

static OP *THX_pp_tuple_length(pTHX)
{
	dSP;
	SV *tuple = tuple_from_arg(Q_POPs_TUPLE_ARG);
	SV *lensv = sv_2mortal(newSViv(ObjectMAXFIELD(tuple) + 1));
	SvREADONLY_fully_on(lensv);
	XPUSHs(lensv);
	PUTBACK;
	return NORMAL;
}

static OP *THX_pp2_slotval_ret(pTHX_ SV *slotval)
{
	int deref_method;
	switch(PL_op->op_private & Q_OPp_SLOTVAL_MASK) {
		case 0: slotval = slotval_as_ret(slotval); goto finalised;
		case Q_OPp_SLOTVAL_RV2SV_LAX:
		case Q_OPp_SLOTVAL_RV2SV_STRICT:
			deref_method = to_sv_amg;
			break;
		case Q_OPp_SLOTVAL_RV2AV: deref_method = to_av_amg; break;
		case Q_OPp_SLOTVAL_RV2HV: deref_method = to_hv_amg; break;
		case Q_OPp_SLOTVAL_RV2CV: deref_method = to_cv_amg; break;
		case Q_OPp_SLOTVAL_RV2GV: deref_method = to_gv_amg; break;
		default: assert(0); goto finalised;
	}
	if(LIKELY(slotval) && UNLIKELY(SvOBJECT(slotval)) &&
			UNLIKELY(HvAMAGIC(SvSTASH(slotval)))) {
		SV *rv = amagic_deref_call(sv_2mortal(newRV_inc(slotval)),
				deref_method);
		slotval = SvRV(rv);
	}
	switch(PL_op->op_private & Q_OPp_SLOTVAL_MASK) {
		case Q_OPp_SLOTVAL_RV2SV_LAX: {
			if(!LIKELY(slotval)) {
				if(ckWARN(WARN_UNINITIALIZED))
					Perl_warner(aTHX_
						packWARN(WARN_UNINITIALIZED),
						PL_warn_uninit_sv, &PL_sv_no,
						" in ", PL_op_desc[OP_RV2SV]);
				slotval = &PL_sv_undef;
				break;
			}
			goto sv_not_null;
		} break;
		case Q_OPp_SLOTVAL_RV2SV_STRICT: {
			if(!LIKELY(slotval)) DIE(aTHX_ PL_no_usym, "a SCALAR");
			sv_not_null:
			if(!LIKELY(SvTYPE(slotval) < SVt_PVAV))
				DIE(aTHX_ "Not %s reference", "a SCALAR");
		} break;
		case Q_OPp_SLOTVAL_RV2AV: {
			if(!LIKELY(slotval))
				DIE(aTHX_ PL_no_usym, "an ARRAY");
			else if(!LIKELY(SvTYPE(slotval) == SVt_PVAV))
				DIE(aTHX_ "Not %s reference", "an ARRAY");
		} break;
		case Q_OPp_SLOTVAL_RV2HV: {
			if(!LIKELY(slotval))
				DIE(aTHX_ PL_no_usym, "a HASH");
			else if(!LIKELY(SvTYPE(slotval) == SVt_PVHV))
				DIE(aTHX_ "Not %s reference", "a HASH");
		} break;
		case Q_OPp_SLOTVAL_RV2CV: {
			if(!LIKELY(slotval)) {
				if(!PL_localizing && ckWARN(WARN_UNINITIALIZED))
					Perl_warner(aTHX_
						packWARN(WARN_UNINITIALIZED),
						PL_warn_uninit_sv, &PL_sv_no,
						" in ", PL_op_desc[OP_RV2CV]);
				slotval = (SV*)gv_fetchpvn_flags("", 0,
						GV_ADD|GV_NO_SVGMAGIC,
						SVt_PVCV);
				goto handle_gv_for_cv;
			} else if(LIKELY(SvTYPE(slotval) == SVt_PVCV))
				;
			else if((SvGETMAGIC(slotval),
					LIKELY(isGV_with_GP(slotval)))) {
				GV *gv;
				CV *cv;
				handle_gv_for_cv:
				gv = (GV*)slotval;
				cv = GvCVu(gv);
				if(!cv) cv = newSTUB(gv, 0);
				slotval = (SV*)cv;
			} else
				DIE(aTHX_ "Not %s reference", "a subroutine");
		} break;
		case Q_OPp_SLOTVAL_RV2GV: {
			if(!LIKELY(slotval))
				DIE(aTHX_ PL_no_usym, "a symbol");
			else if(LIKELY(isGV_with_GP(slotval))) {
				if(UNLIKELY(SvFAKE(slotval))) {
					slotval =
						sv_mortalcopy_flags(slotval, 0);
					SvFAKE_off(slotval);
				}
			} else if(LIKELY(SvTYPE(slotval) == SVt_PVIO)) {
				GV *gv = (GV*)sv_newmortal();
				gv_init(gv, 0, "__ANONIO__", 10, 0);
				GvIOp(gv) = (IO*)slotval;
				SvREFCNT_inc_void_NN(slotval);
				slotval = (SV*)gv;
			} else
				DIE(aTHX_ "Not %s reference", "a GLOB");
		} break;
		default: {
			assert(0);
		} break;
	}
	finalised:
	{
		dSP;
		XPUSHs(slotval);
		PUTBACK;
	}
	return NORMAL;
}

static OP *THX_pp_tuple_slot(pTHX)
{
	dSP;
	SV *ixsv = Q_POPs_INDEX_ARG;
	SSize_t ix;
	SV *tuple = tuple_from_arg(Q_POPs_TUPLE_ARG);
	PUTBACK;
	ix = Q_GET_INDEX_VAL(ixsv);
	if(UNLIKELY(ix < 0 || ix > ObjectMAXFIELD(tuple)))
		croak("tuple slot index is out of range");
	return THX_pp2_slotval_ret(aTHX_ ObjectFIELDS(tuple)[ix]);
}

static OP *THX_pp_tuple_slots(pTHX)
{
	dSP;
	SV *tuple;
	SSize_t len;
	if(UNLIKELY(GIMME_V == G_SCALAR))
		croak("tuple slot list requested in scalar context");
	tuple = tuple_from_arg(Q_POPs_TUPLE_ARG);
	len = ObjectMAXFIELD(tuple) + 1;
	if(LIKELY(len != 0)) {
		SV **fields = ObjectFIELDS(tuple);
		SSize_t i;
		EXTEND(SP, len);
		for(i = 0; i != len; i++) SP[1+i] = slotval_as_ret(fields[i]);
		SP += len;
	}
	PUTBACK;
	return NORMAL;
}

static OP *THX_pp_tuple_set_slot(pTHX)
{
	dSP;
	SV *newslotvalarg = POPs;
	SV *ixsv = Q_POPs_INDEX_ARG;
	SSize_t ix;
	SV *tuple = tuple_from_arg(Q_POPs_TUPLE_ARG);
	SV *newslotval, *oldslotval, **fields;
	PUTBACK;
	ix = Q_GET_INDEX_VAL(ixsv);
	newslotval = slotval_from_arg(newslotvalarg);
	if(UNLIKELY(SvREADONLY(tuple))) croak_no_modify();
	if(UNLIKELY(ix < 0 || ix > ObjectMAXFIELD(tuple)))
		croak("tuple slot index is out of range");
	fields = ObjectFIELDS(tuple);
	oldslotval = fields[ix];
	fields[ix] = SvREFCNT_inc(newslotval);
	SvREFCNT_dec(oldslotval);
	return LIKELY(GIMME_V == G_VOID) ? NORMAL :
		THX_pp2_slotval_ret(aTHX_ newslotval);
}

static OP *THX_pp_tuple_set_slots(pTHX)
{
	dMARK; dSP;
	SSize_t newlen = SP - MARK, oldlen, i;
	SV *tuple;
	SP = MARK;
	tuple = tuple_from_arg(Q_POPs_TUPLE_ARG);
	for(i = 0; i != newlen; i++) MARK[1+i] = slotval_from_arg(MARK[1+i]);
	if(UNLIKELY(SvREADONLY(tuple))) croak_no_modify();
	oldlen = ObjectMAXFIELD(tuple) + 1;
	if(LIKELY(newlen == oldlen)) {
		if(LIKELY(newlen != 0)) {
			SV **fields = ObjectFIELDS(tuple);
			for(i = 0; i != newlen; i++) {
				SV *oldslotval = fields[i];
				SV *newslotval = SvREFCNT_inc(MARK[1+i]);
				fields[i] = newslotval;
				MARK[1+i] = oldslotval;
			}
			for(i = 0; i != newlen; i++) SvREFCNT_dec(MARK[1+i]);
		}
	} else {
		SV **oldfields = ObjectFIELDS(tuple), **newfields;
		if(UNLIKELY(newlen == 0)) {
			newfields = NULL;
		} else {
			Newx(newfields, newlen, SV*);
			Copy(MARK+1, newfields, newlen, SV*);
			for(i = 0; i != newlen; i++) SvREFCNT_inc(newfields[i]);
		}
		ObjectFIELDS(tuple) = newfields;
		ObjectMAXFIELD(tuple) = newlen - 1;
		for(i = 0; i != oldlen; i++) SvREFCNT_dec(oldfields[i]);
		Safefree(oldfields);
	}
	if(UNLIKELY(GIMME_V == G_SCALAR)) XPUSHs(&PL_sv_undef);
	PUTBACK;
	return NORMAL;
}

static OP *THX_pp_tuple_seal(pTHX)
{
	dSP;
	SV *tuple_arg = Q_POPs_TUPLE_ARG;
	SV *tuple = tuple_from_arg(tuple_arg);
	if(UNLIKELY(GIMME_V != G_VOID)) XPUSHs(tuple_as_ret(tuple));
	PUTBACK;
	if(UNLIKELY(SvREADONLY(tuple))) croak_no_modify();
	SvREADONLY_fully_on(tuple);
	return NORMAL;
}

struct q_func {
	char const *fqsubname;
	Perl_ppaddr_t THX_pp;
	U32 flags;
};

static void THX_xsfunc_tuple_any(pTHX_ CV *cv)
{
	struct q_func const *qf = (struct q_func const *)CvXSUBANY(cv).any_ptr;
	U32 flags = qf->flags;
	SSize_t base_arity = !!(flags & Q_ARGf_TUPLE) +
		!!(flags & Q_ARGf_INDEX) + !!(flags & Q_ARGf_REF);
	UNOP myop;
	dMARK; dSP;
	if(UNLIKELY(SP - MARK < base_arity ||
			(!(flags & Q_ARGf_LIST) && SP - MARK > base_arity))) {
		SV *argnames = sv_newmortal();
		sv_setpvs(argnames, "");
		if(flags & Q_ARGf_TUPLE) sv_catpvs_nomg(argnames, ", tuple");
		if(flags & Q_ARGf_INDEX) sv_catpvs_nomg(argnames, ", index");
		if(flags & Q_ARGf_REF) sv_catpvs_nomg(argnames, ", ref");
		if(flags & Q_ARGf_REF_LIST)
			sv_catpvs_nomg(argnames, ", ref ...");
		croak_xs_usage(cv, SvPVX(argnames) + 2);
	}
	if(UNLIKELY(flags & Q_ARGf_LIST)) PUSHMARK(MARK + base_arity);
	Zero(&myop, 1, UNOP);
	myop.op_flags = PL_op->op_flags;
	myop.op_private = (U8)flags;
	SAVEOP();
	PL_op = (OP*)&myop;
	(void) qf->THX_pp(aTHX);
}

#define is_std_op(o, type) \
	((o)->op_type == (type) && (o)->op_ppaddr == PL_ppaddr[(type)])

PERL_STATIC_INLINE OP *skip_null_ops(OP *o)
{
	while(o && (o->op_type == OP_NULL || o->op_type == OP_SCALAR ||
			o->op_type == OP_SCOPE || o->op_type == OP_LINESEQ))
		o = o->op_next;
	return o;
}

static void THX_cpeep_tuple(pTHX_ OP *first, OP *prevop)
{
	OP *second, *third;
	PERL_UNUSED_ARG(prevop);
	if((second = skip_null_ops(first->op_next)) &&
			is_std_op(second, OP_PADSV) &&
			!(second->op_private & (OPpDEREF|OPpPAD_STATE)) &&
			(third = skip_null_ops(second->op_next)) &&
			is_std_op(third, OP_SASSIGN) &&
			!(third->op_private &
				(OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))) {
		first->op_private |= Q_OPp_PAD_TUPLE;
		first->op_flags = (first->op_flags & OPf_KIDS) |
			((second->op_flags & OPf_MOD) &&
					(second->op_private & OPpLVAL_INTRO) ?
				OPf_SPECIAL : 0) |
			(third->op_flags & OPf_WANT);
		first->op_targ = second->op_targ;
		first->op_next = third->op_next;
	}
}

#define eligible_for_multideref(o) THX_eligible_for_multideref(aTHX_ o)
static bool THX_eligible_for_multideref(pTHX_ OP *o)
{
	/*
	 * The logic here is duplicating that of the core's
	 * S_maybe_multideref(), in order to determine whether core
	 * peephole optimisation would turn the ops being examined into
	 * a multideref op.  The aim is to match the core's criteria,
	 * not to decide whether it would be a good idea to turn the
	 * ops into a multideref.  Accurately predicting the behaviour
	 * of the core's multideref optimisation is not necessary in
	 * order to achieve correct behaviour, but is desired in order
	 * to produce the best possible optimisation.
	 */
	Optype reftyp = o->op_type;
	if(!(reftyp == OP_RV2AV || reftyp == OP_RV2HV)) return 0;
	if(o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF)) return 0;
	if(!(o = o->op_next)) return 0;
	switch(o->op_type) {
		case OP_PADSV: {
			if((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
				return 0;
		} break;
		case OP_CONST: {
			SV *val = cSVOPo_sv;
			if(reftyp == OP_RV2HV) {
				if(!(SvFLAGS(val) & (SVf_IOK|SVf_NOK|SVf_POK)))
					return 0;
			} else {
				if(!SvIOK(val)) return 0;
			}
		} break;
		case OP_GV: {
			if((o->op_flags & ~(OPf_PARENS|OPf_SPECIAL))
					!= OPf_WANT_SCALAR)
				return 0;
			if(o->op_private) return 0;
			o = o->op_next;
			if(o->op_type != OP_RV2SV) return 0;
			if((o->op_flags & ~OPf_PARENS) !=
					(OPf_WANT_SCALAR|OPf_KIDS))
				return 0;
			if(o->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
				return 0;
		} break;
		default: return 0;
	}
	if(!(o = o->op_next)) return 0;
	if(o->op_type == OP_NULL && !(o = o->op_next)) return 0;
	switch(o->op_type) {
		case OP_AELEM: {
			if(reftyp != OP_RV2AV) return 0;
			aelem_or_helem:
			switch(o->op_private & OPpDEREF) {
				case OPpDEREF_AV: case OPpDEREF_HV: {
					if(!(o->op_private & OPpLVAL_INTRO)) {
						if((o->op_flags & ~OPf_PARENS)
							!= (OPf_WANT_SCALAR|
								OPf_KIDS|
								OPf_MOD))
							return 0;
						if(o->op_private &
							~(OPpDEREF|
								OPpARG2_MASK))
							return 0;
					}
				} break;
				case OPpDEREF_SV: return 0;
				default: break;
			}
		} break;
		case OP_HELEM: {
			if(reftyp != OP_RV2HV) return 0;
			goto aelem_or_helem;
		} break;
		case OP_EXISTS: {
			if(reftyp != OP_RV2HV) return 0;
			if(o->op_private & ~OPpARG1_MASK) return 0;
		} break;
		case OP_DELETE: {
			if(reftyp != OP_RV2HV) return 0;
			if(o->op_private & ~OPpARG1_MASK) return 0;
			if(OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM) &&
					!(o->op_flags & OPf_SPECIAL))
				return 0;
		} break;
		default: return 0;
	}
	return 1;
}

static void THX_cpeep_slotval_ret(pTHX_ OP *first, OP *prevop)
{
	OP *second = skip_null_ops(first->op_next);
	Optype typ;
	bool elide_second;
	U8 pflag;
	PERL_UNUSED_ARG(prevop);
	if(!second) return;
	typ = second->op_type;
	if(second->op_ppaddr != PL_ppaddr[typ]) return;
	switch(typ) {
		case OP_RV2SV: {
			if((second->op_flags & OPf_MOD) &&
					(second->op_private &
						(OPpLVAL_INTRO|OPpDEREF)))
				return;
			pflag = ((second->op_flags & OPf_REF) ||
					(second->op_private & HINT_STRICT_REFS))
				? Q_OPp_SLOTVAL_RV2SV_STRICT :
				Q_OPp_SLOTVAL_RV2SV_LAX;
			elide_second = 1;
		} break;
		case OP_RV2AV: {
			pflag = Q_OPp_SLOTVAL_RV2AV;
			av_or_hv:
			if((second->op_flags & OPf_MOD) &&
					(second->op_private & OPpLVAL_INTRO))
				return;
			elide_second = (second->op_flags & OPf_REF) &&
				!eligible_for_multideref(second);
		} break;
		case OP_RV2HV: {
			pflag = Q_OPp_SLOTVAL_RV2HV;
			goto av_or_hv;
		} break;
		case OP_RV2CV: {
			if(PL_op->op_flags & OPf_SPECIAL) return;
			if((PL_op->op_private &
					(OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
					== OPpMAY_RETURN_CONSTANT)
				return;
			pflag = Q_OPp_SLOTVAL_RV2CV;
			elide_second = 1;
		} break;
		case OP_RV2GV: {
			if(second->op_private & (OPpLVAL_INTRO|OPpALLOW_FAKE))
				return;
			if(!((second->op_flags & OPf_REF) ||
					(second->op_private &
						HINT_STRICT_REFS)))
				return;
			pflag = Q_OPp_SLOTVAL_RV2GV;
			elide_second = 1;
		} break;
		default: return;
	}
	first->op_private |= pflag;
	if(elide_second) first->op_next = second->op_next;
}

#define Q_PKG_PREFIX "Tuple::Munge::"
#define Q_FUNC_SIMPLE_INIT(name, flags) \
	{ \
		Q_PKG_PREFIX #name, \
		THX_pp_##name, \
		(flags), \
	}
#define Q_FUNC_CONSTRUCTOR_INIT(name, flags) \
	{ \
		Q_PKG_PREFIX #name, \
		THX_pp_tuple, \
		Q_BTf_NO_REGISTER_XOP | (flags), \
	}
static struct q_func const q_funcs[] = {
	Q_FUNC_CONSTRUCTOR_INIT(pure_tuple,
		Q_ARGf_REF_LIST | Q_OPp_CONSTRUCT_READONLY | Q_CKf_FOLD),
	Q_FUNC_CONSTRUCTOR_INIT(constant_tuple,
		Q_ARGf_REF_LIST | Q_OPp_CONSTRUCT_READONLY),
	Q_FUNC_CONSTRUCTOR_INIT(variable_tuple, Q_ARGf_REF_LIST),
	Q_FUNC_SIMPLE_INIT(tuple_mutable, Q_ARGf_TUPLE | Q_CKf_FOLD),
	Q_FUNC_SIMPLE_INIT(tuple_length, Q_ARGf_TUPLE | Q_CKf_FOLD),
	Q_FUNC_SIMPLE_INIT(tuple_slot,
		Q_ARGf_TUPLE | Q_ARGf_INDEX | Q_CKf_FOLD | Q_BTf_SLOTVAL_RET),
	Q_FUNC_SIMPLE_INIT(tuple_slots, Q_ARGf_TUPLE | Q_CKf_NOT_SCALAR_RETURN),
	Q_FUNC_SIMPLE_INIT(tuple_set_slot,
		Q_ARGf_TUPLE | Q_ARGf_INDEX | Q_ARGf_REF | Q_BTf_SLOTVAL_RET),
	Q_FUNC_SIMPLE_INIT(tuple_set_slots,
		Q_ARGf_TUPLE | Q_ARGf_REF_LIST | Q_CKf_NOT_SCALAR_RETURN),
	Q_FUNC_SIMPLE_INIT(tuple_seal, Q_ARGf_TUPLE),
};

#define check_and_extract_args(entersubop, namegv, cv, argopl_ptr) \
	THX_check_and_extract_args(aTHX_ entersubop, namegv, cv, argopl_ptr)
PERL_STATIC_INLINE bool THX_check_and_extract_args(pTHX_ OP *entersubop,
	GV *namegv, CV *cv, OP **argopl_ptr)
{
	OP *pushop, *firstargop, *cvop, *lastargop;
	SSize_t nargs;
	entersubop = ck_entersub_args_proto(entersubop, namegv, (SV*)cv);
	if(!LIKELY(entersubop->op_flags & OPf_KIDS)) return 1;
	pushop = cUNOPx(entersubop)->op_first;
	if(!OpHAS_SIBLING(pushop)) {
		if(!LIKELY(pushop->op_flags & OPf_KIDS)) return 1;
		pushop = cUNOPx(pushop)->op_first;
	}
	if(!LIKELY(OpHAS_SIBLING(pushop))) return 1;
	firstargop = OpSIBLING(pushop);
	for(nargs = 0, cvop = firstargop, lastargop = pushop;
			OpHAS_SIBLING(cvop);
			lastargop = cvop, cvop = OpSIBLING(cvop))
		nargs++;
	{
		STRLEN protolen = CvPROTOLEN(cv);
		char const *protopv = CvPROTO(cv);
		if(!LIKELY(protopv[protolen-1] == '@' ?
				nargs >= (SSize_t)(protolen-1) :
				nargs == (SSize_t)protolen))
			return 1;
	}
	if(LIKELY(nargs != 0)) {
		*argopl_ptr = firstargop;
		OpMORESIB_set(pushop, cvop);
		OpLASTSIB_set(lastargop, NULL);
	} else {
		*argopl_ptr = NULL;
	}
	op_free(entersubop);
	return 0;
}

#define newOP_simple_custom(sz, THX_pp, argopl) \
	THX_newOP_simple_custom(aTHX_ sz, THX_pp, argopl)
PERL_STATIC_INLINE OP *THX_newOP_simple_custom(pTHX_ Size_t sz,
	Perl_ppaddr_t THX_pp, OP *argopl)
{
	OP *newop;
	NewOpSz(0, newop, sz);
	newop->op_type = OP_CUSTOM;
	newop->op_ppaddr = THX_pp;
	if(argopl) {
		OP *aop;
		newop->op_flags = OPf_KIDS;
		cUNOPx(newop)->op_first = argopl;
		for(aop = argopl; OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) ;
		OpLASTSIB_set(aop, newop);
	}
	return newop;
}

#define fold_clean_optree(inop) THX_fold_clean_optree(aTHX_ inop)
PERL_STATIC_INLINE OP *THX_fold_clean_optree(pTHX_ OP *inop)
{
	SV *val;
	OP *outop;
	ENTER_with_name("fold_clean_optree");
	SAVETMPS;
	SAVEOP();
	{
		dSP;
		PUSHSTACKi(PERLSI_REQUIRE);
	}
	PL_op = LINKLIST(inop);
	inop->op_next = NULL;
	while(PL_op) PL_op = PL_op->op_ppaddr(aTHX);
	{
		dSP;
		val = POPs;
		PUTBACK;
	}
	outop = newSVOP(OP_CONST, 0, SvREFCNT_inc(val));
	POPSTACK;
	FREETMPS;
	LEAVE_with_name("fold_clean_optree");
	op_free(inop);
	return outop;
}

#define extract_scalar_arg(argopl, thisargop_ptr, have_arg_p) \
	THX_extract_scalar_arg(aTHX_ argopl, thisargop_ptr, have_arg_p)
PERL_STATIC_INLINE OP *THX_extract_scalar_arg(pTHX_ OP *argopl,
	OP **thisargop_ptr, U32 have_arg_p)
{
	if(have_arg_p) {
		OP *thisargop = argopl;
		assert(thisargop);
		argopl = OpSIBLING(argopl);
		OpLASTSIB_set(thisargop, NULL);
		*thisargop_ptr = thisargop;
	} else {
		*thisargop_ptr = NULL;
	}
	return argopl;
}

#define link_scalar_arg(argopl, thisargop) \
	THX_link_scalar_arg(aTHX_ argopl, thisargop)
PERL_STATIC_INLINE OP *THX_link_scalar_arg(pTHX_ OP *argopl, OP *thisargop)
{
	if(thisargop) {
		if(argopl) OpMORESIB_set(thisargop, argopl);
		return thisargop;
	} else {
		return argopl;
	}
}

#define op_scalar_value(op) THX_op_scalar_value(aTHX_ op)
static SV *THX_op_scalar_value(pTHX_ OP *op)
{
	if(op->op_flags & OPf_KIDS) return NULL;
	if(is_std_op(op, OP_CONST)) {
		SV *val = cSVOPx(op)->op_sv;
		return SvGMAGICAL(val) ? NULL : val;
	} else if(is_std_op(op, OP_UNDEF)) {
		return op->op_private ? NULL : &PL_sv_undef;
	} else {
		return NULL;
	}
}

#define ref_arg_list_all_constant(argopl) \
	THX_ref_arg_list_all_constant(aTHX_ argopl)
PERL_STATIC_INLINE bool THX_ref_arg_list_all_constant(pTHX_ OP *argopl)
{
	OP *argop;
	for(argop = argopl; argop; argop = OpSIBLING(argop)) {
		SV *val = op_scalar_value(argop);
		if(!(val && (SvROK(val) || sv_is_undef(val)))) return 0;
	}
	return 1;
}

static OP *THX_cksub_tuple_any(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
	CV *cv = (CV*)ckobj;
	struct q_func const *qf = (struct q_func const *)CvXSUBANY(cv).any_ptr;
	U32 flags = qf->flags;
	OP *argopl, *newop;
	OP *tuple_arg_op, *index_arg_op, *ref_arg_op;
	PADOFFSET tuple_po = 0;
	SV *tuple_sv = NULL;
	SSize_t index_val = 0;
	if(UNLIKELY(check_and_extract_args(entersubop, namegv, cv, &argopl)))
		return entersubop;
	argopl = extract_scalar_arg(argopl, &tuple_arg_op,
		flags & Q_ARGf_TUPLE);
	argopl = extract_scalar_arg(argopl, &index_arg_op,
		flags & Q_ARGf_INDEX);
	argopl = extract_scalar_arg(argopl, &ref_arg_op, flags & Q_ARGf_REF);
	assert(!argopl || (flags & Q_ARGf_LIST));
	if((flags & Q_ARGf_TUPLE) && is_std_op(tuple_arg_op, OP_PADSV) &&
			!(tuple_arg_op->op_flags & OPf_KIDS) &&
			!(tuple_arg_op->op_private & OPpLVAL_INTRO) &&
			!(tuple_arg_op->op_private & OPpDEREF)) {
		tuple_po = tuple_arg_op->op_targ;
		op_free(tuple_arg_op);
		tuple_arg_op = NULL;
		flags |= Q_OPp_PAD_TUPLE;
		flags &= ~Q_CKf_FOLD;
	}
	if((flags & Q_ARGf_TUPLE) && (flags & Q_CKf_FOLD)) {
		SV *argsv = op_scalar_value(tuple_arg_op);
		if(!(argsv && SvROK(argsv) && (tuple_sv = SvRV(argsv)) &&
				SvTYPE(tuple_sv) == SVt_PVOBJ &&
				SvREADONLY(tuple_sv)))
			flags &= ~Q_CKf_FOLD;
	}
	if(flags & Q_ARGf_INDEX) {
		SV *argsv = op_scalar_value(index_arg_op);
		if(LIKELY(argsv && SvIOK(argsv))) {
			index_val = index_from_arg(argsv);
			op_free(index_arg_op);
			index_arg_op = NULL;
			flags |= Q_OPp_FIXED_INDEX;
		}
		assert(flags & Q_ARGf_TUPLE);
		if(flags & Q_CKf_FOLD) {
			assert(tuple_sv);
			if(!((flags & Q_OPp_FIXED_INDEX) &&
					index_val >= 0 &&
					index_val <= ObjectMAXFIELD(tuple_sv)))
				flags &= ~Q_CKf_FOLD;
		}
	}
	if(UNLIKELY(flags & Q_ARGf_REF_LIST)) {
		OP *pushop;
		if((flags & Q_CKf_FOLD) && !ref_arg_list_all_constant(argopl))
			flags &= ~Q_CKf_FOLD;
		pushop = newOP(OP_PUSHMARK, 0);
		if(LIKELY(argopl)) OpMORESIB_set(pushop, argopl);
		argopl = pushop;
	}
	argopl = link_scalar_arg(argopl, ref_arg_op);
	argopl = link_scalar_arg(argopl, index_arg_op);
	argopl = link_scalar_arg(argopl, tuple_arg_op);
	newop = newOP_simple_custom(
		(flags & Q_OPp_FIXED_INDEX) ? sizeof(Q_TUPLE_OP) : sizeof(UNOP),
		qf->THX_pp, argopl);
	if(flags & Q_OPp_PAD_TUPLE) newop->op_targ = tuple_po;
	if(flags & Q_OPp_FIXED_INDEX) ((Q_TUPLE_OP*)newop)->index = index_val;
	if(!UNLIKELY(flags & Q_CKf_NOT_SCALAR_RETURN))
		newop->op_flags |= OPf_WANT_SCALAR;
	newop->op_private = (U8)flags;
	if(UNLIKELY(flags & Q_CKf_FOLD)) newop = fold_clean_optree(newop);
	return newop;
}

MODULE = Tuple::Munge PACKAGE = Tuple::Munge

PROTOTYPES: DISABLE

BOOT:
{
	int i;
	{
		XOP *xop;
		Newxz(xop, 1, XOP);
		XopENTRY_set(xop, xop_name, "tuple");
		XopENTRY_set(xop, xop_desc, "Tuple::Munge tuple construction");
		XopENTRY_set(xop, xop_class, OA_UNOP);
		XopENTRY_set(xop, xop_peep, THX_cpeep_tuple);
		Perl_custom_op_register(aTHX_ THX_pp_tuple, xop);
	}
	for(i = C_ARRAY_LENGTH(q_funcs); i--; ) {
		struct q_func const *qf = &q_funcs[i];
		CV *fcv;
		char proto[4], *p = proto;
		if(!(qf->flags & Q_BTf_NO_REGISTER_XOP)) {
			XOP *xop;
			Newxz(xop, 1, XOP);
			XopENTRY_set(xop, xop_name,
				qf->fqsubname + sizeof(Q_PKG_PREFIX)-1);
			XopENTRY_set(xop, xop_desc, qf->fqsubname);
			XopENTRY_set(xop, xop_class, OA_UNOP);
			if(qf->flags & Q_BTf_SLOTVAL_RET)
				XopENTRY_set(xop, xop_peep,
					THX_cpeep_slotval_ret);
			Perl_custom_op_register(aTHX_ qf->THX_pp, xop);
		}
		if(qf->flags & Q_ARGf_TUPLE) *p++ = '$';
		if(qf->flags & Q_ARGf_INDEX) *p++ = '$';
		if(qf->flags & Q_ARGf_REF) *p++ = '$';
		if(qf->flags & Q_ARGf_LIST) *p++ = '@';
		*p = 0;
		fcv = newXS_flags((char*)qf->fqsubname,
			THX_xsfunc_tuple_any, __FILE__, proto, 0);
		CvXSUBANY(fcv).any_ptr = (void*)qf;
		cv_set_call_checker_flags(fcv, THX_cksub_tuple_any,
			(SV*)fcv, 0);
	}
}