slime/src/memory.cpp

namespace Slime::Memory {

    // ------------------
    //   global symbol / keyword table
    // ------------------
    Hash_Map<char*, Lisp_Object*> global_symbol_table;
    Hash_Map<char*, Lisp_Object*> global_keyword_table;


    Hash_Map<char*, Environment*> file_to_env_map;
    // ------------------
    //   lisp_objects
    // ------------------
    Bucket_Allocator<Lisp_Object> object_memory;

    // ------------------
    //   environments
    // ------------------
    Bucket_Allocator<Environment> environment_memory;

    // NOTE(Felix): we are doing hashmaps separately so we don't have
    // to malloc them every time, and if two lisp objects have the
    // same hashmap, it will not cause double free problems when
    // freeing all at the end. It also plays nice with garbage
    // collection
    // ------------------
    //   Hashmaps
    // ------------------
    Bucket_Allocator<Hash_Map<Lisp_Object*, Lisp_Object*>> hashmap_memory;

    // ------------------
    //   immutables
    // ------------------
    Lisp_Object* nil     = nullptr;
    Lisp_Object* t       = nullptr;


    proc print_status() {
        // printf("Memory Status:\n"
        //        " - %f%% of the object_memory is used\n"
        //        " - %d of %d total Lisp_Objects are in use\n"
        //        " - %d holes in used memory (fragmentation)\n",
        //        (1.0*next_index_in_object_memory - free_spots_in_object_memory.next_index)/object_memory_size,
        //        next_index_in_object_memory - free_spots_in_object_memory.next_index, object_memory_size,
        //        free_spots_in_object_memory.next_index);

        // printf("Memory Status:\n"
        //        " - %f%% of the string_memory is used\n"
        //        " - %d holes in used memory (fragmentation)\n",
        //        (1.0*(size_t)next_free_spot_in_string_memory - (size_t)string_memory)/string_memory_size,
        //        free_spots_in_string_memory.next_index);
    }

    inline proc get_c_str(String str) -> char* {
        return str.data;
    }

    inline proc get_c_str(Lisp_Object* str) -> char* {
        assert_type(str, Lisp_Object_Type::String);
        return get_c_str(str->value.string);
    }

    proc hash(String str) -> u64 {
        // TODO(Felix): When parsing symbols or keywords, compute the
        // hash while reading them in.
        u64 value = str.data[0] << 7;
        for (u32 i = 1; i < str.length; ++i) {
            char c = str.data[i];
            value = (1000003 * value) ^ c;
        }
        value ^= str.length;

        return value;

    }

    proc create_string(const char* str, u32 len) -> String {
        String s = {
            len,
            (char*)malloc(sizeof(char) * len + 1)
        };
        strcpy(s.data, str);
        return s;
    }

    proc create_string (const char* str) -> String {
        return create_string(str, (u32)strlen(str));
    }

    proc duplicate_string(String str) -> String {
        return create_string(str.data, str.length);
    }

    proc create_lisp_object() -> Lisp_Object* {
        Lisp_Object* object = object_memory.allocate();
        object->type = Lisp_Object_Type::Invalid_Under_Construction;
        return object;
    }

    proc free_everything() -> void {
        object_memory.for_each([](Lisp_Object* lo){
            switch (lo->type) {
            case Lisp_Object_Type::Function: {
                lo->value.function->args.positional.symbols.dealloc();
                lo->value.function->args.keyword.keywords.dealloc();
                lo->value.function->args.keyword.values.dealloc();
                free(lo->value.function);
            } break;
            case Lisp_Object_Type::Symbol:
            case Lisp_Object_Type::Keyword:
            case Lisp_Object_Type::String: {
                free(lo->value.string.data);
            } break;
            default: break;
            }
        });
        environment_memory.for_each([](Environment* env){
            env->parents.dealloc();
            env->hm.dealloc();
        });
        hashmap_memory.for_each([](Hash_Map<Lisp_Object*, Lisp_Object*>* hm){
            hm->dealloc();
        });

        for_hash_map(Globals::docs) {
            free(value);
        }

        // free the exe dir:
        free(Globals::load_path.data[0]);
        // Globals::load_path.dealloc();
        Globals::user_types.dealloc();
        Globals::docs.dealloc();
        Globals::Current_Execution::envi_stack.dealloc();
        Globals::Current_Execution::cs.dealloc();
        Globals::Current_Execution::ams.dealloc();
        Globals::Current_Execution::pcs.dealloc();
        Globals::Current_Execution::nass.dealloc();
        Globals::Current_Execution::ats.dealloc();
        Globals::Current_Execution::mes.dealloc();

        free(Parser::standard_in.data);

        object_memory.dealloc();
        environment_memory.dealloc();
        hashmap_memory.dealloc();

        global_symbol_table.dealloc();
        global_keyword_table.dealloc();
        file_to_env_map.dealloc();
    }


    proc create_child_environment(Environment* parent) -> Environment*  {

        Environment* env = environment_memory.allocate();

        // inject a new array list;
        env->parents.alloc();
        env->hm.alloc();
        if (parent)
            env->parents.append(parent);

        new(&env->hm) Hash_Map<void*, Lisp_Object*>;

        return env;
    }

    proc create_empty_environment() -> Environment* {
        Environment* ret;
        try ret = create_child_environment(nullptr);
        return ret;
    }

    proc load_pre() -> void {
        String file_name = Memory::create_string("pre.slime");
        defer_free(file_name.data);
        try_void built_in_load(file_name);
    }
    proc init() -> void {
        profile_this();

        object_memory.alloc(1024, 8);
        environment_memory.alloc(1024, 8);
        hashmap_memory.alloc(256, 8);

        system_shutdown_hook << [&] {
            if_debug {
                Slime::Memory::free_everything();
            }
        };
        char* exe_path = get_exe_dir();


        global_symbol_table.alloc();
        global_keyword_table.alloc();
        file_to_env_map.alloc();

        Globals::Current_Execution::envi_stack.alloc();
        Globals::Current_Execution::cs.alloc();
        Globals::Current_Execution::nass.alloc();
        Globals::Current_Execution::pcs.alloc();
        Globals::Current_Execution::ams.alloc();
        Globals::Current_Execution::ats.alloc();
        Globals::Current_Execution::mes.alloc();

        Globals::docs.alloc();
        Globals::user_types.alloc();
        // Globals::load_path.alloc();
        add_to_load_path(exe_path);
        add_to_load_path("../bin/");


        // init nil
        try_void nil = create_lisp_object();
        nil->type = Lisp_Object_Type::Nil;

        // init t
        try_void t = create_lisp_object();
        t->type = Lisp_Object_Type::T;

        try_void Parser::standard_in = create_string("stdin");

        Globals::Current_Execution::envi_stack.next_index = 0;
        Environment* env;
        try_void env = create_built_ins_environment();
        push_environment(env);


    }


    proc create_lisp_object(void* ptr) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type =  Lisp_Object_Type::Pointer;
        node->value.pointer = ptr;
        return node;
    }

    proc create_lisp_object_hash_map() -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::HashMap;
        node->value.hashMap = hashmap_memory.allocate();
        node->value.hashMap->alloc();
        return node;
    }

    proc create_lisp_object(f64 number) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::Number;
        node->value.number = number;
        return node;
    }

    proc create_lisp_object(String str) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::String;
        node->value.string = str;
        return node;
    }

    proc create_lisp_object(const char* str) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::String;
        node->value.string = create_string(str);
        return node;
    }

    proc allocate_vector(u32 size) -> Lisp_Object* {
        Lisp_Object* ret = object_memory.allocate(size);
        if (!ret) {
            create_out_of_memory_error("The vector is too big to fit in a memory bucket.");
            return nullptr;
        }
        return ret;
    }

    proc create_lisp_object_vector(u32 length, Lisp_Object* element_list) -> Lisp_Object* {
        try assert_type(element_list, Lisp_Object_Type::Pair);

        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::Vector;

        node->value.vector.length = length;
        try node->value.vector.data = allocate_vector(length);

        Lisp_Object* head = element_list;

        u32 i = 0;
        while (head != Memory::nil) {
            node->value.vector.data[i] = *head->value.pair.first;
            head = head->value.pair.rest;
            ++i;
        }

        return node;
    }

    proc create_lisp_object_vector(Lisp_Object* e1) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type =  Lisp_Object_Type::Vector;

        node->value.vector.length = 1;
        try node->value.vector.data = allocate_vector(1);

        node->value.vector.data[0] = *e1;

        return node;
    }

    proc create_lisp_object_vector(Lisp_Object* e1, Lisp_Object* e2) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::Vector;

        node->value.vector.length = 2;
        try node->value.vector.data = allocate_vector(2);

        node->value.vector.data[0] = *e1;
        node->value.vector.data[1] = *e2;

        return node;
    }

    proc create_lisp_object_vector(Lisp_Object* e1, Lisp_Object* e2, Lisp_Object* e3) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::Vector;

        node->value.vector.length = 3;
        try node->value.vector.data = allocate_vector(3);

        node->value.vector.data[0] = *e1;
        node->value.vector.data[1] = *e2;
        node->value.vector.data[2] = *e3;

        return node;
    }

    inline proc _create_symbol(char* identifier) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::Symbol;
        node->value.symbol = create_string(identifier);
        global_symbol_table.set_object((char*)node->value.symbol.data, node);
        return node;
    }

    inline proc get_symbol(String identifier) -> Lisp_Object* {
        return get_symbol(identifier.data);
    }

    inline proc get_symbol(const char* identifier) -> Lisp_Object* {
        if (Lisp_Object* ret = global_symbol_table.get_object((char*)identifier))
            return (Lisp_Object*)ret;
        return _create_symbol((char*)identifier);
    }

    inline proc _create_keyword(char* identifier) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::Keyword;
        node->value.symbol = create_string(identifier);
        global_keyword_table.set_object((char*)node->value.symbol.data, node);
        return node;
    }

    inline proc get_keyword(String identifier) -> Lisp_Object* {
        return get_keyword(identifier.data);
    }

    inline proc get_keyword(const char* identifier) -> Lisp_Object* {
        if (Lisp_Object* ret = global_keyword_table.get_object((char*)identifier))
            return ret;
        return _create_keyword((char*)identifier);
    }

    proc create_lisp_object_cfunction(C_Function_Type type) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::Function;
        node->value.function = (Function*)malloc(sizeof(Function));
        node->value.function->type.c_function_type = type;
        node->value.function->args.keyword.keywords.alloc();
        node->value.function->args.keyword.values.alloc();
        node->value.function->args.positional.symbols.alloc();
        node->value.function->is_c = true;
        return node;
    }

    proc create_lisp_object_function(Lisp_Function_Type ft) -> Lisp_Object* {
        Lisp_Object* func;
        try func = Memory::create_lisp_object();
        func->type = Lisp_Object_Type::Function;
        func->value.function = (Function*)malloc(sizeof(Function));
        func->value.function->args.keyword.keywords.alloc();
        func->value.function->args.keyword.values.alloc();
        func->value.function->args.positional.symbols.alloc();
        func->value.function->type.lisp_function_type = ft;
        func->value.function->is_c = false;
        return func;
    }

    proc create_lisp_object_pair(Lisp_Object* first, Lisp_Object* rest) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        node->type = Lisp_Object_Type::Pair;
        node->value.pair.first = first;
        node->value.pair.rest = rest;
        return node;
    }

    proc copy_lisp_object(Lisp_Object* n) -> Lisp_Object* {
        // QUESTION(Felix): If argument is a list (cons), should we do
        // a full copy?

        // we don't copy singleton objects
        if (n == Memory::nil || n == Memory::t) {
            return n;
        } else {
            Lisp_Object_Type type = n->type;
            if (type == Lisp_Object_Type::Symbol  ||
                type == Lisp_Object_Type::Keyword ||
                type == Lisp_Object_Type::Function)
            {
                return n;
            } else if (type == Lisp_Object_Type::String) {
                Lisp_Object* target;
                try target = create_lisp_object();
                *target = *n;
                target->value.string = create_string(target->value.string.data);
                return target;
            } else {
                Lisp_Object* target;
                try target = create_lisp_object();
                *target = *n;

                return target;
            }
        }
    }

    proc copy_lisp_object_except_pairs(Lisp_Object* n) -> Lisp_Object* {
        if (n->type == Lisp_Object_Type::Pair)
            return n;
        return copy_lisp_object(n);
    }

    proc create_built_ins_environment() -> Environment* {
        Environment* ret;
        try ret = create_empty_environment();
        push_environment(ret);
        defer {
            pop_environment();
        };

        try load_built_ins_into_environment();
        return ret;
    }


    inline proc create_list(Lisp_Object* o1) -> Lisp_Object* {
        Lisp_Object* ret;
        try ret = create_lisp_object_pair(o1, nil);
        return ret;
    }

    inline proc create_list(Lisp_Object* o1, Lisp_Object* o2) -> Lisp_Object* {
        Lisp_Object* ret;
        try ret = create_lisp_object_pair(o1, create_list(o2));
        return ret;
    }

    inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3) -> Lisp_Object* {
        Lisp_Object* ret;
        try ret = create_lisp_object_pair(o1, create_list(o2, o3));
        return ret;
    }

    inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4) -> Lisp_Object* {
        Lisp_Object* ret;
        try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4));
        return ret;
    }

    inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4, Lisp_Object* o5) -> Lisp_Object* {
        Lisp_Object* ret;
        try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4, o5));
        return ret;
    }

    inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4, Lisp_Object* o5, Lisp_Object* o6) -> Lisp_Object* {
        Lisp_Object* ret;
        try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4, o5, o6));
        return ret;
    }
}