diff 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
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab4/tran.ml	Thu Oct 05 08:04:15 2017 +0100
@@ -0,0 +1,315 @@
+(* lab4/tran.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Optree
+open Target
+open Regs
+open Print
+
+let debug = ref 0
+
+(* |release| -- release any register used by a value *)
+let release =
+  function
+      Register reg -> release_reg reg
+    | Index (reg, off) -> release_reg reg
+    | Index2 (r1, r2, n) -> release_reg r1; release_reg r2
+    | _ -> ()
+
+let fix_reg r = Register (get_reg (reg_of r))
+
+(* |gen_reg| -- emit instruction with result in a register *)
+let gen_reg op rands =
+  List.iter release (List.tl rands);
+  let r' = fix_reg (List.hd rands) in
+  emit op (r' :: List.tl rands);
+  r'
+
+(* |gen| -- emit an instruction *)
+let gen op rands =
+  List.iter release rands;
+  emit op rands
+
+(* |gen_move| -- move value to specific register *)
+let gen_move dst src =
+  if reg_of dst = R_any || reg_of dst = R_temp || dst = src then
+    src
+  else
+    gen_reg "mov" [dst; src]
+
+
+(* Tests for fitting in various immediate fields *)
+
+(* |fits_offset| -- test for fitting in offset field of address *)
+let fits_offset x = (-4096 < x && x < 4096)
+
+(* |fits_immed| -- test for fitting in immediate field *)
+let fits_immed x =
+  (* A conservative approximation, using shifts instead of rotates *)
+  let rec reduce r =
+    if r land 3 <> 0 then r else reduce (r lsr 2) in
+  x = 0 || x > 0 && reduce x < 256
+
+(* |fits_move| -- test for fitting in immediate move *)
+let fits_move x = fits_immed x || fits_immed (lnot x)
+
+(* |fits_add| -- test for fitting in immediate add *)
+let fits_add x = fits_immed x || fits_immed (-x)
+
+(* |line| -- current line number *)
+let line = ref 0
+
+(* The main part of the code generator consists of a family of functions
+   e_X t, each generating code for a tree t, leaving the value in
+   a register, or as an operand for another instruction, etc. *)
+
+let anyreg = Register R_any
+let anytemp = Register R_temp
+
+(* |e_reg| -- evaluate expression with result in specified register *)
+let rec e_reg t r =
+  (* returns |Register| *)
+
+  (* Binary operation *)
+  let binary op t1 t2 =
+    let v1 = e_reg t1 anyreg in
+    let v2 = e_rand t2 in
+    gen_reg op [r; v1; v2]
+
+  (* Unary operation *)
+  and unary op t1 =
+    let v1 = e_reg t1 anyreg in
+    gen_reg op [r; v1]
+
+  (* Comparison with boolean result *)
+  and compare op t1 t2 =
+    let v1 = e_reg t1 anyreg in
+    let v2 = e_rand t2 in
+    release v1; release v2;
+    let rr = fix_reg r in
+    emit "cmp" [v1; v2];
+    emit "mov" [rr; Const 0];
+    emit op [rr; Const 1];
+    rr in
+
+  match t with
+      <CONST k> when fits_move k -> 
+        gen_reg "mov" [r; Const k]
+    | <CONST k> ->
+        gen_reg "set" [r; Const k]
+    | <LOCAL 0> ->
+        gen_move r (Register R_fp)
+    | <LOCAL n> when fits_add n ->
+        gen_reg "add" [r; Register R_fp; Const n]
+    | <LOCAL n> ->
+        emit "set" [Register R_ip; Const n];
+        gen_reg "add" [r; Register R_fp; Register R_ip]
+    | <GLOBAL x> ->
+        gen_reg "set" [r; Global x]
+    | <TEMP n> ->
+        gen_move r (Register (Regs.use_temp n))
+    | <(LOADW|LOADC), <REGVAR i>> ->
+        let rv = List.nth stable i in
+        reserve_reg rv; gen_move r (Register rv)
+    | <LOADW, t1> -> 
+        let v1 = e_addr t1 in
+        gen_reg "ldr" [r; v1]
+    | <LOADC, t1> -> 
+        let v1 = e_addr t1 in
+        gen_reg "ldrb" [r; v1]
+
+    | <MONOP Uminus, t1> -> unary "neg" t1
+    | <MONOP Not, t1> -> 
+        let v1 = e_reg t1 anyreg in
+        gen_reg "eor" [r; v1; Const 1]
+    | <MONOP BitNot, t1> -> unary "mvn" t1
+
+    | <OFFSET, t1, <CONST n>> when fits_add n ->
+        (* Allow add for negative constants *)
+        let v1 = e_reg t1 anyreg in
+        gen_reg "add" [r; v1; Const n]
+    | <OFFSET, t1, t2> -> binary "add" t1 t2
+
+    | <BINOP Plus, t1, t2> -> binary "add" t1 t2
+    | <BINOP Minus, t1, t2> -> binary "sub" t1 t2
+    | <BINOP And, t1, t2> -> binary "and" t1 t2
+    | <BINOP Or, t1, t2> -> binary "orr" t1 t2
+    | <BINOP Lsl, t1, t2> -> binary "lsl" t1 t2
+    | <BINOP Lsr, t1, t2> -> binary "lsr" t1 t2
+    | <BINOP Asr, t1, t2> -> binary "asr" t1 t2
+    | <BINOP BitAnd, t1, t2> -> binary "and" t1 t2
+    | <BINOP BitOr, t1, t2> -> binary "orr" t1 t2
+
+    | <BINOP Times, t1, t2> ->
+        (* The mul instruction needs both operands in registers *)
+        let v1 = e_reg t1 anyreg in
+        let v2 = e_reg t2 anyreg in
+        gen_reg "mul" [r; v1; v2]
+
+    | <BINOP Eq, t1, t2> -> compare "moveq" t1 t2
+    | <BINOP Neq, t1, t2> -> compare "movne" t1 t2
+    | <BINOP Gt, t1, t2> -> compare "movgt" t1 t2
+    | <BINOP Geq, t1, t2> -> compare "movge" t1 t2
+    | <BINOP Lt, t1, t2> -> compare "movlt" t1 t2
+    | <BINOP Leq, t1, t2> -> compare "movle" t1 t2
+
+    | <BOUND, t1, t2> ->
+        let v1 = e_reg t1 r in
+        let v2 = e_rand t2 in
+        release v2;
+        emit "cmp" [v1; v2];
+        emit "seths" [Register (R 0); Const !line];
+        emit "blhs" [Global "check"];
+        v1
+
+    | <NCHECK, t1> ->
+        let v1 = e_reg t1 r in
+        emit "cmp" [v1; Const 0];
+        emit "seteq" [Register (R 0); Const !line];
+        emit "bleq" [Global "nullcheck"];
+        v1
+
+    | <w, @args> ->
+        failwith (sprintf "eval $" [fInst w])
+
+(* |e_rand| -- evaluate to form second operand *)
+and e_rand =
+  (* returns |Const| or |Register| *)
+  function
+      <CONST k> when fits_immed k -> Const k
+    | t -> e_reg t anyreg
+
+(* |e_addr| -- evaluate to form an address for ldr or str *)
+and e_addr =
+  (* returns |Index| *)
+  function
+      <LOCAL n> when fits_offset n ->
+        Index (R_fp, n) 
+    | <OFFSET, t1, <CONST n>> when fits_offset n ->
+        let v1 = e_reg t1 anyreg in
+        Index (reg_of v1, n)
+    | t ->
+        let v1 = e_reg t anyreg in
+        Index (reg_of v1, 0)
+
+(* |e_call| -- execute procedure call *)
+let e_call =
+  function
+      <GLOBAL f> -> 
+        gen "bl" [Global f]
+    | t -> 
+        let v1 = e_reg t anyreg in
+        gen "blx" [v1]
+
+(* |e_stmt| -- generate code to execute a statement *)
+let e_stmt t =
+
+  (* Conditional jump *)
+  let condj op lab t1 t2 =
+    let v1 = e_reg t1 anyreg in
+    let v2 = e_rand t2 in
+    gen "cmp" [v1; v2];
+    gen op [Label lab] in
+
+  (* Procedure call *)
+  let call t =
+    spill_temps volatile;     (* Spill any remaining temps *)
+    e_call t;                 (* Call the function *)
+    List.iter (function r ->  (* Release argument registers *)
+      if not (is_free r) then release_reg r) volatile in
+
+  match t with
+      <PCALL k, t1> -> 
+        call t1
+
+    | <DEFTMP n, <PCALL k, t1>> ->
+        call t1;
+        reserve_reg (R 0); 
+        Regs.def_temp n (R 0)
+
+    | <DEFTMP n, t1> ->
+        let v1 = e_reg t1 anytemp in
+        Regs.def_temp n (reg_of v1)
+
+    | <(STOREW|STOREC), t1, <REGVAR i>> ->
+        let rv = List.nth stable i in
+        release (e_reg t1 (Register rv))
+    | <STOREW, t1, t2> -> 
+        let v1 = e_reg t1 anyreg in
+        let v2 = e_addr t2 in
+        gen "str" [v1; v2]
+    | <STOREC, t1, t2> -> 
+        let v1 = e_reg t1 anyreg in
+        let v2 = e_addr t2 in
+        gen "strb" [v1; v2]
+
+    | <RESULTW, t1> ->
+        release (e_reg t1 (Register (R 0)))
+
+    | <LABEL lab> -> emit_lab lab
+
+    | <JUMP lab> -> gen "b" [Label lab]
+
+    | <JUMPC (Eq, lab), t1, t2> -> condj "beq" lab t1 t2
+    | <JUMPC (Lt, lab), t1, t2> -> condj "blt" lab t1 t2
+    | <JUMPC (Gt, lab), t1, t2> -> condj "bgt" lab t1 t2
+    | <JUMPC (Leq, lab), t1, t2> -> condj "ble" lab t1 t2
+    | <JUMPC (Geq, lab), t1, t2> -> condj "bge" lab t1 t2
+    | <JUMPC (Neq, lab), t1, t2> -> condj "bne" lab t1 t2
+
+    | <JCASE (table, deflab), t1> ->
+        (* This jump table code exploits the fact that on ARM, reading
+           the pc gives a value 8 bytes beyond the current instruction,
+           so in the ldrlo instruction below, pc points to the branch
+           table itself. *)
+        let v1 = e_reg t1 anyreg in
+        emit "cmp" [v1; Const (List.length table)];
+        gen "ldrlo" [Register R_pc; Index2 (R_pc, reg_of v1, 2)];
+        gen "b" [Label deflab];
+        List.iter (fun lab -> emit ".word" [Label lab]) table
+
+    | <ARG i, <TEMP k>> when i < 4 ->
+        (* Avoid annoying spill and reload if the value is a temp
+           already in the correct register: e.g. in f(g(x)). *)
+        let r = R i in
+        let r1 = Regs.use_temp k in
+        spill_temps [r];
+        ignore (gen_move (Register r) (Register r1))
+    | <ARG i, t1> when i < 4 ->
+        let r = R i in
+        spill_temps [r];
+        ignore (e_reg t1 (Register r))
+    | <ARG i, t1> when i >= 4 ->
+        need_stack (4*i-12);
+        let v1 = e_reg t1 anyreg in
+        gen "str" [v1; Index (R_sp, 4*i-16)]
+
+    | <SLINK, <CONST 0>> -> ()
+    | <SLINK, t1> ->
+        let r = R 10 in
+        spill_temps [r];
+        ignore (e_reg t1 (Register r))
+
+    | <w, @ts> -> 
+        failwith (sprintf "e_stmt $" [fInst w])
+
+(* |process| -- generate code for a statement, or note a line number *)
+let process =
+  function
+      <LINE n> ->
+        if !line <> n then
+          emit_comment (Source.get_line n);
+        line := n
+    | t ->
+        if !debug > 0 then emit_tree t;
+        e_stmt t;
+        if !debug > 1 then emit_comment (Regs.dump_regs ())
+
+(* |translate| -- translate a procedure body *)
+let translate lab nargs fsize nregv code =
+  Target.start_proc lab nargs fsize;
+  Regs.get_regvars nregv;
+  (try List.iter process code with exc -> 
+    (* Code generation failed, but let's see how far we got *)
+    Target.flush_proc (); raise exc);
+  Target.end_proc ()