annotate ppc/dict.ml @ 1:b5139af1a420 tip basis

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