From: Gurusamy Sarathy Date: Mon, 10 May 1999 19:33:36 +0000 (+0000) Subject: "weak" references internals, still needs perlguts documentation X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=810b8aa5436a934d1a2016588cbacf9b55463c40;p=p5sagit%2Fp5-mst-13.2.git "weak" references internals, still needs perlguts documentation (somewhat modified version of patch suggested by Tuomas J. Lukka ) p4raw-id: //depot/perl@3385 --- diff --git a/dump.c b/dump.c index 811fe78..cb3a643 100644 --- a/dump.c +++ b/dump.c @@ -638,6 +638,7 @@ do_magic_dump(I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool du #endif else if (v == &PL_vtbl_amagic) s = "amagic"; else if (v == &PL_vtbl_amagicelem) s = "amagicelem"; + else if (v == &PL_vtbl_backref) s = "backref"; if (s) dump_indent(level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s); else @@ -766,7 +767,10 @@ do_sv_dump(I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, if (flags & SVf_IOK) sv_catpv(d, "IOK,"); if (flags & SVf_NOK) sv_catpv(d, "NOK,"); if (flags & SVf_POK) sv_catpv(d, "POK,"); - if (flags & SVf_ROK) sv_catpv(d, "ROK,"); + if (flags & SVf_ROK) { + sv_catpv(d, "ROK,"); + if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,"); + } if (flags & SVf_OOK) sv_catpv(d, "OOK,"); if (flags & SVf_FAKE) sv_catpv(d, "FAKE,"); if (flags & SVf_READONLY) sv_catpv(d, "READONLY,"); diff --git a/embed.h b/embed.h index 011cc68..2386993 100644 --- a/embed.h +++ b/embed.h @@ -271,6 +271,7 @@ #define magic_gettaint Perl_magic_gettaint #define magic_getuvar Perl_magic_getuvar #define magic_getvec Perl_magic_getvec +#define magic_killbackrefs Perl_magic_killbackrefs #define magic_len Perl_magic_len #define magic_mutexfree Perl_magic_mutexfree #define magic_nextpack Perl_magic_nextpack @@ -896,6 +897,7 @@ #define sv_replace Perl_sv_replace #define sv_report_used Perl_sv_report_used #define sv_reset Perl_sv_reset +#define sv_rvweaken Perl_sv_rvweaken #define sv_setiv Perl_sv_setiv #define sv_setiv_mg Perl_sv_setiv_mg #define sv_setnv Perl_sv_setnv @@ -1314,6 +1316,7 @@ #define magic_gettaint CPerlObj::Perl_magic_gettaint #define magic_getuvar CPerlObj::Perl_magic_getuvar #define magic_getvec CPerlObj::Perl_magic_getvec +#define magic_killbackrefs CPerlObj::Perl_magic_killbackrefs #define magic_len CPerlObj::Perl_magic_len #define magic_methcall CPerlObj::Perl_magic_methcall #define magic_methcall CPerlObj::Perl_magic_methcall @@ -2008,6 +2011,7 @@ #define sv_2pv_nolen CPerlObj::Perl_sv_2pv_nolen #define sv_2uv CPerlObj::Perl_sv_2uv #define sv_add_arena CPerlObj::Perl_sv_add_arena +#define sv_add_backref CPerlObj::Perl_sv_add_backref #define sv_backoff CPerlObj::Perl_sv_backoff #define sv_bless CPerlObj::Perl_sv_bless #define sv_catpv CPerlObj::Perl_sv_catpv @@ -2027,6 +2031,7 @@ #define sv_collxfrm CPerlObj::Perl_sv_collxfrm #define sv_compile_2op CPerlObj::Perl_sv_compile_2op #define sv_dec CPerlObj::Perl_sv_dec +#define sv_del_backref CPerlObj::Perl_sv_del_backref #define sv_derived_from CPerlObj::Perl_sv_derived_from #define sv_dump CPerlObj::Perl_sv_dump #define sv_eq CPerlObj::Perl_sv_eq @@ -2059,6 +2064,7 @@ #define sv_replace CPerlObj::Perl_sv_replace #define sv_report_used CPerlObj::Perl_sv_report_used #define sv_reset CPerlObj::Perl_sv_reset +#define sv_rvweaken CPerlObj::Perl_sv_rvweaken #define sv_setiv CPerlObj::Perl_sv_setiv #define sv_setiv_mg CPerlObj::Perl_sv_setiv_mg #define sv_setnv CPerlObj::Perl_sv_setnv diff --git a/embed.pl b/embed.pl index 32c034f..19f68a9 100755 --- a/embed.pl +++ b/embed.pl @@ -376,6 +376,8 @@ my @staticfuncs = qw( new_logop simplify_sort is_handle_constructor + sv_add_backref + sv_del_backref do_trans_CC_simple do_trans_CC_count do_trans_CC_complex diff --git a/global.sym b/global.sym index 09520a9..55a8b8b 100644 --- a/global.sym +++ b/global.sym @@ -262,6 +262,7 @@ magic_getsubstr magic_gettaint magic_getuvar magic_getvec +magic_killbackrefs magic_len magic_mutexfree magic_nextpack @@ -543,6 +544,7 @@ sv_reftype sv_replace sv_report_used sv_reset +sv_rvweaken sv_setiv sv_setiv_mg sv_setnv diff --git a/mg.c b/mg.c index 3584dbc..9183104 100644 --- a/mg.c +++ b/mg.c @@ -1589,6 +1589,27 @@ vivify_defelem(SV *sv) } int +magic_killbackrefs(SV *sv, MAGIC *mg) +{ + AV *av = (AV*)mg->mg_obj; + SV **svp = AvARRAY(av); + I32 i = AvFILLp(av); + while (i >= 0) { + if (svp[i] && svp[i] != &PL_sv_undef) { + if (!SvWEAKREF(svp[i])) + croak("panic: magic_killbackrefs"); + /* XXX Should we check that it hasn't changed? */ + SvRV(svp[i]) = 0; + SvOK_off(svp[i]); + SvWEAKREF_off(svp[i]); + svp[i] = &PL_sv_undef; + } + i--; + } + return 0; +} + +int magic_setmglob(SV *sv, MAGIC *mg) { mg->mg_len = -1; diff --git a/objXSUB.h b/objXSUB.h index 6297e9f..69a891c 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -1489,6 +1489,8 @@ #define magic_getuvar pPerl->Perl_magic_getuvar #undef magic_getvec #define magic_getvec pPerl->Perl_magic_getvec +#undef magic_killbackrefs +#define magic_killbackrefs pPerl->Perl_magic_killbackrefs #undef magic_len #define magic_len pPerl->Perl_magic_len #undef magic_methcall @@ -2877,6 +2879,8 @@ #define sv_2uv pPerl->Perl_sv_2uv #undef sv_add_arena #define sv_add_arena pPerl->Perl_sv_add_arena +#undef sv_add_backref +#define sv_add_backref pPerl->Perl_sv_add_backref #undef sv_backoff #define sv_backoff pPerl->Perl_sv_backoff #undef sv_bless @@ -2915,6 +2919,8 @@ #define sv_compile_2op pPerl->Perl_sv_compile_2op #undef sv_dec #define sv_dec pPerl->Perl_sv_dec +#undef sv_del_backref +#define sv_del_backref pPerl->Perl_sv_del_backref #undef sv_derived_from #define sv_derived_from pPerl->Perl_sv_derived_from #undef sv_dump @@ -2979,6 +2985,8 @@ #define sv_report_used pPerl->Perl_sv_report_used #undef sv_reset #define sv_reset pPerl->Perl_sv_reset +#undef sv_rvweaken +#define sv_rvweaken pPerl->Perl_sv_rvweaken #undef sv_setiv #define sv_setiv pPerl->Perl_sv_setiv #undef sv_setiv_mg diff --git a/perl.h b/perl.h index e77e585..0acc213 100644 --- a/perl.h +++ b/perl.h @@ -2218,7 +2218,8 @@ enum { /* pass one of these to get_vtbl */ want_vtbl_mutex, #endif want_vtbl_regdata, - want_vtbl_regdatum + want_vtbl_regdatum, + want_vtbl_backref }; /* Note: the lowest 8 bits are reserved for @@ -2512,6 +2513,9 @@ EXT MGVTBL PL_vtbl_amagic = {0, magic_setamagic, EXT MGVTBL PL_vtbl_amagicelem = {0, magic_setamagic, 0, 0, magic_setamagic}; +EXT MGVTBL PL_vtbl_backref = {0, 0, + 0, 0, magic_killbackrefs}; + #else /* !DOINIT */ EXT MGVTBL PL_vtbl_sv; @@ -2552,6 +2556,8 @@ EXT MGVTBL PL_vtbl_collxfrm; EXT MGVTBL PL_vtbl_amagic; EXT MGVTBL PL_vtbl_amagicelem; +EXT MGVTBL PL_vtbl_backref; + #endif /* !DOINIT */ enum { diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 4b18882..b83b577 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -971,6 +971,11 @@ weren't. subscript. But to the left of the brackets was an expression that didn't look like an array reference, or anything else subscriptable. +=item Can't weaken a nonreference + +(F) You attempted to weaken something that was not a reference. Only +references can be weakened. + =item Can't x= to read-only value (F) You tried to repeat a constant value (often the undefined value) with @@ -1983,6 +1988,11 @@ See L. (P) The savestack was requested to restore more localized values than there are in the savestack. +=item panic: del_backref + +(P) Failed an internal consistency check while trying to reset a weak +reference. + =item panic: die %s (P) We popped the context stack to an eval context, and then discovered @@ -2043,6 +2053,11 @@ invalid enum on the top of it. (P) Something requested a negative number of bytes of malloc. +=item panic: magic_killbackrefs + +(P) Failed an internal consistency check while trying to reset all weak +references to an object. + =item panic: mapstart (P) The compiler is screwed up with respect to the map() function. @@ -2285,6 +2300,11 @@ to use parens. In any case, a hash requires key/value B. %hash = ( one => 1, two => 2, ); # right %hash = qw( one 1 two 2 ); # also fine +=item Reference is already weak + +(W) You have attempted to weaken a reference that is already weak. +Doing so has no effect. + =item Reference miscount in sv_replace() (W) The internal sv_replace() function was handed a new SV with a diff --git a/proto.h b/proto.h index ff71c5a..adc4d0a 100644 --- a/proto.h +++ b/proto.h @@ -894,6 +894,8 @@ void *bset_obj_store _((void *obj, I32 ix)); OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp)); void simplify_sort _((OP *o)); bool is_handle_constructor _((OP *o, I32 argnum)); +void sv_add_backref _((SV *tsv, SV *sv)); +void sv_del_backref _((SV *sv)); I32 do_trans_CC_simple _((SV *sv)); I32 do_trans_CC_count _((SV *sv)); @@ -973,3 +975,5 @@ VIRTUAL char* sv_pv _((SV *sv)); VIRTUAL void sv_force_normal _((SV *sv)); VIRTUAL void tmps_grow _((I32 n)); +VIRTUAL SV* sv_rvweaken _((SV *)); +VIRTUAL int magic_killbackrefs _((SV *sv, MAGIC *mg)); diff --git a/sv.c b/sv.c index 1fff726..87c3755 100644 --- a/sv.c +++ b/sv.c @@ -58,6 +58,8 @@ static void del_xnv _((XPVNV* p)); static void del_xpv _((XPV* p)); static void del_xrv _((XRV* p)); static void sv_unglob _((SV* sv)); +static void sv_add_backref _((SV *tsv, SV *sv)); +static void sv_del_backref _((SV *sv)); #ifndef PURIFY static void *my_safemalloc(MEM_SIZE size); @@ -2769,6 +2771,9 @@ sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen) case '.': mg->mg_virtual = &PL_vtbl_pos; break; + case '<': + mg->mg_virtual = &PL_vtbl_backref; + break; case '~': /* Reserved for use by extensions not perl internals. */ /* Useful for attaching extension internal data to perl vars. */ /* Note that multiple extensions may clash if magical scalars */ @@ -2817,6 +2822,63 @@ sv_unmagic(SV *sv, int type) return 0; } +SV * +sv_rvweaken(SV *sv) +{ + SV *tsv; + if (!SvOK(sv)) /* let undefs pass */ + return sv; + if (!SvROK(sv)) + croak("Can't weaken a nonreference"); + else if (SvWEAKREF(sv)) { + dTHR; + if (ckWARN(WARN_MISC)) + warner(WARN_MISC, "Reference is already weak"); + return sv; + } + tsv = SvRV(sv); + sv_add_backref(tsv, sv); + SvWEAKREF_on(sv); + SvREFCNT_dec(tsv); + return sv; +} + +STATIC void +sv_add_backref(SV *tsv, SV *sv) +{ + AV *av; + MAGIC *mg; + if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<'))) + av = (AV*)mg->mg_obj; + else { + av = newAV(); + sv_magic(tsv, (SV*)av, '<', NULL, 0); + SvREFCNT_dec(av); /* for sv_magic */ + } + av_push(av,sv); +} + +STATIC void +sv_del_backref(SV *sv) +{ + AV *av; + SV **svp; + I32 i; + SV *tsv = SvRV(sv); + MAGIC *mg; + if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<'))) + croak("panic: del_backref"); + av = (AV *)mg->mg_obj; + svp = AvARRAY(av); + i = AvFILLp(av); + while (i >= 0) { + if (svp[i] == sv) { + svp[i] = &PL_sv_undef; /* XXX */ + } + i--; + } +} + void sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) { @@ -3038,8 +3100,12 @@ sv_clear(register SV *sv) /* FALL THROUGH */ case SVt_PV: case SVt_RV: - if (SvROK(sv)) - SvREFCNT_dec(SvRV(sv)); + if (SvROK(sv)) { + if (SvWEAKREF(sv)) + sv_del_backref(sv); + else + SvREFCNT_dec(SvRV(sv)); + } else if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); break; @@ -4452,7 +4518,13 @@ void sv_unref(SV *sv) { SV* rv = SvRV(sv); - + + if (SvWEAKREF(sv)) { + sv_del_backref(sv); + SvWEAKREF_off(sv); + SvRV(sv) = 0; + return; + } SvRV(sv) = 0; SvROK_off(sv); if (SvREFCNT(rv) != 1 || SvREADONLY(rv)) diff --git a/sv.h b/sv.h index 533b4c4..cc8c6bc 100644 --- a/sv.h +++ b/sv.h @@ -165,6 +165,8 @@ struct io { #define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */ #define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */ +#define SVprv_WEAKREF 0x80000000 /* Weak reference */ + struct xrv { SV * xrv_rv; /* pointer to another SV */ }; @@ -410,6 +412,11 @@ struct xpvio { */ #define Gv_AMG(stash) (PL_amagic_generation && Gv_AMupdate(stash)) +#define SvWEAKREF(sv) ((SvFLAGS(sv) & (SVf_ROK|SVprv_WEAKREF)) \ + == (SVf_ROK|SVprv_WEAKREF)) +#define SvWEAKREF_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_WEAKREF)) +#define SvWEAKREF_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_WEAKREF)) + #define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST) #define SvPADBUSY(sv) (SvFLAGS(sv) & SVs_PADBUSY) diff --git a/util.c b/util.c index 8df5616..56199d2 100644 --- a/util.c +++ b/util.c @@ -3188,6 +3188,9 @@ get_vtbl(int vtbl_id) case want_vtbl_amagicelem: result = &PL_vtbl_amagicelem; break; + case want_vtbl_backref: + result = &PL_vtbl_backref; + break; } return result; }