vm: got the VM to finally actually work

lib/compiler/emit.ml

@@ -104,11 +104,21 @@ let backpatch_one p (i, b) =
   Dynarray.set p.instrs i (Instr (MakeClosure (current_index p)));
   let* _ = compile_one p b in
   emit_instr p End
-let backpatch p =
+let rec backpatch p =
   if Queue.is_empty p.backpatch then
     Ok ()
-  else backpatch_one p (Queue.pop p.backpatch)
+  else
+    (let* _ = backpatch_one p (Queue.pop p.backpatch) in
+     backpatch p)
 
+
+let print_instr = function
+  | Instr i -> Vm.Types.print_one i
+  | BackPatchJumpF ->  "BACKPATCH JUMPF\n"
+  | BackPatchMkClosure -> "BACKPATCH CLOSURE\n"
+let print_instrs =
+  Array.mapi_inplace (fun i ins ->
+    print_endline (Printf.sprintf "%d: %s" i (print_instr ins)); ins)
 let smooth_one = function
   | Instr i -> i
   | _ -> failwith "backpatching process was not complete!"
@@ -123,6 +133,12 @@ let compile (exprs : expression list) (tbl : int SymbolTable.t) =
       backpatch=Queue.create ();
     } in
   let* _ = compile_all program exprs in
+  let* _ = emit_instr program End in
   let* _ = backpatch program in
   let final_instrs = smooth_instrs program in
-  Ok (Vm.Types.make_vm final_instrs (Dynarray.to_array program.constants) (SymbolTable.cardinal tbl))
+  print_endline (string_of_int (SymbolTable.cardinal tbl));
+  Ok (Vm.make_vm final_instrs (Dynarray.to_array program.constants) ((SymbolTable.cardinal tbl) + 1))
+
+let compile_src src =
+  let* (exprs, tbl) = Scope_analysis.of_src src in
+  compile exprs tbl

lib/compiler/scope_analysis.ml

@@ -66,7 +66,7 @@ let default_global_table =
    be kept at runtime.
  *)
 let extract_globals (top : Core_ast.top_level list) =
-  let id_counter = (ref (-1)) in
+  let id_counter = (ref (SymbolTable.cardinal default_global_table)) in
   let id () =
     id_counter := !id_counter + 1; !id_counter in
   let rec aux tbl = function
@@ -156,7 +156,7 @@ let convert program =
        let tbl = SymbolTable.add s (SymbolTable.find s global_tbl) tbl in
        (analyze tbl [] (Set (s, e))) :: (aux tbl rest)
   in
-  let* program = traverse (fun x -> x) (aux SymbolTable.empty program) in
+  let* program = traverse (fun x -> x) (aux default_global_table program) in
   Ok (program, global_tbl)
 
 let of_src src =

lib/vm/native.ml

@@ -3,12 +3,20 @@
    Stuff like printing to the screen, file I/O etc will be implemented
    here.
  *)
-
 open Types
-
+let builtin_print (v : Types.value) =
-let builtin_print (v : value) =
+  let p = Printf.sprintf in
-  ignore v;
+  let rec aux_print = function
-  Nil
+    | 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
@@ -16,4 +24,3 @@ let table = [|
 
 
   
-  

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 =
+let p = Printf.sprintf 
-  {
+let print_one = function
-    i = 0;
+    | Constant i -> p "CONSTANT %d\n" i
-    instrs = instrs;
+    | LoadLocal i -> p "LOCAL %d\n" i
-    globals = Array.make global_count Nil;
+    | LoadGlobal i -> p "GLOBAL %d\n" i
-    constants = constants;
+    | StoreLocal i -> p "STORE_LOCAL %d\n" i
-    env = [];
+    | StoreGlobal i -> p "STORE_GLOBAL %d\n" i
-    stack = [];
+    | 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 <- (ref arg) :: e;
-     state.env <- cur_env;
+     interpret state
-     state.i <- cur_i
   | 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 = [];
+  }