From a4bb09bcb2389b3d6f1cb1a2bc5b344eff6ccecb Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Fri, 28 Nov 2008 21:44:59 +0000 Subject: [PATCH] adding equalhash.c some cleanup moving some library code around for size optimization now using == instead of flt_equals for float comparison, mostly for hash compatibility --- femtolisp/Makefile | 2 +- femtolisp/builtins.c | 6 --- femtolisp/cvalues.c | 7 +-- femtolisp/equal.c | 11 ++++- femtolisp/equalhash.c | 12 +++++ femtolisp/equalhash.h | 8 +++ femtolisp/flisp.c | 5 ++ femtolisp/flisp.h | 8 +-- femtolisp/print.c | 2 +- femtolisp/table.c | 15 +++--- femtolisp/todo | 3 +- llt/Makefile | 3 +- llt/cplxprint.c | 4 +- llt/dblprint.c | 81 ------------------------------- llt/fp.c | 110 ++++++++++++++++++++++++++++++++++++++++++ llt/hashing.c | 30 ------------ llt/htable.inc | 5 +- llt/operators.c | 6 +-- 18 files changed, 172 insertions(+), 146 deletions(-) create mode 100644 femtolisp/equalhash.c create mode 100644 femtolisp/equalhash.h create mode 100644 llt/fp.c diff --git a/femtolisp/Makefile b/femtolisp/Makefile index 7ee8a3e..86be36b 100644 --- a/femtolisp/Makefile +++ b/femtolisp/Makefile @@ -1,7 +1,7 @@ CC = gcc NAME = flisp -SRCS = $(NAME).c equal.c builtins.c string.c +SRCS = $(NAME).c equal.c builtins.c string.c equalhash.c table.c OBJS = $(SRCS:%.c=%.o) DOBJS = $(SRCS:%.c=%.do) EXENAME = $(NAME) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 88a5cdd..9078272 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -343,11 +343,6 @@ value_t fl_randf(value_t *args, u_int32_t nargs) (void)args; (void)nargs; return mk_float(rand_float()); } -value_t fl_randn(value_t *args, u_int32_t nargs) -{ - (void)args; (void)nargs; - return mk_double(randn()); -} extern void stringfuncs_init(); @@ -376,7 +371,6 @@ static builtinspec_t builtin_info[] = { { "rand.uint64", fl_rand64 }, { "rand.double", fl_randd }, { "rand.float", fl_randf }, - { "randn", fl_randn }, { "path.cwd", fl_path_cwd }, diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index cd303df..6b4ea93 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -109,7 +109,6 @@ value_t cvalue(value_t type, size_t sz) pcv->len = sz; autorelease(pcv); } - pcv->deps = NIL; pcv->type = POP(); return tagptr(pcv, TAG_CVALUE); } @@ -144,7 +143,6 @@ value_t cvalue_from_ref(value_t type, void *ptr, size_t sz, value_t parent) pcv->flags.inlined = 0; pcv->data = ptr; pcv->len = sz; - pcv->deps = NIL; pcv->type = POP(); parent = POP(); if (parent != NIL) { @@ -672,7 +670,7 @@ value_t cvalue_copy(value_t v) static void cvalue_init(value_t type, value_t v, void *dest) { - cvinitfunc_t f; + cvinitfunc_t f=NULL; if (issymbol(type)) { f = ((symbol_t*)ptr(type))->dlcache; @@ -681,9 +679,6 @@ static void cvalue_init(value_t type, value_t v, void *dest) value_t head = car_(type); f = ((symbol_t*)ptr(head))->dlcache; } - else { - f = NULL; - } if (f == NULL) lerror(ArgError, "c-value: invalid c type"); diff --git a/femtolisp/equal.c b/femtolisp/equal.c index 959817e..1cf2ea0 100644 --- a/femtolisp/equal.c +++ b/femtolisp/equal.c @@ -331,7 +331,14 @@ static uptrint_t bounded_hash(value_t a, int bound) return 0; } -uptrint_t hash(value_t a) +int equal_lispvalue(value_t a, value_t b) +{ + if (eq_comparable(a, b)) + return (a==b); + return (numval(compare_(a,b,1))==0); +} + +uptrint_t hash_lispvalue(value_t a) { return bounded_hash(a, BOUNDED_HASH_BOUND); } @@ -339,5 +346,5 @@ uptrint_t hash(value_t a) value_t fl_hash(value_t *args, u_int32_t nargs) { argcount("hash", nargs, 1); - return fixnum(hash(args[0])); + return fixnum(hash_lispvalue(args[0])); } diff --git a/femtolisp/equalhash.c b/femtolisp/equalhash.c new file mode 100644 index 0000000..4e3efdf --- /dev/null +++ b/femtolisp/equalhash.c @@ -0,0 +1,12 @@ +#include +#include +#include +#include +#include + +#include "llt.h" +#include "flisp.h" + +#include "htable.inc" + +HTIMPL(equalhash, hash_lispvalue, equal_lispvalue) diff --git a/femtolisp/equalhash.h b/femtolisp/equalhash.h new file mode 100644 index 0000000..a6f086d --- /dev/null +++ b/femtolisp/equalhash.h @@ -0,0 +1,8 @@ +#ifndef __EQUALHASH_H_ +#define __EQUALHASH_H_ + +#include "htableh.inc" + +HTPROT(equalhash) + +#endif diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 629c826..d351390 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -413,6 +413,11 @@ static value_t relocate(value_t v) return v; } +value_t relocate_lispvalue(value_t v) +{ + return relocate(v); +} + static void trace_globals(symbol_t *root) { while (root != NULL) { diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 3a19f83..cdeb449 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -133,7 +133,10 @@ size_t llength(value_t v); value_t list_nth(value_t l, size_t n); value_t compare(value_t a, value_t b); // -1, 0, or 1 value_t equal(value_t a, value_t b); // T or nil -uptrint_t hash(value_t a); +int equal_lispvalue(value_t a, value_t b); +uptrint_t hash_lispvalue(value_t a); +value_t relocate_lispvalue(value_t v); +void print_traverse(value_t v); value_t fl_hash(value_t *args, u_int32_t nargs); /* safe casts */ @@ -189,7 +192,7 @@ typedef struct { typedef struct { void (*print)(value_t self, ios_t *f, int princ); - void (*relocate)(value_t old, value_t new); + void (*relocate)(value_t oldv, value_t newv); void (*finalize)(value_t self); void (*print_traverse)(value_t self); } cvtable_t; @@ -200,7 +203,6 @@ typedef struct { unsigned long flagbits; }; value_t type; - value_t deps; //cvtable_t *vtable; // fields below are absent in inline-allocated values void *data; diff --git a/femtolisp/print.c b/femtolisp/print.c index 3f88ddf..a5a84c8 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -30,7 +30,7 @@ static void outindent(int n, ios_t *f) } } -static void print_traverse(value_t v) +void print_traverse(value_t v) { value_t *bp; while (iscons(v)) { diff --git a/femtolisp/table.c b/femtolisp/table.c index 234da0f..3996ca3 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -46,24 +46,24 @@ void free_htable(value_t self) htable_free(&pt->ht); } -void relocate_htable(value_t old, value_t new) +void relocate_htable(value_t oldv, value_t newv) { - fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self)); + fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(newv)); htable_t *h = &pt->ht; size_t i; for(i=0; i < h->size; i++) { if (h->table[i] != HT_NOTFOUND) - h->table[i] = (void*)relocate((value_t)h->table[i]); + h->table[i] = (void*)relocate_lispvalue((value_t)h->table[i]); } } -void rehash_htable(value_t old, value_t new) +void rehash_htable(value_t oldv, value_t newv) { } -cvtable_t h_r1_vtable = { print_htable, NULL, free_htable }; -cvtable_t h_r2_vtable = { print_htable, relocate_htable, free_htable }; -cvtable_t h_r3_vtable = { print_htable, rehash_htable, free_htable }; +cvtable_t h_r1_vtable = { print_htable, NULL, free_htable, NULL }; +cvtable_t h_r2_vtable = { print_htable, relocate_htable, free_htable, NULL }; +cvtable_t h_r3_vtable = { print_htable, rehash_htable, free_htable, NULL }; int ishashtable(value_t v) { @@ -72,6 +72,7 @@ int ishashtable(value_t v) value_t fl_table(value_t *args, u_int32_t nargs) { + return NIL; } value_t fl_hashtablep(value_t *args, u_int32_t nargs) diff --git a/femtolisp/todo b/femtolisp/todo index 1e173e6..b29fb8d 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -965,8 +965,9 @@ typedef struct _fltype_t { value_t type; int numtype; size_t sz; + size_t elsz; cvtable_t *vtable; - int marked; struct _fltype_t *eltype; // for arrays struct _fltype_t *artype; // (array this) + int marked; } fltype_t; diff --git a/llt/Makefile b/llt/Makefile index 266b3ac..9176538 100644 --- a/llt/Makefile +++ b/llt/Makefile @@ -1,7 +1,8 @@ CC = gcc SRCS = bitvector.c hashing.c socket.c timefuncs.c utils.c dblprint.c ptrhash.c \ - utf8.c ios.c operators.c cplxprint.c dirpath.c htable.c bitvector-ops.c + utf8.c ios.c operators.c cplxprint.c dirpath.c htable.c \ + bitvector-ops.c fp.c OBJS = $(SRCS:%.c=%.o) DOBJS = $(SRCS:%.c=%.do) TARGET = libllt.a diff --git a/llt/cplxprint.c b/llt/cplxprint.c index eb5d12d..a2161b1 100644 --- a/llt/cplxprint.c +++ b/llt/cplxprint.c @@ -45,14 +45,14 @@ void snprint_cplx(char *s, size_t cnt, double re, double im, } if (!fzi) { len = sl = strlen(s); - if (dbl_equals(im, -1)) { + if (im == -1) { while ((long)(len-sl) < (long)(width-2) && len < (space-3)) s[len++] = ' '; s[len] = '-'; s[len+1] = 'i'; s[len+2] = '\0'; } - else if (dbl_equals(im, 1)) { + else if (im == 1) { while ((long)(len-sl) < (long)(width-1) && len < (space-2)) s[len++] = ' '; s[len] = 'i'; diff --git a/llt/dblprint.c b/llt/dblprint.c index 7f6631a..8d49f92 100644 --- a/llt/dblprint.c +++ b/llt/dblprint.c @@ -5,87 +5,6 @@ #include "ieee754.h" #include "dtypes.h" -static uint64_t max_ulps; -static uint32_t flt_max_ulps; - -static uint64_t nexti64pow2(uint64_t i) -{ - if (i==0) return 1; - if ((i&(i-1))==0) return i; - if (i&BIT63) return BIT63; - // repeatedly clear bottom bit - while (i&(i-1)) - i = i&(i-1); - return i<<1; -} - -static uint32_t nexti32pow2(uint32_t i) -{ - if (i==0) return 1; - if ((i&(i-1))==0) return i; - if (i&BIT31) return BIT31; - // repeatedly clear bottom bit - while (i&(i-1)) - i = i&(i-1); - return i<<1; -} - -void dbl_tolerance(double tol) -{ - max_ulps = nexti64pow2((uint64_t)(tol/DBL_EPSILON)); -} - -void flt_tolerance(float tol) -{ - flt_max_ulps = nexti32pow2((uint32_t)(tol/FLT_EPSILON)); -} - -#ifdef __INTEL_COMPILER -static inline int64_t llabs(int64_t j) -{ - return NBABS(j, 64); -} -#else -extern int64_t llabs(int64_t j); -#endif - -int dbl_equals(double a, double b) -{ - int64_t aint, bint; - - if (a == b) - return 1; - aint = *(int64_t*)&a; - bint = *(int64_t*)&b; - if (aint < 0) - aint = BIT63 - aint; - if (bint < 0) - bint = BIT63 - bint; - /* you'd think it makes no difference whether the result of llabs is - signed or unsigned, but if it's signed then the case of - 0x8000000000000000 blows up, making 4 == -1 :) */ - if ((uint64_t)llabs(aint-bint) <= max_ulps) - return 1; - return 0; -} - -int flt_equals(float a, float b) -{ - int32_t aint, bint; - - if (a == b) - return 1; - aint = *(int32_t*)&a; - bint = *(int32_t*)&b; - if (aint < 0) - aint = BIT31 - aint; - if (bint < 0) - bint = BIT31 - bint; - if ((uint32_t)abs(aint-bint) <= flt_max_ulps) - return 1; - return 0; -} - int double_exponent(double d) { union ieee754_double dl; diff --git a/llt/fp.c b/llt/fp.c new file mode 100644 index 0000000..679eea3 --- /dev/null +++ b/llt/fp.c @@ -0,0 +1,110 @@ +#include +#include +#include +#include +#include "ieee754.h" +#include "dtypes.h" +#include "hashing.h" + +static uint64_t max_ulps; +static uint32_t flt_max_ulps; + +static uint64_t nexti64pow2(uint64_t i) +{ + if (i==0) return 1; + if ((i&(i-1))==0) return i; + if (i&BIT63) return BIT63; + // repeatedly clear bottom bit + while (i&(i-1)) + i = i&(i-1); + return i<<1; +} + +static uint32_t nexti32pow2(uint32_t i) +{ + if (i==0) return 1; + if ((i&(i-1))==0) return i; + if (i&BIT31) return BIT31; + // repeatedly clear bottom bit + while (i&(i-1)) + i = i&(i-1); + return i<<1; +} + +void dbl_tolerance(double tol) +{ + max_ulps = nexti64pow2((uint64_t)(tol/DBL_EPSILON)); +} + +void flt_tolerance(float tol) +{ + flt_max_ulps = nexti32pow2((uint32_t)(tol/FLT_EPSILON)); +} + +#ifdef __INTEL_COMPILER +static inline int64_t llabs(int64_t j) +{ + return NBABS(j, 64); +} +#else +extern int64_t llabs(int64_t j); +#endif + +int dbl_equals(double a, double b) +{ + int64_t aint, bint; + + if (a == b) + return 1; + aint = *(int64_t*)&a; + bint = *(int64_t*)&b; + if (aint < 0) + aint = BIT63 - aint; + if (bint < 0) + bint = BIT63 - bint; + /* you'd think it makes no difference whether the result of llabs is + signed or unsigned, but if it's signed then the case of + 0x8000000000000000 blows up, making 4 == -1 :) */ + if ((uint64_t)llabs(aint-bint) <= max_ulps) + return 1; + return 0; +} + +int flt_equals(float a, float b) +{ + int32_t aint, bint; + + if (a == b) + return 1; + aint = *(int32_t*)&a; + bint = *(int32_t*)&b; + if (aint < 0) + aint = BIT31 - aint; + if (bint < 0) + bint = BIT31 - bint; + if ((uint32_t)abs(aint-bint) <= flt_max_ulps) + return 1; + return 0; +} + +double randn() +{ + double s, vre, vim, ure, uim; + static double next = -42; + + if (next != -42) { + s = next; + next = -42; + return s; + } + do { + ure = rand_double(); + uim = rand_double(); + vre = 2*ure - 1; + vim = 2*uim - 1; + s = vre*vre + vim*vim; + } while (s >= 1); + s = sqrt(-2*log(s)/s); + next = s * vre; + return s * vim; +} diff --git a/llt/hashing.c b/llt/hashing.c index 98cf182..346b720 100644 --- a/llt/hashing.c +++ b/llt/hashing.c @@ -99,28 +99,6 @@ float rand_float() return f.f - 1.0; } -double randn() -{ - double s, vre, vim, ure, uim; - static double next = -42; - - if (next != -42) { - s = next; - next = -42; - return s; - } - do { - ure = rand_double(); - uim = rand_double(); - vre = 2*ure - 1; - vim = 2*uim - 1; - s = vre*vre + vim*vim; - } while (s >= 1); - s = sqrt(-2*log(s)/s); - next = s * vre; - return s * vim; -} - void randomize() { u_int64_t tm = i64time(); @@ -138,14 +116,6 @@ float F_NINF; void llt_init() { - /* - I used this function to guess good values based on epsilon: - tol(eps) = exp(ln(eps)*-.2334012088721472)*eps - I derived the constant by hallucinating freely. - */ - dbl_tolerance(1e-12); - flt_tolerance(5e-6); - randomize(); ios_init_stdstreams(); diff --git a/llt/htable.inc b/llt/htable.inc index 28a373a..13aecac 100644 --- a/llt/htable.inc +++ b/llt/htable.inc @@ -60,7 +60,7 @@ static void **HTNAME##_lookup_bp(htable_t *h, void *key) \ h->table = tab; \ h->size = newsz; \ for(i=0; i < sz; i+=2) { \ - if (ol[i] != HT_NOTFOUND && ol[i+1] != HT_NOTFOUND) { \ + if (ol[i+1] != HT_NOTFOUND) { \ (*HTNAME##_lookup_bp(h, ol[i])) = ol[i+1]; \ } \ } \ @@ -87,6 +87,7 @@ void **HTNAME##_bp(htable_t *h, void *key) \ } \ \ /* returns bp if key is in hash, otherwise NULL */ \ +/* if return is non-NULL and *bp == HT_NOTFOUND then key was deleted */ \ static void **HTNAME##_peek_bp(htable_t *h, void *key) \ { \ size_t sz = hash_size(h); \ @@ -100,7 +101,7 @@ static void **HTNAME##_peek_bp(htable_t *h, void *key) \ do { \ if (tab[index] == HT_NOTFOUND) \ return NULL; \ - if (EQFUNC(key, tab[index]) && tab[index+1] != HT_NOTFOUND) \ + if (EQFUNC(key, tab[index])) \ return &tab[index+1]; \ \ index = (index+2) & (sz-1); \ diff --git a/llt/operators.c b/llt/operators.c index f02f6a9..73b0c37 100644 --- a/llt/operators.c +++ b/llt/operators.c @@ -167,8 +167,8 @@ int cmp_same_eq(void *a, void *b, numerictype_t tag) case T_UINT32: return *(uint32_t*)a == *(uint32_t*)b; case T_INT64: return *(int64_t*)a == *(int64_t*)b; case T_UINT64: return *(uint64_t*)a == *(uint64_t*)b; - case T_FLOAT: return flt_equals(*(float*)a, *(float*)b); - case T_DOUBLE: return dbl_equals(*(double*)a, *(double*)b); + case T_FLOAT: return *(float*)a == *(float*)b; + case T_DOUBLE: return *(double*)a == *(double*)b; } return 0; } @@ -234,7 +234,7 @@ int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag) double db = conv_to_double(b, btag); if ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT) - return dbl_equals(da, db); + return (da == db); if (da != db) return 0;