X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=ce294f06666fb6046d4c09893efc3f15161b6b58;hb=cddfcddc190fa3c9953973822c35e3baa71181f0;hp=e686b2afba312d4a8083619dccb6a5d4ee23b972;hpb=07bc277f32c1d7aff237dd3f55d558b5d4b93314;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index e686b2a..ce294f0 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -39,14 +39,7 @@ PP(pp_const) { dVAR; dSP; - if ( PL_op->op_flags & OPf_SPECIAL ) - /* This is a const op added to hold the hints hash for - pp_entereval. The hash can be modified by the code - being eval'ed, so we return a copy instead. */ - XPUSHs(sv_2mortal((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv))); - else - /* Normal const. */ - XPUSHs(cSVOP_sv); + XPUSHs(cSVOP_sv); RETURN; } @@ -78,13 +71,6 @@ PP(pp_null) return NORMAL; } -PP(pp_setstate) -{ - dVAR; - PL_curcop = (COP*)PL_op; - return NORMAL; -} - PP(pp_pushmark) { dVAR; @@ -248,7 +234,7 @@ PP(pp_concat) /* mg_get(right) may happen here ... */ rpv = SvPV_const(right, rlen); rbyte = !DO_UTF8(right); - right = sv_2mortal(newSVpvn(rpv, rlen)); + right = newSVpvn_flags(rpv, rlen, SVs_TEMP); rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ rcopied = TRUE; } @@ -287,7 +273,7 @@ PP(pp_concat) sv_utf8_upgrade_nomg(TARG); else { if (!rcopied) - right = sv_2mortal(newSVpvn(rpv, rlen)); + right = newSVpvn_flags(rpv, rlen, SVs_TEMP); sv_utf8_upgrade_nomg(right); rpv = SvPV_const(right, rlen); } @@ -731,6 +717,11 @@ PP(pp_print) *MARK = SvTIED_obj((SV*)io, mg); PUTBACK; ENTER; + if( PL_op->op_type == OP_SAY ) { + /* local $\ = "\n" */ + SAVEGENERICSV(PL_ors_sv); + PL_ors_sv = newSVpvs("\n"); + } call_method("PRINT", G_SCALAR); LEAVE; SPAGAIN; @@ -810,8 +801,6 @@ PP(pp_rv2av) { dVAR; dSP; dTOPss; const I32 gimme = GIMME_V; - static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context"; - static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context"; static const char an_array[] = "an ARRAY"; static const char a_hash[] = "a HASH"; const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV; @@ -830,8 +819,7 @@ PP(pp_rv2av) } else if (LVRET) { if (gimme != G_ARRAY) - Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar - : return_hash_to_lvalue_scalar); + goto croak_cant_return; SETs(sv); RETURN; } @@ -847,9 +835,7 @@ PP(pp_rv2av) } else if (LVRET) { if (gimme != G_ARRAY) - Perl_croak(aTHX_ - is_pp_rv2av ? return_array_to_lvalue_scalar - : return_hash_to_lvalue_scalar); + goto croak_cant_return; SETs(sv); RETURN; } @@ -880,9 +866,7 @@ PP(pp_rv2av) } else if (LVRET) { if (gimme != G_ARRAY) - Perl_croak(aTHX_ - is_pp_rv2av ? return_array_to_lvalue_scalar - : return_hash_to_lvalue_scalar); + goto croak_cant_return; SETs(sv); RETURN; } @@ -932,12 +916,20 @@ PP(pp_rv2av) } } RETURN; + + croak_cant_return: + Perl_croak(aTHX_ "Can't return %s to lvalue scalar context", + is_pp_rv2av ? "array" : "hash"); + RETURN; } STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) { dVAR; + + PERL_ARGS_ASSERT_DO_ODDBALL; + if (*relem) { SV *tmpstr; const HE *didstore; @@ -1192,13 +1184,23 @@ PP(pp_qr) dVAR; dSP; register PMOP * const pm = cPMOP; REGEXP * rx = PM_GETRE(pm); - SV * const pkg = CALLREG_PACKAGE(rx); + SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL; SV * const rv = sv_newmortal(); - SV * const sv = newSVrv(rv, pkg ? SvPV_nolen(pkg) : NULL); + + SvUPGRADE(rv, SVt_IV); + /* This RV is about to own a reference to the regexp. (In addition to the + reference already owned by the PMOP. */ + ReREFCNT_inc(rx); + SvRV_set(rv, (SV*) rx); + SvROK_on(rv); + + if (pkg) { + HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD); + (void)sv_bless(rv, stash); + } + if (RX_EXTFLAGS(rx) & RXf_TAINTED) SvTAINTED_on(rv); - sv_upgrade(sv, SVt_REGEXP); - ((struct xregexp *)SvANY(sv))->xrx_regexp = ReREFCNT_inc(rx); XPUSHs(rv); RETURN; } @@ -1212,7 +1214,7 @@ PP(pp_match) register const char *s; const char *strend; I32 global; - I32 r_flags = REXEC_CHECKED; + U8 r_flags = REXEC_CHECKED; const char *truebase; /* Start of string */ register REGEXP *rx = PM_GETRE(pm); bool rxtainted; @@ -1312,7 +1314,7 @@ play_it_again: minmatch = had_zerolen; } if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT && - DO_UTF8(TARG) == ((RX_EXTFLAGS(rx) & RXf_UTF8) != 0)) { + DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) { /* FIXME - can PL_bostr be made const char *? */ PL_bostr = (char *)truebase; s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL); @@ -1469,16 +1471,17 @@ yup: /* Confirmed by INTUIT */ (int) SvTYPE(TARG), (void*)truebase, (void*)t, (int)(t-truebase)); } - rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG); - RX_SUBBEG(rx) = (char *) SvPVX_const(rx->saved_copy) + (t - truebase); - assert (SvPOKp(rx->saved_copy)); + RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG); + RX_SUBBEG(rx) + = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase); + assert (SvPOKp(RX_SAVED_COPY(rx))); } else #endif { RX_SUBBEG(rx) = savepvn(t, strend - t); #ifdef PERL_OLD_COPY_ON_WRITE - rx->saved_copy = NULL; + RX_SAVED_COPY(rx) = NULL; #endif } RX_SUBLEN(rx) = strend - t; @@ -1886,25 +1889,24 @@ PP(pp_iter) dVAR; dSP; register PERL_CONTEXT *cx; SV *sv, *oldsv; - AV* av; SV **itersvp; + AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */ + bool av_is_stack = FALSE; EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; - if (CxTYPE(cx) != CXt_LOOP) + if (!CxTYPE_is_LOOP(cx)) DIE(aTHX_ "panic: pp_iter"); itersvp = CxITERVAR(cx); - av = cx->blk_loop.iterary; - if (SvTYPE(av) != SVt_PVAV) { - /* iterate ($min .. $max) */ - if (cx->blk_loop.iterlval) { + if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { /* string increment */ - register SV* cur = cx->blk_loop.iterlval; + SV* cur = cx->blk_loop.state_u.lazysv.cur; + SV *end = cx->blk_loop.state_u.lazysv.end; + /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no. + It has SvPVX of "" and SvCUR of 0, which is what we want. */ STRLEN maxlen = 0; - const char *max = - SvOK((SV*)av) ? - SvPV_const((SV*)av, maxlen) : (const char *)""; + const char *max = SvPV_const(end, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ @@ -1926,15 +1928,16 @@ PP(pp_iter) RETPUSHYES; } RETPUSHNO; - } + } + else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) { /* integer increment */ - if (cx->blk_loop.iterix > cx->blk_loop.itermax) + if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end) RETPUSHNO; /* don't risk potential race */ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ - sv_setiv(*itersvp, cx->blk_loop.iterix++); + sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++); } else { @@ -1942,37 +1945,52 @@ PP(pp_iter) * completely new SV for closures/references to work as they * used to */ oldsv = *itersvp; - *itersvp = newSViv(cx->blk_loop.iterix++); + *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++); SvREFCNT_dec(oldsv); } + + /* Handle end of range at IV_MAX */ + if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) && + (cx->blk_loop.state_u.lazyiv.end == IV_MAX)) + { + cx->blk_loop.state_u.lazyiv.cur++; + cx->blk_loop.state_u.lazyiv.end++; + } + RETPUSHYES; } /* iterate array */ + assert(CxTYPE(cx) == CXt_LOOP_FOR); + av = cx->blk_loop.state_u.ary.ary; + if (!av) { + av_is_stack = TRUE; + av = PL_curstack; + } if (PL_op->op_private & OPpITER_REVERSED) { - /* In reverse, use itermax as the min :-) */ - if (cx->blk_loop.iterix <= cx->blk_loop.itermax) + if (cx->blk_loop.state_u.ary.ix <= (av_is_stack + ? cx->blk_loop.resetsp + 1 : 0)) RETPUSHNO; if (SvMAGICAL(av) || AvREIFY(av)) { - SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE); + SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE); sv = svp ? *svp : NULL; } else { - sv = AvARRAY(av)[--cx->blk_loop.iterix]; + sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix]; } } else { - if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : + if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; if (SvMAGICAL(av) || AvREIFY(av)) { - SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); + SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE); sv = svp ? *svp : NULL; } else { - sv = AvARRAY(av)[++cx->blk_loop.iterix]; + sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix]; } } @@ -1981,31 +1999,24 @@ PP(pp_iter) Perl_croak(aTHX_ "Use of freed value in iteration"); } - if (sv) + if (sv) { SvTEMP_off(sv); + SvREFCNT_inc_simple_void_NN(sv); + } else sv = &PL_sv_undef; - if (av != PL_curstack && sv == &PL_sv_undef) { - SV *lv = cx->blk_loop.iterlval; - if (lv && SvREFCNT(lv) > 1) { - SvREFCNT_dec(lv); - lv = NULL; - } - if (lv) - SvREFCNT_dec(LvTARG(lv)); - else { - lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV); - LvTYPE(lv) = 'y'; - sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); - } + if (!av_is_stack && sv == &PL_sv_undef) { + SV *lv = newSV_type(SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); LvTARG(lv) = SvREFCNT_inc_simple(av); - LvTARGOFF(lv) = cx->blk_loop.iterix; + LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix; LvTARGLEN(lv) = (STRLEN)UV_MAX; - sv = (SV*)lv; + sv = lv; } oldsv = *itersvp; - *itersvp = SvREFCNT_inc_simple_NN(sv); + *itersvp = sv; SvREFCNT_dec(oldsv); RETPUSHYES; @@ -2026,9 +2037,9 @@ PP(pp_subst) I32 maxiters; register I32 i; bool once; - bool rxtainted; + U8 rxtainted; char *orig; - I32 r_flags; + U8 r_flags; register REGEXP *rx = PM_GETRE(pm); STRLEN len; int force_on_match = 0; @@ -2241,7 +2252,7 @@ PP(pp_subst) } TAINT_IF(rxtainted & 1); SPAGAIN; - PUSHs(sv_2mortal(newSViv((I32)iters))); + mPUSHi((I32)iters); } (void)SvPOK_only_UTF8(TARG); TAINT_IF(rxtainted); @@ -2268,10 +2279,8 @@ PP(pp_subst) have_a_cow: #endif rxtainted |= RX_MATCH_TAINTED(rx); - dstr = newSVpvn(m, s-m); + dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG)); SAVEFREESV(dstr); - if (DO_UTF8(TARG)) - SvUTF8_on(dstr); PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; @@ -2329,7 +2338,7 @@ PP(pp_subst) TAINT_IF(rxtainted & 1); SPAGAIN; - PUSHs(sv_2mortal(newSViv((I32)iters))); + mPUSHi((I32)iters); (void)SvPOK_only(TARG); if (doutf8) @@ -2482,7 +2491,7 @@ PP(pp_leavesublv) TAINT_NOT; - if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { + if (CxLVAL(cx) & OPpENTERSUB_INARGS) { /* We are an argument to a function or grep(). * This kind of lvalueness was legal before lvalue * subroutines too, so be backward compatible: @@ -2509,7 +2518,7 @@ PP(pp_leavesublv) } } } - else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */ + else if (CxLVAL(cx)) { /* Leave it as it is if we can. */ /* Here we go for robustness, not for speed, so we change all * the refcounts so the caller gets a live guy. Cannot set * TEMP, so sv_2mortal is out of question. */ @@ -2807,13 +2816,9 @@ try_autoload: * stuff so that __WARN__ handlers can safely dounwind() * if they want to */ - if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) + if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION) && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) sub_crush_depth(cv); -#if 0 - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv))); -#endif RETURNOP(CvSTART(cv)); } else { @@ -2862,6 +2867,8 @@ try_autoload: void Perl_sub_crush_depth(pTHX_ CV *cv) { + PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH; + if (CvANON(cv)) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { @@ -2935,6 +2942,8 @@ PP(pp_aelem) void Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) { + PERL_ARGS_ASSERT_VIVIFY_REF; + SvGETMAGIC(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) @@ -2997,6 +3006,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp) const char * const name = SvPV_const(meth, namelen); SV * const sv = *(PL_stack_base + TOPMARK + 1); + PERL_ARGS_ASSERT_METHOD_COMMON; + if (!sv) Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);