# 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
+
void
Perl_Slab_Free(pTHX_ void *op)
{
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);
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,
PL_parser->in_my == KEY_state ? "state" : "my"));
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);
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;
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));
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));
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:
}
}
+/* 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)
+{
+ 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;
+ 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 */
+
+ /* -----------------------------------------------------------------
+ * 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);
+
+ /* 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)
+ && (cUNOPo->op_first->op_flags & OPf_MOD))
+ {
+ /* 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 > 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))
+ ) {
+ argp++->p = sv;
+ utf8 |= cBOOL(SvUTF8(sv));
+ nconst++;
+ }
+ else {
+ argp++->p = NULL;
+ nargs++;
+ }
+
+ if (last)
+ break;
+ }
+
+ toparg = argp - 1;
+
+ if (stacked_last)
+ return; /* we don't support ((A.=B).=C)...) */
+
+ /* -----------------------------------------------------------------
+ * 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) {
+ char *p = (char*)argp->p;
+ STRLEN len = argp->len;
+ while (len--) {
+ U8 c = *p++;
+ if (!UTF8_IS_INVARIANT(c))
+ variant++;
+ }
+ }
+ }
+
+ /* 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.:
+ *
+ * |
+ * kid= CONST
+ * |
+ * prev= CONST -- 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)
*startp = start;
optree->op_private |= OPpREFCOUNTED;
OpREFCNT_set(optree, 1);
+ optimize_optree(optree);
CALL_PEEP(*startp);
finalize_optree(optree);
S_prune_chain_head(startp);
/*
+=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 on op then recurses
+ * to optimise any children.
+ */
+
+STATIC void
+S_optimize_op(pTHX_ OP* o)
+{
+ OP *kid;
+
+ PERL_ARGS_ASSERT_OPTIMIZE_OP;
+ 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)
+ optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ break;
+
+ default:
+ break;
+ }
+
+ if (!(o->op_flags & OPf_KIDS))
+ return;
+
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
+ optimize_op(kid);
+}
+
+
+/*
=for apidoc finalize_optree
This function finalizes the optree. Should be called directly after
case OP_CONST:
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
- /* FALLTHROUGH */
#ifdef USE_ITHREADS
+ /* FALLTHROUGH */
case OP_HINTSEVAL:
op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
#endif
}
STATIC void
-S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
+S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
+ bool curstash)
{
OP *new_proto = NULL;
STRLEN pvlen;
o = *attrs;
if (o->op_type == OP_CONST) {
pv = SvPV(cSVOPo_sv, pvlen);
- if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ if (memBEGINs(pv, pvlen, "prototype(")) {
SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
SV ** const tmpo = cSVOPx_svp(o);
SvREFCNT_dec(cSVOPo_sv);
for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
if (o->op_type == OP_CONST) {
pv = SvPV(cSVOPo_sv, pvlen);
- if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ if (memBEGINs(pv, pvlen, "prototype(")) {
SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
SV ** const tmpo = cSVOPx_svp(o);
SvREFCNT_dec(cSVOPo_sv);
else
svname = (SV *)name;
if (ckWARN(WARN_ILLEGALPROTO))
- (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
+ (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
+ curstash);
if (*proto && ckWARN(WARN_PROTOTYPE)) {
STRLEN old_len, new_len;
const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
+ if (curstash && svname == (SV *)name
+ && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
+ svname = sv_2mortal(newSVsv(PL_curstname));
+ sv_catpvs(svname, "::");
+ sv_catsv(svname, (SV *)name);
+ }
+
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
" in %" SVf,
S_fold_constants(pTHX_ OP *const o)
{
dVAR;
- OP * VOL curop;
+ OP * volatile curop;
OP *newop;
- VOL I32 type = o->op_type;
+ volatile I32 type = o->op_type;
bool is_stringify;
- SV * VOL sv = NULL;
+ SV * volatile sv = NULL;
int ret = 0;
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
scope->op_next = NULL; /* stop on last op */
op_null(scope);
}
+
+ if (is_compiletime)
+ /* runtime finalizes as part of finalizing whole tree */
+ optimize_optree(o);
+
/* have to peep the DOs individually as we've removed it from
* the op_next chain */
CALL_PEEP(o);
Constructs, checks, and returns an op of any type that involves an
embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
-the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
-must have been allocated using C<PerlMemShared_malloc>; the memory will
-be freed when the op is destroyed.
+the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
+Depending on the op type, the memory referenced by C<pv> may be freed
+when the op is destroyed. If the op is of a freeing type, C<pv> must
+have been allocated using C<PerlMemShared_malloc>.
=cut
*/
return ret;
}
+static OP *
+S_newONCEOP(pTHX_ OP *initop, OP *padop)
+{
+ const PADOFFSET target = padop->op_targ;
+ OP *const other = newOP(OP_PADSV,
+ padop->op_flags
+ | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
+ OP *const first = newOP(OP_NULL, 0);
+ OP *const nullop = newCONDOP(0, first, initop, other);
+ /* XXX targlex disabled for now; see ticket #124160
+ newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
+ */
+ OP *const condop = first->op_next;
+
+ OpTYPE_set(condop, OP_ONCE);
+ other->op_targ = target;
+ nullop->op_flags |= OPf_WANT_SCALAR;
+
+ /* Store the initializedness of state vars in a separate
+ pad entry. */
+ condop->op_targ =
+ pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(condop->op_targ));
+
+ return nullop;
+}
/*
=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
}
if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
+ OP *state_var_op = NULL;
static const char no_list_state[] = "Initialization of state variables"
- " in list context currently forbidden";
+ " in list currently forbidden";
OP *curop;
if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
{
- OP* lop = ((LISTOP*)left)->op_first;
- while (lop) {
- if ((lop->op_type == OP_PADSV ||
- lop->op_type == OP_PADAV ||
- lop->op_type == OP_PADHV ||
- lop->op_type == OP_PADANY)
- && (lop->op_private & OPpPAD_STATE)
- )
- yyerror(no_list_state);
- lop = OpSIBLING(lop);
+ OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
+ if (!(left->op_flags & OPf_PARENS) &&
+ lop->op_type == OP_PUSHMARK &&
+ (vop = OpSIBLING(lop)) &&
+ (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
+ !(vop->op_flags & OPf_PARENS) &&
+ (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
+ (OPpLVAL_INTRO|OPpPAD_STATE) &&
+ (eop = OpSIBLING(vop)) &&
+ eop->op_type == OP_ENTERSUB &&
+ !OpHAS_SIBLING(eop)) {
+ state_var_op = vop;
+ } else {
+ while (lop) {
+ if ((lop->op_type == OP_PADSV ||
+ lop->op_type == OP_PADAV ||
+ lop->op_type == OP_PADHV ||
+ lop->op_type == OP_PADANY)
+ && (lop->op_private & OPpPAD_STATE)
+ )
+ yyerror(no_list_state);
+ lop = OpSIBLING(lop);
+ }
}
}
else if ( (left->op_private & OPpLVAL_INTRO)
state (%a) = ...
(state %a) = ...
*/
- yyerror(no_list_state);
+ if (left->op_flags & OPf_PARENS)
+ yyerror(no_list_state);
+ else
+ state_var_op = left;
}
/* optimise @a = split(...) into:
}
}
}
+
+ if (state_var_op)
+ o = S_newONCEOP(aTHX_ o, state_var_op);
return o;
}
if (assign_type == ASSIGN_REF)
=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
Constructs, checks, and returns an op tree expressing a C<given> block.
-C<cond> supplies the expression that will be locally assigned to a lexical
-variable, and C<block> supplies the body of the C<given> construct; they
+C<cond> supplies the expression to whose value C<$_> will be locally
+aliased, and C<block> supplies the body of the C<given> construct; they
are consumed by this function and become part of the constructed op tree.
C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
PERL_ARGS_ASSERT_NEWMYSUB;
+ PL_hints |= HINT_BLOCK_SCOPE;
+
/* Find the pad slot for storing the new sub.
We cannot use PL_comppad, as it is the pad owned by the new sub. We
need to look in CvOUTSIDE and find the pad belonging to the enclos-
spot = (CV **)svspot;
if (!(PL_parser && PL_parser->error_count))
- move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
+ move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
if (proto) {
assert(proto->op_type == OP_CONST);
sub is stored in. */
const I32 flags =
ec ? GV_NOADD_NOINIT
- : PL_curstash != CopSTASH(PL_curcop)
+ : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
|| memchr(name, ':', namlen) || memchr(name, '\'', namlen)
? gv_fetch_flags
: GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
if (!ec) {
if (isGV(gv)) {
- move_proto_attr(&proto, &attrs, gv);
+ move_proto_attr(&proto, &attrs, gv, 0);
} else {
assert(cSVOPo);
- move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
+ move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
}
}
PL_compcv = 0;
if (name && block) {
- const char *s = strrchr(name, ':');
+ const char *s = (char *) my_memrchr(name, ':', namlen);
s = s ? s+1 : name;
if (strEQ(s, "BEGIN")) {
if (PL_in_eval & EVAL_KEEPERR)
SvROK_on(gv);
}
SvRV_set(gv, (SV *)cv);
+ if (HvENAME_HEK(PL_curstash))
+ mro_method_changed_in(PL_curstash);
}
}
&& strEQ(GvNAME(cGVOPx_gv(kid)), "[");
}
+/* for lt, gt, le, ge, eq, ne and their i_ variants */
+
OP *
Perl_ck_cmp(pTHX_ OP *o)
{
+ bool is_eq;
+ bool neg;
+ bool reverse;
+ bool iv0;
+ OP *indexop, *constop, *start;
+ SV *sv;
+ IV iv;
+
PERL_ARGS_ASSERT_CK_CMP;
- if (ckWARN(WARN_SYNTAX)) {
+
+ is_eq = ( o->op_type == OP_EQ
+ || o->op_type == OP_NE
+ || o->op_type == OP_I_EQ
+ || o->op_type == OP_I_NE);
+
+ if (!is_eq && ckWARN(WARN_SYNTAX)) {
const OP *kid = cUNOPo->op_first;
if (kid &&
(
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"$[ used in %s (did you mean $] ?)", OP_DESC(o));
}
- return o;
+
+ /* convert (index(...) == -1) and variations into
+ * (r)index/BOOL(,NEG)
+ */
+
+ reverse = FALSE;
+
+ indexop = cUNOPo->op_first;
+ constop = OpSIBLING(indexop);
+ start = NULL;
+ if (indexop->op_type == OP_CONST) {
+ constop = indexop;
+ indexop = OpSIBLING(constop);
+ start = constop;
+ reverse = TRUE;
+ }
+
+ if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
+ return o;
+
+ /* ($lex = index(....)) == -1 */
+ if (indexop->op_private & OPpTARGET_MY)
+ return o;
+
+ if (constop->op_type != OP_CONST)
+ return o;
+
+ sv = cSVOPx_sv(constop);
+ if (!(sv && SvIOK_notUV(sv)))
+ return o;
+
+ iv = SvIVX(sv);
+ if (iv != -1 && iv != 0)
+ return o;
+ iv0 = (iv == 0);
+
+ if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
+ if (!(iv0 ^ reverse))
+ return o;
+ neg = iv0;
+ }
+ else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
+ if (iv0 ^ reverse)
+ return o;
+ neg = !iv0;
+ }
+ else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
+ if (!(iv0 ^ reverse))
+ return o;
+ neg = !iv0;
+ }
+ else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
+ if (iv0 ^ reverse)
+ return o;
+ neg = iv0;
+ }
+ else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
+ if (iv0)
+ return o;
+ neg = TRUE;
+ }
+ else {
+ assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
+ if (iv0)
+ return o;
+ neg = FALSE;
+ }
+
+ indexop->op_flags &= ~OPf_PARENS;
+ indexop->op_flags |= (o->op_flags & OPf_PARENS);
+ indexop->op_private |= OPpTRUEBOOL;
+ if (neg)
+ indexop->op_private |= OPpINDEX_BOOLNEG;
+ /* cut out the index op and free the eq,const ops */
+ (void)op_sibling_splice(o, start, 1, NULL);
+ op_free(o);
+
+ return indexop;
}
+
OP *
Perl_ck_concat(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_CONCAT;
PERL_UNUSED_CONTEXT;
+ /* reuse the padtmp returned by the concat child */
if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
!(kUNOP->op_first->op_flags & OPf_MOD))
o->op_flags |= OPf_STACKED;
}
-/* for OP_EQ, OP_NE, OP_I_EQ, OP_I_NE */
-
-OP *
-Perl_ck_eq(pTHX_ OP *o)
-{
- OP *indexop, *constop, *start;
- SV *sv;
- PERL_ARGS_ASSERT_CK_EQ;
-
- /* convert (index(...) == -1) and variations into
- * (r)index/BOOL(,NEG)
- */
-
- indexop = cUNOPo->op_first;
- constop = OpSIBLING(indexop);
- start = NULL;
- if (indexop->op_type == OP_CONST) {
- constop = indexop;
- indexop = OpSIBLING(constop);
- start = constop;
- }
-
- if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
- return o;
-
- if (constop->op_type != OP_CONST)
- return o;
-
- sv = cSVOPx_sv(constop);
- if (!(sv && SvIOK_notUV(sv) && SvIVX(sv) == -1))
- return o;
-
- /* ($lex = index(....)) == -1 */
- if (indexop->op_private & OPpTARGET_MY)
- return o;
-
- indexop->op_flags &= ~OPf_PARENS;
- indexop->op_flags |= (o->op_flags & OPf_PARENS);
- indexop->op_private |= OPpTRUEBOOL;
- if (o->op_type == OP_EQ || o->op_type == OP_I_EQ)
- indexop->op_private |= OPpINDEX_BOOLNEG;
- /* cut out the index op and free the eq,const ops */
- (void)op_sibling_splice(o, start, 1, NULL);
- op_free(o);
-
- return indexop;
-}
-
-
OP *
Perl_ck_eval(pTHX_ OP *o)
{
)
&& (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
== (OPpLVAL_INTRO|OPpPAD_STATE)) {
- const PADOFFSET target = kkid->op_targ;
- OP *const other = newOP(OP_PADSV,
- kkid->op_flags
- | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
- OP *const first = newOP(OP_NULL, 0);
- OP *const nullop =
- newCONDOP(0, first, o, other);
- /* XXX targlex disabled for now; see ticket #124160
- newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
- */
- OP *const condop = first->op_next;
-
- OpTYPE_set(condop, OP_ONCE);
- other->op_targ = target;
- nullop->op_flags |= OPf_WANT_SCALAR;
-
- /* Store the initializedness of state vars in a separate
- pad entry. */
- condop->op_targ =
- pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
- /* hijacking PADSTALE for uninitialized state variables */
- SvPADSTALE_on(PAD_SVl(condop->op_targ));
-
- return nullop;
+ return S_newONCEOP(aTHX_ o, kkid);
}
}
return S_maybe_targlex(aTHX_ o);
}
+
OP *
Perl_ck_match(pTHX_ OP *o)
{
sv = kSVOP->op_sv;
/* replace ' with :: */
- while ((compatptr = strchr(SvPVX(sv), '\''))) {
+ while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
+ SvEND(sv) - SvPVX(sv) )))
+ {
*compatptr = ':';
sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
}
return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
}
- if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
+ if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
op_free(o);
return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
}
/* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
- if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
+ if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
} else {
SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
if (svp) {
const I32 sorthints = (I32)SvIV(*svp);
- if ((sorthints & HINT_SORT_QUICKSORT) != 0)
- o->op_private |= OPpSORT_QSORT;
if ((sorthints & HINT_SORT_STABLE) != 0)
o->op_private |= OPpSORT_STABLE;
+ if ((sorthints & HINT_SORT_UNSTABLE) != 0)
+ o->op_private |= OPpSORT_UNSTABLE;
}
}
}
if (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
- if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
- if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
- && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
+ if (flags & RV2CVOPCV_RETURN_NAME_GV) {
+ if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
+ gv = CvGV(cv);
+ return (CV*)gv;
+ }
+ else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
+ if (CvLEXICAL(cv) || CvNAMED(cv))
+ return NULL;
+ if (!CvANON(cv) || !gv)
gv = CvGV(cv);
return (CV*)gv;
+
} else {
return cv;
}
switch (*proto++) {
case '[':
if (contextclass++ == 0) {
- e = strchr(proto, ']');
+ e = (char *) memchr(proto, ']', proto_end - proto);
if (!e || e == proto)
goto oops;
}
OP *
Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
{
- int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
+ IV cvflags = SvIVX(protosv);
+ int opnum = cvflags & 0xffff;
OP *aop = cUNOPx(entersubop)->op_first;
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
aop = cUNOPx(aop)->op_first;
aop = OpSIBLING(aop);
for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
- if (aop != cvop)
- (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
+ if (aop != cvop) {
+ SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
+ SVfARG(namesv)), SvUTF8(namesv));
+ }
op_free(entersubop);
- switch(GvNAME(namegv)[2]) {
+ switch(cvflags >> 16) {
case 'F': return newSVOP(OP_CONST, 0,
newSVpv(CopFILE(PL_curcop),0));
case 'L': return newSVOP(
op_sibling_splice(parent, first, -1, NULL);
op_free(entersubop);
- if (opnum == OP_ENTEREVAL
- && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
+ if (cvflags == (OP_ENTEREVAL | (1<<16)))
flags |= OPpEVAL_BYTES <<8;
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
case OA_BASEOP:
if (aop) {
- (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
+ SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
+ SVfARG(namesv)), SvUTF8(namesv));
op_free(aop);
}
return opnum == OP_RUNCV
}
/*
-=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
+=for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
Retrieves the function that will be used to fix up a call to C<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
subroutine call, not marked with C<&>, where the callee can be identified
at compile time as C<cv>.
-The C-level function pointer is returned in C<*ckfun_p>, and an SV
-argument for it is returned in C<*ckobj_p>. The function is intended
-to be called in this manner:
+The C-level function pointer is returned in C<*ckfun_p>, an SV argument
+for it is returned in C<*ckobj_p>, and control flags are returned in
+C<*ckflags_p>. The function is intended to be called in this manner:
entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
In this call, C<entersubop> is a pointer to the C<entersub> op,
-which may be replaced by the check function, and C<namegv> is a GV
-supplying the name that should be used by the check function to refer
+which may be replaced by the check function, and C<namegv> supplies
+the name that should be used by the check function to refer
to the callee of the C<entersub> op if it needs to emit any diagnostics.
It is permitted to apply the check function in non-standard situations,
such as to a call to a different subroutine or to a method call.
-By default, the function is
+C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
+bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
+instead, anything that can be used as the first argument to L</cv_name>.
+If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
+check function requires C<namegv> to be a genuine GV.
+
+By default, the check function is
L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
-and the SV parameter is C<cv> itself. This implements standard
-prototype processing. It can be changed, for a particular subroutine,
-by L</cv_set_call_checker>.
+the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
+flag is clear. This implements standard prototype processing. It can
+be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
+
+If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
+indicates that the caller only knows about the genuine GV version of
+C<namegv>, and accordingly the corresponding bit will always be set in
+C<*ckflags_p>, regardless of the check function's recorded requirements.
+If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
+indicates the caller knows about the possibility of passing something
+other than a GV as C<namegv>, and accordingly the corresponding bit may
+be either set or clear in C<*ckflags_p>, indicating the check function's
+recorded requirements.
+
+C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
+only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
+(for which see above). All other bits should be clear.
+
+=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
+
+The original form of L</cv_get_call_checker_flags>, which does not return
+checker flags. When using a checker function returned by this function,
+it is only safe to call it with a genuine GV as its C<namegv> argument.
=cut
*/
-static void
-S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
- U8 *flagsp)
+void
+Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
+ Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
{
MAGIC *callmg;
+ PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
+ PERL_UNUSED_CONTEXT;
callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
if (callmg) {
*ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
*ckobj_p = callmg->mg_obj;
- if (flagsp) *flagsp = callmg->mg_flags;
+ *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
} else {
*ckfun_p = Perl_ck_entersub_args_proto_or_list;
*ckobj_p = (SV*)cv;
- if (flagsp) *flagsp = 0;
+ *ckflags_p = gflags & MGf_REQUIRE_GV;
}
}
void
Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
{
+ U32 ckflags;
PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
PERL_UNUSED_CONTEXT;
- S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
+ cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
+ &ckflags);
}
/*
-=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
+=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
Sets the function that will be used to fix up a call to C<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
subroutine call, not marked with C<&>, where the callee can be identified
at compile time as C<cv>.
-The C-level function pointer is supplied in C<ckfun>, and an SV argument
-for it is supplied in C<ckobj>. The function should be defined like this:
+The C-level function pointer is supplied in C<ckfun>, an SV argument for
+it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
+The function should be defined like this:
STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
C<namegv> may not actually be a GV. For efficiency, perl may pass a
CV or other SV instead. Whatever is passed can be used as the first
argument to L</cv_name>. You can force perl to pass a GV by including
-C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
+C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
+
+C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
+bit currently has a defined meaning (for which see above). All other
+bits should be clear.
The current setting for a particular CV can be retrieved by
-L</cv_get_call_checker>.
+L</cv_get_call_checker_flags>.
=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
The original form of L</cv_set_call_checker_flags>, which passes it the
-C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
+C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
+of that flag setting is that the check function is guaranteed to get a
+genuine GV as its C<namegv> argument.
=cut
*/
void
Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
- SV *ckobj, U32 flags)
+ SV *ckobj, U32 ckflags)
{
PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
callmg->mg_flags |= MGf_REFCOUNTED;
}
callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
- | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
+ | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
}
}
} else {
Perl_call_checker ckfun;
SV *ckobj;
- U8 flags;
- S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
+ U32 ckflags;
+ cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
if (CvISXSUB(cv) || !CvROOT(cv))
S_entersub_alloc_targ(aTHX_ o);
if (!namegv) {
the CV’s GV, unless this is an anonymous sub. This is not
ideal for lexical subs, as its stringification will include
the package. But it is the best we can do. */
- if (flags & MGf_REQUIRE_GV) {
+ if (ckflags & CALL_CHECKER_REQUIRE_GV) {
if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
namegv = CvGV(cv);
}
if (kid->op_type == OP_NULL)
kid = OpSIBLING(kid);
if (kid)
- kid->op_flags |= OPf_MOD;
+ op_lvalue(kid, o->op_type);
}
return o;
is a pointer to the C function that is to be added to that opcode's
check chain, and C<old_checker_p> points to the storage location where a
pointer to the next function in the chain will be stored. The value of
-C<new_pointer> is written into the L</PL_check> array, while the value
+C<new_checker> is written into the L</PL_check> array, while the value
previously stored there is written to C<*old_checker_p>.
L</PL_check> is global to an entire process, and a module wishing to
wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
If you want to influence compilation of calls to a specific subroutine,
-then use L</cv_set_call_checker> rather than hooking checking of all
-C<entersub> ops.
+then use L</cv_set_call_checker_flags> rather than hooking checking of
+all C<entersub> ops.
=cut
*/
https://perl5.git.perl.org / perl5.git / blobdiff