annotate lab4/tgen.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 (* lab4/tgen.ml *)
mike@0 2 (* Copyright (c) 2017 J. M. Spivey *)
mike@0 3
mike@0 4 open Dict
mike@0 5 open Tree
mike@0 6 open Mach
mike@0 7 open Optree
mike@0 8 open Lexer
mike@0 9 open Print
mike@0 10
mike@0 11 let boundchk = ref false
mike@0 12 let optlevel = ref 0
mike@0 13 let debug = ref 0
mike@0 14
mike@0 15 (* |level| -- nesting level of current procedure *)
mike@0 16 let level = ref 0
mike@0 17
mike@0 18 (* |retlab| -- label to return from current procedure *)
mike@0 19 let retlab = ref nolab
mike@0 20
mike@0 21 (* |size_of| -- calculate size of type *)
mike@0 22 let size_of t = t.t_rep.r_size
mike@0 23
mike@0 24 (* |get_value| -- get constant value or fail *)
mike@0 25 let get_value e =
mike@0 26 match e.e_value with
mike@0 27 Some v -> v
mike@0 28 | None -> failwith "get_value"
mike@0 29
mike@0 30 (* |line_number| -- compute line number of variable for bound check *)
mike@0 31 let rec line_number v =
mike@0 32 match v.e_guts with
mike@0 33 Variable x -> x.x_line
mike@0 34 | Sub (a, i) -> line_number a
mike@0 35 | Select (r, x) -> x.x_line
mike@0 36 | Deref p -> line_number p
mike@0 37 | _ -> failwith "line_number"
mike@0 38
mike@0 39 (* |addr_size| -- size of address *)
mike@0 40 let addr_size = addr_rep.r_size
mike@0 41
mike@0 42 (* |schain| -- code to follow N links of static chain *)
mike@0 43 let rec schain n =
mike@0 44 if n = 0 then
mike@0 45 <LOCAL 0>
mike@0 46 else
mike@0 47 <LOADW, <OFFSET, schain (n-1), <CONST stat_link>>>
mike@0 48
mike@0 49 (* |address| -- code to push address of an object *)
mike@0 50 let address d =
mike@0 51 match d.d_addr with
mike@0 52 Global g ->
mike@0 53 <GLOBAL g>
mike@0 54 | Local off ->
mike@0 55 <OFFSET, schain (!level - d.d_level), <CONST off>>
mike@0 56 | Register i ->
mike@0 57 <REGVAR i>
mike@0 58 | Nowhere ->
mike@0 59 failwith (sprintf "address $" [fId d.d_tag])
mike@0 60
mike@0 61 (* |gen_closure| -- two trees for a (code, envt) pair *)
mike@0 62 let gen_closure d =
mike@0 63 match d.d_kind with
mike@0 64 ProcDef ->
mike@0 65 (address d,
mike@0 66 if d.d_level = 0 then <CONST 0> else schain (!level - d.d_level))
mike@0 67 | PParamDef ->
mike@0 68 (<LOADW, address d>,
mike@0 69 <LOADW, <OFFSET, address d, <CONST addr_size>>>)
mike@0 70 | _ -> failwith "missing closure"
mike@0 71
mike@0 72 let rec numargs i =
mike@0 73 function
mike@0 74 [] -> []
mike@0 75 | (x::xs) -> <ARG i, x> :: numargs (i+1) xs
mike@0 76
mike@0 77 (* |libcall| -- code for library call *)
mike@0 78 let libcall lab args rtype =
mike@0 79 let n = List.length args in
mike@0 80 <PCALL n, @(<GLOBAL lab> :: numargs 0 args)>
mike@0 81
mike@0 82 (* |gen_copy| -- generate code to copy a fixed-size chunk *)
mike@0 83 let gen_copy dst src n =
mike@0 84 libcall "memcpy" [dst; src; <CONST n>] voidtype
mike@0 85
mike@0 86 (* |gen_addr| -- code for the address of a variable *)
mike@0 87 let rec gen_addr v =
mike@0 88 match v.e_guts with
mike@0 89 Variable x ->
mike@0 90 let d = get_def x in
mike@0 91 begin
mike@0 92 match d.d_kind with
mike@0 93 VarDef ->
mike@0 94 address d
mike@0 95 | VParamDef ->
mike@0 96 <LOADW, address d>
mike@0 97 | CParamDef ->
mike@0 98 if scalar d.d_type || is_pointer d.d_type then
mike@0 99 address d
mike@0 100 else
mike@0 101 <LOADW, address d>
mike@0 102 | StringDef ->
mike@0 103 address d
mike@0 104 | _ ->
mike@0 105 failwith "load_addr"
mike@0 106 end
mike@0 107 | Sub (a, i) ->
mike@0 108 let bound_check t =
mike@0 109 if not !boundchk then t else <BOUND, t, <CONST (bound a.e_type)>> in
mike@0 110 <OFFSET,
mike@0 111 gen_addr a,
mike@0 112 <BINOP Times, bound_check (gen_expr i), <CONST (size_of v.e_type)>>>
mike@0 113 | Select (r, x) ->
mike@0 114 let d = get_def x in
mike@0 115 <OFFSET, gen_addr r, <CONST (offset_of d)>>
mike@0 116 | Deref p ->
mike@0 117 let null_check t =
mike@0 118 if not !boundchk then t else <NCHECK, t> in
mike@0 119 null_check (gen_expr p)
mike@0 120 | String (lab, n) -> <GLOBAL lab>
mike@0 121 | _ -> failwith "gen_addr"
mike@0 122
mike@0 123 (* |gen_expr| -- tree for the value of an expression *)
mike@0 124 and gen_expr e =
mike@0 125 match e.e_value with
mike@0 126 Some v ->
mike@0 127 <CONST v>
mike@0 128 | None ->
mike@0 129 begin
mike@0 130 match e.e_guts with
mike@0 131 Variable _ | Sub _ | Select _ | Deref _ ->
mike@0 132 let ld = if size_of e.e_type = 1 then LOADC else LOADW in
mike@0 133 <ld, gen_addr e>
mike@0 134 | Monop (w, e1) ->
mike@0 135 <MONOP w, gen_expr e1>
mike@0 136 | Binop (Div, e1, e2) ->
mike@0 137 libcall "int_div" [gen_expr e1; gen_expr e2] integer
mike@0 138 | Binop (Mod, e1, e2) ->
mike@0 139 libcall "int_mod" [gen_expr e1; gen_expr e2] integer
mike@0 140 | Binop (w, e1, e2) ->
mike@0 141 <BINOP w, gen_expr e1, gen_expr e2>
mike@0 142 | FuncCall (p, args) ->
mike@0 143 gen_call p args
mike@0 144 | _ -> failwith "gen_expr"
mike@0 145 end
mike@0 146
mike@0 147 (* |gen_call| -- generate code to call a procedure *)
mike@0 148 and gen_call x args =
mike@0 149 let d = get_def x in
mike@0 150 match d.d_kind with
mike@0 151 LibDef q ->
mike@0 152 gen_libcall q args
mike@0 153 | _ ->
mike@0 154 let p = get_proc d.d_type in
mike@0 155 let (fn, sl) = gen_closure d in
mike@0 156 let args = List.concat (List.map2 gen_arg p.p_fparams args) in
mike@0 157 <PCALL p.p_pcount, @(fn :: <SLINK, sl> :: numargs 0 args)>
mike@0 158
mike@0 159 (* |gen_arg| -- generate code for a procedure argument *)
mike@0 160 and gen_arg f a =
mike@0 161 match f.d_kind with
mike@0 162 CParamDef ->
mike@0 163 if scalar f.d_type || is_pointer f.d_type then
mike@0 164 [gen_expr a]
mike@0 165 else
mike@0 166 [gen_addr a]
mike@0 167 | VParamDef ->
mike@0 168 [gen_addr a]
mike@0 169 | PParamDef ->
mike@0 170 begin
mike@0 171 match a.e_guts with
mike@0 172 Variable x ->
mike@0 173 let (fn, sl) = gen_closure (get_def x) in [fn; sl]
mike@0 174 | _ ->
mike@0 175 failwith "bad funarg"
mike@0 176 end
mike@0 177 | _ -> failwith "bad arg"
mike@0 178
mike@0 179 (* |gen_libcall| -- generate code to call a built-in procedure *)
mike@0 180 and gen_libcall q args =
mike@0 181 match (q.q_id, args) with
mike@0 182 (ChrFun, [e]) -> gen_expr e
mike@0 183 | (OrdFun, [e]) -> gen_expr e
mike@0 184 | (PrintString, [e]) ->
mike@0 185 libcall "print_string" [gen_addr e; <CONST (bound e.e_type)>] voidtype
mike@0 186 | (ReadChar, [e]) ->
mike@0 187 libcall "read_char" [gen_addr e] voidtype
mike@0 188 | (NewProc, [e]) ->
mike@0 189 let size = size_of (base_type e.e_type) in
mike@0 190 <STOREW, libcall "new" [<CONST size>] addrtype, gen_addr e>
mike@0 191 | (ArgcFun, []) ->
mike@0 192 libcall "argc" [] integer
mike@0 193 | (ArgvProc, [e1; e2]) ->
mike@0 194 libcall "argv" [gen_expr e1; gen_addr e2] voidtype
mike@0 195 | (OpenIn, [e]) ->
mike@0 196 libcall "open_in" [gen_addr e] voidtype
mike@0 197 | (Operator op, [e1]) ->
mike@0 198 <MONOP op, gen_expr e1>
mike@0 199 | (Operator op, [e1; e2]) ->
mike@0 200 <BINOP op, gen_expr e1, gen_expr e2>
mike@0 201 | (_, _) ->
mike@0 202 let proc = sprintf "$" [fLibId q.q_id] in
mike@0 203 libcall proc (List.map gen_expr args) voidtype
mike@0 204
mike@0 205 (* |gen_cond| -- generate code to branch on a condition *)
mike@0 206 let rec gen_cond test tlab flab =
mike@0 207 match test.e_value with
mike@0 208 Some v ->
mike@0 209 if v <> 0 then <JUMP tlab> else <JUMP flab>
mike@0 210 | None ->
mike@0 211 begin match test.e_guts with
mike@0 212 Monop (Not, e) ->
mike@0 213 gen_cond e flab tlab
mike@0 214 | Binop (Or, e1, e2) ->
mike@0 215 let l1 = label () in
mike@0 216 <SEQ,
mike@0 217 gen_cond e1 tlab l1,
mike@0 218 <LABEL l1>,
mike@0 219 gen_cond e2 tlab flab>
mike@0 220 | Binop (And, e1, e2) ->
mike@0 221 let l1 = label () in
mike@0 222 <SEQ,
mike@0 223 gen_cond e1 l1 flab,
mike@0 224 <LABEL l1>,
mike@0 225 gen_cond e2 tlab flab>
mike@0 226 | Binop ((Eq | Neq | Lt | Leq | Gt | Geq) as w, e1, e2) ->
mike@0 227 <SEQ,
mike@0 228 <JUMPC (w, tlab), gen_expr e1, gen_expr e2>,
mike@0 229 <JUMP flab>>
mike@0 230 | _ ->
mike@0 231 <SEQ,
mike@0 232 <JUMPC (Neq, tlab), gen_expr test, <CONST 0>>,
mike@0 233 <JUMP flab>>
mike@0 234 end
mike@0 235
mike@0 236 (* |gen_jtable| -- lay out jump table for case statement *)
mike@0 237 let gen_jtable sel table0 deflab =
mike@0 238 if table0 = [] then
mike@0 239 <JUMP deflab>
mike@0 240 else begin
mike@0 241 let table = List.sort (fun (v1, l1) (v2, l2) -> compare v1 v2) table0 in
mike@0 242 let lobound = fst (List.hd table) in
mike@0 243 let rec tab u qs =
mike@0 244 match qs with
mike@0 245 [] -> []
mike@0 246 | (v, l) :: rs ->
mike@0 247 if u = v then l :: tab (v+1) rs else deflab :: tab (u+1) qs in
mike@0 248 <JCASE (tab lobound table, deflab),
mike@0 249 <BINOP Minus, sel, <CONST lobound>>>
mike@0 250 end
mike@0 251
mike@0 252 (* |gen_stmt| -- generate code for a statement *)
mike@0 253 let rec gen_stmt s =
mike@0 254 let code =
mike@0 255 match s.s_guts with
mike@0 256 Skip -> <NOP>
mike@0 257
mike@0 258 | Seq ss -> <SEQ, @(List.map gen_stmt ss)>
mike@0 259
mike@0 260 | Assign (v, e) ->
mike@0 261 if scalar v.e_type || is_pointer v.e_type then begin
mike@0 262 let st = if size_of v.e_type = 1 then STOREC else STOREW in
mike@0 263 <st, gen_expr e, gen_addr v>
mike@0 264 end else begin
mike@0 265 gen_copy (gen_addr v) (gen_addr e) (size_of v.e_type)
mike@0 266 end
mike@0 267
mike@0 268 | ProcCall (p, args) ->
mike@0 269 gen_call p args
mike@0 270
mike@0 271 | Return res ->
mike@0 272 begin
mike@0 273 match res with
mike@0 274 Some e -> <SEQ, <RESULTW, gen_expr e>, <JUMP !retlab>>
mike@0 275 | None -> <JUMP !retlab>
mike@0 276 end
mike@0 277
mike@0 278 | IfStmt (test, thenpt, elsept) ->
mike@0 279 let l1 = label () and l2 = label () and l3 = label() in
mike@0 280 <SEQ,
mike@0 281 gen_cond test l1 l2,
mike@0 282 <LABEL l1>,
mike@0 283 gen_stmt thenpt,
mike@0 284 <JUMP l3>,
mike@0 285 <LABEL l2>,
mike@0 286 gen_stmt elsept,
mike@0 287 <LABEL l3>>
mike@0 288
mike@0 289 | WhileStmt (test, body) ->
mike@0 290 let l1 = label () and l2 = label () and l3 = label() in
mike@0 291 <SEQ,
mike@0 292 <LABEL l1>,
mike@0 293 gen_cond test l2 l3,
mike@0 294 <LABEL l2>,
mike@0 295 gen_stmt body,
mike@0 296 <JUMP l1>,
mike@0 297 <LABEL l3>>
mike@0 298
mike@0 299 | RepeatStmt (body, test) ->
mike@0 300 let l1 = label () and l2 = label () in
mike@0 301 <SEQ,
mike@0 302 <LABEL l1>,
mike@0 303 gen_stmt body,
mike@0 304 gen_cond test l2 l1,
mike@0 305 <LABEL l2>>
mike@0 306
mike@0 307 | ForStmt (var, lo, hi, body, upb) ->
mike@0 308 (* Use previously allocated temp variable to store upper bound.
mike@0 309 We could avoid this if the upper bound is constant. *)
mike@0 310 let tmp = match !upb with Some d -> d | _ -> failwith "for" in
mike@0 311 let l1 = label () and l2 = label () in
mike@0 312 <SEQ,
mike@0 313 <STOREW, gen_expr lo, gen_addr var>,
mike@0 314 <STOREW, gen_expr hi, address tmp>,
mike@0 315 <LABEL l1>,
mike@0 316 <JUMPC (Gt, l2), gen_expr var, <LOADW, address tmp>>,
mike@0 317 gen_stmt body,
mike@0 318 <STOREW, <BINOP Plus, gen_expr var, <CONST 1>>, gen_addr var>,
mike@0 319 <JUMP l1>,
mike@0 320 <LABEL l2>>
mike@0 321
mike@0 322 | CaseStmt (sel, arms, deflt) ->
mike@0 323 (* Use one jump table, and hope it is reasonably compact *)
mike@0 324 let deflab = label () and donelab = label () in
mike@0 325 let labs = List.map (function x -> label ()) arms in
mike@0 326 let get_val (v, body) = get_value v in
mike@0 327 let table = List.combine (List.map get_val arms) labs in
mike@0 328 let gen_case lab (v, body) =
mike@0 329 <SEQ,
mike@0 330 <LABEL lab>,
mike@0 331 gen_stmt body,
mike@0 332 <JUMP donelab>> in
mike@0 333 <SEQ,
mike@0 334 gen_jtable (gen_expr sel) table deflab,
mike@0 335 <SEQ, @(List.map2 gen_case labs arms)>,
mike@0 336 <LABEL deflab>,
mike@0 337 gen_stmt deflt,
mike@0 338 <LABEL donelab>> in
mike@0 339
mike@0 340 (* Label the code with a line number *)
mike@0 341 <SEQ, <LINE s.s_line>, code>
mike@0 342
mike@0 343 (* unnest -- move procedure calls to top level *)
mike@0 344 let unnest code =
mike@0 345 let rec do_tree =
mike@0 346 function
mike@0 347 <PCALL n, @args> ->
mike@0 348 let t = Regs.new_temp 1 in
mike@0 349 <AFTER,
mike@0 350 <DEFTMP t, <PCALL n, @(List.map do_tree args)>>,
mike@0 351 <TEMP t>>
mike@0 352 | <w, @args> ->
mike@0 353 <w, @(List.map do_tree args)> in
mike@0 354 let do_root =
mike@0 355 function <op, @args> -> <op, @(List.map do_tree args)> in
mike@0 356 Optree.canon <SEQ, @(List.map do_root code)>
mike@0 357
mike@0 358 let show label code =
mike@0 359 if !debug > 0 then begin
mike@0 360 printf "$$:\n" [fStr Mach.comment; fStr label];
mike@0 361 List.iter (Optree.print_optree Mach.comment) code;
mike@0 362 printf "\n" []
mike@0 363 end;
mike@0 364 code
mike@0 365
mike@0 366 (* |do_proc| -- generate code for a procedure and pass to the back end *)
mike@0 367 let do_proc lab lev nargs (Block (_, body, fsize, nregv)) =
mike@0 368 level := lev+1;
mike@0 369 retlab := label ();
mike@0 370 let code0 =
mike@0 371 show "Initial code" (Optree.canon <SEQ, gen_stmt body, <LABEL !retlab>>) in
mike@0 372 Regs.init ();
mike@0 373 let code1 = if !optlevel < 1 then code0 else
mike@0 374 show "After simplification" (Jumpopt.optimise (Simp.optimise code0)) in
mike@0 375 let code2 = if !optlevel < 2 then
mike@0 376 show "After unnesting" (unnest code1)
mike@0 377 else
mike@0 378 show "After sharing" (Share.traverse code1) in
mike@0 379 Tran.translate lab nargs !fsize !nregv (flatten code2)
mike@0 380
mike@0 381 (* |get_label| -- extract label for global definition *)
mike@0 382 let get_label d =
mike@0 383 match d.d_addr with Global lab -> lab | _ -> failwith "get_label"
mike@0 384
mike@0 385 let get_decls (Block (decls, _, _, _)) = decls
mike@0 386
mike@0 387 (* |gen_proc| -- translate a procedure, ignore other declarations *)
mike@0 388 let rec gen_proc =
mike@0 389 function
mike@0 390 ProcDecl (Heading (x, _, _), block) ->
mike@0 391 let d = get_def x in
mike@0 392 let p = get_proc d.d_type in
mike@0 393 let line = Source.get_line x.x_line in
mike@0 394 printf "$$\n" [fStr Mach.comment; fStr line];
mike@0 395 do_proc (get_label d) d.d_level p.p_pcount block;
mike@0 396 gen_procs (get_decls block)
mike@0 397 | _ -> ()
mike@0 398
mike@0 399 (* |gen_procs| -- generate code for the procedures in a block *)
mike@0 400 and gen_procs ds = List.iter gen_proc ds
mike@0 401
mike@0 402 (* |gen_global| -- generate declaration for global variable *)
mike@0 403 let gen_global d =
mike@0 404 match d.d_kind with
mike@0 405 VarDef ->
mike@0 406 Target.emit_global (get_label d) (size_of d.d_type)
mike@0 407 | _ -> ()
mike@0 408
mike@0 409 (* |translate| -- generate code for the whole program *)
mike@0 410 let translate (Prog (block, glodefs)) =
mike@0 411 Target.preamble ();
mike@0 412 gen_procs (get_decls block);
mike@0 413 do_proc "pmain" 0 0 block;
mike@0 414 List.iter gen_global !glodefs;
mike@0 415 List.iter (fun (lab, s) -> Target.emit_string lab s) (string_table ());
mike@0 416 Target.postamble ()
mike@0 417