comparison lab4/tran.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/tran.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Optree
5 open Target
6 open Regs
7 open Print
8
9 let debug = ref 0
10
11 (* |release| -- release any register used by a value *)
12 let release =
13 function
14 Register reg -> release_reg reg
15 | Index (reg, off) -> release_reg reg
16 | Index2 (r1, r2, n) -> release_reg r1; release_reg r2
17 | _ -> ()
18
19 let fix_reg r = Register (get_reg (reg_of r))
20
21 (* |gen_reg| -- emit instruction with result in a register *)
22 let gen_reg op rands =
23 List.iter release (List.tl rands);
24 let r' = fix_reg (List.hd rands) in
25 emit op (r' :: List.tl rands);
26 r'
27
28 (* |gen| -- emit an instruction *)
29 let gen op rands =
30 List.iter release rands;
31 emit op rands
32
33 (* |gen_move| -- move value to specific register *)
34 let gen_move dst src =
35 if reg_of dst = R_any || reg_of dst = R_temp || dst = src then
36 src
37 else
38 gen_reg "mov" [dst; src]
39
40
41 (* Tests for fitting in various immediate fields *)
42
43 (* |fits_offset| -- test for fitting in offset field of address *)
44 let fits_offset x = (-4096 < x && x < 4096)
45
46 (* |fits_immed| -- test for fitting in immediate field *)
47 let fits_immed x =
48 (* A conservative approximation, using shifts instead of rotates *)
49 let rec reduce r =
50 if r land 3 <> 0 then r else reduce (r lsr 2) in
51 x = 0 || x > 0 && reduce x < 256
52
53 (* |fits_move| -- test for fitting in immediate move *)
54 let fits_move x = fits_immed x || fits_immed (lnot x)
55
56 (* |fits_add| -- test for fitting in immediate add *)
57 let fits_add x = fits_immed x || fits_immed (-x)
58
59 (* |line| -- current line number *)
60 let line = ref 0
61
62 (* The main part of the code generator consists of a family of functions
63 e_X t, each generating code for a tree t, leaving the value in
64 a register, or as an operand for another instruction, etc. *)
65
66 let anyreg = Register R_any
67 let anytemp = Register R_temp
68
69 (* |e_reg| -- evaluate expression with result in specified register *)
70 let rec e_reg t r =
71 (* returns |Register| *)
72
73 (* Binary operation *)
74 let binary op t1 t2 =
75 let v1 = e_reg t1 anyreg in
76 let v2 = e_rand t2 in
77 gen_reg op [r; v1; v2]
78
79 (* Unary operation *)
80 and unary op t1 =
81 let v1 = e_reg t1 anyreg in
82 gen_reg op [r; v1]
83
84 (* Comparison with boolean result *)
85 and compare op t1 t2 =
86 let v1 = e_reg t1 anyreg in
87 let v2 = e_rand t2 in
88 release v1; release v2;
89 let rr = fix_reg r in
90 emit "cmp" [v1; v2];
91 emit "mov" [rr; Const 0];
92 emit op [rr; Const 1];
93 rr in
94
95 match t with
96 <CONST k> when fits_move k ->
97 gen_reg "mov" [r; Const k]
98 | <CONST k> ->
99 gen_reg "set" [r; Const k]
100 | <LOCAL 0> ->
101 gen_move r (Register R_fp)
102 | <LOCAL n> when fits_add n ->
103 gen_reg "add" [r; Register R_fp; Const n]
104 | <LOCAL n> ->
105 emit "set" [Register R_ip; Const n];
106 gen_reg "add" [r; Register R_fp; Register R_ip]
107 | <GLOBAL x> ->
108 gen_reg "set" [r; Global x]
109 | <TEMP n> ->
110 gen_move r (Register (Regs.use_temp n))
111 | <(LOADW|LOADC), <REGVAR i>> ->
112 let rv = List.nth stable i in
113 reserve_reg rv; gen_move r (Register rv)
114 | <LOADW, t1> ->
115 let v1 = e_addr t1 in
116 gen_reg "ldr" [r; v1]
117 | <LOADC, t1> ->
118 let v1 = e_addr t1 in
119 gen_reg "ldrb" [r; v1]
120
121 | <MONOP Uminus, t1> -> unary "neg" t1
122 | <MONOP Not, t1> ->
123 let v1 = e_reg t1 anyreg in
124 gen_reg "eor" [r; v1; Const 1]
125 | <MONOP BitNot, t1> -> unary "mvn" t1
126
127 | <OFFSET, t1, <CONST n>> when fits_add n ->
128 (* Allow add for negative constants *)
129 let v1 = e_reg t1 anyreg in
130 gen_reg "add" [r; v1; Const n]
131 | <OFFSET, t1, t2> -> binary "add" t1 t2
132
133 | <BINOP Plus, t1, t2> -> binary "add" t1 t2
134 | <BINOP Minus, t1, t2> -> binary "sub" t1 t2
135 | <BINOP And, t1, t2> -> binary "and" t1 t2
136 | <BINOP Or, t1, t2> -> binary "orr" t1 t2
137 | <BINOP Lsl, t1, t2> -> binary "lsl" t1 t2
138 | <BINOP Lsr, t1, t2> -> binary "lsr" t1 t2
139 | <BINOP Asr, t1, t2> -> binary "asr" t1 t2
140 | <BINOP BitAnd, t1, t2> -> binary "and" t1 t2
141 | <BINOP BitOr, t1, t2> -> binary "orr" t1 t2
142
143 | <BINOP Times, t1, t2> ->
144 (* The mul instruction needs both operands in registers *)
145 let v1 = e_reg t1 anyreg in
146 let v2 = e_reg t2 anyreg in
147 gen_reg "mul" [r; v1; v2]
148
149 | <BINOP Eq, t1, t2> -> compare "moveq" t1 t2
150 | <BINOP Neq, t1, t2> -> compare "movne" t1 t2
151 | <BINOP Gt, t1, t2> -> compare "movgt" t1 t2
152 | <BINOP Geq, t1, t2> -> compare "movge" t1 t2
153 | <BINOP Lt, t1, t2> -> compare "movlt" t1 t2
154 | <BINOP Leq, t1, t2> -> compare "movle" t1 t2
155
156 | <BOUND, t1, t2> ->
157 let v1 = e_reg t1 r in
158 let v2 = e_rand t2 in
159 release v2;
160 emit "cmp" [v1; v2];
161 emit "seths" [Register (R 0); Const !line];
162 emit "blhs" [Global "check"];
163 v1
164
165 | <NCHECK, t1> ->
166 let v1 = e_reg t1 r in
167 emit "cmp" [v1; Const 0];
168 emit "seteq" [Register (R 0); Const !line];
169 emit "bleq" [Global "nullcheck"];
170 v1
171
172 | <w, @args> ->
173 failwith (sprintf "eval $" [fInst w])
174
175 (* |e_rand| -- evaluate to form second operand *)
176 and e_rand =
177 (* returns |Const| or |Register| *)
178 function
179 <CONST k> when fits_immed k -> Const k
180 | t -> e_reg t anyreg
181
182 (* |e_addr| -- evaluate to form an address for ldr or str *)
183 and e_addr =
184 (* returns |Index| *)
185 function
186 <LOCAL n> when fits_offset n ->
187 Index (R_fp, n)
188 | <OFFSET, t1, <CONST n>> when fits_offset n ->
189 let v1 = e_reg t1 anyreg in
190 Index (reg_of v1, n)
191 | t ->
192 let v1 = e_reg t anyreg in
193 Index (reg_of v1, 0)
194
195 (* |e_call| -- execute procedure call *)
196 let e_call =
197 function
198 <GLOBAL f> ->
199 gen "bl" [Global f]
200 | t ->
201 let v1 = e_reg t anyreg in
202 gen "blx" [v1]
203
204 (* |e_stmt| -- generate code to execute a statement *)
205 let e_stmt t =
206
207 (* Conditional jump *)
208 let condj op lab t1 t2 =
209 let v1 = e_reg t1 anyreg in
210 let v2 = e_rand t2 in
211 gen "cmp" [v1; v2];
212 gen op [Label lab] in
213
214 (* Procedure call *)
215 let call t =
216 spill_temps volatile; (* Spill any remaining temps *)
217 e_call t; (* Call the function *)
218 List.iter (function r -> (* Release argument registers *)
219 if not (is_free r) then release_reg r) volatile in
220
221 match t with
222 <PCALL k, t1> ->
223 call t1
224
225 | <DEFTMP n, <PCALL k, t1>> ->
226 call t1;
227 reserve_reg (R 0);
228 Regs.def_temp n (R 0)
229
230 | <DEFTMP n, t1> ->
231 let v1 = e_reg t1 anytemp in
232 Regs.def_temp n (reg_of v1)
233
234 | <(STOREW|STOREC), t1, <REGVAR i>> ->
235 let rv = List.nth stable i in
236 release (e_reg t1 (Register rv))
237 | <STOREW, t1, t2> ->
238 let v1 = e_reg t1 anyreg in
239 let v2 = e_addr t2 in
240 gen "str" [v1; v2]
241 | <STOREC, t1, t2> ->
242 let v1 = e_reg t1 anyreg in
243 let v2 = e_addr t2 in
244 gen "strb" [v1; v2]
245
246 | <RESULTW, t1> ->
247 release (e_reg t1 (Register (R 0)))
248
249 | <LABEL lab> -> emit_lab lab
250
251 | <JUMP lab> -> gen "b" [Label lab]
252
253 | <JUMPC (Eq, lab), t1, t2> -> condj "beq" lab t1 t2
254 | <JUMPC (Lt, lab), t1, t2> -> condj "blt" lab t1 t2
255 | <JUMPC (Gt, lab), t1, t2> -> condj "bgt" lab t1 t2
256 | <JUMPC (Leq, lab), t1, t2> -> condj "ble" lab t1 t2
257 | <JUMPC (Geq, lab), t1, t2> -> condj "bge" lab t1 t2
258 | <JUMPC (Neq, lab), t1, t2> -> condj "bne" lab t1 t2
259
260 | <JCASE (table, deflab), t1> ->
261 (* This jump table code exploits the fact that on ARM, reading
262 the pc gives a value 8 bytes beyond the current instruction,
263 so in the ldrlo instruction below, pc points to the branch
264 table itself. *)
265 let v1 = e_reg t1 anyreg in
266 emit "cmp" [v1; Const (List.length table)];
267 gen "ldrlo" [Register R_pc; Index2 (R_pc, reg_of v1, 2)];
268 gen "b" [Label deflab];
269 List.iter (fun lab -> emit ".word" [Label lab]) table
270
271 | <ARG i, <TEMP k>> when i < 4 ->
272 (* Avoid annoying spill and reload if the value is a temp
273 already in the correct register: e.g. in f(g(x)). *)
274 let r = R i in
275 let r1 = Regs.use_temp k in
276 spill_temps [r];
277 ignore (gen_move (Register r) (Register r1))
278 | <ARG i, t1> when i < 4 ->
279 let r = R i in
280 spill_temps [r];
281 ignore (e_reg t1 (Register r))
282 | <ARG i, t1> when i >= 4 ->
283 need_stack (4*i-12);
284 let v1 = e_reg t1 anyreg in
285 gen "str" [v1; Index (R_sp, 4*i-16)]
286
287 | <SLINK, <CONST 0>> -> ()
288 | <SLINK, t1> ->
289 let r = R 10 in
290 spill_temps [r];
291 ignore (e_reg t1 (Register r))
292
293 | <w, @ts> ->
294 failwith (sprintf "e_stmt $" [fInst w])
295
296 (* |process| -- generate code for a statement, or note a line number *)
297 let process =
298 function
299 <LINE n> ->
300 if !line <> n then
301 emit_comment (Source.get_line n);
302 line := n
303 | t ->
304 if !debug > 0 then emit_tree t;
305 e_stmt t;
306 if !debug > 1 then emit_comment (Regs.dump_regs ())
307
308 (* |translate| -- translate a procedure body *)
309 let translate lab nargs fsize nregv code =
310 Target.start_proc lab nargs fsize;
311 Regs.get_regvars nregv;
312 (try List.iter process code with exc ->
313 (* Code generation failed, but let's see how far we got *)
314 Target.flush_proc (); raise exc);
315 Target.end_proc ()