Guile Mailing List Archive
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Dybvig's Guardians etc.
Well, a patch that implements Kent Dybvig's Guardians is attached.
Meanwhile, some questions:
1. Why does Guile have 3 types of weak hash tables (weak-key,
weak-value, doubly-weak)? What are they all useful for?
2. Is there a way to implement a `markedp' function (or macro)
better than I did? 'Cause there _must_ be, but I'm lame.
regards,
mike.
------------------>8 cut cut 8<--------------------------
Index: ice-9/boot-9.scm
===================================================================
RCS file: /home/cmm/cvs/tracked/guile-core/ice-9/boot-9.scm,v
retrieving revision 1.1.1.8
retrieving revision 1.9
diff -u -b -r1.1.1.8 -r1.9
--- boot-9.scm 1998/10/27 17:32:09 1.1.1.8
+++ boot-9.scm 1998/10/27 21:08:09 1.9
@@ -446,6 +446,21 @@
(provide 'record)
+;;; {Guardians}
+;;;
+
+(define (make-guardian)
+ (let ((g (%make-guardian)))
+ (lambda args
+ (cond
+ ((null? args)
+ (%guardian-get! g))
+ (else
+ (for-each (lambda (obj)
+ (%guardian-add! g obj))
+ args))))))
+
+
;;; {Booleans}
;;;
Index: libguile/Makefile.am
===================================================================
RCS file: /home/cmm/cvs/tracked/guile-core/libguile/Makefile.am,v
retrieving revision 1.1.1.4
retrieving revision 1.5
diff -u -b -r1.1.1.4 -r1.5
--- Makefile.am 1998/10/27 17:32:14 1.1.1.4
+++ Makefile.am 1998/10/27 17:59:23 1.5
@@ -45,7 +45,8 @@
procs.c ramap.c read.c readline.c root.c scmsigs.c script.c \
simpos.c smob.c socket.c srcprop.c stackchk.c stacks.c stime.c \
strings.c strop.c strorder.c strports.c struct.c symbols.c tag.c \
- throw.c unif.c variable.c vectors.c version.c vports.c weaks.c
+ throw.c unif.c variable.c vectors.c version.c vports.c weaks.c \
+ guardian.c
BUILT_SOURCES = \
cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
@@ -60,7 +61,7 @@
scmsigs.x script.x simpos.x smob.x socket.x srcprop.x stackchk.x \
stacks.x stime.x strings.x strop.x strorder.x strports.x struct.x \
symbols.x tag.x threads.x throw.x unif.x variable.x vectors.x \
- version.x vports.x weaks.x
+ version.x vports.x weaks.x guardian.x
EXTRA_libguile_la_SOURCES = _scm.h \
strerror.c inet_aton.c putenv.c \
@@ -95,7 +96,7 @@
simpos.h smob.h socket.h srcprop.h stackchk.h stacks.h stime.h \
strings.h strop.h strorder.h strports.h struct.h symbols.h tag.h \
tags.h throw.h unif.h variable.h vectors.h version.h vports.h \
- weaks.h snarf.h threads.h coop-defs.h fluids.h iselect.h
+ weaks.h snarf.h threads.h coop-defs.h fluids.h iselect.h guardian.h
## This file is generated at configure time. That is why it is DATA
## and not a header -- headers are included in the distribution.
Index: libguile/gc.c
===================================================================
RCS file: /home/cmm/cvs/tracked/guile-core/libguile/gc.c,v
retrieving revision 1.1.1.6
retrieving revision 1.2
diff -u -b -r1.1.1.6 -r1.2
--- gc.c 1998/10/27 17:32:21 1.1.1.6
+++ gc.c 1998/10/27 17:59:24 1.2
@@ -46,6 +46,7 @@
#include "struct.h"
#include "genio.h"
#include "weaks.h"
+#include "guardian.h"
#include "smob.h"
#include "unif.h"
#include "async.h"
@@ -549,6 +550,8 @@
scm_mark_weak_vector_spines ();
+ scm_gc_mark_guardians ();
+
scm_gc_sweep ();
--scm_gc_heap_lock;
Index: libguile/guardian.c
===================================================================
RCS file: guardian.c
diff -N guardian.c
--- /dev/null Thu Jan 1 02:00:00 1970
+++ /tmp/cvs29582gaa Tue Oct 27 23:47:37 1998
@@ -0,0 +1,343 @@
+#include <stdio.h>
+#include <assert.h>
+
+#include "_scm.h"
+#include "print.h"
+#include "smob.h"
+#include "eq.h"
+
+#include "guardian.h"
+
+long scm_tc16_guardian;
+
+typedef struct scm_guardian_t {
+ SCM live;
+ SCM zombies;
+
+ /* Guardians are kept in a circular doubly-linked
+ list. It wastes a word per guardian but is easier to
+ deal with. */
+ SCM prev;
+ SCM next;
+} scm_guardian_t;
+
+/* This is the root node of the doubly-linked guardian list. */
+static SCM scm_guardian_anchor;
+
+static SCM scm_currently_marked_guardian;
+
+static SCM
+g_mark(SCM ptr)
+{
+ /*
+ This function exists for the sole purpose of
+ reviving guardians that are guarded by other guardians
+ and are not referenced anywhere else.
+
+ Such guardians are distinguished by SCM_BOOL_F in
+ their `next' slot.
+ */
+ if (SCM_BOOL_F == SCM_GUARDIAN_NEXT(ptr)) {
+ /* guarded guardian, let's link it back */
+ SCM next_g;
+ assert(SCM_BOOL_F != scm_currently_marked_guardian);
+
+ next_g = SCM_GCGUARDIAN_NEXT(scm_currently_marked_guardian);
+ SCM_GCGUARDIAN_PREV(next_g) = ptr;
+ SCM_GCGUARDIAN_NEXT(ptr) = next_g;
+ SCM_GCGUARDIAN_PREV(ptr) = scm_currently_marked_guardian;
+ SCM_GCGUARDIAN_NEXT(scm_currently_marked_guardian) = ptr;
+ }
+
+ return SCM_BOOL_F;
+}
+
+static int
+g_print(SCM exp, SCM port, SCM pstate)
+{
+ char buf[256];
+ sprintf(buf, "#<guardian live objs: %lu zombies: %lu>",
+ scm_ilength(SCM_GUARDIAN_LIVE(exp)),
+ scm_ilength(SCM_GUARDIAN_ZOMBIES(exp)));
+ scm_puts(buf, port);
+
+ return 1;
+}
+
+static scm_smobfuns g_smob = {
+ g_mark,
+ scm_free0,
+ g_print
+};
+
+static SCM
+make_g()
+{
+ SCM z;
+ SCM_NEWCELL(z);
+ SCM_SETCAR(z, scm_tc16_guardian);
+ SCM_SETCDR(z, scm_must_malloc(sizeof(scm_guardian_t), "make-guardian"));
+ SCM_GUARDIAN_LIVE(z) = SCM_EOL;
+ SCM_GUARDIAN_ZOMBIES(z) = SCM_EOL;
+
+ return z;
+}
+
+SCM_PROC(s_make_guardian, "%make-guardian", 0, 0, 0, scm_primitive_make_guardian);
+SCM
+scm_primitive_make_guardian()
+{
+ SCM z;
+
+ SCM_DEFER_INTS;
+
+ z = make_g();
+ SCM_GUARDIAN_NEXT(z) = scm_guardian_anchor;
+ SCM_GUARDIAN_PREV(z) = SCM_GUARDIAN_PREV(scm_guardian_anchor);
+ SCM_GUARDIAN_NEXT(SCM_GUARDIAN_PREV(scm_guardian_anchor)) = z;
+ SCM_GUARDIAN_PREV(scm_guardian_anchor) = z;
+
+ SCM_ALLOW_INTS;
+
+ return z;
+}
+
+SCM_PROC(s_guardian_p, "%guardian?", 1, 0, 0, scm_primitive_guardian_p);
+SCM
+scm_primitive_guardian_p(SCM obj)
+{
+ return (SCM_NIMP(obj) && SCM_GUARDIANP(obj)) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM_PROC(s_guardian_add_x, "%guardian-add!", 2, 0, 0, scm_primitive_guardian_add_x);
+SCM
+scm_primitive_guardian_add_x(SCM g, SCM obj)
+{
+ SCM lst;
+
+ if (SCM_IMP(obj))
+ return SCM_UNSPECIFIED;
+
+ SCM_REDEFER_INTS;
+
+ lst = SCM_GUARDIAN_LIVE(g);
+ SCM_GUARDIAN_LIVE(g) = scm_cons(obj, lst);
+
+ SCM_REALLOW_INTS;
+
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC(s_guardian_get_x, "%guardian-get!", 1, 0, 0, scm_primitive_guardian_get_x);
+SCM
+scm_primitive_guardian_get_x(SCM g)
+{
+ SCM res, lst;
+
+ SCM_REDEFER_INTS;
+
+ lst = SCM_GUARDIAN_ZOMBIES(g);
+ if (SCM_NULLP(lst))
+ res = SCM_BOOL_F;
+ else {
+ res = SCM_CAR(lst);
+ SCM_GUARDIAN_ZOMBIES(g) = SCM_CDR(lst);
+ }
+
+ SCM_REALLOW_INTS;
+
+ return res;
+}
+
+SCM_PROC(s_guardian_get_all_x, "%guardian-get-all!", 1, 0, 0, scm_primitive_guardian_get_all_x);
+SCM
+scm_primitive_guardian_get_all_x(SCM g)
+{
+ SCM res;
+
+ SCM_REDEFER_INTS;
+
+ res = SCM_GUARDIAN_ZOMBIES(g);
+ SCM_GUARDIAN_ZOMBIES(g) = SCM_EOL;
+
+ SCM_REALLOW_INTS;
+
+ return res;
+}
+
+#ifdef GUILE_DEBUG
+
+SCM_PROC(s_live_guardians, "%live-guardians", 0, 0, 0, primitive_live_guardians);
+static SCM
+primitive_live_guardians()
+{
+ SCM g;
+ unsigned long res = 0;
+
+ SCM_REDEFER_INTS;
+ for (g = SCM_GUARDIAN_NEXT(scm_guardian_anchor); g != scm_guardian_anchor;
+ g = SCM_GUARDIAN_NEXT(g))
+ ++res;
+ SCM_REALLOW_INTS;
+
+ return scm_ulong2num(res);
+}
+
+#endif
+
+/*
+ I'm sure this can be written more cleanly, it's just that
+ my head started to ache when I tried to figure it out.
+ So for now the olden rule is that this function must be changed
+ whenever scm_gc_mark is changed.
+*/
+static int
+is_marked(p)
+ SCM p;
+{
+ if (SCM_IMP(p))
+ return 1;
+
+ switch (SCM_TYP7(p)) {
+ case scm_tcs_cons_nimcar:
+ case scm_tcs_cons_imcar:
+ case scm_tcs_cons_gloc:
+ case scm_tcs_closures:
+ return SCM_GCMARKP(p);
+ case scm_tc7_vector:
+ case scm_tc7_lvector:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ case scm_tc7_contin:
+ case scm_tc7_bvect:
+ case scm_tc7_byvect:
+ case scm_tc7_ivect:
+ case scm_tc7_uvect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ case scm_tc7_svect:
+#ifdef LONGLONGS
+ case scm_tc7_llvect:
+#endif
+ case scm_tc7_string:
+ case scm_tc7_substring:
+ case scm_tc7_wvect:
+ case scm_tc7_msymbol:
+ case scm_tc7_ssymbol:
+ case scm_tc7_port:
+ case scm_tc7_smob:
+ return SCM_GC8MARKP(p);
+ case scm_tcs_subrs:
+ return SCM_GC8MARKP((SCM)(scm_heap_org + (((unsigned long)SCM_CAR(p)) >> 8)));
+ default:
+ /* what is this then? */
+ abort();
+ }
+}
+
+void
+scm_gc_mark_guardians()
+{
+ SCM g;
+ SCM next_g = scm_guardian_anchor;
+
+ for (g = SCM_GCGUARDIAN_NEXT(scm_guardian_anchor);
+ g != scm_guardian_anchor;
+ g = next_g) {
+
+ next_g = SCM_GCGUARDIAN_NEXT(g);
+
+ if (!SCM_GC8MARKP(g)) {
+ /* This guardian is dead unless is itself
+ guarded.
+ Unlink it and disregard it.
+ If it's guarded, it'll be linked back later,
+ as if by magic :) */
+ SCM_GCGUARDIAN_NEXT(SCM_GCGUARDIAN_PREV(g)) = next_g;
+ SCM_GCGUARDIAN_PREV(next_g) = SCM_GCGUARDIAN_PREV(g);
+ SCM_GCGUARDIAN_NEXT(g) = SCM_BOOL_F;
+ } else {
+ SCM pair, next_pair;
+ /* suppose that everyone guarded is live */
+ SCM last_z_pair = SCM_EOL;
+ SCM last_l_pair = SCM_GCGUARDIAN_LIVE(g);
+
+ /* the following is basically equivalent to scm_last_pair,
+ but with no checks, GC-minded, and we know that the
+ list has no cycles :) */
+ while (SCM_NNULLP(last_l_pair)) {
+ SCM x = SCM_GCCDR(last_l_pair);
+ if (SCM_NULLP(x)) break;
+ last_l_pair = x;
+ }
+
+ /* glue the two lists together, make
+ the result the new live list and zero the zombie list */
+ if (SCM_NNULLP(last_l_pair))
+ SCM_CDR(last_l_pair) = SCM_GCGUARDIAN_ZOMBIES(g);
+ else
+ SCM_GCGUARDIAN_LIVE(g) = SCM_GCGUARDIAN_ZOMBIES(g);
+ SCM_GCGUARDIAN_ZOMBIES(g) = SCM_EOL;
+ last_l_pair = SCM_EOL;
+
+ /* move the not-already-marked objects to zombies */
+ for (pair = SCM_GCGUARDIAN_LIVE(g);
+ SCM_NNULLP(pair);
+ pair = next_pair) {
+
+ SCM p = SCM_CAR(pair);
+ next_pair = SCM_GCCDR(pair);
+
+ if (!is_marked(p)) {
+ /* move it to the fellow zombies */
+ if (SCM_NULLP(last_z_pair))
+ SCM_GCGUARDIAN_ZOMBIES(g) = pair;
+ else
+ SCM_CDR(last_z_pair) = pair;
+ last_z_pair = pair;
+
+ if (SCM_NULLP(last_l_pair))
+ SCM_GCGUARDIAN_LIVE(g) = next_pair;
+ else
+ SCM_CDR(last_l_pair) = next_pair;
+
+ SCM_CDR(pair) = SCM_EOL;
+ } else
+ last_l_pair = pair;
+ }
+
+ /*
+ Marking the two object lists is done thusly:
+ 1. The magic `current guardian' pointer is set
+ to g. This insures that any undead (?) guardians
+ inside of g are linked back right after g.
+ Clear, ain't I?
+ 2. The two lists are marked.
+ 3. The magic is revoked.
+ */
+ scm_currently_marked_guardian = g;
+ scm_gc_mark(SCM_GCGUARDIAN_LIVE(g));
+ scm_gc_mark(SCM_GCGUARDIAN_ZOMBIES(g));
+ scm_currently_marked_guardian = SCM_BOOL_F;
+
+ next_g = SCM_GCGUARDIAN_NEXT(g);
+ }
+ }
+}
+
+void
+scm_init_guardian()
+{
+ scm_tc16_guardian = scm_newsmob(&g_smob);
+
+ /* make the anchor */
+ scm_guardian_anchor = scm_permanent_object(make_g());
+ SCM_GUARDIAN_PREV(scm_guardian_anchor) = scm_guardian_anchor;
+ SCM_GUARDIAN_NEXT(scm_guardian_anchor) = scm_guardian_anchor;
+
+ scm_currently_marked_guardian = SCM_BOOL_F;
+
+#include "guardian.x"
+}
Index: libguile/guardian.h
===================================================================
RCS file: guardian.h
diff -N guardian.h
--- /dev/null Thu Jan 1 02:00:00 1970
+++ /tmp/cvs29582haa Tue Oct 27 23:47:37 1998
@@ -0,0 +1,35 @@
+/* classes: h_files */
+
+#ifndef SCM_GUARDIANH
+#define SCM_GUARDIANH
+
+#include "libguile/__scm.h"
+
+extern long scm_tc16_guardian;
+
+#define SCM_GUARDIANP(x) (SCM_TYP16(x) == scm_tc16_guardian)
+#define SCM_GCGUARDIANP(x) (SCM_GCTYP16(x) == scm_tc16_guardian)
+#define SCM_GUARDIAN(x) ((scm_guardian_t *)SCM_CDR(x))
+#define SCM_GCGUARDIAN(x) ((scm_guardian_t *)SCM_GCCDR(x))
+#define SCM_GUARDIAN_LIVE(x) (SCM_GUARDIAN(x)->live)
+#define SCM_GCGUARDIAN_LIVE(x) (SCM_GCGUARDIAN(x)->live)
+#define SCM_GUARDIAN_ZOMBIES(x) (SCM_GUARDIAN(x)->zombies)
+#define SCM_GCGUARDIAN_ZOMBIES(x) (SCM_GCGUARDIAN(x)->zombies)
+#define SCM_GUARDIAN_PREV(x) (SCM_GUARDIAN(x)->prev)
+#define SCM_GCGUARDIAN_PREV(x) (SCM_GCGUARDIAN(x)->prev)
+#define SCM_GUARDIAN_NEXT(x) (SCM_GUARDIAN(x)->next)
+#define SCM_GCGUARDIAN_NEXT(x) (SCM_GCGUARDIAN(x)->next)
+
+SCM scm_primitive_make_guardian(void);
+SCM scm_primitive_guardian_p(SCM obj);
+
+SCM scm_primitive_guardian_add_x(SCM guardian, SCM obj);
+SCM scm_primitive_guardian_get_x(SCM guardian);
+
+SCM scm_primitive_guardian_get_all_x(SCM guardian);
+
+void scm_gc_mark_guardians(void);
+
+void scm_init_guardian(void);
+
+#endif /* !SCM_GUARDIANH */
Index: libguile/init.c
===================================================================
RCS file: /home/cmm/cvs/tracked/guile-core/libguile/init.c,v
retrieving revision 1.1.1.7
retrieving revision 1.9
diff -u -b -r1.1.1.7 -r1.9
--- init.c 1998/10/27 17:32:29 1.1.1.7
+++ init.c 1998/10/27 20:13:58 1.9
@@ -118,6 +118,7 @@
#include "version.h"
#include "vports.h"
#include "weaks.h"
+#include "guardian.h"
#include "init.h"
@@ -481,6 +482,7 @@
scm_init_vectors ();
scm_init_version ();
scm_init_weaks ();
+ scm_init_guardian ();
scm_init_vports ();
scm_init_eval ();
#ifdef DEBUG_EXTENSIONS
------------------>8 cut cut 8<--------------------------
Guile Home |
Main Index |
Thread Index