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
|
open Printf ;;
open Interp_ast ;;
open Interp ;;
open Interp_lib ;;
open Big_int ;;
let lit_to_string = function
| L_unit -> "unit"
| L_zero -> "bitzero"
| L_one -> "bitone"
| L_true -> "true"
| L_false -> "false"
| L_num n -> string_of_big_int n
| L_hex s -> s
| L_bin s -> s
| L_undef -> "undefined"
| L_string s -> "\"" ^ s ^ "\""
;;
let id_to_string = function
| Id s | DeIid s -> s
;;
let rec val_to_string = function
| V_boxref n -> sprintf "boxref %d" n
| V_lit l -> sprintf "literal %s" (lit_to_string l)
| V_tuple l ->
let repr = String.concat ", " (List.map val_to_string l) in
sprintf "tuple (%s)" repr
| V_list l ->
let repr = String.concat "; " (List.map val_to_string l) in
sprintf "list [%s]" repr
| V_vector (first_index, inc, l) ->
let order = if inc then "little-endian" else "big-endian" in
let repr = String.concat "; " (List.map val_to_string l) in
sprintf "vector [%s] (%s, from %s)" repr order (string_of_big_int first_index)
| V_record l ->
let pp (id, value) = sprintf "%s = %s" (id_to_string id) (val_to_string value) in
let repr = String.concat "; " (List.map pp l) in
sprintf "record {%s}" repr
| V_ctor (id, value) ->
sprintf "constructor %s %s" (id_to_string id) (val_to_string value)
;;
let rec env_to_string = function
| [] -> ""
| [id,v] -> sprintf "%s |-> %s" (id_to_string id) (val_to_string v)
| (id,v)::env -> sprintf "%s |-> %s, %s" (id_to_string id) (val_to_string v) (env_to_string env)
let rec stack_to_string = function
| Top -> "Top"
| Frame(id,exp,env,mem,s) ->
sprintf "(Frame of %s, e, (%s), m, %s)" (id_to_string id) (env_to_string env) (stack_to_string s)
;;
let reg_to_string = function Reg (id,_) | SubReg (id,_,_) -> id_to_string id ;;
let sub_to_string = function None -> "" | Some (x, y) -> sprintf " (%s, %s)"
(string_of_big_int x) (string_of_big_int y)
let act_to_string = function
| Read_reg (reg, sub) ->
sprintf "read_reg %s%s" (reg_to_string reg) (sub_to_string sub)
| Write_reg (reg, sub, value) ->
sprintf "write_reg %s%s = %s" (reg_to_string reg) (sub_to_string sub)
(val_to_string value)
| Read_mem (id, args, sub) ->
sprintf "read_mem %s(%s)%s" (id_to_string id) (val_to_string args)
(sub_to_string sub)
| Write_mem (id, args, sub, value) ->
sprintf "write_mem %s(%s)%s = %s" (id_to_string id) (val_to_string args)
(sub_to_string sub) (val_to_string value)
| Call_extern (name, arg) ->
sprintf "extern call %s applied to %s" name (val_to_string arg)
;;
module Reg = struct
include Map.Make(struct type t = id let compare = compare end)
end ;;
module Mem = struct
include Map.Make(struct
type t = (id * big_int)
let compare (i1, v1) (i2, v2) =
match compare i1 i2 with
| 0 -> compare_big_int v1 v2
| n -> n
end)
end ;;
let slice v = function
| None -> v
| Some (n, m) -> slice_vector v n m
;;
let perform_action ((reg, mem) as env) = function
| Read_reg ((Reg (id, _) | SubReg (id, _, _)), sub) ->
slice (Reg.find id reg) sub, env
| Read_mem (id, V_lit(L_num n), sub) ->
slice (Mem.find (id, n) mem) sub, env
| Write_reg ((Reg (id, _) | SubReg (id, _, _)), None, value) ->
V_lit L_unit, (Reg.add id value reg, mem)
| Write_mem (id, V_lit(L_num n), None, value) ->
V_lit L_unit, (reg, Mem.add (id, n) value mem)
| Call_extern (name, arg) -> eval_external name arg, env
| _ -> failwith "partial write not implemented" (* XXX *)
;;
let run (name, test) =
let rec loop env = function
| Value v -> eprintf "%s: returned %s\n" name (val_to_string v)
| Action (a, s) ->
eprintf "%s: suspended on action %s\n" name (act_to_string a);
(*eprintf "%s: suspended on action %s, with stack %s\n" name (act_to_string a) (stack_to_string s);*)
let return, env' = perform_action env a in
eprintf "%s: action returned %s\n" name (val_to_string return);
loop env' (resume test s return)
| Error e -> eprintf "%s: error: %s\n" name e in
let entry = E_app((Id "main"), [E_lit L_unit]) in
eprintf "%s: starting\n" name;
try
Printexc.record_backtrace true;
loop (Reg.empty, Mem.empty) (interp test entry)
with e ->
let trace = Printexc.get_backtrace () in
eprintf "%s: interpretor error %s\n%s\n" name (Printexc.to_string e) trace
;;
|
