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 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 v r =
if list_mem_assoc_id v !av then failwith "a variable has two locations in memory!";
(* if list_mem_assoc' r !av then failwith "; *)
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
let do_before a =
before := a :: !before
in
(* TODO: remove *)
let print_av av =
do_before
(Code
((List.fold_left
(fun s ->
(function
| (vd, Reg_int i) -> s ^ " " ^ (string_of_int i) ^ "," ^ (string_of_int vd.vd_ident)
| _ -> s ^ " ?"
)) "av:" av) ^ "\n")
)
in
(* let do_before a =
do_before a; print_av !av;
in *)
let during =
(** Mark a register as unused. *) |
let free_reg r =
av := List.filter (fun (_, r') -> r' <> r) !av
in
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))
and do_unspill v =
match get_var_type v with
| Other _ ->
do_before (Address_of(v,v))
| _ ->
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
| 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 =
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;
(
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
);
(** If the variable is in a register then spill it. Its register is then marked as free. *) |
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 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
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;
free_reg (get_var_reg v)
)
else
(
spill_var v occ;
assert_avail v occ
)
in
match instr with
| Mov_b(v1, v2)
| Not(v1, v2)
| Neg_i(v1, v2)
| Mov_i(v1, v2) ->
assert_avail v2 [];
ignore(alloc_reg v1 [get_var_reg v2]);
[instr]
| Address_of(v1, v2) ->
ignore(alloc_reg v1 []);
[instr]
| New(v1, n) ->
set_available v1.var_def (Reg_int 8);
[instr]
| Mult_i(v1, v2, v3)
| And(v1, v2, v3)
| Or(v1, v2, v3)
| Div_i(v1, v2, v3)
| Mod_i(v1, v2, v3)
| Add_i(v1, v2, v3)
| Sub_i(v1, v2, v3)
| Cmp_i(v1, v2, _, v3) ->
assert_avail v2 [];
assert_avail v3 [get_var_reg v2];
ignore(alloc_reg v1 [get_var_reg v2; get_var_reg v3]);
[instr]
| Proc(p, l) ->
spill_all();
let argv = Array.of_list l in
for i = 0 to min 6 ((Array.length argv)-1) do
let v = argv.(i) in
match get_var_type v with
| Other _ ->
assert_avail v [];
do_before(Push_o(v, sizeof(get_var_type v)))
| _ ->
let a = get_reg_var(Reg_int (i+8)) in
assert_avail argv.(i) [];
do_before(Mov_i (a,argv.(i)))
done;
for i = 7 to Array.length argv do
let v = argv.(i) in
match get_var_type v with
| Other _ ->
assert_avail v [];
do_before(Push_o(v, sizeof(get_var_type v)))
| _ ->
do_before(Push argv.(i))
done;
[Call p.proc_name]
| Fun(x,p,l) ->
spill_all();
let argv = Array.of_list l in
for i = 0 to min 6 ((Array.length argv)-1) do
let v = argv.(i) in
match get_var_type v with
| Other _ ->
assert_avail v [];
do_before(Push_o(v, sizeof(get_var_type v)))
| _ ->
let a = get_reg_var(Reg_int (i+8)) in
assert_avail argv.(i) [];
do_before(Mov_i (a,argv.(i)))
done;
for i = 7 to Array.length argv do
let v = argv.(i) in
match get_var_type v with
| Other _ ->
assert_avail v [];
do_before(Push_o(v, sizeof(get_var_type v)))
| _ ->
do_before(Push argv.(i))
done;
set_available x.var_def (Reg_int 8);
[Call p.proc_name]
| Delete _
| Return _
| Nop -> [instr]
| 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
(** Allocate registers for a list of instructions. @returns a list of available variables after the instruction and a rewrite of the code *) |
let rec alloc_instrs av nd = function
| h :: t ->
let av', i' = alloc_instr av h [] (*used_var_defs_in_instrs t*) in
let av'', i'' = alloc_instrs av' nd t in
av'', i' @ i''
| [] -> av, []
in
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
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 -> (* (** Let's spill everything. *)
instrs := !instrs @ (List.fold_left (fun l (vd, r) ->
match r with
| Reg_int _ ->
vd.vd_on_the_stack := true;
Spill(get_ vd <> lex_depth, r, vd) :: l
| Reg_flag _ -> l (* TODO! *)
) [] av) *) ()
);
base_block.bb_block <- !instrs; av
in
ignore (alloc_base_block [] base_block)