* either way, as the saying is, if you follow me." --the Gaffer
*/
+/* This file contains the functions that create, manipulate and optimize
+ * the OP structures that hold a compiled perl program.
+ *
+ * A Perl program is compiled into a tree of OPs. Each op contains
+ * structural pointers (eg to its siblings and the next op in the
+ * execution sequence), a pointer to the function that would execute the
+ * op, plus any data specific to that op. For example, an OP_CONST op
+ * points to the pp_const() function and to an SV containing the constant
+ * value. When pp_const() is executed, its job is to push that SV onto the
+ * stack.
+ *
+ * OPs are mainly created by the newFOO() functions, which are mainly
+ * called from the parser (in perly.y) as the code is parsed. For example
+ * the Perl code $a + $b * $c would cause the equivalent of the following
+ * to be called (oversimplifying a bit):
+ *
+ * newBINOP(OP_ADD, flags,
+ * newSVREF($a),
+ * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
+ * )
+ *
+ * Note that during the build of miniperl, a temporary copy of this file
+ * is made, called opmini.c.
+ */
+
+/*
+Perl's compiler is essentially a 3-pass compiler with interleaved phases:
+
+ A bottom-up pass
+ A top-down pass
+ An execution-order pass
+
+The bottom-up pass is represented by all the "newOP" routines and
+the ck_ routines. The bottom-upness is actually driven by yacc.
+So at the point that a ck_ routine fires, we have no idea what the
+context is, either upward in the syntax tree, or either forward or
+backward in the execution order. (The bottom-up parser builds that
+part of the execution order it knows about, but if you follow the "next"
+links around, you'll find it's actually a closed loop through the
+top level node.
+
+Whenever the bottom-up parser gets to a node that supplies context to
+its components, it invokes that portion of the top-down pass that applies
+to that part of the subtree (and marks the top node as processed, so
+if a node further up supplies context, it doesn't have to take the
+plunge again). As a particular subcase of this, as the new node is
+built, it takes all the closed execution loops of its subcomponents
+and links them into a new closed loop for the higher level node. But
+it's still not the real execution order.
+
+The actual execution order is not known till we get a grammar reduction
+to a top-level unit like a subroutine or file that will be called by
+"name" rather than via a "next" pointer. At that point, we can call
+into peep() to do that code's portion of the 3rd pass. It has to be
+recursive, but it's recursive on basic blocks, not on tree nodes.
+*/
#include "EXTERN.h"
#define PERL_IN_OP_C
off = pad_add_name(name,
PL_in_my_stash,
(PL_in_my == KEY_our
- ? (PL_curstash ? PL_curstash : PL_defstash)
+ /* $_ is always in main::, even with our */
+ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: Nullhv
),
0 /* not fake */
{
register OP *kid, *nextkid;
OPCODE type;
+ PADOFFSET refcnt;
if (!o || o->op_static)
return;
case OP_SCOPE:
case OP_LEAVEWRITE:
OP_REFCNT_LOCK;
- if (OpREFCNT_dec(o)) {
- OP_REFCNT_UNLOCK;
- return;
- }
+ refcnt = OpREFCNT_dec(o);
OP_REFCNT_UNLOCK;
+ if (refcnt)
+ return;
break;
default:
break;
o->op_ppaddr = PL_ppaddr[OP_NULL];
}
+void
+Perl_op_refcnt_lock(pTHX)
+{
+ OP_REFCNT_LOCK;
+}
+
+void
+Perl_op_refcnt_unlock(pTHX)
+{
+ OP_REFCNT_UNLOCK;
+}
+
/* Contextualizers */
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
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
return bind_match(type, left,
- pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
+ pmruntime(newPMOP(OP_MATCH, 0), right, 0));
}
OP *
return CHECKOP(type, pmop);
}
+/* Given some sort of match op o, and an expression expr containing a
+ * pattern, either compile expr into a regex and attach it to o (if it's
+ * constant), or convert expr into a runtime regcomp op sequence (if it's
+ * not)
+ *
+ * isreg indicates that the pattern is part of a regex construct, eg
+ * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
+ * split "pattern", which aren't. In the former case, expr will be a list
+ * if the pattern contains more than one term (eg /a$b/) or if it contains
+ * a replacement, ie s/// or tr///.
+ */
+
OP *
-Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
+Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
{
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
+ OP* repl = Nullop;
+ bool reglist;
+
+ if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
+ /* last element in list is the replacement; pop it */
+ OP* kid;
+ repl = cLISTOPx(expr)->op_last;
+ kid = cLISTOPx(expr)->op_first;
+ while (kid->op_sibling != repl)
+ kid = kid->op_sibling;
+ kid->op_sibling = Nullop;
+ cLISTOPx(expr)->op_last = kid;
+ }
+
+ if (isreg && expr->op_type == OP_LIST &&
+ cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
+ {
+ /* convert single element list to element */
+ OP* oe = expr;
+ expr = cLISTOPx(oe)->op_first->op_sibling;
+ cLISTOPx(oe)->op_first->op_sibling = Nullop;
+ cLISTOPx(oe)->op_last = Nullop;
+ op_free(oe);
+ }
- if (o->op_type == OP_TRANS)
+ if (o->op_type == OP_TRANS) {
return pmtrans(o, expr, repl);
+ }
+
+ reglist = isreg && expr->op_type == OP_LIST;
+ if (reglist)
+ op_null(expr);
PL_hints |= HINT_BLOCK_SCOPE;
pm = (PMOP*)o;
rcop->op_type = OP_REGCOMP;
rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
rcop->op_first = scalar(expr);
- rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
- ? (OPf_SPECIAL | OPf_KIDS)
- : OPf_KIDS);
+ rcop->op_flags |= OPf_KIDS
+ | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
+ | (reglist ? OPf_STACKED : 0);
rcop->op_private = 1;
rcop->op_other = o;
+ if (reglist)
+ rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
+
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
PL_cv_has_eval = 1;
&& (left->op_private & OPpLVAL_INTRO))
{
op_free(right);
+ left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
return left;
}
curop = list(force_list(left));
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;
- other->op_private |= OPpCONST_SHORTCIRCUIT;
+ if (other->op_type == OP_CONST)
+ other->op_private |= OPpCONST_SHORTCIRCUIT;
return other;
}
else {
op_free(other);
*otherp = Nullop;
- first->op_private |= OPpCONST_SHORTCIRCUIT;
+ if (first->op_type == OP_CONST)
+ first->op_private |= OPpCONST_SHORTCIRCUIT;
return first;
}
}
char *name;
char *aname;
GV *gv;
- char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
+ char *ps;
register CV *cv=0;
SV *const_sv;
name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+
+ if (proto) {
+ assert(proto->op_type == OP_CONST);
+ ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
+ }
+ else
+ ps = Nullch;
+
if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV *sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
return newUNOP(OP_RV2SV, 0, scalar(o));
}
-/* Check routines. */
+/* Check routines. See the comments at the top of this file for details
+ * on when these are called */
OP *
Perl_ck_anoncode(pTHX_ OP *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* 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;
{
register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
- int reversed;
+ int descending;
GV *gv;
if (!(o->op_flags & OPf_STACKED))
return;
if (GvSTASH(gv) != PL_curstash)
return;
if (strEQ(GvNAME(gv), "a"))
- reversed = 0;
+ descending = 0;
else if (strEQ(GvNAME(gv), "b"))
- reversed = 1;
+ descending = 1;
else
return;
+
kid = k; /* back to cmp */
if (kBINOP->op_last->op_type != OP_RV2SV)
return;
kid = kUNOP->op_first; /* get past rv2sv */
gv = kGVOP_gv;
if (GvSTASH(gv) != PL_curstash
- || ( reversed
+ || ( descending
? strNE(GvNAME(gv), "a")
: strNE(GvNAME(gv), "b")))
return;
o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
- if (reversed)
- o->op_private |= OPpSORT_REVERSE;
+ if (descending)
+ o->op_private |= OPpSORT_DESCEND;
if (k->op_type == OP_NCMP)
o->op_private |= OPpSORT_NUMERIC;
if (k->op_type == OP_I_NCMP)
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
OP *sibl = kid->op_sibling;
kid->op_sibling = 0;
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
if (cLISTOPo->op_first == cLISTOPo->op_last)
cLISTOPo->op_last = kid;
cLISTOPo->op_first = kid;
OP *sibling = o2->op_sibling;
SV *n = newSVpvn("",0);
op_free(o2);
- gv_fullname3(n, gv, "");
- if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
- sv_chop(n, SvPVX(n)+6);
+ gv_fullname4(n, gv, "", FALSE);
o2 = newSVOP(OP_CONST, 0, n);
prev->op_sibling = o2;
o2->op_sibling = sibling;
return o;
}
-/* A peephole optimizer. We visit the ops in the order they're to execute. */
+/* A peephole optimizer. We visit the ops in the order they're to execute.
+ * See the comments at the top of this file for more details about when
+ * peep() is called */
void
Perl_peep(pTHX_ register OP *o)
break;
case OP_HELEM: {
+ UNOP *rop;
SV *lexname;
+ GV **fields;
SV **svp, *sv;
char *key = NULL;
STRLEN keylen;
SvREFCNT_dec(sv);
*svp = lexname;
}
+
+ if ((o->op_private & (OPpLVAL_INTRO)))
+ break;
+
+ rop = (UNOP*)((BINOP*)o)->op_first;
+ if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+ break;
+ lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
+ if (!(SvFLAGS(lexname) & SVpad_TYPED))
+ break;
+ fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ key = SvPV(*svp, keylen);
+ if (!hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ {
+ Perl_croak(aTHX_ "No such class field \"%s\" "
+ "in variable %s of type %s",
+ key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+ }
+
break;
}
- case OP_SORT: {
- /* make @a = sort @a act in-place */
+ case OP_HSLICE: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp;
+ char *key;
+ STRLEN keylen;
+ SVOP *first_key_op, *key_op;
+
+ if ((o->op_private & (OPpLVAL_INTRO))
+ /* I bet there's always a pushmark... */
+ || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
+ /* hmmm, no optimization if list contains only one key. */
+ break;
+ rop = (UNOP*)((LISTOP*)o)->op_last;
+ if (rop->op_type != OP_RV2HV)
+ break;
+ if (rop->op_first->op_type == OP_PADSV)
+ /* @$hash{qw(keys here)} */
+ rop = (UNOP*)rop->op_first;
+ else {
+ /* @{$hash}{qw(keys here)} */
+ if (rop->op_first->op_type == OP_SCOPE
+ && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
+ {
+ rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
+ }
+ else
+ break;
+ }
+
+ lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
+ if (!(SvFLAGS(lexname) & SVpad_TYPED))
+ break;
+ fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ /* Again guessing that the pushmark can be jumped over.... */
+ first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
+ ->op_first->op_sibling;
+ for (key_op = first_key_op; key_op;
+ key_op = (SVOP*)key_op->op_sibling) {
+ if (key_op->op_type != OP_CONST)
+ continue;
+ svp = cSVOPx_svp(key_op);
+ key = SvPV(*svp, keylen);
+ if (!hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ {
+ Perl_croak(aTHX_ "No such class field \"%s\" "
+ "in variable %s of type %s",
+ key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+ }
+ }
+ break;
+ }
+ case OP_SORT: {
/* 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;
+
+ /* reverse sort ... can be optimised. */
+ if (!cUNOPo->op_sibling) {
+ /* Nothing follows us on the list. */
+ OP *reverse = o->op_next;
+
+ if (reverse->op_type == OP_REVERSE &&
+ (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
+ OP *pushmark = cUNOPx(reverse)->op_first;
+ if (pushmark && (pushmark->op_type == OP_PUSHMARK)
+ && (cUNOPx(pushmark)->op_sibling == o)) {
+ /* reverse -> pushmark -> sort */
+ o->op_private |= OPpSORT_REVERSE;
+ op_null(reverse);
+ pushmark->op_next = oright->op_next;
+ op_null(oright);
+ }
+ }
+ }
+
+ /* make @a = sort @a act in-place */
+
+ o->op_opt = 1;
+
oright = cUNOPx(oright)->op_sibling;
if (!oright)
break;
|| (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
break;
}
-
+ case OP_REVERSE: {
+ OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
+ OP *gvop = NULL;
+ LISTOP *enter, *exlist;
+ o->op_opt = 1;
+ enter = (LISTOP *) o->op_next;
+ if (!enter)
+ break;
+ if (enter->op_type == OP_NULL) {
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ }
+ /* for $a (...) will have OP_GV then OP_RV2GV here.
+ for (...) just has an OP_GV. */
+ if (enter->op_type == OP_GV) {
+ gvop = (OP *) enter;
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ if (enter->op_type == OP_RV2GV) {
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ }
+ }
+
+ if (enter->op_type != OP_ENTERITER)
+ break;
+
+ iter = enter->op_next;
+ if (!iter || iter->op_type != OP_ITER)
+ break;
+
+ expushmark = enter->op_first;
+ if (!expushmark || expushmark->op_type != OP_NULL
+ || expushmark->op_targ != OP_PUSHMARK)
+ break;
+
+ exlist = (LISTOP *) expushmark->op_sibling;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_last != o) {
+ /* Mmm. Was expecting to point back to this op. */
+ break;
+ }
+ theirmark = exlist->op_first;
+ if (!theirmark || theirmark->op_type != OP_PUSHMARK)
+ break;
+
+ if (theirmark->op_sibling != o) {
+ /* There's something between the mark and the reverse, eg
+ for (1, reverse (...))
+ so no go. */
+ break;
+ }
+
+ ourmark = ((LISTOP *)o)->op_first;
+ if (!ourmark || ourmark->op_type != OP_PUSHMARK)
+ break;
+
+ ourlast = ((LISTOP *)o)->op_last;
+ if (!ourlast || ourlast->op_next != o)
+ break;
+
+ rv2av = ourmark->op_sibling;
+ if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
+ && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
+ && enter->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;
+ }
+
+ /* We don't have control over who points to theirmark, so sacrifice
+ ours. */
+ theirmark->op_next = ourmark->op_next;
+ theirmark->op_flags = ourmark->op_flags;
+ ourlast->op_next = gvop ? gvop : (OP *) enter;
+ op_null(ourmark);
+ op_null(o);
+ enter->op_private |= OPpITER_REVERSED;
+ iter->op_private |= OPpITER_REVERSED;
+
+ break;
+ }
+
default:
o->op_opt = 1;
break;
https://perl5.git.perl.org / perl5.git / blobdiff