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