# 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 {
+ UV 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;
+ UV 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];
+
+ UV nargs = 0;
+ UV 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);
+
+ /* 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++)->uv = q - oldq;
+ oldq = q;
+ continue;
+ }
+ }
+ *q++ = *p;
+ }
+ lenp->uv = 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->size = -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)->size = -1;
+ else {
+ STRLEN l = argp->len;
+ Copy(argp->p, p, l, char);
+ p += l;
+ if (lenp->size == -1)
+ lenp->size = l;
+ else
+ lenp->size += 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].uv = nargs;
+ aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
+ aux[PERL_MULTICONCAT_IX_PLAIN_LEN].size = utf8 ? 0 : total_len;
+ aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
+ aux[PERL_MULTICONCAT_IX_UTF8_LEN].size = 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);
+ UV n;
+
+ aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
+ aux[PERL_MULTICONCAT_IX_UTF8_LEN].size = ulen;
+
+ for (n = 0; n < (nargs + 1); n++) {
+ SSize_t i;
+ char * orig_up = up;
+ for (i = (lens++)->size; i > 0; i--) {
+ U8 c = *p++;
+ append_utf8_from_native_byte(c, (U8**)&up);
+ }
+ (ulens++)->size = (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
goto nomod;
case OP_AVHVSWITCH:
if (type == OP_LEAVESUBLV
- && (o->op_private & 3) + OP_EACH == OP_KEYS)
+ && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
o->op_private |= OPpMAYBE_LVSUB;
goto nomod;
case OP_AV2ARYLEN:
}
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;
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,
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
- (type == OP_RV2SV ? GvSV(gv) :
- type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
- type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
+ (type == OP_RV2SV ? GvSVn(gv) :
+ type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
+ type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
attrs);
}
o->op_private |= OPpOUR_INTRO;
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;
switch (ret) {
case 0:
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+ PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
+#endif
Perl_pp_pushmark(aTHX);
CALLRUNOPS(aTHX);
PL_op = curop;
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);
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)
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);
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);
}
}
SvROK_on(gv);
}
SvRV_set(gv, (SV *)cv);
+ if (HvENAME_HEK(PL_curstash))
+ mro_method_changed_in(PL_curstash);
}
}
case OP_RV2SV:
case OP_RV2AV:
OpTYPE_set(o, OP_RV2HV);
+ /* rv2hv steals the bottom bit for its own uses */
+ o->op_private &= ~OPpARG1_MASK;
ref(o, OP_RV2HV);
break;
&& 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;
case OP_HELEM:
break;
case OP_KVASLICE:
- Perl_croak(aTHX_ "delete argument is index/value array slice,"
- " use array slice");
+ o->op_flags |= OPf_SPECIAL;
+ /* FALLTHROUGH */
case OP_KVHSLICE:
- Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
- " hash slice");
+ o->op_private |= OPpKVSLICE;
+ break;
default:
Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
"element or slice");
return o;
}
+
OP *
Perl_ck_eval(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_RVCONST;
+ if (o->op_type == OP_RV2HV)
+ /* rv2hv steals the bottom bit for its own uses */
+ o->op_private &= ~OPpARG1_MASK;
+
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
if (kid && kid->op_type == OP_CONST) {
const bool save_taint = TAINT_get;
SV *sv = kSVOP->op_sv;
- if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
+ if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
+ && SvOK(sv) && !SvROK(sv))
+ {
sv = newSV(0);
sv_copypv(sv, kSVOP->op_sv);
SvREFCNT_dec_NN(kSVOP->op_sv);
)
&& (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)
{
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;
}
}
}
/* for sort { X } ..., where X is one of
- * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
+ * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
* elide the second child of the sort (the one containing X),
* and set these flags as appropriate
OPpSORT_NUMERIC;
}
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;
}
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);
}
case OP_GV:
/* it may be a package var index */
- ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
- if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
+ if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
|| o->op_private != 0
)
break;
/* See if the ops following o are such that o will always be executed in
* boolean context: that is, the SV which o pushes onto the stack will
- * only ever be used by later ops with SvTRUE(sv) or similar.
+ * only ever be consumed by later ops via SvTRUE(sv) or similar.
* If so, set a suitable private flag on o. Normally this will be
- * bool_flag; but if it's only possible to determine booleaness at run
- * time (e.g. sub f { ....; (%h || $y) }), then set maybe_flag instead.
+ * bool_flag; but see below why maybe_flag is needed too.
+ *
+ * Typically the two flags you pass will be the generic OPpTRUEBOOL and
+ * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
+ * already be taken, so you'll have to give that op two different flags.
+ *
+ * More explanation of 'maybe_flag' and 'safe_and' parameters.
+ * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
+ * those underlying ops) short-circuit, which means that rather than
+ * necessarily returning a truth value, they may return the LH argument,
+ * which may not be boolean. For example in $x = (keys %h || -1), keys
+ * should return a key count rather than a boolean, even though its
+ * sort-of being used in boolean context.
+ *
+ * So we only consider such logical ops to provide boolean context to
+ * their LH argument if they themselves are in void or boolean context.
+ * However, sometimes the context isn't known until run-time. In this
+ * case the op is marked with the maybe_flag flag it.
+ *
+ * Consider the following.
+ *
+ * sub f { ....; if (%h) { .... } }
+ *
+ * This is actually compiled as
+ *
+ * sub f { ....; %h && do { .... } }
+ *
+ * Here we won't know until runtime whether the final statement (and hence
+ * the &&) is in void context and so is safe to return a boolean value.
+ * So mark o with maybe_flag rather than the bool_flag.
+ * Note that there is cost associated with determining context at runtime
+ * (e.g. a call to block_gimme()), so it may not be worth setting (at
+ * compile time) and testing (at runtime) maybe_flag if the scalar verses
+ * boolean costs savings are marginal.
+ *
+ * However, we can do slightly better with && (compared to || and //):
+ * this op only returns its LH argument when that argument is false. In
+ * this case, as long as the op promises to return a false value which is
+ * valid in both boolean and scalar contexts, we can mark an op consumed
+ * by && with bool_flag rather than maybe_flag.
+ * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
+ * than &PL_sv_no for a false result in boolean context, then it's safe. An
+ * op which promises to handle this case is indicated by setting safe_and
+ * to true.
*/
static void
-S_check_for_bool_cxt(pTHX_ OP*o, U8 bool_flag, U8 maybe_flag)
+S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
{
OP *lop;
+ U8 flag = 0;
assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
+ /* OPpTARGET_MY and boolean context probably don't mix well.
+ * If someone finds a valid use case, maybe add an extra flag to this
+ * function which indicates its safe to do so for this op? */
+ assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
+ && (o->op_private & OPpTARGET_MY)));
+
lop = o->op_next;
while (lop) {
case OP_XOR:
case OP_COND_EXPR:
case OP_GREPWHILE:
- o->op_private |= bool_flag;
+ flag = bool_flag;
lop = NULL;
break;
* that whatever follows consumes the arg only in boolean context
* too.
*/
+ case OP_AND:
+ if (safe_and) {
+ flag = bool_flag;
+ lop = NULL;
+ break;
+ }
+ /* FALLTHROUGH */
case OP_OR:
case OP_DOR:
- case OP_AND:
if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
- o->op_private |= bool_flag;
+ flag = bool_flag;
lop = NULL;
}
else if (!(lop->op_flags & OPf_WANT)) {
/* unknown context - decide at runtime */
- o->op_private |= maybe_flag;
+ flag = maybe_flag;
lop = NULL;
}
break;
if (lop)
lop = lop->op_next;
}
+
+ o->op_private |= flag;
}
break;
}
+ case OP_RV2AV:
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ break;
+
case OP_RV2HV:
case OP_PADHV:
+ /*'keys %h' in void or scalar context: skip the OP_KEYS
+ * and perform the functionality directly in the RV2HV/PADHV
+ * op
+ */
+ if (o->op_flags & OPf_REF) {
+ OP *k = o->op_next;
+ U8 want = (k->op_flags & OPf_WANT);
+ if ( k
+ && k->op_type == OP_KEYS
+ && ( want == OPf_WANT_VOID
+ || want == OPf_WANT_SCALAR)
+ && !(k->op_private & OPpMAYBE_LVSUB)
+ && !(k->op_flags & OPf_MOD)
+ ) {
+ o->op_next = k->op_next;
+ o->op_flags &= ~(OPf_REF|OPf_WANT);
+ o->op_flags |= want;
+ o->op_private |= (o->op_type == OP_PADHV ?
+ OPpRV2HV_ISKEYS : OPpRV2HV_ISKEYS);
+ /* for keys(%lex), hold onto the OP_KEYS's targ
+ * since padhv doesn't have its own targ to return
+ * an int with */
+ if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
+ op_null(k);
+ }
+ }
+
/* see if %h is used in boolean context */
if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
- S_check_for_bool_cxt(aTHX_ o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+
+
if (o->op_type != OP_PADHV)
break;
/* FALLTHROUGH */
case OP_PADAV:
+ if ( o->op_type == OP_PADAV
+ && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
+ )
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ /* FALLTHROUGH */
case OP_PADSV:
/* Skip over state($x) in void context. */
if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
o->op_opt = 1;
break;
+ case OP_GREPWHILE:
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ /* FALLTHROUGH */
case OP_COND_EXPR:
case OP_MAPWHILE:
- case OP_GREPWHILE:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
break;
case OP_SUBST:
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
assert(!(cPMOP->op_pmflags & PMf_ONCE));
while (cPMOP->op_pmstashstartu.op_pmreplstart &&
cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
o->op_private &=
~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
break;
}
+ case OP_REF:
+ /* see if ref() is used in boolean context */
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+ break;
+
+ case OP_LENGTH:
+ /* see if the op is used in known boolean context,
+ * but not if OA_TARGLEX optimisation is enabled */
+ if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
+ && !(o->op_private & OPpTARGET_MY)
+ )
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ break;
+
+ case OP_POS:
+ /* see if the op is used in known boolean context */
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ break;
+
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
XopENTRYCUSTOM(o, xop_peep);
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>.
-The function should be defined like this:
-
- static OP *new_checker(pTHX_ OP *op) { ... }
-
-It is intended to be called in this manner:
-
- new_checker(aTHX_ op)
-
-C<old_checker_p> should be defined like this:
-
- static Perl_check_t old_checker_p;
-
L</PL_check> is global to an entire process, and a module wishing to
hook op checking may find itself invoked more than once per process,
typically in different threads. To handle that situation, this function
is the usual case for most uses of op check hooking), it must chain the
check function referenced by C<*old_checker_p>.
+Taken all together, XS code to hook an op checker should typically look
+something like this:
+
+ static Perl_check_t nxck_frob;
+ static OP *myck_frob(pTHX_ OP *op) {
+ ...
+ op = nxck_frob(aTHX_ op);
+ ...
+ return op;
+ }
+ BOOT:
+ 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