Permalink
Browse files

simpler register allocations

  • Loading branch information...
1 parent c4f7a59 commit 502684873ec3b50d7c204fd60bd9b1010f267179 sumii committed Oct 20, 2005
Showing with 869 additions and 7 deletions.
  1. +5 −5 Makefile
  2. +167 −0 regAlloc.notarget-nospill.ml
  3. +262 −0 regAlloc.target-earlyspill.ml
  4. +228 −0 regAlloc.target-latespill.ml
  5. +205 −0 regAlloc.target-nospill.ml
  6. +2 −2 sparcAsm.ml
View
@@ -1,16 +1,16 @@
# Sumii's Makefile for Min-Caml (for GNU Make)
-
+#
# ack.mlなどのテストプログラムをtest/に用意してmake do_testを実行すると、
# min-camlとocamlでコンパイル・実行した結果を自動で比較します。
-default: debug-code top native-code do_test
-clean:: nobackup
-
RESULT = min-caml
NCSUFFIX = .opt
CC = gcc
CFLAGS = -g -O2 -Wall
+default: debug-code top native-code do_test
+clean:: nobackup
+
# ↓もし実装を改造したら、それに合わせて変える
SOURCES = float.c type.ml id.ml m.ml s.ml \
syntax.ml parser.mly lexer.mll typing.mli typing.ml kNormal.mli kNormal.ml \
@@ -30,7 +30,7 @@ do_test: $(TESTS:%=test/%.cmp)
.PRECIOUS: test/%.s test/% test/%.res test/%.ans test/%.cmp
TRASH = $(TESTS:%=test/%.s) $(TESTS:%=test/%) $(TESTS:%=test/%.res) $(TESTS:%=test/%.ans) $(TESTS:%=test/%.cmp)
-test/%.s: debug-code test/%.ml
+test/%.s: debug-code test/%.ml # [X] debug-codeはファイルではないので、何度でも実行されてしまう!
./$(RESULT) test/$*
test/%: test/%.s libmincaml.s stub.c
$(CC) $(CFLAGS) $^ -lm -o $@
@@ -0,0 +1,167 @@
+open SparcAsm
+
+let rec alloc cont regenv all x =
+ (* allocate a register or spill a variable *)
+ assert (not (M.mem x regenv));
+ if all = ["%g0"] then "%g0" else (* [XX] ad hoc optimization *)
+ if is_reg x then x else
+ let free = fv cont in
+ try
+ let live = (* 生きているレジスタ *)
+ List.fold_left
+ (fun live y ->
+ if is_reg y then S.add y live else
+ try S.add (M.find y regenv) live
+ with Not_found -> live)
+ S.empty
+ free in
+ let r = (* そうでないレジスタを探す *)
+ List.find
+ (fun r -> not (S.mem r live))
+ all in
+ (* Format.eprintf "allocated %s to %s@." x r; *)
+ r
+ with Not_found ->
+ failwith (Printf.sprintf "register allocation failed for %s" x)
+
+(* auxiliary function for g and g'_and_restore *)
+let add x r regenv =
+ if is_reg x then (assert (x = r); regenv) else
+ M.add x r regenv
+
+(* auxiliary functions for g' *)
+exception NoReg of Id.t * Type.t
+let find x t regenv =
+ if is_reg x then x else
+ try M.find x regenv
+ with Not_found -> raise (NoReg(x, t))
+let find' x' regenv =
+ match x' with
+ | V(x) -> V(find x Type.Int regenv)
+ | c -> c
+
+let rec g dest cont regenv = function (* 命令列のレジスタ割り当て (caml2html: regalloc_g) *)
+ | Ans(exp) -> g'_and_restore dest cont regenv exp
+ | Let((x, t) as xt, exp, e) ->
+ assert (not (M.mem x regenv));
+ let cont' = concat e dest cont in
+ let (e1', regenv1) = g'_and_restore xt cont' regenv exp in
+ let all =
+ match t with
+ | Type.Unit -> ["%g0"] (* dummy *)
+ | Type.Float -> allfregs
+ | _ -> allregs in
+ let r = alloc cont' regenv1 all x in
+ let (e2', regenv2) = g dest cont (add x r regenv1) e in
+ (concat e1' (r, t) e2', regenv2)
+ | Forget(x, e) -> assert false
+and g'_and_restore dest cont regenv exp = (* 使用される変数をスタックからレジスタへRestore (caml2html: regalloc_unspill) *)
+ try g' dest cont regenv exp
+ with NoReg(x, t) ->
+ (* Format.eprintf "unspilling %s@." x; *)
+ let cont' = Let(dest, exp, cont) in
+ let all =
+ match t with
+ | Type.Unit -> assert false
+ | Type.Float -> allfregs
+ | _ -> allregs in
+ let r = alloc cont' regenv all x in
+ let (e1', regenv1) = g'_and_restore dest cont (add x r regenv) exp in
+ (Let((r, t), Restore(x), e1'), regenv1)
+and g' dest cont regenv = function (* 各命令のレジスタ割り当て (caml2html: regalloc_gprime) *)
+ | Nop | Set _ | SetL _ | Comment _ | Restore _ as exp -> (Ans(exp), regenv)
+ | Mov(x) -> (Ans(Mov(find x Type.Int regenv)), regenv)
+ | Neg(x) -> (Ans(Neg(find x Type.Int regenv)), regenv)
+ | Add(x, y') -> (Ans(Add(find x Type.Int regenv, find' y' regenv)), regenv)
+ | Sub(x, y') -> (Ans(Sub(find x Type.Int regenv, find' y' regenv)), regenv)
+ | SLL(x, y') -> (Ans(SLL(find x Type.Int regenv, find' y' regenv)), regenv)
+ | Ld(x, y') -> (Ans(Ld(find x Type.Int regenv, find' y' regenv)), regenv)
+ | St(x, y, z') -> (Ans(St(find x Type.Int regenv, find y Type.Int regenv, find' z' regenv)), regenv)
+ | FMovD(x) -> (Ans(FMovD(find x Type.Float regenv)), regenv)
+ | FNegD(x) -> (Ans(FNegD(find x Type.Float regenv)), regenv)
+ | FAddD(x, y) -> (Ans(FAddD(find x Type.Float regenv, find y Type.Float regenv)), regenv)
+ | FSubD(x, y) -> (Ans(FSubD(find x Type.Float regenv, find y Type.Float regenv)), regenv)
+ | FMulD(x, y) -> (Ans(FMulD(find x Type.Float regenv, find y Type.Float regenv)), regenv)
+ | FDivD(x, y) -> (Ans(FDivD(find x Type.Float regenv, find y Type.Float regenv)), regenv)
+ | LdDF(x, y') -> (Ans(LdDF(find x Type.Int regenv, find' y' regenv)), regenv)
+ | StDF(x, y, z') -> (Ans(StDF(find x Type.Float regenv, find y Type.Int regenv, find' z' regenv)), regenv)
+ | IfEq(x, y', e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfEq(find x Type.Int regenv, find' y' regenv, e1', e2')) e1 e2
+ | IfLE(x, y', e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfLE(find x Type.Int regenv, find' y' regenv, e1', e2')) e1 e2
+ | IfGE(x, y', e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfGE(find x Type.Int regenv, find' y' regenv, e1', e2')) e1 e2
+ | IfFEq(x, y, e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfFEq(find x Type.Float regenv, find y Type.Float regenv, e1', e2')) e1 e2
+ | IfFLE(x, y, e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfFLE(find x Type.Float regenv, find y Type.Float regenv, e1', e2')) e1 e2
+ | CallCls(x, ys, zs) as exp -> g'_call dest cont regenv exp (fun ys zs -> CallCls(find x Type.Int regenv, ys, zs)) ys zs
+ | CallDir(l, ys, zs) as exp -> g'_call dest cont regenv exp (fun ys zs -> CallDir(l, ys, zs)) ys zs
+ | Save(x, y) -> assert false
+and g'_if dest cont regenv exp constr e1 e2 = (* ifのレジスタ割り当て (caml2html: regalloc_if) *)
+ let (e1', regenv1) = g dest cont regenv e1 in
+ let (e2', regenv2) = g dest cont regenv e2 in
+ let regenv' = (* 両方に共通のレジスタ変数だけ利用 *)
+ List.fold_left
+ (fun regenv' x ->
+ try
+ if is_reg x then regenv' else
+ let r1 = M.find x regenv1 in
+ let r2 = M.find x regenv2 in
+ if r1 <> r2 then regenv' else
+ M.add x r1 regenv'
+ with Not_found -> regenv')
+ M.empty
+ (fv cont) in
+ (List.fold_left
+ (fun e x ->
+ if is_reg x || x = fst dest || not (M.mem x regenv) || M.mem x regenv' then e else
+ seq(Save(M.find x regenv, x), e)) (* そうでない変数は分岐直前にセーブ *)
+ (Ans(constr e1' e2'))
+ (fv cont),
+ regenv')
+and g'_call dest cont regenv exp constr ys zs = (* 関数呼び出しのレジスタ割り当て (caml2html: regalloc_call) *)
+ let xs =
+ List.filter (* セーブすべきレジスタ変数を探す *)
+ (fun x -> not (is_reg x) && x <> fst dest)
+ (fv cont) in
+ (List.fold_left
+ (fun e x ->
+ if is_reg x || x = fst dest || not (M.mem x regenv) then e else
+ seq(Save(M.find x regenv, x), e))
+ (Ans(constr
+ (List.map (fun y -> find y Type.Int regenv) ys)
+ (List.map (fun z -> find z Type.Float regenv) zs)))
+ xs,
+ M.empty)
+
+let h { name = Id.L(x); args = ys; fargs = zs; body = e; ret = t } = (* 関数のレジスタ割り当て (caml2html: regalloc_h) *)
+ let regenv = M.add x reg_cl M.empty in
+ let (i, arg_regs, regenv) =
+ List.fold_left
+ (fun (i, arg_regs, regenv) y ->
+ let r = regs.(i) in
+ (i + 1,
+ arg_regs @ [r],
+ (assert (not (is_reg y));
+ M.add y r regenv)))
+ (0, [], regenv)
+ ys in
+ let (d, farg_regs, regenv) =
+ List.fold_left
+ (fun (d, farg_regs, regenv) z ->
+ let fr = fregs.(d) in
+ (d + 1,
+ farg_regs @ [fr],
+ (assert (not (is_reg z));
+ M.add z fr regenv)))
+ (0, [], regenv)
+ zs in
+ let a =
+ match t with
+ | Type.Unit -> Id.gentmp Type.Unit
+ | Type.Float -> fregs.(0)
+ | _ -> regs.(0) in
+ let (e', regenv') = g (a, t) (Ans(Nop)) regenv e in
+ { name = Id.L(x); args = arg_regs; fargs = farg_regs; body = e'; ret = t }
+
+let f (Prog(data, fundefs, e)) = (* プログラム全体のレジスタ割り当て (caml2html: regalloc_f) *)
+ Format.eprintf "register allocation: may take some time (up to a few minutes, depending on the size of functions)@.";
+ let fundefs' = List.map h fundefs in
+ let e', regenv' = g (Id.gentmp Type.Unit, Type.Unit) (Ans(Nop)) M.empty e in
+ Prog(data, fundefs', e')
Oops, something went wrong.

0 comments on commit 5026848

Please sign in to comment.