From 1382f81bc7d283325bb8b7b612c271cfb2d4eae0 Mon Sep 17 00:00:00 2001 From: kimmy441 Date: Fri, 19 Dec 2025 20:47:49 +0000 Subject: [PATCH] Initial --- README.md | 30 ++++ bin/main.ml | 204 ++++++++++++++++++++++++++ dune | 12 ++ dune-project | 9 ++ lib/cont.ml | 54 +++++++ lib/instr.ml | 113 +++++++++++++++ lib/state.ml | 79 ++++++++++ lib/step.ml | 361 ++++++++++++++++++++++++++++++++++++++++++++++ lib/trampoline.ml | 63 ++++++++ lib/vm.ml | 62 ++++++++ 10 files changed, 987 insertions(+) create mode 100644 README.md create mode 100644 bin/main.ml create mode 100644 dune create mode 100644 dune-project create mode 100644 lib/cont.ml create mode 100644 lib/instr.ml create mode 100644 lib/state.ml create mode 100644 lib/step.ml create mode 100644 lib/trampoline.ml create mode 100644 lib/vm.ml diff --git a/README.md b/README.md new file mode 100644 index 0000000..593d8a4 --- /dev/null +++ b/README.md @@ -0,0 +1,30 @@ +# sequence + +A stackless bytecode interpreter implemented in OCaml using CPS. + + All control flow is expressed through explicit continuations rather than the OCaml call to ensure stack safety through a trampoline + +## Continuation Representation + +Continuations are represented as a recursive type: + +```ocaml +type continuation = + | Halt + | Return_to of continuation + | Apply_to of { func : value; cont : continuation } + | Eval_to of { expr : instruction; cont : continuation } + | Pop_to of { n : int; cont : continuation } + | Exception_to of { handler : continuation; cont : continuation } +``` + +Each continuation represents "what to do next" after the current computation completes + +Exception continuations enable structured error handling + +## Building/Running + +```bash +dune build +dune exec sequence +``` \ No newline at end of file diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 0000000..b1d0f1e --- /dev/null +++ b/bin/main.ml @@ -0,0 +1,204 @@ +open Sequence + +let example_program = + [| + Instr.PUSH (Instr.Int 5); + Instr.PUSH (Instr.Int 3); + Instr.ADD; + Instr.DUP; + Instr.PUSH (Instr.Int 2); + Instr.MUL; + Instr.ADD; + Instr.HALT; + |] + +let arithmetic_program = + [| + Instr.PUSH (Instr.Int 10); + Instr.PUSH (Instr.Int 7); + Instr.SUB; + Instr.PUSH (Instr.Int 2); + Instr.MUL; + Instr.HALT; + |] + +let conditional_program = + [| + Instr.PUSH (Instr.Int 5); + Instr.PUSH (Instr.Int 3); + Instr.LT; + Instr.JMP_IF 2; + Instr.PUSH (Instr.Int 100); + Instr.JMP 1; + Instr.PUSH (Instr.Int 200); + Instr.HALT; + |] + +let comparison_program = + [| + Instr.PUSH (Instr.Int 10); + Instr.PUSH (Instr.Int 5); + Instr.GT; + Instr.PUSH (Instr.Int 5); + Instr.PUSH (Instr.Int 10); + Instr.LE; + Instr.AND; + Instr.HALT; + |] + +let division_program = + [| + Instr.PUSH (Instr.Int 20); + Instr.PUSH (Instr.Int 4); + Instr.DIV; + Instr.PUSH (Instr.Int 3); + Instr.MOD; + Instr.HALT; + |] + +let stack_ops_program = + [| + Instr.PUSH (Instr.Int 1); + Instr.PUSH (Instr.Int 2); + Instr.PUSH (Instr.Int 3); + Instr.ROT; + Instr.SWAP; + Instr.OVER; + Instr.ADD; + Instr.HALT; + |] + +let logical_program = + [| + Instr.PUSH (Instr.Bool true); + Instr.PUSH (Instr.Bool false); + Instr.OR; + Instr.PUSH (Instr.Bool true); + Instr.AND; + Instr.NOT; + Instr.HALT; + |] + +let negation_program = + [| + Instr.PUSH (Instr.Int 42); + Instr.NEG; + Instr.PUSH (Instr.Int 10); + Instr.ADD; + Instr.HALT; + |] + +let closure_program = + [| + Instr.PUSH (Instr.Int 100); + Instr.MK_CLOSURE 10; + Instr.CALL; + Instr.HALT; + Instr.PUSH (Instr.Int 200); + Instr.RET; + |] + +let exception_program = + [| + Instr.TRY 3; + Instr.PUSH (Instr.Int 42); + Instr.PUSH (Instr.Int 0); + Instr.DIV; + Instr.HALT; + Instr.POP; + Instr.PUSH (Instr.Int 999); + Instr.HALT; + |] + +let complex_program = + [| + Instr.PUSH (Instr.Int 15); + Instr.PUSH (Instr.Int 3); + Instr.DIV; + Instr.DUP; + Instr.PUSH (Instr.Int 2); + Instr.MUL; + Instr.SWAP; + Instr.ADD; + Instr.PUSH (Instr.Int 10); + Instr.GT; + Instr.JMP_IF 2; + Instr.PUSH (Instr.Int 0); + Instr.JMP 1; + Instr.PUSH (Instr.Int 1); + Instr.HALT; + |] + +let run_test name program expected = + Printf.printf "Test: %s\n" name; + match Vm.execute_program program with + | Vm.Success (Some (Instr.Int result)) -> + if result = expected then + Printf.printf " ✓ Pass: %d (expected %d)\n\n" result expected + else + Printf.printf " ✗ Fail: got %d, expected %d\n\n" result expected + | Vm.Success (Some (Instr.Bool result)) -> + Printf.printf " Result: %b\n\n" result + | Vm.Success None -> + Printf.printf " ✗ Fail: No result\n\n" + | Vm.Failure e -> + Printf.printf " ✗ Error: %s\n\n" (State.show_error e) + +let run_trace_test name program = + Printf.printf "Trace test: %s\n" name; + let result, trace = Vm.execute_with_trace program in + (match result with + | Vm.Success (Some (Instr.Int n)) -> + Printf.printf " Result: %d\n" n + | Vm.Success (Some (Instr.Bool b)) -> + Printf.printf " Result: %b\n" b + | Vm.Success None -> + Printf.printf " Result: None\n" + | Vm.Failure e -> + Printf.printf " Error: %s\n" (State.show_error e)); + Printf.printf " Trace entries: %d\n" (List.length trace); + if List.length trace > 0 then + (let last = List.hd (List.rev trace) in + Printf.printf " Final: pc=%d, stack_len=%d, cont_depth=%d\n" + last.Trampoline.pc last.Trampoline.stack_len last.Trampoline.cont_depth); + Printf.printf "\n" + +let () = + run_test "Basic arithmetic" example_program 24; + run_test "Subtraction and multiplication" arithmetic_program 6; + run_test "Conditional branching" conditional_program 200; + run_test "Comparison operations" comparison_program 1; + run_test "Division and modulo" division_program 2; + run_test "Stack operations" stack_ops_program 5; + run_test "Logical operations" logical_program 0; + run_test "Negation" negation_program (-32); + run_test "Complex expression" complex_program 1; + + let invalid_jump = [| + Instr.PUSH (Instr.Int 1); + Instr.JMP 1000; + Instr.HALT; + |] in + let errors = Vm.validate invalid_jump in + Printf.printf "Invalid jump validation: %d errors found\n" (List.length errors); + List.iter (fun (pc, err) -> + Printf.printf " PC %d: %s\n" pc (State.show_error err)) + errors; + Printf.printf "\n"; + + let disasm = Vm.disassemble example_program in + List.iter (fun (pc, instr) -> + Printf.printf " %d: %s\n" pc instr) + disasm; + Printf.printf "\n"; + + run_trace_test "Traced execution" arithmetic_program; + + match Vm.execute_program exception_program with + | Vm.Success (Some (Instr.Int n)) -> + Printf.printf "Exception caught, result: %d\n" n + | Vm.Success None -> + Printf.printf "Exception caught, no result\n" + | Vm.Failure e -> + Printf.printf "Exception not caught: %s\n" (State.show_error e); + Printf.printf "\n" diff --git a/dune b/dune new file mode 100644 index 0000000..46f6326 --- /dev/null +++ b/dune @@ -0,0 +1,12 @@ +(executable + (public_name sequence) + (name main) + (libraries sequence) + (package sequence)) + +(library + (name sequence) + (public_name sequence) + (modules instr state cont step trampoline vm)) + + diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..612a9a5 --- /dev/null +++ b/dune-project @@ -0,0 +1,9 @@ +(lang dune 3.0) + +(name sequence) + +(package + (name sequence) + (depends ocaml)) + + diff --git a/lib/cont.ml b/lib/cont.ml new file mode 100644 index 0000000..c0a10c9 --- /dev/null +++ b/lib/cont.ml @@ -0,0 +1,54 @@ +open Instr + +type t = continuation + +let halt = Halt + +let return_to cont = Return_to cont + +let apply_to func cont = Apply_to { func; cont } + +let eval_to expr cont = Eval_to { expr; cont } + +let pop_to n cont = Pop_to { n; cont } + +let exception_to handler cont = Exception_to { handler; cont } + +let rec build_cont instructions cont = + match instructions with + | [] -> cont + | instr :: rest -> + eval_to instr (build_cont rest cont) + +let apply_cont k v : (t * value option) option = + match k with + | Halt -> None + | Return_to k' -> Some (k', Some v) + | Apply_to { func; cont } -> + (match func with + | Closure { code; env } -> + Some (Eval_to { expr = Instr.LOAD code; cont }, Some v) + | _ -> None) + | Eval_to { expr; cont } -> + Some (cont, Some v) + | Pop_to { n; cont } -> + Some (cont, Some v) + | Exception_to { handler; cont } -> + Some (handler, Some v) + +let rec depth = function + | Halt -> 0 + | Return_to k -> 1 + depth k + | Apply_to { cont; _ } -> 1 + depth cont + | Eval_to { cont; _ } -> 1 + depth cont + | Pop_to { cont; _ } -> 1 + depth cont + | Exception_to { cont; _ } -> 1 + depth cont + +let rec show_cont k = + match k with + | Halt -> "Halt" + | Return_to k' -> Printf.sprintf "Return_to(%s)" (show_cont k') + | Apply_to { func; cont } -> Printf.sprintf "Apply_to(%s, %s)" (show_value func) (show_cont cont) + | Eval_to { expr; cont } -> Printf.sprintf "Eval_to(%s, %s)" (show expr) (show_cont cont) + | Pop_to { n; cont } -> Printf.sprintf "Pop_to(%d, %s)" n (show_cont cont) + | Exception_to { handler; cont } -> Printf.sprintf "Exception_to(%s, %s)" (show_cont handler) (show_cont cont) diff --git a/lib/instr.ml b/lib/instr.ml new file mode 100644 index 0000000..83d283f --- /dev/null +++ b/lib/instr.ml @@ -0,0 +1,113 @@ +type value = + | Int of int + | Closure of { code : int; env : value list } + | Continuation of continuation + | Bool of bool + +and continuation = + | Halt + | Return_to of continuation + | Apply_to of { func : value; cont : continuation } + | Eval_to of { expr : t; cont : continuation } + | Pop_to of { n : int; cont : continuation } + | Exception_to of { handler : continuation; cont : continuation } + +and t = + | PUSH of value + | POP + | DUP + | SWAP + | OVER + | ROT + | ADD + | SUB + | MUL + | DIV + | MOD + | EQ + | NE + | LT + | LE + | GT + | GE + | AND + | OR + | NOT + | NEG + | JMP of int + | JMP_IF of int + | JMP_IF_NOT of int + | CALL + | RET + | MK_CLOSURE of int + | LOAD of int + | STORE of int + | PUSH_ENV + | POP_ENV + | HALT + | TRY of int + | RAISE + | RERAISE + +let show_value = function + | Int n -> Printf.sprintf "Int(%d)" n + | Bool b -> Printf.sprintf "Bool(%b)" b + | Closure { code; env } -> Printf.sprintf "Closure(code=%d, env_len=%d)" code (List.length env) + | Continuation _ -> "Continuation" + +let show_continuation = function + | Halt -> "Halt" + | Return_to _ -> "Return_to" + | Apply_to _ -> "Apply_to" + | Eval_to _ -> "Eval_to" + | Pop_to _ -> "Pop_to" + | Exception_to _ -> "Exception_to" + +let show = function + | PUSH v -> Printf.sprintf "PUSH %s" (show_value v) + | POP -> "POP" + | DUP -> "DUP" + | SWAP -> "SWAP" + | OVER -> "OVER" + | ROT -> "ROT" + | ADD -> "ADD" + | SUB -> "SUB" + | MUL -> "MUL" + | DIV -> "DIV" + | MOD -> "MOD" + | EQ -> "EQ" + | NE -> "NE" + | LT -> "LT" + | LE -> "LE" + | GT -> "GT" + | GE -> "GE" + | AND -> "AND" + | OR -> "OR" + | NOT -> "NOT" + | NEG -> "NEG" + | JMP offset -> Printf.sprintf "JMP %d" offset + | JMP_IF offset -> Printf.sprintf "JMP_IF %d" offset + | JMP_IF_NOT offset -> Printf.sprintf "JMP_IF_NOT %d" offset + | CALL -> "CALL" + | RET -> "RET" + | MK_CLOSURE code -> Printf.sprintf "MK_CLOSURE %d" code + | LOAD idx -> Printf.sprintf "LOAD %d" idx + | STORE idx -> Printf.sprintf "STORE %d" idx + | PUSH_ENV -> "PUSH_ENV" + | POP_ENV -> "POP_ENV" + | HALT -> "HALT" + | TRY offset -> Printf.sprintf "TRY %d" offset + | RAISE -> "RAISE" + | RERAISE -> "RERAISE" + +let int_of_value = function + | Int n -> Some n + | Bool true -> Some 1 + | Bool false -> Some 0 + | _ -> None + +let bool_of_value = function + | Bool b -> Some b + | Int 0 -> Some false + | Int n -> Some (n <> 0) + | _ -> None diff --git a/lib/state.ml b/lib/state.ml new file mode 100644 index 0000000..28891f6 --- /dev/null +++ b/lib/state.ml @@ -0,0 +1,79 @@ +type error = + | StackUnderflow + | InvalidIndex of int + | TypeMismatch of string + | DivisionByZero + | InvalidJump of int + | InvalidClosure + | NoExceptionHandler + +type 'a result = Ok of 'a | Error of error + +type t = { + pc : int; + stack : Instr.value list; + code : Instr.t array; + env : Instr.value list; + env_stack : Instr.value list list; + exception_value : Instr.value option; +} + +let create code = { + pc = 0; + stack = []; + code; + env = []; + env_stack = []; + exception_value = None; +} + +let with_pc state pc = { state with pc } +let with_stack state stack = { state with stack } +let with_env state env = { state with env } +let with_exception state exn = { state with exception_value = Some exn } +let clear_exception state = { state with exception_value = None } + +let push state v = { state with stack = v :: state.stack } + +let pop state = match state.stack with + | [] -> Error StackUnderflow + | v :: rest -> Ok (v, { state with stack = rest }) + +let pop_n state n = + if n < 0 then Error (InvalidIndex n) + else if n = 0 then Ok ([], state) + else + let rec aux acc n = function + | [] when n > 0 -> Error StackUnderflow + | rest when n = 0 -> Ok (List.rev acc, { state with stack = rest }) + | v :: rest -> aux (v :: acc) (n - 1) rest + in + aux [] n state.stack + +let peek state = match state.stack with + | [] -> Error StackUnderflow + | v :: _ -> Ok v + +let push_env state = + { state with env_stack = state.env :: state.env_stack } + +let pop_env state = match state.env_stack with + | [] -> Error StackUnderflow + | env :: rest -> Ok ({ state with env = env; env_stack = rest }) + +let get_env state = state.env + +let set_env state env = { state with env } + +let show state = + Printf.sprintf "State(pc=%d, stack_len=%d, env_len=%d, env_stack_len=%d)" + state.pc (List.length state.stack) (List.length state.env) (List.length state.env_stack) + +let show_error = function + | StackUnderflow -> "StackUnderflow" + | InvalidIndex i -> Printf.sprintf "InvalidIndex(%d)" i + | TypeMismatch s -> Printf.sprintf "TypeMismatch(%s)" s + | DivisionByZero -> "DivisionByZero" + | InvalidJump i -> Printf.sprintf "InvalidJump(%d)" i + | InvalidClosure -> "InvalidClosure" + | NoExceptionHandler -> "NoExceptionHandler" diff --git a/lib/step.ml b/lib/step.ml new file mode 100644 index 0000000..5730b5b --- /dev/null +++ b/lib/step.ml @@ -0,0 +1,361 @@ +open Instr + +type result = + | Continue of { state : State.t; cont : Cont.t } + | Halted of value option + | Error of State.error + +let step state cont : result = + if state.pc >= Array.length state.code then + Halted None + else + let instr = state.code.(state.pc) in + let next_pc = state.pc + 1 in + let next_state = State.with_pc state next_pc in + + match instr with + | PUSH v -> + let new_state = State.push next_state v in + Continue { state = new_state; cont } + + | POP -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (_, new_state) -> + Continue { state = new_state; cont }) + + | DUP -> + (match State.peek next_state with + | State.Error e -> Error e + | State.Ok v -> + let new_state = State.push next_state v in + Continue { state = new_state; cont }) + + | SWAP -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([a; b], new_state) -> + let new_state = State.push (State.push new_state a) b in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "SWAP")) + + | OVER -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([a; b], new_state) -> + let new_state = State.push (State.push new_state b) a in + let new_state = State.push new_state b in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "OVER")) + + | ROT -> + (match State.pop_n next_state 3 with + | State.Error e -> Error e + | State.Ok ([a; b; c], new_state) -> + let new_state = State.push (State.push (State.push new_state a) c) b in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "ROT")) + + | ADD -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (a + b)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "ADD")) + + | SUB -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (a - b)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "SUB")) + + | MUL -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (a * b)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "MUL")) + + | DIV -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int 0], _) -> Error State.DivisionByZero + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (a / b)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "DIV")) + + | MOD -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int 0], _) -> Error State.DivisionByZero + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (a mod b)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "MOD")) + + | EQ -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (if a = b then 1 else 0)) in + Continue { state = new_state; cont } + | State.Ok ([Bool a; Bool b], new_state) -> + let new_state = State.push new_state (Bool (a = b)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "EQ")) + + | NE -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (if a <> b then 1 else 0)) in + Continue { state = new_state; cont } + | State.Ok ([Bool a; Bool b], new_state) -> + let new_state = State.push new_state (Bool (a <> b)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "NE")) + + | LT -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (if a < b then 1 else 0)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "LT")) + + | LE -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (if a <= b then 1 else 0)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "LE")) + + | GT -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (if a > b then 1 else 0)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "GT")) + + | GE -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([Int a; Int b], new_state) -> + let new_state = State.push new_state (Int (if a >= b then 1 else 0)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "GE")) + + | AND -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([a; b], new_state) -> + (match (bool_of_value a, bool_of_value b) with + | (Some a', Some b') -> + let new_state = State.push new_state (Bool (a' && b')) in + Continue { state = new_state; cont } + | _ -> Error (State.TypeMismatch "AND"))) + + | OR -> + (match State.pop_n next_state 2 with + | State.Error e -> Error e + | State.Ok ([a; b], new_state) -> + (match (bool_of_value a, bool_of_value b) with + | (Some a', Some b') -> + let new_state = State.push new_state (Bool (a' || b')) in + Continue { state = new_state; cont } + | _ -> Error (State.TypeMismatch "OR"))) + + | NOT -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (v, new_state) -> + (match bool_of_value v with + | Some b -> + let new_state = State.push new_state (Bool (not b)) in + Continue { state = new_state; cont } + | None -> Error (State.TypeMismatch "NOT"))) + + | NEG -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (Int n, new_state) -> + let new_state = State.push new_state (Int (-n)) in + Continue { state = new_state; cont } + | State.Ok _ -> Error (State.TypeMismatch "NEG")) + + | JMP offset -> + let new_pc = next_state.pc + offset - 1 in + if new_pc < 0 || new_pc >= Array.length state.code then + Error (State.InvalidJump new_pc) + else + let new_state = State.with_pc next_state new_pc in + Continue { state = new_state; cont } + + | JMP_IF offset -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (v, new_state) -> + (match bool_of_value v with + | Some true -> + let new_pc = new_state.pc + offset - 1 in + if new_pc < 0 || new_pc >= Array.length state.code then + Error (State.InvalidJump new_pc) + else + let new_state = State.with_pc new_state new_pc in + Continue { state = new_state; cont } + | Some false -> + Continue { state = new_state; cont } + | None -> Error (State.TypeMismatch "JMP_IF"))) + + | JMP_IF_NOT offset -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (v, new_state) -> + (match bool_of_value v with + | Some false -> + let new_pc = new_state.pc + offset - 1 in + if new_pc < 0 || new_pc >= Array.length state.code then + Error (State.InvalidJump new_pc) + else + let new_state = State.with_pc new_state new_pc in + Continue { state = new_state; cont } + | Some true -> + Continue { state = new_state; cont } + | None -> Error (State.TypeMismatch "JMP_IF_NOT"))) + + | CALL -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (func, new_state) -> + (match func with + | Closure { code; env } -> + let new_state = State.push_env new_state in + let new_state = State.set_env new_state env in + let new_pc = code in + if new_pc < 0 || new_pc >= Array.length state.code then + Error (State.InvalidJump new_pc) + else + let new_state = State.with_pc new_state new_pc in + let new_cont = Cont.return_to cont in + Continue { state = new_state; cont = new_cont } + | _ -> Error State.InvalidClosure)) + + | RET -> + (match State.pop_env next_state with + | State.Error _ -> + (match cont with + | Return_to k -> + Continue { state = next_state; cont = k } + | Halt -> + Halted (match State.peek next_state with State.Ok v -> Some v | _ -> None) + | _ -> + Halted (match State.peek next_state with State.Ok v -> Some v | _ -> None)) + | State.Ok (new_state, _) -> + (match cont with + | Return_to k -> + Continue { state = new_state; cont = k } + | Halt -> + Halted (match State.peek new_state with State.Ok v -> Some v | _ -> None) + | _ -> + Halted (match State.peek new_state with State.Ok v -> Some v | _ -> None))) + + | MK_CLOSURE code -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (env_val, new_state) -> + let env = match env_val with + | Closure { env; _ } -> env + | _ -> State.get_env new_state + in + let closure = Closure { code; env } in + let new_state = State.push new_state closure in + Continue { state = new_state; cont }) + + | LOAD idx -> + if idx < 0 || idx >= List.length next_state.env then + Error (State.InvalidIndex idx) + else + let v = List.nth next_state.env idx in + let new_state = State.push next_state v in + Continue { state = new_state; cont } + + | STORE idx -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (v, new_state) -> + let env = new_state.env in + let env' = if idx < List.length env then + let rec update i = function + | [] -> [] + | x :: xs -> if i = idx then v :: xs else x :: update (i + 1) xs + in update 0 env + else + let padding = List.init (idx - List.length env) (fun _ -> Int 0) in + env @ padding @ [v] + in + let new_state = State.set_env new_state env' in + Continue { state = new_state; cont }) + + | PUSH_ENV -> + let new_state = State.push_env next_state in + Continue { state = new_state; cont } + + | POP_ENV -> + (match State.pop_env next_state with + | State.Error e -> Error e + | State.Ok (new_state, _) -> + Continue { state = new_state; cont }) + + | TRY offset -> + let handler_pc = next_state.pc + offset - 1 in + if handler_pc < 0 || handler_pc >= Array.length state.code then + Error (State.InvalidJump handler_pc) + else + let handler_cont = Cont.eval_to (state.code.(handler_pc)) Cont.halt in + let new_cont = Cont.exception_to handler_cont cont in + Continue { state = next_state; cont = new_cont } + + | RAISE -> + (match State.pop next_state with + | State.Error e -> Error e + | State.Ok (exn_val, new_state) -> + let new_state = State.with_exception new_state exn_val in + let rec find_handler = function + | Exception_to { handler; cont } -> + let new_state = State.clear_exception new_state in + let new_state = State.push new_state exn_val in + Continue { state = new_state; cont = handler } + | Return_to k -> find_handler k + | Apply_to { cont; _ } -> find_handler cont + | Eval_to { cont; _ } -> find_handler cont + | Pop_to { cont; _ } -> find_handler cont + | Halt -> Error State.NoExceptionHandler + in + find_handler cont) + + | RERAISE -> + (match next_state.exception_value with + | None -> Error State.NoExceptionHandler + | Some exn_val -> + let rec find_handler = function + | Exception_to { handler; cont } -> + let new_state = State.clear_exception new_state in + let new_state = State.push new_state exn_val in + Continue { state = new_state; cont = handler } + | Return_to k -> find_handler k + | Apply_to { cont; _ } -> find_handler cont + | Eval_to { cont; _ } -> find_handler cont + | Pop_to { cont; _ } -> find_handler cont + | Halt -> Error State.NoExceptionHandler + in + find_handler cont) + + | HALT -> + Halted (match State.peek next_state with State.Ok v -> Some v | _ -> None) diff --git a/lib/trampoline.ml b/lib/trampoline.ml new file mode 100644 index 0000000..87f81e2 --- /dev/null +++ b/lib/trampoline.ml @@ -0,0 +1,63 @@ +open Step + +type thunk = unit -> result + +type trace_entry = { + pc : int; + stack_len : int; + cont_depth : int; +} + +type config = { + max_steps : int option; + trace : bool; + trace_entries : trace_entry list ref; +} + +let default_config = { + max_steps = None; + trace = false; + trace_entries = ref []; +} + +let rec run ?(config = default_config) thunk = + match config.max_steps with + | Some max when max <= 0 -> None + | Some max -> run_with_limit ~config max thunk + | None -> run_unlimited ~config thunk + +and run_unlimited ~config thunk = + match thunk () with + | Continue { state; cont } -> + (if config.trace then + config.trace_entries := { + pc = state.pc; + stack_len = List.length state.stack; + cont_depth = Cont.depth cont; + } :: !(config.trace_entries)); + run_unlimited ~config (fun () -> step state cont) + | Halted v -> Some v + | Error e -> None + +and run_with_limit ~config max_steps thunk = + let rec aux steps thunk = + if steps >= max_steps then + None + else + match thunk () with + | Continue { state; cont } -> + (if config.trace then + config.trace_entries := { + pc = state.pc; + stack_len = List.length state.stack; + cont_depth = Cont.depth cont; + } :: !(config.trace_entries)); + aux (steps + 1) (fun () -> step state cont) + | Halted v -> Some v + | Error e -> None + in + aux 0 thunk + +let get_trace config = List.rev !(config.trace_entries) + +let clear_trace config = config.trace_entries := [] diff --git a/lib/vm.ml b/lib/vm.ml new file mode 100644 index 0000000..85adb91 --- /dev/null +++ b/lib/vm.ml @@ -0,0 +1,62 @@ +open Instr +open State +open Cont +open Step +open Trampoline + +type t = { + code : Instr.t array; + initial_state : State.t; +} + +type execution_result = + | Success of value option + | Failure of State.error + | Timeout + +let create code = + let state = State.create code in + { code; initial_state = state } + +let execute ?(config = Trampoline.default_config) vm = + let state = vm.initial_state in + let cont = Cont.halt in + match Trampoline.run ~config (fun () -> step state cont) with + | Some v -> Success v + | None -> Failure NoExceptionHandler + +let execute_with_limit vm max_steps = + let config = { Trampoline.default_config with max_steps = Some max_steps } in + execute ~config vm + +let execute_program ?(config = Trampoline.default_config) code = + let vm = create code in + execute ~config vm + +let execute_program_with_limit code max_steps = + let vm = create code in + execute_with_limit vm max_steps + +let execute_with_trace code = + let config = { Trampoline.default_config with trace = true } in + let result = execute_program ~config code in + (result, Trampoline.get_trace config) + +let disassemble code = + Array.mapi (fun i instr -> (i, Instr.show instr)) code + |> Array.to_list + +let validate code = + let errors = ref [] in + Array.iteri (fun i instr -> + match instr with + | JMP offset | JMP_IF offset | JMP_IF_NOT offset | TRY offset -> + let target = i + 1 + offset - 1 in + if target < 0 || target >= Array.length code then + errors := (i, State.InvalidJump target) :: !errors + | MK_CLOSURE code_addr -> + if code_addr < 0 || code_addr >= Array.length code then + errors := (i, State.InvalidJump code_addr) :: !errors + | _ -> ()) + code; + List.rev !errors