From 6c549f03998ac6493fc36efe3fccec54face84e4 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Wed, 13 May 2009 04:03:13 +0000 Subject: [PATCH] fixing hash of circular structure to avoid tree recursion (very important!!) simplifying vector_grow --- femtolisp/equal.c | 42 ++++++++++++++++++++++++++-------- femtolisp/flisp.c | 58 ++++++++++++++--------------------------------- femtolisp/read.c | 28 +++++++++++++++++++---- 3 files changed, 74 insertions(+), 54 deletions(-) diff --git a/femtolisp/equal.c b/femtolisp/equal.c index a86882b..3321395 100644 --- a/femtolisp/equal.c +++ b/femtolisp/equal.c @@ -256,16 +256,24 @@ value_t equal(value_t a, value_t b) #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; 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 @@ static uptrint_t bounded_hash(value_t a, int bound) 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 @@ static uptrint_t bounded_hash(value_t a, int bound) 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 @@ int equal_lispvalue(value_t a, value_t b) 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) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index adb7ff8..489dacc 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -401,22 +401,23 @@ static value_t relocate(value_t v) 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); + } + 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)); + } } - for(; i < newsz; i++) - vector_elt(nc,i) = NIL; return nc; } else if (t == TAG_CPRIM) { @@ -647,24 +648,6 @@ value_t fl_cons(value_t a, value_t b) 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 @@ int isnumber(value_t v) // 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 @@ static value_t apply_cl(uint32_t nargs) 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 diff --git a/femtolisp/read.c b/femtolisp/read.c index 8262ad8..1125bcb 100644 --- a/femtolisp/read.c +++ b/femtolisp/read.c @@ -344,6 +344,28 @@ static u_int32_t peek() 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 @@ static value_t read_vector(value_t label, u_int32_t closer) 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;