WIP

gc.c

@@ -9,6 +9,203 @@
 #include "utils.h"
 #include "schaf.h"
 
+//
+// Runtime-locals (aka global variables)
+//
+
+static Value symbol_names; // ("name0" "name1" ...)
+
+// Value (uintptr_t):
+//   0b.....000 Pointer (Unchangeable pattern!)
+//   0b.......1 Integer
+//   0b......10 Symbol
+//   0b0--00100 #f
+//   0b0--01100 #t
+//   0b0-010100 <undef>
+typedef const uintptr_t Flag;
+static Flag FLAG_NBIT_SYM = 2;
+static Flag FLAG_NBIT_INT = 1;
+static Flag FLAG_MASK     = 0b111; // for 64 bit machine
+static Flag FLAG_MASK_SYM =  0b11;
+static Flag FLAG_MASK_INT =   0b1;
+static Flag FLAG_SYM      =  0b10;
+static Flag FLAG_INT      =   0b1;
+const Value Qfalse = 0b00100U;
+const Value Qtrue  = 0b01100U;
+const Value Qundef = 0b10100U; // may be an error or something
+
+static bool is_immediate(Value v)
+{
+    return v & FLAG_MASK;
+}
+
+inline bool value_is_int(Value v)
+{
+    return v & FLAG_MASK_INT;
+}
+
+inline bool value_is_symbol(Value v)
+{
+    return (v & FLAG_MASK_SYM) == FLAG_SYM;
+}
+
+//
+// value_is_*: Type Checks
+//
+
+static inline bool value_tag_is(Value v, ValueTag expected)
+{
+    return !is_immediate(v) && VALUE_TAG(v) == expected;
+}
+
+inline bool value_is_string(Value v)
+{
+    return value_tag_is(v, TAG_STR);
+}
+
+inline bool value_is_procedure(Value v)
+{
+    if (is_immediate(v))
+        return false;
+    switch (VALUE_TAG(v)) {
+    case TAG_SYNTAX:
+    case TAG_CFUNC:
+    case TAG_CLOSURE:
+    case TAG_CONTINUATION:
+        return true;
+    default:
+        return false;
+    }
+}
+
+inline bool value_is_pair(Value v)
+{
+    return value_tag_is(v, TAG_PAIR);
+}
+
+inline bool value_is_nil(Value v)
+{
+    return v == Qnil;
+}
+
+static Type immediate_type_of(Value v)
+{
+    if (value_is_int(v))
+        return TYPE_INT;
+    if (value_is_symbol(v))
+        return TYPE_SYMBOL;
+    if (v == Qtrue || v == Qfalse)
+        return TYPE_BOOL;
+    if (v == Qundef)
+        return TYPE_UNDEF;
+    UNREACHABLE();
+}
+
+Type value_type_of(Value v)
+{
+    if (is_immediate(v))
+        return immediate_type_of(v);
+    ValueTag t = VALUE_TAG(v);
+    switch (t) {
+    case TAG_STR:
+    case TAG_PAIR:
+        return (Type) t;
+    case TAG_CFUNC:
+    case TAG_SYNTAX:
+    case TAG_CLOSURE:
+    case TAG_CONTINUATION:
+        return TYPE_PROC;
+    }
+    UNREACHABLE();
+}
+
+// value_to_*: Convert internal data to external plain C
+
+inline int64_t value_to_int(Value x)
+{
+#if __x86_64__
+    return (int64_t) x >> FLAG_NBIT_INT;
+#else
+    int64_t i = x;
+    return (i - 1) / (1 << FLAG_NBIT_INT);
+#endif
+}
+
+inline Symbol value_to_symbol(Value v)
+{
+    return (Symbol) v >> FLAG_NBIT_SYM;
+}
+
+static const char *name_nth(Value list, int64_t n)
+{
+    for (int64_t i = 0; i < n; i++) {
+        list = cdr(list);
+        if (list == Qnil)
+            return NULL;
+    }
+    Value name = car(list);
+    return STRING(name)->body;
+}
+
+static const char *unintern(Symbol sym)
+{
+    const char *name = name_nth(symbol_names, (int64_t) sym);
+    if (name == NULL) // fatal; every known symbols should have a name
+        error("symbol %lu not found", sym);
+    return name;
+}
+
+inline const char *value_to_string(Value v)
+{
+    if (value_is_symbol(v))
+        return unintern(value_to_symbol(v));
+    return STRING(v)->body;
+}
+
+// value_of_*: Convert external plain C data to internal
+
+inline Value value_of_int(int64_t i)
+{
+    Value v = i;
+    return v << FLAG_NBIT_INT | FLAG_INT;
+}
+
+static inline Value list1(Value x)
+{
+    return cons(x, Qnil);
+}
+
+static Symbol intern(const char *name)
+{
+    Value last = Qnil;
+    int64_t i = 0;
+    // find
+    for (Value p = symbol_names; p != Qnil; last = p, p = cdr(p)) {
+        Value v = car(p);
+        if (strcmp(STRING(v)->body, name) == 0)
+            return i;
+        i++;
+    }
+    // or put at `i`
+    Value s = value_of_string(name);
+    Value next = list1(s);
+    if (last == Qnil)
+        symbol_names = next;
+    else
+        PAIR(last)->cdr = next;
+    return i;
+}
+
+inline Value value_of_symbol(const char *s)
+{
+    Symbol sym = intern(s);
+    return (Value) (sym << FLAG_NBIT_SYM | FLAG_SYM);
+}
+
+//
+// GC things
+//
+
 #define HEADER(v) ((Header *) v)
 
 typedef struct {
@@ -50,6 +247,9 @@ void gc_init(void)
     ch->h.living = false;
     ch->next = NULL;
     free_list = ch;
+
+    symbol_names = Qnil;
+    gc_add_root(&symbol_names);
 }
 
 static void *allocate_from_list(Chunk *prev, Chunk *curr, size_t size)
@@ -115,7 +315,7 @@ static inline Header *get_header(Value v)
 
 static void mark(Value v)
 {
-    if (value_is_immediate(v) || v == Qnil)
+    if (is_immediate(v) || v == Qnil)
         return;
     Header *h = get_header(v);
     if (h->living)
@@ -164,7 +364,7 @@ static bool in_heap_range(uintptr_t v)
 
 static bool in_heap(uintptr_t v)
 {
-    if (value_is_immediate(v) || v == Qnil ||
+    if (is_immediate(v) || v == Qnil ||
         v % 8U != 0 || !in_heap_range(v))
         return false;
     ValueTag t = VALUE_TAG((Value) v);

gc.h

@@ -65,6 +65,7 @@ typedef struct {
 
 #define SCH_STACK_INIT(p) void *p; gc_stack_init(&p)
 
+bool value_is_procedure(Value v);
 void gc_init(void);
 void gc_add_root(const Value *r);
 void gc_stack_init(const volatile void *b);