Add mark&sweep GC

Makefile

@@ -7,7 +7,7 @@ test: aqaml test.sh utility.o
 	./test.sh
 
 utility.o: utility.c
-	gcc -Wall -std=c11 -c -o $@ $^
+	gcc -Wall -std=c11 -O0 -g3 -c -o $@ $^
 
 _self_aqaml: stdlib.ml $(SRC) utility.o aqaml
 	./aqaml stdlib.ml $(SRC) > _self_aqaml.s

generator.ml

@@ -81,9 +81,11 @@ let rec generate (letfuncs, strings, typedefs, exps) =
     appfmt buf "%s:" exit_label ;
     Buffer.contents buf
   in
+  let save_rsp = "mov [rip + aqaml_current_rsp], rsp" in
   let rec gen_alloc_block size color tag =
     (* allocated block address is in rax *)
     let buf = Buffer.create 128 in
+    appstr buf save_rsp ;
     appfmt buf "mov rdi, %d" size ;
     appfmt buf "mov rsi, %d" color ;
     appfmt buf "mov rdx, %d" tag ;
@@ -948,6 +950,7 @@ let rec generate (letfuncs, strings, typedefs, exps) =
     let buf = Buffer.create 512 in
     let gen_c_func funcname argument_types ret_type =
       appfmt buf "%s:" funcname ;
+      appstr buf save_rsp ;
       List.iteri
         (fun i -> function
           | CTyInt | CTyUnit -> appstr buf @@ untag_int @@ reg_of_index i
@@ -1018,6 +1021,7 @@ let rec generate (letfuncs, strings, typedefs, exps) =
     appstr buf "ret" ;
     appstr buf "" ;
     appstr buf "aqaml_open_in:" ;
+    appstr buf save_rsp ;
     let exit_label = make_label () in
     appstr buf "mov rdi, rax" ;
     appstr buf @@ gen_call_with_aligned_rsp "aqaml_open_in_detail@PLT" ;
@@ -1117,7 +1121,6 @@ let rec generate (letfuncs, strings, typedefs, exps) =
     appstr buf "" ;
     appstr buf ".global main" ;
     appstr buf "main:" ;
-    appstr buf "push rbp" ;
     appstr buf "mov rbp, rsp" ;
     (* handle command-line arguments *)
     appstr buf "push rsi" ;
@@ -1149,6 +1152,7 @@ let rec generate (letfuncs, strings, typedefs, exps) =
     appfmt buf "jmp %s" loop_label ;
     appfmt buf "%s:" exit_label ;
     appstr buf ".data" ;
+    appstr buf ".global aqaml_sys_argv" ;
     appstr buf "aqaml_sys_argv:" ;
     appstr buf ".space 8" ;
     appstr buf ".text" ;
@@ -1160,18 +1164,20 @@ let rec generate (letfuncs, strings, typedefs, exps) =
     appstr buf "mov r14, rsp" ;
     (* set start address of stack *)
     appstr buf ".data" ;
+    appstr buf ".global aqaml_initial_rsp" ;
     appstr buf "aqaml_initial_rsp:" ;
     appstr buf ".zero 8" ;
+    appstr buf ".global aqaml_current_rsp" ;
+    appstr buf "aqaml_current_rsp:" ;
+    appstr buf ".zero 8" ;
     appstr buf ".text" ;
     appstr buf "mov [rip + aqaml_initial_rsp], rsp" ;
     (* give unit value as an argument *)
     appfmt buf "mov rax, %d" @@ tagged_int 0 ;
     appstr buf "call aqaml_main" ;
     appstr buf "pop rax" ;
     appstr buf "pop rax" ;
-    appstr buf "mov rax, 0" ;
-    appstr buf "pop rbp" ;
-    appstr buf "ret" ;
+    appstr buf @@ gen_call_with_aligned_rsp "aqaml_gracefully_exit@PLT" ;
     appstr buf "aqaml_default_exception_handler:" ;
     appfmt buf "mov rax, %d" @@ tagged_int 1 ;
     appstr buf "call aqaml_exit" ;

test.ml

@@ -668,6 +668,7 @@ let rec length lst =
 test (length [1; 2; 3]) 3 ;
 test (length []) 0
 
+
 ;;
 let nqueen n =
   let rec safe q qs =

utility.c

@@ -7,7 +7,92 @@
 #include <stdlib.h>
 #include <string.h>
 
-extern uint64_t aqaml_initial_rsp;
+////// struct Vector implementation from here
+
+typedef struct Vector Vector;
+struct Vector {
+    void **data;
+    size_t size, rsved_size;
+};
+
+Vector *new_vector(void)
+{
+    Vector *ret = (Vector *)malloc(sizeof(Vector));
+    ret->size = 0;
+    ret->rsved_size = 0;
+    ret->data = NULL;
+    return ret;
+}
+
+// NOTE: delete_vector() WILL NOT call free(3) for each element in the vector,
+//       since it doesn't know the actual content of each one.
+void delete_vector(Vector *vec)
+{
+    if (vec->data != NULL) free(vec->data);
+    free(vec);
+}
+
+void vector_push_back(Vector *vec, void *item)
+{
+    assert(vec != NULL);
+
+    if (vec->size == vec->rsved_size) {
+        vec->rsved_size = vec->rsved_size > 0 ? vec->rsved_size * 2 : 2;
+        // TODO: Use realloc(3), which somehow show an "Illegal instruction"
+        // error.
+        void **ndata = (void **)malloc(sizeof(void *) * vec->rsved_size);
+        if (vec->data != NULL) {
+            memcpy(ndata, vec->data, vec->size * sizeof(void *));
+            free(vec->data);
+        }
+        vec->data = ndata;
+    }
+
+    vec->data[vec->size++] = item;
+}
+
+void *vector_pop_back(Vector *vec)
+{
+    if (vec->size == 0) return NULL;
+    return vec->data[--vec->size];
+}
+
+void *vector_get(Vector *vec, size_t i)
+{
+    if (i >= vec->size) return NULL;
+    return vec->data[i];
+}
+
+size_t vector_size(Vector *vec)
+{
+    return vec->size;
+}
+
+void *vector_set(Vector *vec, size_t i, void *item)
+{
+    assert(vec != NULL && i < vector_size(vec));
+    vec->data[i] = item;
+    return item;
+}
+
+void vector_push_back_vector(Vector *vec, Vector *src)
+{
+    for (size_t i = 0; i < vector_size(src); i++)
+        vector_push_back(vec, vector_get(src, i));
+}
+
+void vector_sort(Vector *vec, int (*compar)(const void *, const void *))
+{
+    qsort(vec->data, vec->size, sizeof(void *), compar);
+}
+
+////// struct Vector implementation to here
+
+extern uint64_t aqaml_initial_rsp, aqaml_current_rsp;
+extern uint64_t aqaml_sys_argv;
+static Vector *malloced_regions = NULL;
+enum GC_COLOR { WHITE = 0, BLACK = 3, GRAY = 1, BLUE = 2 };
+static const int No_scan_tag = 251;
 
 typedef struct AQamlValue {
     enum {
@@ -88,25 +173,125 @@ uint32_t aqaml_structural_equal_detail(uint64_t lhs_src, uint64_t rhs_src)
     return 1;
 }
 
+int aqaml_gc_is_malloced(uint64_t value)
+{
+    assert(malloced_regions != NULL);
+
+    if ((value & 1) == 1) return 0;  // integer
+
+    // [begin, end)
+    uint64_t begin = 0, end = vector_size(malloced_regions);
+    while (end - begin > 1) {
+        uint64_t mid = begin + (end - begin) / 2;
+        uint64_t t = (uint64_t)vector_get(malloced_regions, mid);
+        if (t <= value)
+            begin = mid;
+        else
+            end = mid;
+    }
+
+    return (uint64_t)vector_get(malloced_regions, begin) == value;
+}
+
+void aqaml_gc_mark_block(uint64_t *ptr)
+{
+    uint64_t size = ptr[0] >> 10, color = (ptr[0] >> 8) & 3,
+             tag = ptr[0] & 0xff;
+    if (color != WHITE) return;  // already scanned or partially scanned
+
+    if (tag > No_scan_tag) {  // opaque block
+        ptr[0] |= (3 << 8);
+        return;
+    }
+
+    // start marking this block
+    ptr[0] |= (1 << 8);  // make the color GRAY
+    for (uint64_t i = 0; i < size; i++) {
+        uint64_t elm = ptr[i + 1] - 8;
+        if (aqaml_gc_is_malloced(elm)) aqaml_gc_mark_block((uint64_t *)elm);
+    }
+    // end marking
+    ptr[0] |= (1 << 9);  // make the color BLACK
+}
+
+int aqaml_gc_compar_for_malloced_regions(const void *lhs, const void *rhs)
+{
+    if (*(uint64_t *)lhs < *(uint64_t *)rhs) return -1;
+    if (*(uint64_t *)rhs < *(uint64_t *)lhs) return 1;
+    return 0;
+}
+
+void aqaml_gc(void)
+{
+    if (aqaml_initial_rsp == 0) return;
+
+    assert(aqaml_current_rsp < aqaml_initial_rsp);
+    assert((aqaml_initial_rsp - aqaml_current_rsp) % 8 == 0);
+
+    vector_sort(malloced_regions, aqaml_gc_compar_for_malloced_regions);
+
+    // Let's mark.
+    // First, mark pointers on the stack.
+    uint64_t size = (aqaml_initial_rsp - aqaml_current_rsp) / 8;
+    for (uint64_t i = 0; i < size; i++) {
+        uint64_t elm = *(uint64_t *)(aqaml_current_rsp + i * 8) - 8;
+        if (aqaml_gc_is_malloced(elm))
+            // decrease for block's header
+            aqaml_gc_mark_block((uint64_t *)elm);
+    }
+    // Then, mark global pointers.
+    aqaml_gc_mark_block((uint64_t *)(aqaml_sys_argv - 8));
+
+    // Let's sweep.
+    Vector *new_malloced_regions = new_vector();
+    for (int i = 0; i < vector_size(malloced_regions); i++) {
+        uint64_t *ptr = (uint64_t *)vector_get(malloced_regions, i);
+        uint64_t color = (ptr[0] >> 8) & 3;
+        switch (color) {
+        case BLACK:  // marked
+            vector_push_back(new_malloced_regions, ptr);
+            break;
+        case WHITE:  // not marked i.e. should be freed
+            free(ptr);
+            break;
+        default:  // unreachable
+            assert(0);
+        }
+    }
+    delete_vector(malloced_regions);
+    malloced_regions = new_malloced_regions;
+
+    // clear color flags
+    for (uint64_t i = 0; i < vector_size(malloced_regions); i++) {
+        uint64_t *ptr = (uint64_t *)vector_get(malloced_regions, i);
+        ptr[0] &= 0xFFFFFCFF;  // make the color WHITE
+    }
+    *(uint64_t *)(aqaml_sys_argv - 8) &= 0xFFFFFCFF;  // make the color WHITE
+}
+
 uint64_t aqaml_alloc_block(uint64_t size, uint64_t color, uint64_t tag)
 {
-    static const uint64_t HEAP_SIZE = 1024 * 1024 * 1024;  // 1512MiB
-    static uint8_t *heap_ptr = NULL, *heap_limit = NULL;
-    if (heap_ptr == NULL) {  // initialize
-        heap_ptr = (uint8_t *)malloc(HEAP_SIZE);
-        assert(heap_ptr != NULL);
-        // for (uint64_t i = 0; i < HEAP_SIZE / 8; i++)
-        //    *((uint64_t *)heap_ptr + i) = 0xDEADBEEFll;
-        heap_limit = heap_ptr + HEAP_SIZE;
+    if (malloced_regions == NULL) {  // initialize
+        malloced_regions = new_vector();
+        assert(malloced_regions != NULL);
+    }
+
+    static uint64_t gc_threshold = 100000;
+    if (vector_size(malloced_regions) > gc_threshold) {
+        // fprintf(stderr, "thr = %lu\t#regions = %d\t=> ", gc_threshold,
+        //        vector_size(malloced_regions));
+        aqaml_gc();
+        // fprintf(stderr, "%d\n", vector_size(malloced_regions));
+
+        gc_threshold *= 1.1;
     }
 
-    uint64_t needed_nbytes = (size + 1) * 8;
-    assert(heap_ptr + needed_nbytes < heap_limit);
+    uint64_t *ptr = (uint64_t *)malloc((size + 1) * 8);
+    vector_push_back(malloced_regions, ptr);
 
-    uint64_t *ptr = (uint64_t *)heap_ptr;
-    heap_ptr += needed_nbytes;
     // size in word (54 bits) | color (2 bits) | tag byte (8 bits)
     *ptr = (size << 10) | (color << 8) | tag;
+
     return (uint64_t)(ptr + 1);
 }
 
@@ -568,3 +753,11 @@ uint64_t aqaml_array_length_detail(uint64_t ary_src)
     assert(ary.kind == AQAML_ARRAY);
     return ary.array->header >> 10;
 }
+
+_Noreturn void aqaml_gracefully_exit(void)
+{
+    for (size_t i = 0; i < vector_size(malloced_regions); i++)
+        free(vector_get(malloced_regions, i));
+    delete_vector(malloced_regions);
+    exit(0);
+}