1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
(*
Rewriting the Python implementation of the register VM in OCaml to see how
how much imperative/mutative programming OCaml allows.
Note: Some of this code is intentionally not written in a functional style
because one of the goals was to see how similar this OCaml implementation
could be to the Python implementation.
Conclusion: It's pretty easily to switch between the two languages.
Usage: Recommended compilation settings I hastily found online:
$ ocamlopt -w +A-42-48 -warn-error +A-3-44 ./register_vm.ml && ./a.out
Formatting:
$ ocamlformat --inplace --enable-outside-detected-project ./register_vm.ml
*)
type reg = X | Y | Res
type binop = int -> int -> int
type ast =
| Const of int
| Add of ast * ast
| Sub of ast * ast
| Mul of ast * ast
| Div of ast * ast
type opcode0 =
| Op0AssignRegLit of reg * int
| Op0AssignRegReg of reg * reg
| Op0BinOp of binop * reg * reg * reg
| Op0PushReg of reg
| Op0PopAndSet of reg
| Op0Null
type opcode1 =
| Op1AssignRegLit of int * int
| Op1AssignRegReg of int * int
| Op1BinOp of (int -> int -> int) * int * int * int
| Op1PushReg of int
| Op1PopAndSet of int
| Op1Null
type opcodes0 = opcode0 array
type opcodes1 = opcode1 array
let registers : int array = Array.make 8 0
let stack : int Stack.t = Stack.create ()
let reg_idx (r : reg) : int = match r with X -> 0 | Y -> 1 | Res -> 2
let reg_name (r : reg) : string =
match r with X -> "x" | Y -> "y" | Res -> "res"
let print_opcodes0 (xs : opcodes0) : opcodes0 =
let print_opcode x =
match x with
| Op0AssignRegLit (r, x) -> Printf.printf "%s <- %d\n" (reg_name r) x
| Op0AssignRegReg (dst, src) ->
Printf.printf "%s <- $%s\n" (reg_name dst) (reg_name src)
| Op0PushReg src -> Printf.printf "push $%s\n" (reg_name src)
| Op0PopAndSet dst -> Printf.printf "%s <- pop\n" (reg_name dst)
| Op0BinOp (_, lhs, rhs, dst) ->
Printf.printf "%s <- $%s ? $%s\n" (reg_name dst) (reg_name lhs)
(reg_name rhs)
| Op0Null -> ()
in
Array.iter print_opcode xs;
xs
(* Mutatively add xs to ys *)
let add_ops (xs : opcodes0) (ys : opcodes0) (i : int ref) : unit =
let j = ref 0 in
while xs.(!j) != Op0Null do
ys.(!i) <- xs.(!j);
i := !i + 1;
j := !j + 1
done
let rec compile (ast : ast) : opcodes0 =
let result : opcodes0 = Array.make 20 Op0Null and i : int ref = ref 0 in
(match ast with
| Const x ->
result.(!i) <- Op0AssignRegLit (Res, x);
i := !i + 1
| Add (lhs, rhs) -> compile_bin_op ( + ) lhs rhs result i
| Sub (lhs, rhs) -> compile_bin_op ( - ) lhs rhs result i
| Mul (lhs, rhs) -> compile_bin_op ( * ) lhs rhs result i
| Div (lhs, rhs) -> compile_bin_op ( / ) lhs rhs result i);
result
and compile_bin_op (f : binop) (lhs : ast) (rhs : ast) (result : opcodes0)
(i : int ref) =
add_ops (compile lhs) result i;
result.(!i) <- Op0PushReg Res;
i := !i + 1;
add_ops (compile rhs) result i;
result.(!i + 1) <- Op0PopAndSet X;
result.(!i) <- Op0AssignRegReg (Y, Res);
result.(!i + 2) <- Op0BinOp (f, X, Y, Res);
i := !i + 3
let compile_registers (xs : opcodes0) : opcodes1 =
let do_compile x =
match x with
| Op0AssignRegLit (dst, x) -> Op1AssignRegLit (reg_idx dst, x)
| Op0AssignRegReg (dst, src) -> Op1AssignRegReg (reg_idx dst, reg_idx src)
| Op0PushReg src -> Op1PushReg (reg_idx src)
| Op0PopAndSet dst -> Op1PopAndSet (reg_idx dst)
| Op0BinOp (f, lhs, rhs, dst) ->
Op1BinOp (f, reg_idx lhs, reg_idx rhs, reg_idx dst)
| Op0Null -> Op1Null
in
Array.map do_compile xs
let eval (xs : opcodes1) : int =
let ip = ref 0 in
while !ip < Array.length xs do
match xs.(!ip) with
| Op1AssignRegLit (dst, x) ->
registers.(dst) <- x;
ip := !ip + 1
| Op1AssignRegReg (dst, src) ->
registers.(dst) <- registers.(src);
ip := !ip + 1
| Op1PushReg src ->
Stack.push registers.(src) stack;
ip := !ip + 1
| Op1PopAndSet dst ->
registers.(dst) <- Stack.pop stack;
ip := !ip + 1
| Op1BinOp (f, lhs, rhs, dst) ->
registers.(dst) <- f registers.(lhs) registers.(rhs);
ip := !ip + 1
| Op1Null -> ip := !ip + 1
done;
registers.(reg_idx Res)
;;
Add (Mul (Const 2, Div (Const 100, Const 2)), Const 5)
|> compile |> print_opcodes0 |> compile_registers |> eval |> print_int
|
