Implement more features

compiler/compile.c

@@ -94,14 +94,20 @@ void emit(struct function *fn, struct context *ctx, struct node *expr) {
                 size_t index;
 
                 assert(ctx_lookup_name(ctx, n0->n_ident, &kind, &index) == 0);
-                assert(kind == NAME_GLOBAL);
 
                 n1 = caddr(expr);
                 assert(null_q(cdr(cddr(expr))));
                 // (define ident value)
                 // Emit value for n1
                 emit(fn, ctx, n1);
-                emit_insn(fn, OP(OP_STG, index));
+                switch (kind) {
+                case NAME_LOCAL:
+                    emit_insn(fn, OP(OP_STL, index));
+                    break;
+                case NAME_GLOBAL:
+                    emit_insn(fn, OP(OP_STG, index));
+                    break;
+                }
             } else if (cons_q(n0)) {
                 struct node *name = car(n0);
                 struct node *args = cdr(n0);
@@ -147,7 +153,17 @@ void emit(struct function *fn, struct context *ctx, struct node *expr) {
         }
 
         // Check for macros/builtin operators
-        if (!strcmp(n0->n_ident, "if")) {
+        if (!strcmp(n0->n_ident, "begin")) {
+            n1 = cdr(expr);
+            assert(!null_q(n1));
+
+            for (; n1; n1 = cdr(n1)) {
+                n2 = car(n1);
+
+                emit(fn, ctx, n2);
+            }
+            return;
+        } else if (!strcmp(n0->n_ident, "if")) {
             n1 = cadr(expr);            // condition
             n2 = caddr(expr);           // yes-expr
             n3 = car(cdr(cddr(expr)));  // no-expr
@@ -238,7 +254,7 @@ void emit(struct function *fn, struct context *ctx, struct node *expr) {
         } else if (!strcmp(n0->n_ident, "<=") && c0 == 2) {
             emit_insn(fn, OP(OP_LE, 0));
         } else if (!strcmp(n0->n_ident, "null?") && c0 == 1) {
-            emit_insn(fn, OP(OP_TEST, 0));
+            emit_insn(fn, OP(OP_ISZ, 0));
         } else if (!strcmp(n0->n_ident, "not") && c0 == 1) {
             emit_insn(fn, OP(OP_NOT, 0));
         } else if (!strcmp(n0->n_ident, "car") && c0 == 1) {
@@ -247,19 +263,29 @@ void emit(struct function *fn, struct context *ctx, struct node *expr) {
             emit_insn(fn, OP(OP_CDR, 0));
         } else {
             size_t index;
+            int kind;
 
-            // TODO lookup unit-local function
-            // TODO function signature validation?
-
-            // Lookup external reference in the list, if already present
-            if (unit_ext_ref(ctx, n0->n_ident, &index) == 0) {
-                emit_insn(fn, OP(OP_XCALL, index));
-            } else {
+            if (ctx_lookup_name(ctx, n0->n_ident, &kind, &index) != 0) {
                 printf("Undefined reference to function ");
                 vm_print(n0, 0);
                 printf("\n");
                 abort();
             }
+
+            switch (kind) {
+            case NAME_EXTERNAL:
+                emit_insn(fn, OP(OP_XCALL, index));
+                break;
+            case NAME_LOCAL:
+                emit_insn(fn, OP(OP_LCALL, index));
+                break;
+            case NAME_GLOBAL:
+                emit_insn(fn, OP(OP_GCALL, index));
+                break;
+            default:
+                printf("Unknown\n");
+                abort();
+            }
         }
         return;
     case N_INTEGER:
@@ -292,6 +318,9 @@ void emit(struct function *fn, struct context *ctx, struct node *expr) {
             case NAME_ARGUMENT:
                 emit_insn(fn, OP(OP_LDARG, index));
                 break;
+            case NAME_LOCAL:
+                emit_insn(fn, OP(OP_LDL, index));
+                break;
             default:
                 abort();
             }

compiler/include/unit.h

@@ -50,7 +50,6 @@ struct unit {
 void unit_init(struct unit *u);
 void ctx_init(struct context *c, struct context *p);
 struct function *unit_lambda(struct unit *u);
-int unit_ext_ref(struct context *ctx, const char *name, size_t *index);
 int unit_ext_load(struct unit *self, const char *unit);
 int ctx_lookup_name(struct context *ctx, const char *name, int *kind, size_t *index);
 

compiler/main.c

@@ -11,10 +11,39 @@
 #include "unit.h"
 #include "node.h"
 
-static struct node *read_program(const char *text) {
-    struct vm_parser p;
+static int file_peek(struct vm_parser *p) {
+    if (p->ch == -1) {
+        int ch = fgetc(p->ctx);
+        p->ch = ch;
+    }
+    if (p->ch == -1) {
+        return 0;
+    }
+    return p->ch;
+}
+
+static int file_pop(struct vm_parser *p) {
+    int ch = file_peek(p);
+    if (ch == -1) {
+        return 0;
+    }
+    p->ch = fgetc(p->ctx);
+    return ch;
+}
+
+static struct node *read_program(const char *filename) {
+    FILE *fp;
     struct node *head, *tail, *expr;
-    vm_str_parser(&p, text);
+    struct vm_parser p;
+
+    fp = fopen(filename, "r");
+    assert(fp);
+
+    p.ch = -1;
+    p.ctx = fp;
+    p.peek = file_peek;
+    p.pop = file_pop;
+
     head = NULL;
     while (vm_parse(&p, &expr) == 0) {
         expr = cons(expr, NULL);
@@ -25,6 +54,8 @@ static struct node *read_program(const char *text) {
         }
         tail = expr;
     }
+
+    fclose(fp);
     return head;
 }
 
@@ -92,21 +123,18 @@ static void write_unit(FILE *fp, struct unit *u) {
     }
 }
 
-int main(void) {
+int main(int argc, char **argv) {
+    const char *input, *output;
+    assert(argc == 3);
+    input = argv[1];
+    output = argv[2];
+
     struct unit unit;
     struct node *program;
     FILE *fp;
-    const char *code =
-"(use core)"
-"(define in (cons 1 (cons 2 (cons 3 (cons 4 nil)))))"
-"(while (not (null? in))"
-"  (print (car in))"
-"  (setq in (cdr in))"
-")"
-;
 
     unit_init(&unit);
-    program = read_program(code);
+    program = read_program(input);
 
     struct function *main = unit_lambda(&unit);
     main->args = NULL;
@@ -114,9 +142,9 @@ int main(void) {
     unit.global.owner = main;
     emit_function(&unit.global, main);
 
-    fp = fopen("output.vmx", "wb");
+    fp = fopen(output, "wb");
     if (!fp) {
-        perror("output.vmx");
+        perror(output);
         return -1;
     }
     write_unit(fp, &unit);

compiler/parse.c

@@ -30,7 +30,7 @@ static inline int is_digit(int ch) {
 static inline int is_ident0(int ch) {
     return (ch >= 'a' && ch <= 'z') ||
            (ch >= 'A' && ch <= 'Z') ||
-           strchr("+-*&^%$@!~<>/.", ch);
+           strchr("+-*&^%$@!~<>/=.", ch);
 }
 
 static int skip_whitespace(struct vm_parser *in) {

compiler/unit.c

@@ -46,11 +46,48 @@ void emit_insn(struct function *fn, uint32_t insn) {
     *p = insn;
 }
 
-int unit_ext_ref(struct context *ctx, const char *name, size_t *index) {
-    (void) ctx;
-    (void) name;
-    (void) index;
+// TODO non-builtin units
+int unit_ext_load(struct unit *self, const char *name) {
+    if (!strcmp(name, "core")) {
+        struct ext_unit *unit = vector_append(&self->ext_units);
+        unit->entry_count = sizeof(u_core_entries) / sizeof(u_core_entries[0]);
+        unit->entries = u_core_entries;
+        strcpy(unit->name, name);
+        return 0;
+    }
+    return -ENOENT;
+}
 
+// TODO external references
+int ctx_lookup_name(struct context *ctx, const char *name, int *kind, size_t *index) {
+    // 1. Lookup local
+    struct hash_pair *p;
+    p = hash_lookup(&ctx->vars, name);
+    if (p) {
+        if (ctx->parent) {
+            // TODO only look into level-1 local contexts
+            *kind = NAME_LOCAL;
+        } else {
+            *kind = NAME_GLOBAL;
+        }
+        *index = (size_t) p->value;
+        return 0;
+    }
+
+    // 2. Lookup argument
+    assert(ctx->owner);
+    size_t arg_i = 0;
+    for (struct node *node = ctx->owner->args; node; node = cdr(node), ++arg_i) {
+        struct node *arg = car(node);
+        assert(ident_q(arg));
+        if (!strcmp(arg->n_ident, name)) {
+            *kind = NAME_ARGUMENT;
+            *index = arg_i;
+            return 0;
+        }
+    }
+
+    // 3. Lookup external
     struct unit *root = ctx->root;
 
     // Try looking up an existing reference entry
@@ -69,6 +106,7 @@ int unit_ext_ref(struct context *ctx, const char *name, size_t *index) {
             struct ext_unit_entry *ent = &unit->entries[j];
 
             if (!strcmp(ent->name, name)) {
+                *kind = NAME_EXTERNAL;
                 *index = root->ext_refs.size;
                 struct ext_ref *ref = vector_append(&root->ext_refs);
                 ref->unit_index = i;
@@ -79,48 +117,6 @@ int unit_ext_ref(struct context *ctx, const char *name, size_t *index) {
         }
     }
 
-    return -ENOENT;
-}
-
-// TODO non-builtin units
-int unit_ext_load(struct unit *self, const char *name) {
-    if (!strcmp(name, "core")) {
-        struct ext_unit *unit = vector_append(&self->ext_units);
-        unit->entry_count = sizeof(u_core_entries) / sizeof(u_core_entries[0]);
-        unit->entries = u_core_entries;
-        strcpy(unit->name, name);
-        return 0;
-    }
-    return -ENOENT;
-}
-
-// TODO external references
-int ctx_lookup_name(struct context *ctx, const char *name, int *kind, size_t *index) {
-    struct hash_pair *p;
-    p = hash_lookup(&ctx->vars, name);
-    if (p) {
-        if (ctx->parent) {
-            printf("TODO local contexts\n");
-            abort();
-        }
-        *kind = NAME_GLOBAL;
-        *index = (size_t) p->value;
-        return 0;
-    }
-
-    // Lookup argument
-    assert(ctx->owner);
-    size_t arg_i = 0;
-    for (struct node *node = ctx->owner->args; node; node = cdr(node), ++arg_i) {
-        struct node *arg = car(node);
-        assert(ident_q(arg));
-        if (!strcmp(arg->n_ident, name)) {
-            *kind = NAME_ARGUMENT;
-            *index = arg_i;
-            return 0;
-        }
-    }
-
     if (ctx->parent) {
         return ctx_lookup_name(ctx->parent, name, kind, index);
     }

core/include/op.h

@@ -26,15 +26,18 @@
 #define OP_CDR          0x41
 #define OP_CONS         0x45
 
-#define OP_TEST         0x46
+#define OP_ISZ          0x46
 #define OP_LDARG        0x4B
 #define OP_LDG          0x4E
 #define OP_STG          0x4F
 #define OP_LDF          0x50
+#define OP_LDL          0x51
+#define OP_STL          0x52
 
 #define OP_XCALL        0x60
 #define OP_LCALL        0x61
-#define OP_JMP          0x62
-#define OP_BT           0x63
-#define OP_BF           0x64
+#define OP_GCALL        0x62
+#define OP_JMP          0x63
+#define OP_BT           0x64
+#define OP_BF           0x65
 #define OP_RET          0x6F

vm/include/vmstate.h

@@ -4,6 +4,8 @@
 
 #include "vector.h"
 
+#define MAXARG 12
+
 struct vm_value;
 
 #define REF_NATIVE      (1 << 0)
@@ -23,6 +25,10 @@ struct vm_state {
     // Runtime stack
     uint64_t *stack;
     size_t sp, stack_size;
+    uint64_t *call_stack;
+    size_t csp, call_stack_size;
+
+    uint64_t arg_regs[MAXARG];
 
     struct vector ref_table;
 
@@ -39,6 +45,9 @@ void vm_state_init(struct vm_state *vm,
 struct vm_func_entry *vm_add_function(struct vm_state *vm);
 struct vm_ref_entry *vm_add_ref(struct vm_state *vm);
 
+void vm_call_index(struct vm_state *vm, size_t index);
+void vm_call_ref(struct vm_state *vm, struct vm_value *ref);
+
 // Bytecode interpretation
 int vm_eval_step(struct vm_state *vm);
 

vm/include/vmval.h

@@ -9,6 +9,7 @@
 enum vm_type {
     VT_CONS,
     VT_STRING,
+    VT_FUNC,
 };
 
 struct vm_value {
@@ -18,6 +19,9 @@ struct vm_value {
         struct {
             uintptr_t fat_ar, fat_dr;
         } v_cons;
+        struct {
+            size_t lib_index, fn_index;
+        } v_func;
         struct vm_string v_string;
     };
 };
@@ -43,11 +47,16 @@ static inline int cons_q(uint64_t w) {
     }
 }
 
+static inline int func_q(uint64_t w) {
+    return ref_q(w) && !null_q(w) && getref(w)->type == VT_FUNC;
+}
+
 static inline int pair_q(uint64_t w) {
     return ref_q(w) && (!null_q(w) && getref(w)->type == VT_CONS);
 }
 
 struct vm_value *vm_cons(uint64_t w0, uint64_t w1);
 struct vm_value *vm_makestr(const char *str);
+struct vm_value *vm_func(size_t lib_index, size_t fn_index);
 
 void vm_print(uint64_t w);

vm/vmstate.c

@@ -57,6 +57,10 @@ void vm_state_init(struct vm_state *vm, size_t stack_size, size_t global_pool_si
     vm->sp = stack_size;
     vm->stack_size = stack_size;
 
+    vm->call_stack_size = 1024;
+    vm->call_stack = calloc(sizeof(uint64_t), vm->call_stack_size);
+    vm->csp = vm->call_stack_size;
+
     vm->global_pool = calloc(sizeof(uint64_t), global_pool_size);
     vm->global_pool_size = global_pool_size;
 
@@ -90,6 +94,28 @@ struct vm_func_entry *vm_add_function(struct vm_state *vm) {
 //    }
 //}
 
+void vm_call_index(struct vm_state *vm, size_t index) {
+    struct vm_func_entry *func;
+    assert(index < vm->functions.size);
+    assert(vm->csp);
+
+    vm->call_stack[--vm->csp] = vm->ip;
+    vm->fp = index;
+    vm->ip = 0;
+
+    func = vector_ref(&vm->functions, index);
+    assert(func->argc <= MAXARG);
+    for (size_t i = 0; i < func->argc; ++i) {
+        vm->arg_regs[i] = pop(vm);
+    }
+}
+
+void vm_call_ref(struct vm_state *vm, struct vm_value *ref) {
+    assert(ref->type == VT_FUNC);
+    assert(ref->v_func.lib_index == 0);
+    vm_call_index(vm, ref->v_func.fn_index);
+}
+
 int vm_eval_opcode(struct vm_state *vm, uint32_t opcode) {
     uint64_t w0, w1;
     size_t i0;
@@ -105,6 +131,18 @@ int vm_eval_opcode(struct vm_state *vm, uint32_t opcode) {
             push_ref(vm, NULL);
         }
         return 0;
+    case OP_EQ:
+        w0 = pop(vm);
+        w1 = pop(vm);
+        if (ref_q(w0) || ref_q(w1)) {
+            assert(0 && "Ref cmp not implemented yet");
+        }
+        if (w0 == w1) {
+            push_integer(vm, 1);
+        } else {
+            push_ref(vm, NULL);
+        }
+        return 0;
 //
     case OP_LDNIL:
         push_ref(vm, NULL);
@@ -128,6 +166,11 @@ int vm_eval_opcode(struct vm_state *vm, uint32_t opcode) {
         push_ref(vm, vm_cons(w0, w1));
         return 0;
 //
+    case OP_LDARG:
+        i0 = opcode & 0xFFFFFF;
+        assert(i0 < MAXARG);
+        push(vm, vm->arg_regs[i0]);
+        return 0;
     case OP_LDG:
         i0 = opcode & 0xFFFFFF;
         assert(i0 < vm->global_pool_size);
@@ -139,8 +182,17 @@ int vm_eval_opcode(struct vm_state *vm, uint32_t opcode) {
         assert(i0 < vm->global_pool_size);
         vm->global_pool[i0] = w0;
         return 0;
+    case OP_LDF:
+        i0 = opcode & 0xFFFFFF;
+        assert(i0 < vm->functions.size);
+        push_ref(vm, vm_func(0, i0));
+        return 0;
+    case OP_STL:
+    case OP_LDL:
+        printf("TODO implement local values\n");
+        abort();
 //
-    case OP_TEST:
+    case OP_ISZ:
         w0 = pop(vm);
         if (null_q(w0)) {
             push_integer(vm, 1);
@@ -158,6 +210,13 @@ int vm_eval_opcode(struct vm_state *vm, uint32_t opcode) {
             assert(func);
             return func(vm);
         }
+    case OP_GCALL:
+        i0 = opcode & 0xFFFFFF;
+        assert(i0 < vm->global_pool_size);
+        w0 = vm->global_pool[i0];
+        assert(func_q(w0));
+        vm_call_ref(vm, getref(w0));
+        return 0;
     case OP_BF:
         w0 = pop(vm);
         ii0 = sximm(opcode & 0xFFFFFF);

vm/vmval.c

@@ -34,6 +34,9 @@ static void vm_print_ref(struct vm_value *value, int cdepth) {
             printf(")");
         }
         break;
+    case VT_FUNC:
+        printf("<function %zu:%zu>", value->v_func.lib_index, value->v_func.fn_index);
+        break;
     }
 }
 
@@ -65,6 +68,15 @@ struct vm_value *vm_makestr(const char *str) {
     return v;
 }
 
+struct vm_value *vm_func(size_t lib_index, size_t fn_index) {
+    struct vm_value *v = malloc(sizeof(struct vm_value));
+    v->type = VT_FUNC;
+    v->refcount = 0;
+    v->v_func.lib_index = lib_index;
+    v->v_func.fn_index = fn_index;
+    return v;
+}
+
 void vm_print(uint64_t w) {
     vm_print2(w, 0);
 }