slime/src/memory.cpp

namespace Memory {

    // ------------------
    //   global symbol / keyword table
    // ------------------
    String_Hash_Map* global_symbol_table;
    String_Hash_Map* global_keyword_table;

    // ------------------
    //   lisp_objects
    // ------------------
    int object_memory_size;
    Int_Array_List free_spots_in_object_memory;
    Lisp_Object* object_memory;
    int next_index_in_object_memory = 0;

    // ------------------
    //   environments
    // ------------------
    int environment_memory_size;
    Environment_Array_List free_spots_in_environment_memory;
    Environment* environment_memory;
    int next_index_in_environment_memory = 0;

    // ------------------
    //   strings
    // ------------------
    int string_memory_size; //  = 4096 * 1024; // == 98304kb == 96mb
    // free_spots_in_string_memory is an arraylist of pointers into
    // the string_memory, where dead String objects live (which give
    // information about their size)
    Void_Ptr_Array_List free_spots_in_string_memory;
    String* string_memory;
    String* next_free_spot_in_string_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);
    }

    inline proc get_type(Lisp_Object* node) -> Lisp_Object_Type {
        // the type is in the bits 0 to 5 (including)
        return (Lisp_Object_Type) ((u64)node->flags & (u64)0b11111);
    }


    inline proc set_type(Lisp_Object* node, Lisp_Object_Type type) {
        // the type is in the bits 0 to 5 (including)
        u64 bitmask = (u64)-1;
        bitmask -= 0b11111;
        bitmask += (u64) type;
        node->flags = (u64)(node->flags) | bitmask;
    }

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

        return value;

    }

    proc create_string(const char* str, int len) -> String* {
        // TODO(Felix): check the holes first, not just always append
        // at the end

        String* ret = next_free_spot_in_string_memory;
        ret->length = len;
        strcpy(&ret->data, str);

        // now update the next_free_spot_in_string_memory pointer:
        // overstrep the counter and the first char (thik of it as if
        // we were overstepping the last ('\0') char) and then we only
        // need to overstep 'len' more chars
        next_free_spot_in_string_memory += 1;

        // overstep the other chars
        next_free_spot_in_string_memory = ((String*)((char*)next_free_spot_in_string_memory)+len);
        return ret;
    }

    proc delete_string(String* str) {
        append_to_array_list(&free_spots_in_string_memory, (void*)str);
    }

    proc duplicate_string(String* str) -> String* {
        return create_string(get_c_str(str), str->length);
    }

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

    // proc create_string_formatted (const char* format, ...) -> String* {
    //     // HACK(Felix): the length of all strings is 200!!!!!!!!!!
    //     // HACK(Felix): the length of all strings is 200!!!!!!!!!!
    //     int length = 200;
    //     String* ret = create_string("", length);

    //     int written_length;
    //     va_list args;
    //     va_start(args, format);
    //     written_length = vsnprintf(&ret->data, length, format, args);
    //     va_end(args);

    //     ret->length = written_length;
    //     return ret;
    // }

    proc create_lisp_object() -> Lisp_Object* {
        int index;
        // if we have no free spots then append at the end
        if (free_spots_in_object_memory.next_index == 0) {
            // if we still have space
            if (object_memory_size == next_index_in_object_memory) {
                create_out_of_memory_error(
                    "There is not enough space in the lisp object "
                    "memory to allocate additional lisp objects. "
                    "Maybe try increasing the Memory size when "
                    "calling Memory::init()");
                return nullptr;
            }
            index = next_index_in_object_memory++;
        } else {
            // else fill a free spot, and remove the free spot
            index = free_spots_in_object_memory.data[free_spots_in_object_memory.next_index--];
        }
        Lisp_Object* object = object_memory+index;
        object->flags = 0;
        object->sourceCodeLocation = nullptr;
        object->userType  = nullptr;
        object->docstring = nullptr;
        return object;
    }

    proc free_everything() {
        free(global_symbol_table);
        free(global_keyword_table);
        free(object_memory);
        free(environment_memory);
        free(string_memory);
    }

    proc init(int oms, int ems, int sms) {
        global_symbol_table  = create_String_hashmap();
        global_keyword_table = create_String_hashmap();

        object_memory_size      = oms;
        environment_memory_size = ems;
        string_memory_size      = sms;

        free_spots_in_object_memory      = create_Int_array_list();
        free_spots_in_environment_memory = create_Environment_array_list();
        free_spots_in_string_memory      = create_Void_Ptr_array_list();

        object_memory      = (Lisp_Object*)malloc(object_memory_size      * sizeof(Lisp_Object));
        environment_memory = (Environment*)malloc(environment_memory_size * sizeof(Environment));
        string_memory      = (String*)malloc(string_memory_size           * sizeof(char));

        next_free_spot_in_string_memory = string_memory;

        // init nil
        try_void nil = create_lisp_object();
        set_type(nil, Lisp_Object_Type::Nil);

        // init t
        try_void t = create_lisp_object();
        set_type(t, Lisp_Object_Type::T);

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

        Globals::Current_Execution::envi_stack.next_index = 0;
        push_environment(create_built_ins_environment());

    }

    proc reset() -> void {
        free_spots_in_object_memory.next_index      = 0;
        free_spots_in_environment_memory.next_index = 0;
        free_spots_in_string_memory.next_index      = 0;

        global_symbol_table  = create_String_hashmap();
        global_keyword_table = create_String_hashmap();

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

        // because t and nil are always there we start the index at 2
        next_index_in_object_memory      = 2;
        next_index_in_environment_memory = 0;
        next_free_spot_in_string_memory  = string_memory;

        Globals::Current_Execution::envi_stack.next_index = 0;
        push_environment(create_built_ins_environment());
    }

    proc create_lisp_object_pointer(void* ptr) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        set_type(node, 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();
        set_type(node, Lisp_Object_Type::HashMap);
        node->value.hashMap = create_Lisp_Obj_hashmap();
        return node;
    }

    proc create_lisp_object_number(double number) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        set_type(node, Lisp_Object_Type::Number);
        node->value.number = number;
        return node;
    }

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

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

    proc allocate_vector(int size) -> Lisp_Object* {
        // NOTE(Felix): Vectors are now only allocated at the back of
        // the memory, we don't check the free list at all right now

        if (object_memory_size - next_index_in_object_memory < size) {
            create_out_of_memory_error(
                "There is not enough space in the lisp object "
                "memory to allocate additional lisp objects. "
                "Maybe try increasing the Memory size when "
                "calling Memory::init()");
            return nullptr;
        }

        int start = next_index_in_object_memory;
        next_index_in_object_memory += size;
        return object_memory+start;
    }

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

        Lisp_Object* node;
        try node = create_lisp_object();
        set_type(node, Lisp_Object_Type::Vector);

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

        Lisp_Object* head = element_list;

        int 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_new_lisp_object_symbol(String* identifier) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        set_type(node, Lisp_Object_Type::Symbol);
        node->value.symbol.identifier = identifier;
        node->value.symbol.hash = hash(identifier);
        hm_set(global_symbol_table, get_c_str(identifier), node);
        return node;
    }

    proc create_new_lisp_object_keyword(String* keyword) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        set_type(node, Lisp_Object_Type::Keyword);
        node->value.symbol.identifier = keyword;
        node->value.symbol.hash = hash(keyword);
        hm_set(global_keyword_table, get_c_str(keyword), node);
        return node;
    }

    proc get_or_create_lisp_object_symbol(String* identifier) -> Lisp_Object* {
        if (auto ret = hm_get_object(global_symbol_table, get_c_str(identifier)))
            return (Lisp_Object*)ret;
        else
            return create_new_lisp_object_symbol(identifier);
    }

    proc get_or_create_lisp_object_symbol(const char* identifier) -> Lisp_Object* {
        if (auto ret = hm_get_object(global_symbol_table, (char*)identifier))
            return (Lisp_Object*)ret;
        else {
            String* str;
            try str = Memory::create_string(identifier);
            return create_new_lisp_object_symbol(str);
        }
    }

    proc get_or_create_lisp_object_keyword(String* keyword) -> Lisp_Object* {
        if (auto ret = hm_get_object(global_keyword_table, get_c_str(keyword)))
            return (Lisp_Object*)ret;
        else
            return create_new_lisp_object_keyword(keyword);
    }

    proc get_or_create_lisp_object_keyword(const char* keyword) -> Lisp_Object* {
        if (auto ret = hm_get_object(global_keyword_table, (char*)keyword))
            return (Lisp_Object*)ret;
        else {
            String* str;
            try str = Memory::create_string(keyword);
            return create_new_lisp_object_keyword(str);
        }
    }

    proc create_lisp_object_cfunction(bool is_special) -> Lisp_Object* {
        Lisp_Object* node;
        try node = create_lisp_object();
        set_type(node, Lisp_Object_Type::CFunction);
        // node->value.lambdaWrapper = new Lambda_Wrapper(function);
        node->value.cFunction = new(cFunction);
        node->value.cFunction->args = {};
        node->value.cFunction->is_special_form = is_special;
        return node;
    }

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

    proc copy_lisp_object(Lisp_Object* n) -> Lisp_Object* {
        // TODO(Felix): If argument is a list (pair), do a FULL copy,

        // we don't copy singleton objects
        if (n == Memory::nil || n == Memory::t ||
            Memory::get_type(n) == Lisp_Object_Type::Symbol ||
            Memory::get_type(n) == Lisp_Object_Type::Keyword)
        {
            return n;
        }

        Lisp_Object* target;
        try target = create_lisp_object();
        *target = *n;
        return target;
    }

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

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

        Environment* env;
        // if we have no free spots then append at the end
        if (free_spots_in_environment_memory.next_index == 0) {
            int index;
            // if we still have space
            if (environment_memory_size == next_index_in_environment_memory) {
                create_out_of_memory_error(
                    "There is not enough space in the environment "
                    "memory to allocate additional environments. "
                    "Maybe try increasing the Memory size when "
                    "calling Memory::init()");
                return nullptr;
            }
            index = next_index_in_environment_memory++;
            env = environment_memory+index;
        } else {
            // else fill a free spot, and remove the free spot
            env = free_spots_in_environment_memory.data[--free_spots_in_environment_memory.next_index];
        }

        int start_capacity = 16;

        env->parents = create_Environment_array_list();

        if (parent)
            append_to_array_list(&env->parents, parent);

        env->hm = create_Void_Ptr_hashmap();

        return env;
    }

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

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

        load_built_ins_into_environment();

        // save the current working directory
        //char* cwd = get_cwd();
        //defer {
        //    change_cwd(cwd);
        //    free(cwd);
        //};

        //// get the direction of the exe
        //char* exe_path = get_exe_dir();
        //change_cwd(exe_path);
        //free(exe_path);

        built_in_load(Memory::create_string("pre.slime"));

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