glisp/src/stack.c

#include "stack.h"

#include "function.h"
#include "hashtable.h"
#include "list.h"
#include "memory.h"

#include <assert.h>

struct LispStack the_stack;

void lisp_init_stack(void) {
    the_stack.max_depth = DEFAULT_MAX_LISP_EVAL_DEPTH;
    the_stack.depth = 0;
    the_stack.first_clear_local_refs = 0;
    the_stack.frames =
        lisp_malloc(sizeof(struct StackFrame) * the_stack.max_depth);
    for (size_t i = 0; i < the_stack.max_depth; ++i) {
        the_stack.frames[i].local_refs.num_refs = 0;
        the_stack.frames[i].local_refs.num_blocks = 1;
        the_stack.frames[i].local_refs.blocks =
            lisp_malloc(sizeof(struct LocalReferencesBlock *));
        the_stack.frames[i].local_refs.blocks[0] =
            lisp_malloc(sizeof(struct LocalReferencesBlock));
    }
    the_stack.nogc_retval = Qnil;
}

static void teardown_stack_frame(struct StackFrame *restrict frame) {
    for (size_t i = 0; i < frame->local_refs.num_blocks; ++i) {
        lisp_free(frame->local_refs.blocks[i]);
    }
    lisp_free(frame->local_refs.blocks);
}

void lisp_teardown_stack(void) {
    assert(the_stack.depth == 0);
    for (size_t i = 0; i < the_stack.max_depth; ++i) {
        teardown_stack_frame(&the_stack.frames[i]);
    }
    lisp_free(the_stack.frames);
}

void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args) {
    assert(the_stack.depth < the_stack.max_depth);
    struct StackFrame *frame = &the_stack.frames[the_stack.depth++];
    frame->name = name;
    frame->fobj = fobj;
    frame->args = args;
    frame->lexenv = Qnil;
    frame->local_refs.num_refs = 0;
}

static void reset_local_refs(struct LocalReferences *refs) {
    size_t last_block_size = refs->num_refs % LOCAL_REFERENCES_BLOCK_LENGTH;
    size_t num_full_blocks = refs->num_blocks / LOCAL_REFERENCES_BLOCK_LENGTH;
    for (size_t i = 0; i < num_full_blocks; ++i) {
        for (size_t j = 0; j < LOCAL_REFERENCES_BLOCK_LENGTH; ++j) {
            assert(OBJECTP(refs->blocks[i]->refs[j]));
            SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[i]->refs[j], false);
        }
    }
    for (size_t i = 0; i < last_block_size; ++i) {
        assert(OBJECTP(refs->blocks[num_full_blocks]->refs[i]));
        SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[num_full_blocks]->refs[i],
                                       false);
    }
}

void pop_stack_frame(void) {
    assert(the_stack.depth > 0);
    struct StackFrame *frame = &the_stack.frames[--the_stack.depth];
    reset_local_refs(&frame->local_refs);
}

static void store_local_reference_in_frame(struct StackFrame *frame,
                                           LispVal *obj) {
    struct LocalReferences *refs = &frame->local_refs;
    size_t num_full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH;
    if (num_full_blocks == refs->num_blocks) {
        refs->blocks =
            lisp_realloc(refs->blocks, sizeof(struct LocalReferencesBlock *)
                                           * ++refs->num_blocks);
        refs->blocks[refs->num_blocks - 1] =
            lisp_malloc(sizeof(struct LocalReferencesBlock));
        refs->blocks[refs->num_blocks - 1]->refs[0] = obj;
        refs->num_refs += 1;
        the_stack.first_clear_local_refs = the_stack.depth;
    } else {
        refs->blocks[num_full_blocks]
            ->refs[refs->num_refs++ % LOCAL_REFERENCES_BLOCK_LENGTH] = obj;
    }
}

void add_local_reference_no_recurse(LispVal *obj) {
    assert(the_stack.depth > 0);
    if (OBJECTP(obj) && !OBJECT_HAS_LOCAL_REFERENCE_P(obj)) {
        store_local_reference_in_frame(LISP_STACK_TOP(), obj);
    }
}

static LispVal *next_local_reference(size_t *restrict i) {
    if (*i >= LISP_STACK_TOP()->local_refs.num_refs) {
        return NULL;
    }
    size_t block_idx = *i / LOCAL_REFERENCES_BLOCK_LENGTH;
    size_t small_idx = *i % LOCAL_REFERENCES_BLOCK_LENGTH;
    LispVal *obj =
        LISP_STACK_TOP()->local_refs.blocks[block_idx]->refs[small_idx];
    ++*i;
    return obj;
}

static inline void add_local_ref_if_not_seen_no_recurse(LispVal *seen_objs,
                                                        LispVal *obj) {
    if (NILP(Fgethash(seen_objs, obj, Qnil))) {
        add_local_reference_no_recurse(obj);
        Fputhash(seen_objs, obj, Qt);
    }
}

static inline void add_local_refs_for_object_sub_vals(LispVal *seen_objs,
                                                      LispVal *val) {
    switch (((LispObject *) val)->type) {
    case TYPE_CONS:
        add_local_ref_if_not_seen_no_recurse(seen_objs,
                                             ((LispCons *) val)->car);
        add_local_ref_if_not_seen_no_recurse(seen_objs,
                                             ((LispCons *) val)->cdr);
        break;
    case TYPE_SYMBOL: {
        LispSymbol *sym = val;
        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->name);
        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->value);
        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->function);
        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->plist);
        break;
    }
    case TYPE_VECTOR: {
        LispVector *vec = val;
        for (size_t i = 0; i < vec->length; ++i) {
            add_local_ref_if_not_seen_no_recurse(seen_objs, vec->data[i]);
        }
        break;
    }
    case TYPE_HASH_TABLE: {
        HT_FOREACH_INDEX(val, i) {
            add_local_ref_if_not_seen_no_recurse(seen_objs, HASH_KEY(val, i));
            add_local_ref_if_not_seen_no_recurse(seen_objs, HASH_VALUE(val, i));
        }
        break;
    }
    case TYPE_FUNCTION: {
        LispFunction *fobj = val;
        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->name);
        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->docstr);
        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.req);
        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.opt);
        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.kw);
        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.rest);
        break;
    }
    case TYPE_STRING:
        // no held refs
        break;
    case TYPE_FIXNUM:
    case TYPE_FLOAT:
    default:
        abort();
    }
}

void add_local_reference(LispVal *obj) {
    add_local_reference_no_recurse(obj);
    LispVal *seen_objs = make_hash_table_no_gc(Qnil, Qnil);
    Fputhash(seen_objs, obj, Qt);
    size_t i = LISP_STACK_TOP()->local_refs.num_refs - 1;
    LispVal *cur;
    while ((cur = next_local_reference(&i))) {
        add_local_refs_for_object_sub_vals(seen_objs, cur);
    }
    release_hash_table_no_gc(seen_objs);
}

void compact_stack_frame(struct StackFrame *restrict frame) {
    struct LocalReferences *restrict refs = &frame->local_refs;
    for (size_t i = 1; i < refs->num_blocks; ++i) {
        lisp_free(refs->blocks[i]);
    }
    lisp_realloc(refs->blocks, sizeof(struct LocalReferencesBlock *));
    refs->num_blocks = 1;
}

bool set_lexical_variable(LispVal *name, LispVal *value,
                          bool create_if_absent) {
    assert(the_stack.depth != 0);
    DOTAILS(rest, LISP_STACK_TOP()->lexenv) {
        if (EQ(XCAR(rest), name)) {
            RPLACA(XCDR(rest), value);
            return true;
        }
    }
    if (create_if_absent) {
        new_lexical_variable(name, value);
    }
    return create_if_absent;
}

void new_lexical_variable(LispVal *name, LispVal *value) {
    assert(the_stack.depth != 0);
    LISP_STACK_TOP()->lexenv =
        CONS(name, CONS(value, LISP_STACK_TOP()->lexenv));
}

void copy_parent_lexenv(void) {
    assert(the_stack.depth != 0);
    if (the_stack.depth > 1) {
        LISP_STACK_TOP()->lexenv = the_stack.frames[the_stack.depth - 2].lexenv;
    }
}