vm: got the VM to finally actually work

bin/comp.ml

@@ -1,16 +1,18 @@
 let ( let* ) = Result.bind;;
 
+
+
 (* Try to interpret some test source code. *)
 let some_source = "(define (+ a b) b)
-                   (+ 1 2)";;
+                   (print 1)";;
 (* I don't have any built-in functions at all rn, so we just use a dummy function *)
 
 let bruh =
-  let* res = Interpreter.Main.interpret_src some_source in
-  match res with
-  | Int x -> Printf.printf "got %d as result\n" x; Ok ()
-  | _ -> Printf.printf "got something else\n" ; Ok ()
-let _ =
-  match bruh with
-  | Error s -> Printf.printf "%s" s
-  | _ -> ()
+  let* vm = Compiler.Emit.compile_src some_source in
+  Vm.Types.print_instrs vm.instrs;
+  Vm.interpret vm;
+  Ok (print_endline "hello")
+
+let _ = match bruh with
+  | Ok _ -> ()
+  | Error s -> print_endline s

bin/dune

@@ -1,4 +1,4 @@
 (executable
  (name comp)
  (public_name ollisp)
- (libraries str unix compiler interpreter))
+ (libraries str unix compiler vm interpreter))

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 : 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
@@ -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 =
-  {
-    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 = [];
+  }