glisp/src/hashtable.c

#include "hashtable.h"

#include "lisp.h"
#include "lisp_string.h"

#define INITIAL_SIZE     32
#define GROWTH_THRESHOLD 0.5
#define GROWTH_FACTOR    2

static ALWAYS_INLINE float TABLE_LOAD(LispHashTable *ht) {
    return ((float) ht->count) / ht->size;
}

LispVal *make_hash_table_no_gc(LispVal *hash_fn, LispVal *eq_fn) {
    LispHashTable *obj =
        lisp_alloc_object_no_gc(sizeof(LispHashTable), TYPE_HASH_TABLE);
    obj->eq_fn = eq_fn;
    MARK_OBJECT_ADDED(eq_fn, obj);
    obj->hash_fn = hash_fn;
    MARK_OBJECT_ADDED(hash_fn, obj);
    obj->count = 0;
    obj->size = INITIAL_SIZE;
    obj->data = lisp_malloc0(sizeof(struct HashTableBucket) * obj->size);
    return obj;
}

void release_hash_table_no_gc(LispVal *val) {
    assert(HASH_TABLE_P(val));
    LispHashTable *ht = val;
    lisp_free(ht->data);
    lisp_free(ht);
}

DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn),
      "(hash-fn eq-fn)", "") {
    LispHashTable *obj =
        lisp_alloc_object(sizeof(LispHashTable), TYPE_HASH_TABLE);
    obj->eq_fn = eq_fn;
    MARK_OBJECT_ADDED(eq_fn, obj);
    obj->hash_fn = hash_fn;
    MARK_OBJECT_ADDED(hash_fn, obj);
    obj->count = 0;
    obj->size = INITIAL_SIZE;
    obj->data = lisp_malloc0(sizeof(struct HashTableBucket) * obj->size);
    return obj;
}

static uintptr_t hash_key_for_table(LispHashTable *ht, LispVal *key) {
    if (NILP(ht->hash_fn) || ht->hash_fn == Qid) {
        return (uintptr_t) key;
    } else if (ht->hash_fn == Qhash_string) { // needed for initialization
        return XFIXNUM(Fhash_string(key));
    } else {
        LispVal *hash = CALL(ht->hash_fn, key);
        CHECK_TYPE(hash, TYPE_FIXNUM);
        return XFIXNUM(hash);
    }
}

static bool compare_keys(LispHashTable *ht, LispVal *key1, LispVal *key2) {
    if (NILP(ht->eq_fn) || ht->eq_fn == Qeq) {
        return EQ(key1, key2);
    } else if (ht->eq_fn == Qstrings_equal) { // needed for initialization
        return !NILP(Fstrings_equal(key1, key2));
    } else {
        return !NILP(CALL(ht->eq_fn, key1, key2));
    }
}

static struct HashTableBucket *
find_bucket_for_key(LispHashTable *ht, LispVal *key, uintptr_t hash) {
    assert(TABLE_LOAD(ht) < 0.95f);
    for (uintptr_t i = hash % ht->size; true; i = (i + 1) % ht->size) {
        struct HashTableBucket *cb = &ht->data[i];
        if (HT_BUCKET_EMPTY_P(cb)
            || (cb->hash == hash && compare_keys(ht, key, cb->key))) {
            return cb;
        }
    }
}

static void rehash(LispHashTable *ht, size_t new_size) {
    ht->cache_bucket = NULL;
    struct HashTableBucket *old_data = ht->data;
    size_t old_size = ht->size;
    ht->size = new_size;
    ht->data = lisp_malloc0(sizeof(struct HashTableBucket) * new_size);
    for (size_t i = 0; i < old_size; ++i) {
        struct HashTableBucket *cob = &old_data[i];
        if (!HT_BUCKET_EMPTY_P(cob)) {
            struct HashTableBucket *nb =
                find_bucket_for_key(ht, cob->key, cob->hash);
            nb->hash = cob->hash;
            nb->key = cob->key;
            nb->value = cob->value;
        }
    }
    lisp_free(old_data);
}

static void maybe_rehash(LispHashTable *ht) {
    if (TABLE_LOAD(ht) >= GROWTH_THRESHOLD) {
        rehash(ht, ht->size * GROWTH_FACTOR);
    }
}

DEFUN(gethash, "gethash", (LispVal * ht, LispVal *key, LispVal *def),
      "(ht key &optional def)", "") {
    CHECK_TYPE(ht, TYPE_HASH_TABLE);
    LispHashTable *obj = ht;
    if (obj->cache_bucket && key == obj->cache_bucket->key) {
        return obj->cache_bucket->value;
    }
    uintptr_t hash = hash_key_for_table(obj, key);
    struct HashTableBucket *b = find_bucket_for_key(obj, key, hash);
    obj->cache_bucket = b;
    return HT_BUCKET_EMPTY_P(b) ? def : b->value;
}

DEFUN(puthash, "puthash", (LispVal * ht, LispVal *key, LispVal *val),
      "(ht key val)", "") {
    CHECK_TYPE(ht, TYPE_HASH_TABLE);
    LispHashTable *obj = ht;
    if (obj->cache_bucket && key == obj->cache_bucket->key) {
        obj->cache_bucket->value = val;
        MARK_OBJECT_ADDED(val, ht);
        return Qnil;
    }
    maybe_rehash(ht);
    uintptr_t hash = hash_key_for_table(ht, key);
    struct HashTableBucket *b = find_bucket_for_key(ht, key, hash);
    if (HT_BUCKET_EMPTY_P(b)) {
        b->hash = hash;
        b->key = key;
        MARK_OBJECT_ADDED(key, ht);
    }
    b->value = val;
    MARK_OBJECT_ADDED(val, ht);
    ++((LispHashTable *) ht)->count;
    obj->cache_bucket = b;
    return Qnil;
}

DEFUN(remhash, "remhash", (LispVal * ht, LispVal *key), "(ht key)", "") {
    CHECK_TYPE(ht, TYPE_HASH_TABLE);
    LispHashTable *obj = ht;
    uintptr_t hash = hash_key_for_table(ht, key);
    struct HashTableBucket *b;
    if (obj->cache_bucket && obj->cache_bucket->key == key) {
        b = obj->cache_bucket;
    } else {
        b = find_bucket_for_key(ht, key, hash);
    }
    if (HT_BUCKET_EMPTY_P(b)) {
        return Qnil;
    }
    b->key = NULL;
    LispHashTable *tobj = ht;
    --tobj->count;
    size_t k = hash % tobj->size;
    for (size_t i = (k + 1) % tobj->size; !HT_BUCKET_EMPTY_P(&tobj->data[i]);
         i = (i + 1) % tobj->size) {
        size_t target = tobj->data[i].hash % tobj->size;
        if ((i > k && target >= k && target < i)
            || (i < k && (target >= k || target < i))) {
            tobj->data[k].hash = tobj->data[i].hash;
            tobj->data[k].key = tobj->data[i].key;
            tobj->data[k].value = tobj->data[i].value;
            tobj->data[i].key = NULL;
            k = i;
        }
    }
    obj->cache_bucket = NULL;
    return Qt;
}

DEFUN(hash_table_count, "hash-table-count", (LispVal * ht), "(ht)", "") {
    CHECK_TYPE(ht, TYPE_HASH_TABLE);
    return MAKE_FIXNUM(((LispHashTable *) ht)->count);
}