-
Notifications
You must be signed in to change notification settings - Fork 75
/
interp_2.ml
347 lines (282 loc) · 11.4 KB
/
interp_2.ml
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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
(**************************************
Compiler Construction 2016
Computer Laboratory
University of Cambridge
Timothy G. Griffin (tgg22@cam.ac.uk)
*****************************************)
(* Interpreter 2.
A high-level stack-oriented abstract machine with compiler.
What do I mean by "high-level"?
---Code is still tree-structured.
---Complex values are pushed onto value stack.
---Slang state (heap) used only for references.
---Code is maintained on a code stack.
---Program variables contained in code.
*)
open Ast
let complain = Errors.complain
type address = int
type var = string
type value =
| REF of address
| INT of int
| BOOL of bool
| UNIT
| PAIR of value * value
| INL of value
| INR of value
| CLOSURE of closure
| REC_CLOSURE of code
and closure = code * env
and instruction =
| PUSH of value
| LOOKUP of var
| UNARY of unary_oper
| OPER of oper
| ASSIGN
| SWAP
| POP
| BIND of var
| FST
| SND
| DEREF
| APPLY
| MK_PAIR
| MK_INL
| MK_INR
| MK_REF
| MK_CLOSURE of code
| MK_REC of var * code
| TEST of code * code
| CASE of code * code
| WHILE of code * code
and code = instruction list
and binding = var * value
and env = binding list
type env_or_value = EV of env | V of value
type env_value_stack = env_or_value list
(* This is the the slang program state --- that is, values for references *)
(* It is an array of referenced values together with next unallocated address *)
type state = (value array) * int
type interp_state = code * env_value_stack * state
(* Printing *)
let string_of_list sep f l =
let rec aux f = function
| [] -> ""
| [t] -> (f t)
| t :: rest -> (f t) ^ sep ^ (aux f rest)
in "[" ^ (aux f l) ^ "]"
let rec string_of_value = function
| REF a -> "REF(" ^ (string_of_int a) ^ ")"
| BOOL b -> string_of_bool b
| INT n -> string_of_int n
| UNIT -> "UNIT"
| PAIR(v1, v2) -> "(" ^ (string_of_value v1) ^ ", " ^ (string_of_value v2) ^ ")"
| INL v -> "inl(" ^ (string_of_value v) ^ ")"
| INR v -> "inr(" ^ (string_of_value v) ^ ")"
| CLOSURE(cl) -> "CLOSURE(" ^ (string_of_closure cl) ^ ")"
| REC_CLOSURE(c) -> "REC_CLOSURE(" ^ (string_of_code c) ^ ")"
and string_of_closure (c, env) =
"(" ^ (string_of_code c) ^ ", " ^ (string_of_env env) ^ ")"
and string_of_env env = string_of_list ",\n " string_of_binding env
and string_of_binding (x, v) = "(" ^ x ^ ", " ^ (string_of_value v) ^ ")"
and string_of_instruction = function
| UNARY op -> "UNARY " ^ (string_of_uop op)
| OPER op -> "OPER " ^ (string_of_bop op)
| MK_PAIR -> "MK_PAIR"
| FST -> "FST"
| SND -> "SND"
| MK_INL -> "MK_INL"
| MK_INR -> "MK_INR"
| MK_REF -> "MK_REF"
| PUSH v -> "PUSH " ^ (string_of_value v)
| LOOKUP x -> "LOOKUP " ^ x
| TEST(c1, c2) -> "TEST(" ^ (string_of_code c1) ^ ", " ^ (string_of_code c2) ^ ")"
| CASE(c1, c2) -> "CASE(" ^ (string_of_code c1) ^ ", " ^ (string_of_code c2) ^ ")"
| WHILE(c1, c2) -> "WHILE(" ^ (string_of_code c1) ^ ", " ^ (string_of_code c2) ^ ")"
| APPLY -> "APPLY"
| BIND x -> "BIND " ^ x
| SWAP -> "SWAP"
| POP -> "POP"
| DEREF -> "DEREF"
| ASSIGN -> "ASSIGN"
| MK_CLOSURE c -> "MK_CLOSURE(" ^ (string_of_code c) ^ ")"
| MK_REC(f, c) -> "MK_REC(" ^ f ^ ", " ^ (string_of_code c) ^ ")"
and string_of_code c = string_of_list ";\n " string_of_instruction c
let string_of_env_or_value = function
| EV env -> "EV " ^ (string_of_env env)
| V v -> "V " ^ (string_of_value v)
let string_of_env_value_stack = string_of_list ";\n " string_of_env_or_value
let string_of_state (heap, i) =
let rec aux k =
if i < k
then ""
else (string_of_int k) ^ " -> " ^ (string_of_value (heap.(k))) ^ "\n" ^ (aux (k+1))
in if i = 0
then ""
else "\nHeap = \n" ^ (aux 0)
let string_of_interp_state (c, evs, s) =
"\nCode Stack = \n" ^ (string_of_code c)
^ "\nEnv/Value Stack = \n" ^ (string_of_env_value_stack evs)
^ (string_of_state(s))
(* The "MACHINE" *)
(* allocate a new location in the heap
and give it value v
*)
let allocate (heap, i) v =
if i < Option.heap_max
then let _ = heap.(i) <- v
in (i, (heap, i+1))
else complain "runtime error: heap kaput"
let deref (heap, _) a = heap.(a)
let assign (heap, i) a v =
let _ = heap.(a) <- v
in (heap, i)
(* update : (env * binding) -> env *)
let update(env, (x, v)) = (x, v) :: env
let mk_fun(c, env) = CLOSURE(c, env)
let mk_rec(f, c, env) = CLOSURE(c, (f, REC_CLOSURE(c))::env)
(*
in interp_0:
interpret(LetRecFun(f, (x, body), e), env) =
let rec new_env g =
if g = f then FUN (fun v -> interpret(body, update(new_env, (x, v)))) else env g
in interpret(e, new_env, store)
new_env x = env x
new_env f = FUN (fun v -> interpret(body, update(new_env, (x, v))))
lookup (env1 @ [(f, cl1)] @ evn2, f) =
CLOSURE (false, (x, body, (f, cl2) :: env2))
*)
let lookup_opt (env, x) =
let rec aux = function
| [] -> None
| (y, v) :: rest ->
if x = y
then Some(match v with
| REC_CLOSURE(body) -> mk_rec(x, body, rest)
| _ -> v)
else aux rest
in aux env
let rec search (evs, x) =
match evs with
| [] -> complain (x ^ " is not defined!\n")
| (V _) :: rest -> search (rest, x)
| (EV env) :: rest ->
(match lookup_opt(env, x) with
| None -> search (rest, x)
| Some v -> v
)
let rec evs_to_env = function
| [] -> []
| (V _) :: rest -> evs_to_env rest
| (EV env) :: rest -> env @ (evs_to_env rest)
let readint () = let _ = print_string "input> " in read_int()
let do_unary = function
| (NOT, BOOL m) -> BOOL (not m)
| (NEG, INT m) -> INT (-m)
| (READ, UNIT) -> INT (readint())
| (op, _) -> complain ("malformed unary operator: " ^ (string_of_unary_oper op))
let do_oper = function
| (AND, BOOL m, BOOL n) -> BOOL (m && n)
| (OR, BOOL m, BOOL n) -> BOOL (m || n)
| (EQB, BOOL m, BOOL n) -> BOOL (m = n)
| (LT, INT m, INT n) -> BOOL (m < n)
| (EQI, INT m, INT n) -> BOOL (m = n)
| (ADD, INT m, INT n) -> INT (m + n)
| (SUB, INT m, INT n) -> INT (m - n)
| (MUL, INT m, INT n) -> INT (m * n)
| (DIV, INT m, INT n) -> INT (m / n)
| (op, _, _) -> complain ("malformed binary operator: " ^ (string_of_oper op))
(*
val step : interp_state -> interp_state
= (code * env_value_stack * state) -> (code * env_value_stack * state)
*)
let step = function
(* (code stack, value/env stack, state) -> (code stack, value/env stack, state) *)
| ((PUSH v) :: ds, evs, s) -> (ds, (V v) :: evs, s)
| (POP :: ds, e :: evs, s) -> (ds, evs, s)
| (SWAP :: ds, e1 :: e2 :: evs, s) -> (ds, e2 :: e1 :: evs, s)
| ((BIND x) :: ds, (V v) :: evs, s) -> (ds, EV([(x, v)]) :: evs, s)
| ((LOOKUP x) :: ds, evs, s) -> (ds, V(search(evs, x)) :: evs, s)
| ((UNARY op) :: ds, (V v) :: evs, s) -> (ds, V(do_unary(op, v)) :: evs, s)
| ((OPER op) :: ds, (V v2) :: (V v1) :: evs, s) -> (ds, V(do_oper(op, v1, v2)) :: evs, s)
| (MK_PAIR :: ds, (V v2) :: (V v1) :: evs, s) -> (ds, V(PAIR(v1, v2)) :: evs, s)
| (FST :: ds, V(PAIR (v, _)) :: evs, s) -> (ds, (V v) :: evs, s)
| (SND :: ds, V(PAIR (_, v)) :: evs, s) -> (ds, (V v) :: evs, s)
| (MK_INL :: ds, (V v) :: evs, s) -> (ds, V(INL v) :: evs, s)
| (MK_INR :: ds, (V v) :: evs, s) -> (ds, V(INR v) :: evs, s)
| (CASE (c1, _) :: ds, V(INL v)::evs, s) -> (c1 @ ds, (V v) :: evs, s)
| (CASE ( _, c2) :: ds, V(INR v)::evs, s) -> (c2 @ ds, (V v) :: evs, s)
| ((TEST(c1, c2)) :: ds, V(BOOL true) :: evs, s) -> (c1 @ ds, evs, s)
| ((TEST(c1, c2)) :: ds, V(BOOL false) :: evs, s) -> (c2 @ ds, evs, s)
| (ASSIGN :: ds, (V v) :: (V (REF a)) :: evs, s) -> (ds, V(UNIT) :: evs, assign s a v)
| (DEREF :: ds, (V (REF a)) :: evs, s) -> (ds, V(deref s a) :: evs, s)
| (MK_REF :: ds, (V v) :: evs, s) -> let (a, s') = allocate s v in (ds, V(REF a) :: evs, s')
| ((WHILE(c1, c2)) :: ds,V(BOOL false) :: evs, s) -> (ds, V(UNIT) :: evs, s)
| ((WHILE(c1, c2)) :: ds, V(BOOL true) :: evs, s) -> (c2 @ [POP] @ c1 @ [WHILE(c1, c2)] @ ds, evs, s)
| ((MK_CLOSURE c) :: ds, evs, s) -> (ds, V(mk_fun(c, evs_to_env evs)) :: evs, s)
| (MK_REC(f, c) :: ds, evs, s) -> (ds, V(mk_rec(f, c, evs_to_env evs)) :: evs, s)
| (APPLY :: ds, V(CLOSURE (c, env)) :: (V v) :: evs, s)
-> (c @ ds, (V v) :: (EV env) :: evs, s)
| state -> complain ("step : bad state = " ^ (string_of_interp_state state) ^ "\n")
let rec driver n state =
let _ = if Option.verbose
then print_string ("\nState " ^ (string_of_int n)
^ " : " ^ (string_of_interp_state state) ^ "\n")
else ()
in match state with
| ([], [V v], s) -> (v, s)
| _ -> driver (n + 1) (step state)
(* A BIND will leave an env on stack.
This gets rid of it. *)
let leave_scope = [SWAP; POP]
(*
val compile : expr -> code
*)
let rec compile = function
| Unit -> [PUSH UNIT]
| Integer n -> [PUSH (INT n)]
| Boolean b -> [PUSH (BOOL b)]
| Var x -> [LOOKUP x]
| UnaryOp(op, e) -> (compile e) @ [UNARY op]
| Op(e1, op, e2) -> (compile e1) @ (compile e2) @ [OPER op]
| Pair(e1, e2) -> (compile e1) @ (compile e2) @ [MK_PAIR]
| Fst e -> (compile e) @ [FST]
| Snd e -> (compile e) @ [SND]
| Inl e -> (compile e) @ [MK_INL]
| Inr e -> (compile e) @ [MK_INR]
| Case(e, (x1, e1), (x2, e2)) ->
(compile e)
@ [CASE((BIND x1) :: (compile e1) @ leave_scope,
(BIND x2) :: (compile e2) @ leave_scope)]
| If(e1, e2, e3) -> (compile e1) @ [TEST(compile e2, compile e3)]
| Seq [] -> []
| Seq [e] -> compile e
| Seq (e ::rest) -> (compile e) @ [POP] @ (compile (Seq rest))
| Ref e -> (compile e) @ [MK_REF]
| Deref e -> (compile e) @ [DEREF]
| While(e1, e2) -> let cl = compile e1 in cl @ [WHILE(cl, compile e2)]
| Assign(e1, e2) -> (compile e1) @ (compile e2) @ [ASSIGN]
| App(e1, e2) -> (compile e2) (* I chose to evaluate arg first *)
@ (compile e1)
@ [APPLY;
SWAP; POP] (* get rid of env left on stack *)
| Lambda(x, e) -> [MK_CLOSURE((BIND x) :: (compile e) @ leave_scope)]
| LetFun(f, (x, body), e) ->
(MK_CLOSURE((BIND x) :: (compile body) @ leave_scope)) ::
(BIND f) ::
(compile e) @ leave_scope
| LetRecFun(f, (x, body), e) ->
(MK_REC(f, (BIND x) :: (compile body) @ leave_scope)) ::
(BIND f) ::
(compile e) @ leave_scope
(* The initial Slang state is the Slang state : all locations contain 0 *)
let initial_state = (Array.make Option.heap_max (INT 0), 0)
let initial_env = []
(* interpret : expr -> (value * state) *)
let interpret e =
let c = compile e in
let _ = if Option.verbose
then print_string("Compile code =\n" ^ (string_of_code c) ^ "\n")
else ()
in driver 1 (c, initial_env, initial_state)