X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=d812e95644e467a70c30ea07c082df2f754fe2e5;hb=ea726b52599b52cf534201a46ec3455418c9eb8e;hp=4e28a1248704f63bf7685676f945d106d2fa4a20;hpb=267cc4a8114e05742ba94bb40aa5728a5cfaa166;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 4e28a12..d812e95 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,7 +1,7 @@ /* pp_hot.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -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. */ - mXPUSHs((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; @@ -321,8 +307,8 @@ PP(pp_readline) dVAR; tryAMAGICunTARGET(iter, 0); PL_last_in_gv = (GV*)(*PL_stack_sp--); - if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { - if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) + if (!isGV_with_GP(PL_last_in_gv)) { + if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); else { dSP; @@ -411,7 +397,7 @@ PP(pp_eq) PP(pp_preinc) { dVAR; dSP; - if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) DIE(aTHX_ PL_no_modify); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -815,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; @@ -835,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; } @@ -852,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; } @@ -862,7 +843,7 @@ PP(pp_rv2av) else { GV *gv; - if (SvTYPE(sv) != SVt_PVGV) { + if (!isGV_with_GP(sv)) { if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -885,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; } @@ -931,18 +910,26 @@ PP(pp_rv2av) } else if (gimme == G_SCALAR) { dTARGET; - TARG = Perl_hv_scalar(aTHX_ (HV*)sv); + TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv)); SPAGAIN; SETTARG; } } 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; @@ -1033,8 +1020,14 @@ PP(pp_aassign) *(relem++) = sv; didstore = av_store(ary,i++,sv); if (magic) { - if (SvSMAGICAL(sv)) + if (SvSMAGICAL(sv)) { + /* More magic can happen in the mg_set callback, so we + * backup the delaymagic for now. */ + U16 dmbak = PL_delaymagic; + PL_delaymagic = 0; mg_set(sv); + PL_delaymagic = dmbak; + } if (!didstore) sv_2mortal(sv); } @@ -1046,7 +1039,7 @@ PP(pp_aassign) case SVt_PVHV: { /* normal hash */ SV *tmpstr; - hash = (HV*)sv; + hash = MUTABLE_HV(sv); magic = SvMAGICAL(hash) != 0; hv_clear(hash); firsthashrelem = relem; @@ -1064,8 +1057,12 @@ PP(pp_aassign) duplicates += 2; didstore = hv_store_ent(hash,sv,tmpstr,0); if (magic) { - if (SvSMAGICAL(tmpstr)) + if (SvSMAGICAL(tmpstr)) { + U16 dmbak = PL_delaymagic; + PL_delaymagic = 0; mg_set(tmpstr); + PL_delaymagic = dmbak; + } if (!didstore) sv_2mortal(tmpstr); } @@ -1089,7 +1086,13 @@ PP(pp_aassign) } else sv_setsv(sv, &PL_sv_undef); - SvSETMAGIC(sv); + + if (SvSMAGICAL(sv)) { + U16 dmbak = PL_delaymagic; + PL_delaymagic = 0; + mg_set(sv); + PL_delaymagic = dmbak; + } break; } } @@ -1209,6 +1212,7 @@ PP(pp_qr) if (pkg) { HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD); + SvREFCNT_dec(pkg); (void)sv_bless(rv, stash); } @@ -1765,7 +1769,7 @@ PP(pp_helem) HE* he; SV **svp; SV * const keysv = POPs; - HV * const hv = (HV*)POPs; + HV * const hv = MUTABLE_HV(POPs); const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; const U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; @@ -1902,8 +1906,9 @@ 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]; @@ -1911,17 +1916,14 @@ PP(pp_iter) DIE(aTHX_ "panic: pp_iter"); itersvp = CxITERVAR(cx); - av = (CxTYPE(cx) == CXt_LOOP_STACK) - ? PL_curstack : cx->blk_loop.ary_min_u.iterary; - if (SvTYPE(av) != SVt_PVAV) { - /* iterate ($min .. $max) */ - if (CxTYPE(cx) != CXt_LOOP_LAZYIV) { + if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { /* string increment */ - register SV* cur = cx->blk_loop.lval_max_u.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 = SvPV_const((SV*)av, maxlen); + const char *max = SvPV_const(end, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ @@ -1943,15 +1945,16 @@ PP(pp_iter) RETPUSHYES; } RETPUSHNO; - } + } + else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) { /* integer increment */ - if (cx->blk_loop.iterix > cx->blk_loop.lval_max_u.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 { @@ -1959,47 +1962,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.iterix == IV_MIN) && - (cx->blk_loop.lval_max_u.itermax == IV_MAX)) + if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) && + (cx->blk_loop.state_u.lazyiv.end == IV_MAX)) { - cx->blk_loop.iterix++; - cx->blk_loop.lval_max_u.itermax++; + 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 <= (CxTYPE(cx) == CXt_LOOP_STACK - ? cx->blk_loop.ary_min_u.itermin : 0)) + 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]; } } @@ -2008,31 +2016,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.lval_max_u.iterlval; - if (lv && SvREFCNT(lv) > 1) { - SvREFCNT_dec(lv); - lv = NULL; - } - if (lv) - SvREFCNT_dec(LvTARG(lv)); - else { - lv = cx->blk_loop.lval_max_u.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; @@ -2665,6 +2666,8 @@ PP(pp_entersub) switch (SvTYPE(sv)) { /* This is overwhelming the most common case: */ case SVt_PVGV: + if (!isGV_with_GP(sv)) + DIE(aTHX_ "Not a CODE reference"); if (!(cv = GvCVu((GV*)sv))) { HV *stash; cv = sv_2cv(sv, &stash, &gv, 0); @@ -2711,7 +2714,7 @@ PP(pp_entersub) SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); } - cv = (CV*)SvRV(sv); + cv = MUTABLE_CV(SvRV(sv)); if (SvTYPE(cv) == SVt_PVCV) break; /* FALL THROUGH */ @@ -2720,7 +2723,7 @@ PP(pp_entersub) DIE(aTHX_ "Not a CODE reference"); /* This is the second most common case: */ case SVt_PVCV: - cv = (CV*)sv; + cv = MUTABLE_CV(sv); break; } @@ -2835,10 +2838,6 @@ try_autoload: 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 { @@ -2887,6 +2886,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 { @@ -2960,6 +2961,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)) @@ -3022,6 +3025,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); @@ -3072,7 +3077,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) /* if we got here, ob should be a reference or a glob */ if (!ob || !(SvOBJECT(ob) - || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) + || (SvTYPE(ob) == SVt_PVGV + && isGV_with_GP(ob) + && (ob = (SV*)GvIO((GV*)ob)) && SvOBJECT(ob)))) { Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", @@ -3098,81 +3105,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } } - gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name); - - if (!gv) { - /* This code tries to figure out just what went wrong with - gv_fetchmethod. It therefore needs to duplicate a lot of - the internals of that function. We can't move it inside - Perl_gv_fetchmethod_autoload(), however, since that would - cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we - don't want that. - */ - const char* leaf = name; - const char* sep = NULL; - const char* p; - - for (p = name; *p; p++) { - if (*p == '\'') - sep = p, leaf = p + 1; - else if (*p == ':' && *(p + 1) == ':') - sep = p, leaf = p + 2; - } - if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - /* the method name is unqualified or starts with SUPER:: */ -#ifndef USE_ITHREADS - if (sep) - stash = CopSTASH(PL_curcop); -#else - bool need_strlen = 1; - if (sep) { - packname = CopSTASHPV(PL_curcop); - } - else -#endif - if (stash) { - HEK * const packhek = HvNAME_HEK(stash); - if (packhek) { - packname = HEK_KEY(packhek); - packlen = HEK_LEN(packhek); -#ifdef USE_ITHREADS - need_strlen = 0; -#endif - } else { - goto croak; - } - } + gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name, + GV_AUTOLOAD | GV_CROAK); - if (!packname) { - croak: - Perl_croak(aTHX_ - "Can't use anonymous symbol table for method lookup"); - } -#ifdef USE_ITHREADS - if (need_strlen) - packlen = strlen(packname); -#endif + assert(gv); - } - else { - /* the method name is qualified */ - packname = name; - packlen = sep - name; - } - - /* we're relying on gv_fetchmethod not autovivifying the stash */ - if (gv_stashpvn(packname, packlen, 0)) { - Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%.*s\"", - leaf, (int)packlen, packname); - } - else { - Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%.*s\"" - " (perhaps you forgot to load \"%.*s\"?)", - leaf, (int)packlen, packname, (int)packlen, packname); - } - } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; }