comparison lab4/dict.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 (* lab4/dict.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Print
5 open Optree
6 open Mach
7
8 (* Identifiers are represented by integers, with a hash table that maps
9 strings to the corresponding integer, and a vector that maps the
10 other way. *)
11
12 type ident = int
13
14 let nids = ref 0
15 let idhash = Hashtbl.create 100
16 let idvec = Growvect.create 100
17
18 let intern s =
19 try Hashtbl.find idhash s with
20 Not_found ->
21 let x = !nids in
22 incr nids;
23 Hashtbl.add idhash s x;
24 Growvect.append idvec s;
25 x
26
27 let spelling x = Growvect.get idvec x
28
29 let fId x = fStr (spelling x)
30
31 (* |location| -- runtime locations *)
32 type location =
33 Local of int (* Local (offset) *)
34 | Global of symbol (* Global (label) *)
35 | Register of int (* Register *)
36 | Nowhere (* Compile-time only *)
37
38 let fLoc =
39 function
40 Local n -> fMeta "local $" [fNum n]
41 | Global g -> fMeta "global $" [fStr g]
42 | Register i -> fMeta "register $" [fNum i]
43 | Nowhere -> fStr "*nowhere*"
44
45 (* |libid| -- type of picoPascal library procedures *)
46 type libid = ChrFun | OrdFun | PrintNum | PrintChar | PrintString
47 | NewLine | ReadChar | ExitProc | NewProc | ArgcFun | ArgvProc
48 | OpenIn | CloseIn | Operator of Optree.op
49
50 (* |lib_name| -- name of a library procedure *)
51 let lib_name x =
52 match x with
53 PrintNum -> "print_num" | PrintChar -> "print_char"
54 | PrintString -> "print_string" | NewLine -> "newline"
55 | ReadChar -> "read_char" | ChrFun -> "chr" | OrdFun -> "ord"
56 | ExitProc -> "exit" | NewProc -> "new"
57 | ArgcFun -> "argc" | ArgvProc -> "argv"
58 | OpenIn -> "open_in" | CloseIn -> "close_in"
59 | Operator op -> sprintf "$" [Optree.fOp op]
60
61 let fLibId l = fStr (lib_name l)
62
63
64 (*
65 Environments are represented using CAML Light's library module that
66 implements mappings using balanced binary trees.
67
68 The top block is also kept separately as a list, to check for multiple
69 declarations, and so that it can be returned by the top_block function.
70 This is used for formal parameter lists and lists of fields in
71 record types. The list is kept in reverse order internally, so that
72 an element can be added in constant time.
73 *)
74
75 (* |def_kind| -- kinds of definition *)
76 type def_kind =
77 ConstDef of int (* Constant (value) *)
78 | StringDef (* String *)
79 | TypeDef (* Type *)
80 | VarDef (* Variable *)
81 | CParamDef (* Value parameter *)
82 | VParamDef (* Var parameter *)
83 | FieldDef (* Field of record *)
84 | ProcDef (* Procedure *)
85 | PParamDef (* Proc parameter *)
86 | LibDef of libproc (* Lib proc (data) *)
87 | HoleDef of ptype ref (* Pending type *)
88 | DummyDef (* Dummy *)
89
90 (* |def| -- definitions in environment *)
91 and def =
92 { d_tag: ident; (* Name *)
93 d_kind: def_kind; (* Kind of object *)
94 d_type: ptype; (* Type *)
95 d_level: int; (* Static level *)
96 mutable d_mem: bool; (* Whether addressible *)
97 mutable d_addr: location } (* Run-time location *)
98
99 and basic_type = VoidType | IntType | CharType | BoolType | AddrType
100
101 (* |ptype| -- picoPascal types *)
102 and ptype =
103 { t_id: int; (* Unique identifier *)
104 t_guts: type_guts; (* Shape of the type *)
105 t_rep: Mach.metrics }
106
107 and type_guts =
108 BasicType of basic_type
109 | ArrayType of int * ptype
110 | RecordType of def list
111 | ProcType of proc_data
112 | PointerType of ptype ref
113
114 (* |proc_data| -- data about a procedure type *)
115 and proc_data =
116 { p_fparams: def list;
117 p_pcount: int;
118 p_result: ptype }
119
120 (* |libproc| -- data about a library procedure *)
121 and libproc =
122 { q_id: libid;
123 q_nargs: int;
124 q_argtypes: ptype list }
125
126 module IdMap =
127 Map.Make(struct
128 type t = ident
129 let compare = compare
130 end)
131
132 type environment = Env of (def list * def IdMap.t)
133
134 let add_def d m = IdMap.add d.d_tag d m
135
136 let add_block b (Env (b0, m)) =
137 Env (List.rev b, Util.accum add_def b m)
138
139 let top_block (Env (b, m)) = List.rev b
140
141 let new_block (Env (b0, m)) = Env ([], m)
142
143 let find_def x ds =
144 let rec search =
145 function
146 [] -> raise Not_found
147 | d::ds ->
148 if x = d.d_tag then d else search ds in
149 search ds
150
151 let can f x = try f x; true with Not_found -> false
152
153 let define d (Env (b, m)) =
154 if can (find_def d.d_tag) b then raise Exit;
155 Env (d::b, add_def d m)
156
157 let replace d (Env (b, m)) =
158 let rec repl =
159 function
160 [] -> failwith "replace"
161 | d'::ds ->
162 if d.d_tag = d'.d_tag then d::ds else d' :: repl ds in
163 Env (repl b, add_def d m)
164
165 let lookup x (Env (b, m)) = IdMap.find x m
166
167 let empty = Env ([], IdMap.empty)
168
169 let n_types = ref 0
170
171 let mk_type t r =
172 incr n_types;
173 { t_id = !n_types; t_guts = t; t_rep = r }
174
175 let voidtype = mk_type (BasicType VoidType) void_rep
176 let integer = mk_type (BasicType IntType) int_rep
177 let character = mk_type (BasicType CharType) char_rep
178 let boolean = mk_type (BasicType BoolType) bool_rep
179 let addrtype = mk_type (BasicType AddrType) addr_rep
180
181 let row n t =
182 let r = t.t_rep in
183 mk_type (ArrayType (n, t)) { r_size = n * r.r_size; r_align = r.r_align }
184
185 let discrete t =
186 match t.t_guts with
187 BasicType (IntType | CharType | BoolType) -> true
188 | _ -> false
189
190 let scalar t =
191 match t.t_guts with
192 BasicType (IntType | CharType | BoolType) -> true
193 | PointerType _ -> true
194 | _ -> false
195
196 let is_pointer t =
197 match t.t_guts with
198 PointerType t1 -> true
199 | _ -> false
200
201 let bound t =
202 match t.t_guts with
203 ArrayType (n, t1) -> n
204 | _ -> failwith "bound"
205
206 let base_type t =
207 match t.t_guts with
208 PointerType t1 -> !t1
209 | ArrayType (n, t1) -> t1
210 | _ -> failwith "base_type"
211
212 let get_proc t =
213 match t.t_guts with
214 ProcType p -> p
215 | _ -> failwith "get_proc"
216
217 let rec same_type t1 t2 =
218 match (t1.t_guts, t2.t_guts) with
219 (ProcType p1, ProcType p2) ->
220 match_args p1.p_fparams p2.p_fparams
221 && same_type p1.p_result p2.p_result
222 | (ArrayType (n1, u1), ArrayType(n2, u2)) ->
223 n1 = n2 && same_type u1 u2
224 | (PointerType _, BasicType x) -> x = AddrType
225 | (BasicType x, PointerType _) -> x = AddrType
226 | (_, _) -> t1.t_id = t2.t_id
227
228 and match_args fp1 fp2 =
229 match (fp1, fp2) with
230 ([], []) -> true
231 | (f1::fp1', f2::fp2') ->
232 f1.d_kind = f2.d_kind && same_type f1.d_type f2.d_type
233 && match_args fp1' fp2'
234 | _ -> false
235
236 let is_string t =
237 match t.t_guts with
238 ArrayType (n, t1) -> same_type t1 character
239 | _ -> false
240
241 let offset_of d =
242 match d.d_addr with
243 Local o -> o
244 | _ -> failwith "offset_of"