X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=d99045b0d9fac330fd77d8203150fd7fa02d35b5;hb=59910b6dbc5bdf043d9f33f40bbbc9957f008770;hp=be05875ca6cfe11f73a4497f9cc6d4d3312bbbfa;hpb=1af34c76bc1167bbfada70004d6cbc41b0098f64;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index be05875..d99045b 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 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. @@ -16,6 +16,30 @@ * 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. + */ #include "EXTERN.h" #define PERL_IN_OP_C @@ -30,13 +54,8 @@ #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 * @@ -74,8 +93,8 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) 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]; @@ -83,9 +102,9 @@ S_Slab_Free(pTHX_ void *op) 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) { @@ -93,10 +112,6 @@ S_Slab_Free(pTHX_ void *op) } } } - -#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 @@ -164,11 +179,11 @@ Perl_allocmy(pTHX_ char *name) { PADOFFSET off; - /* complain about "my $_" etc etc */ + /* complain about "my $" 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 */ @@ -194,7 +209,7 @@ Perl_allocmy(pTHX_ char *name) /* 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) ); @@ -225,7 +240,7 @@ Perl_op_free(pTHX_ OP *o) register OP *kid, *nextkid; OPCODE type; - if (!o || o->op_seq == (U16)-1) + if (!o || o->op_static) return; if (o->op_private & OPpREFCOUNTED) { @@ -284,17 +299,20 @@ Perl_op_clear(pTHX_ OP *o) 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: @@ -303,7 +321,7 @@ Perl_op_clear(pTHX_ OP *o) #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. **/ @@ -667,6 +685,15 @@ Perl_scalarvoid(pTHX_ 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: @@ -683,10 +710,14 @@ Perl_scalarvoid(pTHX_ OP *o) 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 @@ -888,10 +919,23 @@ S_modkids(pTHX_ OP *o, I32 type) 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; @@ -904,6 +948,7 @@ Perl_mod(pTHX_ OP *o, I32 type) switch (o->op_type) { case OP_UNDEF: + localize = 0; PL_modcount++; return o; case OP_CONST: @@ -1060,6 +1105,7 @@ Perl_mod(pTHX_ OP *o, I32 type) break; case OP_COND_EXPR: + localize = 1; for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); break; @@ -1080,6 +1126,7 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_HSLICE: if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; + localize = 1; /* FALL THROUGH */ case OP_AASSIGN: case OP_NEXTSTATE: @@ -1088,6 +1135,7 @@ Perl_mod(pTHX_ OP *o, I32 type) break; case OP_RV2SV: ref(cUNOPo->op_first, o->op_type); + localize = 1; /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: @@ -1096,7 +1144,11 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: + PL_modcount++; + break; + case OP_AELEMFAST: + localize = -1; PL_modcount++; break; @@ -1112,17 +1164,13 @@ Perl_mod(pTHX_ OP *o, I32 type) /* 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: @@ -1153,6 +1201,7 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_private |= OPpLVAL_DEFER; if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; + localize = 1; PL_modcount++; break; @@ -1160,11 +1209,13 @@ Perl_mod(pTHX_ OP *o, I32 type) 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)) @@ -1175,6 +1226,7 @@ Perl_mod(pTHX_ OP *o, I32 type) } /* FALL THROUGH */ case OP_LIST: + localize = 0; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; @@ -1197,10 +1249,21 @@ Perl_mod(pTHX_ OP *o, I32 type) 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) @@ -1650,6 +1713,7 @@ OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { OP *o; + bool ismatchop = 0; if (ckWARN(WARN_MISC) && (left->op_type == OP_RV2AV || @@ -1674,10 +1738,14 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 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 && @@ -1728,22 +1796,17 @@ Perl_scope(pTHX_ OP *o) 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; @@ -1765,8 +1828,6 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) { 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) @@ -1778,7 +1839,15 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) 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 @@ -1797,8 +1866,12 @@ Perl_newPROG(pTHX_ OP *o) 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); @@ -1838,14 +1911,31 @@ Perl_localize(pTHX_ OP *o, I32 lex) && 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) @@ -1968,7 +2058,9 @@ Perl_gen_constant_list(pTHX_ register OP *o) 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); @@ -2128,7 +2220,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) listop->op_last = pushop; } - return (OP*)listop; + return CHECKOP(type, listop); } OP * @@ -2251,13 +2343,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 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; @@ -2565,7 +2657,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) PmopSTASH_set(pmop,PL_curstash); } - return (OP*)pmop; + return CHECKOP(type, pmop); } OP * @@ -2612,6 +2704,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) : 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)) { @@ -2631,7 +2725,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) 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) @@ -2883,6 +2977,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; PL_expect = XSTATE; + PL_cop_seqmax++; /* Purely for B::*'s benefit */ } /* @@ -3062,6 +3157,15 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) op_free(right); return Nullop; } + /* optimise C to C, 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)); @@ -3294,24 +3398,47 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } } 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, or C */ + 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 err FOO. */ + { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; @@ -3369,6 +3496,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) first->op_next = (OP*)logop; first->op_sibling = other; + CHECKOP(type,logop); + o = newUNOP(OP_NULL, 0, (OP*)logop); other->op_next = o; @@ -3413,6 +3542,8 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 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); @@ -3511,6 +3642,10 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) } } + /* 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); @@ -3577,11 +3712,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * 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); @@ -3634,13 +3764,16 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo 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); @@ -3657,7 +3790,13 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo 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); @@ -3699,6 +3838,9 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo 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; @@ -3734,7 +3876,9 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) 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); } @@ -3811,6 +3955,8 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) 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); @@ -3844,6 +3990,26 @@ Perl_cv_const_sv(pTHX_ CV *cv) 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) { @@ -3872,26 +4038,31 @@ 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; } @@ -3922,11 +4093,19 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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"]", @@ -4084,6 +4263,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) /* 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; @@ -4093,6 +4274,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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; } @@ -4138,6 +4320,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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; @@ -4279,6 +4466,9 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) CvCONST_on(cv); sv_setpv((SV*)cv, ""); /* prototype is "" */ + if (stash) + CopSTASH_free(PL_curcop); + LEAVE; return cv; @@ -4606,13 +4796,17 @@ Perl_ck_bitop(pTHX_ OP *o) (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", @@ -4626,8 +4820,10 @@ Perl_ck_bitop(pTHX_ OP *o) 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; } @@ -4739,8 +4935,10 @@ Perl_ck_eval(pTHX_ OP *o) enter->op_other = o; return o; } - else + else { scalar((OP*)kid); + PL_cv_has_eval = 1; + } } else { op_free(o); @@ -4932,12 +5130,16 @@ Perl_ck_ftst(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_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); @@ -5092,10 +5294,6 @@ Perl_ck_fun(pTHX_ OP *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 @@ -5149,8 +5347,7 @@ Perl_ck_fun(pTHX_ OP *o) } if (tmpstr) { - name = savepv(SvPVX(tmpstr)); - len = strlen(name); + name = SvPV(tmpstr, len); sv_2mortal(tmpstr); } } @@ -5224,7 +5421,7 @@ Perl_ck_glob(pTHX_ OP *o) #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, @@ -5245,6 +5442,7 @@ Perl_ck_glob(pTHX_ OP *o) 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, @@ -5266,6 +5464,7 @@ Perl_ck_grep(pTHX_ OP *o) 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); @@ -5274,7 +5473,7 @@ Perl_ck_grep(pTHX_ OP *o) 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; @@ -5297,10 +5496,17 @@ Perl_ck_grep(pTHX_ OP *o) 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) @@ -5440,13 +5646,34 @@ Perl_ck_sassign(pTHX_ OP *o) return kid; } } + /* optimise C to C */ + 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; } @@ -5710,7 +5937,7 @@ S_simplify_sort(pTHX_ OP *o) { 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; @@ -5739,11 +5966,12 @@ S_simplify_sort(pTHX_ OP *o) 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; @@ -5753,13 +5981,13 @@ S_simplify_sort(pTHX_ OP *o) 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) @@ -6104,6 +6332,18 @@ Perl_ck_trunc(pTHX_ OP *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); @@ -6126,25 +6366,21 @@ Perl_peep(pTHX_ register OP *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: @@ -6175,7 +6411,7 @@ Perl_peep(pTHX_ register OP *o) o->op_targ = ix; } #endif - o->op_seq = PL_op_seqmax++; + o->op_opt = 1; break; case OP_CONCAT: @@ -6193,11 +6429,11 @@ Perl_peep(pTHX_ register OP *o) 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; @@ -6212,6 +6448,7 @@ Perl_peep(pTHX_ register OP *o) 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; @@ -6225,25 +6462,17 @@ Perl_peep(pTHX_ register OP *o) 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)) && @@ -6252,16 +6481,36 @@ Perl_peep(pTHX_ register OP *o) 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)) { @@ -6287,7 +6536,7 @@ Perl_peep(pTHX_ register OP *o) op_null(o->op_next); } - o->op_seq = PL_op_seqmax++; + o->op_opt = 1; break; case OP_MAPWHILE: @@ -6300,7 +6549,7 @@ Perl_peep(pTHX_ register OP *o) 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 */ @@ -6308,7 +6557,7 @@ Perl_peep(pTHX_ register OP *o) 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); @@ -6323,7 +6572,7 @@ Perl_peep(pTHX_ register OP *o) 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; @@ -6331,7 +6580,7 @@ Perl_peep(pTHX_ register OP *o) 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 && @@ -6351,12 +6600,14 @@ Perl_peep(pTHX_ register OP *o) break; case OP_HELEM: { + UNOP *rop; SV *lexname; + GV **fields; SV **svp, *sv; 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; @@ -6371,11 +6622,299 @@ Perl_peep(pTHX_ register OP *o) 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_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; + + /* 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; + 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; + } + + 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_seq = PL_op_seqmax++; + o->op_opt = 1; break; } oldop = o;