let allocate_registers base_block lex_depth =
(** @param av list of available variables (list of definition and associated register) @param instr the instruction code should be generated for @param needed_defs definition of variables whose values are used in the rest of the block @returns a list of available variables after the instruction and a rewrite of the code *) |
let rec alloc_instr av instr needed_defs =
let av = ref av in
(** Mark a register as unused. *) |
let free_reg r =
av := List.filter (fun (_, r') -> r' <> r) !av
in
let free_var_reg v =
free_reg (get_var_reg v)
in
(** Declare that a variable is available in a register. If some other variable was previously declared as available in the same register, it won't be anymore. *) |
let set_available vd r =
(
try
if list_assoc_id vd !av = r then
raise Not_found
else
failwith "a variable has two locations in memory!";
with
| Not_found -> ()
);
free_reg r;
av := (vd, r) :: !av
in
(** Warning before and after are reversed at the end of the function! *) |
let before = ref []
and after = ref [] in
let do_before a =
before := a :: !before
in
let do_after a =
after := a :: !after
in
(** Debug. *) |
let dbg s = do_before (Code s) in
let during =
(** Spill a variable. *) |
let do_spill r vd =
vd.vd_on_the_stack := true;
match get_vd_type vd with
| Other _ -> ()
| _ -> do_before (Spill(get_vd_lex vd <> lex_depth, r, vd))
in
(** Unspill a variable. *) |
let do_unspill v =
match get_var_type v with
| Other _ -> do_before (Address_of(v, v)) (* TODO: this is not nice at all + we should determine if we're in the same lexical scope or not *)
| _ ->
(
match v.var_def.vd_value with
| Some _ ->
let v' = copy_var v in
v'.var_reg <- None;
do_before (Mov_i(v, v'));
| None ->
do_before (Unspill (get_var_lex v <> lex_depth, v))
)
in
(** Allocate a variable in a specific register. *) |
let alloc_in_reg v r occ =
v.var_reg <- Some r;
do_unspill (copy_var v); (* TODO: why copy var? *)
set_available v.var_def r
in
let rec get_fresh_reg occ =
(** Find an unused register. *) |
let rec find_free_int n =
if n >= nb_registers then raise Not_found
else if List.mem (Reg_int n) occ then
find_free_int (n + 1)
else if list_mem_assoc' (Reg_int n) !av then
find_free_int (n + 1)
else
Reg_int n
in
let rec find_to_spill_int n =
if n >= nb_registers then raise (Asm_error "no registers left during assembly generation")
else if List.mem (Reg_int n) occ then
find_to_spill_int (n + 1)
else
Reg_int n
in
try
find_free_int 0
with
| Not_found ->
let r = find_to_spill_int 0 in
let replaced_vd = list_assoc' r !av in
spill r replaced_vd occ; free_reg r; r
(** @return new occ *) |
and check_dependencies vd occ =
match get_vd_pos vd with
| Pos_arr(b, v, _, _) ->
assert_avail b occ;
if not (is_constant v) then
assert_avail v (get_var_reg b :: occ);
if is_constant v then
get_var_reg b :: occ
else
get_var_reg v :: get_var_reg b :: occ
| Pos_pointed p
| Pos_rec(p, _) ->
assert_avail p occ;
get_var_reg p :: occ
| _ -> occ
(** Allocate an integer register to the variable v .
@param occ is a list of already taken integer registers *) |
and alloc_reg v occ =
let occ = check_dependencies v.var_def occ in
let r = get_fresh_reg occ in
alloc_in_reg v r occ; r
(* TODO: if it's not needed anymore, don't spill it *)
(** @param occ is here to specify needed registers because we might need an extra register during the spill *) |
and spill r vd occ =
let occ = r :: (check_dependencies vd occ) in
set_vd_ots vd;
do_spill r vd (*;
free_reg r*)
(** If the variable is in a register then spill it. *) |
and spill_var v occ =
if not (is_constant v) then
check_avail v occ (fun l -> List.iter (fun r -> spill r v.var_def occ) l)
(** Make sure that a specific register is available. *) |
and spill_reg r occ =
List.iter (fun (vd, rd) -> if r = rd then spill rd vd occ) !av
(** If the variable v is available then we should execute f which will receive v 's register as argument else we should execute g . *) |
and on_avail v f g =
try
let r = list_assoc_id v.var_def !av in
f r
with
| Not_found -> g ()
and is_complicated v =
match get_var_pos v with
| Pos_rec _
| Pos_arr _
| Pos_pointed _ -> true
| Pos_label _
| Pos_stack _
| Pos_base _
| Pos_none -> false
(** If variable v already was in a register it stays in it. The function f is called with the list of used registers. *) |
and check_avail v occ f =
on_avail v
(fun r -> v.var_reg <- Some r; f [r])
(fun () ->
if get_var_lex v <> lex_depth || is_complicated v then
f [alloc_reg v occ]
else
(
if not (is_constant v) then set_var_ots v;
f []
)
)
(** If the variable is not yet in a register put it in some register. *) |
and assert_avail v occ =
check_avail v occ
(fun r ->
match r with
| [] -> ignore (alloc_reg v occ)
| _ -> ()
)
in
let spill_and_free_reg r occ =
spill_reg r occ; free_reg r
in
let spill_all () =
List.iter (fun (vd, r) -> spill r vd []) !av
in
let just_check_avail v occ =
check_avail v occ (fun _ -> ())
in
(**
Spill iff v is complicated.
*) |
let spill_complicated v occ =
if is_complicated v then
(
try
let r = get_var_reg v in
let vd = v.var_def in
let occ = check_dependencies vd occ in
do_after (Spill(get_vd_lex vd <> lex_depth, r, vd))
with
| Not_found -> failwith "ooops"
)
in
(* TODO: do not systematically free with spill_var! *)
match instr with
| Mov_b(v1, v2)
| Mov_i(v1, v2)
| Address_of(v1, v2) ->
check_avail v2 [] (fun r2 -> assert_avail v1 r2);
spill_complicated v1 [];
[instr]
| New(v1, n) ->
spill_and_free_reg eax [];
free_var_reg v1;
set_available v1.var_def eax;
[instr]
(** Not commutative operations. *) |
(** v2 is going to be replaced. *) |
| Sub_i(v1, v2, v3) ->
check_avail v3 []
(fun r3 ->
spill_var v2 r3;
assert_avail v2 r3;
free_var_reg v2;
set_available v1.var_def (get_var_reg v2)
);
[instr]
| Not(v1, v2)
| Neg_i(v1, v2) ->
spill_var v2 [];
assert_avail v2 [];
free_var_reg v2;
set_available v1.var_def (get_var_reg v2);
[instr]
| Cmp_i(v1, v2, flags, v3) ->
if is_constant v2 then
(
assert (not (is_constant v3));
let av', i = alloc_instr !av (Cmp_i(v1, v3, commute_flag flags, v2)) needed_defs in
av := av'; i
)
else
(
let r1 = get_fresh_reg [] in
check_avail v3 [r1] (fun r3 -> assert_avail v2 (r1 :: r3));
set_available v1.var_def r1;
v1.var_reg <- Some r1;
[instr; Set_var(flags, v1)]
)
(** Commutative operations. *) |
| And(v1, v2, v3)
| Or(v1, v2, v3)
| Add_i(v1, v2, v3) ->
if is_constant v2 then
(
assert (not (is_constant v3));
let av', i = (alloc_instr !av (commute_instr instr) needed_defs) in
av := av'; i
)
else
(
check_avail v3 []
(fun r3 ->
spill_var v2 r3;
assert_avail v2 r3;
free_var_reg v2;
set_available v1.var_def (get_var_reg v2);
spill_complicated v1 []
);
[instr]
)
| Mult_i(v1, v2, v3) ->
if is_constant v2 then
(
assert (not (is_constant v3));
let av', i = (alloc_instr !av (commute_instr instr) needed_defs) in
av := av'; i
)
else
(
(* TODO: use commutativity *)
(** I386 is so dirty... The result is stored in %edx:%eax. *) |
let occ = [eax; edx] in
List.iter (fun r -> spill_and_free_reg r occ) occ;
check_avail v3 occ
(fun r3 ->
spill_var v2 (r3 @ occ);
alloc_in_reg v2 eax (r3 @ occ);
free_reg eax;
set_available v1.var_def eax
);
[instr]
)
| Mod_i(v1, v2, v3)
| Div_i(v1, v2, v3) ->
(** I386 is so dirty... The result is stored in %edx:%eax. *) |
let occ = [eax; edx] in
List.iter (fun r -> spill_and_free_reg r occ) occ;
check_avail v3 occ
(fun r3 ->
spill_var v2 (r3 @ occ);
alloc_in_reg v2 eax (r3 @ occ);
free_reg eax;
set_available v1.var_def
(
match instr with
| Div_i _ -> eax
| Mod_i _ -> edx
| _ -> raise (Asm_error "internal error")
)
);
[instr]
| Proc(p, l) ->
(** Let's save used registers. *) |
spill_all ();
(** Those registers might be needed for copying arrays and records. *) |
let occ = [ecx; esi; edi] in
List.iter (fun r -> spill_and_free_reg r occ) occ;
let pushes =
(List.rev
(List.fold_left2 (* TODO: fold_left *)
(fun l a v ->
(
just_check_avail v occ;
match get_var_type v with
| Other _ ->
(* assert_avail v occ; *)
Push_o(v, sizeof (get_var_type v))
| _ ->
Push v
) :: l
) [] p.proc_args l))
in
av := [];
pushes @ [Call p.proc_name;
Add_i (get_stack_pos_var (),
get_stack_pos_var (),
new_const_int_var (List.fold_left (fun s a -> s + (sizeof (get_vd_type a))) 0 p.proc_args) lex_depth)]
| Fun(x, p, l) ->
(** Let's save used registers. *) |
spill_all ();
(** Those registers might be needed for copying arrays and records. *) |
let occ = [ecx; esi; edi] in
List.iter (fun r -> spill_and_free_reg r occ) occ;
let pushes =
(List.rev
(List.fold_left2
(fun l a v ->
(
just_check_avail v occ;
match get_var_type v with
| Other _ ->
(* assert_avail v occ; *)
Push_o(v, sizeof (get_var_type v))
| _ ->
Push v
) :: l
) [] p.proc_args l))
in
av := [];
set_available x.var_def eax;
pushes @ [Call p.proc_name;
Add_i (get_stack_pos_var (),
get_stack_pos_var (),
new_const_int_var (List.fold_left (fun s a -> s + (sizeof (get_vd_type a))) 0 p.proc_args) lex_depth)]
| Delete v -> []
| Return v ->
just_check_avail v [];
spill_all ();
[instr]
| Nop -> []
| Assert_avail v -> assert_avail v []; []
| Check_avail_with_flags v -> just_check_avail v []; []
| Spill_var v ->
spill_var v []; []
| Spill_all ->
spill_all (); []
| Code _
| Set_var _
| Unspill _
| Spill _
| Push_o _
| Push _
| Call _
| Check_avail _
| Read_flag _ -> raise (Asm_error "internal error in alloc_instr (encountered an instruction which should not have been generated)")
in
!av, (List.rev !before) @ during @ (List.rev !after)
in
(* TODO: data-flow equations *)
(*
let get_needed_var_defs_in_instr = function
| Mov_i(_, v2)
| Mov_b(_, v2) -> [v2]
| Add_i(_, v2, v3)
| Cmp_i(_, v2, _, v3)
| Mult_i(_, v2, v3) -> [v2; v3]
in
*)
let rec get_needed_var_defs i =
(* TODO: remove duplicates *)
(* List.concat (List.map get_needed_var_defs_in_instr i) *)
[]
in
let used_var_defs_in_instrs = get_needed_var_defs
in
(** Allocate registers for a list of instructions. @param nd list of variable definition needed after the block @returns a list of available variables after the instruction and a rewrite of the code *) |
(* TODO: fill nd correctly *)
let rec alloc_instrs av nd = function
| h :: t ->
let av', i' = alloc_instr av h [] (*used_var_defs_in_instrs t*) in (* TODO: use nd *)
let av'', i'' = alloc_instrs av' nd t in
av'', i' @ i''
| [] -> av, []
in
(** Allocate registers for the base block. *) |
let rec alloc_base_block av base_block =
(** Assembly needed by the following base blocks. *) |
let needed =
match base_block.bb_link with
| If(v, _, _, _) -> [Check_avail_with_flags v]
| While _
| End -> []
in
(* TODO: the Spill_all is not really nice *)
(* TODO: compute variables needed in the next blocks *)
let av, instrs = alloc_instrs av [] (base_block.bb_block @ [Spill_all] @ needed) in
let instrs = ref instrs in
(
match base_block.bb_link with
| If(v, b1, b2, b3) ->
let av1 = alloc_base_block av b1 in
let av2 = alloc_base_block av b2 in
ignore (alloc_base_block
[] (* TODO: we could use the " of av1 and av2 *)
b3)
| While(v, be, b1, b2) ->
be.bb_block <- be.bb_block @ [Check_avail_with_flags v];
let ave = alloc_base_block av be in
let av1 = alloc_base_block ave b1 in (* TODO: is ave correct? *)
ignore (alloc_base_block av1 b2)
| End -> ()
);
base_block.bb_block <- !instrs; av
in
ignore (alloc_base_block [] base_block)