X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=da0ad2c710e97b0b0a13dbbac1bc3cb39a78d003;hb=c2dc4c7d5e51c6211637044820c7a560da7e6268;hp=573b67b5e8578586d2b8513cb9a19ff84a5b7628;hpb=70938cb944714e91b284c1fcdab01a6ab2f49034;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 573b67b..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; @@ -575,7 +581,24 @@ Perl_op_clear(pTHX_ OP *o) && PL_curpad #endif ? cGVOPo_gv : NULL; - SvREFCNT_inc_simple_void(gv); + /* 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 @@ -587,7 +610,7 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; #endif - if (gv) { + if (still_valid) { int try_downgrade = SvREFCNT(gv) == 2; SvREFCNT_dec(gv); if (try_downgrade) @@ -901,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; @@ -963,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; } @@ -1064,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 && @@ -1073,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: @@ -1193,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); } @@ -1267,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; } @@ -2193,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; @@ -2206,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; @@ -2998,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; @@ -3031,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]; @@ -3054,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) @@ -3077,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) @@ -3472,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]; @@ -3716,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]; @@ -3738,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]; @@ -3776,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]; @@ -4219,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) = ... @@ -4533,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 @@ -5089,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)) @@ -5218,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: @@ -5651,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); @@ -5720,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); @@ -5749,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; @@ -5850,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; @@ -6537,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]; @@ -6678,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) { @@ -7147,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); @@ -7617,7 +7687,7 @@ Perl_ck_require(pTHX_ OP *o) return newop; } - return ck_fun(o); + return scalar(ck_fun(o)); } OP * @@ -7683,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)); @@ -8302,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; @@ -8327,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 */ @@ -8542,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: @@ -8560,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)) @@ -8728,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 */ @@ -8767,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 */ @@ -8849,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;