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