comparison ppc/kgen.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/kgen.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Dict
5 open Tree
6 open Mach
7 open Keiko
8 open Lexer
9 open Print
10
11 (* This code generator is a bit more like a functional program,
12 because each generation routine returns a list of instructions,
13 represented using the SEQ constructor of Keiko.inst *)
14
15 let optflag = ref false
16 let boundchk = ref false
17
18 (* |level| -- nesting level of current procedure *)
19 let level = ref 0
20
21 (* |size_of| -- calculate size of type *)
22 let size_of t = t.t_rep.r_size
23
24 (* |count_of| -- calculate number of parameter words *)
25 let count_of t = if t.t_rep.r_size = 0 then 0 else 1
26
27 (* |is_const| -- test if expression is a constant *)
28 let is_const e = (e.e_value <> None)
29
30 (* |get_value| -- get constant value or fail *)
31 let get_value e =
32 match e.e_value with
33 Some v -> v
34 | None -> failwith "get_value"
35
36 (* |arg_size| -- compute size of argument *)
37 let arg_size f =
38 match f.d_kind with PParamDef -> 2 | _ -> 1
39
40 (* |line_number| -- compute line number of variable for bound check *)
41 let rec line_number v =
42 match v.e_guts with
43 Variable x -> x.x_line
44 | Sub (a, i) -> line_number a
45 | Select (r, x) -> x.x_line
46 | Deref p -> line_number p
47 | _ -> failwith "line_number"
48
49 let load_addr = LOAD addr_rep.r_size
50
51 (* |schain| -- code to follow N links of static chain *)
52 let schain n =
53 if n = 0 then
54 LOCAL 0
55 else
56 SEQ [LOCAL stat_link; load_addr;
57 SEQ (Util.copy (n-1) (SEQ [CONST stat_link; OFFSET; load_addr]))]
58
59 (* |address| -- code to push address of an object *)
60 let address d =
61 match d.d_addr with
62 Global g -> GLOBAL g
63 | Local off ->
64 if d.d_level = !level then
65 LOCAL off
66 else
67 SEQ [schain (!level - d.d_level); CONST off; OFFSET]
68 | _ ->
69 failwith (sprintf "address $" [fId d.d_tag])
70
71 (* |gen_closure| -- push a (code, envt) pair *)
72 let gen_closure d =
73 match d.d_kind with
74 ProcDef ->
75 let statlink =
76 if d.d_level = 0 then CONST 0
77 else schain (!level - d.d_level) in
78 SEQ [statlink; address d]
79 | PParamDef ->
80 SEQ [address d; CONST addr_rep.r_size; OFFSET; load_addr;
81 address d; load_addr]
82 | _ -> failwith "missing closure"
83
84 (* |gen_addr| -- code for the address of a variable *)
85 let rec gen_addr v =
86 match v.e_guts with
87 Variable x ->
88 let d = get_def x in
89 begin
90 match d.d_kind with
91 VarDef ->
92 address d
93 | VParamDef ->
94 SEQ [address d; load_addr]
95 | CParamDef ->
96 if scalar d.d_type || is_pointer d.d_type then
97 address d
98 else
99 SEQ [address d; load_addr]
100 | StringDef ->
101 address d
102 | _ ->
103 failwith "load_addr"
104 end
105 | Sub (a, i) ->
106 SEQ [gen_addr a; gen_expr i;
107 if !boundchk then
108 SEQ [CONST (bound a.e_type); BOUND (line_number a)]
109 else
110 NOP;
111 CONST (size_of v.e_type); BINOP Times; OFFSET]
112 | Select (r, x) ->
113 let d = get_def x in
114 SEQ [gen_addr r; CONST (offset_of d); OFFSET]
115 | Deref p ->
116 SEQ [gen_expr p;
117 if !boundchk then NCHECK (line_number p) else NOP]
118 | String (lab, n) ->
119 GLOBAL lab
120 | _ -> failwith "gen_addr"
121
122 (* |gen_expr| -- tree for the value of an expression *)
123 and gen_expr e =
124 match e.e_value with
125 Some v ->
126 CONST v
127 | None ->
128 begin
129 match e.e_guts with
130 Variable _ | Sub _ | Select _ | Deref _ ->
131 SEQ [gen_addr e; LOAD (size_of e.e_type)]
132 | (Monop (Not, _) | Binop ((And|Or), _, _) ) ->
133 gen_cond_expr e
134 | Monop (w, e1) ->
135 SEQ [gen_expr e1; MONOP w]
136 | Binop (w, e1, e2) ->
137 SEQ [gen_expr e1; gen_expr e2; BINOP w]
138 | FuncCall (p, args) ->
139 gen_call p args
140 | _ -> failwith "gen_expr"
141 end
142
143 (* |gen_call| -- generate code to call a procedure *)
144 and gen_call x args =
145 let d = get_def x in
146 match d.d_kind with
147 LibDef q ->
148 gen_libcall q args
149 | _ ->
150 let p = get_proc d.d_type in
151 SEQ [
152 SEQ (List.map gen_arg (List.rev (List.combine p.p_fparams args)));
153 gen_closure d;
154 PCALL (p.p_pcount, count_of p.p_result)]
155
156 (* |gen_arg| -- generate code to push a procedure argument *)
157 and gen_arg (f, a) =
158 match f.d_kind with
159 CParamDef ->
160 if scalar f.d_type || is_pointer f.d_type then
161 gen_expr a
162 else
163 gen_addr a
164 | VParamDef ->
165 gen_addr a
166 | PParamDef ->
167 begin
168 match a.e_guts with
169 Variable x ->
170 gen_closure (get_def x)
171 | _ ->
172 failwith "bad funarg"
173 end
174 | _ -> failwith "bad arg"
175
176 (* |gen_libcall| -- generate code to call a built-in procedure *)
177 and gen_libcall q args =
178 let libcall lab n rt =
179 SEQ [CONST 0; GLOBAL lab; PCALL (n, count_of rt)] in
180 match (q.q_id, args) with
181 ((ChrFun|OrdFun), [e]) ->
182 gen_expr e
183 | (PrintString, [e]) ->
184 SEQ [CONST (bound e.e_type); gen_addr e;
185 libcall "lib.print_string" 2 voidtype]
186 | (ReadChar, [e]) ->
187 SEQ [gen_addr e; libcall "lib.read_char" 1 voidtype]
188 | (NewProc, [e]) ->
189 let size = size_of (base_type e.e_type) in
190 SEQ [CONST size; libcall "lib.new" 1 addrtype; gen_addr e;
191 STORE addr_rep.r_size]
192 | (ArgcFun, []) ->
193 libcall "lib.argc" 0 integer
194 | (ArgvProc, [e1; e2]) ->
195 SEQ [gen_addr e2; gen_expr e1; libcall "lib.argv" 2 voidtype]
196 | (OpenIn, [e]) ->
197 SEQ [gen_addr e; libcall "lib.open_in" 1 voidtype]
198 | (Operator op, [e1]) ->
199 SEQ [gen_expr e1; MONOP op]
200 | (Operator op, [e1; e2]) ->
201 SEQ [gen_expr e1; gen_expr e2; BINOP op]
202 | (_, _) ->
203 let proc = sprintf "lib.$" [fLibId q.q_id] in
204 SEQ [SEQ (List.map gen_expr (List.rev args));
205 libcall proc (List.length args) voidtype]
206
207 (* |gen_cond| -- generate code to branch on a condition *)
208 and gen_cond tlab flab test =
209 match test.e_value with
210 Some v ->
211 if v <> 0 then JUMP tlab else JUMP flab
212 | None ->
213 begin
214 match test.e_guts with
215 Monop (Not, e) ->
216 gen_cond flab tlab e
217 | Binop (And, e1, e2) ->
218 let lab1 = label () in
219 SEQ [gen_cond lab1 flab e1; LABEL lab1; gen_cond tlab flab e2]
220 | Binop (Or, e1, e2) ->
221 let lab1 = label () in
222 SEQ [gen_cond tlab lab1 e1; LABEL lab1; gen_cond tlab flab e2]
223 | Binop ((Eq | Neq | Lt | Leq | Gt | Geq) as w, e1, e2) ->
224 SEQ [gen_expr e1; gen_expr e2; JUMPC (w, tlab); JUMP flab]
225 | _ ->
226 SEQ [gen_expr test; CONST 0; JUMPC (Neq, tlab); JUMP flab]
227 end
228
229 (* |gen_cond_expr| -- generate short-cicuit expression with boolean result *)
230 and gen_cond_expr test =
231 let l1 = label () and l2 = label () and l3 = label () in
232 SEQ [gen_cond l1 l2 test;
233 LABEL l1; CONST 1; JUMP l3; LABEL l2; CONST 0; LABEL l3]
234
235 let gen_jtable tab0 deflab =
236 if tab0 = [] then JUMP deflab else begin
237 let table = List.sort (fun (v1, l1) (v2, l2) -> compare v1 v2) tab0 in
238 let lob = fst (List.hd table) in
239 let rec tab u qs =
240 match qs with
241 [] -> []
242 | (v, l) :: rs ->
243 if u = v then l :: tab (v+1) rs else deflab :: tab (u+1) qs in
244 SEQ [CONST lob; BINOP Minus; JCASE (tab lob table); JUMP deflab]
245 end
246
247 (* |gen_stmt| -- generate code for a statement *)
248 let rec gen_stmt s =
249 let code =
250 match s.s_guts with
251 Skip -> NOP
252 | Seq ss -> SEQ (List.map gen_stmt ss)
253 | Assign (v, e) ->
254 if scalar v.e_type || is_pointer v.e_type then
255 SEQ [gen_expr e; gen_addr v; STORE (size_of v.e_type)]
256 else
257 SEQ [gen_addr v; gen_addr e;
258 CONST (size_of v.e_type); FIXCOPY]
259 | ProcCall (p, args) ->
260 gen_call p args
261 | Return res ->
262 begin
263 match res with
264 Some e -> SEQ [gen_expr e; RETURN 1]
265 | None -> SEQ [RETURN 0]
266 end
267 | IfStmt (test, thenpt, elsept) ->
268 let lab1 = label () and lab2 = label () and lab3 = label () in
269 SEQ [gen_cond lab1 lab2 test;
270 LABEL lab1; gen_stmt thenpt; JUMP lab3;
271 LABEL lab2; gen_stmt elsept; LABEL lab3]
272 | WhileStmt (test, body) ->
273 let lab1 = label () and lab2 = label () and lab3 = label () in
274 SEQ [JUMP lab2; LABEL lab1; gen_stmt body;
275 LABEL lab2; gen_cond lab1 lab3 test; LABEL lab3]
276 | RepeatStmt (body, test) ->
277 let lab1 = label () and lab2 = label () in
278 SEQ [LABEL lab1; gen_stmt body;
279 gen_cond lab2 lab1 test; LABEL lab2]
280 | ForStmt (var, lo, hi, body) ->
281 (* For simplicity, this code re-evaluates hi on each iteration *)
282 let l1 = label () and l2 = label () in
283 let s = int_rep.r_size in
284 SEQ [gen_expr lo; gen_addr var; STORE s; JUMP l2;
285 LABEL l1; gen_stmt body;
286 gen_expr var; CONST 1; BINOP Plus; gen_addr var; STORE s;
287 LABEL l2; gen_expr var; gen_expr hi; JUMPC (Leq, l1)]
288 | CaseStmt (sel, arms, deflt) ->
289 let deflab = label () and donelab = label () in
290 let labs = List.map (function x -> label ()) arms in
291 let get_val (v, body) = get_value v in
292 let table = List.combine (List.map get_val arms) labs in
293 let gen_case lab (v, body) =
294 SEQ [LABEL lab; gen_stmt body; JUMP donelab] in
295 SEQ [gen_expr sel; gen_jtable table deflab;
296 SEQ (List.map2 gen_case labs arms);
297 LABEL deflab; gen_stmt deflt;
298 LABEL donelab] in
299 SEQ [if s.s_line <> 0 then LINE s.s_line else NOP; code]
300
301 (* |do_proc| -- generate code for a procedure *)
302 let do_proc lab lev rtype fsize body =
303 printf "PROC $ $ 0 0\n" [fStr lab; fNum fsize];
304 level := lev+1;
305 let code =
306 SEQ [gen_stmt body;
307 (if rtype.t_rep.r_size = 0 then RETURN 0 else ERETURN 0)] in
308 Keiko.output (if !optflag then Peepopt.optimise code else code);
309 printf "END\n\n" []
310
311 (* |gen_proc| -- translate a procedure, ignore other declarations *)
312 let rec gen_proc =
313 function
314 ProcDecl (Heading (x, _, _), Block (locals, body, fsize, nregv)) ->
315 let d = get_def x in
316 let p = get_proc d.d_type in
317 begin
318 match d.d_addr with
319 Global lab ->
320 do_proc lab d.d_level p.p_result !fsize body;
321 gen_procs locals
322 | _ -> failwith "gen_proc"
323 end
324 | _ -> ()
325
326 (* |gen_procs| -- generate code for the procedures in a block *)
327 and gen_procs ds = List.iter gen_proc ds
328
329 (* |gen_string| -- generate code for a string constant *)
330 let gen_string (lab, s) =
331 let s' = s ^ "\000" in
332 printf "! String \"$\"\n" [fStr (String.escaped s)];
333 printf "DEFINE $\n" [fStr lab];
334 let hex = "0123456789ABCDEF" in
335 let n = String.length s' and r = ref 0 in
336 while !r < n do
337 let k = min (n - !r) 32 in
338 printf "STRING " [];
339 for i = !r to !r+k-1 do
340 let c = int_of_char s'.[i] in
341 printf "$$" [fChr (hex.[c / 16]); fChr (hex.[c mod 16])]
342 done;
343 printf "\n" [];
344 r := !r + k
345 done;
346 printf "\n" []
347
348 (* |gen_global| -- reserve space for global variables *)
349 let gen_global d =
350 match d.d_kind with
351 VarDef ->
352 (match d.d_addr with
353 Global lab ->
354 printf "GLOVAR $ $\n" [fStr lab; fNum (size_of d.d_type)]
355 | _ -> failwith "gen_global")
356 | _ -> ()
357
358 (* |translate| -- generate code for the whole program *)
359 let translate (Prog (Block (globals, main, _, _), glodefs)) =
360 gen_procs globals;
361 do_proc "MAIN" 0 voidtype 0 main;
362 List.iter gen_global !glodefs;
363 List.iter gen_string (string_table ())