Initial
This commit is contained in:
kimmy441
GitHub
commit
1382f81bc7
|
|
@ -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
|
||||
```
|
||||
|
|
@ -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"
|
||||
|
|
@ -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))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
(lang dune 3.0)
|
||||
|
||||
(name sequence)
|
||||
|
||||
(package
|
||||
(name sequence)
|
||||
(depends ocaml))
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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"
|
||||
|
|
@ -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)
|
||||
|
|
@ -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 := []
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue