diff --git a/lib/compiler/emit.ml b/lib/compiler/emit.ml index 07102f7..259d89b 100644 --- a/lib/compiler/emit.ml +++ b/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 diff --git a/lib/compiler/scope_analysis.ml b/lib/compiler/scope_analysis.ml index 220e8fb..b30ea5c 100644 --- a/lib/compiler/scope_analysis.ml +++ b/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 = diff --git a/lib/vm/native.ml b/lib/vm/native.ml index 4b30927..047f553 100644 --- a/lib/vm/native.ml +++ b/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 "" i + | Native i -> p "" i in + print_endline (aux_print v); + Types.Nil let table = [| builtin_print |] - diff --git a/lib/vm/types.ml b/lib/vm/types.ml index 3c30e87..ce9de93 100644 --- a/lib/vm/types.ml +++ b/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 diff --git a/lib/vm/vm.ml b/lib/vm/vm.ml index 12883c3..f193b53 100644 --- a/lib/vm/vm.ml +++ b/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 = []; + }