diff --git a/Sujet.pdf b/Sujet.pdf
index 353998034bf772d40308012fcade67ca4a22e1d3..fee3b5191a38a331944da73049353c94da487764 100644
Binary files a/Sujet.pdf and b/Sujet.pdf differ
diff --git a/alpaga/grammar_lexer.mll b/alpaga/grammar_lexer.mll
index 5716c08bf5e1d840a78e8f28313376110a2ae922..e2802373e089f6071d553ed23d371275404d9e67 100644
--- a/alpaga/grammar_lexer.mll
+++ b/alpaga/grammar_lexer.mll
@@ -1,5 +1,6 @@
{
open Grammar_parser_yacc
+open Lexing
}
let digit = ['0'-'9']
diff --git a/src/elang_gen.ml b/src/elang_gen.ml
index 8c08406e29016e99b565a08bc9153ab790446374..e8f9cd6922ac226fc7496be037d92ae7f351f476 100644
--- a/src/elang_gen.ml
+++ b/src/elang_gen.ml
@@ -81,9 +81,8 @@ let make_fundef_of_ast (a: tree) : (string * efun) res =
let make_eprog_of_ast (a: tree) : eprog res =
match a with
- | Node (Tlistglobdef, [a]) ->
- make_fundef_of_ast a >>= fun (fname, efun) ->
- OK [(fname, Gfun efun)]
+ | Node (Tlistglobdef, l) ->
+ list_map_res (fun a -> make_fundef_of_ast a >>= fun (fname, efun) -> OK (fname, Gfun efun)) l
| _ ->
Error (Printf.sprintf "make_fundef_of_ast: Expected a Tlistglobdef, got %s."
(string_of_ast a))
diff --git a/src/linear_liveness.ml b/src/linear_liveness.ml
index 5459485e17caf0b200c1ac25e50edf9701c3ba31..0a5891e75cfe8718612141f84e5e97e86f8b377c 100644
--- a/src/linear_liveness.ml
+++ b/src/linear_liveness.ml
@@ -5,11 +5,75 @@ open Utils
open Linear
open Rtl
+let gen_live (i: rtl_instr) =
+ match i with
+ | Rbinop (b, rd, rs1, rs2) -> Set.of_list [rs1; rs2]
+ | Rprint rs
+ | Runop (_, _, rs) -> Set.singleton rs
+ | Rconst (_, _) -> Set.empty
+ | Rbranch (_, rs1, rs2, _) -> Set.of_list [rs1; rs2]
+ | Rjmp _ -> Set.empty
+ | Rmov (_, rs) -> Set.singleton rs
+ | Rret r -> Set.singleton r
+ | Rlabel _ -> Set.empty
+let kill_live (i: rtl_instr) =
+ match i with
+ | Rbinop (_, rd, _, _)
+ | Runop (_, rd,_)
+ | Rconst (rd, _)
+ | Rmov (rd,_) -> Set.singleton rd
+ | Rbranch (_, _, _, _)
+ | Rprint _
+ | Rret _
+ | Rjmp _
+ | Rlabel _ -> Set.empty
- let liveness_instrs linearfunbody =
- (Hashtbl.create 0, Hashtbl.create 0)
+let linear_succs (ins: rtl_instr) i labels =
+ match ins with
+ | Rbranch(_, _, _, s1) -> [Hashtbl.find_default labels s1 0; i+1]
+ | Rjmp s -> [Hashtbl.find_default labels s 0]
+ | Rret r -> []
+ | _ -> [i+1]
+let setup_labels insl =
+ let labels = Hashtbl.create 17 in
+ List.iteri (fun i ins ->
+ match ins with
+ | Rlabel l -> Hashtbl.replace labels l i
+ | _ -> ()
+ ) insl;
+ labels
+
+let add_changes h k v =
+ let orig = Hashtbl.find_default h k Set.empty in
+ Hashtbl.replace h k v;
+ not (Set.equal v orig)
+
+let iter_liveness insl live_in live_out labels =
+ List.fold_lefti (fun changed i ins ->
+
+ let gl = gen_live ins in
+ let kl = kill_live ins in
+ let oi = Hashtbl.find_default live_out i Set.empty in
+ let newin = Set.union gl (Set.diff oi kl) in
+ let changed = add_changes live_in i newin || changed in
+ let succs = linear_succs ins i labels in
+ let j = List.fold_left (fun j succ ->
+ Set.union j (Hashtbl.find_default live_in succ Set.empty)
+ ) Set.empty succs in
+ add_changes live_out i j || changed
+ ) false insl
+
+let liveness_instrs insns =
+ let live_in = Hashtbl.create 17 in
+ let live_out = Hashtbl.create 17 in
+ let labels = setup_labels insns in
+ let rec aux () =
+ if iter_liveness insns live_in live_out labels
+ then aux ()
+ else (live_in, live_out) in
+ aux ()
let liveness_linear_prog lp =
let lives = Hashtbl.create 17 in
diff --git a/src/ltl_gen.ml b/src/ltl_gen.ml
index 5244b3eb35eb83919317b31aed97075efc3ab5c9..3a7b6172a3befdb7ea476ed2f500523afa671687 100644
--- a/src/ltl_gen.ml
+++ b/src/ltl_gen.ml
@@ -31,37 +31,412 @@ let make_sp_sub v =
let make_sp_add v =
[LAddi(reg_sp, reg_sp, v)]
+(* Moving between locations. [src] and [dst] are locations. [make_loc_mov src
+ dst] generates instructions so that the value in [src] ends up in [dst],
+ where [src] and [dst] can be registers [Reg r] or stack offsets [Stk o].
+*)
+let make_loc_mov src dst =
+ match src, dst with
+ | Stk osrc , Stk odst ->
+ let rtmp = reg_tmp1 in
+ [LLoad(rtmp, reg_fp, !Archi.wordsize * osrc, !Archi.wordsize);
+ LStore(reg_fp, !Archi.wordsize * odst, rtmp, !Archi.wordsize)]
+ | Stk osrc, Reg rdst ->
+ [LLoad(rdst, reg_fp, !Archi.wordsize * osrc, !Archi.wordsize)]
+ | Reg rsrc, Stk ofst ->
+ [LStore(reg_fp, !Archi.wordsize * ofst, rsrc, !Archi.wordsize)]
+ | Reg rsrc, Reg rdst ->
+ [LMov(rdst,rsrc)]
+(* load_loc tmp allocation r = (l, r'). Loads the equivalent of RTL register r
+ in a LTL register r'. tmpis used if necessary. *)
+let load_loc tmp allocation r =
+ match Hashtbl.find_option allocation r with
+ | None ->
+ Error (Format.sprintf "Unable to allocate RTL register r%d." r)
+ | Some (Stk o) -> OK ([LLoad(tmp, reg_fp, !Archi.wordsize * o, !Archi.wordsize)], tmp)
+ | Some (Reg r) -> OK ([], r)
+(* store_loc tmp allocation r = (l, r'). I want to write in RTL register r.
+ Tells me that I just have to write to LTL register r' and execute l. *)
+let store_loc tmp allocation r =
+ match Hashtbl.find_option allocation r with
+ | None ->
+ Error (Format.sprintf "Unable to allocate RTL register r%d." r)
+ | Some (Stk o) -> OK ([LStore(reg_fp, !Archi.wordsize * o, tmp, !Archi.wordsize)], tmp)
+ | Some (Reg r) -> OK ([], r)
- let ltl_prog_of_linear_with_alloc_order alloc_order lp =
- let prog = List.map (function
- (fname, Gfun f) ->
- (fname, Gfun {
- ltlfunargs = 0;
- ltlfunbody = [];
- ltlfuninfo = [];
- ltlregalloc = [];
- }
- )) lp in
- prog
+(* saves registers in [to_save] on the stack at offsets [fp + o, fp + o - 8, fp
+ + o - 16...]. Returns:
+ - an association list [(reg,ofs)] (meaning register reg is saved at [fp+ofs])
+ - the list of store instructions
+ - the next offset to be written.
+*)
+let save_caller_save to_save ofs =
+ List.fold_left (fun (instrs, arg_saved, ofs) reg ->
+ (instrs @ [LStore(reg_fp, ofs, reg, !Archi.wordsize)],
+ (reg,ofs)::arg_saved, ofs - !Archi.wordsize)
+ ) ([], [], ofs) to_save
+(* Given a list [(reg,ofs)], loads [fp+ofs] into [reg]. *)
+let restore_caller_save =
+ List.map (fun (reg, ofs) -> LLoad(reg, reg_fp, ofs, !Archi.wordsize))
-let alloc_order_st = [
- reg_s1; reg_s2; reg_s3; reg_s4; reg_s5;
- reg_s6; reg_s7; reg_s8; reg_s9; reg_s10; reg_s11;
- reg_t2; reg_t3; reg_t4; reg_t5; reg_t6;
-]
+let num_parameters_passed_on_stack regs =
+ let r = List.length regs - number_of_arguments_passed_in_registers in
+ Stdlib.max 0 r
-let alloc_order_ts = [
- reg_t2; reg_t3; reg_t4; reg_t5; reg_t6;
+
+(* Given a list or RTL registers [rargs], we want to load their values in LTL
+ argument registers a0-7. But while writing these registers, we may overwrite
+ the value of some registers before we actually read them.
+
+ For example if [r1 -> a1] and [r2 -> a0], and we want to load [r1] in [a0]
+ and [r2] in [a1] (because a function call f(r1,r2) occurs), the following
+ would happen :
+
+ mv a0, a1
+ mv a1, a0
+
+ But the value in [a1] will not be the value that was originally in RTL reg
+ [r2].
+
+ Hence, we keep track of the registers like [a1] that are going to be written
+ before being read, and those will be saved on the stack.
+*)
+let overwritten_args rargs allocation =
+
+ (* [ltl_args] contains the locations of RTL args after allocation. *)
+ list_map_res (fun r -> match Hashtbl.find_option allocation r with
+ | None -> Error (Format.sprintf
+ "pass_parameters: Couldn't allocate register r%d."
+ r)
+ | Some loc -> OK loc
+ ) rargs >>= fun ltl_args ->
+
+ let (overwritten, read_overwritten) =
+ List.fold_lefti (fun (overwritten, read_overwritten) i (src: loc) ->
+ (* [overwritten] contains the list of registers that have been written
+ to.
+
+ [read_overwritten] contains the list of registers that have been read
+ after being written to. *)
+ let read_overwritten =
+ match src with
+ | Reg rs -> if Set.mem rs overwritten
+ then Set.add rs read_overwritten
+ else read_overwritten
+ | Stk _ -> read_overwritten
+ in
+ let overwritten =
+ if i < number_of_arguments_passed_in_registers
+ then Set.add (starting_arg_register + i) overwritten
+ else overwritten
+ in (overwritten, read_overwritten)
+ ) (Set.empty,Set.empty) ltl_args in
+ OK read_overwritten
+
+
+
+(* [pass_parameters rargs allocation arg_saved ofs] generates code to pass
+ parameters in RTL registers rargs. [allocation] maps RTL registers to LTL
+ locations, [arg_saved] contains saved registers, and [ofs] says where,
+ relative to reg_fp we may save more registers if needed. *)
+let pass_parameters rargs allocation arg_saved =
+ (* LTL locations corresponding to RTL arguments. *)
+ list_map_res (fun r -> match Hashtbl.find_option allocation r with
+ | None ->
+ Error (Format.sprintf
+ "pass_parameters: Couldn't allocate register r%d." r)
+ | Some loc -> OK loc
+ ) rargs >>= fun ltl_args ->
+
+ (* Relocation of arguments may be necessary if, e.g. a1 must be passed as
+ first argument (in a0) and a0 must be passed as second argument (in a1). In
+ that situation, a temporary must be used. These registers (a0 and a1) would
+ have been saved before on the stack and the relocation information is
+ available in arg_saved. *)
+ let reloc_loc overwritten loc =
+ match loc with
+ | Stk o -> OK loc
+ | Reg r -> if List.mem r overwritten
+ then match List.assoc_opt r arg_saved with
+ | None -> Error (Format.sprintf "Register %s has been overwritten, \
+ yet it has not been saved."
+ (print_reg r))
+ | Some newloc -> OK (Stk newloc)
+ else OK loc
+ in
+ (* Iterates over the list of LTL arguments. Generates 4 things:
+
+ - [overwritten] is the set of registers that are overwritten during
+ parameter passing. If a register has been overwritten, then we use its copy
+ on the stack; otherwise we can use it directly.
+
+ - [instrs] is a list of instructions for the arguments passed in registers.
+
+ - [pushes] is a list of push pseudo-instructions for every additional
+ argument. The two lists are built separately so that we can build [pushes]
+ backwards so that e.g. the 9th argument is at the top of the stack at the
+ end, and e.g. the 15th at higher addresses.
+
+ - [npush] is the number of arguments that were pushed to the stack. *)
+
+ List.fold_lefti (fun acc i (src: loc) ->
+ acc >>= fun (overwritten, instrs, pushes, npush) ->
+ reloc_loc overwritten src >>= fun src ->
+ let (overwritten, l,pushes, npush) =
+ if i < number_of_arguments_passed_in_registers
+ then let rd = starting_arg_register + i in
+ begin match src with
+ | Reg rs -> (rd::overwritten, [LMov(rd, rs)],[], npush)
+ | Stk o -> (rd::overwritten,
+ [LLoad(rd, reg_fp, !Archi.wordsize * o, !Archi.wordsize)],
+ [], npush)
+ end else
+ begin match src with
+ | Reg rs -> (overwritten, [], make_push rs@pushes, npush+1)
+ | Stk o -> (overwritten, [],
+ LLoad(reg_tmp1, reg_fp, !Archi.wordsize * o, !Archi.wordsize)
+ ::make_push reg_tmp1 @ pushes,
+ npush+1)
+ end
+ in
+ OK (overwritten, instrs@l, pushes, npush)
+ ) (OK ([], [], [], 0)) ltl_args >>=
+ fun (overwritten, instrs, pushes, npush) ->
+ OK (instrs@pushes, npush)
+
+let written_rtl_regs_instr (i: rtl_instr) =
+ match i with
+ | Rbinop (_, rd, _, _)
+ | Runop (_, rd, _)
+ | Rconst (rd, _)
+ | Rmov (rd, _) -> Set.singleton rd
+ | Rprint _
+ | Rret _
+ | Rlabel _
+ | Rbranch (_, _, _, _)
+ | Rjmp _ -> Set.empty
+
+let read_rtl_regs_instr (i: rtl_instr) =
+ match i with
+ | Rbinop (_, _, rs1, rs2)
+ | Rbranch (_, rs1, rs2, _) -> Set.of_list [rs1; rs2]
+
+ | Rprint rs
+ | Runop (_, _, rs)
+ | Rmov (_, rs)
+ | Rret rs -> Set.singleton rs
+
+ | Rlabel _
+ | Rconst (_, _)
+ | Rjmp _ -> Set.empty
+
+let read_rtl_regs (l: rtl_instr list) =
+ List.fold_left (fun acc i -> Set.union acc (read_rtl_regs_instr i))
+ Set.empty l
+
+let written_rtl_regs (l: rtl_instr list) =
+ List.fold_left (fun acc i -> Set.union acc (written_rtl_regs_instr i))
+ Set.empty l
+
+let rtl_to_ltl_registers allocation l =
+ Set.filter_map (fun rtlreg ->
+ match Hashtbl.find_option allocation rtlreg with
+ | Some (Stk ofs) -> None
+ | None -> None
+ | Some (Reg r) -> Some r) l
+
+(* Take the RTL registers used by RTL instructions in [l], apply allocation to
+ them. This gives a list of machine registers used by the LTL function. We
+ need to add also the registers that will be used for argument passing. *)
+
+let read_ltl_regs_clever fname l allocation =
+ read_rtl_regs l |> rtl_to_ltl_registers allocation
+let written_ltl_regs_clever fname l allocation =
+ written_rtl_regs l |> rtl_to_ltl_registers allocation
+
+let read_ltl_regs fname l allocation =
+ read_ltl_regs_clever fname l allocation
+
+let written_ltl_regs fname l allocation =
+ written_ltl_regs_clever fname l allocation
+
+(* We propose three different strategies for caller-save registers:
+ - [CSS_all] : save all registers before calling a function
+ - [CSS_read] : save all registers that are read in the calling function,
+ we might need them later in the function
+ - [CSS_live] : save all registers that are live after the call to the
+ function, this is more precise than [CSS_read].
+*)
+type caller_save_strategy =
+ | CSS_all
+ | CSS_read
+ | CSS_live
+
+let caller_save live_out allocation read_regs rargs
+ (strategy: caller_save_strategy) =
+ let l =
+ match strategy with
+ | CSS_all -> OK (range 32 |> Set.of_list)
+ | CSS_read -> OK read_regs
+ | CSS_live ->
+ let live_after = live_out in
+ let live_after_ltl = live_after |> rtl_to_ltl_registers allocation in
+ overwritten_args rargs allocation >>= fun overwritten_args_tosave ->
+ OK (Set.union live_after_ltl overwritten_args_tosave)
+ in
+ l >>= fun l -> OK (Set.intersect l (Set.of_list (arg_registers @ reg_tmp)))
+
+(* This generates LTL instructions for a given Linear/RTL instruction. In most
+ cases, the transformation amounts to 'loading' RTL registers in LTL locations
+ and emitting the straightforward corresponding LTL instructions. This uses
+ load_loc and store_loc, described above, a lot. The most interesting case is
+ call instructions. Indeed, in that case, we emit code for saving and
+ restoring caller-save registers before and after the call, respectively. The
+ registers to be saved are computed as the set of Risc-V registers marked as
+ caller-save (a0-a7,t0-t6) intersected with the registers that are read in the
+ code of the caller. (The rationale being, if we don't read this variable,
+ then we don't need its value to be preserved across function calls.) These
+ registers are saved at [fp - 8 * (curstackslot + 1)] *)
+let ltl_instrs_of_linear_instr fname live_out allocation read_regs
+ numspilled epilogue_label ins =
+ match ins with
+ | Rbinop (b, rd, rs1, rs2) ->
+ load_loc reg_tmp1 allocation rs1 >>= fun (l1, r1) ->
+ load_loc reg_tmp2 allocation rs2 >>= fun (l2, r2) ->
+ store_loc reg_tmp1 allocation rd >>= fun (ld, rd) ->
+ OK (l1 @ l2 @ LBinop(b, rd, r1, r2) :: ld)
+ | Runop (u, rd, rs) ->
+ load_loc reg_tmp1 allocation rs >>= fun (l1,r1) ->
+ store_loc reg_tmp1 allocation rd >>= fun (ld, rd) ->
+ OK (l1 @ LUnop(u, rd, r1) :: ld)
+ | Rconst (rd, i) ->
+ store_loc reg_tmp1 allocation rd >>= fun (ld, rd) ->
+ OK (LConst(rd, i)::ld)
+ | Rbranch (cmp, rs1, rs2, s1) ->
+ load_loc reg_tmp1 allocation rs1 >>= fun (l1, r1) ->
+ load_loc reg_tmp2 allocation rs2 >>= fun (l2, r2) ->
+ OK (l1 @ l2 @ [LBranch(cmp, r1, r2, Format.sprintf "%s_%d" fname s1)])
+ | Rjmp s -> OK [LJmp (Format.sprintf "%s_%d" fname s)]
+ | Rmov (rd, rs) ->
+ load_loc reg_tmp1 allocation rs >>= fun (ls, rs) ->
+ store_loc reg_tmp1 allocation rd >>= fun (ld, rd) ->
+ OK (ls @ LMov(rd, rs) :: ld)
+ | Rprint r ->
+
+ let (save_a_regs, arg_saved, ofs) =
+ save_caller_save
+ (range 32)
+ (- !Archi.wordsize * (numspilled+1)) in
+ let parameter_passing =
+ match Hashtbl.find_option allocation r with
+ | None -> Error (Format.sprintf "Could not find allocation for register %d\n" r)
+ | Some (Reg rs) -> OK [LMov(reg_a0, rs)]
+ | Some (Stk o) -> OK [LLoad(reg_a0, reg_fp, !Archi.wordsize * o, !Archi.wordsize)]
+ in
+ parameter_passing >>= fun parameter_passing ->
+ OK (LComment "Saving a0-a7,t0-t6" :: save_a_regs @
+ LAddi(reg_sp, reg_s0, ofs) ::
+ parameter_passing @
+ LCall "print" ::
+ LComment "Restoring a0-a7,t0-t6" :: restore_caller_save arg_saved)
+
+ | Rret r ->
+ load_loc reg_tmp1 allocation r >>= fun (l,r) ->
+ OK (l @ [LMov (reg_ret, r) ; LJmp epilogue_label])
+ | Rlabel l -> OK [LLabel (Format.sprintf "%s_%d" fname l)]
+
+(** Retrieves the location of the n-th argument (in the callee). The first 8 are
+ passed in a0-a7, the next are passed on the stack. *)
+let retrieve_nth_arg n numcalleesave =
+ let thr = number_of_arguments_passed_in_registers in
+ if n < thr
+ then Reg (n + starting_arg_register)
+ else Stk ((numcalleesave + n-thr))
+
+(* This function creates a LTL function out of a Linear function. In addition to
+ using machine registers instead of ideal registers, it deals with saving and
+ restoring callee-save registers. The function prologue consists of saving
+ these callee-save registers, making the frame pointer to sp, and saving space
+ on the stack for the variables that would reside on the stack (i.e. spilled -
+ they go from [s0] to [s0+curstackslot] (curstackslot is negative, and
+ returned by the register allocation)). The function epilogue restores sp to
+ the value stored in s0 (fp), restore all the callee-save registers and jumps
+ back to [ra]. *)
+let ltl_fun_of_linear_fun linprog
+ (({ linearfunargs; linearfunbody; linearfuninfo }): linear_fun) fname
+ (live_in,live_out) (allocation, numspilled) =
+ List.iteri (fun i pr ->
+ Hashtbl.replace allocation pr (retrieve_nth_arg i 0)
+ ) linearfunargs;
+ let written_regs = Set.add reg_ra
+ (Set.add reg_fp
+ (written_ltl_regs fname linearfunbody allocation)) in
+ let callee_saved_regs =
+ Set.intersect (Set.of_list callee_saved) written_regs in
+ List.iteri (fun i pr ->
+ Hashtbl.replace allocation pr
+ (retrieve_nth_arg i (Set.cardinal callee_saved_regs))
+ ) linearfunargs;
+
+ let max_label =
+ List.fold_left (fun acc i ->
+ match i with
+ Rlabel l -> Stdlib.max l acc
+ | _ -> acc)
+ 0 linearfunbody in
+ let epilogue_label = Format.sprintf "%s_%d" fname (max_label + 1) in
+ let prologue =
+ List.concat (List.map make_push (Set.to_list callee_saved_regs)) @
+ LMov (reg_fp, reg_sp) ::
+ make_sp_sub (numspilled * !Archi.wordsize) @
+ [LComment "end prologue"] in
+ let epilogue = LLabel epilogue_label ::
+ LMov(reg_sp, reg_fp) ::
+ List.concat (List.map make_pop
+ (List.rev (Set.to_list callee_saved_regs))) @
+ [LJmpr reg_ra] in
+ let read_regs_f = read_ltl_regs fname linearfunbody allocation in
+ list_map_resi (fun i ->
+ ltl_instrs_of_linear_instr fname (Hashtbl.find_default live_out i Set.empty)
+ allocation read_regs_f numspilled epilogue_label) linearfunbody
+ >>= fun l ->
+ let instrs = List.concat l
+ in
+ OK {
+ ltlfunargs = List.length linearfunargs;
+ ltlfunbody = prologue @ instrs @ epilogue;
+ ltlfuninfo = linearfuninfo;
+ ltlregalloc = Hashtbl.bindings allocation;
+ }
+
+
+let allocable_registers = Set.of_list [
reg_s1; reg_s2; reg_s3; reg_s4; reg_s5;
reg_s6; reg_s7; reg_s8; reg_s9; reg_s10; reg_s11;
+ reg_t2; reg_t3; reg_t4; reg_t5; reg_t6;
]
-let ltl_prog_of_linear lp () =
- let alloc_order =
- if !Options.alloc_order_st then alloc_order_st else alloc_order_ts in
- ltl_prog_of_linear_with_alloc_order alloc_order lp
+let ltl_prog_of_linear lp =
+ let lives = liveness_linear_prog lp in
+ let allocations = regalloc lp lives allocable_registers in
+ let prog = list_map_res (function
+ (fname, Gfun f) ->
+ let f_alloc =
+ match Hashtbl.find_option allocations fname with
+ | None -> (Hashtbl.create 0, 0)
+ | Some (rig, allocation, next_stack_slot) -> (allocation, - next_stack_slot)
+ in
+ let f_lives =
+ match Hashtbl.find_option lives fname with
+ | None -> (Hashtbl.create 0, Hashtbl.create 0)
+ | Some x -> x
+ in
+ ltl_fun_of_linear_fun lp f fname f_lives f_alloc >>= fun f ->
+ OK (fname, Gfun f)
+ ) lp in
+ prog
diff --git a/src/ltl_print.ml b/src/ltl_print.ml
index b4421cfbedfab7b81d908c1df22bdd4c0f9e018f..bdabe2569a3d8f27638ba06ee2f40cf0380c7a14 100644
--- a/src/ltl_print.ml
+++ b/src/ltl_print.ml
@@ -107,15 +107,16 @@ let dump_ltl_instr_list fname oc l =
dump_ltl_instr oc ins;
Format.fprintf oc "\n") l
+let dump_allocation oc fname alloc =
+ Format.fprintf oc "// In function %s\n" fname;
+ List.iter (fun (linr,ltlloc) ->
+ Format.fprintf oc "// LinReg %d allocated to %s\n" linr (print_loc ltlloc)
+ ) alloc
+
let dump_ltl_fun oc fname lf =
+ dump_allocation oc fname lf.ltlregalloc;
Format.fprintf oc "%s:\n" fname;
dump_ltl_instr_list fname oc lf.ltlfunbody
let dump_ltl_prog oc lp =
dump_prog dump_ltl_fun oc lp
-
-let dump_allocation fname alloc =
- Format.printf "In function %s\n" fname;
- Hashtbl.iter (fun linr ltlloc ->
- Format.printf "LinReg %d allocated to %s\n" linr (print_loc ltlloc)
- ) alloc
diff --git a/src/main.ml b/src/main.ml
index f53ff78eda9922bf30423bbcb81deffeca546a54..f9a4a22e5e43e17f9ba1b79dceda4397e11b4f6a 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -67,6 +67,11 @@ let speclist =
("-riscv-run", Arg.Set riscv_run, "Run RISC-V program.");
("-no-dump", Arg.Set no_dump, "Do not dump anything but the .s file");
("-no-dot", Arg.Set no_dot, "Do not call dot on CFG dumps (default false)");
+ ("-clever-regalloc", Arg.Unit (fun () -> naive_regalloc := false), "Use the graph coloring algorithm for register allocation.");
+ ("-naive-regalloc", Arg.Unit (fun () -> naive_regalloc := true),
+ "Use the naive algorithm for register allocation (all pseudo-registers go on the stack).");
+ ("-rig-dump", Arg.String (fun s -> rig_dump := Some s),
+ "Path to output the register interference graph");
("-all-run", Arg.Unit (fun () ->
e_run := true;
cfg_run := true;
@@ -115,7 +120,11 @@ let results = ref []
let run step flag eval p =
if flag then begin
- begin match eval Format.str_formatter p !heapsize !params with
+ let res = match eval Format.str_formatter p !heapsize !params with
+ | exception e ->
+ Error (Printexc.to_string e)
+ | e -> e in
+ begin match res with
| OK v ->
let output = Format.flush_str_formatter () in
results := !results @ [RunRes { step ; retval = v; output; error = None}];
@@ -149,21 +158,6 @@ let record_compile_result ?error:(error=None) ?data:(data=[]) step =
let data = if not !Options.nostats then `List data else `Null in
results := !results @ [CompRes { step; error; data}]
-let dump file dumpf p additional_command =
- begin match file with
- | None -> ()
- | Some file ->
- let oc, close =
- if file = "-"
- then (Format.std_formatter, fun _ -> ())
- else
- let oc = open_out file in
- (Format.formatter_of_out_channel oc, fun () -> close_out oc)
- in
- dumpf oc p; close ();
- if file <> "-" then additional_command file ()
- end
-
let process_output_to_list2 = fun command ->
@@ -224,7 +218,13 @@ let exec_rv_prog ltl basename oc rvp heapsize params =
f
in
let error = ref None in
- dump (Some rvp) dump_riscv_prog ltl (fun file () -> error := compile_rv basename file ());
+ dump (Some rvp) (fun oc p ->
+ match dump_riscv_prog oc p with
+ | OK _ -> ()
+ | Error msg -> error := Some msg
+ ) ltl (fun file () ->
+ if !error = None
+ then error := compile_rv basename file ());
match !error with
| Some e -> Error ("RiscV generation error:\n" ^e)
| None ->
@@ -237,13 +237,6 @@ let exec_rv_prog ltl basename oc rvp heapsize params =
OK (Some ret)
with _ -> OK None
-let call_dot report_sectid report_secttitle file () : unit =
- if not !Options.no_dot
- then begin
- let r = Sys.command (Format.sprintf "dot -Tsvg %s -o %s.svg" file file) in
- add_to_report report_sectid report_secttitle (Img (Filename.basename file^".svg"));
- ignore r
- end
let _ =
Arg.parse speclist (fun s -> ()) "Usage";
@@ -267,6 +260,7 @@ let _ =
set_default cfg_dump basename ".cfg";
set_default rtl_dump basename ".rtl";
set_default linear_dump basename ".linear";
+ set_default rig_dump basename ".rig";
set_default ltl_dump basename ".ltl";
end;
@@ -275,89 +269,95 @@ let _ =
) $ fun tokens ->
record_compile_result "Lexing";
dump !show_tokens (fun oc tokens ->
- List.iter (fun (tok,_) ->
- Format.fprintf oc "%s\n" (string_of_symbol tok)
+ List.iter (fun (tok,_) ->
+ Format.fprintf oc "%s\n" (string_of_symbol tok)
) tokens) tokens (fun f () -> add_to_report "lexer" "Lexer" (Code (file_contents f)));
- parse tokens () >>* (fun msg ->
- record_compile_result ~error:(Some msg) "Parsing";
- ) $ fun (ast, tokens) ->
- record_compile_result "Parsing";
- dump !ast_tree draw_ast_tree ast (call_dot "ast" "AST");
- if !ast_dump then Format.printf "%s\n" (string_of_ast ast) else ();
-
- match make_eprog_of_ast ast with
- | Error msg -> record_compile_result ~error:(Some msg) "Elang"
- | OK ep ->
- dump !e_dump dump_e ep (fun file () ->
- add_to_report "e" "E" (Code (file_contents file)));
- run "Elang" !e_run eval_eprog ep;
-
- match cfg_prog_of_eprog ep with
- | Error msg ->
- record_compile_result ~error:(Some msg) "CFG";
- | OK cfg ->
- record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "CFG";
-
- dump !cfg_dump dump_cfg_prog cfg (call_dot "cfg" "CFG");
- run "CFG" !cfg_run eval_cfgprog cfg;
-
- let cfg = optimize_loop_cfg cfg in
- record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "CFG loops";
- dump (!cfg_dump >*> fun s -> s ^ "0") dump_cfg_prog cfg
- (call_dot "cfg-after-loop" "CFG after loop optim");
- run "CFG after loop optim" !cfg_run_after_loop eval_cfgprog cfg;
-
-
- let cfg = constant_propagation cfg in
- record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "Constprop";
- dump (!cfg_dump >*> fun s -> s ^ "1") dump_cfg_prog cfg
- (call_dot "cfg-after-cstprop" "CFG after Constant Propagation");
- run "CFG after constant_propagation" !cfg_run_after_cp eval_cfgprog cfg;
-
- let cfg = dead_assign_elimination cfg in
- record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "DeadAssign";
- dump (!cfg_dump >*> fun s -> s ^ "2") dump_cfg_prog cfg
- (call_dot "cfg-after-dae" "CFG after DAE");
- run "CFG after dead_assign_elimination" !cfg_run_after_dae eval_cfgprog cfg;
-
- let cfg = nop_elimination cfg in
- record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "NopElim";
- dump (!cfg_dump >*> fun s -> s ^ "3") dump_cfg_prog cfg
- (call_dot "cfg-after-nop" "CFG after NOP elim");
- run "CFG after nop_elimination" !cfg_run_after_ne eval_cfgprog cfg;
-
-
- let rtl = rtl_of_cfg cfg in
- dump !rtl_dump dump_rtl_prog rtl
- (fun file () -> add_to_report "rtl" "RTL" (Code (file_contents file)));
- run "RTL" !rtl_run exec_rtl_prog rtl;
-
- let linear = linear_of_rtl rtl in
- let lives = liveness_linear_prog linear in
- dump !linear_dump (fun oc -> dump_linear_prog oc (Some lives)) linear
- (fun file () -> add_to_report "linear" "Linear" (Code (file_contents file)));
- run "Linear" !linear_run exec_linear_prog linear;
-
- let linear = dse_prog linear lives in
- record_compile_result "DSE";
- dump (!linear_dump >*> fun s -> s ^ "1")
- (fun oc -> dump_linear_prog oc (Some lives)) linear
- (fun file () -> add_to_report "linear-after-dse" "Linear after DSE"
- (Code (file_contents file)));
- run "Linear after DSE" !linear_run_after_dse exec_linear_prog linear;
-
- let ltl = ltl_prog_of_linear linear () in
- dump !ltl_dump dump_ltl_prog ltl
- (fun file () -> add_to_report "ltl" "LTL" (Code (file_contents file)));
- run "LTL" !ltl_run (exec_ltl_prog) ltl;
- (if !ltl_debug then debug_ltl_prog input ltl !heapsize !params);
-
- dump !riscv_dump dump_riscv_prog ltl (fun file () ->
- add_to_report "riscv" "RISC-V" (Code (file_contents file));
- ignore (compile_rv basename file ()));
- if not !Options.nostart then begin
- run "Risc-V" !riscv_run (exec_rv_prog ltl basename) !riscv_dump
- end;
+ parse tokens () >>* (fun msg ->
+ record_compile_result ~error:(Some msg) "Parsing";
+ ) $ fun (ast, tokens) ->
+ record_compile_result "Parsing";
+ dump !ast_tree draw_ast_tree ast (call_dot "ast" "AST");
+ if !ast_dump then Format.printf "%s\n" (string_of_ast ast) else ();
+
+ match make_eprog_of_ast ast with
+ | Error msg -> record_compile_result ~error:(Some msg) "Elang"
+ | OK ep ->
+ dump !e_dump dump_e ep (fun file () ->
+ add_to_report "e" "E" (Code (file_contents file)));
+ run "Elang" !e_run eval_eprog ep;
+
+ match cfg_prog_of_eprog ep with
+ | Error msg ->
+ record_compile_result ~error:(Some msg) "CFG";
+ | OK cfg ->
+ record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "CFG";
+
+ dump !cfg_dump dump_cfg_prog cfg (call_dot "cfg" "CFG");
+ run "CFG" !cfg_run eval_cfgprog cfg;
+
+ let cfg = optimize_loop_cfg cfg in
+ record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "CFG loops";
+ dump (!cfg_dump >*> fun s -> s ^ "0") dump_cfg_prog cfg
+ (call_dot "cfg-after-loop" "CFG after loop optim");
+ run "CFG after loop optim" !cfg_run_after_loop eval_cfgprog cfg;
+
+
+ let cfg = constant_propagation cfg in
+ record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "Constprop";
+ dump (!cfg_dump >*> fun s -> s ^ "1") dump_cfg_prog cfg
+ (call_dot "cfg-after-cstprop" "CFG after Constant Propagation");
+ run "CFG after constant_propagation" !cfg_run_after_cp eval_cfgprog cfg;
+
+ let cfg = dead_assign_elimination cfg in
+ record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "DeadAssign";
+ dump (!cfg_dump >*> fun s -> s ^ "2") dump_cfg_prog cfg
+ (call_dot "cfg-after-dae" "CFG after DAE");
+ run "CFG after dead_assign_elimination" !cfg_run_after_dae eval_cfgprog cfg;
+
+ let cfg = nop_elimination cfg in
+ record_compile_result ~data:([(`Assoc (List.map (fun (fname,Prog.Gfun cfgfun) -> (fname, `Int (Cfg.size_fun cfgfun.cfgfunbody))) cfg))]) "NopElim";
+ dump (!cfg_dump >*> fun s -> s ^ "3") dump_cfg_prog cfg
+ (call_dot "cfg-after-nop" "CFG after NOP elim");
+ run "CFG after nop_elimination" !cfg_run_after_ne eval_cfgprog cfg;
+
+
+ let rtl = rtl_of_cfg cfg in
+ dump !rtl_dump dump_rtl_prog rtl
+ (fun file () -> add_to_report "rtl" "RTL" (Code (file_contents file)));
+ run "RTL" !rtl_run exec_rtl_prog rtl;
+
+ let linear = linear_of_rtl rtl in
+ let lives = liveness_linear_prog linear in
+ dump !linear_dump (fun oc -> dump_linear_prog oc (Some lives)) linear
+ (fun file () -> add_to_report "linear" "Linear" (Code (file_contents file)));
+ run "Linear" !linear_run exec_linear_prog linear;
+
+ let linear = dse_prog linear lives in
+ record_compile_result "DSE";
+ dump (!linear_dump >*> fun s -> s ^ "1")
+ (fun oc -> dump_linear_prog oc (Some lives)) linear
+ (fun file () -> add_to_report "linear-after-dse" "Linear after DSE"
+ (Code (file_contents file)));
+ run "Linear after DSE" !linear_run_after_dse exec_linear_prog linear;
+
+ match ltl_prog_of_linear linear with
+ | Error msg -> record_compile_result ~error:(Some msg) "LTL"
+ | OK ltl ->
+ dump !ltl_dump dump_ltl_prog ltl
+ (fun file () -> add_to_report "ltl" "LTL" (Code (file_contents file)));
+ run "LTL" !ltl_run (exec_ltl_prog) ltl;
+ (if !ltl_debug then debug_ltl_prog input ltl !heapsize !params);
+
+ dump !riscv_dump (fun oc p ->
+ match dump_riscv_prog oc p with
+ | OK _ -> ()
+ | Error msg -> record_compile_result ~error:(Some msg) "RISCV"
+ ) ltl (fun file () ->
+ add_to_report "riscv" "RISC-V" (Code (file_contents file));
+ ignore (compile_rv basename file ()));
+ if not !Options.nostart then begin
+ run "Risc-V" !riscv_run (exec_rv_prog ltl basename) !riscv_dump
+ end;
end;
diff --git a/src/options.ml b/src/options.ml
index 53c33dfcf99529e7d6ff99ae59174f270a3d2208..b6bdd51360827630c4e5ca2f18a02186ac4bef2f 100644
--- a/src/options.ml
+++ b/src/options.ml
@@ -32,3 +32,5 @@ let no_dump = ref false
let no_dot = ref false
let alloc_order_st = ref true
+let naive_regalloc = ref true
+let rig_dump : string option ref = ref None
diff --git a/src/regalloc.ml b/src/regalloc.ml
index c0b28144a4752c2753e53e2127e5da0c88252105..f625cce21ab616f7cf2652daaa4481d0e036d6f1 100644
--- a/src/regalloc.ml
+++ b/src/regalloc.ml
@@ -5,27 +5,306 @@ open Prog
open Linear
open Rtl
open Linear_liveness
+open Utils
+open Report
+open Options
+
+
+
+(* Allocation de registres *)
+
+(* Nous allons procéder à l'allocation de registres, par coloration de graphe
+ d'interférences.
+
+ Le but de l'allocateur est d'associer à chaque pseudo-registre utilisé dans
+ une fonction Linear, un emplacement (type [loc]). *)
-type regalloc_decision = Spill of int | NoSpill of int
type loc = Reg of int | Stk of int
+(* Un emplacement (location en anglais) est soit un registre machine (identifié
+ par son numéro [r] entre 0 et 31 inclus) : [Reg r], soit un emplacement sur
+ la pile [Stk o] signifiant un décalage de [o] octets par rapport au pointeur
+ de trame présent dans le registre [s0] (aussi appelé [fp] pour frame
+ pointer). *)
+(* Nous vous fournissons, ci-dessous, une implémentation naïve qui évince tous
+ les pseudo-registres sur la pile. *)
+let regs_in_instr i =
+ Set.union (gen_live i) (kill_live i)
- let regalloc_fun (f: linear_fun) (live_in, live_out) all_colors =
- (Hashtbl.create 0, 0)
+let regs_in_instr_list (l: rtl_instr list) : reg Set.t =
+ List.fold_left
+ (fun acc i -> Set.union acc (regs_in_instr i))
+ Set.empty l
+let regalloc_on_stack_fun (f: linear_fun) : ((reg, loc) Hashtbl.t * int)=
+ let allocation = Hashtbl.create 10 in
+ let regs = regs_in_instr_list f.linearfunbody in
+ let next_stack_slot =
+ List.fold_left (fun next_stack_slot r ->
+ Hashtbl.replace allocation r (Stk (next_stack_slot));
+ next_stack_slot - 1
+ ) 0 (Set.to_list regs) in
+ (allocation, next_stack_slot)
-let regalloc lp lives all_colors =
- let allocations =
- Hashtbl.create 17 in
+(* Nous allons maintenant construire un graphe d'interférence de registres
+ (register interference graph, ou rig). Le type d'un rig est donné par le type
+ OCaml [(reg, reg Set.t) Hashtbl.t], i.e. une table dont les clés sont des
+ registres et les valeurs sont des ensembles de registres qui "interfèrent"
+ avec le registre-clé. Cela correspond à la relation d'adjacence dans le
+ graphe d'interférence. *)
+
+(* La fonction [add_to_interf rig x y] ajoute [y] Ã la liste des registres qui
+ interfèrent avec [x] dans le graphe [rig].
+
+ On pourra utiliser la fonction [Hashtbl.modify_def] qui permet de modifier la
+ valeur associée à une clé.
+
+ Par exemple, l'appel [Hashtbl.modify_def def k f rig] modifie la valeur
+ associée à la clé [k] dans le graphe [rig].
+
+ [f] est une fonction qui prend en entrée l'ancienne valeur, et qui retourne
+ la nouvelle valeur (type ['b -> 'b], si [rig] est de type [('a,'b)
+ Hashtbl.t], i.e. ['b] est le type des valeurs).
+
+ [def] est la valeur par défaut donnée à [f] s'il n'existe pas d'ancienne
+ valeur pour la clé [k].
+
+ Attention, les interférences doivent exister dans les deux sens, i.e. si [x]
+ est dans la liste d'interférence de [y], alors [y] doit être dans la liste
+ d'interférence de [x].
+
+*)
+
+let add_interf (rig : (reg, reg Set.t) Hashtbl.t) (x: reg) (y: reg) : unit =
+ (* TODO *)
+ ()
+
+
+(* [make_interf_live rig live] ajoute des arcs dans le graphe d'interférence
+ pour chaque paire de registres vivants en même temps à un point de programme.
+ *)
+let make_interf_live
+ (rig: (reg, reg Set.t) Hashtbl.t)
+ (live : (int, reg Set.t) Hashtbl.t) : unit =
+ (* TODO *)
+ ()
+
+(* [build_interference_graph live_out] construit, en utilisant les fonctions que
+ vous avez écrites, le graphe d'interférence en fonction de la vivacité des
+ variables à la sortie des nœuds donné par [live_out].
+
+ Offert par la maison !
+*)
+let build_interference_graph (live_out : (int, reg Set.t) Hashtbl.t) : (reg, reg Set.t) Hashtbl.t =
+ let interf = Hashtbl.create 17 in
+ (* On ajoute un sommet pour chaque variable qui apparaît dans le programme. *)
+ Hashtbl.iter (fun _ s ->
+ Set.iter (fun v -> Hashtbl.replace interf v Set.empty) s
+ ) live_out;
+ make_interf_live interf live_out;
+ interf
+
+(* [remove_from_rig rig v] supprime le sommet [v] du graphe d'interférences
+ [rig]. *)
+let remove_from_rig (rig : (reg, reg Set.t) Hashtbl.t) (v: reg) : unit =
+ (* TODO *)
+ ()
+
+
+(* Type représentant les différentes décisions qui peuvent être prises par
+ l'allocateur de registres.
+
+ - [Spill r] signifie que le pseudo-registre [r] sera évincé (spillé) sur la pile.
+
+ - [NoSpill r] signifie que le pseudo-registre [r] sera alloué dans un vrai
+ registre physique.
+*)
+type regalloc_decision =
+ Spill of reg
+ | NoSpill of reg
+
+(* Rappel de l'algorithme d'empilement des registres *)
+
+(* Une fois le graphe d'interférences construit, il nous faut parcourir ce
+ graphe afin de le colorer, avec [n] couleurs. On construit une pile de
+ [regalloc_decision].
+
+ Tant que le graphe n'est pas vide:
+
+ - choisir un sommet [s] avec strictement moins de [n] voisins (ce sera le
+ travail de la fonction [pick_node_with_fewer_than_n_neighbors]), empiler la
+ décision [NoSpill s] et retirer [s] du graphe.
+
+ - si aucun tel sommet n'existe dans le graphe, choisir un sommet [s]
+ correspondant à un registre que l'on évincera (ce sera le travail de la
+ fonction [pick_spilling_candidate]). Empiler la décision [Spill s] et retirer
+ [s] du graphe.
+
+*)
+
+(* [pick_node_with_fewer_than_n_neighbors rig n] choisit un nœud du graphe [rig]
+ possédant strictement moins de [n] voisins. Retourne [None] si aucun sommet
+ ne satisfait cette condition. *)
+let pick_node_with_fewer_than_n_neighbors (rig : (reg, reg Set.t) Hashtbl.t) (n: int) : reg option =
+ (* TODO *)
+ None
+
+(* Lorsque la fonction précédente échoue (i.e. aucun sommet n'a moins de [n]
+ voisins), on choisit un pseudo-registre à évincer.
+
+ Une heuristique possible consiste à évincer le pseudo-registre qui a le plus
+ de voisins dans le graphe [rig].
+
+ [pick_spilling_candidate rig] retourne donc le pseudo-registre [r] qui a le
+ plus de voisins dans [rig], ou [None] si [rig] est vide. *)
+let pick_spilling_candidate (rig : (reg, reg Set.t) Hashtbl.t) : reg option =
+ (* TODO *)
+ None
+
+(* [make_stack rig stack ncolors] construit la pile, selon l'algorithme vu en
+ cours (slides 60 Ã 63 du cours "Allocation de registres - Autres slides"
+ présent sur Edunao.) *)
+let rec make_stack (rig : (reg, reg Set.t) Hashtbl.t) (stack : regalloc_decision list) (ncolors: int) : regalloc_decision list =
+ (* TODO *)
+ stack
+
+(* Maintenant que nous avons une pile de [regalloc_decision], il est temps de
+ colorer notre graphe, i.e. associer une couleur (un numéro de registre
+ physique) Ã chaque pseudo-registre. Nous allons parcourir la pile et pour
+ chaque décision :
+
+ - Â [Spill r] : associer un emplacement sur la pile au pseudo-registre [r]. On
+ choisira l'emplacement [next_stack_slot].
+
+ - [NoSpill r] : associer une couleur (un registre) physique au
+ pseudo-registre [r]. On choisira une couleur qui n'est pas déjà associée à un
+ voisin de [r] dans [rig].
+
+ Cette fonction prend en entrée :
+
+ - [allocation] : l'allocation courante, que l'on mettra à jour, et qui
+ permettra de trouver les couleurs qui ne sont pas déjà associées à des
+ voisins.
+
+ - [rig] : le graphe d'interférence, qui permettra de connaître les voisins
+ d'un registre.
+
+ - [all_colors] : l'ensemble des couleurs que l'on peut allouer.
+
+ - [next_stack_slot] : le prochain emplacement disponible sur la pile. Cela
+ représentera des offsets négatifs par rapport à fp, on le mettra donc à jour
+ en décrémentant cette valeur de 1.
+
+ - [decision] : une décision parmi celles empilées.
+
+ Cette fonction met à jour [allocation] et renvoie la nouvelle valeur de
+ [next_stack_slot].
+
+*)
+let allocate (allocation: (reg, loc) Hashtbl.t) (rig: (reg, reg Set.t) Hashtbl.t)
+ (all_colors: int Set.t)
+ (next_stack_slot: int) (decision: regalloc_decision)
+ : int =
+ (* TODO *)
+ next_stack_slot
+
+(* [regalloc_fun f live_out all_colors] effectue l'allocation de registres pour
+ la fonction [f].
+
+ - [live_out] est un mapping des numéros d'instructions dans la fonction
+ Linear vers l'ensemble des registres vivants après cette instruction.
+
+ - [all_colors] est l'ensemble des registres que l'on pourra utiliser.
+
+ Cette fonction renvoie un triplet [(rig, allocation, next_stack_slot)] :
+
+ - [rig] est le graphe d'interférences (simplement pour l'affichage)
+
+ - [allocation] est l'allocation de registre que vous aurez construit
+
+ - [next_stack_slot] est le prochain emplacement disponible sur la pile
+ (utilisé dans [ltl_gen], qui vous est fourni.)
+*)
+let regalloc_fun (f: linear_fun)
+ (live_out: (int, reg Set.t) Hashtbl.t)
+ (all_colors: int Set.t) :
+ (reg, reg Set.t) Hashtbl.t (* the RIG *)
+ * (reg, loc) Hashtbl.t (* the allocation *)
+ * int (* the next stack slot *)
+ =
+ let rig = build_interference_graph live_out in
+ let allocation = Hashtbl.create 17 in
+ (* Les pseudo-registres qui contiennent les arguments sont traités séparément
+ dans [ltl_gen.ml]. On les enlève donc du graphe. *)
+ List.iter (fun p -> remove_from_rig rig p) f.linearfunargs;
+ (* On effectue une copie [g] du graphe d'interférence [rig]. En effet, comme
+ on va supprimer des sommets du graphe, on perd l'information
+ d'interférence, dont on aura besoin pour effectuer la coloration. *)
+ let g = Hashtbl.copy rig in
+ let stack = make_stack g [] (Set.cardinal all_colors) in
+ let next_stack_slot =
+ List.fold_left (fun next_stack_slot decision ->
+ allocate allocation rig all_colors next_stack_slot decision
+ ) 0 stack in
+ (rig, allocation, next_stack_slot)
+
+
+(* [dump_interf_graph fname rig] affiche les interférences associées à chaque
+ registre. Peut être utile pour le débogage ! Pas besoin d'inspecter cette
+ fonction, à moins qu'elle soit buggée... :-) *)
+let dump_interf_graph oc (fname, rig, allocation) =
+ let colors = Array.of_list [
+ "blue"; "red"; "orange"; "pink"; "green"; "purple";
+ "brown"; "turquoise"; "gray"; "gold"; "darkorchid"; "bisque";
+ "darkseagreen"; "cornsilk"; "burlywood"; "dodgerblue"; "antiquewhite"; "firebrick";
+ "deepskyblue"; "darkolivegreen"; "hotpink"; "lightsalmon"; "magenta"; "lawngreen";
+ ] in
+ let color_of_allocation r =
+ match Hashtbl.find_option allocation r with
+ | Some (Reg r) ->
+ Array.get colors (r mod Array.length colors)
+ | _ -> "white"
+ in
+ Format.fprintf oc "subgraph cluster_%s{\n" fname;
+ Format.fprintf oc "label=\"%s\";\n" fname;
+ Hashtbl.keys rig |> Enum.iter (fun r ->
+ Format.fprintf oc "r%d [style=filled,fillcolor=\"%s\"];\n" r (color_of_allocation r)
+ );
+ Hashtbl.iter
+ (fun i s ->
+ Set.iter (fun x ->
+ Format.fprintf oc "r%d -> r%d;\n" i x
+ ) s;)
+ rig;
+ Format.fprintf oc "}\n"
+
+let dump_interf_graphs oc allocations =
+ Format.fprintf oc "digraph RIGS {\n";
+ Hashtbl.iter (fun fname (rig, allocation, next_stack_slot) ->
+ dump_interf_graph oc (fname, rig, allocation)
+ ) allocations;
+ Format.fprintf oc "}\n"
+
+(* On applique l'allocation de registres à tout le programme Linear, et on
+ affiche tout ça dans le rapport (la page HTML de chaque fichier). *)
+let regalloc lp lives all_colors =
+ let allocations = Hashtbl.create 17 in
List.iter (function (fname,Gfun f) ->
begin match Hashtbl.find_option lives fname with
| Some (live_in, live_out) ->
- let (allocation, curstackslot) = regalloc_fun f (live_in, live_out) all_colors in
- Hashtbl.replace allocations fname (allocation, curstackslot)
+ let (rig, allocation, curstackslot) =
+ if !Options.naive_regalloc
+ then let (al, nss) = regalloc_on_stack_fun f in
+ (Hashtbl.create 0, al, nss)
+ else regalloc_fun f live_out all_colors
+ in
+ Hashtbl.replace allocations fname (rig, allocation, curstackslot)
| None -> ()
end
) lp;
+ dump !Options.rig_dump dump_interf_graphs allocations
+ (call_dot "regalloc" "Register Allocation");
allocations
diff --git a/src/report.ml b/src/report.ml
index 8c2d2281654805228eb2bc096affc3759df4e2c9..b60bb9c5a854c1b56c1ae7bba4906d8c5cb27730 100644
--- a/src/report.ml
+++ b/src/report.ml
@@ -37,3 +37,11 @@ let make_report filename report () =
!report;
close_out html;
()
+
+let call_dot report_sectid report_secttitle file () : unit =
+ if not !Options.no_dot
+ then begin
+ let r = Sys.command (Format.sprintf "dot -Tsvg %s -o %s.svg" file file) in
+ add_to_report report_sectid report_secttitle (Img (Filename.basename file^".svg"));
+ ignore r
+ end
diff --git a/src/riscv.ml b/src/riscv.ml
index b4f85ae85b9296e34a93f26ff7e31fae07a3b29a..ca9dd36e550739e238720ef82273f8d55361d74e 100644
--- a/src/riscv.ml
+++ b/src/riscv.ml
@@ -58,52 +58,100 @@ let print_unop (u: unop) =
let instrsuffix_of_size sz =
match !Archi.archi, sz with
- | _, 1 -> 'b'
- | _, 4 -> 'w'
- | A64, 8 -> 'd'
+ | _, 1 -> OK 'b'
+ | _, 4 -> OK 'w'
+ | A64, 8 -> OK 'd'
| _, _ ->
- failwith (Format.sprintf "Impossible write size (%d) in archi (%d)"
+ Error (Format.sprintf "Impossible write size (%d) in archi (%d)"
sz !Archi.nbits)
let dump_riscv_instr oc (i: ltl_instr) =
match i with
| LAddi(rd, rs, i) ->
- Format.fprintf oc "addi %s, %s, %d\n" (print_reg rd) (print_reg rs) i
+ Format.fprintf oc "addi %s, %s, %d\n" (print_reg rd) (print_reg rs) i;
+ OK ()
| LSubi(rd, rs, i) ->
- Format.fprintf oc "addi %s, %s, %d\n" (print_reg rd) (print_reg rs) (-i)
+ Format.fprintf oc "addi %s, %s, %d\n" (print_reg rd) (print_reg rs) (-i);
+ OK ()
| LBinop(b, rd, rs1, rs2) ->
- (* TODO *)
- Format.fprintf oc "%s %s, %s, %s\n"
- (print_binop b) (print_reg rd) (print_reg rs1) (print_reg rs2)
+ begin match b with
+ | Elang.Eclt ->
+ Format.fprintf oc "slt %s, %s, %s\n"
+ (print_reg rd) (print_reg rs1) (print_reg rs2);
+ OK ()
+ | Elang.Ecgt ->
+ Format.fprintf oc "slt %s, %s, %s\n"
+ (print_reg rd) (print_reg rs2) (print_reg rs1);
+ OK ()
+ | Elang.Ecle ->
+ (* 'rd <- rs1 <= rs2' == 'rd <- rs2 < rs1; rd <- not rd' *)
+ Format.fprintf oc "slt %s, %s, %s\n"
+ (print_reg rd) (print_reg rs2) (print_reg rs1);
+ Format.fprintf oc "not %s, %s\n"
+ (print_reg rd) (print_reg rd);
+ OK ()
+ | Elang.Ecge ->
+ Format.fprintf oc "slt %s, %s, %s\n"
+ (print_reg rd) (print_reg rs1) (print_reg rs2);
+ Format.fprintf oc "not %s, %s\n"
+ (print_reg rd) (print_reg rd);
+ OK ()
+ | Elang.Eceq ->
+ Format.fprintf oc "sub %s, %s, %s\n"
+ (print_reg rd) (print_reg rs1) (print_reg rs2);
+ Format.fprintf oc "seqz %s, %s\n"
+ (print_reg rd) (print_reg rd);
+ OK ()
+ | Elang.Ecne ->
+ Format.fprintf oc "sub %s, %s, %s\n"
+ (print_reg rd) (print_reg rs1) (print_reg rs2);
+ Format.fprintf oc "snez %s, %s\n"
+ (print_reg rd) (print_reg rd);
+ OK ()
+ | _ -> Format.fprintf oc "%s %s, %s, %s\n"
+ (print_binop b) (print_reg rd) (print_reg rs1) (print_reg rs2);
+ OK ()
+ end
| LUnop(u, rd, rs) ->
Format.fprintf oc "%s %s, %s\n"
- (print_unop u) (print_reg rd) (print_reg rs)
+ (print_unop u) (print_reg rd) (print_reg rs); OK ()
| LStore(rt, i, rs, sz) ->
- Format.fprintf oc "s%c %s, %d(%s)\n"
- (instrsuffix_of_size sz) (print_reg rs) i (print_reg rt)
+ (instrsuffix_of_size sz) >>= fun sz ->
+ OK (Format.fprintf oc "s%c %s, %d(%s)\n"
+ sz (print_reg rs) i (print_reg rt))
| LLoad(rd, rt, i, sz) ->
+ (instrsuffix_of_size sz) >>= fun sz ->
Format.fprintf oc "l%c %s, %d(%s)\n"
- (instrsuffix_of_size sz) (print_reg rd) i (print_reg rt)
+ sz (print_reg rd) i (print_reg rt); OK ()
| LMov(rd, rs) ->
- Format.fprintf oc "mv %s, %s\n" (print_reg rd) (print_reg rs)
+ Format.fprintf oc "mv %s, %s\n" (print_reg rd) (print_reg rs);
+ OK ()
| LLabel l ->
- Format.fprintf oc "%s:\n" l
- | LJmp l -> Format.fprintf oc "j %s\n" l
- | LJmpr r -> Format.fprintf oc "jr %s\n" (print_reg r)
- | LConst (rd, i) -> Format.fprintf oc "li %s, %d\n\n" (print_reg rd) i
- | LComment l -> Format.fprintf oc "# %s\n" l
+ Format.fprintf oc "%s:\n" l;
+ OK ()
+ | LJmp l -> Format.fprintf oc "j %s\n" l;
+ OK ()
+ | LJmpr r -> Format.fprintf oc "jr %s\n" (print_reg r);
+ OK ()
+ | LConst (rd, i) -> Format.fprintf oc "li %s, %d\n\n" (print_reg rd) i;
+ OK ()
+ | LComment l -> Format.fprintf oc "# %s\n" l;
+ OK ()
| LBranch(cmp, rs1, rs2, s) ->
Format.fprintf oc "%s %s, %s, %s\n"
- (riscv_of_cmp cmp) (print_reg rs1) (print_reg rs2) s
+ (riscv_of_cmp cmp) (print_reg rs1) (print_reg rs2) s;
+ OK ()
| LCall fname ->
- Format.fprintf oc "jal ra, %s\n" fname
- | LHalt -> Format.fprintf oc "halt\n"
+ Format.fprintf oc "jal ra, %s\n" fname;
+ OK ()
+ | LHalt -> Format.fprintf oc "halt\n";
+ OK ()
let dump_riscv_fun oc (fname , lf) =
Format.fprintf oc "%s:\n" fname;
- List.iter (dump_riscv_instr oc) lf.ltlfunbody
+ list_iter_res (dump_riscv_instr oc) lf.ltlfunbody
-let riscv_load_args oc =
+let riscv_load_args oc : unit res =
let nargs = [1;2;3;4;5;6;7;8] in
(* for each arg in [1..8]:
a0 <- arg
@@ -126,7 +174,7 @@ let riscv_load_args oc =
List.map (fun i ->
[LLoad(starting_arg_register + i - 1, reg_fp,
- !Archi.wordsize*i, !Archi.wordsize)]) in
- (l1 @ l2) |> List.concat |> List.iter (fun i -> dump_riscv_instr oc i)
+ (l1 @ l2) |> List.concat |> list_iter_res (fun i -> dump_riscv_instr oc i)
let riscv_fun_load_arg oc () =
@@ -163,7 +211,7 @@ let riscv_prelude oc =
Format.fprintf oc " %s t0, 0(gp)\n" (rv_store ());
Format.fprintf oc " mv s0, sp\n";
Format.fprintf oc " add sp, sp, -72\n";
- riscv_load_args oc;
+ riscv_load_args oc >>= fun _ ->
Format.fprintf oc "jal ra, main\n";
Format.fprintf oc "mv s0, a0\n";
Format.fprintf oc "jal ra, println\n";
@@ -171,12 +219,13 @@ let riscv_prelude oc =
Format.fprintf oc "jal ra, print_int\n";
Format.fprintf oc "jal ra, println\n";
Format.fprintf oc "addi a7, zero, 93\n";
- Format.fprintf oc "ecall\n"
+ Format.fprintf oc "ecall\n";
+ OK ()
-let dump_riscv_prog oc lp =
- if !nostart then () else riscv_prelude oc;
+let dump_riscv_prog oc lp : unit res =
+ if !nostart then OK () else riscv_prelude oc >>= fun _ ->
Format.fprintf oc ".global main\n";
- List.iter (function
+ list_iter_res (function
(fname, Gfun f) -> dump_riscv_fun oc (fname,f)
- ) lp;
+ ) lp >>= fun _ ->
riscv_fun_load_arg oc ()
diff --git a/src/rtl_print.ml b/src/rtl_print.ml
index 15d4ca117fdee3127656c0d86caccf18d8794d8c..c8ed813944d2722f5266a043b1af819e2d321860 100644
--- a/src/rtl_print.ml
+++ b/src/rtl_print.ml
@@ -19,6 +19,13 @@ let print_cmpop (r: rtl_cmp) =
let dump_rtl_instr name (live_in, live_out) oc (i: rtl_instr) =
let print_node s = Format.sprintf "%s_%d" name s in
+
+ let dump_liveness live where =
+ match live with
+ Some live -> Format.fprintf oc "// Live %s : { %s }\n" where (String.concat ", " (Set.to_list (Set.map string_of_int live)))
+ | None -> ()
+ in
+ dump_liveness live_in "before";
begin match i with
| Rbinop (b, rd, rs1, rs2) ->
Format.fprintf oc "%s <- %s(%s, %s)" (print_reg rd) (dump_binop b) (print_reg rs1) (print_reg rs2)
@@ -35,7 +42,8 @@ let dump_rtl_instr name (live_in, live_out) oc (i: rtl_instr) =
| Rprint r -> Format.fprintf oc "print %s" (print_reg r)
| Rlabel n -> Format.fprintf oc "%s_%d:" name n
end;
- Format.fprintf oc "\n"
+ Format.fprintf oc "\n";
+ dump_liveness live_out "after"
let dump_rtl_node name lives =
print_listi (fun i ->
diff --git a/src/utils.ml b/src/utils.ml
index 3b1b122340e4ba34b0e8abe98c26e4a55ba80196..f77987931e59a1b128afee4223dfeb4d7776b9c3 100644
--- a/src/utils.ml
+++ b/src/utils.ml
@@ -246,6 +246,21 @@ let list_map_res f l =
OK (acc@[e])
) (OK []) l
+
+let list_map_resi f l =
+ List.fold_lefti (fun acc i e ->
+ acc >>= fun acc ->
+ f i e >>= fun e ->
+ OK (acc@[e])
+ ) (OK []) l
+
+let rec list_iter_res f l =
+ match l with
+ [] -> OK ()
+ | a::r ->
+ f a >>= fun _ ->
+ list_iter_res f r
+
let assoc_err ?word:(word="item") k l =
match List.assoc_opt k l with
| Some v -> OK v
@@ -286,3 +301,19 @@ let string_of_int_option v =
match v with
| None -> "undef"
| Some x -> string_of_int x
+
+
+let dump file (dumpf : _ -> 'a -> unit) (p: 'a) (additional_command: string -> unit -> unit) =
+ begin match file with
+ | None -> ()
+ | Some file ->
+ let oc, close =
+ if file = "-"
+ then (Format.std_formatter, fun _ -> ())
+ else
+ let oc = open_out file in
+ (Format.formatter_of_out_channel oc, fun () -> close_out oc)
+ in
+ dumpf oc p; close ();
+ if file <> "-" then additional_command file ()
+ end
diff --git a/tests/Makefile b/tests/Makefile
index b740fda1fe88bd18652f50caedd20faf247bd4b6..1169a467d9d8cd7129f7bd2876692dbbdbe879ea 100644
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -8,9 +8,5 @@ all: ../main.native
./test.py $(OPTS)
clean:
- find . -name *.ltl -or -name *.cfg -or -name *.exe -or -name *.s -or -name \
- *.rtl -or -name *.ast -or -name *.cfg0 -or -name *.cfg1 -or -name *.cfg2 -or \
- -name *.riscv -or -name *.dump -or -name *.linear1 -or -name *.linear -or \
- -name *.html -or -name *.svg -or -name *.html -or -name *.lex | xargs -I{} rm \
- {}
+ find . -name '*.ltl' -or -name '*.cfg' -or -name '*.exe' -or -name '*.s' -or -name '*.rtl' -or -name '*.ast' -or -name '*.cfg0' -or -name '*.cfg1' -or -name '*.cfg2' -or -name '*.cfg3' -or -name '*.riscv' -or -name '*.dump' -or -name '*.linear1' -or -name '*.linear' -or -name '*.html' -or -name '*.svg' -or -name '*.html' -or -name '*.lex' -or -name "*.json" | xargs -I{} rm {}
rm -rf __pycache__
diff --git a/tests/basic/arg-test.e b/tests/basic/arg-test.e
new file mode 100644
index 0000000000000000000000000000000000000000..a265d644923b1ca6ded782d8faeb94756d90c0f6
--- /dev/null
+++ b/tests/basic/arg-test.e
@@ -0,0 +1,14 @@
+main(n, m){
+ a = 10;
+ b = 20;
+ if (3 > n){
+ x = a;
+ } else {
+ x = b;
+ }
+ return x;
+}
+f(x){
+ n = 3;
+ return 3 * x;
+}
diff --git a/tests/basic/arg-test.e.expect_14_12_3_8_12 b/tests/basic/arg-test.e.expect_14_12_3_8_12
new file mode 100644
index 0000000000000000000000000000000000000000..4de51e4d38522a71a09ab4c411d09d99f1e80932
--- /dev/null
+++ b/tests/basic/arg-test.e.expect_14_12_3_8_12
@@ -0,0 +1 @@
+{"output": "", "error": null, "retval": 20}
\ No newline at end of file
diff --git a/tests/basic/arg-test.e.expect_1_2_3 b/tests/basic/arg-test.e.expect_1_2_3
new file mode 100644
index 0000000000000000000000000000000000000000..4de51e4d38522a71a09ab4c411d09d99f1e80932
--- /dev/null
+++ b/tests/basic/arg-test.e.expect_1_2_3
@@ -0,0 +1 @@
+{"output": "", "error": null, "retval": 20}
\ No newline at end of file
diff --git a/tests/basic/lots-of-regs.e b/tests/basic/lots-of-regs.e
new file mode 100644
index 0000000000000000000000000000000000000000..2495c7855016762430ba4f6927e798d036f0f723
--- /dev/null
+++ b/tests/basic/lots-of-regs.e
@@ -0,0 +1,21 @@
+main(a, b){
+ x = a;
+ y = b;
+ z = a * b;
+ t = a + b + z;
+ u = z - 3;
+ v = x - u;
+ w = a * x + z - t;
+ i = 35;
+ j = i * w;
+ k = 8 * t + z / i;
+ l = 19 * k;
+ m = 12;
+ n = 12;
+ o = 12;
+ p = 12;
+ q = 12;
+ r = 12;
+ s = 12;
+ return x + y + z + t + u + v + w + i + j + k + l + m + n + o + p + q + r + s;
+}
diff --git a/tests/basic/lots-of-regs.e.expect_14_12_3_8_12 b/tests/basic/lots-of-regs.e.expect_14_12_3_8_12
new file mode 100644
index 0000000000000000000000000000000000000000..36bc30ad8e3a677ef8d97fda646b7d615463399b
--- /dev/null
+++ b/tests/basic/lots-of-regs.e.expect_14_12_3_8_12
@@ -0,0 +1 @@
+{"output": "", "error": null, "retval": 37761}
\ No newline at end of file
diff --git a/tests/basic/lots-of-regs.e.expect_1_2_3 b/tests/basic/lots-of-regs.e.expect_1_2_3
new file mode 100644
index 0000000000000000000000000000000000000000..0f7c0dd6058a095a430101f739d92a8259ed714c
--- /dev/null
+++ b/tests/basic/lots-of-regs.e.expect_1_2_3
@@ -0,0 +1 @@
+{"output": "", "error": null, "retval": 858}
\ No newline at end of file