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