ref: a4bb09bcb2389b3d6f1cb1a2bc5b344eff6ccecb
parent: e7e5677d51c0c3bf605ecf35ca4e0ab8af3c90bf
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Fri Nov 28 16:44:59 EST 2008
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
--- 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)
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -343,11 +343,6 @@
(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 @@
{ "rand.uint64", fl_rand64 }, { "rand.double", fl_randd }, { "rand.float", fl_randf },- { "randn", fl_randn }, { "path.cwd", fl_path_cwd },--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -109,7 +109,6 @@
pcv->len = sz;
autorelease(pcv);
}
- pcv->deps = NIL;
pcv->type = POP();
return tagptr(pcv, TAG_CVALUE);
}
@@ -144,7 +143,6 @@
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 @@
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;
@@ -680,9 +678,6 @@
else if (iscons(type)) {value_t head = car_(type);
f = ((symbol_t*)ptr(head))->dlcache;
- }
- else {- f = NULL;
}
if (f == NULL)
lerror(ArgError, "c-value: invalid c type");
--- a/femtolisp/equal.c
+++ b/femtolisp/equal.c
@@ -331,8 +331,15 @@
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 @@
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]));
}
--- /dev/null
+++ b/femtolisp/equalhash.c
@@ -1,0 +1,12 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+#include "llt.h"
+#include "flisp.h"
+
+#include "htable.inc"
+
+HTIMPL(equalhash, hash_lispvalue, equal_lispvalue)
--- /dev/null
+++ b/femtolisp/equalhash.h
@@ -1,0 +1,8 @@
+#ifndef __EQUALHASH_H_
+#define __EQUALHASH_H_
+
+#include "htableh.inc"
+
+HTPROT(equalhash)
+
+#endif
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -413,6 +413,11 @@
return v;
}
+value_t relocate_lispvalue(value_t v)
+{+ return relocate(v);
+}
+
static void trace_globals(symbol_t *root)
{ while (root != NULL) {--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -133,7 +133,10 @@
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 {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 @@
unsigned long flagbits;
};
value_t type;
- value_t deps;
//cvtable_t *vtable;
// fields below are absent in inline-allocated values
void *data;
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -30,7 +30,7 @@
}
}
-static void print_traverse(value_t v)
+void print_traverse(value_t v)
{value_t *bp;
while (iscons(v)) {--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -46,24 +46,24 @@
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 @@
value_t fl_table(value_t *args, u_int32_t nargs)
{+ return NIL;
}
value_t fl_hashtablep(value_t *args, u_int32_t nargs)
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -965,8 +965,9 @@
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;
--- 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
--- a/llt/cplxprint.c
+++ b/llt/cplxprint.c
@@ -45,7 +45,7 @@
}
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] = '-';
@@ -52,7 +52,7 @@
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';
--- 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;
--- /dev/null
+++ b/llt/fp.c
@@ -1,0 +1,110 @@
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#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;
+}
--- a/llt/hashing.c
+++ b/llt/hashing.c
@@ -99,28 +99,6 @@
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 @@
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();
--- a/llt/htable.inc
+++ b/llt/htable.inc
@@ -60,7 +60,7 @@
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 @@
} \
\
/* 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 @@
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); \
--- a/llt/operators.c
+++ b/llt/operators.c
@@ -167,8 +167,8 @@
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 @@
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;