"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

diff --git a/dump.c b/dump.c
index 811fe78..cb3a643 100644 (file)
--- 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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 ff71c5a..adc4d0a 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;
 }