ref: 6c549f03998ac6493fc36efe3fccec54face84e4
parent: 77e37368c9f126a14cf9d09fd61d0df7cee15af3
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed May 13 00:03:13 EDT 2009
fixing hash of circular structure to avoid tree recursion (very important!!) simplifying vector_grow
--- a/femtolisp/equal.c
+++ b/femtolisp/equal.c
@@ -256,8 +256,11 @@
#define doublehash(a) int64to32hash(a)
#endif
-static uptrint_t bounded_hash(value_t a, int bound)
+// *flag means max recursion bound exceeded
+// *ut means this happened some time, so we had to start using the table
+static uptrint_t bounded_hash(value_t a, int bound, int *flag, int *ut)
{
+ *flag = 0;
double d;
numerictype_t nt;
size_t i, len;
@@ -264,8 +267,13 @@
cvalue_t *cv;
cprim_t *cp;
void *data;
- if (bound <= 0) return 0;
uptrint_t h = 0;
+ if (*ut) {
+ h = (uptrint_t)ptrhash_get(&equal_eq_hashtable, (void*)a);
+ if (h != (uptrint_t)HT_NOTFOUND)
+ return h;
+ }
+ if (bound <= 0) { *ut = *flag = 1; return 0; }
int bb, tg = tag(a);
switch(tg) {
case TAG_NUM :
@@ -274,7 +282,7 @@
return doublehash(*(int64_t*)&d);
case TAG_FUNCTION:
if (uintval(a) > N_BUILTINS)
- return bounded_hash(((function_t*)ptr(a))->bcode, bound);
+ return bounded_hash(((function_t*)ptr(a))->bcode, bound, flag, ut);
return inthash(a);
case TAG_SYM:
return ((symbol_t*)ptr(a))->hash;
@@ -292,18 +300,30 @@
case TAG_VECTOR:
len = vector_size(a);
for(i=0; i < len; i++) {
- h = MIX(h, bounded_hash(vector_elt(a,i), bound-1));
+ h = MIX(h, bounded_hash(vector_elt(a,i), bound-1, flag, ut));
+ if (*flag) {
+ if (h == (uptrint_t)HT_NOTFOUND) h++;
+ ptrhash_put(&equal_eq_hashtable, (void*)a, (void*)h);
+ }
}
return h;
case TAG_CONS:
bb = BOUNDED_HASH_BOUND;
do {
- h = MIX(h, bounded_hash(car_(a), bound-1)+1);
- bb--;
- if (bb <= 0) return h;
+ h = MIX(h, bounded_hash(car_(a), bound-1, flag, ut)+1);
+ if (*flag) {
+ if (h == (uptrint_t)HT_NOTFOUND) h++;
+ ptrhash_put(&equal_eq_hashtable, (void*)a, (void*)h);
+ }
a = cdr_(a);
+ bb--;
+ if (bb <= 0) { *ut = *flag = 1; return h; }
+ if (*ut) {
+ if (ptrhash_get(&equal_eq_hashtable, (void*)a) != HT_NOTFOUND)
+ return h;
+ }
} while (iscons(a));
- return MIX(h, bounded_hash(a, bound-1)+1);
+ return MIX(h, bounded_hash(a, bound-1, flag, ut)+1);
}
return 0;
}
@@ -317,7 +337,11 @@
uptrint_t hash_lispvalue(value_t a)
{
- return bounded_hash(a, BOUNDED_HASH_BOUND);
+ int flag, ut=0;
+ uptrint_t n = bounded_hash(a, BOUNDED_HASH_BOUND, &flag, &ut);
+ if (ut)
+ htable_reset(&equal_eq_hashtable, 512);
+ return n;
}
value_t fl_hash(value_t *args, u_int32_t nargs)
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -401,22 +401,23 @@
if (t == TAG_VECTOR) {
// N.B.: 0-length vectors secretly have space for a first element
- size_t i, newsz, sz = vector_size(v);
- newsz = sz;
- if (vector_elt(v,-1) & 0x1)
- newsz += vector_grow_amt(sz);
- nc = tagptr(alloc_words(newsz+1), TAG_VECTOR);
- vector_setsize(nc, newsz);
- a = vector_elt(v,0);
- forward(v, nc);
- i = 0;
- if (sz > 0) {
- vector_elt(nc,0) = relocate(a); i++;
- for(; i < sz; i++)
- vector_elt(nc,i) = relocate(vector_elt(v,i));
+ size_t i, sz = vector_size(v);
+ if (vector_elt(v,-1) & 0x1) {
+ // grown vector
+ nc = relocate(vector_elt(v,0));
+ forward(v, nc);
}
- for(; i < newsz; i++)
- vector_elt(nc,i) = NIL;
+ else {
+ nc = tagptr(alloc_words(sz+1), TAG_VECTOR);
+ vector_setsize(nc, sz);
+ a = vector_elt(v,0);
+ forward(v, nc);
+ if (sz > 0) {
+ vector_elt(nc,0) = relocate(a);
+ for(i=1; i < sz; i++)
+ vector_elt(nc,i) = relocate(vector_elt(v,i));
+ }
+ }
return nc;
}
else if (t == TAG_CPRIM) {
@@ -647,24 +648,6 @@
return c;
}
-// NOTE: this is NOT an efficient operation. it is only used by the
-// reader; vectors should not generally be resized.
-// vector_grow requires at least 1 and up to 3 garbage collections!
-static value_t vector_grow(value_t v)
-{
- size_t s = vector_size(v);
- size_t d = vector_grow_amt(s);
- PUSH(v);
- // first allocate enough space to guarantee the heap will be big enough
- // for the new vector
- alloc_words(d);
- // setting low bit of vector's size acts as a flag to the collector
- // to grow this vector as it is relocated
- ((size_t*)ptr(Stack[SP-1]))[0] |= 0x1;
- gc(0);
- return POP();
-}
-
int isnumber(value_t v)
{
return (isfixnum(v) || iscprim(v));
@@ -676,13 +659,6 @@
// eval -----------------------------------------------------------------------
-/*
- there is one interesting difference between this and (lambda x x).
- (eq a (apply list a)) is always false for nonempty a, while
- (eq a (apply (lambda x x) a)) is always true. the justification for this
- is that a vararg lambda often needs to recur by applying itself to the
- tail of its argument list, so copying the list would be unacceptable.
-*/
static value_t list(value_t *args, uint32_t nargs)
{
cons_t *c;
@@ -841,7 +817,7 @@
POPN(1);
goto next_op;
case OP_NOP: goto next_op;
- case OP_DUP: v = Stack[SP-1]; PUSH(v); goto next_op;
+ case OP_DUP: SP++; Stack[SP-1] = Stack[SP-2]; goto next_op;
case OP_POP: POPN(1); goto next_op;
case OP_TCALL:
n = code[ip++]; // nargs
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -344,6 +344,28 @@
return toktype;
}
+// NOTE: this is NOT an efficient operation. it is only used by the
+// reader, and requires at least 1 and up to 3 garbage collections!
+static value_t vector_grow(value_t v)
+{
+ size_t s = vector_size(v);
+ size_t d = vector_grow_amt(s);
+ PUSH(v);
+ value_t newv = alloc_vector(s+d, 1);
+ v = Stack[SP-1];
+ int i;
+ for(i=0; i < s; i++)
+ vector_elt(newv, i) = vector_elt(v, i);
+ // use gc to rewrite references from the old vector to the new
+ Stack[SP-1] = newv;
+ if (s > 0) {
+ ((size_t*)ptr(v))[0] |= 0x1;
+ vector_elt(v, 0) = newv;
+ gc(0);
+ }
+ return POP();
+}
+
static value_t read_vector(value_t label, u_int32_t closer)
{
value_t v=the_empty_vector, elt;
@@ -354,13 +376,11 @@
while (peek() != closer) {
if (ios_eof(F))
lerror(ParseError, "read: unexpected end of input");
- if (i == 0) {
- v = Stack[SP-1] = alloc_vector(4, 1);
+ if (i >= vector_size(v)) {
+ v = Stack[SP-1] = vector_grow(v);
if (label != UNBOUND)
ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
}
- else if (i >= vector_size(v))
- Stack[SP-1] = vector_grow(v);
elt = do_read_sexpr(UNBOUND);
v = Stack[SP-1];
vector_elt(v,i) = elt;