X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=6fb53d49a4c303f56b0e43e120d41c02b6594312;hb=ce5e090c3cdc0df8112cc707442a0492b20b168b;hp=dabdc97c66adad7a9a2a1c677cbf09188538a567;hpb=dc3c76f8b4fe904265e159454587697a06e6e98a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index dabdc97..6fb53d4 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -39,7 +39,14 @@ PP(pp_const) { dVAR; dSP; - XPUSHs(cSVOP_sv); + 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); RETURN; } @@ -120,12 +127,6 @@ PP(pp_sassign) SV * const temp = left; left = right; right = temp; } - else if (PL_op->op_private & OPpASSIGN_STATE) { - if (SvPADSTALE(right)) - SvPADSTALE_off(right); - else - RETURN; /* ignore assignment */ - } if (PL_tainting && PL_tainted && !SvTAINTED(left)) TAINT_NOT; if (PL_op->op_private & OPpASSIGN_CV_TO_GV) { @@ -167,23 +168,44 @@ PP(pp_sassign) if (!got_coderef) { /* We've been returned a constant rather than a full subroutine, but they expect a subroutine reference to apply. */ - ENTER; - SvREFCNT_inc_void(SvRV(cv)); - /* newCONSTSUB takes a reference count on the passed in SV - from us. We set the name to NULL, otherwise we get into - all sorts of fun as the reference to our new sub is - donated to the GV that we're about to assign to. - */ - SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL, + if (SvROK(cv)) { + ENTER; + SvREFCNT_inc_void(SvRV(cv)); + /* newCONSTSUB takes a reference count on the passed in SV + from us. We set the name to NULL, otherwise we get into + all sorts of fun as the reference to our new sub is + donated to the GV that we're about to assign to. + */ + SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL, SvRV(cv))); - SvREFCNT_dec(cv); - LEAVE; - } + SvREFCNT_dec(cv); + LEAVE; + } else { + /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; + is that + First: ops for \&{"BONK"}; return us the constant in the + symbol table + Second: ops for *{"BONK"} cause that symbol table entry + (and our reference to it) to be upgraded from RV + to typeblob) + Thirdly: We get here. cv is actually PVGV now, and its + GvCV() is actually the subroutine we're looking for + + So change the reference so that it points to the subroutine + of that typeglob, as that's what they were after all along. + */ + GV *const upgraded = (GV *) cv; + CV *const source = GvCV(upgraded); - if (strEQ(GvNAME(right),"isa")) { - GvCVGEN(right) = 0; - ++PL_sub_generation; + assert(source); + assert(CvFLAGS(source) & CVf_CONST); + + SvREFCNT_inc_void(source); + SvREFCNT_dec(upgraded); + SvRV_set(left, (SV *)source); + } } + } SvSetMagicSV(right, left); SETs(right); @@ -430,12 +452,13 @@ PP(pp_defined) --SP; RETURNOP(cLOGOP->op_other); } - } else if (op_type == OP_DEFINED) { + } + else { + /* OP_DEFINED */ sv = POPs; if (!sv || !SvANY(sv)) RETPUSHNO; - } else - DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op)); + } defined = FALSE; switch (SvTYPE(sv)) { @@ -788,7 +811,7 @@ PP(pp_rv2av) 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; - const U32 type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV; + const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV; if (SvROK(sv)) { wasref: @@ -900,6 +923,7 @@ PP(pp_rv2av) else if (gimme == G_SCALAR) { dTARGET; TARG = Perl_hv_scalar(aTHX_ (HV*)sv); + SPAGAIN; SETTARG; } } @@ -961,7 +985,6 @@ PP(pp_aassign) int duplicates = 0; SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */ - PL_delaymagic = DM_DELAY; /* catch simultaneous items */ gimme = GIMME_V; @@ -978,12 +1001,6 @@ PP(pp_aassign) } } } - if (PL_op->op_private & OPpASSIGN_STATE) { - if (SvPADSTALE(*firstlelem)) - SvPADSTALE_off(*firstlelem); - else - RETURN; /* ignore assignment */ - } relem = firstrelem; lelem = firstlelem; @@ -1014,6 +1031,8 @@ PP(pp_aassign) } TAINT_NOT; } + if (PL_delaymagic & DM_ARRAY) + SvSETMAGIC((SV*)ary); break; case SVt_PVHV: { /* normal hash */ SV *tmpstr; @@ -1160,6 +1179,7 @@ PP(pp_aassign) while (relem <= SP) *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; } + RETURN; } @@ -1167,12 +1187,15 @@ PP(pp_qr) { dVAR; dSP; register PMOP * const pm = cPMOP; + REGEXP * rx = PM_GETRE(pm); + SV * const pkg = CALLREG_PACKAGE(rx); SV * const rv = sv_newmortal(); - SV * const sv = newSVrv(rv, "Regexp"); - if (pm->op_pmdynflags & PMdf_TAINTED) + SV * const sv = newSVrv(rv, SvPV_nolen(pkg)); + if (rx->extflags & RXf_TAINTED) SvTAINTED_on(rv); - sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); - RETURNX(PUSHs(rv)); + sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0); + XPUSHs(rv); + RETURN; } PP(pp_match) @@ -1210,20 +1233,28 @@ PP(pp_match) if (!s) DIE(aTHX_ "panic: pp_match"); strend = s + len; - rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + rxtainted = ((rx->extflags & RXf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); /* PMdf_USED is set after a ?? matches once */ - if (pm->op_pmdynflags & PMdf_USED) { + if ( +#ifdef USE_ITHREADS + SvREADONLY(PL_regex_pad[pm->op_pmoffset]) +#else + pm->op_pmflags & PMf_USED +#endif + ) { failure: if (gimme == G_ARRAY) RETURN; RETPUSHNO; } + + /* empty pattern special-cased to use last successful pattern if possible */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; @@ -1237,36 +1268,39 @@ PP(pp_match) /* XXXX What part of this is needed with true \G-support? */ if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { - rx->startp[0] = -1; + rx->offs[0].start = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global); if (mg && mg->mg_len >= 0) { if (!(rx->extflags & RXf_GPOS_SEEN)) - rx->endp[0] = rx->startp[0] = mg->mg_len; + rx->offs[0].end = rx->offs[0].start = mg->mg_len; else if (rx->extflags & RXf_ANCH_GPOS) { r_flags |= REXEC_IGNOREPOS; - rx->endp[0] = rx->startp[0] = mg->mg_len; + rx->offs[0].end = rx->offs[0].start = mg->mg_len; } else if (rx->extflags & RXf_GPOS_FLOAT) gpos = mg->mg_len; else - rx->endp[0] = rx->startp[0] = mg->mg_len; + rx->offs[0].end = rx->offs[0].start = mg->mg_len; minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0; update_minmatch = 0; } } } - /* remove comment to get faster /g but possibly unsafe $1 vars after a - match. Test for the unsafe vars will fail as well*/ - if (( /* !global && */ rx->nparens) + /* XXX: comment out !global get safe $1 vars after a + match, BUT be aware that this leads to dramatic slowdowns on + /g matches against large strings. So far a solution to this problem + appears to be quite tricky. + Test for the unsafe vars are TODO for now. */ + if (( !global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand || - (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY))) + (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))) r_flags |= REXEC_COPY_STR; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; play_it_again: - if (global && rx->startp[0] != -1) { - t = s = rx->endp[0] + truebase - rx->gofs; + if (global && rx->offs[0].start != -1) { + t = s = rx->offs[0].end + truebase - rx->gofs; if ((s + rx->minlen) > strend || s < truebase) goto nope; if (update_minmatch++) @@ -1282,7 +1316,7 @@ play_it_again: goto nope; if ( (rx->extflags & RXf_CHECK_ALL) && !PL_sawampersand - && !(pm->op_pmflags & PMf_KEEPCOPY) + && !(rx->extflags & RXf_PMf_KEEPCOPY) && ((rx->extflags & RXf_NOSCAN) || !((rx->extflags & RXf_INTUIT_TAIL) && (r_flags & REXEC_SCREAM))) @@ -1292,8 +1326,13 @@ play_it_again: if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags)) { PL_curpm = pm; - if (dynpm->op_pmflags & PMf_ONCE) - dynpm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) { +#ifdef USE_ITHREADS + SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); +#else + dynpm->op_pmflags |= PMf_USED; +#endif + } goto gotcha; } else @@ -1313,10 +1352,10 @@ play_it_again: EXTEND_MORTAL(nparens + i); for (i = !i; i <= nparens; i++) { PUSHs(sv_newmortal()); - if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { - const I32 len = rx->endp[i] - rx->startp[i]; - s = rx->startp[i] + truebase; - if (rx->endp[i] < 0 || rx->startp[i] < 0 || + if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) { + const I32 len = rx->offs[i].end - rx->offs[i].start; + s = rx->offs[i].start + truebase; + if (rx->offs[i].end < 0 || rx->offs[i].start < 0 || len < 0 || len > strend - s) DIE(aTHX_ "panic: pp_match start/end pointers"); sv_setpvn(*SP, s, len); @@ -1337,16 +1376,17 @@ play_it_again: mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, NULL, 0); } - if (rx->startp[0] != -1) { - mg->mg_len = rx->endp[0]; - if (rx->startp[0] + rx->gofs == (UV)rx->endp[0]) + if (rx->offs[0].start != -1) { + mg->mg_len = rx->offs[0].end; + if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; } } - had_zerolen = (rx->startp[0] != -1 - && rx->startp[0] + rx->gofs == (UV)rx->endp[0]); + had_zerolen = (rx->offs[0].start != -1 + && (rx->offs[0].start + rx->gofs + == (UV)rx->offs[0].end)); PUTBACK; /* EVAL blocks may use stack */ r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; @@ -1371,9 +1411,9 @@ play_it_again: mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, NULL, 0); } - if (rx->startp[0] != -1) { - mg->mg_len = rx->endp[0]; - if (rx->startp[0] + rx->gofs == (UV)rx->endp[0]) + if (rx->offs[0].start != -1) { + mg->mg_len = rx->offs[0].end; + if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; @@ -1388,8 +1428,13 @@ yup: /* Confirmed by INTUIT */ RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); PL_curpm = pm; - if (dynpm->op_pmflags & PMf_ONCE) - dynpm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) { +#ifdef USE_ITHREADS + SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); +#else + dynpm->op_pmflags |= PMf_USED; +#endif + } if (RX_MATCH_COPIED(rx)) Safefree(rx->subbeg); RX_MATCH_COPIED_off(rx); @@ -1397,18 +1442,18 @@ yup: /* Confirmed by INTUIT */ if (global) { /* FIXME - should rx->subbeg be const char *? */ rx->subbeg = (char *) truebase; - rx->startp[0] = s - truebase; + rx->offs[0].start = s - truebase; if (RX_MATCH_UTF8(rx)) { char * const t = (char*)utf8_hop((U8*)s, rx->minlenret); - rx->endp[0] = t - truebase; + rx->offs[0].end = t - truebase; } else { - rx->endp[0] = s - truebase + rx->minlenret; + rx->offs[0].end = s - truebase + rx->minlenret; } rx->sublen = strend - truebase; goto gotcha; } - if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) { + if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) { I32 off; #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) { @@ -1432,12 +1477,12 @@ yup: /* Confirmed by INTUIT */ } rx->sublen = strend - t; RX_MATCH_COPIED_on(rx); - off = rx->startp[0] = s - t; - rx->endp[0] = off + rx->minlenret; + off = rx->offs[0].start = s - t; + rx->offs[0].end = off + rx->minlenret; } else { /* startp/endp are used by @- @+. */ - rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + rx->minlenret; + rx->offs[0].start = s - truebase; + rx->offs[0].end = s - truebase + rx->minlenret; } /* including rx->nparens in the below code seems highly suspicious. -dmq */ @@ -1943,8 +1988,7 @@ PP(pp_iter) if (lv) SvREFCNT_dec(LvTARG(lv)); else { - lv = cx->blk_loop.iterlval = newSV(0); - sv_upgrade(lv, SVt_PVLV); + lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV); LvTYPE(lv) = 'y'; sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); } @@ -2023,7 +2067,7 @@ PP(pp_subst) s = SvPV_mutable(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; - rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + rxtainted = ((rx->extflags & RXf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); if (PL_tainted) rxtainted |= 2; @@ -2046,7 +2090,7 @@ PP(pp_subst) rx = PM_GETRE(pm); } r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand - || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) ) + || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) ) ? REXEC_COPY_STR : 0; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; @@ -2061,7 +2105,7 @@ PP(pp_subst) /* How to do it in subst? */ /* if ( (rx->extflags & RXf_CHECK_ALL) && !PL_sawampersand - && !(pm->op_pmflags & PMf_KEEPCOPY) + && !(rx->extflags & RXf_KEEPCOPY) && ((rx->extflags & RXf_NOSCAN) || !((rx->extflags & RXf_INTUIT_TAIL) && (r_flags & REXEC_SCREAM)))) @@ -2127,8 +2171,8 @@ PP(pp_subst) SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { rxtainted |= RX_MATCH_TAINTED(rx); - m = orig + rx->startp[0]; - d = orig + rx->endp[0]; + m = orig + rx->offs[0].start; + d = orig + rx->offs[0].end; s = orig; if (m - s > strend - d) { /* faster to shorten from end */ if (clen) { @@ -2170,7 +2214,7 @@ PP(pp_subst) if (iters++ > maxiters) DIE(aTHX_ "Substitution loop"); rxtainted |= RX_MATCH_TAINTED(rx); - m = rx->startp[0] + orig; + m = rx->offs[0].start + orig; if ((i = m - s)) { if (s != d) Move(s, d, i, char); @@ -2180,7 +2224,7 @@ PP(pp_subst) Copy(c, d, clen, char); d += clen; } - s = rx->endp[0] + orig; + s = rx->offs[0].end + orig; } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, /* don't match same null twice */ @@ -2229,7 +2273,7 @@ PP(pp_subst) register PERL_CONTEXT *cx; SPAGAIN; PUSHSUBST(cx); - RETURNOP(cPMOP->op_pmreplroot); + RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); } r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; do { @@ -2243,12 +2287,12 @@ PP(pp_subst) s = orig + (m - s); strend = s + (strend - m); } - m = rx->startp[0] + orig; + m = rx->offs[0].start + orig; if (doutf8 && !SvUTF8(dstr)) sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); else sv_catpvn(dstr, s, m-s); - s = rx->endp[0] + orig; + s = rx->offs[0].end + orig; if (clen) sv_catpvn(dstr, c, clen); if (once) @@ -2689,9 +2733,6 @@ try_autoload: gimme = GIMME_V; if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { - if (CvASSERTION(cv) && PL_DBassertion) - sv_setiv(PL_DBassertion, 1); - Perl_get_db_sub(aTHX_ &sv, cv); if (CvISXSUB(cv)) PL_curcopdb = PL_curcop; @@ -2993,12 +3034,12 @@ S_method_common(pTHX_ SV* meth, U32* hashp) : "on an undefined value"); } /* assume it's a package name */ - stash = gv_stashpvn(packname, packlen, FALSE); + stash = gv_stashpvn(packname, packlen, 0); if (!stash) packsv = sv; else { SV* const ref = newSViv(PTR2IV(stash)); - hv_store(PL_stashcache, packname, packlen, ref, 0); + (void)hv_store(PL_stashcache, packname, packlen, ref, 0); } goto fetch; } @@ -3012,6 +3053,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) && SvOBJECT(ob)))) { Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", + (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" : name); } @@ -3027,7 +3069,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp) if (he) { gv = (GV*)HeVAL(he); if (isGV(gv) && GvCV(gv) && - (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation)) + (!GvCVGEN(gv) || GvCVGEN(gv) + == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) return (SV*)GvCV(gv); } } @@ -3085,7 +3128,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } /* we're relying on gv_fetchmethod not autovivifying the stash */ - if (gv_stashpvn(packname, packlen, FALSE)) { + if (gv_stashpvn(packname, packlen, 0)) { Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", leaf, (int)packlen, packname);