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