X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=da0ad2c710e97b0b0a13dbbac1bc3cb39a78d003;hb=c2dc4c7d5e51c6211637044820c7a560da7e6268;hp=504fae90a09749ed3291dd7d05717e7f6bf52965;hpb=4b88f2805a1717a959eb17ecb3e8968e25f54d02;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 504fae9..da0ad2c 100644 --- a/op.c +++ b/op.c @@ -372,7 +372,7 @@ S_no_bareword_allowed(pTHX_ const OP *o) /* "register" allocation */ PADOFFSET -Perl_allocmy(pTHX_ const char *const name) +Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { dVAR; PADOFFSET off; @@ -380,38 +380,43 @@ Perl_allocmy(pTHX_ const char *const name) PERL_ARGS_ASSERT_ALLOCMY; + if (flags) + Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, + (UV)flags); + + /* Until we're using the length for real, cross check that we're being + told the truth. */ + assert(strlen(name) == len); + /* complain about "my $" etc etc */ - if (*name && + if (len && !(is_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || - (name[1] == '_' && (*name == '$' || name[2])))) + (name[1] == '_' && (*name == '$' || len > 2)))) { /* name[2] is true if strlen(name) > 2 */ if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { - yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"", - name[0], toCTRL(name[1]), name + 2, + yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", + name[0], toCTRL(name[1]), (int)(len - 2), name + 2, PL_parser->in_my == KEY_state ? "state" : "my")); } else { - yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name, + yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, PL_parser->in_my == KEY_state ? "state" : "my")); } } - /* check for duplicate declaration */ - pad_check_dup(name, is_our, (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 */ @@ -557,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; @@ -570,6 +576,29 @@ Perl_op_clear(pTHX_ OP *o) case OP_AELEMFAST: if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { /* not an OP_PADAV replacement */ + GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV) +#ifdef USE_ITHREADS + && PL_curpad +#endif + ? cGVOPo_gv : NULL; + /* It's possible during global destruction that the GV is freed + before the optree. Whilst the SvREFCNT_inc is happy to bump from + 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0 + will trigger an assertion failure, because the entry to sv_clear + checks that the scalar is not already freed. A check of for + !SvIS_FREED(gv) turns out to be invalid, because during global + destruction the reference count can be forced down to zero + (with SVf_BREAK set). In which case raising to 1 and then + dropping to 0 triggers cleanup before it should happen. I + *think* that this might actually be a general, systematic, + weakness of the whole idea of SVf_BREAK, in that code *is* + allowed to raise and lower references during global destruction, + so any *valid* code that happens to do this during global + destruction might well trigger premature cleanup. */ + bool still_valid = gv && SvREFCNT(gv); + + if (still_valid) + SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { /* No GvIN_PAD_off(cGVOPo_gv) here, because other references @@ -581,6 +610,12 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; #endif + if (still_valid) { + int try_downgrade = SvREFCNT(gv) == 2; + SvREFCNT_dec(gv); + if (try_downgrade) + gv_try_downgrade(gv); + } } break; case OP_METHOD_NAMED: @@ -889,25 +924,28 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - while ((kid = kid->op_sibling)) { - if (kid->op_sibling) - scalarvoid(kid); - else + kid = kid->op_sibling; + do_kids: + while (kid) { + OP *sib = kid->op_sibling; + if (sib && kid->op_type != OP_LEAVEWHEN) { + if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) { + scalar(kid); + scalarvoid(sib); + break; + } else + scalarvoid(kid); + } else scalar(kid); + kid = sib; } PL_curcop = &PL_compiling; break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) - scalarvoid(kid); - else - scalar(kid); - } - PL_curcop = &PL_compiling; - break; + kid = cLISTOPo->op_first; + goto do_kids; case OP_SORT: Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); break; @@ -951,7 +989,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 || o->op_type == OP_LEAVEWHEN) { return o; } @@ -1052,6 +1090,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 && @@ -1061,6 +1110,11 @@ Perl_scalarvoid(pTHX_ OP *o) useless = "negative pattern binding (!~)"; break; + case OP_SUBST: + if (cPMOPo->op_pmflags & PMf_NONDESTRUCT) + useless = "Non-destructive substitution (s///r)"; + break; + case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: @@ -1181,10 +1235,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); } @@ -1255,28 +1305,27 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - while ((kid = kid->op_sibling)) { - if (kid->op_sibling) - scalarvoid(kid); - else + kid = kid->op_sibling; + do_kids: + while (kid) { + OP *sib = kid->op_sibling; + if (sib && kid->op_type != OP_LEAVEWHEN) { + if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) { + list(kid); + scalarvoid(sib); + break; + } else + scalarvoid(kid); + } else list(kid); + kid = sib; } PL_curcop = &PL_compiling; break; case OP_SCOPE: case OP_LINESEQ: - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) - scalarvoid(kid); - else - list(kid); - } - PL_curcop = &PL_compiling; - break; - case OP_REQUIRE: - /* all requires must return a boolean value */ - o->op_flags &= ~OPf_WANT; - return scalar(o); + kid = cLISTOPo->op_first; + goto do_kids; } return o; } @@ -2181,6 +2230,11 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) no_bareword_allowed(right); } + /* !~ doesn't make sense with s///r, so error on it for now */ + if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) && + type == OP_NOT) + yyerror("Using !~ with s///r doesn't make sense"); + ismatchop = rtype == OP_MATCH || rtype == OP_SUBST || rtype == OP_TRANS; @@ -2194,7 +2248,9 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) right->op_flags |= OPf_STACKED; if (rtype != OP_MATCH && ! (rtype == OP_TRANS && - right->op_private & OPpTRANS_IDENTICAL)) + right->op_private & OPpTRANS_IDENTICAL) && + ! (rtype == OP_SUBST && + (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT))) newleft = mod(left, rtype); else newleft = left; @@ -2281,7 +2337,7 @@ STATIC OP * S_newDEFSVOP(pTHX) { dVAR; - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } @@ -2986,6 +3042,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; @@ -3019,6 +3077,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]; @@ -3042,6 +3106,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) @@ -3065,6 +3137,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) @@ -3460,6 +3536,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]; @@ -3704,6 +3782,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]; @@ -3726,6 +3808,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]; @@ -3764,6 +3850,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]; @@ -4207,7 +4297,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) = ... @@ -4521,6 +4611,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 @@ -4995,7 +5087,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP } } else { - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { sv = newGVOP(OP_GV, 0, PL_defgv); } @@ -5077,6 +5169,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)) @@ -5206,14 +5300,11 @@ S_looks_like_bool(pTHX_ const OP *o) && looks_like_bool(cLOGOPo->op_first->op_sibling)); case OP_NULL: + case OP_SCALAR: return ( o->op_flags & OPf_KIDS && looks_like_bool(cUNOPo->op_first)); - case OP_SCALAR: - return looks_like_bool(cUNOPo->op_first); - - case OP_ENTERSUB: case OP_NOT: case OP_XOR: @@ -5639,7 +5730,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); @@ -5708,8 +5801,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); @@ -5737,7 +5831,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; @@ -5838,7 +5933,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); - if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) { + if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) { CV * const pcv = GvCV(db_postponed); if (pcv) { dSP; @@ -6525,8 +6620,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]; @@ -6666,17 +6759,6 @@ Perl_ck_rvconst(pTHX_ register OP *o) Perl_croak(aTHX_ "Constant is not %s reference", badtype); return o; } - else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) && - (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) { - /* If this is an access to a stash, disable "strict refs", because - * stashes aren't auto-vivified at compile-time (unless we store - * symbols in them), and we don't want to produce a run-time - * stricture error when auto-vivifying the stash. */ - const char *s = SvPV_nolen(kidsv); - const STRLEN l = SvCUR(kidsv); - if (l > 1 && s[l-1] == ':' && s[l-2] == ':') - o->op_private &= ~HINT_STRICT_REFS; - } if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { const char *badthing; switch (o->op_type) { @@ -7135,10 +7217,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); @@ -7166,7 +7248,7 @@ Perl_ck_grep(pTHX_ OP *o) gwop->op_flags |= OPf_KIDS; gwop->op_other = LINKLIST(kid); kid->op_next = (OP*)gwop; - offset = pad_findmy("$_"); + offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { o->op_private = gwop->op_private = 0; gwop->op_targ = pad_alloc(type, SVs_PADTMP); @@ -7406,7 +7488,7 @@ Perl_ck_match(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_MATCH; if (o->op_type != OP_QR && PL_compcv) { - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { o->op_targ = offset; o->op_private |= OPpTARGET_MY; @@ -7605,7 +7687,7 @@ Perl_ck_require(pTHX_ OP *o) return newop; } - return ck_fun(o); + return scalar(ck_fun(o)); } OP * @@ -7671,8 +7753,14 @@ Perl_ck_shift(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SHIFT; if (!(o->op_flags & OPf_KIDS)) { - OP *argop = newUNOP(OP_RV2AV, 0, - scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); + OP *argop; + + if (!CvUNIQUE(PL_compcv)) { + o->op_flags |= OPf_SPECIAL; + return o; + } + + argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); #ifdef PERL_MAD OP * const oldo = o; o = newUNOP(type, 0, scalar(argop)); @@ -7945,22 +8033,29 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private |= OPpENTERSUB_HASTARG; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { - SVOP* tmpop; o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); op_null(cvop); /* disable rv2cv */ - tmpop = (SVOP*)((UNOP*)cvop)->op_first; - if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { - GV *gv = cGVOPx_gv(tmpop); - cv = GvCVu(gv); - if (!cv) - tmpop->op_private |= OPpEARLY_CV; - else { - if (SvPOK(cv)) { - STRLEN len; - namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV(MUTABLE_SV(cv), len); - proto_end = proto + len; - } + if (!(o->op_private & OPpENTERSUB_AMPER)) { + SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first; + GV *gv = NULL; + switch (tmpop->op_type) { + case OP_GV: { + gv = cGVOPx_gv(tmpop); + cv = GvCVu(gv); + if (!cv) + tmpop->op_private |= OPpEARLY_CV; + } break; + case OP_CONST: { + SV *sv = cSVOPx_sv(tmpop); + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) + cv = (CV*)SvRV(sv); + } break; + } + if (cv && SvPOK(cv)) { + STRLEN len; + namegv = gv && CvANON(cv) ? gv : CvGV(cv); + proto = SvPV(MUTABLE_SV(cv), len); + proto_end = proto + len; } } } @@ -8283,8 +8378,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; @@ -8308,6 +8404,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 */ @@ -8523,7 +8691,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: @@ -8541,7 +8709,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)) @@ -8709,6 +8877,20 @@ Perl_peep(pTHX_ register OP *o) } break; } + case OP_RV2SV: + case OP_RV2AV: + case OP_RV2HV: + if (oldop + && ( oldop->op_type == OP_AELEM + || oldop->op_type == OP_PADSV + || oldop->op_type == OP_RV2SV + || oldop->op_type == OP_RV2GV + || oldop->op_type == OP_HELEM + ) + && (oldop->op_private & OPpDEREF) + ) { + o->op_private |= OPpDEREFed; + } case OP_SORT: { /* will point to RV2AV or PADAV op on LHS/RHS of assign */ @@ -8748,62 +8930,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 */ @@ -8830,8 +8958,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;