!(is_our ||
isALPHA(name[1]) ||
((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
- (name[1] == '_' && (*name == '$' || len > 2))))
+ (name[1] == '_' && len > 2)))
{
if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
&& isASCII(name[1])
PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
}
}
- else if (len == 2 && name[1] == '_' && !is_our)
- /* diag_listed_as: Use of my $_ is experimental */
- Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
- "Use of %s $_ is experimental",
- PL_parser->in_my == KEY_state
- ? "state"
- : "my");
/* allocate a spare slot and store the name in that slot */
type = o->op_type;
/* an op should only ever acquire op_private flags that we know about.
- * If this fails, you may need to fix something in regen/op_private */
- if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
+ * If this fails, you may need to fix something in regen/op_private.
+ * Don't bother testing if:
+ * * the op_ppaddr doesn't match the op; someone may have
+ * overridden the op and be doing strange things with it;
+ * * we've errored, as op flags are often left in an
+ * inconsistent state then. Note that an error when
+ * compiling the main program leaves PL_parser NULL, so
+ * we can't spot faults in the main code, only
+ * evaled/required code */
+#ifdef DEBUGGING
+ if ( o->op_ppaddr == PL_ppaddr[o->op_type]
+ && PL_parser
+ && !PL_parser->error_count)
+ {
assert(!(o->op_private & ~PL_op_private_valid[type]));
}
+#endif
if (o->op_private & OPpREFCOUNTED) {
switch (type) {
/* S_op_clear_gv(): free a GV attached to an OP */
+STATIC
#ifdef USE_ITHREADS
void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
#else
void
Perl_op_refcnt_lock(pTHX)
+ PERL_TSA_ACQUIRE(PL_op_mutex)
{
#ifdef USE_ITHREADS
dVAR;
void
Perl_op_refcnt_unlock(pTHX)
+ PERL_TSA_RELEASE(PL_op_mutex)
{
#ifdef USE_ITHREADS
dVAR;
=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
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. It may passed as NULL if
+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:
For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
-see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>.
+see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
=cut
*/
/*
=for apidoc op_parent
-Returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+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
* Returns the new UNOP.
*/
-OP *
+STATIC OP *
S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
{
OP *kid, *newop;
* being spread throughout this file.
*/
-LOGOP *
+STATIC LOGOP *
S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
dVAR;
* key_op is the first key
*/
-void
+STATIC void
S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
{
PADNAME *lexname;
continue;
svp = cSVOPx_svp(key_op);
+ /* make sure it's not a bareword under strict subs */
+ if (key_op->op_private & OPpCONST_BARE &&
+ key_op->op_private & OPpCONST_STRICT)
+ {
+ no_bareword_allowed((OP*)key_op);
+ }
+
/* Make the CONST have a shared SV */
if ( !SvIsCOW_shared_hash(sv = *svp)
&& SvTYPE(sv) < SVt_PVMG
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
Propagate lvalue ("modifiable") context to an op and its children.
C<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,
+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>.
OP *kid = cUNOPo->op_first;
CV *cv;
GV *gv;
+ SV *namesv;
if (kid->op_type != OP_PUSHMARK) {
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
break;
if (CvLVALUE(cv))
break;
+ if (flags & OP_LVALUE_NO_CROAK)
+ return NULL;
+
+ namesv = cv_name(cv, NULL, 0);
+ yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
+ "subroutine call of &%"SVf" in %s",
+ SVfARG(namesv), PL_op_desc[type]),
+ SvUTF8(namesv));
+ return o;
}
}
/* FALLTHROUGH */
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
? "do block"
- : (o->op_type == OP_ENTERSUB
- ? "non-lvalue subroutine call"
- : OP_DESC(o))),
+ : OP_DESC(o)),
type ? PL_op_desc[type] : "local"));
return o;
((PL_in_eval & EVAL_KEEPERR)
? OPf_SPECIAL : 0), o);
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_EVAL);
if ((cx->blk_gimme & G_WANT) == G_VOID)
s++;
while (1) {
- if (*s && strchr("@$%*", *s) && *++s
+ if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
+ && *++s
&& (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
s++;
sigil = TRUE;
bool is_stringify;
SV * VOL sv = NULL;
int ret = 0;
- I32 oldscope;
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
COP not_compiling;
U8 oldwarn = PL_dowarn;
+ I32 old_cxix;
dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
o->op_next = 0;
PL_op = curop;
- oldscope = PL_scopestack_ix;
- create_eval_scope(G_FAKINGEVAL);
+ old_cxix = cxstack_ix;
+ create_eval_scope(NULL, G_FAKINGEVAL);
/* Verify that we don't need to save it: */
assert(PL_curcop == &PL_compiling);
PL_diehook = olddiehook;
PL_curcop = &PL_compiling;
- if (PL_scopestack_ix > oldscope)
- delete_eval_scope();
-
+ /* if we croaked, depending on how we croaked the eval scope
+ * may or may not have already been popped */
+ if (cxstack_ix > old_cxix) {
+ assert(cxstack_ix == old_cxix + 1);
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ delete_eval_scope();
+ }
if (ret)
goto nope;
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.
/*
=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
*/
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
*/
C<op_flags>, and, shifted up eight bits, the eight bits of
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
*/
}
}
- /* 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;
max = rfirst + diff;
if (!grows)
grows = (tfirst < rfirst &&
- UNISKIP(tfirst) < UNISKIP(rfirst + diff));
+ UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
rfirst += diff + 1;
}
tfirst += diff + 1;
/*
=for apidoc Am|OP *|newDEFSVOP|
-Constructs and returns an op to access C<$_>, either as a lexical
-variable (if declared as C<my $_>) in the current scope, or the
-global C<$_>.
+Constructs and returns an op to access C<$_>.
=cut
*/
OP *
Perl_newDEFSVOP(pTHX)
{
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
- }
- else {
- OP * const o = newOP(OP_PADSV, 0);
- o->op_targ = offset;
- return o;
- }
}
#ifdef USE_ITHREADS
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.
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
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
o->op_flags |= flags;
o = op_scope(o);
- o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
+ o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
return o;
}
with structure that allows exiting the loop by C<last> and suchlike.
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).
+item in turn; if null, it defaults to C<$_>.
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
}
}
else {
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
- sv = newGVOP(OP_GV, 0, PL_defgv);
- }
- else {
- padoff = offset;
- }
+ sv = newGVOP(OP_GV, 0, PL_defgv);
iterpflags |= OPpITER_DEF;
}
OP *o;
PERL_ARGS_ASSERT_NEWGIVWHENOP;
+ PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
- enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
+ enterop->op_targ = 0;
enterop->op_private = 0;
o = newUNOP(leave_opcode, 0, (OP *) enterop);
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.
-C<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> must be zero (it used to identity the pad slot of lexical $_).
=cut
*/
Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
{
PERL_ARGS_ASSERT_NEWGIVENOP;
+ PERL_UNUSED_ARG(defsv_off);
+
+ assert(!defsv_off);
return newGIVWHENOP(
ref_array_or_hash(cond),
block,
OP_ENTERGIVEN, OP_LEAVEGIVEN,
- defsv_off);
+ 0);
}
/*
=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">.
: NULL;
if (block) {
+ assert(PL_parser);
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
const line_t l = PL_parser->copline;
block->op_next = 0;
if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
const_sv =
- S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
+ S_op_const_sv(aTHX_ start, PL_compcv,
+ cBOOL(CvCLONE(PL_compcv)));
else
const_sv = NULL;
}
const_sv = NULL;
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
- assert (block);
cv_ckproto_len_flags((const CV *)gv,
o ? (const GV *)cSVOPo->op_sv : NULL, ps,
ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
/*
=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.)
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);
op_free(o);
return newop;
}
+ scalar((OP *) kid);
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
if (type != OP_STAT && type != OP_LSTAT
LOGOP *gwop;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
- PADOFFSET offset;
PERL_ARGS_ASSERT_CK_GREP;
gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
kid->op_next = (OP*)gwop;
- offset = pad_findmy_pvs("$_", 0);
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
- o->op_private = gwop->op_private = 0;
- gwop->op_targ = pad_alloc(type, SVs_PADTMP);
- }
- else {
- o->op_private = gwop->op_private = OPpGREP_LEX;
- gwop->op_targ = o->op_targ = offset;
- }
+ o->op_private = gwop->op_private = 0;
+ gwop->op_targ = pad_alloc(type, SVs_PADTMP);
kid = OpSIBLING(cLISTOPo->op_first);
for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
OP *
Perl_ck_match(pTHX_ OP *o)
{
+ PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_CK_MATCH;
- if (o->op_type != OP_QR && PL_compcv) {
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
- o->op_targ = offset;
- o->op_private |= OPpTARGET_MY;
- }
- }
if (o->op_type == OP_MATCH || o->op_type == OP_QR)
o->op_private |= OPpRUNTIME;
return o;
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;
/* 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. */
}
case OP_AELEM:
case OP_HELEM:
+ o->op_private |= (varop->op_private & OPpLVAL_INTRO);
o->op_private |= OPpLVREF_ELEM;
op_null(varop);
stacked = TRUE;
Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
{
OP *aop;
+
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
+
aop = cUNOPx(entersubop)->op_first;
if (!OpHAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
+ /* skip the extra attributes->import() call implicitly added in
+ * something like foo(my $x : bar)
+ */
+ if ( aop->op_type == OP_ENTERSUB
+ && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ )
+ continue;
list(aop);
op_lvalue(aop, OP_ENTERSUB);
}
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;
+ flags = AAS_DANGEROUS;
+ break;
+ }
+
+ 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 */
* OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
*/
-void
+STATIC void
S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
{
dVAR;
}
redo:
+
+ /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
+ assert(!oldoldop || oldoldop->op_next == oldop);
+ assert(!oldop || oldop->op_next == o);
+
/* By default, this op has now been optimised. A couple of cases below
clear this again. */
o->op_opt = 1;
op_null(o);
if (oldop)
oldop->op_next = nextop;
+ o = nextop;
/* Skip (old)oldop assignment since the current oldop's
op_next already points to the next op. */
- continue;
+ goto redo;
}
}
break;
break;
/* there's a biggest base we can fit into a
- * SAVEt_CLEARPADRANGE in pp_padrange */
- if (intro && base >
- (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
+ * SAVEt_CLEARPADRANGE in pp_padrange.
+ * (The sizeof() stuff will be constant-folded, and is
+ * intended to avoid getting "comparison is always false"
+ * compiler warnings)
+ */
+ if ( intro
+ && (8*sizeof(base) >
+ 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
+ ? base : 0) >
+ (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
+ )
break;
/* Success! We've got another valid pad op to optimise away */
oldoldop = NULL;
goto redo;
}
- o = oldop;
+ o = oldop->op_next;
+ goto redo;
}
else if (o->op_next->op_type == OP_RV2SV) {
if (!(o->op_next->op_private & OPpDEREF)) {
op_null(o);
enter->op_private |= OPpITER_REVERSED;
iter->op_private |= OPpITER_REVERSED;
+
+ oldoldop = NULL;
+ oldop = ourlast;
+ o = oldop->op_next;
+ goto redo;
break;
}
}
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.
}
}
}
- /* Some gcc releases emit a warning for this function:
+ /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
* op.c: In function 'Perl_custom_op_get_field':
* op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
- * Whether this is true, is currently unknown. */
+ * This is because on those platforms (with -DEBUGGING) NOT_REACHED
+ * expands to assert(0), which expands to ((0) ? (void)0 :
+ * __assert(...)), and gcc doesn't know that __assert can never return. */
return any;
}
}
=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