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 *) |
(* TODO: really compute and use needed_defs *)
let rec alloc_instr av instr needed_defs =
let av = ref av in
(** Declare that a variable is avaiable in a register. If some other variable was previously declared as available in the same register, it won't be anymore. *) |
let set_available v r =
if list_mem_assoc_id v !av then failwith "a variable has two locations in memory!";
av := (v, r) :: (List.filter (fun (_, r') -> r' <> r) !av)
in
(** Warning before and after are reversed at the end of the function! *) |
let before = ref []
and after = ref [] in (* TODO: remove after if it's not used *)
let do_before a =
before := a :: !before
in
let do_after a =
after := a :: !after
in
let during =
(** Mark a register as unused. *) |
let free_reg r =
av := List.filter (fun (_, r') -> r' <> r) !av
in
(** Spill a variable. *) |
let rec 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))
(** Unspill a variable. *) |
and 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 *)
| _ ->
do_before (Unspill (get_var_lex v <> lex_depth, v))
(** Allocate a variable in a specific register. *) |
and alloc_in_reg v r occ =
(** Warning: v.var_reg should be set for flags! *) |
match v.var_reg with
| Some ((Reg_flag f) as rf) ->
v.var_reg <- Some r;
do_before (Set_var(f, v));
free_reg rf;
set_available v.var_def r; r
| Some r -> r (* TODO: do not compute the first r in this case! *)
| None ->
(
match v.var_def.vd_value with
| Some _ ->
v.var_reg <- Some r;
let v' = copy_var v in
v'.var_reg <- None;
do_before (Mov_i(v, v'));
set_available v.var_def r; r
| None ->
v.var_reg <- Some r;
do_unspill (copy_var v);
set_available v.var_def r; r
)
(** Allocate an integer register to the variable v .
@param occ is a list of already taken integer registers *) |
and alloc_reg v occ =
(* TODO: should this be there or in check_avail? *)
let occ =
match get_var_pos v with
| Pos_arr(a, v, _, _) -> get_var_reg a :: get_var_reg v :: occ
| Pos_rec(p, _)
| Pos_pointed p -> get_var_reg p :: occ
| Pos_base _
| Pos_stack _
| Pos_label _
| Pos_none -> occ
in
let r =
(** 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
(* TODO: spill the one which will not be used during the most long time *)
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_free true r replaced_vd occ; r
in
alloc_in_reg v r occ
(* TODO: if it's not needed anymore, don't spill it *)
(** @param free should we declare the freed variable's register as free? @param occ is here to specify needed registers because we might need an extra register during the spill *) |
and spill_free free r vd occ =
vd.vd_on_the_stack := true;
(
match get_vd_pos vd with
| Pos_arr(b, v, _, _) ->
assert_avail b occ; assert_avail v occ
| Pos_pointed p
| Pos_rec(p, _) -> assert_avail p occ
| _ -> ()
);
(
match r with
| Reg_int _ ->
do_spill r vd;
if free then free_reg r
| Reg_flag f ->
let v = new_var vd in
v.var_reg <- Some r;
free_reg r; (* TODO: this is not really nice but else we get the " error *)
(
(* TODO: why do we need to do that? *)
try
v.var_reg <- Some (list_assoc_id v.var_def !av)
with
| _ -> ignore (alloc_reg v occ)
);
let r' = get_var_reg v in
do_spill r' vd;
free_reg r';
if free then free_reg r
);
and spill_var_free free v occ =
check_avail_flags true v occ (fun l -> List.iter (fun r -> spill_free free 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_free true 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 ()
(** If variable v already was in a register it stays in it. The function f is called with the list of used registers. The second argument tells whether it is acceptable or not for it to be stored in flags. *) |
and check_avail_flags flags v occ f =
let check_pos occ = function
| Pos_rec(v, _)
| Pos_pointed v -> assert_avail v occ; get_var_reg v :: occ
| Pos_arr(a, v, _, _) ->
assert_avail a occ;
let occ = get_var_reg a :: occ in
assert_avail v occ;
get_var_reg v :: occ
| Pos_base _ | Pos_stack _ | Pos_label _ | Pos_none -> occ
in
v.var_reg <- None; (* TODO: is that useful? *)
on_avail v
(fun r ->
(* let occ = check_pos (r :: occ) v.var_def.vd_pos in *)
let r =
if flags && !Params.use_flags then r
else
match r with
| Reg_flag _ ->
v.var_reg <- Some r;
alloc_reg v occ
| _ -> r
in
v.var_reg <- Some r; f [r]
)
(fun () ->
let occ = check_pos occ (get_var_pos v) in
if get_var_lex v <> lex_depth || get_var_type v = Boolean then
f [alloc_reg v occ]
else
(
if not (is_constant v) then
v.var_def.vd_on_the_stack := true;
f []
)
)
(** If the variable is not yet in a register put it in some register. *) |
and assert_avail v occ =
check_avail_flags false v occ
(fun r ->
match r with
| [] -> ignore (alloc_reg v occ)
| [Reg_flag f] -> ignore (alloc_reg v occ)
| _ -> ()
)
in
let spill = spill_free true in
(** If the variable is in a register then spill it. Its register is then marked as free. *) |
let spill_var = spill_var_free true in
let spill_all () =
List.iter (fun (vd, r) ->
match r with
| Reg_int _ ->
vd.vd_on_the_stack := true;
spill r vd []
| Reg_flag _ -> () (* TODO! *)
) !av
in
let check_avail = check_avail_flags false in
let just_check_avail v occ =
check_avail v occ (fun _ -> ())
in
let used_and_replaced v occ =
if !(Params.minimize_spills) then
(
spill_var_free false v occ;
assert_avail v occ; (* TODO: we do not need to load the value *)
free_reg (get_var_reg v)
)
else
(
spill_var v occ;
assert_avail v occ
)
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 ->
spill_var v1 r2;
(* TODO: we don't need to load v1's value *)
assert_avail v1 r2;
(* used_and_replaced v1 r2; *)
(* set_available v1.var_def (get_var_reg v1) *)
);
(* check_avail v2 []
(fun r2 -> ignore (alloc_reg v1 r2)); *)
(
match get_var_pos v1 with
| Pos_pointed _
| Pos_arr _
| Pos_rec _ -> do_after (Spill(false, get_var_reg v1, v1.var_def)); free_reg (get_var_reg v1)
| _ -> ()
);
[instr]
| New(v1, n) ->
used_and_replaced 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_free false v2 r3;
set_available v1.var_def (alloc_reg v2 r3)
);
[instr]
| Not(v1, v2)
| Neg_i(v1, v2) ->
used_and_replaced v2 [];
let r2 = get_var_reg v2 in
set_available v1.var_def r2;
[instr]
| Cmp_i(v1, v2, flags, v3) ->
if is_constant v2 then
(
assert (not (is_constant v3)); (* TODO *)
let av', i = alloc_instr !av (Cmp_i(v1, v3, commute_flag flags, v2)) needed_defs in
av := av'; i
)
else
(
(** If there was already somebody in the flags we spill it. *) |
List.iter
(fun (vd, r) ->
match r with
| Reg_flag f -> spill r vd []
| _ -> ()
) !av;
check_avail v3 []
(fun r3 ->
assert_avail v2 r3;
let r2 = get_var_reg v2 in
set_available v1.var_def (Reg_flag flags)
);
[instr]
)
(** 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 ->
used_and_replaced v2 r3;
let r2 = get_var_reg v2 in
set_available v1.var_def r2
);
[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_reg r occ) occ;
check_avail v3 occ
(fun r3 ->
spill_var v2 (r3 @ occ);
ignore (alloc_in_reg v2 eax (r3 @ occ));
free_reg eax;
free_reg edx;
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_reg r occ) occ;
assert_avail v3 occ;
let r3 = [get_var_reg v3] in
spill_var v2 (r3 @ occ);
ignore (alloc_in_reg v2 eax (r3 @ occ));
free_reg eax;
free_reg edx;
set_available v1.var_def
(Reg_int
(
match instr with
| Div_i _ -> 0
| Mod_i _ -> 3
| _ -> 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
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 := [];
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
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 := [];
used_and_replaced x occ;
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 [];
[instr]
| Nop -> []
| Assert_avail v -> assert_avail v []; []
| Check_avail_with_flags v -> check_avail_flags false v [] (fun _ -> ()); []
| 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)