X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=9c94cc8c275070122de8deff50665153e7393b6c;hb=20d572319ce8b690b7b68fec6b58f8ac07b1d362;hp=aa5994dbcf20caec4cdd70e07bcf7b20e2b32732;hpb=35f82371218a026d1f07258ae020fffabf397fdc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index aa5994d..9c94cc8 100644 --- a/op.c +++ b/op.c @@ -406,21 +406,17 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) } } - /* check for duplicate declaration */ - pad_check_dup(name, len, is_our ? pad_add_OUR : 0, - (PL_curstash ? PL_curstash : PL_defstash)); - /* allocate a spare slot and store the name in that slot */ - off = pad_add_name(name, + off = pad_add_name(name, len, + is_our ? padadd_OUR : + PL_parser->in_my == KEY_state ? padadd_STATE : 0, PL_parser->in_my_stash, (is_our /* $_ is always in main::, even with our */ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : NULL - ), - 0, /* not fake */ - PL_parser->in_my == KEY_state + ) ); /* anon sub prototypes contains state vars should always be cloned, * otherwise the state var would be shared between anon subs */ @@ -566,6 +562,7 @@ Perl_op_clear(pTHX_ OP *o) o->op_targ = 0; goto retry; } + case OP_ENTERTRY: case OP_ENTEREVAL: /* Was holding hints. */ o->op_targ = 0; break; @@ -989,7 +986,7 @@ Perl_scalarvoid(pTHX_ OP *o) want = o->op_flags & OPf_WANT; if ((want && want != OPf_WANT_SCALAR) || (PL_parser && PL_parser->error_count) - || o->op_type == OP_RETURN) + || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE) { return o; } @@ -1090,6 +1087,17 @@ Perl_scalarvoid(pTHX_ OP *o) useless = OP_DESC(o); break; + case OP_SPLIT: + kid = cLISTOPo->op_first; + if (kid && kid->op_type == OP_PUSHRE +#ifdef USE_ITHREADS + && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff) +#else + && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv) +#endif + useless = OP_DESC(o); + break; + case OP_NOT: kid = cUNOPo->op_first; if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && @@ -1219,10 +1227,6 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_ENTEREVAL: scalarkids(o); break; - case OP_REQUIRE: - /* all requires must return a boolean value */ - o->op_flags &= ~OPf_WANT; - /* FALL THROUGH */ case OP_SCALAR: return scalar(o); } @@ -1311,10 +1315,6 @@ Perl_list(pTHX_ OP *o) } PL_curcop = &PL_compiling; break; - case OP_REQUIRE: - /* all requires must return a boolean value */ - o->op_flags &= ~OPf_WANT; - return scalar(o); } return o; } @@ -3024,6 +3024,8 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) dVAR; LISTOP *listop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP); + NewOp(1101, listop, 1, LISTOP); listop->op_type = (OPCODE)type; @@ -3057,6 +3059,12 @@ Perl_newOP(pTHX_ I32 type, I32 flags) { dVAR; OP *o; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + NewOp(1101, o, 1, OP); o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; @@ -3080,6 +3088,14 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) dVAR; UNOP *unop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP + || type == OP_SASSIGN + || type == OP_ENTERTRY + || type == OP_NULL ); + if (!first) first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) @@ -3103,6 +3119,10 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { dVAR; BINOP *binop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP + || type == OP_SASSIGN || type == OP_NULL ); + NewOp(1101, binop, 1, BINOP); if (!first) @@ -3498,6 +3518,8 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) dVAR; PMOP *pmop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP); + NewOp(1101, pmop, 1, PMOP); pmop->op_type = (OPCODE)type; pmop->op_ppaddr = PL_ppaddr[type]; @@ -3742,6 +3764,10 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) PERL_ARGS_ASSERT_NEWSVOP; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); + NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)type; svop->op_ppaddr = PL_ppaddr[type]; @@ -3764,6 +3790,10 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) PERL_ARGS_ASSERT_NEWPADOP; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); + NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; @@ -3802,6 +3832,10 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { dVAR; PVOP *pvop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + NewOp(1101, pvop, 1, PVOP); pvop->op_type = (OPCODE)type; pvop->op_ppaddr = PL_ppaddr[type]; @@ -4245,7 +4279,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) || left->op_type == OP_PADHV || left->op_type == OP_PADANY)) { - maybe_common_vars = FALSE; + if (left->op_type == OP_PADSV) maybe_common_vars = FALSE; if (left->op_private & OPpPAD_STATE) { /* All single variable list context state assignments, hence state ($a) = ... @@ -4559,6 +4593,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP); + scalarboolean(first); /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT @@ -5115,6 +5151,8 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) PERL_ARGS_ASSERT_NEWLOOPEX; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) @@ -5677,7 +5715,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) )&& !attrs) { if (CvFLAGS(PL_compcv)) { /* might have had built-in attrs applied */ - CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); + if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC)) + Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE); } /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); @@ -5746,8 +5786,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) && block->op_type != OP_NULL #endif ) { + cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; cv_undef(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv); + CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; if (!CvWEAKOUTSIDE(cv)) SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); @@ -5775,7 +5816,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (PL_madskills) { if (strEQ(name, "import")) { PL_formfeed = MUTABLE_SV(cv); - Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv); + /* diag_listed_as: SKIPME */ + Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv)); } } GvCVGEN(gv) = 0; @@ -6563,8 +6605,6 @@ Perl_ck_eval(pTHX_ OP *o) /* establish postfix order */ enter->op_next = (OP*)enter; - CHECKOP(OP_ENTERTRY, enter); - o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; @@ -7173,10 +7213,10 @@ Perl_ck_grep(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) { OP* k; o = ck_sort(o); - kid = cLISTOPo->op_first->op_sibling; - if (!cUNOPx(kid)->op_next) - Perl_croak(aTHX_ "panic: ck_grep"); - for (k = cUNOPx(kid)->op_first; k; k = k->op_next) { + kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first; + if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) + return no_fh_allowed(o); + for (k = kid; k; k = k->op_next) { kid = k; } NewOp(1101, gwop, 1, LOGOP); @@ -7643,7 +7683,7 @@ Perl_ck_require(pTHX_ OP *o) return newop; } - return ck_fun(o); + return scalar(ck_fun(o)); } OP * @@ -8328,8 +8368,9 @@ Perl_ck_each(pTHX_ OP *o) /* caller is supposed to assign the return to the container of the rep_op var */ -OP * +STATIC OP * S_opt_scalarhv(pTHX_ OP *rep_op) { + dVAR; UNOP *unop; PERL_ARGS_ASSERT_OPT_SCALARHV; @@ -8353,6 +8394,78 @@ S_opt_scalarhv(pTHX_ OP *rep_op) { return (OP*)unop; } +/* Checks if o acts as an in-place operator on an array. oright points to the + * beginning of the right-hand side. Returns the left-hand side of the + * assignment if o acts in-place, or NULL otherwise. */ + +STATIC OP * +S_is_inplace_av(pTHX_ OP *o, OP *oright) { + OP *o2; + OP *oleft = NULL; + + PERL_ARGS_ASSERT_IS_INPLACE_AV; + + if (!oright || + (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) + || oright->op_next != o + || (oright->op_private & OPpLVAL_INTRO) + ) + return NULL; + + /* 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) + return NULL; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_PUSHMARK) + return NULL; + 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) + ) + return NULL; + oleft = o2; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_AASSIGN + || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) + return NULL; + + /* check that the sort is the first arg on RHS of assign */ + + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_PUSHMARK) + return NULL; + if (o2->op_sibling != o) + return NULL; + + /* 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) + ) + return NULL; + } + else if (oright->op_type != OP_PADAV + || oright->op_targ != oleft->op_targ + ) + return NULL; + + return oleft; +} + /* 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 */ @@ -8568,7 +8681,7 @@ Perl_peep(pTHX_ register OP *o) ){ OP * nop = o; OP * lop = o; - if (!(nop->op_flags && OPf_WANT_VOID)) { + if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) { while (nop && nop->op_next) { switch (nop->op_next->op_type) { case OP_NOT: @@ -8586,7 +8699,7 @@ Perl_peep(pTHX_ register OP *o) } } } - if (lop->op_flags && OPf_WANT_VOID) { + if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) { if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) cLOGOP->op_first = opt_scalarhv(fop); if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)) @@ -8793,62 +8906,8 @@ Perl_peep(pTHX_ register OP *o) 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 - ) + oleft = is_inplace_av(o, oright); + if (!oleft) break; /* transfer MODishness etc from LHS arg to RHS arg */ @@ -8875,8 +8934,36 @@ Perl_peep(pTHX_ register OP *o) case OP_REVERSE: { OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; OP *gvop = NULL; + OP *oleft, *oright; LISTOP *enter, *exlist; + /* @a = reverse @a */ + if ((oright = cLISTOPo->op_first) + && (oright->op_type == OP_PUSHMARK) + && (oright = oright->op_sibling) + && (oleft = is_inplace_av(o, oright))) { + OP *o2; + + /* transfer MODishness etc from LHS arg to RHS arg */ + oright->op_flags = oleft->op_flags; + o->op_private |= OPpREVERSE_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; + } + enter = (LISTOP *) o->op_next; if (!enter) break;