weak key hash tables - gcl.git - GNU Common Lisp

diff --git a/gcl/h/lu.h b/gcl/h/lu.h
index 6c0cc3e0f..ff64498f3 100644
--- a/gcl/h/lu.h
+++ b/gcl/h/lu.h

@@ -142,6 +142,7 @@ struct hashtable {

int ht_nent;

int ht_size;

short ht_test;

+ short ht_weak;

SPAD;

};

diff --git a/gcl/o/gbc.c b/gcl/o/gbc.c
index ebd19eccf..342dd6aa3 100755
--- a/gcl/o/gbc.c
+++ b/gcl/o/gbc.c

@@ -58,6 +58,9 @@ mark_contblock(void *, int);

static void

mark_object(object);

+static object

+mark_weak_hashtables(object);

+

/* the following in line definitions seem to be twice as fast (at

least on mc68020) as going to the assembly function calls in bitop.c so

@@ -967,6 +970,11 @@ mark_phase(void) {

#define N_RECURSION_REQD 2

#endif

mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully);

+

+ {

+ extern object weak_hash_tables;

+ weak_hash_tables=mark_weak_hashtables(weak_hash_tables);

+ }

}

@@ -1637,6 +1645,66 @@ FFN(siLgbc_time)(void) {

#include "sgbc.c"

#endif

+static object

+mark_weak_hashtables(object x) {

+

+ struct htent *e,*ee;

+ ufixnum p,pe;

+ object h,d=x->c.c_cdr,dp=(void *)&d,y;

+ bool wx=

+#ifdef SGC

+ sgc_enabled ? ON_WRITABLE_PAGE(x) :

+#endif

+ 1;

+

+ if (x==Cnil)

+ return x;

+

+ unmark(dp);

+ y=mark_weak_hashtables(d);

+

+ if (is_marked((h=x->c.c_car))) {

+

+ e=h->ht.ht_self;

+ if (COLLECT_RELBLOCK_P

+#ifdef SGC

+ && (sgc_enabled ? SGC_RELBLOCK_P(h->ht.ht_self) : 1)

+#endif

+ )

+ e=(void *)e+(rb_pointer1-rb_pointer);

+ ee=e+h->ht.ht_size;

+

+ for (p=page(e),pe=page(ee);p<=pe;p++) {

+

+ struct htent *en=(void *)pagetoinfo(p+1);

+ bool w=

+#ifdef SGC

+ sgc_enabled ? WRITABLE_PAGE_P(p) :

+#endif

+ 1;

+

+ for (;e<ee && e<en;e++)

+ if (w && e->hte_key!=OBJNULL) {

+ if (is_marked(e->hte_key)) {

+#ifdef SGC

+ if (sgc_enabled) sgc_mark_object(e->hte_value); else

+#endif

+ mark_object(e->hte_value);

+ } else {

+ e->hte_key=OBJNULL;

+ e->hte_value=Cnil;

+ h->ht.ht_nent--;

+ }

+ }

+ }

+ if (wx) {x->c.c_cdr=y;mark(x);}

+ } else

+ x=wx ? y : x;

+

+ return x;

+

+}

+

DEFVAR("*NOTIFY-GBC*",sSAnotify_gbcA,SI,Cnil,"");

#ifdef DEBUG

DEFVAR("*GBC-MESSAGE*",sSAgbc_messageA,SI,Cnil,"");

diff --git a/gcl/o/hash.d b/gcl/o/hash.d
index 00ebd2a96..47ec1e75e 100755
--- a/gcl/o/hash.d
+++ b/gcl/o/hash.d

@@ -30,6 +30,7 @@ object sLequal;

object sKsize;

object sKrehash_size;

object sKrehash_threshold;

+object sKweak;

#define MHSH(a_) ((a_) & ~(1UL<<(sizeof(a_)*CHAR_SIZE-1)))

@@ -316,12 +317,15 @@ DEFVAR("*DEFAULT-HASH-TABLE-SIZE*",sSAdefault_hash_table_sizeA,SI,make_fixnum(10

DEFVAR("*DEFAULT-HASH-TABLE-REHASH-SIZE*",sSAdefault_hash_table_rehash_sizeA,SI,make_shortfloat((shortfloat)1.5),"");

DEFVAR("*DEFAULT-HASH-TABLE-REHASH-THRESHOLD*",sSAdefault_hash_table_rehash_thresholdA,SI,make_shortfloat((shortfloat)0.7),"");

+object weak_hash_tables=Cnil;

+

@(defun make_hash_table (&key (test sLeql)

(size `sSAdefault_hash_table_sizeA->s.s_dbind`)

(rehash_size

`sSAdefault_hash_table_rehash_sizeA->s.s_dbind`)

(rehash_threshold

`sSAdefault_hash_table_rehash_thresholdA->s.s_dbind`)

+ (weak `Cnil`)

&aux h)

enum httest htt=0;

int i;

@@ -335,6 +339,7 @@ DEFVAR("*DEFAULT-HASH-TABLE-REHASH-THRESHOLD*",sSAdefault_hash_table_rehash_thre

else

FEerror("~S is an illegal hash-table test function.",

1, test);

+

if (type_of(size) != t_fixnum || 0 < fix(size))

;

else

@@ -359,6 +364,7 @@ DEFVAR("*DEFAULT-HASH-TABLE-REHASH-THRESHOLD*",sSAdefault_hash_table_rehash_thre

{BEGIN_NO_INTERRUPT;

h = alloc_object(t_hashtable);

h->ht.ht_test = (short)htt;

+ h->ht.ht_weak = weak!=Cnil && (htt==htt_eq || htt==htt_eql);

h->ht.ht_size = fix(size);

h->ht.ht_rhsize = rehash_size;

h->ht.ht_rhthresh = rehash_threshold;

@@ -370,6 +376,8 @@ DEFVAR("*DEFAULT-HASH-TABLE-REHASH-THRESHOLD*",sSAdefault_hash_table_rehash_thre

h->ht.ht_self[i].hte_key = OBJNULL;

h->ht.ht_self[i].hte_value = OBJNULL;

}

+ if (h->ht.ht_weak)

+ weak_hash_tables=MMcons(h,weak_hash_tables);

END_NO_INTERRUPT;}

@(return h)

@)

@@ -547,6 +555,7 @@ gcl_init_hash()

sKtest = make_keyword("TEST");

sKrehash_size = make_keyword("REHASH-SIZE");

sKrehash_threshold = make_keyword("REHASH-THRESHOLD");

+ sKweak = make_keyword("WEAK");

make_function("MAKE-HASH-TABLE", Lmake_hash_table);

make_function("HASH-TABLE-P", Lhash_table_p);

diff --git a/gcl/o/sgbc.c b/gcl/o/sgbc.c
index 33e210b4e..d52e5bc22 100755
--- a/gcl/o/sgbc.c
+++ b/gcl/o/sgbc.c

@@ -642,7 +642,12 @@ sgc_mark_phase(void) {

}

mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully);

-

+

+ {

+ extern object weak_hash_tables;

+ weak_hash_tables=mark_weak_hashtables(weak_hash_tables);

+ }

+

}

static void