DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
gotit:
- /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
- o->op_lastsib = 1;
- assert(!o->op_sibling);
+#ifdef PERL_OP_PARENT
+ /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
+ assert(!o->op_moresib);
+ assert(!o->op_sibparent);
+#endif
return (void *)o;
}
PERL_UNUSED_CONTEXT;
DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
assert(slab->opslab_refcnt == 1);
- for (; slab; slab = slab2) {
+ do {
slab2 = slab->opslab_next;
#ifdef DEBUGGING
slab->opslab_refcnt = ~(size_t)0;
#else
PerlMemShared_free(slab);
#endif
- }
+ slab = slab2;
+ } while (slab);
}
void
#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
-#define CHANGE_TYPE(o,type) \
+#define OpTYPE_set(o,type) \
STMT_START { \
o->op_type = (OPCODE)type; \
o->op_ppaddr = PL_ppaddr[type]; \
return;
op_clear(o);
o->op_targ = o->op_type;
- CHANGE_TYPE(o, OP_NULL);
+ OpTYPE_set(o, OP_NULL);
}
void
=for apidoc op_sibling_splice
A general function for editing the structure of an existing chain of
-op_sibling nodes. By analogy with the perl-level splice() function, allows
+op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
you to delete zero or more sequential nodes, replacing them with zero or
more different nodes. Performs the necessary op_first/op_last
housekeeping on the parent node and op_sibling manipulation on the
children. The last deleted node will be marked as as the last node by
-updating the op_sibling or op_lastsib field as appropriate.
+updating the op_sibling/op_sibparent or op_moresib field as appropriate.
Note that op_next is not manipulated, and nodes are not freed; that is the
responsibility of the caller. It also won't create a new list op for an
empty list etc; use higher-level functions like op_append_elem() for that.
-parent is the parent node of the sibling chain.
+C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
+the splicing doesn't affect the first or last op in the chain.
-start is the node preceding the first node to be spliced. Node(s)
+C<start> is the node preceding the first node to be spliced. Node(s)
following it will be deleted, and ops will be inserted after it. If it is
-NULL, the first node onwards is deleted, and nodes are inserted at the
+C<NULL>, the first node onwards is deleted, and nodes are inserted at the
beginning.
-del_count is the number of nodes to delete. If zero, no nodes are deleted.
+C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
If -1 or greater than or equal to the number of remaining kids, all
remaining kids are deleted.
-insert is the first of a chain of nodes to be inserted in place of the nodes.
-If NULL, no nodes are inserted.
+C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
+If C<NULL>, no nodes are inserted.
-The head of the chain of deleted ops is returned, or NULL if no ops were
+The head of the chain of deleted ops is returned, or C<NULL> if no ops were
deleted.
For example:
splice(P, B, 0, X-Y) | | NULL
A-B-C-D A-B-X-Y-C-D
+
+For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
+see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
+
=cut
*/
OP *
Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
{
- OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first;
+ OP *first;
OP *rest;
OP *last_del = NULL;
OP *last_ins = NULL;
- PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
+ if (start)
+ first = OpSIBLING(start);
+ else if (!parent)
+ goto no_parent;
+ else
+ first = cLISTOPx(parent)->op_first;
assert(del_count >= -1);
while (--del_count && OpHAS_SIBLING(last_del))
last_del = OpSIBLING(last_del);
rest = OpSIBLING(last_del);
- OpSIBLING_set(last_del, NULL);
- last_del->op_lastsib = 1;
+ OpLASTSIB_set(last_del, NULL);
}
else
rest = first;
last_ins = insert;
while (OpHAS_SIBLING(last_ins))
last_ins = OpSIBLING(last_ins);
- OpSIBLING_set(last_ins, rest);
- last_ins->op_lastsib = rest ? 0 : 1;
+ OpMAYBESIB_set(last_ins, rest, NULL);
}
else
insert = rest;
if (start) {
- OpSIBLING_set(start, insert);
- start->op_lastsib = insert ? 0 : 1;
+ OpMAYBESIB_set(start, insert, NULL);
}
else {
+ if (!parent)
+ goto no_parent;
cLISTOPx(parent)->op_first = insert;
if (insert)
parent->op_flags |= OPf_KIDS;
if (!rest) {
/* update op_last etc */
- U32 type = parent->op_type;
+ U32 type;
OP *lastop;
- if (type == OP_NULL)
- type = parent->op_targ;
- type = PL_opargs[type] & OA_CLASS_MASK;
+ if (!parent)
+ goto no_parent;
+
+ /* ought to use OP_CLASS(parent) here, but that can't handle
+ * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
+ * either */
+ type = parent->op_type;
+ if (type == OP_CUSTOM) {
+ dTHX;
+ type = XopENTRYCUSTOM(parent, xop_class);
+ }
+ else {
+ if (type == OP_NULL)
+ type = parent->op_targ;
+ type = PL_opargs[type] & OA_CLASS_MASK;
+ }
lastop = last_ins ? last_ins : start ? start : NULL;
if ( type == OA_BINOP
)
cLISTOPx(parent)->op_last = lastop;
- if (lastop) {
- lastop->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- lastop->op_sibling = parent;
-#endif
- }
+ if (lastop)
+ OpLASTSIB_set(lastop, parent);
}
return last_del ? first : NULL;
+
+ no_parent:
+ Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
}
+
+#ifdef PERL_OP_PARENT
+
/*
=for apidoc op_parent
-returns the parent OP of o, if it has a parent. Returns NULL otherwise.
-(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
-work.
+Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
+This function is only available on perls built with C<-DPERL_OP_PARENT>.
=cut
*/
Perl_op_parent(OP *o)
{
PERL_ARGS_ASSERT_OP_PARENT;
-#ifdef PERL_OP_PARENT
while (OpHAS_SIBLING(o))
o = OpSIBLING(o);
- return o->op_sibling;
-#else
- PERL_UNUSED_ARG(o);
- return NULL;
-#endif
+ return o->op_sibparent;
}
+#endif
+
/* replace the sibling following start with a new UNOP, which becomes
* the parent of the original sibling; e.g.
LOGOP *logop;
OP *kid = first;
NewOp(1101, logop, 1, LOGOP);
- CHANGE_TYPE(logop, type);
+ OpTYPE_set(logop, type);
logop->op_first = first;
logop->op_other = other;
logop->op_flags = OPf_KIDS;
while (kid && OpHAS_SIBLING(kid))
kid = OpSIBLING(kid);
- if (kid) {
- kid->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- kid->op_sibling = (OP*)logop;
-#endif
- }
+ if (kid)
+ OpLASTSIB_set(kid, (OP*)logop);
return logop;
}
=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
Applies a syntactic context to an op tree representing an expression.
-I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
+C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
or C<G_VOID> to specify the context to apply. The modified op tree
is returned.
case OP_LOCALTIME:
case OP_GMTIME:
case OP_ENTEREVAL:
- case OP_REACH:
- case OP_RKEYS:
- case OP_RVALUES:
return;
}
break;
case OP_POSTINC:
- CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
+ OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
break;
case OP_POSTDEC:
- CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
+ OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
break;
case OP_I_POSTINC:
- CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
+ OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
break;
case OP_I_POSTDEC:
- CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
+ OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
break;
case OP_SASSIGN: {
if (kid->op_type == OP_NOT
&& (kid->op_flags & OPf_KIDS)) {
if (o->op_type == OP_AND) {
- CHANGE_TYPE(o, OP_OR);
+ OpTYPE_set(o, OP_OR);
} else {
- CHANGE_TYPE(o, OP_AND);
+ OpTYPE_set(o, OP_AND);
}
op_null(kid);
}
This function finalizes the optree. Should be called directly after
the complete optree is built. It does some additional
-checking which can't be done in the normal ck_xxx functions and makes
+checking which can't be done in the normal C<ck_>xxx functions and makes
the tree thread-safe.
=cut
#ifdef DEBUGGING
/* check that op_last points to the last sibling, and that
- * the last op_sibling field points back to the parent, and
- * that the only ops with KIDS are those which are entitled to
- * them */
+ * the last op_sibling/op_sibparent field points back to the
+ * parent, and that the only ops with KIDS are those which are
+ * entitled to them */
U32 type = o->op_type;
U32 family;
bool has_last;
if (!OpHAS_SIBLING(kid)) {
if (has_last)
assert(kid == cLISTOPo->op_last);
- assert(kid->op_sibling == o);
+ assert(kid->op_sibparent == o);
}
# else
- if (OpHAS_SIBLING(kid)) {
- assert(!kid->op_lastsib);
- }
- else {
- assert(kid->op_lastsib);
- if (has_last)
- assert(kid == cLISTOPo->op_last);
- }
+ if (has_last && !OpHAS_SIBLING(kid))
+ assert(kid == cLISTOPo->op_last);
# endif
}
#endif
=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
Propagate lvalue ("modifiable") context to an op and its children.
-I<type> represents the context type, roughly based on the type of op that
-would do the modifying, although C<local()> is represented by OP_NULL,
+C<type> represents the context type, roughly based on the type of op that
+would do the modifying, although C<local()> is represented by C<OP_NULL>,
because it has no op type of its own (it is signalled by a flag on
the lvalue op).
This function detects things that can't be modified, such as C<$x+1>, and
generates errors for them. For example, C<$x+1 = 2> would cause it to be
-called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
+called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
It also flags things that need to behave specially in an lvalue context,
such as C<$$x = 5> which might have to vivify a reference in C<$x>.
return;
}
slurpy:
- CHANGE_TYPE(o, OP_LVAVREF);
+ OpTYPE_set(o, OP_LVAVREF);
o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
o->op_flags |= OPf_MOD|OPf_REF;
return;
case OP_RV2CV:
kid = cUNOPo->op_first;
if (kid->op_type == OP_NULL)
- kid = cUNOPx(kUNOP->op_first->op_sibling)
+ kid = cUNOPx(OpSIBLING(kUNOP->op_first))
->op_first;
o->op_private = OPpLVREF_CV;
if (kid->op_type == OP_GV)
break;
case OP_ASLICE:
case OP_HSLICE:
- CHANGE_TYPE(o, OP_LVREFSLICE);
+ OpTYPE_set(o, OP_LVREFSLICE);
o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
return;
case OP_NULL:
: OP_DESC(o),
PL_op_desc[type]));
}
- CHANGE_TYPE(o, OP_LVREF);
+ OpTYPE_set(o, OP_LVREF);
o->op_private &=
OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
if (type == OP_ENTERLOOP)
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
- CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
+ OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
break;
case OP_KEYS:
- case OP_RKEYS:
if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
goto nomod;
goto lvalue_func;
PERL_ARGS_ASSERT_DOREF;
- if (!o || (PL_parser && PL_parser->error_count))
+ if (PL_parser && PL_parser->error_count)
return o;
switch (o->op_type) {
case OP_ENTERSUB:
if ((type == OP_EXISTS || type == OP_DEFINED) &&
!(o->op_flags & OPf_STACKED)) {
- CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
+ OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
STATIC void
S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
{
- SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
-
PERL_ARGS_ASSERT_APPLY_ATTRS;
+ {
+ SV * const stashsv = newSVhek(HvNAME_HEK(stash));
- /* fake up C<use attributes $pkg,$rv,@attrs> */
+ /* fake up C<use attributes $pkg,$rv,@attrs> */
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
- Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvs(ATTRSMODULE),
- NULL,
- op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, stashsv),
- op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0,
- newRV(target)),
- dup_attrlist(attrs))));
+ Perl_load_module(
+ aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ newSVpvs(ATTRSMODULE),
+ NULL,
+ op_prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, stashsv),
+ op_prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newRV(target)),
+ dup_attrlist(attrs))));
+ }
}
STATIC void
pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
/* Build up the real arg-list. */
- stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
+ stashsv = newSVhek(HvNAME_HEK(stash));
arg = newOP(OP_PADSV, 0);
arg->op_targ = target->op_targ;
if (o) {
if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
- CHANGE_TYPE(o, OP_LEAVE);
+ OpTYPE_set(o, OP_LEAVE);
}
else if (o->op_type == OP_LINESEQ) {
OP *kid;
- CHANGE_TYPE(o, OP_SCOPE);
+ OpTYPE_set(o, OP_SCOPE);
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
op_null(kid);
/*
=for apidoc Am|OP *|block_end|I32 floor|OP *seq
-Handles compile-time scope exit. I<floor>
+Handles compile-time scope exit. C<floor>
is the savestack index returned by
-C<block_start>, and I<seq> is the body of the block. Returns the block,
+C<block_start>, and C<seq> is the body of the block. Returns the block,
possibly modified.
=cut
Perl_pp_anonlist(aTHX);
PL_tmps_floor = oldtmps_floor;
- CHANGE_TYPE(o, OP_RV2AV);
+ OpTYPE_set(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in rpeep() */
=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
Append an item to the list of ops contained directly within a list-type
-op, returning the lengthened list. I<first> is the list-type op,
-and I<last> is the op to append to the list. I<optype> specifies the
-intended opcode for the list. If I<first> is not already a list of the
-right type, it will be upgraded into one. If either I<first> or I<last>
+op, returning the lengthened list. C<first> is the list-type op,
+and C<last> is the op to append to the list. C<optype> specifies the
+intended opcode for the list. If C<first> is not already a list of the
+right type, it will be upgraded into one. If either C<first> or C<last>
is null, the other is returned unchanged.
=cut
=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
Concatenate the lists of ops contained directly within two list-type ops,
-returning the combined list. I<first> and I<last> are the list-type ops
-to concatenate. I<optype> specifies the intended opcode for the list.
-If either I<first> or I<last> is not already a list of the right type,
-it will be upgraded into one. If either I<first> or I<last> is null,
+returning the combined list. C<first> and C<last> are the list-type ops
+to concatenate. C<optype> specifies the intended opcode for the list.
+If either C<first> or C<last> is not already a list of the right type,
+it will be upgraded into one. If either C<first> or C<last> is null,
the other is returned unchanged.
=cut
if (last->op_type != (unsigned)type)
return op_append_elem(type, first, last);
- ((LISTOP*)first)->op_last->op_lastsib = 0;
- OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
+ OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
- ((LISTOP*)first)->op_last->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- ((LISTOP*)first)->op_last->op_sibling = first;
-#endif
+ OpLASTSIB_set(((LISTOP*)first)->op_last, first);
first->op_flags |= (last->op_flags & OPf_KIDS);
-
S_op_destroy(aTHX_ last);
return first;
=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
Prepend an item to the list of ops contained directly within a list-type
-op, returning the lengthened list. I<first> is the op to prepend to the
-list, and I<last> is the list-type op. I<optype> specifies the intended
-opcode for the list. If I<last> is not already a list of the right type,
-it will be upgraded into one. If either I<first> or I<last> is null,
+op, returning the lengthened list. C<first> is the op to prepend to the
+list, and C<last> is the list-type op. C<optype> specifies the intended
+opcode for the list. If C<last> is not already a list of the right type,
+it will be upgraded into one. If either C<first> or C<last> is null,
the other is returned unchanged.
=cut
/*
=for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
-Converts I<o> into a list op if it is not one already, and then converts it
-into the specified I<type>, calling its check function, allocating a target if
+Converts C<o> into a list op if it is not one already, and then converts it
+into the specified C<type>, calling its check function, allocating a target if
it needs one, and folding constants.
A list-type op is usually constructed one kid at a time via C<newLISTOP>,
}
}
- CHANGE_TYPE(o, type);
+ OpTYPE_set(o, type);
o->op_flags |= flags;
if (flags & OPf_FOLDED)
o->op_folded = 1;
if (o) {
/* manually detach any siblings then add them back later */
rest = OpSIBLING(o);
- OpSIBLING_set(o, NULL);
- o->op_lastsib = 1;
+ OpLASTSIB_set(o, NULL);
}
o = newLISTOP(OP_LIST, 0, o, NULL);
if (rest)
/*
=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
-Constructs, checks, and returns an op of any list type. I<type> is
-the opcode. I<flags> gives the eight bits of C<op_flags>, except that
-C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
+Constructs, checks, and returns an op of any list type. C<type> is
+the opcode. C<flags> gives the eight bits of C<op_flags>, except that
+C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
supply up to two ops to be direct children of the list op; they are
consumed by this function and become part of the constructed op tree.
For most list operators, the check function expects all the kid ops to be
present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
appropriate. What you want to do in that case is create an op of type
-OP_LIST, append more children to it, and then call L</op_convert_list>.
+C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
See L</op_convert_list> for more information.
NewOp(1101, listop, 1, LISTOP);
- CHANGE_TYPE(listop, type);
+ OpTYPE_set(listop, type);
if (first || last)
flags |= OPf_KIDS;
listop->op_flags = (U8)flags;
else if (!first && last)
first = last;
else if (first)
- OpSIBLING_set(first, last);
+ OpMORESIB_set(first, last);
listop->op_first = first;
listop->op_last = last;
if (type == OP_LIST) {
OP* const pushop = newOP(OP_PUSHMARK, 0);
- pushop->op_lastsib = 0;
- OpSIBLING_set(pushop, first);
+ OpMORESIB_set(pushop, first);
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
if (!last)
listop->op_last = pushop;
}
- if (first)
- first->op_lastsib = 0;
- if (listop->op_last) {
- listop->op_last->op_lastsib = 1;
-#ifdef PERL_OP_PARENT
- listop->op_last->op_sibling = (OP*)listop;
-#endif
- }
+ if (listop->op_last)
+ OpLASTSIB_set(listop->op_last, (OP*)listop);
return CHECKOP(type, listop);
}
=for apidoc Am|OP *|newOP|I32 type|I32 flags
Constructs, checks, and returns an op of any base type (any type that
-has no extra fields). I<type> is the opcode. I<flags> gives the
+has no extra fields). C<type> is the opcode. C<flags> gives the
eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
of C<op_private>.
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, o, 1, OP);
- CHANGE_TYPE(o, type);
+ OpTYPE_set(o, type);
o->op_flags = (U8)flags;
o->op_next = o;
/*
=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
-Constructs, checks, and returns an op of any unary type. I<type> is
-the opcode. I<flags> gives the eight bits of C<op_flags>, except that
+Constructs, checks, and returns an op of any unary type. C<type> is
+the opcode. C<flags> gives the eight bits of C<op_flags>, except that
C<OPf_KIDS> will be set automatically if required, and, shifted up eight
bits, the eight bits of C<op_private>, except that the bit with value 1
-is automatically set. I<first> supplies an optional op to be the direct
+is automatically set. C<first> supplies an optional op to be the direct
child of the unary op; it is consumed by this function and become part
of the constructed op tree.
first = force_list(first, 1);
NewOp(1101, unop, 1, UNOP);
- CHANGE_TYPE(unop, type);
+ OpTYPE_set(unop, type);
unop->op_first = first;
unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
-#ifdef PERL_OP_PARENT
if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
- first->op_sibling = (OP*)unop;
-#endif
+ OpLASTSIB_set(first, (OP*)unop);
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
/*
=for apidoc newUNOP_AUX
-Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
-initialised to aux
+Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
+initialised to C<aux>
=cut
*/
unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
unop->op_aux = aux;
-#ifdef PERL_OP_PARENT
if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
- first->op_sibling = (OP*)unop;
-#endif
+ OpLASTSIB_set(first, (OP*)unop);
unop = (UNOP_AUX*) CHECKOP(type, unop);
=for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
Constructs, checks, and returns an op of method type with a method name
-evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
+evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
and, shifted up eight bits, the eight bits of C<op_private>, except that
-the bit with value 1 is automatically set. I<dynamic_meth> supplies an
+the bit with value 1 is automatically set. C<dynamic_meth> supplies an
op which evaluates method name; it is consumed by this function and
become part of the constructed op tree.
-Supported optypes: OP_METHOD.
+Supported optypes: C<OP_METHOD>.
=cut
*/
methop->op_u.op_first = dynamic_meth;
methop->op_private = (U8)(1 | (flags >> 8));
-#ifdef PERL_OP_PARENT
if (!OpHAS_SIBLING(dynamic_meth))
- dynamic_meth->op_sibling = (OP*)methop;
-#endif
+ OpLASTSIB_set(dynamic_meth, (OP*)methop);
}
else {
assert(const_meth);
methop->op_rclass_sv = NULL;
#endif
- CHANGE_TYPE(methop, type);
+ OpTYPE_set(methop, type);
return CHECKOP(type, methop);
}
=for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
Constructs, checks, and returns an op of method type with a constant
-method name. I<type> is the opcode. I<flags> gives the eight bits of
+method name. C<type> is the opcode. C<flags> gives the eight bits of
C<op_flags>, and, shifted up eight bits, the eight bits of
-C<op_private>. I<const_meth> supplies a constant method name;
+C<op_private>. C<const_meth> supplies a constant method name;
it must be a shared COW string.
-Supported optypes: OP_METHOD_NAMED.
+Supported optypes: C<OP_METHOD_NAMED>.
=cut
*/
/*
=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
-Constructs, checks, and returns an op of any binary type. I<type>
-is the opcode. I<flags> gives the eight bits of C<op_flags>, except
+Constructs, checks, and returns an op of any binary type. C<type>
+is the opcode. C<flags> gives the eight bits of C<op_flags>, except
that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
the eight bits of C<op_private>, except that the bit with value 1 or
-2 is automatically set as required. I<first> and I<last> supply up to
+2 is automatically set as required. C<first> and C<last> supply up to
two ops to be the direct children of the binary op; they are consumed
by this function and become part of the constructed op tree.
if (!first)
first = newOP(OP_NULL, 0);
- CHANGE_TYPE(binop, type);
+ OpTYPE_set(binop, type);
binop->op_first = first;
binop->op_flags = (U8)(flags | OPf_KIDS);
if (!last) {
}
else {
binop->op_private = (U8)(2 | (flags >> 8));
- OpSIBLING_set(first, last);
- first->op_lastsib = 0;
+ OpMORESIB_set(first, last);
}
-#ifdef PERL_OP_PARENT
if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
- last->op_sibling = (OP*)binop;
-#endif
+ OpLASTSIB_set(last, (OP*)binop);
binop->op_last = OpSIBLING(binop->op_first);
-#ifdef PERL_OP_PARENT
if (binop->op_last)
- binop->op_last->op_sibling = (OP*)binop;
-#endif
+ OpLASTSIB_set(binop->op_last, (OP*)binop);
binop = (BINOP*)CHECKOP(type, binop);
if (binop->op_next || binop->op_type != (OPCODE)type)
}
}
- /* now see which range will peter our first, if either. */
+ /* now see which range will peter out first, if either. */
tdiff = tlast - tfirst;
rdiff = rlast - rfirst;
tcount += tdiff + 1;
=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
Constructs, checks, and returns an op of any pattern matching type.
-I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
+C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
and, shifted up eight bits, the eight bits of C<op_private>.
=cut
|| type == OP_CUSTOM);
NewOp(1101, pmop, 1, PMOP);
- CHANGE_TYPE(pmop, type);
+ OpTYPE_set(pmop, type);
pmop->op_flags = (U8)flags;
pmop->op_private = (U8)(0 | (flags >> 8));
if (PL_opargs[type] & OA_RETSCALAR)
=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
Constructs, checks, and returns an op of any type that involves an
-embedded SV. I<type> is the opcode. I<flags> gives the eight bits
-of C<op_flags>. I<sv> gives the SV to embed in the op; this function
+embedded SV. C<type> is the opcode. C<flags> gives the eight bits
+of C<op_flags>. C<sv> gives the SV to embed in the op; this function
takes ownership of one reference to it.
=cut
|| type == OP_CUSTOM);
NewOp(1101, svop, 1, SVOP);
- CHANGE_TYPE(svop, type);
+ OpTYPE_set(svop, type);
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
Constructs, checks, and returns an op of any type that involves a
-reference to a pad element. I<type> is the opcode. I<flags> gives the
+reference to a pad element. C<type> is the opcode. C<flags> gives the
eight bits of C<op_flags>. A pad slot is automatically allocated, and
-is populated with I<sv>; this function takes ownership of one reference
+is populated with C<sv>; this function takes ownership of one reference
to it.
This function only exists if Perl has been compiled to use ithreads.
|| type == OP_CUSTOM);
NewOp(1101, padop, 1, PADOP);
- CHANGE_TYPE(padop, type);
+ OpTYPE_set(padop, type);
padop->op_padix =
pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
Constructs, checks, and returns an op of any type that involves an
-embedded reference to a GV. I<type> is the opcode. I<flags> gives the
-eight bits of C<op_flags>. I<gv> identifies the GV that the op should
+embedded reference to a GV. C<type> is the opcode. C<flags> gives the
+eight bits of C<op_flags>. C<gv> identifies the GV that the op should
reference; calling this function does not transfer ownership of any
reference to it.
=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
Constructs, checks, and returns an op of any type that involves an
-embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
-the eight bits of C<op_flags>.
I<pv> supplies the C-level pointer, which
+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.
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
- CHANGE_TYPE(pvop, type);
+ OpTYPE_set(pvop, type);
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
Loads the module whose name is pointed to by the string part of name.
Note that the actual module name, not its filename, should be given.
Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
-PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
+C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
(or 0 for no flags). ver, if specified
and not NULL, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
-arguments can be used to specify arguments to the module's import()
+arguments can be used to specify arguments to the module's C<import()>
method, similar to C<use Foo::Bar VERSION LIST>. They must be
-terminated with a final NULL pointer. Note that this list can only
-be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
-Otherwise at least a single NULL pointer to designate the default
+terminated with a final C<NULL> pointer. Note that this list can only
+be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
+Otherwise at least a single C<NULL> pointer to designate the default
import list is required.
The reference count for each specified C<SV*> parameter is decremented.
=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
-Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
+Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
be set automatically, and, shifted up eight bits, the eight bits of
C<op_private>, except that the bit with value 1 or 2 is automatically
-set as required. I<listval> and I<subscript> supply the parameters of
+set as required. C<listval> and C<subscript> supply the parameters of
the slice; they are consumed by this function and become part of the
constructed op tree.
return ret;
}
-/*
- Helper function for newASSIGNOP to detect commonality between the
- lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
- flags the op and the peephole optimizer calls this helper function
- if the flag is set.) Marks all variables with PL_generation. If it
- returns TRUE the assignment must be able to handle common variables.
-
- PL_generation sorcery:
- An assignment like ($a,$b) = ($c,$d) is easier than
- ($a,$b) = ($c,$a), since there is no need for temporary vars.
- To detect whether there are common vars, the global var
- PL_generation is incremented for each assign op we compile.
- Then, while compiling the assign op, we run through all the
- variables on both sides of the assignment, setting a spare slot
- in each of them to PL_generation. If any of them already have
- that value, we know we've got commonality. Also, if the
- generation number is already set to PERL_INT_MAX, then
- the variable is involved in aliasing, so we also have
- potential commonality in that case. We could use a
- single bit marker, but then we'd have to make 2 passes, first
- to clear the flag, then to test and set it. And that
- wouldn't help with aliasing, either. To find somewhere
- to store these values, evil chicanery is done with SvUVX().
-*/
-PERL_STATIC_INLINE bool
-S_aassign_common_vars(pTHX_ OP* o)
-{
- OP *curop;
- for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
- if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
- if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
- || curop->op_type == OP_AELEMFAST) {
- GV *gv = cGVOPx_gv(curop);
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- return TRUE;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
- else if (curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_AELEMFAST_LEX ||
- curop->op_type == OP_PADANY)
- {
- padcheck:
- if (PAD_COMPNAME_GEN(curop->op_targ)
- == (STRLEN)PL_generation
- || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
- return TRUE;
- PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
-
- }
- else if (curop->op_type == OP_RV2CV)
- return TRUE;
- else if (curop->op_type == OP_RV2SV ||
- curop->op_type == OP_RV2AV ||
- curop->op_type == OP_RV2HV ||
- curop->op_type == OP_RV2GV) {
- if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
- return TRUE;
- }
- else if (curop->op_type == OP_PUSHRE) {
- GV *const gv =
-#ifdef USE_ITHREADS
- ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
- ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
- : NULL;
-#else
- ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
-#endif
- if (gv) {
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- return TRUE;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
- else if (curop->op_targ)
- goto padcheck;
- }
- else if (curop->op_type == OP_PADRANGE)
- /* Ignore padrange; checking its siblings is sufficient. */
- continue;
- else
- return TRUE;
- }
- else if (PL_opargs[curop->op_type] & OA_TARGLEX
- && curop->op_private & OPpTARGET_MY)
- goto padcheck;
-
- if (curop->op_flags & OPf_KIDS) {
- if (aassign_common_vars(curop))
- return TRUE;
- }
- }
- return FALSE;
-}
-
-/* This variant only handles lexical aliases. It is called when
- newASSIGNOP decides that we don’t have any common vars, as lexical ali-
- ases trump that decision. */
-PERL_STATIC_INLINE bool
-S_aassign_common_vars_aliases_only(pTHX_ OP *o)
-{
- OP *curop;
- for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
- if ((curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_AELEMFAST_LEX ||
- curop->op_type == OP_PADANY ||
- ( PL_opargs[curop->op_type] & OA_TARGLEX
- && curop->op_private & OPpTARGET_MY ))
- && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
- return TRUE;
-
- if (curop->op_type == OP_PUSHRE && curop->op_targ
- && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
- return TRUE;
-
- if (curop->op_flags & OPf_KIDS) {
- if (S_aassign_common_vars_aliases_only(aTHX_ curop))
- return TRUE;
- }
- }
- return FALSE;
-}
/*
=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
-Constructs, checks, and returns an assignment op. I<left> and I<right>
+Constructs, checks, and returns an assignment op. C<left> and C<right>
supply the parameters of the assignment; they are consumed by this
function and become part of the constructed op tree.
-If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
-a suitable conditional optree is constructed. If I<optype> is the opcode
+If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
+a suitable conditional optree is constructed. If C<optype> is the opcode
of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
performs the binary operation and assigns the result to the left argument.
-Either way, if I<optype> is non-zero then I<flags> has no effect.
+Either way, if C<optype> is non-zero then C<flags> has no effect.
-If I<optype> is zero, then a plain scalar or list assignment is
+If C<optype> is zero, then a plain scalar or list assignment is
constructed. Which type of assignment it is is automatically determined.
-I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
+C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
will be set automatically, and, shifted up eight bits, the eight bits
of C<op_private>, except that the bit with value 1 or 2 is automatically
set as required.
static const char no_list_state[] = "Initialization of state variables"
" in list context currently forbidden";
OP *curop;
- bool maybe_common_vars = TRUE;
if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
left->op_private &= ~ OPpSLICEWARNING;
if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
{
OP* lop = ((LISTOP*)left)->op_first;
- maybe_common_vars = FALSE;
while (lop) {
- if (lop->op_type == OP_PADSV ||
- lop->op_type == OP_PADAV ||
- lop->op_type == OP_PADHV ||
- lop->op_type == OP_PADANY) {
- if (!(lop->op_private & OPpLVAL_INTRO))
- maybe_common_vars = TRUE;
-
- if (lop->op_private & OPpPAD_STATE) {
- if (left->op_private & OPpLVAL_INTRO) {
- /* Each variable in state($a, $b, $c) = ... */
- }
- else {
- /* Each state variable in
- (state $a, my $b, our $c, $d, undef) = ... */
- }
- yyerror(no_list_state);
- } else {
- /* Each my variable in
- (state $a, my $b, our $c, $d, undef) = ... */
- }
- } else if (lop->op_type == OP_UNDEF ||
- OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
- /* undef may be interesting in
- (state $a, undef, state $c) */
- } else {
- /* Other ops in the list. */
- maybe_common_vars = TRUE;
- }
+ 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)
+ else if ( (left->op_private & OPpLVAL_INTRO)
+ && (left->op_private & OPpPAD_STATE)
&& ( left->op_type == OP_PADSV
|| left->op_type == OP_PADAV
|| left->op_type == OP_PADHV
- || left->op_type == OP_PADANY))
- {
- if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
- if (left->op_private & OPpPAD_STATE) {
+ || left->op_type == OP_PADANY)
+ ) {
/* All single variable list context state assignments, hence
state ($a) = ...
(state $a) = ...
(state %a) = ...
*/
yyerror(no_list_state);
- }
- }
-
- if (maybe_common_vars) {
- /* The peephole optimizer will do the full check and pos-
- sibly turn this off. */
- o->op_private |= OPpASSIGN_COMMON;
}
if (right && right->op_type == OP_SPLIT
Constructs a state op (COP). The state op is normally a C<nextstate> op,
but will be a C<dbstate> op if debugging is enabled for currently-compiled
code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
-If I<label> is non-null, it supplies the name of a label to attach to
+If C<label> is non-null, it supplies the name of a label to attach to
the state op; this function takes ownership of the memory pointed at by
-I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
+C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
for the state op.
-If I<o> is null, the state op is returned. Otherwise the state op is
-combined with I<o> into a C<lineseq> list op, which is returned. I<o>
+If C<o> is null, the state op is returned. Otherwise the state op is
+combined with C<o> into a C<lineseq> list op, which is returned. C<o>
is consumed by this function and becomes part of the returned op tree.
=cut
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
- CHANGE_TYPE(cop, OP_DBSTATE);
+ OpTYPE_set(cop, OP_DBSTATE);
}
else {
- CHANGE_TYPE(cop, OP_NEXTSTATE);
+ OpTYPE_set(cop, OP_NEXTSTATE);
}
cop->op_flags = (U8)flags;
CopHINTS_set(cop, PL_hints);
/*
=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
-Constructs, checks, and returns a logical (flow control) op. I<type>
-is the opcode. I<flags> gives the eight bits of C<op_flags>, except
+Constructs, checks, and returns a logical (flow control) op. C<type>
+is the opcode. C<flags> gives the eight bits of C<op_flags>, except
that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
the eight bits of C<op_private>, except that the bit with value 1 is
-automatically set. I<first> supplies the expression controlling the
-flow, and I<other> supplies the side (alternate) chain of ops; they are
+automatically set. C<first> supplies the expression controlling the
+flow, and C<other> supplies the side (alternate) chain of ops; they are
consumed by this function and become part of the constructed op tree.
=cut
=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
Constructs, checks, and returns a conditional-expression (C<cond_expr>)
-op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
+op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
will be set automatically, and, shifted up eight bits, the eight bits of
C<op_private>, except that the bit with value 1 is automatically set.
-I<first> supplies the expression selecting between the two branches,
-and I<trueop> and I<falseop> supply the branches; they are consumed by
+C<first> supplies the expression selecting between the two branches,
+and C<trueop> and C<falseop> supply the branches; they are consumed by
this function and become part of the constructed op tree.
=cut
=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
Constructs and returns a C<range> op, with subordinate C<flip> and
-C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
+C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
for both the C<flip> and C<range> ops, except that the bit with value
-1 is automatically set. I<left> and I<right> supply the expressions
+1 is automatically set. C<left> and C<right> supply the expressions
controlling the endpoints of the range; they are consumed by this function
and become part of the constructed op tree.
Constructs, checks, and returns an op tree expressing a loop. This is
only a loop in the control flow through the op tree; it does not have
the heavyweight loop structure that allows exiting the loop by C<last>
-and suchlike. I<flags> gives the eight bits of C<op_flags> for the
+and suchlike. C<flags> gives the eight bits of C<op_flags> for the
top-level op, except that some bits will be set automatically as required.
-I<expr> supplies the expression controlling loop iteration, and I<block>
+C<expr> supplies the expression controlling loop iteration, and C<block>
supplies the body of the loop; they are consumed by this function and
-become part of the constructed op tree. I<debuggable> is currently
+become part of the constructed op tree. C<debuggable> is currently
unused and should always be 1.
=cut
This is a heavyweight loop, with structure that allows exiting the loop
by C<last> and suchlike.
-I<loop> is an optional preconstructed C<enterloop> op to use in the
+C<loop> is an optional preconstructed C<enterloop> op to use in the
loop; if it is null then a suitable op will be constructed automatically.
-I<expr> supplies the loop's controlling expression. I<block> supplies the
-main body of the loop, and I<cont> optionally supplies a C<continue> block
+C<expr> supplies the loop's controlling expression. C<block> supplies the
+main body of the loop, and C<cont> optionally supplies a C<continue> block
that operates as a second half of the body. All of these optree inputs
are consumed by this function and become part of the constructed op tree.
-I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
+C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
op and, shifted up eight bits, the eight bits of C<op_private> for
the C<leaveloop> op, except that (in both cases) some bits will be set
-automatically. I<debuggable> is currently unused and should always be 1.
-I<has_my> can be supplied as true to force the
+automatically. C<debuggable> is currently unused and should always be 1.
+C<has_my> can be supplied as true to force the
loop body to be enclosed in its own scope.
=cut
if (!loop) {
NewOp(1101,loop,1,LOOP);
- CHANGE_TYPE(loop, OP_ENTERLOOP);
+ OpTYPE_set(loop, OP_ENTERLOOP);
loop->op_private = 0;
loop->op_next = (OP*)loop;
}
loop (iteration through a list of values). This is a heavyweight loop,
with structure that allows exiting the loop by C<last> and suchlike.
-I<sv> optionally supplies the variable that will be aliased to each
+C<sv> optionally supplies the variable that will be aliased to each
item in turn; if null, it defaults to C<$_> (either lexical or global).
-I<expr> supplies the list of values to iterate over. I<block> supplies
-the main body of the loop, and I<cont> optionally supplies a C<continue>
+C<expr> supplies the list of values to iterate over. C<block> supplies
+the main body of the loop, and C<cont> optionally supplies a C<continue>
block that operates as a second half of the body. All of these optree
inputs are consumed by this function and become part of the constructed
op tree.
-I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
+C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
op and, shifted up eight bits, the eight bits of C<op_private> for
the C<leaveloop> op, except that (in both cases) some bits will be set
automatically.
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
- CHANGE_TYPE(sv, OP_RV2GV);
+ OpTYPE_set(sv, OP_RV2GV);
/* The op_type check is needed to prevent a possible segfault
* if the loop variable is undeclared and 'strict vars' is in
expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
}
- loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
- op_append_elem(OP_LIST, expr, scalar(sv))));
+ loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
+ op_append_elem(OP_LIST, list(expr),
+ scalar(sv)));
assert(!loop->op_next);
/* for my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
#ifdef PERL_OP_PARENT
- assert(loop->op_last->op_sibling == (OP*)loop);
- loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
+ assert(loop->op_last->op_sibparent == (OP*)loop);
+ OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
#endif
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
{
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
#ifdef PERL_OP_PARENT
- loop->op_last->op_sibling = (OP *)loop;
+ OpLASTSIB_set(loop->op_last, (OP*)loop);
#endif
}
loop->op_targ = padoff;
=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
Constructs, checks, and returns a loop-exiting op (such as C<goto>
-or C<last>). I<type> is the opcode. I<label> supplies the parameter
+or C<last>). C<type> is the opcode. C<label> supplies the parameter
determining the target of the op; it is consumed by this function and
becomes part of the constructed op tree.
/* anonlist now needs a list from this op, was previously used in
* scalar context */
- cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
+ cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
cond->op_flags |= OPf_WANT_LIST;
return newANONLIST(op_lvalue(cond, OP_ANONLIST));
=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
Constructs, checks, and returns an op tree expressing a C<given> block.
-I<cond> supplies the expression that will be locally assigned to a lexical
-variable, and I<block> supplies the body of the C<given> construct; they
+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
are consumed by this function and become part of the constructed op tree.
-I<defsv_off> is the pad offset of the scalar lexical variable that will
-be affected. If it is 0, the global $_ will be used.
+C<defsv_off> is the pad offset of the scalar lexical variable that will
+be affected. If it is 0, the global C<$_> will be used.
=cut
*/
=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
Constructs, checks, and returns an op tree expressing a C<when> block.
-I<cond> supplies the test expression, and I<block> supplies the block
+C<cond> supplies the test expression, and C<block> supplies the block
that will be executed if the test evaluates to true; they are consumed
-by this function and become part of the constructed op tree. I<cond>
+by this function and become part of the constructed op tree. C<cond>
will be interpreted DWIMically, often as a comparison against C<$_>,
and may be null to generate a C<default> block.
=for apidoc cv_const_sv
If C<cv> is a constant sub eligible for inlining, returns the constant
-value returned by the sub. Otherwise, returns NULL.
+value returned by the sub. Otherwise, returns C<NULL>.
Constant subs can be created with C<newCONSTSUB> or as described in
L<perlsub/"Constant Functions">.
: newUNOP(OP_LEAVESUB, 0, scalarseq(block));
start = LINKLIST(block);
block->op_next = 0;
+ if (ps && !*ps && !attrs && !CvLVALUE(compcv))
+ const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
+ else
+ const_sv = NULL;
}
-
- if (!block || !ps || *ps || attrs
- || CvLVALUE(compcv)
- )
- const_sv = NULL;
else
- const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
+ const_sv = NULL;
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
if (slab)
Slab_to_ro(slab);
#endif
- if (o) op_free(o);
+ op_free(o);
return cv;
}
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
- if (!ec)
- move_proto_attr(&proto, &attrs,
- isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
+ if (!ec) {
+ if (isGV(gv)) {
+ move_proto_attr(&proto, &attrs, gv);
+ } else {
+ assert(cSVOPo);
+ move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
+ }
+ }
if (proto) {
assert(proto->op_type == OP_CONST);
: newUNOP(OP_LEAVESUB, 0, scalarseq(block));
start = LINKLIST(block);
block->op_next = 0;
+ if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
+ const_sv =
+ S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
+ else
+ const_sv = NULL;
}
-
- if (!block || !ps || *ps || attrs
- || CvLVALUE(PL_compcv)
- )
- const_sv = NULL;
else
- const_sv =
- S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv)));
+ const_sv = NULL;
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
/*
=for apidoc newCONSTSUB_flags
-Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
+Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
eligible for inlining at compile-time.
-Currently, the only useful value for C<flags> is SVf_UTF8.
+Currently, the only useful value for C<flags> is C<SVf_UTF8>.
The newly created subroutine takes ownership of a reference to the passed in
SV.
-Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
+Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
which won't be called if used as a destructor, but will suppress the overhead
of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
compile time.)
/*
=for apidoc U||newXS
-Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
static storage, as it is used directly as CvFILE(), without a copy being made.
=cut
{
PERL_ARGS_ASSERT_NEWXS_DEFFILE;
return newXS_len_flags(
- name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+ name, strlen(name), subaddr, NULL, NULL, NULL, 0
);
}
bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
- if (!subaddr)
- Perl_croak_nocontext("panic: no address for '%s' in '%s'",
- name, filename ? filename : PL_xsubfilename);
+
{
GV * const gv = gv_fetchpvn(
name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
CvGV_set(cv, gv);
if(filename) {
- (void)gv_fetchfile(filename);
+ /* XSUBs can't be perl lang/perl5db.pl debugged
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(filename); */
assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
if (flags & XS_DYNAMIC_FILENAME) {
CvDYNFILE_on(cv);
switch (o->op_type) {
case OP_PADSV:
case OP_PADHV:
- CHANGE_TYPE(o, OP_PADAV);
+ OpTYPE_set(o, OP_PADAV);
return ref(o, OP_RV2AV);
case OP_RV2SV:
case OP_RV2HV:
- CHANGE_TYPE(o, OP_RV2AV);
+ OpTYPE_set(o, OP_RV2AV);
ref(o, OP_RV2AV);
break;
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
- CHANGE_TYPE(o, OP_PADHV);
+ OpTYPE_set(o, OP_PADHV);
return ref(o, OP_RV2HV);
case OP_RV2SV:
case OP_RV2AV:
- CHANGE_TYPE(o, OP_RV2HV);
+ OpTYPE_set(o, OP_RV2HV);
ref(o, OP_RV2HV);
break;
PERL_ARGS_ASSERT_NEWAVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADAV);
+ OpTYPE_set(o, OP_PADAV);
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
PERL_ARGS_ASSERT_NEWHVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADHV);
+ OpTYPE_set(o, OP_PADHV);
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
{
if (o->op_type == OP_PADANY) {
dVAR;
- CHANGE_TYPE(o, OP_PADCV);
+ OpTYPE_set(o, OP_PADCV);
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
PERL_ARGS_ASSERT_NEWSVREF;
if (o->op_type == OP_PADANY) {
- CHANGE_TYPE(o, OP_PADSV);
+ OpTYPE_set(o, OP_PADSV);
scalar(o);
return o;
}
enter->op_next = (OP*)enter;
o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
- CHANGE_TYPE(o, OP_LEAVETRY);
+ OpTYPE_set(o, OP_LEAVETRY);
enter->op_other = o;
return o;
}
&& SvTYPE(SvRV(gv)) != SVt_PVCV)
gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
}
- CHANGE_TYPE(kid, OP_GV);
+ OpTYPE_set(kid, OP_GV);
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
bad_type_pv(numargs, "array", o, kid);
- /* Defer checks to run-time if we have a scalar arg */
- if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
- op_lvalue(kid, type);
- else {
- scalar(kid);
- /* diag_listed_as: push on reference is experimental */
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__AUTODEREF),
- "%s on reference is experimental",
- PL_op_desc[type]);
+ else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
+ yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
+ PL_op_desc[type]), 0);
}
+ else {
+ op_lvalue(kid, type);
+ }
break;
case OA_HVREF:
if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
}
else {
OP * const newop
- = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
+ = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
op_free(o);
return newop;
}
/* Implicitly take a reference to a regular expression */
if (first->op_type == OP_MATCH) {
- CHANGE_TYPE(first, OP_QR);
+ OpTYPE_set(first, OP_QR);
}
if (second->op_type == OP_MATCH) {
- CHANGE_TYPE(second, OP_QR);
+ OpTYPE_set(second, OP_QR);
}
}
| ((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;
- CHANGE_TYPE(condop, OP_ONCE);
+ OpTYPE_set(condop, OP_ONCE);
other->op_targ = target;
nullop->op_flags |= OPf_WANT_SCALAR;
assert (left);
assert (left->op_type == OP_SREFGEN);
- o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
+ o->op_private = 0;
+ /* we use OPpPAD_STATE in refassign to mean either of those things,
+ * and the code assumes the two flags occupy the same bit position
+ * in the various ops below */
+ assert(OPpPAD_STATE == OPpOUR_INTRO);
switch (varop->op_type) {
case OP_PADAV:
goto settarg;
case OP_PADHV:
o->op_private |= OPpLVREF_HV;
+ /* FALLTHROUGH */
case OP_PADSV:
settarg:
+ o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
o->op_targ = varop->op_targ;
varop->op_targ = 0;
PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
break;
+
case OP_RV2AV:
o->op_private |= OPpLVREF_AV;
goto checkgv;
+ NOT_REACHED; /* NOTREACHED */
case OP_RV2HV:
o->op_private |= OPpLVREF_HV;
+ /* FALLTHROUGH */
case OP_RV2SV:
checkgv:
+ o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
detach_and_stack:
/* Point varop to its GV kid, detached. */
break;
case OP_RV2CV: {
OP * const kidparent =
- cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
+ OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
OP * const kid = cUNOPx(kidparent)->op_first;
o->op_private |= OPpLVREF_CV;
if (kid->op_type == OP_GV) {
}
case OP_AELEM:
case OP_HELEM:
+ o->op_private |= (varop->op_private & OPpLVAL_INTRO);
o->op_private |= OPpLVREF_ELEM;
op_null(varop);
stacked = TRUE;
unshare_hek(hek);
SvFLAGS(sv) |= was_readonly;
}
- else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
+ else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
+ && !SvVOK(sv)) {
s = SvPV(sv, len);
if (SvREFCNT(sv) > 1) {
kid->op_sv = newSVpvn_share(
if (o->op_flags & OPf_KIDS) {
kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid && OpHAS_SIBLING(kid)) {
- CHANGE_TYPE(o, OP_SSELECT);
+ OpTYPE_set(o, OP_SSELECT);
o = ck_fun(o);
return fold_constants(op_integerize(op_std_init(o)));
}
else {
OP * const padop = newOP(OP_PADCV, 0);
padop->op_targ = off;
- cUNOPx(firstkid)->op_first = padop;
-#ifdef PERL_OP_PARENT
- padop->op_sibling = firstkid;
-#endif
+ /* replace the const op with the pad op */
+ op_sibling_splice(firstkid, NULL, 1, padop);
op_free(kid);
}
}
kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
op_sibling_splice(o, NULL, 0, kid);
}
- CHANGE_TYPE(kid, OP_PUSHRE);
+ OpTYPE_set(kid, OP_PUSHRE);
/* target implies @ary=..., so wipe it */
kid->op_targ = 0;
scalar(kid);
{
OP * const kid = OpSIBLING(cUNOPo->op_first);
PERL_ARGS_ASSERT_CK_STRINGIFY;
- if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
- || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
- || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
+ || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
+ || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
{
- assert(!OpHAS_SIBLING(kid));
op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
op_free(o);
return kid;
Examines an op, which is expected to identify a subroutine at runtime,
and attempts to determine at compile time which subroutine it identifies.
This is normally used during Perl compilation to determine whether
-a prototype can be applied to a function call. I<cvop> is the op
+a prototype can be applied to a function call. C<cvop> is the op
being considered, normally an C<rv2cv> op. A pointer to the identified
subroutine is returned, if it could be determined statically, and a null
pointer is returned if it was not possible to determine statically.
the subroutine statically: this flag is used to suppress compile-time
magic on a subroutine call, forcing it to use default runtime behaviour.
-If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
+If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
of a GV reference is modified. If a GV was examined and its CV slot was
found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
If the op is not optimised away, and the CV slot is later populated with
a subroutine having a prototype, that flag eventually triggers the warning
"called too early to check prototype".
-If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
+If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
of returning a pointer to the subroutine it returns a pointer to the
GV giving the most appropriate name for the subroutine in this context.
Normally this is just the C<CvGV> of the subroutine, but for an anonymous
CV *compcv = PL_compcv;
while (PadnameOUTER(name)) {
assert(PARENT_PAD_INDEX(name));
- compcv = CvOUTSIDE(PL_compcv);
+ compcv = CvOUTSIDE(compcv);
name = PadlistNAMESARRAY(CvPADLIST(compcv))
[off = PARENT_PAD_INDEX(name)];
}
not marked with C<&>, where the callee can be identified at compile time
and has a prototype.
-
I<protosv> supplies the subroutine prototype to be applied to the call.
+
C<protosv> supplies the subroutine prototype to be applied to the call.
It may be a normal defined scalar, of which the string value will be used.
Alternatively, for convenience, it may be a subroutine object (a C<CV*>
that has been cast to C<SV*>) which has a prototype. The prototype
The error is reflected in the parser state, normally resulting in a single
exception at the top level of parsing which covers all the compilation
errors that occurred. In the error message, the callee is referred to
-by the name defined by the I<namegv> parameter.
+by the name defined by the C<namegv> parameter.
=cut
*/
case '&':
proto++;
arg++;
- if (o3->op_type != OP_SREFGEN
- || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
- != OP_ANONCODE
- && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
- != OP_RV2CV))
+ if ( o3->op_type != OP_UNDEF
+ && (o3->op_type != OP_SREFGEN
+ || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
+ != OP_ANONCODE
+ && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
+ != OP_RV2CV)))
bad_type_gv(arg, namegv, o3,
arg == 1 ? "block or sub {}" : "sub {}");
break;
This is the standard treatment used on a subroutine call, not marked
with C<&>, where the callee can be identified at compile time.
-
I<protosv> supplies the subroutine prototype to be applied to the call,
+
C<protosv> supplies the subroutine prototype to be applied to the call,
or indicates that there is no prototype. It may be a normal scalar,
in which case if it is defined then the string value will be used
as a prototype, and if it is undefined then there is no prototype.
The error is reflected in the parser state, normally resulting in a single
exception at the top level of parsing which covers all the compilation
errors that occurred. In the error message, the callee is referred to
-by the name defined by the I<namegv> parameter.
+by the name defined by the C<namegv> parameter.
=cut
*/
/*
=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
-Retrieves the function that will be used to fix up a call to I<cv>.
+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 I<cv>.
+at compile time as C<cv>.
-The C-level function pointer is returned in I<*ckfun_p>, and an SV
-argument for it is returned in I<*ckobj_p>. The function is intended
+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:
- entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
+ entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
-In this call, I<entersubop> is a pointer to the C<entersub> op,
-which may be replaced by the check function, and I<namegv> is a GV
+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
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,
By default, the function is
L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
-and the SV parameter is I<cv> itself. This implements standard
+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>.
/*
=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
-Sets the function that will be used to fix up a call to I<cv>.
+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 I<cv>.
+at compile time as C<cv>.
-The C-level function pointer is supplied in I<ckfun>, and an SV argument
-for it is supplied in I<ckobj>. The function should be defined like this:
+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:
STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
-In this call, I<entersubop> is a pointer to the C<entersub> op,
-which may be replaced by the check function, and I<namegv> supplies
+In this call, C<entersubop> is a pointer to the C<entersub> op,
+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.
-I<namegv> may not actually be a GV. For efficiency, perl may pass a
+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 I<flags>.
+C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
The current setting for a particular CV can be retrieved by
L</cv_get_call_checker>.
? -(SSize_t)len : (SSize_t)len,
0
);
+ if (SvREADONLY(*const_class))
+ SvREADONLY_on(shared);
SvREFCNT_dec(*const_class);
*const_class = shared;
}
SV * const sv = cSVOPo->op_sv;
PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv)) sv_force_normal(sv);
-#elif defined(PERL_NEW_COPY_ON_WRITE)
+#ifdef PERL_COPY_ON_WRITE
/* Since the read-only flag may be used to protect a string buffer, we
cannot do copy-on-write with existing read-only scalars that are not
already copy-on-write scalars. To allow $_ = "hello" to do COW with
dVAR;
OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
const unsigned orig_type = o->op_type;
- const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
- : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
- const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
- : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
PERL_ARGS_ASSERT_CK_EACH;
break;
case OP_PADAV:
case OP_RV2AV:
- CHANGE_TYPE(o, array_type);
+ OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
+ : orig_type == OP_KEYS ? OP_AKEYS
+ : OP_AVALUES);
break;
case OP_CONST:
if (kid->op_private == OPpCONST_BARE
/* we let ck_fun handle it */
break;
default:
- CHANGE_TYPE(o, ref_type);
- scalar(kid);
+ Perl_croak_nocontext(
+ "Experimental %s on scalar is now forbidden",
+ PL_op_desc[orig_type]);
+ break;
}
}
- /* if treating as a reference, defer additional checks to runtime */
- if (o->op_type == ref_type) {
- /* diag_listed_as: keys on reference is experimental */
- Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
- "%s is experimental", PL_op_desc[ref_type]);
- return o;
- }
return ck_fun(o);
}
return o;
}
+
+
+/*
+ ---------------------------------------------------------
+
+ Common vars in list assignment
+
+ There now follows some enums and static functions for detecting
+ common variables in list assignments. Here is a little essay I wrote
+ for myself when trying to get my head around this. DAPM.
+
+ ----
+
+ First some random observations:
+
+ * If a lexical var is an alias of something else, e.g.
+ for my $x ($lex, $pkg, $a[0]) {...}
+ then the act of aliasing will increase the reference count of the SV
+
+ * If a package var is an alias of something else, it may still have a
+ reference count of 1, depending on how the alias was created, e.g.
+ in *a = *b, $a may have a refcount of 1 since the GP is shared
+ with a single GvSV pointer to the SV. So If it's an alias of another
+ package var, then RC may be 1; if it's an alias of another scalar, e.g.
+ a lexical var or an array element, then it will have RC > 1.
+
+ * There are many ways to create a package alias; ultimately, XS code
+ may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
+ run-time tracing mechanisms are unlikely to be able to catch all cases.
+
+ * When the LHS is all my declarations, the same vars can't appear directly
+ on the RHS, but they can indirectly via closures, aliasing and lvalue
+ subs. But those techniques all involve an increase in the lexical
+ scalar's ref count.
+
+ * When the LHS is all lexical vars (but not necessarily my declarations),
+ it is possible for the same lexicals to appear directly on the RHS, and
+ without an increased ref count, since the stack isn't refcounted.
+ This case can be detected at compile time by scanning for common lex
+ vars with PL_generation.
+
+ * lvalue subs defeat common var detection, but they do at least
+ return vars with a temporary ref count increment. Also, you can't
+ tell at compile time whether a sub call is lvalue.
+
+
+ So...
+
+ A: There are a few circumstances where there definitely can't be any
+ commonality:
+
+ LHS empty: () = (...);
+ RHS empty: (....) = ();
+ RHS contains only constants or other 'can't possibly be shared'
+ elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
+ i.e. they only contain ops not marked as dangerous, whose children
+ are also not dangerous;
+ LHS ditto;
+ LHS contains a single scalar element: e.g. ($x) = (....); because
+ after $x has been modified, it won't be used again on the RHS;
+ RHS contains a single element with no aggregate on LHS: e.g.
+ ($a,$b,$c) = ($x); again, once $a has been modified, its value
+ won't be used again.
+
+ B: If LHS are all 'my' lexical var declarations (or safe ops, which
+ we can ignore):
+
+ my ($a, $b, @c) = ...;
+
+ Due to closure and goto tricks, these vars may already have content.
+ For the same reason, an element on the RHS may be a lexical or package
+ alias of one of the vars on the left, or share common elements, for
+ example:
+
+ my ($x,$y) = f(); # $x and $y on both sides
+ sub f : lvalue { ($x,$y) = (1,2); $y, $x }
+
+ and
+
+ my $ra = f();
+ my @a = @$ra; # elements of @a on both sides
+ sub f { @a = 1..4; \@a }
+
+
+ First, just consider scalar vars on LHS:
+
+ RHS is safe only if (A), or in addition,
+ * contains only lexical *scalar* vars, where neither side's
+ lexicals have been flagged as aliases
+
+ If RHS is not safe, then it's always legal to check LHS vars for
+ RC==1, since the only RHS aliases will always be associated
+ with an RC bump.
+
+ Note that in particular, RHS is not safe if:
+
+ * it contains package scalar vars; e.g.:
+
+ f();
+ my ($x, $y) = (2, $x_alias);
+ sub f { $x = 1; *x_alias = \$x; }
+
+ * It contains other general elements, such as flattened or
+ * spliced or single array or hash elements, e.g.
+
+ f();
+ my ($x,$y) = @a; # or $a[0] or @a{@b} etc
+
+ sub f {
+ ($x, $y) = (1,2);
+ use feature 'refaliasing';
+ \($a[0], $a[1]) = \($y,$x);
+ }
+
+ It doesn't matter if the array/hash is lexical or package.
+
+ * it contains a function call that happens to be an lvalue
+ sub which returns one or more of the above, e.g.
+
+ f();
+ my ($x,$y) = f();
+
+ sub f : lvalue {
+ ($x, $y) = (1,2);
+ *x1 = \$x;
+ $y, $x1;
+ }
+
+ (so a sub call on the RHS should be treated the same
+ as having a package var on the RHS).
+
+ * any other "dangerous" thing, such an op or built-in that
+ returns one of the above, e.g. pp_preinc
+
+
+ If RHS is not safe, what we can do however is at compile time flag
+ that the LHS are all my declarations, and at run time check whether
+ all the LHS have RC == 1, and if so skip the full scan.
+
+ Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
+
+ Here the issue is whether there can be elements of @a on the RHS
+ which will get prematurely freed when @a is cleared prior to
+ assignment. This is only a problem if the aliasing mechanism
+ is one which doesn't increase the refcount - only if RC == 1
+ will the RHS element be prematurely freed.
+
+ Because the array/hash is being INTROed, it or its elements
+ can't directly appear on the RHS:
+
+ my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
+
+ but can indirectly, e.g.:
+
+ my $r = f();
+ my (@a) = @$r;
+ sub f { @a = 1..3; \@a }
+
+ So if the RHS isn't safe as defined by (A), we must always
+ mortalise and bump the ref count of any remaining RHS elements
+ when assigning to a non-empty LHS aggregate.
+
+ Lexical scalars on the RHS aren't safe if they've been involved in
+ aliasing, e.g.
+
+ use feature 'refaliasing';
+
+ f();
+ \(my $lex) = \$pkg;
+ my @a = ($lex,3); # equivalent to ($a[0],3)
+
+ sub f {
+ @a = (1,2);
+ \$pkg = \$a[0];
+ }
+
+ Similarly with lexical arrays and hashes on the RHS:
+
+ f();
+ my @b;
+ my @a = (@b);
+
+ sub f {
+ @a = (1,2);
+ \$b[0] = \$a[1];
+ \$b[1] = \$a[0];
+ }
+
+
+
+ C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
+ my $a; ($a, my $b) = (....);
+
+ The difference between (B) and (C) is that it is now physically
+ possible for the LHS vars to appear on the RHS too, where they
+ are not reference counted; but in this case, the compile-time
+ PL_generation sweep will detect such common vars.
+
+ So the rules for (C) differ from (B) in that if common vars are
+ detected, the runtime "test RC==1" optimisation can no longer be used,
+ and a full mark and sweep is required
+
+ D: As (C), but in addition the LHS may contain package vars.
+
+ Since package vars can be aliased without a corresponding refcount
+ increase, all bets are off. It's only safe if (A). E.g.
+
+ my ($x, $y) = (1,2);
+
+ for $x_alias ($x) {
+ ($x_alias, $y) = (3, $x); # whoops
+ }
+
+ Ditto for LHS aggregate package vars.
+
+ E: Any other dangerous ops on LHS, e.g.
+ (f(), $a[0], @$r) = (...);
+
+ this is similar to (E) in that all bets are off. In addition, it's
+ impossible to determine at compile time whether the LHS
+ contains a scalar or an aggregate, e.g.
+
+ sub f : lvalue { @a }
+ (f()) = 1..3;
+
+* ---------------------------------------------------------
+*/
+
+
+/* A set of bit flags returned by S_aassign_scan(). Each flag indicates
+ * that at least one of the things flagged was seen.
+ */
+
+enum {
+ AAS_MY_SCALAR = 0x001, /* my $scalar */
+ AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
+ AAS_LEX_SCALAR = 0x004, /* $lexical */
+ AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
+ AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
+ AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
+ AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
+ AAS_DANGEROUS = 0x080, /* an op (other than the above)
+ that's flagged OA_DANGEROUS */
+ AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
+ not in any of the categories above */
+ AAS_DEFAV = 0x200, /* contains just a single '@_' on RHS */
+};
+
+
+
+/* helper function for S_aassign_scan().
+ * check a PAD-related op for commonality and/or set its generation number.
+ * Returns a boolean indicating whether its shared */
+
+static bool
+S_aassign_padcheck(pTHX_ OP* o, bool rhs)
+{
+ if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
+ /* lexical used in aliasing */
+ return TRUE;
+
+ if (rhs)
+ return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
+ else
+ PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
+
+ return FALSE;
+}
+
+
+/*
+ Helper function for OPpASSIGN_COMMON* detection in rpeep().
+ It scans the left or right hand subtree of the aassign op, and returns a
+ set of flags indicating what sorts of things it found there.
+ 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
+ set PL_generation on lexical vars; if the latter, we see if
+ PL_generation matches.
+ 'top' indicates whether we're recursing or at the top level.
+ 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
+ This fn will increment it by the number seen. It's not intended to
+ be an accurate count (especially as many ops can push a variable
+ number of SVs onto the stack); rather it's used as to test whether there
+ can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
+*/
+
+static int
+S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
+{
+ int flags = 0;
+ bool kid_top = FALSE;
+
+ /* first, look for a solitary @_ on the RHS */
+ if ( rhs
+ && top
+ && (o->op_flags & OPf_KIDS)
+ && OP_TYPE_IS_OR_WAS(o, OP_LIST)
+ ) {
+ OP *kid = cUNOPo->op_first;
+ if ( ( kid->op_type == OP_PUSHMARK
+ || kid->op_type == OP_PADRANGE) /* ex-pushmark */
+ && ((kid = OpSIBLING(kid)))
+ && !OpHAS_SIBLING(kid)
+ && kid->op_type == OP_RV2AV
+ && !(kid->op_flags & OPf_REF)
+ && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
+ && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
+ && ((kid = cUNOPx(kid)->op_first))
+ && kid->op_type == OP_GV
+ && cGVOPx_gv(kid) == PL_defgv
+ )
+ flags |= AAS_DEFAV;
+ }
+
+ switch (o->op_type) {
+ case OP_GVSV:
+ (*scalars_p)++;
+ return AAS_PKG_SCALAR;
+
+ case OP_PADAV:
+ case OP_PADHV:
+ (*scalars_p) += 2;
+ if (top && (o->op_flags & OPf_REF))
+ return (o->op_private & OPpLVAL_INTRO)
+ ? AAS_MY_AGG : AAS_LEX_AGG;
+ return AAS_DANGEROUS;
+
+ case OP_PADSV:
+ {
+ int comm = S_aassign_padcheck(aTHX_ o, rhs)
+ ? AAS_LEX_SCALAR_COMM : 0;
+ (*scalars_p)++;
+ return (o->op_private & OPpLVAL_INTRO)
+ ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
+ }
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ (*scalars_p) += 2;
+ if (cUNOPx(o)->op_first->op_type != OP_GV)
+ return AAS_DANGEROUS; /* @{expr}, %{expr} */
+ /* @pkg, %pkg */
+ if (top && (o->op_flags & OPf_REF))
+ return AAS_PKG_AGG;
+ return AAS_DANGEROUS;
+
+ case OP_RV2SV:
+ (*scalars_p)++;
+ if (cUNOPx(o)->op_first->op_type != OP_GV) {
+ (*scalars_p) += 2;
+ return AAS_DANGEROUS; /* ${expr} */
+ }
+ return AAS_PKG_SCALAR; /* $pkg */
+
+ case OP_SPLIT:
+ if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
+ /* "@foo = split... " optimises away the aassign and stores its
+ * destination array in the OP_PUSHRE that precedes it.
+ * A flattened array is always dangerous.
+ */
+ (*scalars_p) += 2;
+ return AAS_DANGEROUS;
+ }
+ break;
+
+ case OP_UNDEF:
+ /* undef counts as a scalar on the RHS:
+ * (undef, $x) = ...; # only 1 scalar on LHS: always safe
+ * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
+ */
+ if (rhs)
+ (*scalars_p)++;
+ flags = AAS_SAFE_SCALAR;
+ break;
+
+ case OP_PUSHMARK:
+ case OP_STUB:
+ /* these are all no-ops; they don't push a potentially common SV
+ * onto the stack, so they are neither AAS_DANGEROUS nor
+ * AAS_SAFE_SCALAR */
+ return 0;
+
+ case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
+ break;
+
+ case OP_NULL:
+ case OP_LIST:
+ /* these do nothing but may have children; but their children
+ * should also be treated as top-level */
+ kid_top = top;
+ break;
+
+ default:
+ if (PL_opargs[o->op_type] & OA_DANGEROUS) {
+ (*scalars_p) += 2;
+ return AAS_DANGEROUS;
+ }
+
+ if ( (PL_opargs[o->op_type] & OA_TARGLEX)
+ && (o->op_private & OPpTARGET_MY))
+ {
+ (*scalars_p)++;
+ return S_aassign_padcheck(aTHX_ o, rhs)
+ ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
+ }
+
+ /* if its an unrecognised, non-dangerous op, assume that it
+ * it the cause of at least one safe scalar */
+ (*scalars_p)++;
+ flags = AAS_SAFE_SCALAR;
+ break;
+ }
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
+ flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
+ }
+ return flags;
+}
+
+
/* Check for in place reverse and sort assignments like "@a = reverse @a"
and modify the optree to make them work inplace */
* determines whether the op chain is convertible and calculates the
* buffer size; the second pass populates the buffer and makes any
* changes necessary to ops (such as moving consts to the pad on
- * threaded builds)
+ * threaded builds).
+ *
+ * NB: for things like Coverity, note that both passes take the same
+ * path through the logic tree (except for 'if (pass)' bits), since
+ * both passes are following the same op_next chain; and in
+ * particular, if it would return early on the second pass, it would
+ * already have returned early on the first pass.
*/
for (pass = 0; pass < 2; pass++) {
OP *o = orig_o;
assert(OpSIBLING(ns2) == pad2);
assert(OpSIBLING(pad2) == ns3);
+ /* excise and delete ns2 */
+ op_sibling_splice(NULL, pad1, 1, NULL);
+ op_free(ns2);
+
+ /* excise pad1 and pad2 */
+ op_sibling_splice(NULL, o, 2, NULL);
+
/* create new listop, with children consisting of:
* a new pushmark, pad1, pad2. */
- OpSIBLING_set(pad2, NULL);
newop = newLISTOP(OP_LIST, 0, pad1, pad2);
newop->op_flags |= OPf_PARENS;
newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
- newpm = cUNOPx(newop)->op_first; /* pushmark */
- /* Kill nextstate2 between padop1/padop2 */
- op_free(ns2);
+ /* insert newop between o and ns3 */
+ op_sibling_splice(NULL, o, 0, newop);
+ /*fixup op_next chain */
+ newpm = cUNOPx(newop)->op_first; /* pushmark */
o ->op_next = newpm;
newpm->op_next = pad1;
pad1 ->op_next = pad2;
pad2 ->op_next = newop; /* listop */
newop->op_next = ns3;
- OpSIBLING_set(o, newop);
- OpSIBLING_set(newop, ns3);
- newop->op_lastsib = 0;
-
- newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
-
/* Ensure pushmark has this flag if padops do */
if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
- o->op_next->op_flags |= OPf_MOD;
+ newpm->op_flags |= OPf_MOD;
}
break;
o->op_flags &=~ OPf_KIDS;
/* stub is a baseop; repeat is a binop */
STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
- CHANGE_TYPE(o, OP_STUB);
+ OpTYPE_set(o, OP_STUB);
o->op_private = 0;
break;
}
* *always* formerly a pushmark */
assert(o->op_type == OP_PUSHMARK);
o->op_next = followop;
- CHANGE_TYPE(o, OP_PADRANGE);
+ OpTYPE_set(o, OP_PADRANGE);
o->op_targ = base;
/* bit 7: INTRO; bit 6..0: count */
o->op_private = (intro | count);
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
- CHANGE_TYPE(o, OP_GVSV);
+ OpTYPE_set(o, OP_GVSV);
}
}
else if (o->op_next->op_type == OP_READLINE
&& (o->op_next->op_next->op_flags & OPf_STACKED))
{
/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
- CHANGE_TYPE(o, OP_RCATLINE);
+ OpTYPE_set(o, OP_RCATLINE);
o->op_flags |= OPf_STACKED;
op_null(o->op_next->op_next);
op_null(o->op_next);
rv2av = OpSIBLING(ourmark);
if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
- && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
- && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
+ && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
/* We're just reversing a single array. */
rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
enter->op_flags |= OPf_STACKED;
sv_rvweaken(sv);
SvREADONLY_on(sv);
}
- CHANGE_TYPE(o, OP_CONST);
+ OpTYPE_set(o, OP_CONST);
o->op_flags |= OPf_SPECIAL;
cSVOPo->op_sv = sv;
}
}
break;
- case OP_AASSIGN:
- /* We do the common-vars check here, rather than in newASSIGNOP
- (as formerly), so that all lexical vars that get aliased are
- marked as such before we do the check. */
- /* There can’t be common vars if the lhs is a stub. */
- if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
- == cLISTOPx(cBINOPo->op_last)->op_last
- && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
- {
- o->op_private &=~ OPpASSIGN_COMMON;
- break;
- }
- if (o->op_private & OPpASSIGN_COMMON) {
- /* See the comment before S_aassign_common_vars concerning
- PL_generation sorcery. */
- PL_generation++;
- if (!aassign_common_vars(o))
- o->op_private &=~ OPpASSIGN_COMMON;
- }
- else if (S_aassign_common_vars_aliases_only(aTHX_ o))
- o->op_private |= OPpASSIGN_COMMON;
+ case OP_AASSIGN: {
+ int l, r, lr, lscalars, rscalars;
+
+ /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
+ Note that we do this now rather than in newASSIGNOP(),
+ since only by now are aliased lexicals flagged as such
+
+ See the essay "Common vars in list assignment" above for
+ the full details of the rationale behind all the conditions
+ below.
+
+ PL_generation sorcery:
+ To detect whether there are common vars, the global var
+ PL_generation is incremented for each assign op we scan.
+ Then we run through all the lexical variables on the LHS,
+ of the assignment, setting a spare slot in each of them to
+ PL_generation. Then we scan the RHS, and if any lexicals
+ already have that value, we know we've got commonality.
+ Also, if the generation number is already set to
+ PERL_INT_MAX, then the variable is involved in aliasing, so
+ we also have potential commonality in that case.
+ */
+
+ PL_generation++;
+ /* scan LHS */
+ lscalars = 0;
+ l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
+ /* scan RHS */
+ rscalars = 0;
+ r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
+ lr = (l|r);
+
+
+ /* After looking for things which are *always* safe, this main
+ * if/else chain selects primarily based on the type of the
+ * LHS, gradually working its way down from the more dangerous
+ * to the more restrictive and thus safer cases */
+
+ if ( !l /* () = ....; */
+ || !r /* .... = (); */
+ || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
+ || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
+ || (lscalars < 2) /* ($x, undef) = ... */
+ ) {
+ NOOP; /* always safe */
+ }
+ else if (l & AAS_DANGEROUS) {
+ /* always dangerous */
+ o->op_private |= OPpASSIGN_COMMON_SCALAR;
+ o->op_private |= OPpASSIGN_COMMON_AGG;
+ }
+ else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
+ /* package vars are always dangerous - too many
+ * aliasing possibilities */
+ if (l & AAS_PKG_SCALAR)
+ o->op_private |= OPpASSIGN_COMMON_SCALAR;
+ if (l & AAS_PKG_AGG)
+ o->op_private |= OPpASSIGN_COMMON_AGG;
+ }
+ else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
+ |AAS_LEX_SCALAR|AAS_LEX_AGG))
+ {
+ /* LHS contains only lexicals and safe ops */
+
+ if (l & (AAS_MY_AGG|AAS_LEX_AGG))
+ o->op_private |= OPpASSIGN_COMMON_AGG;
+
+ if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
+ if (lr & AAS_LEX_SCALAR_COMM)
+ o->op_private |= OPpASSIGN_COMMON_SCALAR;
+ else if ( !(l & AAS_LEX_SCALAR)
+ && (r & AAS_DEFAV))
+ {
+ /* falsely mark
+ * my (...) = @_
+ * as scalar-safe for performance reasons.
+ * (it will still have been marked _AGG if necessary */
+ NOOP;
+ }
+ else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
+ o->op_private |= OPpASSIGN_COMMON_RC1;
+ }
+ }
+
+ /* ... = ($x)
+ * may have to handle aggregate on LHS, but we can't
+ * have common scalars. */
+ if (rscalars < 2)
+ o->op_private &=
+ ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
+
break;
+ }
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
=for apidoc Ao||custom_op_xop
Return the XOP structure for a given custom op. This macro should be
-considered internal to OP_NAME and the other access macros: use them instead.
+considered internal to C<OP_NAME> and the other access macros: use them instead.
This macro does call a function. Prior
to 5.19.6, this was implemented as a
function.
=for apidoc core_prototype
This function assigns the prototype of the named core function to C<sv>, or
-to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
-NULL if the core function has no prototype. C<code> is a code as returned
+to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
+C<NULL> if the core function has no prototype. C<code> is a code as returned
by C<keyword()>. It must not be equal to 0.
=cut
case KEY_x : case KEY_xor :
if (!opnum) return NULL; nullret = TRUE; goto findopnum;
case KEY_glob: retsetpvs("_;", OP_GLOB);
- case KEY_keys: retsetpvs("+", OP_KEYS);
- case KEY_values: retsetpvs("+", OP_VALUES);
- case KEY_each: retsetpvs("+", OP_EACH);
- case KEY_push: retsetpvs("+@", OP_PUSH);
- case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
- case KEY_pop: retsetpvs(";+", OP_POP);
- case KEY_shift: retsetpvs(";+", OP_SHIFT);
+ case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
+ case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
+ case KEY_each: retsetpvs("\\[%@]", OP_EACH);
+ case KEY_push: retsetpvs("\\@@", OP_PUSH);
+ case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
+ case KEY_pop: retsetpvs(";\\@", OP_POP);
+ case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
case KEY_splice:
- retsetpvs("+;$$@", OP_SPLICE);
+ retsetpvs("\\@;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
retsetpvs("", 0);
case KEY_evalbytes:
Puts a C function into the chain of check functions for a specified op
type. This is the preferred way to manipulate the L</PL_check> array.
-I<opcode> specifies which type of op is to be affected. I<new_checker>
+C<opcode> specifies which type of op is to be affected. C<new_checker>
is a pointer to the C function that is to be added to that opcode's
-check chain, and
I<old_checker_p> points to the storage location where a
+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
-I<new_pointer> is written into the L</PL_check> array, while the value
-previously stored there is written to I<*old_checker_p>.
+C<new_pointer> 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:
new_checker(aTHX_ op)
-
I<old_checker_p> should be defined like this:
+
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 idempotent. The location I<*old_checker_p> must initially (once
+is idempotent. The location C<*old_checker_p> must initially (once
per process) contain a null pointer. A C variable of static duration
(declared at file scope, typically also marked C<static> to give
it internal linkage) will be implicitly initialised appropriately,
if it does not have an explicit initialiser. This function will only
-actually modify the check chain if it finds I<*old_checker_p> to be null.
+actually modify the check chain if it finds C<*old_checker_p> to be null.
This function is also thread safe on the small scale. It uses appropriate
locking to avoid race conditions in accessing L</PL_check>.
-When this function is called, the function referenced by I<new_checker>
-must be ready to be called, except for I<*old_checker_p> being unfilled.
-In a threading situation, I<new_checker> may be called immediately,
-even before this function has returned. I<*old_checker_p> will always
-be appropriately set before I<new_checker> is called. If I<new_checker>
+When this function is called, the function referenced by C<new_checker>
+must be ready to be called, except for C<*old_checker_p> being unfilled.
+In a threading situation, C<new_checker> may be called immediately,
+even before this function has returned. C<*old_checker_p> will always
+be appropriately set before C<new_checker> is called. If C<new_checker>
decides not to do anything special with an op that it is given (which
is the usual case for most uses of op check hooking), it must chain the
-check function referenced by I<*old_checker_p>.
+check function referenced by C<*old_checker_p>.
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
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff