diff options
| -rw-r--r-- | lo2.ml | 193 |
1 files changed, 178 insertions, 15 deletions
diff --git a/lo2.ml b/lo2.ml index a6f8519..e004151 100644 --- a/lo2.ml +++ b/lo2.ml @@ -2,7 +2,7 @@ type uop = Neg type bop = Add | Sub | CLe | CEq type bref = int (* Block references. *) -type 'op seqi = [ `Nop | `Uop of uop * 'op | `Bop of 'op * bop * 'op ] +type 'op seqi = [ `Con of int | `Uop of uop * 'op | `Bop of 'op * bop * 'op ] type 'op jmpi = [ `Brz of 'op * bref * bref | `Jmp of bref ] type ('ins, 'phi, 'jmp) bb = @@ -27,6 +27,7 @@ let liveout lh ir = let livein lh p ir = let gen (b, i) = IRSet.of_list begin let {bb_inss; bb_jmp; _} = p.(b) in + if i = -1 then [] else if i = Array.length bb_inss then match bb_jmp with | `Brz (i1, _, _) -> [i1] @@ -34,11 +35,17 @@ let livein lh p ir = else match bb_inss.(i) with | `Uop (_, i1) -> [i1] | `Bop (i1, _, i2) -> [i1; i2] - | `Nop -> [] + | `Con _ -> [] end in + let kill ((b, i) as ir) = + if i >= 0 then IRSet.singleton (IRIns ir) else + fst (Array.fold_left + (fun (k, i) _ -> (IRSet.add (IRPhi (b, i)) k, i+1)) + (IRSet.empty, 0) p.(b).bb_phis + ) in let s = liveout lh ir in let s = IRSet.union s (gen ir) in - IRSet.remove (IRIns ir) s + IRSet.diff s (kill ir) let liveness (p: iprog) = let module H = Hashtbl in @@ -52,18 +59,18 @@ let liveness (p: iprog) = H.replace lh ir' (IRSet.add ir lir'); end in let succs (b, i) = (* Successor nodes of an instruction. *) - let bb = {bb_inss; bb_jmp; _} in + let {bb_inss; bb_jmp; _} = p.(b) in if i = Array.length bb_inss then if b+1 = nbb then [] else match bb_jmp with - | `Brz (_, b1, b2) -> [(b1, 0); (b2, 0)] - | `Jmp b1 -> [(b1, 0)] + | `Brz (_, b1, b2) -> [(b1, -1); (b2, -1)] + | `Jmp b1 -> [(b1, -1)] else [(b, i+1)] in while !changed do changed := false; for b = nbb - 1 downto 0 do let bb = p.(b) in - for i = Array.length bb.bb_inss downto 0 do + for i = Array.length bb.bb_inss downto -1 do let ir = (b, i) in let live = List.fold_left (fun live ir' -> IRSet.union live (livein lh p ir') @@ -75,8 +82,7 @@ let liveness (p: iprog) = | IRPhi (b, _) | IRIns (b, _) -> b in List.iter (fun ir -> let br = blk ir in - let bb = p.(br) in - setlive ir (br, Array.length bb.bb_inss) + setlive ir (br, Array.length p.(br).bb_inss) ) il ) bb.bb_phis; done @@ -90,29 +96,186 @@ type 'op rins = { ri_res: 'op; ri_ins: [ 'op seqi | `Mov of 'op ] } type 'op rphi = { rp_res: 'op; rp_list: (bref * loc) list } type rprog = (loc rins, loc rphi, loc jmpi) bb array - let regalloc nr (p: iprog) = - let module H = Hashtbl in + let module H = struct + include Hashtbl + let find h ir = try find h ir with Not_found -> LVoid + end in + let lh = liveness p in let nbb = Array.length p in - let bbmaps = Array.create nbb [] in let rp = Array.init nbb (fun i -> { bb_name = p.(i).bb_name ; bb_phis = [| |] ; bb_inss = [| |] - ; bb_jmp = `Jmp -1 + ; bb_jmp = `Jmp (-1) } ) in + let outmaps = Array.make nbb [] in + let phimaps = Array.make nbb [| |] in let bb = ref [] in (* Basic block in construction. *) let emiti l i = bb := {ri_res=l; ri_ins=i} :: !bb in - let m = H.create 101 in (* The map from iref to locations. *) + let act = H.create 101 in (* The active list. *) + let free = ref [0;1;2;3;4;5;6;7;8;9] in (* Free registers. *) + + let nspill = ref 0 in + let newspill () = incr nspill; !nspill - 1 in + let getspill ir = + match H.find act ir with + | LSpill s -> s + | _ -> -1 in + + let kill ir = + match H.find act ir with + | LReg r -> H.remove act ir; free := r :: !free + | _ -> () in + + let loc ir = + match H.find act ir with + | LVoid -> + let l = + match !free with + | r :: f -> free := f; LReg r + | [] -> LSpill (newspill ()) (* Here we can try to spill the longer range instead. *) + in + H.add act ir l; l + | l -> l in + for b = nbb - 1 downto 0 do - (* At the end, spill everyting not in liveout of the predecessor block. *) + let bi = p.(b).bb_inss in + let bl = Array.length bi in + + (* Fill outmaps with the allocation state at + * the end of the block (after the final branch). + * Invariant 1: everything in registers is live. + *) + + let lvout = liveout lh (b, bl) in + IRSet.iter (fun ir -> ignore (loc ir)) lvout; + outmaps.(b) <- begin + H.fold (fun ir l m -> + if IRSet.mem ir lvout + then (ir, l) :: m + else m + ) act [] + end; + + let jmp = + match p.(b).bb_jmp with + | `Jmp br -> `Jmp br + | `Brz (ir, br1, br2) -> `Brz (loc ir, br1, br2) in + rp.(b).bb_jmp <- jmp; + + for i = bl - 1 downto 0 do + let ir = IRIns (b, i) in + begin match H.find act ir with + | LVoid -> () (* Dead code. *) + | lir -> + kill ir; + begin match bi.(i) with + | `Con k -> + emiti lir (`Mov (LCon k)) + | `Uop (op, ir') -> + let lir' = loc ir' in + let spl = getspill ir in + if spl >= 0 && lir <> LSpill spl then + emiti (LSpill spl) (`Mov lir); + emiti lir (`Uop (op, lir')) + | `Bop (ir1, op, ir2) -> + let lir1 = loc ir1 in + let lir2 = loc ir2 in + let spl = getspill ir in + if spl >= 0 && lir <> LSpill spl then + emiti (LSpill spl) (`Mov lir); + emiti lir (`Bop (lir1, op, lir2)) + end + end + done; + + phimaps.(b) <- begin + Array.init (Array.length p.(b).bb_phis) (fun p -> + let pr = IRPhi (b, p) in + let ploc = H.find act pr in + kill pr; ploc + ) + end; + + (* Spill everyting not in liveout of the predecessor block. + * Remove them from the active list (ensures Invariant 1). + *) + + let lvout = + if b = 0 then IRSet.empty else + liveout lh (b-1, Array.length p.(b-1).bb_inss) in + let spl = H.fold (fun ir l s -> + match l with + | LReg r -> + if IRSet.mem ir lvout then s else (ir, r) :: s + | _ -> s + ) act [] in + List.iter (fun (ir, r) -> + let spl = LSpill (newspill ()) in + free := r :: !free; + H.replace act ir spl; + emiti (LReg r) (`Mov spl) + ) spl; + rp.(b).bb_inss <- Array.of_list !bb; bb := []; done; + + (* Compute phis. *) + for b = 0 to nbb - 1 do + rp.(b).bb_phis <- begin + Array.mapi (fun i (`Phi l) -> + { rp_res = phimaps.(b).(i) + ; rp_list = List.map (function + | IRPhi (b, p) -> b, phimaps.(b).(i) + | IRIns (b, _) as ir -> (b, List.assoc ir outmaps.(b)) + ) l + } + ) p.(b).bb_phis + end + done; + rp +(* Facts + * There are little lifetime holes in SSA (caused by block ordering) + *) + + +(* Little tests. *) +let pbasic: iprog = + [| { bb_name = "start" + ; bb_phis = [| |] + ; bb_inss = + [| `Con 2 + ; `Con 3 + ; `Bop (IRIns (0, 0), Add, IRIns (0, 1)) + ; `Bop (IRIns (0, 0), Add, IRIns (0, 2)) + |] + ; bb_jmp = `Brz (IRIns (0, 3), -1, -1) + } + |] + +let pcount: iprog = + [| { bb_name = "init" + ; bb_phis = [||] + ; bb_inss = [| `Con 100; `Con 1 |] + ; bb_jmp = `Jmp 1 + } + ; { bb_name = "loop" + ; bb_phis = [| `Phi [IRIns (0, 0); IRIns (1, 0)] |] + ; bb_inss = [| `Bop (IRPhi (1, 0), Sub, IRIns (0, 1)) |] + ; bb_jmp = `Brz (IRIns (1, 0), 2, 1) + } + ; { bb_name = "end" + ; bb_phis = [||] + ; bb_inss = [| `Con 42 |] + ; bb_jmp = `Jmp (-1) + } + |] (* ** Phi resolution. ** *) (* Machine program, ready for code generation. *) |