"weak" references internals, still needs perlguts documentation

(somewhat modified version of patch suggested by Tuomas J. Lukka
<lukka@fas.harvard.edu>)

p4raw-id: //depot/perl@3385

12 files changed, 160 insertions, 5 deletions

diff --git a/dump.c b/dump.c
index 811fe7886b..cb3a643b03 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 011cc68a32..2386993056 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 32c034fd5b..19f68a9521 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 09520a9406..55a8b8b18f 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 3584dbc92d..9183104339 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 6297e9f7d9..69a891c639 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 e77e58588b..0acc21381d 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 4b18882b28..b83b577b03 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<perlform>.
 (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<pairs>.
     %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 ff71c5a2e1..adc4d0acaf 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 1fff726b9e..87c3755d41 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 533b4c4a46..cc8c6bc936 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 8df5616573..56199d2fcc 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;
 }