X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=7e327d46da0830e41ea5e42480b6df2f64324062;hb=2e5b91de24d62e1e2bf0fd32a1d4d1d849cafc82;hp=c509b03aa516a0613ecd78d280657fdb891b9aff;hpb=60df1e0753f7a21c84e0a9019d61680abb79d154;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index c509b03..7e327d4 100644 --- a/sv.c +++ b/sv.c @@ -904,6 +904,9 @@ static const struct body_details bodies_by_type[] = { /* RVs are in the head now. */ { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 }, + /* The bind placeholder pretends to be an RV for now. */ + { 0, 0, 0, SVt_BIND, FALSE, NONV, NOARENA, 0 }, + /* 8 bytes on most ILP32 with IEEE doubles */ { sizeof(xpv_allocated), copy_length(XPV, xpv_len) @@ -926,10 +929,6 @@ static const struct body_details bodies_by_type[] = { { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - /* 36 */ - { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV, - HASARENA, FIT_ARENA(0, sizeof(XPVBM)) }, - /* 48 */ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, @@ -1293,7 +1292,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) assert(!SvNOK(sv)); case SVt_PVIO: case SVt_PVFM: - case SVt_PVBM: case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: @@ -1558,8 +1556,6 @@ Like C, but also handles 'set' magic. void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { - sv_setiv(sv, 0); - SvIsUV_on(sv); sv_setuv(sv,u); SvSETMAGIC(sv); } @@ -2161,7 +2157,11 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) dVAR; if (!sv) return 0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. In practice it seems that they never + actually anywhere accessible by user Perl code, let alone get used + in anything other than a string context. */ if (flags & SV_GMAGIC) mg_get(sv); if (SvIOKp(sv)) @@ -2241,7 +2241,9 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) dVAR; if (!sv) return 0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. */ if (flags & SV_GMAGIC) mg_get(sv); if (SvIOKp(sv)) @@ -2316,7 +2318,9 @@ Perl_sv_2nv(pTHX_ register SV *sv) dVAR; if (!sv) return 0.0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. */ mg_get(sv); if (SvNOKp(sv)) return SvNVX(sv); @@ -2746,7 +2750,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { /* I'm assuming that if both IV and NV are equally valid then converting the IV is going to be more efficient */ - const U32 isIOK = SvIOK(sv); const U32 isUIOK = SvIsUV(sv); char buf[TYPE_CHARS(UV)]; char *ebuf, *ptr; @@ -2760,12 +2763,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); *s = '\0'; - if (isIOK) - SvIOK_on(sv); - else - SvIOKp_on(sv); - if (isUIOK) - SvIsUV_on(sv); } else if (SvNOKp(sv)) { const int olderrno = errno; @@ -3180,7 +3177,9 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } sv_upgrade(dstr, SVt_PVGV); (void)SvOK_off(dstr); - SvSCREAM_on(dstr); + /* FIXME - why are we doing this, then turning it off and on again + below? */ + isGV_with_GP_on(dstr); } GvSTASH(dstr) = GvSTASH(sstr); if (GvSTASH(dstr)) @@ -3196,9 +3195,9 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) #endif gp_free((GV*)dstr); - SvSCREAM_off(dstr); + isGV_with_GP_off(dstr); (void)SvOK_off(dstr); - SvSCREAM_on(dstr); + isGV_with_GP_on(dstr); GvINTRO_off(dstr); /* one-shot flag */ GvGP(dstr) = gp_ref(GvGP(sstr)); if (SvTAINTED(sstr)) @@ -3377,6 +3376,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PV: sv_upgrade(dstr, SVt_PVIV); break; + case SVt_PVGV: + goto end_of_first_switch; } (void)SvIOK_only(dstr); SvIV_set(dstr, SvIVX(sstr)); @@ -3403,6 +3404,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PVIV: sv_upgrade(dstr, SVt_PVNV); break; + case SVt_PVGV: + goto end_of_first_switch; } SvNV_set(dstr, SvNVX(sstr)); (void)SvNOK_only(dstr); @@ -3450,21 +3453,22 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } break; + /* case SVt_BIND: */ case SVt_PVGV: - if (dtype <= SVt_PVGV) { + if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) { glob_assign_glob(dstr, sstr, dtype); return; } + /* SvVALID means that this PVGV is playing at being an FBM. */ /*FALLTHROUGH*/ case SVt_PVMG: case SVt_PVLV: - case SVt_PVBM: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); if (SvTYPE(sstr) != stype) { stype = SvTYPE(sstr); - if (stype == SVt_PVGV && dtype <= SVt_PVGV) { + if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) { glob_assign_glob(dstr, sstr, dtype); return; } @@ -3475,14 +3479,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) else SvUPGRADE(dstr, (svtype)stype); } + end_of_first_switch: /* dstr may have been upgraded. */ dtype = SvTYPE(dstr); sflags = SvFLAGS(sstr); - if (sflags & SVf_ROK) { - if (dtype == SVt_PVGV && - SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) { + if (dtype == SVt_PVCV) { + /* Assigning to a subroutine sets the prototype. */ + if (SvOK(sstr)) { + STRLEN len; + const char *const ptr = SvPV_const(sstr, len); + + SvGROW(dstr, len + 1); + Copy(ptr, SvPVX(dstr), len + 1, char); + SvCUR_set(dstr, len); + SvPOK_only(dstr); + } else { + SvOK_off(dstr); + } + } else if (sflags & SVf_ROK) { + if (isGV_with_GP(dstr) && dtype == SVt_PVGV + && SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); if (sstr == dstr) { if (GvIMPORTED(dstr) != GVf_IMPORTED @@ -3516,7 +3534,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) assert(!(sflags & SVf_NOK)); assert(!(sflags & SVf_IOK)); } - else if (dtype == SVt_PVGV) { + else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { if (!(sflags & SVf_OK)) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), @@ -5090,7 +5108,7 @@ Perl_sv_clear(pTHX_ register SV *sv) } } if (type >= SVt_PVMG) { - if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) { + if (type == SVt_PVMG && SvPAD_OUR(sv)) { SvREFCNT_dec(OURSTASH(sv)); } else if (SvMAGIC(sv)) mg_free(sv); @@ -5098,6 +5116,7 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREFCNT_dec(SvSTASH(sv)); } switch (type) { + /* case SVt_BIND: */ case SVt_PVIO: if (IoIFP(sv) && IoIFP(sv) != PerlIO_stdin() && @@ -5113,8 +5132,6 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); goto freescalar; - case SVt_PVBM: - goto freescalar; case SVt_PVCV: case SVt_PVFM: cv_undef((CV*)sv); @@ -5136,14 +5153,15 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREFCNT_dec(LvTARG(sv)); goto freescalar; case SVt_PVGV: - gp_free((GV*)sv); - if (GvNAME_HEK(sv)) { - unshare_hek(GvNAME_HEK(sv)); - } + if (isGV_with_GP(sv)) { + gp_free((GV*)sv); + if (GvNAME_HEK(sv)) + unshare_hek(GvNAME_HEK(sv)); /* If we're in a stash, we don't own a reference to it. However it does have a back reference to us, which needs to be cleared. */ - if (GvSTASH(sv)) - sv_del_backref((SV*)GvSTASH(sv), sv); + if (!SvVALID(sv) && GvSTASH(sv)) + sv_del_backref((SV*)GvSTASH(sv), sv); + } case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -7620,7 +7638,6 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVIV: case SVt_PVNV: case SVt_PVMG: - case SVt_PVBM: if (SvVOK(sv)) return "VSTRING"; if (SvROK(sv)) @@ -7639,6 +7656,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVGV: return "GLOB"; case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; + case SVt_BIND: return "BIND"; default: return "UNKNOWN"; } } @@ -7930,7 +7948,7 @@ S_sv_unglob(pTHX_ SV *sv) if (GvNAME_HEK(sv)) { unshare_hek(GvNAME_HEK(sv)); } - SvSCREAM_off(sv); + isGV_with_GP_off(sv); /* need to keep SvANY(sv) in the right arena */ xpvmg = new_XPVMG(); @@ -9460,15 +9478,6 @@ ptr_table_* functions. #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) -/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in - regcomp.c. AMS 20010712 */ - -REGEXP * -Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) -{ - return CALLREGDUPE(r,param); -} - /* duplicate a file handle */ PerlIO * @@ -9563,7 +9572,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; if (mg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param); + nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param); } else if(mg->mg_type == PERL_MAGIC_backref) { /* The backref AV has its reference count deliberately bumped by @@ -9869,6 +9878,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) SvANY(dstr) = &(dstr->sv_u.svu_rv); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; + /* case SVt_BIND: */ default: { /* These are all the types that need complex bodies allocating. */ @@ -9890,7 +9900,6 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVFM: case SVt_PVHV: case SVt_PVAV: - case SVt_PVBM: case SVt_PVCV: case SVt_PVLV: case SVt_PVMG: @@ -9947,8 +9956,6 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) break; case SVt_PVMG: break; - case SVt_PVBM: - break; case SVt_PVLV: /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ @@ -9959,12 +9966,15 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); break; case SVt_PVGV: - if (GvNAME_HEK(dstr)) - GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); + if(isGV_with_GP(sstr)) { + if (GvNAME_HEK(dstr)) + GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); + } /* Don't call sv_add_backref here as it's going to be created as part of the magic cloning of the symbol table. */ - GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); + if(!SvVALID(dstr)) + GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); if(isGV_with_GP(sstr)) { /* Danger Will Robinson - GvGP(dstr) isn't initialised at the point of this comment. */ @@ -10418,7 +10428,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case OP_LEAVEWRITE: TOPPTR(nss,ix) = ptr; o = (OP*)ptr; + OP_REFCNT_LOCK; OpREFCNT_inc(o); + OP_REFCNT_UNLOCK; break; default: TOPPTR(nss,ix) = NULL; @@ -10923,7 +10935,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREPADTMP(regex) ? sv_dup_inc(regex, param) : SvREFCNT_inc( - newSViv(PTR2IV(re_dup( + newSViv(PTR2IV(CALLREGDUPE( INT2PTR(REGEXP *, SvIVX(regex)), param)))) ; av_push(PL_regex_padav, sv); @@ -10990,7 +11002,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* current interpreter roots */ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); + OP_REFCNT_LOCK; PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); + OP_REFCNT_UNLOCK; PL_main_start = proto_perl->Imain_start; PL_eval_root = proto_perl->Ieval_root; PL_eval_start = proto_perl->Ieval_start;