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

@@ -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)

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 },
 

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");
 

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]));
 }

femtolisp/equalhash.c

@@ -0,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)

femtolisp/equalhash.h

@@ -0,0 +1,8 @@
+#ifndef __EQUALHASH_H_
+#define __EQUALHASH_H_
+
+#include "htableh.inc"
+
+HTPROT(equalhash)
+
+#endif

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) {

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;

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)) {

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)

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;

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

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';

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;

llt/fp.c

@@ -0,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;
+}

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();

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);                                     \

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;