vm: got the VM to finally actually work

lib/vm/native.ml

@@ -3,17 +3,24 @@
    Stuff like printing to the screen, file I/O etc will be implemented
    here.
  *)
-
 open Types
-
-let builtin_print (v : value) =
-  ignore v;
-  Nil
+let builtin_print (v : Types.value) =
+  let p = Printf.sprintf in
+  let rec aux_print = function
+    | Int x -> p "%d" x
+    | Double x -> p "%f" x
+    | String x -> p "\"%s\"" x
+    | Nil -> p "'()"
+    | Cons (a, b) -> p "(%s . %s)" (aux_print a) (aux_print b)
+    | Symbol x -> p "'%s" x
+    | Closure (i, _) -> p "<closure %d>" i
+    | Native i -> p "<native %d>" i in
+  print_endline (aux_print v);
+  Types.Nil
 
 let table = [|
     builtin_print
   |]
 
 
-
   

lib/vm/types.ml

@@ -33,18 +33,30 @@ type vm_state = {
     globals : value array;
     constants : value array;
     mutable env : value ref list;
-    mutable stack : value list
+    mutable stack : value list;
+    mutable call_stack : (int * (value ref list)) list;
   }
 
 
-let make_vm instrs constants global_count =
-  {
-    i = 0;
-    instrs = instrs;
-    globals = Array.make global_count Nil;
-    constants = constants;
-    env = [];
-    stack = [];
-  }
+let p = Printf.sprintf 
+let print_one = function
+    | Constant i -> p "CONSTANT %d\n" i
+    | LoadLocal i -> p "LOCAL %d\n" i
+    | LoadGlobal i -> p "GLOBAL %d\n" i
+    | StoreLocal i -> p "STORE_LOCAL %d\n" i
+    | StoreGlobal i -> p "STORE_GLOBAL %d\n" i
+    | MakeCons -> p "CONS\n"
+    | Pop -> p "POP\n"
+    | Apply -> p "APPLY\n"
+    | MakeClosure i -> p "MKCLOSURE %d\n" i
+    | Jump i -> p "JMP %d\n" i
+    | JumpF i -> p "JMPF %d\n" i
+    | End -> p "END\n"
+    | NOOP -> p "NOOP\n"
 
-(* TODO: add facilities to print the VM state in case of errors. *)
+let print_instrs instrs =  
+  Array.mapi_inplace
+    (fun i ins ->
+      print_string (p "%d: %s" i (print_one ins));
+      ins)
+    instrs

lib/vm/vm.ml

@@ -15,10 +15,10 @@ let set_local state i v =
 let pop_one state =
   match state.stack with
   | v :: rest -> state.stack <- rest; v
-  | [] -> failwith "VM error: cannot pop from empty stack!"
+  | [] -> failwith ("VM error: cannot pop from empty stack! " ^ (string_of_int state.i))
 
 let push state v =
-  state.stack <- v :: state.stack
+  state.stack <- (v :: state.stack)
 
 let rec do_apply state =
   let cur_env = state.env in
@@ -27,19 +27,21 @@ let rec do_apply state =
   let f = pop_one state in
   match f with
   | Closure (x, e) ->
-     state.env <- ref arg :: e;
+     state.call_stack <- (cur_i, cur_env) :: state.call_stack;
      state.i <- x;
-     interpret state;
-     state.env <- cur_env;
-     state.i <- cur_i
+     state.env <- (ref arg) :: e;
+     interpret state
   | Native x ->
      push state (Native.table.(x) arg)
   | _ -> failwith "Cannot apply non-closure object"
 
 and interpret state =
+  (match state.stack with
+  | [] -> print_endline "empty"
+  | _ -> print_endline "nonempty");
   let i = state.i in
   state.i <- i + 1;
-  (match state.instrs.(state.i) with
+  (match state.instrs.(i) with
   | Constant x -> push state state.constants.(x) ; interpret state
   | LoadLocal x -> push state (load_local state x) ; interpret state
   | LoadGlobal x -> push state state.globals.(x) ; interpret state
@@ -50,13 +52,32 @@ and interpret state =
      let car = pop_one state in
      push state (Cons (car, cdr))
   | Pop -> ignore (pop_one state) ; interpret state
-  | Apply -> do_apply state ; interpret state
+  | Apply -> do_apply state
   | MakeClosure x -> push state (Closure (x, state.env)); interpret state
   | Jump target -> state.i <- target ; interpret state
   | JumpF target ->
      (match (pop_one state) with
      | Nil -> state.i <- target
      | _ -> ()); interpret state 
-  | End -> ()
+  | End ->
+     (match state.call_stack with
+     | [] ->
+        print_endline "\nPROGRAM HAS SUCCESSFULLY TERMINATED\n"
+     | (old_i, old_env) :: rest ->
+        state.call_stack <- rest;
+        state.env <- old_env;
+        state.i <- old_i;
+        interpret state)
   | NOOP -> interpret state)
 
+let make_vm instrs constants global_count =
+  let globals = Array.init global_count (fun x -> if x < (Array.length Native.table) then Native x else Nil) in
+  {
+    i = 0;
+    instrs = instrs;
+    globals = globals;
+    constants = constants;
+    env = [];
+    stack = [];
+    call_stack = [];
+  }