Dernière mise à jour du sujet avant le premier TP de 2021

src/Makefile

@@ -16,12 +16,15 @@ all: $(TG)
 $(TG): $(SRC)
 	ocamlbuild $(PROF) -cflags  -warn-error,"+a-26" -cflags -w,"-26" -use-ocamlfind $(TG)
 
-test_lexer: $(SRC)
+test_lexer: archi.ml config.ml e_regexp.ml lexer_generator.ml symbols.ml test_lexer.ml utils.ml
 	ocamlbuild -use-ocamlfind test_lexer.native
 	./test_lexer.native
 	dot -Tsvg /tmp/dfa.dot -o /tmp/dfa.svg
 	dot -Tsvg /tmp/nfa.dot -o /tmp/nfa.svg
 
+config.ml: ../configure
+	cd .. && ./configure
+
 clean:
 	rm -rf _build
-	rm -f config.ml main.native
+	rm -f config.ml main.native test_lexer.native

src/cfg_constprop.ml

@@ -48,7 +48,9 @@ let constant_propagation_gdef = function
     Gfun (constant_propagation_fun f)
 
 let constant_propagation p =
-  assoc_map constant_propagation_gdef p
+  if !Options.no_cfg_constprop
+  then p
+  else assoc_map constant_propagation_gdef p
 
 let pass_constant_propagation p =
   let cfg = constant_propagation p in

src/cfg_dead_assign.ml

@@ -34,7 +34,9 @@ let dead_assign_elimination_gdef = function
     Gfun f -> Gfun (iter_dead_assign_elimination_fun f)
 
 let dead_assign_elimination p =
-  assoc_map dead_assign_elimination_gdef p
+  if !Options.no_cfg_dae
+  then p
+  else assoc_map dead_assign_elimination_gdef p
 
 let pass_dead_assign_elimination cfg =
   let cfg = dead_assign_elimination cfg in

src/cfg_loops.ml

-open Batteries
-open Elang
-open Cfg_gen
-open Cfg_print
-open Cfg_liveness
-open Cfg
-open Utils
-open Prog
-
-
-let optimize_loop_cfg cfg = cfg

src/cfg_nop_elim.ml

@@ -79,8 +79,9 @@ let nop_elim_gdef gd =
     Gfun f -> Gfun (nop_elim_fun f)
 
 let nop_elimination cp =
-  assoc_map nop_elim_gdef cp
-
+  if !Options.no_cfg_ne
+  then cp
+  else assoc_map nop_elim_gdef cp
 
 let pass_nop_elimination cfg =
   let cfg = nop_elimination cfg in

src/e_regexp.ml

@@ -55,6 +55,8 @@ let lowercase_letters = "abcdefghijklmnopqrstuvwxyz"
 let uppercase_letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 let digits = "0123456789"
 let other_characters = "?!=<>_ :;,{}()[]^`-+*/%@\n\t\x00.\"\'\\|~#$&"
+
+(* L'opérateur ^ dénote la concaténation des chaînes de caractères. *)
 let alphabet = char_list_of_string (lowercase_letters ^ uppercase_letters ^ digits ^ other_characters)
 let letter_regexp = char_range (char_list_of_string (uppercase_letters ^ lowercase_letters))
 let digit_regexp = char_range (char_list_of_string digits)
@@ -62,7 +64,7 @@ let identifier_material = char_range (char_list_of_string (uppercase_letters ^ l
 let keyword_regexp s = str_regexp (char_list_of_string s)
 
 (* La liste des expressions régulières permettant d'identifier les tokens du langage E *)
-let list_regexp =
+let list_regexp : (regexp * (string -> token option)) list =
   [
     (keyword_regexp "while",    fun s -> Some (SYM_WHILE));
     (keyword_regexp "int", fun s -> Some (SYM_INT));

src/elang_gen.ml

 open Ast
 open Elang
 open Prog
-open Utils
 open Report
-open Elang_print
 open Options
+open Batteries
+open Elang_print
+open Utils
 
 let tag_is_binop =
   function

src/lexer_generator.ml

@@ -64,7 +64,7 @@ let star_nfa n t =
    que l'expression régulière [r].
    [freshstate] correspond à un entier pour lequel il n'y a pas encore d'état dans 
    le nfa. Il suffit d'incrémenter [freshstate] pour obtenir de nouveaux états non utilisés.
-   [t] est une fonction du type [string -> token option] utile pour les état finaux.
+   [t] est une fonction du type [string -> token option] utile pour les états finaux.
 *)
 let rec nfa_of_regexp r freshstate t =
   match r with

src/linear_dse.ml

@@ -7,6 +7,7 @@ open Prog
 open Utils
 open Report
 open Linear_print
+open Report
 open Options
 
 let dse_instr (ins: rtl_instr) live =
@@ -22,6 +23,9 @@ let dse_fun live {linearfunargs; linearfunbody; linearfuninfo; } =
 
 
 let dse_prog p live =
+  if !Options.no_linear_dse
+  then p
+  else
   List.map (fun (fname,gdef) ->
       match gdef with
         Gfun f ->

src/ltl_gen.ml

@@ -278,6 +278,7 @@ let caller_save live_out allocation rargs =
    registers are saved at [fp - 8 * (curstackslot + 1)] *)
 let ltl_instrs_of_linear_instr fname live_out allocation
     numspilled epilogue_label ins =
+  let res =
   match ins with
   | Rbinop (b, rd, rs1, rs2) ->
     load_loc reg_tmp1 allocation rs1 >>= fun (l1, r1) ->
@@ -322,6 +323,9 @@ let ltl_instrs_of_linear_instr fname live_out allocation
     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)]
+  in
+  res >>= fun l ->
+  OK (LComment (Format.asprintf "#<span style=\"background: pink;\"><b>Linear instr</b>: %a #</span>" (Rtl_print.dump_rtl_instr fname (None, None)) ins)::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. *)

src/ltl_print.ml

@@ -93,7 +93,7 @@ let dump_ltl_instr oc (i: ltl_instr) =
   | LJmp l -> Format.fprintf oc "j %s" l
   | LJmpr r -> Format.fprintf oc "jmpr %s" (print_reg r)
   | LConst (rd, i) -> Format.fprintf oc "%s <- %d" (print_reg rd) i
-  | LComment l -> Format.fprintf oc "; %s" l
+  | LComment l -> Format.fprintf oc "<span style=\"color: gray;\">; %s</span>" l
   | LBranch(cmp, rs1, rs2, s) ->
     Format.fprintf oc "%s(%s,%s) ? j %s"
       (print_cmpop cmp) (print_reg rs1) (print_reg rs2) s

src/options.ml

@@ -7,7 +7,6 @@ let e_dump : string option ref = ref None
 let e_run = ref false
 let cfg_dump : string option ref = ref None
 let cfg_run = ref false
-let cfg_run_after_loop = ref false
 let cfg_run_after_cp = ref false
 let cfg_run_after_dae = ref false
 let cfg_run_after_ne = ref false

src/prog.ml

+open Batteries
 open Utils
 
-
 type mem_access_size =
   | MAS1
   | MAS4
@@ -61,7 +61,7 @@ let set_val env v i =
   Hashtbl.replace env v i
 
 let get_val env v =
-  Hashtbl.find_opt env v
+  Hashtbl.find_option env v
 
 let find_function (ep: 'a prog) fname : 'a res =
   match List.assoc_opt fname ep with

src/regalloc.ml

@@ -99,13 +99,24 @@ let make_interf_live
 
    Offert par la maison !
 *)
-let build_interference_graph (live_out : (int, reg Set.t) Hashtbl.t) : (reg, reg Set.t) Hashtbl.t  =
+let build_interference_graph (live_out : (int, reg Set.t) Hashtbl.t) code : (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;
+(* Les registres dans lesquels on écrit mais qui ne sont jamais vivants doivent être considérés comme en interférence avec tous les autres. *)
+  let written_regs = written_rtl_regs code in
+  let written_regs_never_live =
+    Hashtbl.fold (fun _ regset_live_together acc -> Set.diff acc regset_live_together) live_out
+      written_regs in
+  let other_regs = Hashtbl.keys interf |> Set.of_enum in
+  Set.iter (fun r ->
+      Set.iter (fun r_other ->
+          add_interf interf r r_other
+        ) other_regs
+    ) written_regs_never_live;
   interf
 
 (* [remove_from_rig rig v] supprime le sommet [v] du graphe d'interférences
@@ -236,7 +247,8 @@ let regalloc_fun (f: linear_fun)
   * (reg, loc) Hashtbl.t          (* the allocation *)
   * int                         (* the next stack slot *)
   =
-  let rig = build_interference_graph live_out in
+  let rig = build_interference_graph live_out f.linearfunbody 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. *)

src/rtl.ml

@@ -24,3 +24,19 @@ type rtl_fun = { rtlfunargs: reg list;
                  rtlfunentry: int;
                  rtlfuninfo: (string*reg) list
                }
+
+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 written_rtl_regs (l: rtl_instr list) =
+  List.fold_left (fun acc i -> Set.union acc (written_rtl_regs_instr i))
+    Set.empty l

src/symbols.ml

@@ -55,6 +55,7 @@ type token =
  | SYM_PRINT
  | SYM_EXTERN
  | SYM_INCLUDE of string
+ | SYM_AMPERSAND
 
 let string_of_symbol = function
 | SYM_EOF -> "SYM_EOF"
@@ -103,3 +104,4 @@ let string_of_symbol = function
 | SYM_PRINT -> "SYM_PRINT"
 | SYM_EXTERN -> "SYM_EXTERN"
 | SYM_INCLUDE(s) -> Printf.sprintf "SYM_INCLUDE(%s)" s
+| SYM_AMPERSAND -> "SYM_AMPERSAND"

src/utils.ml

@@ -74,8 +74,6 @@ let write_mem_bytes mem addr bl =
       with _ -> Error (Format.sprintf "Problem when writing mem at address %d\n" ofs)
     ) (OK [])
 
-(* let write_mem_int mem addr v =
- *   split_bytes !Archi.wordsize v |> rev |> write_mem_bytes mem addr *)
 
 let write_mem_char mem addr c = write_mem_bytes mem addr [c]