/* op.c
*
- * Copyright (c) 1991-2003, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define PERL_SLAB_SIZE 2048
#endif
-#define NewOp(m,var,c,type) \
- STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
-
-#define FreeOp(p) Slab_Free(p)
-
-STATIC void *
-S_Slab_Alloc(pTHX_ int m, size_t sz)
+void *
+Perl_Slab_Alloc(pTHX_ int m, size_t sz)
{
/*
* To make incrementing use count easy PL_OpSlab is an I32 *
return (void *)(PL_OpPtr + 1);
}
-STATIC void
-S_Slab_Free(pTHX_ void *op)
+void
+Perl_Slab_Free(pTHX_ void *op)
{
I32 **ptr = (I32 **) op;
I32 *slab = ptr[-1];
assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
assert( *slab > 0 );
if (--(*slab) == 0) {
- #ifdef NETWARE
- #define PerlMemShared PerlMem
- #endif
+# ifdef NETWARE
+# define PerlMemShared PerlMem
+# endif
PerlMemShared_free(slab);
if (slab == PL_OpSlab) {
}
}
}
-
-#else
-#define NewOp(m, var, c, type) Newz(m, var, c, type)
-#define FreeOp(p) Safefree(p)
#endif
/*
* In the following definition, the ", Nullop" is just to make the compiler
{
PADOFFSET off;
- /* complain about "my $_" etc etc */
+ /* complain about "my $<special_var>" etc etc */
if (!(PL_in_my == KEY_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
- (name[1] == '_' && (int)strlen(name) > 2)))
+ (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
{
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
/* 1999-02-27 mjd@plover.com */
/* check for duplicate declaration */
pad_check_dup(name,
- PL_in_my == KEY_our,
+ (bool)(PL_in_my == KEY_our),
(PL_curstash ? PL_curstash : PL_defstash)
);
register OP *kid, *nextkid;
OPCODE type;
- if (!o || o->op_seq == (U16)-1)
+ if (!o || o->op_static)
return;
if (o->op_private & OPpREFCOUNTED) {
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
+ if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
+ /* not an OP_PADAV replacement */
#ifdef USE_ITHREADS
- if (cPADOPo->op_padix > 0) {
- /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
- * may still exist on the pad */
- pad_swipe(cPADOPo->op_padix, TRUE);
- cPADOPo->op_padix = 0;
- }
+ if (cPADOPo->op_padix > 0) {
+ /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
+ * may still exist on the pad */
+ pad_swipe(cPADOPo->op_padix, TRUE);
+ cPADOPo->op_padix = 0;
+ }
#else
- SvREFCNT_dec(cSVOPo->op_sv);
- cSVOPo->op_sv = Nullsv;
+ SvREFCNT_dec(cSVOPo->op_sv);
+ cSVOPo->op_sv = Nullsv;
#endif
+ }
break;
case OP_METHOD_NAMED:
case OP_CONST:
#ifdef USE_ITHREADS
/** Bug #15654
Even if op_clear does a pad_free for the target of the op,
- pad_free doesn't actually remove the sv that exists in the bad
+ pad_free doesn't actually remove the sv that exists in the pad;
instead it lives on. This results in that it could be reused as
a target later on when the pad was reallocated.
**/
useless = OP_DESC(o);
break;
+ case OP_NOT:
+ kid = cUNOPo->op_first;
+ if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
+ kid->op_type != OP_TRANS) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
+
case OP_RV2GV:
case OP_RV2SV:
case OP_RV2AV:
else {
if (ckWARN(WARN_VOID)) {
useless = "a constant";
+ /* don't warn on optimised away booleans, eg
+ * use constant Foo, 5; Foo || print; */
+ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
+ useless = 0;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
- if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
+ else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
else if (SvPOK(sv)) {
/* perl4's way of mixing documentation and code
return o;
}
+/* Propagate lvalue ("modifiable") context to an op and it's children.
+ * 'type' represents the context type, roughly based on the type of op that
+ * would do the modifying, although local() is represented by OP_NULL.
+ * It's responsible for detecting things that can't be modified, flag
+ * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
+ * might have to vivify a reference in $x), and so on.
+ *
+ * For example, "$a+1 = 2" would cause mod() to be called with o being
+ * OP_ADD and type being OP_SASSIGN, and would output an error.
+ */
+
OP *
Perl_mod(pTHX_ OP *o, I32 type)
{
OP *kid;
+ /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
+ int localize = -1;
if (!o || PL_error_count)
return o;
switch (o->op_type) {
case OP_UNDEF:
+ localize = 0;
PL_modcount++;
return o;
case OP_CONST:
break;
case OP_COND_EXPR:
+ localize = 1;
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
mod(kid, type);
break;
case OP_HSLICE:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
+ localize = 1;
/* FALL THROUGH */
case OP_AASSIGN:
case OP_NEXTSTATE:
break;
case OP_RV2SV:
ref(cUNOPo->op_first, o->op_type);
+ localize = 1;
/* FALL THROUGH */
case OP_GV:
case OP_AV2ARYLEN:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
+ PL_modcount++;
+ break;
+
case OP_AELEMFAST:
+ localize = -1;
PL_modcount++;
break;
/* FALL THROUGH */
case OP_PADSV:
PL_modcount++;
- if (!type)
- { /* XXX DAPM 2002.08.25 tmp assert test */
- /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
- /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
-
+ if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %s",
PAD_COMPNAME_PV(o->op_targ));
- }
break;
case OP_PUSHMARK:
+ localize = 0;
break;
case OP_KEYS:
o->op_private |= OPpLVAL_DEFER;
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
+ localize = 1;
PL_modcount++;
break;
case OP_LEAVE:
case OP_ENTER:
case OP_LINESEQ:
+ localize = 0;
if (o->op_flags & OPf_KIDS)
mod(cLISTOPo->op_last, type);
break;
case OP_NULL:
+ localize = 0;
if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
goto nomod;
else if (!(o->op_flags & OPf_KIDS))
}
/* FALL THROUGH */
case OP_LIST:
+ localize = 0;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
mod(kid, type);
break;
if (type == OP_AASSIGN || type == OP_SASSIGN)
o->op_flags |= OPf_SPECIAL|OPf_REF;
- else if (!type) {
- o->op_private |= OPpLVAL_INTRO;
- o->op_flags &= ~OPf_SPECIAL;
- PL_hints |= HINT_BLOCK_SCOPE;
+ else if (!type) { /* local() */
+ switch (localize) {
+ case 1:
+ o->op_private |= OPpLVAL_INTRO;
+ o->op_flags &= ~OPf_SPECIAL;
+ PL_hints |= HINT_BLOCK_SCOPE;
+ break;
+ case 0:
+ break;
+ case -1:
+ if (ckWARN(WARN_SYNTAX)) {
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Useless localization of %s", OP_DESC(o));
+ }
+ }
}
else if (type != OP_GREPSTART && type != OP_ENTERSUB
&& type != OP_LEAVESUBLV)
Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
{
OP *o;
+ bool ismatchop = 0;
if (ckWARN(WARN_MISC) &&
(left->op_type == OP_RV2AV ||
no_bareword_allowed(right);
}
- if (!(right->op_flags & OPf_STACKED) &&
- (right->op_type == OP_MATCH ||
- right->op_type == OP_SUBST ||
- right->op_type == OP_TRANS)) {
+ ismatchop = right->op_type == OP_MATCH ||
+ right->op_type == OP_SUBST ||
+ right->op_type == OP_TRANS;
+ if (ismatchop && right->op_private & OPpTARGET_MY) {
+ right->op_targ = 0;
+ right->op_private &= ~OPpTARGET_MY;
+ }
+ if (!(right->op_flags & OPf_STACKED) && ismatchop) {
right->op_flags |= OPf_STACKED;
if (right->op_type != OP_MATCH &&
! (right->op_type == OP_TRANS &&
return o;
}
+/* XXX kept for BINCOMPAT only */
void
Perl_save_hints(pTHX)
{
- SAVEI32(PL_hints);
- SAVESPTR(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
- SAVEFREESV(GvHV(PL_hintgv));
+ Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
}
int
Perl_block_start(pTHX_ int full)
{
int retval = PL_savestack_ix;
- /* If there were syntax errors, don't try to start a block */
- if (PL_yynerrs) return retval;
-
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
{
int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
- /* If there were syntax errors, don't try to close a block */
- if (PL_yynerrs) return retval;
LEAVE_SCOPE(floor);
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
STATIC OP *
S_newDEFSVOP(pTHX)
{
- return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+ I32 offset = pad_findmy("$_");
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+ }
+ else {
+ OP *o = newOP(OP_PADSV, 0);
+ o->op_targ = offset;
+ return o;
+ }
}
void
CALL_PEEP(PL_eval_start);
}
else {
- if (o->op_type == OP_STUB)
+ if (o->op_type == OP_STUB) {
+ PL_comppad_name = 0;
+ PL_compcv = 0;
+ FreeOp(o);
return;
+ }
PL_main_root = scope(sawparens(scalarvoid(o)));
PL_curcop = &PL_compiling;
PL_main_start = LINKLIST(PL_main_root);
&& PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
{
char *s = PL_bufptr;
+ bool sigil = FALSE;
- while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
+ /* some heuristics to detect a potential error */
+ while (*s && (strchr(", \t\n", *s)))
s++;
- if (*s == ';' || *s == '=')
+ while (1) {
+ if (*s && strchr("@$%*", *s) && *++s
+ && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
+ s++;
+ sigil = TRUE;
+ while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
+ s++;
+ while (*s && (strchr(", \t\n", *s)))
+ s++;
+ }
+ else
+ break;
+ }
+ if (sigil && (*s == ';' || *s == '=')) {
Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
- "Parentheses missing around \"%s\" list",
- lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
+ "Parentheses missing around \"%s\" list",
+ lex ? (PL_in_my == KEY_our ? "our" : "my")
+ : "local");
+ }
}
}
if (lex)
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
- o->op_seq = 0; /* needs to be revisited in peep() */
+ 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 peep() */
curop = ((UNOP*)o)->op_first;
((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
op_free(curop);
listop->op_last = pushop;
}
- return (OP*)listop;
+ return CHECKOP(type, listop);
}
OP *
U8* tend = t + tlen;
U8* rend = r + rlen;
STRLEN ulen;
- U32 tfirst = 1;
- U32 tlast = 0;
- I32 tdiff;
- U32 rfirst = 1;
- U32 rlast = 0;
- I32 rdiff;
- I32 diff;
+ UV tfirst = 1;
+ UV tlast = 0;
+ IV tdiff;
+ UV rfirst = 1;
+ UV rlast = 0;
+ IV rdiff;
+ IV diff;
I32 none = 0;
U32 max = 0;
I32 bits;
PmopSTASH_set(pmop,PL_curstash);
}
- return (OP*)pmop;
+ return CHECKOP(type, pmop);
}
OP *
: OPf_KIDS);
rcop->op_private = 1;
rcop->op_other = o;
+ /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
+ PL_cv_has_eval = 1;
/* establish postfix order */
if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
OP *curop;
if (pm->op_pmflags & PMf_EVAL) {
curop = 0;
- if (CopLINE(PL_curcop) < PL_multi_end)
+ if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
CopLINE_set(PL_curcop, (line_t)PL_multi_end);
}
else if (repl->op_type == OP_CONST)
}
void
-Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
+Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
{
OP *pack;
OP *imop;
OP *veop;
- if (id->op_type != OP_CONST)
+ if (idop->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
veop = Nullop;
if (version->op_type != OP_CONST || !SvNIOKp(vesv))
Perl_croak(aTHX_ "Version number must be constant number");
- /* Make copy of id so we don't free it twice */
- pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+ /* Make copy of idop so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to VERSION */
meth = newSVpvn("VERSION",7);
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB)
imop = arg; /* no import on explicit () */
- else if (SvNIOKp(((SVOP*)id)->op_sv)) {
+ else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
imop = Nullop; /* use 5.0; */
}
else {
SV *meth;
- /* Make copy of id so we don't free it twice */
- pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+ /* Make copy of idop so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to import/unimport */
meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
Nullop,
append_elem(OP_LINESEQ,
append_elem(OP_LINESEQ,
- newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
+ newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_expect = XSTATE;
+ PL_cop_seqmax++; /* Purely for B::*'s benefit */
}
/*
op_free(right);
return Nullop;
}
+ /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
+ if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
+ && right->op_type == OP_STUB
+ && (left->op_private & OPpLVAL_INTRO))
+ {
+ op_free(right);
+ left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
+ return left;
+ }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
}
}
if (first->op_type == OP_CONST) {
- if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
- if (first->op_private & OPpCONST_STRICT)
- no_bareword_allowed(first);
- else
+ if (first->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(first);
+ else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
- }
- if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
+ if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
+ (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
+ (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
+ if (other->op_type == OP_CONST)
+ other->op_private |= OPpCONST_SHORTCIRCUIT;
return other;
}
else {
+ /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
+ OP *o2 = other;
+ if ( ! (o2->op_type == OP_LIST
+ && (( o2 = cUNOPx(o2)->op_first))
+ && o2->op_type == OP_PUSHMARK
+ && (( o2 = o2->op_sibling)) )
+ )
+ o2 = other;
+ if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
+ || o2->op_type == OP_PADHV)
+ && o2->op_private & OPpLVAL_INTRO
+ && ckWARN(WARN_DEPRECATED))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Deprecated use of my() in false conditional");
+ }
+
op_free(other);
*otherp = Nullop;
+ if (first->op_type == OP_CONST)
+ first->op_private |= OPpCONST_SHORTCIRCUIT;
return first;
}
}
- else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
+ else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
+ type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
+ {
OP *k1 = ((UNOP*)first)->op_first;
OP *k2 = k1->op_sibling;
OPCODE warnop = 0;
first->op_next = (OP*)logop;
first->op_sibling = other;
+ CHECKOP(type,logop);
+
o = newUNOP(OP_NULL, 0, (OP*)logop);
other->op_next = o;
logop->op_other = LINKLIST(trueop);
logop->op_next = LINKLIST(falseop);
+ CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
+ logop);
/* establish postfix order */
start = LINKLIST(first);
}
}
+ /* if block is null, the next append_elem() would put UNSTACK, a scalar
+ * op, in listop. This is wrong. [perl #27024] */
+ if (!block)
+ block = newOP(OP_NULL, 0);
listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
o = new_logop(OP_AND, 0, &expr, &listop);
if (!next)
next = unstack;
cont = append_elem(OP_LINESEQ, cont, unstack);
- if ((line_t)whileline != NOLINE) {
- PL_copline = (line_t)whileline;
- cont = append_elem(OP_LINESEQ, cont,
- newSTATEOP(0, Nullch, Nullop));
- }
}
listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
OP *wop;
PADOFFSET padoff = 0;
I32 iterflags = 0;
+ I32 iterpflags = 0;
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
+ iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
sv->op_type = OP_RV2GV;
sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
}
else if (sv->op_type == OP_PADSV) { /* private variable */
+ iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
padoff = sv->op_targ;
sv->op_targ = 0;
op_free(sv);
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
}
else {
- sv = newGVOP(OP_GV, 0, PL_defgv);
+ I32 offset = pad_findmy("$_");
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ sv = newGVOP(OP_GV, 0, PL_defgv);
+ }
+ else {
+ padoff = offset;
+ }
}
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
append_elem(OP_LIST, expr, scalar(sv))));
assert(!loop->op_next);
+ /* for my $x () sets OPpLVAL_INTRO;
+ * for our $x () sets OPpOUR_INTRO */
+ loop->op_private = (U8)iterpflags;
#ifdef PL_OP_SLAB_ALLOC
{
LOOP *tmp;
op_free(label);
}
else {
- if (label->op_type == OP_ENTERSUB)
+ /* Check whether it's going to be a goto &function */
+ if (label->op_type == OP_ENTERSUB
+ && !(label->op_flags & OPf_STACKED))
label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
o = newUNOP(type, OPf_STACKED, label);
}
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
if (SvPOK(cv))
Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
+ else
+ Perl_sv_catpvf(aTHX_ msg, ": none");
sv_catpv(msg, " vs ");
if (p)
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
return (SV*)CvXSUBANY(cv).any_ptr;
}
+/* op_const_sv: examine an optree to determine whether it's in-lineable.
+ * Can be called in 3 ways:
+ *
+ * !cv
+ * look for a single OP_CONST with attached value: return the value
+ *
+ * cv && CvCLONE(cv) && !CvCONST(cv)
+ *
+ * examine the clone prototype, and if contains only a single
+ * OP_CONST referencing a pad const, or a single PADSV referencing
+ * an outer lexical, return a non-zero value to indicate the CV is
+ * a candidate for "constizing" at clone time
+ *
+ * cv && CvCONST(cv)
+ *
+ * We have just cloned an anon prototype that was marked as a const
+ * candidiate. Try to grab the current value, and in the case of
+ * PADSV, ignore it if it has multiple references. Return the value.
+ */
+
SV *
Perl_op_const_sv(pTHX_ OP *o, CV *cv)
{
return Nullsv;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
- else if ((type == OP_PADSV || type == OP_CONST) && cv) {
+ else if (cv && type == OP_CONST) {
sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
if (!sv)
return Nullsv;
- if (CvCONST(cv)) {
- /* We get here only from cv_clone2() while creating a closure.
- Copy the const value here instead of in cv_clone2 so that
- SvREADONLY_on doesn't lead to problems when leaving
- scope.
- */
+ }
+ else if (cv && type == OP_PADSV) {
+ if (CvCONST(cv)) { /* newly cloned anon */
+ sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+ /* the candidate should have 1 ref from this pad and 1 ref
+ * from the parent */
+ if (!sv || SvREFCNT(sv) != 2)
+ return Nullsv;
sv = newSVsv(sv);
+ SvREADONLY_on(sv);
+ return sv;
+ }
+ else {
+ if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ sv = &PL_sv_undef; /* an arbitrary non-null value */
}
- if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
- return Nullsv;
}
- else
+ else {
return Nullsv;
+ }
}
- if (sv)
- SvREADONLY_on(sv);
return sv;
}
/* transfer PL_compcv to cv */
cv_undef(cv);
CvFLAGS(cv) = CvFLAGS(PL_compcv);
+ if (!CvWEAKOUTSIDE(cv))
+ SvREFCNT_dec(CvOUTSIDE(cv));
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
CvOUTSIDE(PL_compcv) = 0;
pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
/* ... before we throw it away */
SvREFCNT_dec(PL_compcv);
+ PL_compcv = cv;
if (PERLDB_INTER)/* Advice debugger on the new sub. */
++PL_sub_generation;
}
mod(scalarseq(block), OP_LEAVESUBLV));
}
else {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ op_free(block);
+ block = newSTATEOP(0, Nullch, 0);
+ }
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
CvROOT(cv)->op_private |= OPpREFCOUNTED;
CopSTASH_set(PL_curcop,stash);
}
- cv = newXS(name, const_sv_xsub, CopFILE(PL_curcop));
+ cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
sv_setpv((SV*)cv, ""); /* prototype is "" */
+ if (stash)
+ CopSTASH_free(PL_curcop);
+
LEAVE;
return cv;
(op) == OP_NE || (op) == OP_I_NE || \
(op) == OP_NCMP || (op) == OP_I_NCMP)
o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
- if (o->op_type == OP_BIT_OR
- || o->op_type == OP_BIT_AND
- || o->op_type == OP_BIT_XOR)
+ if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
+ && (o->op_type == OP_BIT_OR
+ || o->op_type == OP_BIT_AND
+ || o->op_type == OP_BIT_XOR))
{
- OPCODE typfirst = cBINOPo->op_first->op_type;
- OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
- if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
+ OP * left = cBINOPo->op_first;
+ OP * right = left->op_sibling;
+ if ((OP_IS_NUMCOMPARE(left->op_type) &&
+ (left->op_flags & OPf_PARENS) == 0) ||
+ (OP_IS_NUMCOMPARE(right->op_type) &&
+ (right->op_flags & OPf_PARENS) == 0))
if (ckWARN(WARN_PRECEDENCE))
Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
"Possible precedence problem on bitwise %c operator",
OP *
Perl_ck_concat(pTHX_ OP *o)
{
- if (cUNOPo->op_first->op_type == OP_CONCAT)
- o->op_flags |= OPf_STACKED;
+ OP *kid = cUNOPo->op_first;
+ if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
+ !(kUNOP->op_first->op_flags & OPf_MOD))
+ o->op_flags |= OPf_STACKED;
return o;
}
enter->op_other = o;
return o;
}
- else
+ else {
scalar((OP*)kid);
+ PL_cv_has_eval = 1;
+ }
}
else {
op_free(o);
gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
op_free(o);
o = newop;
+ return o;
+ }
+ else {
+ if ((PL_hints & HINT_FILETEST_ACCESS) &&
+ OP_IS_FILETEST_ACCESS(o))
+ o->op_private |= OPpFT_ACCESS;
}
+ if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
+ && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
+ o->op_private |= OPpFT_STACKED;
}
else {
op_free(o);
*/
priv = OPpDEREF;
if (kid->op_type == OP_PADSV) {
- /*XXX DAPM 2002.08.25 tmp assert test */
- /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
- /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
-
name = PAD_COMPNAME_PV(kid->op_targ);
/* SvCUR of a pad namesv can't be trusted
* (see PL_generation), so calc its length
}
if (tmpstr) {
- name = savepv(SvPVX(tmpstr));
- len = strlen(name);
+ name = SvPV(tmpstr, len);
sv_2mortal(tmpstr);
}
}
#if !defined(PERL_EXTERNAL_GLOB)
/* XXX this can be tightened up and made more failsafe. */
- if (!gv) {
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
GV *glob_gv;
ENTER;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
o->op_ppaddr = PL_ppaddr[OP_LIST];
cLISTOPo->op_first->op_type = OP_PUSHMARK;
cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
+ cLISTOPo->op_first->op_targ = 0;
o = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, o,
scalar(newUNOP(OP_RV2CV, 0,
LOGOP *gwop;
OP *kid;
OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
+ I32 offset;
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
NewOp(1101, gwop, 1, LOGOP);
OP* k;
o = ck_sort(o);
kid = cLISTOPo->op_first->op_sibling;
- for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
+ for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
kid = k;
}
kid->op_next = (OP*)gwop;
gwop->op_ppaddr = PL_ppaddr[type];
gwop->op_first = listkids(o);
gwop->op_flags |= OPf_KIDS;
- gwop->op_private = 1;
gwop->op_other = LINKLIST(kid);
- gwop->op_targ = pad_alloc(type, SVs_PADTMP);
kid->op_next = (OP*)gwop;
+ offset = pad_findmy("$_");
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ 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;
+ }
kid = cLISTOPo->op_first->op_sibling;
if (!kid || !kid->op_sibling)
return kid;
}
}
+ /* optimise C<my $x = undef> to C<my $x> */
+ if (kid->op_type == OP_UNDEF) {
+ OP *kkid = kid->op_sibling;
+ if (kkid && kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO))
+ {
+ cLISTOPo->op_first = NULL;
+ kid->op_sibling = NULL;
+ op_free(o);
+ op_free(kid);
+ return kkid;
+ }
+ }
return o;
}
OP *
Perl_ck_match(pTHX_ OP *o)
{
- o->op_private |= OPpRUNTIME;
+ if (o->op_type != OP_QR) {
+ I32 offset = pad_findmy("$_");
+ if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
+ 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;
}
}
if (o->op_type == OP_BACKTICK)
return o;
+ {
+ /* In case of three-arg dup open remove strictness
+ * from the last arg if it is a bareword. */
+ OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
+ OP *last = cLISTOPx(o)->op_last; /* The bareword. */
+ OP *oa;
+ char *mode;
+
+ if ((last->op_type == OP_CONST) && /* The bareword. */
+ (last->op_private & OPpCONST_BARE) &&
+ (last->op_private & OPpCONST_STRICT) &&
+ (oa = first->op_sibling) && /* The fh. */
+ (oa = oa->op_sibling) && /* The mode. */
+ SvPOK(((SVOP*)oa)->op_sv) &&
+ (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
+ mode[0] == '>' && mode[1] == '&' && /* A dup open. */
+ (last == oa->op_sibling)) /* The bareword. */
+ last->op_private &= ~OPpCONST_STRICT;
+ }
return ck_fun(o);
}
}
OP *
+Perl_ck_unpack(pTHX_ OP *o)
+{
+ OP *kid = cLISTOPo->op_first;
+ if (kid->op_sibling) {
+ kid = kid->op_sibling;
+ if (!kid->op_sibling)
+ kid->op_sibling = newDEFSVOP();
+ }
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_substr(pTHX_ OP *o)
{
o = ck_fun(o);
{
register OP* oldop = 0;
- if (!o || o->op_seq)
+ if (!o || o->op_opt)
return;
ENTER;
SAVEOP();
SAVEVPTR(PL_curcop);
for (; o; o = o->op_next) {
- if (o->op_seq)
+ if (o->op_opt)
break;
- /* The special value -1 is used by the B::C compiler backend to indicate
- * that an op is statically defined and should not be freed */
- if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
- PL_op_seqmax = 1;
PL_op = o;
switch (o->op_type) {
case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
case OP_CONST:
o->op_targ = ix;
}
#endif
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
case OP_CONCAT:
op_null(o->op_next);
}
ignore_optimization:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
case OP_STUB:
if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break; /* Scalar stub must produce undef. List stub is noop */
}
goto nothin;
to peep() from mistakenly concluding that optimisation
has already occurred. This doesn't fix the real problem,
though (See 20010220.007). AMS 20010719 */
+ /* op_seq functionality is now replaced by op_opt */
if (oldop && o->op_next) {
oldop->op_next = o->op_next;
continue;
oldop->op_next = o->op_next;
continue;
}
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
+ case OP_PADAV:
case OP_GV:
- if (o->op_next->op_type == OP_RV2SV) {
- if (!(o->op_next->op_private & OPpDEREF)) {
- op_null(o->op_next);
- o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
- | OPpOUR_INTRO);
- o->op_next = o->op_next->op_next;
- o->op_type = OP_GVSV;
- o->op_ppaddr = PL_ppaddr[OP_GVSV];
- }
- }
- else if (o->op_next->op_type == OP_RV2AV) {
- OP* pop = o->op_next->op_next;
+ if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
+ OP* pop = (o->op_type == OP_PADAV) ?
+ o->op_next : o->op_next->op_next;
IV i;
if (pop && pop->op_type == OP_CONST &&
- (PL_op = pop->op_next) &&
+ ((PL_op = pop->op_next)) &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
i >= 0)
{
GV *gv;
- op_null(o->op_next);
+ if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(pop);
+ if (o->op_type == OP_GV)
+ op_null(o->op_next);
op_null(pop->op_next);
op_null(pop);
o->op_flags |= pop->op_next->op_flags & OPf_MOD;
o->op_next = pop->op_next->op_next;
- o->op_type = OP_AELEMFAST;
o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
o->op_private = (U8)i;
- gv = cGVOPo_gv;
- GvAVn(gv);
+ if (o->op_type == OP_GV) {
+ gv = cGVOPo_gv;
+ GvAVn(gv);
+ }
+ else
+ o->op_flags |= OPf_SPECIAL;
+ o->op_type = OP_AELEMFAST;
+ }
+ o->op_opt = 1;
+ break;
+ }
+
+ if (o->op_next->op_type == OP_RV2SV) {
+ if (!(o->op_next->op_private & OPpDEREF)) {
+ op_null(o->op_next);
+ o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
+ | OPpOUR_INTRO);
+ o->op_next = o->op_next->op_next;
+ o->op_type = OP_GVSV;
+ o->op_ppaddr = PL_ppaddr[OP_GVSV];
}
}
else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
op_null(o->op_next);
}
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
case OP_MAPWHILE:
case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
case OP_ENTERLOOP:
case OP_ENTERITER:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
while (cLOOP->op_redoop->op_type == OP_NULL)
cLOOP->op_redoop = cLOOP->op_redoop->op_next;
peep(cLOOP->op_redoop);
case OP_QR:
case OP_MATCH:
case OP_SUBST:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
while (cPMOP->op_pmreplstart &&
cPMOP->op_pmreplstart->op_type == OP_NULL)
cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
break;
case OP_EXEC:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
if (ckWARN(WARN_SYNTAX) && o->op_next
&& o->op_next->op_type == OP_NEXTSTATE) {
if (o->op_next->op_sibling &&
char *key = NULL;
STRLEN keylen;
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
if (((BINOP*)o)->op_last->op_type != OP_CONST)
break;
break;
}
+ case OP_SORT: {
+ /* make @a = sort @a act in-place */
+
+ /* will point to RV2AV or PADAV op on LHS/RHS of assign */
+ OP *oleft, *oright;
+ OP *o2;
+
+ o->op_opt = 1;
+
+ /* check that RHS of sort is a single plain array */
+ oright = cUNOPo->op_first;
+ if (!oright || oright->op_type != OP_PUSHMARK)
+ break;
+ oright = cUNOPx(oright)->op_sibling;
+ if (!oright)
+ break;
+ if (oright->op_type == OP_NULL) { /* skip sort block/sub */
+ oright = cUNOPx(oright)->op_sibling;
+ }
+
+ if (!oright ||
+ (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
+ || oright->op_next != o
+ || (oright->op_private & OPpLVAL_INTRO)
+ )
+ break;
+
+ /* o2 follows the chain of op_nexts through the LHS of the
+ * assign (if any) to the aassign op itself */
+ o2 = o->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ break;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ break;
+ o2 = o2->op_next;
+ if (o2 && o2->op_type == OP_GV)
+ o2 = o2->op_next;
+ if (!o2
+ || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
+ || (o2->op_private & OPpLVAL_INTRO)
+ )
+ break;
+ oleft = o2;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ break;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_AASSIGN
+ || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
+ break;
+
+ /* check that the sort is the first arg on RHS of assign */
+
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_NULL)
+ break;
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ break;
+ if (o2->op_sibling != o)
+ break;
+
+ /* check the array is the same on both sides */
+ if (oleft->op_type == OP_RV2AV) {
+ if (oright->op_type != OP_RV2AV
+ || !cUNOPx(oright)->op_first
+ || cUNOPx(oright)->op_first->op_type != OP_GV
+ || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+ cGVOPx_gv(cUNOPx(oright)->op_first)
+ )
+ break;
+ }
+ else if (oright->op_type != OP_PADAV
+ || oright->op_targ != oleft->op_targ
+ )
+ break;
+
+ /* transfer MODishness etc from LHS arg to RHS arg */
+ oright->op_flags = oleft->op_flags;
+ o->op_private |= OPpSORT_INPLACE;
+
+ /* excise push->gv->rv2av->null->aassign */
+ o2 = o->op_next->op_next;
+ op_null(o2); /* PUSHMARK */
+ o2 = o2->op_next;
+ if (o2->op_type == OP_GV) {
+ op_null(o2); /* GV */
+ o2 = o2->op_next;
+ }
+ op_null(o2); /* RV2AV or PADAV */
+ o2 = o2->op_next->op_next;
+ op_null(o2); /* AASSIGN */
+
+ o->op_next = o2->op_next;
+
+ break;
+ }
+
+
+
default:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
}
oldop = o;
https://perl5.git.perl.org / perl5.git / blobdiff