src/regalloc.ml

 open Batteries
-open BatList
-open BatEnum
 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 regs = Set.diff regs (Set.of_list f.linearfunargs) 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
+      ) (-1) (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) 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
+   [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 (slide 26 du cours "Allocation de registres"
+   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 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. *)
+  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
+      ) (-1) 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 "%s_r%d [label=\"r%d\",style=filled,fillcolor=\"%s\"];\n" fname r r (color_of_allocation r)
+    );
+  Hashtbl.iter
+    (fun i s ->
+       Set.iter (fun x ->
+           Format.fprintf oc "%s_r%d -> %s_r%d;\n" fname i fname 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

src/report.ml

+open Options
+open Utils
 
 type html_node =
   | Img of string
@@ -23,17 +25,185 @@ let add_to_report id title content =
 
 let make_report filename report () =
   let html = open_out (filename ^ ".html") in
-  Printf.fprintf html "<ul id=\"top\">";
+  Printf.fprintf html "\
+<html>\n\
+    <head>\n\
+            <link rel=\"stylesheet\" href=\"https://www.w3schools.com/w3css/4/w3.css\">\n\
+    <script src=\"https://kit.fontawesome.com/1f5d81749b.js\" crossorigin=\"anonymous\"></script>\n\
+    <style type=\"text/css\">\n\
+    a.anchor {\n\
+      display: block; \
+      position: relative; \
+      left: -250px; \
+    visibility: hidden;\
+    }\n\
+    </style>\n\
+    </head>\n\
+    <body>\n\
+";
+  Printf.fprintf html "<div \
+                       class=\"w3-container w3-cell\" \
+                       style=\"position: fixed; z-index: 1; top: 0; bottom: 0; width: 250px; overflow-y: scroll;\"\
+                       >\n  <ul class=\"w3-ul\">\n";
+  let t = Unix.time () in
+  let tm = Unix.localtime t in
+  let open Unix in
+  Printf.fprintf html "<li>%02d/%02d/%04d - %02dh%02d</li>"
+    tm.tm_mday
+    (tm.tm_mon + 1)
+    (tm.tm_year + 1900)
+    tm.tm_hour
+    tm.tm_min
+  ;
+  Printf.fprintf html "  <li><a href=\"../results.html\"><i class=\"fa fa-home\"></i> Results</a></li>\n";
   List.iter
-    (fun { sect_id; sect_title  } ->
-       Printf.fprintf html "<li><a href=\"#%s\">%s</a></li>\n" sect_id sect_title
+    (fun { sect_id; sect_title; _ } ->
+       Printf.fprintf html "  <li><a href=\"#%s\">%s</a></li>\n" sect_id sect_title
     )
     !report;
-  Printf.fprintf html "</ul>";
+  Printf.fprintf html "</ul></div><div \
+                       class=\"w3-container w3-cell-row\" \
+                       style=\"margin-left: 250px;\"\
+                       ><a class=\"anchor\" id=\"top\"></a>";
   List.iter
     (fun { sect_id; sect_title; sect_content } ->
-       Printf.fprintf html "<fieldset><h3 id=\"%s\"><a href=\"#top\">&uarr;</a> %s</h3>%a</fieldset>\n" sect_id sect_title print_html sect_content
+       Printf.fprintf html "<fieldset>\n\
+                            <a class=\"anchor\" id=\"%s\"></a>\n\
+                            <h3><a href=\"#top\">&uarr;</a> %s</h3>\n\
+                            %a\n\
+                            </fieldset>\n" sect_id sect_title print_html sect_content
     )
     !report;
+  Printf.fprintf html "\
+</div>\n\
+</body>\n\
+</html>";
   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
+
+(*  *)
+
+
+type run_result = {
+  step: string;
+  retval: int option;
+  output: string;
+  error: string option;
+  time: float;
+}
+
+type compile_result = {
+  step: string;
+  error: string option;
+  data: Yojson.t
+}
+
+type result = RunRes of run_result
+            | CompRes of compile_result
+
+
+let results : result list ref = ref []
+
+
+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 kill pid sign =
+  try Unix.kill pid sign with
+  | Unix.Unix_error (e,f,p) ->
+    begin match e with
+      | ESRCH -> ()
+      | _ -> Printf.printf "%s\n" ((Unix.error_message e)^"|"^f^"|"^p)
+    end
+  | e -> raise e
+
+let run_exn_to_error f x =
+  try f x with
+  | e -> Error (Printexc.to_string e)
+
+let timeout (f: 'a -> 'b res) (arg: 'a) (time: float) : ('b * string) res =
+  let pipe_r,pipe_w = Unix.pipe () in
+  (match Unix.fork () with
+   | 0 ->
+     let r =
+       run_exn_to_error f arg >>= fun v ->
+       OK (v, Format.flush_str_formatter ()) in
+     let oc = Unix.out_channel_of_descr pipe_w in
+     Marshal.to_channel oc r [];
+     close_out oc;
+     exit 0
+   | pid0 ->
+     (match Unix.fork () with
+      | 0 -> Unix.sleepf time;
+        kill pid0 Sys.sigkill;
+        let oc = Unix.out_channel_of_descr pipe_w in
+        Marshal.to_channel oc (Error (Printf.sprintf "Timeout after %f seconds." time)) [];
+        close_out oc;
+        exit 0
+      | _ -> let ic = Unix.in_channel_of_descr pipe_r in
+        let result = Marshal.from_channel ic in
+        result ))
+
+let run step flag eval p =
+  if flag then begin
+    let starttime = Unix.gettimeofday () in
+    let res = timeout
+        (fun (p, params) -> eval Format.str_formatter p !heapsize params)
+        (p, !params)
+        !Options.timeout in
+    let timerun = Unix.gettimeofday () -. starttime in
+    let rres = { step ; retval = None; output=""; error = None; time = timerun} in
+    let rres =
+    begin match res with
+      | OK (v, output) ->  { rres with retval = v; output }
+      | Error msg -> { rres with error = Some msg }
+    end in
+    results := !results @ [RunRes rres];
+    add_to_report step ("Run " ^ step) (
+      Paragraph
+        (
+          Printf.sprintf "With parameters : [%s]<br>\n" (String.concat"," (List.map string_of_int !params))
+          ^ Printf.sprintf "Mem size : %d bytes<br>\n" !heapsize
+          ^ Printf.sprintf "Return value : %s<br>\n" (match rres.retval with | Some v -> string_of_int v | _ -> "none")
+          ^ Printf.sprintf "Output : <pre style=\"padding: 1em; background-color: #ccc;\">%s</pre>\n" rres.output
+          ^
+          (match rres.error with
+           | Some msg -> Printf.sprintf "Error : <pre style=\"padding: 1em; background-color: #fcc;\">\n%s</pre>\n" msg
+           | _ -> "")
+          ^ Printf.sprintf "Time : %f seconds<br>\n" timerun
+        )
+    )
+  end
+
+
+let json_output_string () =
+  let jstring_of_ostring o =
+    match o with
+    | None -> `Null
+    | Some s -> `String s
+  in
+  let j = `List (List.map (function
+      | RunRes { step; retval; output; error; time } ->
+        `Assoc [("runstep",`String step);
+                ("retval", match retval with Some r -> `Int r | None -> `Null);
+                ("output", `String output);
+                ("error", jstring_of_ostring error);
+                ("time", `Float time)
+               ]
+      | CompRes { step; error; data } ->
+        `Assoc [("compstep",`String step);
+                ("error", jstring_of_ostring error);
+                ("data", data)
+               ]
+    ) !results) in
+  (Yojson.pretty_to_string j)

src/riscv.ml

@@ -7,6 +7,7 @@ open Ltl_print
 open Utils
 open Prog
 open Options
+open Archi
 
 (* This file performs the translation from LTL programs to RISC-V assembly
    programs. The languages are basically the same, so the only thing to do here
@@ -43,27 +44,19 @@ let print_binop (b: binop) =
   | Elang.Emul -> "mul"
   | Elang.Emod -> "remu"
   | Elang.Exor -> "xor"
-  | Elang.Ediv -> "div"
+  | Elang.Ediv -> "divu"
   | Elang.Esub -> "sub"
-  | Elang.Eclt -> "slt"
-  | Elang.Ecle -> "sle"
-  | Elang.Ecgt -> "sgt"
-  | Elang.Ecge -> "sge"
-  | Elang.Eceq -> "seq"
-  | Elang.Ecne -> "sne"
+  | _ -> failwith "Unexpected binop"
 
 let print_unop (u: unop) =
   match u with
   | Elang.Eneg -> "neg"
 
 let instrsuffix_of_size sz =
-  match !Archi.archi, sz with
-  | _, 1 -> 'b'
-  | _, 4 -> 'w'
-  | A64, 8 -> 'd'
-  | _, _ ->
-    failwith (Format.sprintf "Impossible write size (%d) in archi (%d)"
-                sz !Archi.nbits)
+  match sz with
+  | MAS1 -> 'b'
+  | MAS4 -> 'w'
+  | MAS8 -> 'd'
 
 let dump_riscv_instr oc (i: ltl_instr) =
   match i with
@@ -72,18 +65,48 @@ let dump_riscv_instr oc (i: ltl_instr) =
   | LSubi(rd, rs, i) ->
     Format.fprintf oc "addi %s, %s, %d\n" (print_reg rd) (print_reg rs) (-i)
   | LBinop(b, rd, rs1, rs2) ->
-     (* TODO *)
-     Format.fprintf oc "%s %s, %s, %s\n"
+    begin match b with
+     | Elang.Eclt ->
+        Format.fprintf oc "slt %s, %s, %s\n"
+          (print_reg rd) (print_reg rs1) (print_reg rs2)
+      | Elang.Ecgt ->
+        Format.fprintf oc "slt %s, %s, %s\n"
+          (print_reg rd) (print_reg rs2) (print_reg rs1)
+      | Elang.Ecle ->
+        (* 'rd <- rs1 <= rs2' == 'rd <- rs2 < rs1; rd <- seqz rd' *)
+        Format.fprintf oc "slt %s, %s, %s\n"
+          (print_reg rd) (print_reg rs2) (print_reg rs1);
+        Format.fprintf oc "seqz %s, %s\n"
+          (print_reg rd) (print_reg rd)
+      | Elang.Ecge ->
+        Format.fprintf oc "slt %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)
+      | 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)
+      | 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)
+      | _ -> Format.fprintf oc "%s %s, %s, %s\n"
                (print_binop b) (print_reg rd) (print_reg rs1) (print_reg rs2)
+    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)
   | LStore(rt, i, rs, sz) ->
+    let sz = instrsuffix_of_size sz in
     Format.fprintf oc "s%c %s, %d(%s)\n"
-      (instrsuffix_of_size sz) (print_reg rs) i (print_reg rt)
+          sz (print_reg rs) i (print_reg rt)
   | LLoad(rd, rt, i, sz) ->
+    let sz = (instrsuffix_of_size sz) in
     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)
   | LMov(rd, rs) ->
     Format.fprintf oc "mv %s, %s\n" (print_reg rd) (print_reg rs)
   | LLabel l ->
@@ -103,58 +126,46 @@ let dump_riscv_fun oc (fname , lf) =
   Format.fprintf oc "%s:\n" fname;
   List.iter (dump_riscv_instr oc) lf.ltlfunbody
 
-let riscv_load_args oc =
-  let nargs = [1;2;3;4;5;6;7;8] in
-  (* for each arg in [1..8]:
-       a0 <- arg
-       call load_int_arg
-       call atoi
-       sd a0, -8*arg(fp)
-  *)
-  let l1 = nargs |>
-           List.map (fun i ->
-               [LConst(reg_a0, i);
-                LCall("load_int_arg");
-                LCall("atoi");
-                LStore(reg_fp, - !Archi.wordsize*i,
-                       reg_a0, !Archi.wordsize)
-               ]) in
-  (* for each arg in [1..8]
-     ld a{arg-1}, -8*arg(fp)
-  *)
-  let l2 = nargs |>
-           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)
-
-
-let riscv_fun_load_arg oc () =
-  ("load_int_arg",{
-      ltlfunargs = 0;
-      (*
-         t0 <- Archi.wordsize (in this example 8)
-         mul a0, a0, t0
-         add t0, fp, a0
-         ld a0, 8(t0)
-         jmpr ra
-      *)
-      ltlfunbody = [LConst(reg_t0, !Archi.wordsize);
-                    LBinop(Emul, reg_ret, reg_ret, reg_t0);
-                    LBinop(Eadd, reg_t0, reg_fp, reg_ret);
-                    LLoad(reg_ret, reg_t0, !Archi.wordsize, !Archi.wordsize);
-                    LJmpr reg_ra
-                   ];
-      ltlfuninfo = [];
-      ltlregalloc = []
-    }) |> dump_riscv_fun oc
+let riscv_load_args target oc : unit =
+  (match target with
+   | Linux -> LLoad(reg_s1, reg_sp, 0, archi_mas ()) :: (* s1 <- argc *)
+              LAddi(reg_s2, reg_sp, (Archi.wordsize ())) :: []
+   | Xv6 -> LMov(reg_s1, reg_a0) ::
+            LMov(reg_s2, reg_a1) :: []) @
+  LConst(reg_s3, 1) ::
+  LSubi(reg_sp, reg_sp, 72) ::
+  LLabel "Lloop" ::
+  LBranch(Rceq, reg_s3, reg_s1, "Lendargs") ::
+  LMov(reg_a0, reg_t4) ::
+  LAddi(reg_s4, reg_s3, 0) ::
+  LConst(reg_t1, (Archi.wordsize ())) ::
+  LBinop(Emul, reg_s4, reg_s4, reg_t1) ::
+  LBinop(Eadd, reg_t3, reg_s4, reg_s2) ::
+  LLoad(reg_a0, reg_t3, 0, archi_mas ()) ::
+  LCall "atoi" ::
+  LBinop(Esub, reg_s4, reg_fp, reg_s4) ::
+  LStore(reg_s4, 0, reg_a0, archi_mas ()) ::
+  LAddi(reg_s3, reg_s3, 1) ::
+  LJmp "Lloop" ::
+  LLabel "Lendargs" ::
+  LLoad(reg_a0, reg_fp, -8, archi_mas ()) ::
+  LLoad(reg_a1, reg_fp, -16, archi_mas ()) ::
+  LLoad(reg_a2, reg_fp, -24, archi_mas ()) ::
+  LLoad(reg_a3, reg_fp, -32, archi_mas ()) ::
+  LLoad(reg_a4, reg_fp, -40, archi_mas ()) ::
+  LLoad(reg_a5, reg_fp, -48, archi_mas ()) ::
+  LLoad(reg_a6, reg_fp, -56, archi_mas ()) ::
+  LLoad(reg_a7, reg_fp, -64, archi_mas ()) ::
+  [] |>
+  List.iter (dump_riscv_instr oc)
 
 let rv_store () =
-  Format.sprintf "s%c" !Archi.instrsuffix
+  Format.sprintf "s%c" (Archi.instrsuffix ())
 let rv_load () =
-  Format.sprintf "l%c" !Archi.instrsuffix
+  Format.sprintf "l%c" (Archi.instrsuffix ())
 
-let riscv_prelude oc =
+let riscv_prelude target oc =
+  Format.fprintf oc ".include \"syscall_numbers.s\"\n";
   Format.fprintf oc ".globl _start\n";
   Format.fprintf oc "_start:\n";
   Format.fprintf oc "  lui gp, %%hi(_heap_start)\n";
@@ -162,21 +173,19 @@ let riscv_prelude oc =
   Format.fprintf oc "  addi t0, gp, 8\n";
   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 target oc ;
   Format.fprintf oc "jal ra, main\n";
   Format.fprintf oc "mv s0, a0\n";
   Format.fprintf oc "jal ra, println\n";
   Format.fprintf oc "mv a0, s0\n";
   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 "addi a7, zero, SYSCALL_EXIT\n";
   Format.fprintf oc "ecall\n"
 
-let dump_riscv_prog oc lp =
-  if !nostart then () else riscv_prelude oc;
+let dump_riscv_prog target oc lp : unit =
+  (if !nostart then () else riscv_prelude target oc);
   Format.fprintf oc ".global main\n";
   List.iter (function
         (fname, Gfun f) -> dump_riscv_fun oc (fname,f)
-    ) lp;
-  riscv_fun_load_arg oc ()
+    ) lp

src/rtl.ml

 open Batteries
-open BatList
 open Elang
 open Cfg
-open Utils
-open Prog
 
 type reg = int
 
@@ -24,3 +21,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/rtl_gen.ml

@@ -4,6 +4,9 @@ open Cfg
 open Rtl
 open Prog
 open Utils
+open Report
+open Rtl_print
+open Options
 
 (* Une partie de la génération de RTL consiste à allouer les variables dans des
    pseudo-registres RTL.
@@ -25,10 +28,9 @@ open Utils
 
 *)
 let find_var (next_reg, var2reg) v =
-  begin match List.assoc_opt v var2reg with
+  match List.assoc_opt v var2reg with
     | Some r -> (r, next_reg, var2reg)
     | None -> (next_reg, next_reg + 1, assoc_set var2reg v next_reg)
-  end
 
 (* [rtl_instrs_of_cfg_expr (next_reg, var2reg) e] construit une liste
    d'instructions RTL correspondant à l'évaluation d'une expression E.
@@ -52,9 +54,12 @@ let is_cmp_op =
          | Ecne -> Some Rcne
          | _ -> None
 
-let is_cmp (e: expr) =
+let rtl_cmp_of_cfg_expr (e: expr) =
   match e with
-  | Ebinop (b, e1, e2) -> (match is_cmp_op b with | None -> (Rcne, e, Eint 0) | Some rop -> (rop, e1, e2))
+  | Ebinop (b, e1, e2) ->
+    (match is_cmp_op b with
+     | None -> (Rcne, e, Eint 0)
+     | Some rop -> (rop, e1, e2))
   | _ -> (Rcne, e, Eint 0)
 
 
@@ -87,3 +92,9 @@ let rtl_of_gdef funname = function
     Gfun f -> Gfun (rtl_instrs_of_cfg_fun funname f)
 
 let rtl_of_cfg cp = List.map (fun (s, gd) -> (s, rtl_of_gdef s gd)) cp
+
+let pass_rtl_gen 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)));
+  OK rtl

src/rtl_print.ml

@@ -17,8 +17,15 @@ let print_cmpop (r: rtl_cmp) =
   | Rceq -> "=="
   | Rcne -> "!=")
 
-let dump_rtl_instr name (live_in, live_out) oc (i: rtl_instr) =
+let dump_rtl_instr name (live_in, live_out) ?(endl="\n") 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 "%s" endl;
+  dump_liveness live_out "after"
 
 let dump_rtl_node name lives =
   print_listi (fun i ->
@@ -44,6 +52,7 @@ let dump_rtl_node name lives =
            None -> (None, None)
          | Some (lin, lout) ->
            Hashtbl.find_option lin i, Hashtbl.find_option lout i)
+        ~endl:"\n"
     ) "" "" ""
 
 let dump_rtl_fun oc rtlfunname ({ rtlfunargs; rtlfunbody; rtlfunentry }: rtl_fun) =

src/symbols.ml

-open BatPrintf
 open Batteries
-open Utils
 
 let string_of_position pos =
   let open Lexing in
@@ -55,6 +53,7 @@ type token =
  | SYM_PRINT
  | SYM_EXTERN
  | SYM_INCLUDE of string
+ | SYM_AMPERSAND
 
 let string_of_symbol = function
 | SYM_EOF -> "SYM_EOF"
@@ -103,3 +102,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/test_lexer.ml

+open E_regexp
+open Lexer_generator
+open Batteries
+open Utils
+open Symbols
+
+let nfa_accepts (n: nfa) (w: char list) : bool =
+  let rec trav vis s =
+    if Set.mem s vis then vis
+    else let en = List.filter_map (fun (oa, n) -> if oa = None then Some n else None) (n.nfa_step s) in
+      List.fold_left trav (Set.add s vis) en in
+  let ec s = trav Set.empty s in
+  let ecs ls = Set.fold (fun q -> Set.union (ec q)) ls Set.empty in
+
+  let rec walk (q: int set) (w: char list) =
+    let q = ecs q in
+    match w with
+    | [] -> Set.exists (fun q -> List.mem q (List.map fst n.nfa_final)) q
+    | c::w ->
+      let q' =
+        Set.fold Set.union (Set.map (fun q ->
+            (List.filter_map
+               (fun (cso,q') ->
+                  match cso with
+                  | None -> None
+                  | Some cs -> if Set.mem c cs then Some q' else None
+               )
+               (n.nfa_step q)) |> Set.of_list
+          ) q) Set.empty
+
+      in walk q' w in
+  walk (Set.of_list n.nfa_initial) w
+
+let () =
+  let regexp_list = [
+    (keyword_regexp "while",    fun s -> Some (SYM_WHILE));
+    (keyword_regexp "if",    fun s -> Some (SYM_IF));
+    (Cat(letter_regexp,
+         Star(identifier_material)),
+     fun s -> Some (SYM_IDENTIFIER s));
+
+  ] in
+  (* Décommentez la ligne suivante pour tester sur la vraie liste d'expressions
+     régulières. *)
+  (* let regexp_list = list_regexp in *)
+  List.iteri
+    (fun i (rg, _) -> Printf.printf "%d: %s\n" i (string_of_regexp rg))
+    regexp_list;
+
+  let nfa = nfa_of_list_regexp regexp_list in
+
+  Printf.printf "%s\n" (nfa_to_string nfa);
+
+  let oc = open_out "/tmp/nfa.dot" in
+  nfa_to_dot oc nfa;
+  close_out oc;
+
+  let dfa = dfa_of_nfa nfa in
+  let oc = open_out "/tmp/dfa.dot" in
+  dfa_to_dot oc dfa alphabet;
+  close_out oc;
+
+  let n =
+    {
+      nfa_states = [1; 2; 3; 4] ;
+      nfa_initial = [1] ;
+      nfa_final = [(3, fun s -> None); (4, fun s -> None)];
+      nfa_step = fun q ->
+        match q with
+        | 1 -> [(Some (Set.singleton '0'), 2); (None, 3)]
+        | 2 -> [(Some (Set.singleton '1'), 2); (Some (Set.singleton '1'), 4)]
+        | 3 -> [(Some (Set.singleton '0'), 4); (None, 2)]
+        | 4 -> [(Some (Set.singleton '0'), 2)]
+        | _ -> []
+
+    } in
+
+  let expect_set str s_got s_exp =
+    if Set.equal s_got s_exp
+    then Printf.printf "[OK] %s\n" str
+    else Printf.printf "[KO] %s : got %s, expected %s\n" str (string_of_int_set s_got)
+        (string_of_int_set s_exp) in
+
+  let ec1 = epsilon_closure n 1 in
+  let ec2 = epsilon_closure n 2 in
+  let ec3 = epsilon_closure n 3 in
+  let ec4 = epsilon_closure n 4 in
+
+  expect_set "epsilon_closure 1" ec1 (Set.of_list [1;2;3]);
+  expect_set "epsilon_closure 2" ec2 (Set.of_list [2]);
+  expect_set "epsilon_closure 3" ec3 (Set.of_list [2;3]);
+  expect_set "epsilon_closure 4" ec4 (Set.of_list [4]);
+
+  expect_set "dfa_initial_state" (dfa_initial_state n) (Set.of_list [1;2;3]);
+
+  let string_of_opt_tok ot =
+    match ot with
+      None -> "None"
+    | Some t -> Printf.sprintf "Some (%s)" (string_of_symbol t)
+  in
+
+  let expect_token_option str to_got to_exp =
+    if to_got = to_exp
+    then Printf.printf "[OK] %s\n" str
+    else Printf.printf "[KO] %s : got %s, expected %s\n" str (string_of_opt_tok to_got)
+        (string_of_opt_tok to_exp)
+  in
+
+  expect_token_option "min_priority 1" (min_priority [SYM_EOF; SYM_IDENTIFIER "bla"; SYM_WHILE]) (Some SYM_WHILE);
+  expect_token_option "min_priority 2" (min_priority [SYM_EOF; SYM_IDENTIFIER "bla"]) (Some (SYM_IDENTIFIER "bla"));
+  expect_token_option "min_priority 3" (min_priority [SYM_EOF; SYM_WHILE]) (Some SYM_WHILE);
+
+  expect_token_option "min_priority 4" (min_priority []) None;
+
+  let set_incl s1 s2 =
+    Set.for_all (fun s -> Set.exists (Set.equal s) s2) s1
+  in
+
+  let set_eq s1 s2 = set_incl s1 s2 && set_incl s2 s1 in
+
+  let string_of_int_set_set s =
+    Set.map (fun s ->
+        Printf.sprintf "{%s}" (String.concat "," (Set.to_list (Set.map string_of_int s)))
+      ) s
+    |> Set.to_list
+    |> String.concat ", "
+    |> Printf.sprintf "{%s}"
+  in
+
+  let expect_set_set str (set_got : int set set) (set_exp : int set set) =
+    if set_eq set_got set_exp
+    then Printf.printf "[OK] %s\n" str
+    else Printf.printf "[KO] %s : got %s, expected %s\n" str
+        (string_of_int_set_set set_got)
+        (string_of_int_set_set set_exp)
+  in
+
+  let table = Hashtbl.create 10 in
+  build_dfa_table table n (dfa_initial_state n);
+  expect_set_set "dfa states" (Hashtbl.keys table |> Set.of_enum) (Set.of_list [Set.of_list [1;2;3]; Set.of_list [2;4]; Set.of_list [2]]);
+
+  let expect_nfa_accepts n s b =
+    let r = nfa_accepts n (char_list_of_string s) in
+    if r = b
+    then Printf.printf "[OK] nfa_accepts %s = %b\n" s r
+    else Printf.printf "[KO] nfa_accepts %s = %b\n" s r
+  in
+
+  Printf.printf "*** NFA n1 : 'hello'\n";
+  let n1, f1 = nfa_of_regexp (keyword_regexp "hello") 1 (fun _ -> None) in
+  expect_nfa_accepts n1 "hello" true;
+  expect_nfa_accepts n1 "bonjour" false;
+
+  Printf.printf "*** NFA n2 : 'bonjour'\n";
+  let n2, f2 = nfa_of_regexp (keyword_regexp "bonjour") f1 (fun _ -> None) in
+  expect_nfa_accepts n2 "hello" false;
+  expect_nfa_accepts n2 "bonjour" true;
+
+  Printf.printf "*** NFA n3 : n1 | n2\n";
+  let n3 = alt_nfa n1 n2 in
+  expect_nfa_accepts n3 "hello" true;
+  expect_nfa_accepts n3 "bonjour" true;
+  expect_nfa_accepts n2 "buongiorno" false;
+
+  Printf.printf "*** NFA n4 : n1 . n2 \n";
+  let n4 = cat_nfa n1 n2 in
+  expect_nfa_accepts n4 "hello" false;
+  expect_nfa_accepts n4 "bonjour" false;
+  expect_nfa_accepts n4 "hellobonjour" true;
+  expect_nfa_accepts n4 "bonjourhello" false;
+
+  Printf.printf "*** NFA n5 : n1* \n";
+  let n5 = star_nfa n1 (fun _ -> None) in
+  expect_nfa_accepts n5 "" true;
+  expect_nfa_accepts n5 "hello" true;
+  expect_nfa_accepts n5 "hellohello" true;
+  expect_nfa_accepts n5 "hellobonjour" false;
+
+  Printf.printf "*** NFA n6 : n3* \n";
+  let n6 = star_nfa n3 (fun _ -> None) in
+  expect_nfa_accepts n6 "" true;
+  expect_nfa_accepts n6 "hello" true;
+  expect_nfa_accepts n6 "hellohello" true;
+  expect_nfa_accepts n6 "hellobonjour" true;
+  expect_nfa_accepts n6 "hellobonjourhello" true;
+  expect_nfa_accepts n6 "bonjourbonjourbonjourhello" true;
+  expect_nfa_accepts n6 "bonjlo" false;
+
+
+  ignore f2

src/tokenize.ml

+open Batteries
+open Lexer_generator
+open Report
+open Utils
+open Options
+open Symbols
+
+let tokenize_handwritten file =
+  Printf.printf "Handwritten lexer\n";
+  Lexer_generator.tokenize_file file >>= fun tokens ->
+  OK (List.map (fun tok -> (tok, None)) tokens)
+
+let tokenize_ocamllex file =
+  Printf.printf "OCamlLex lexer\n";
+  let ic = open_in file in
+  let lexbuf = Lexing.from_channel ic in
+  lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_fname = file };
+  let rec get_symbols () =
+    let s = Lexer.token lexbuf in
+    let ss = (s, Lexing.lexeme_start_p lexbuf) in
+    if s = SYM_EOF
+    then [ss]
+    else ss :: get_symbols ()
+  in
+  let l = get_symbols () in
+  close_in ic;
+  OK (List.map (fun (tok, pos) -> (tok, Some pos)) l)
+
+let tokenize file =
+  if !Options.handwritten_lexer
+  then tokenize_handwritten file
+  else tokenize_ocamllex file
+
+let pass_tokenize file =
+  tokenize file >>* (fun msg ->
+      record_compile_result ~error:(Some msg) "Lexing";
+      Error msg
+    ) $ 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)
+            ) tokens) tokens (fun f () -> add_to_report "lexer" "Lexer" (Code (file_contents f)));
+      OK tokens

src/utils.ml

 open Batteries
-open BatPrintf
 open BatBuffer
 open BatList
 
@@ -74,8 +73,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]
 
@@ -113,7 +110,7 @@ let read_mem_bytes_as_int mem addr n =
 
 
 let read_mem_int mem addr =
-  read_mem_bytes_as_int mem addr !Archi.wordsize
+  read_mem_bytes_as_int mem addr (Archi.wordsize ())
 
 let read_mem_char mem addr =
   read_mem_bytes mem addr 1 >>= fun bl ->
@@ -133,29 +130,30 @@ module Mem : sig
   val write_log : t -> unit -> (int * int) list
 end = struct
   type t = int array * int list ref * (int * int) list ref
-  let write_bytes (m,rl,wl) addr bytes =
-    write_mem_bytes m addr bytes >>= fun w -> wl := !wl @ w; OK ()
-  let write_char (m,rl,wl) addr c =
-    write_mem_char m addr c >>= fun w -> wl := !wl @ w; OK ()
-  let read_bytes (m,rl,wl) addr len =
+  let write_bytes (m,_,wl) addr bytes =
+    write_mem_bytes m addr bytes >>= fun w ->
+    wl := w @ !wl; OK ()
+  let write_char (m,_,wl) addr c =
+    write_mem_char m addr c >>= fun w -> wl := w @ !wl; OK ()
+  let read_bytes (m,rl,_) addr len =
     read_mem_bytes m addr len >>= fun (vl,addrl) ->
-    rl := !rl @ addrl; OK vl
-  let read_bytes_as_int (m,rl,wl) addr len =
+    rl := addrl @ !rl ; OK vl
+  let read_bytes_as_int (m,rl,_) addr len =
     read_mem_bytes_as_int m addr len >>= fun (v,addrl) ->
-    rl := !rl @ addrl; OK v
-  let read_char (m,rl,wl) addr =
+    rl := addrl @ !rl; OK v
+  let read_char (m,rl,_) addr =
     read_mem_char m addr >>= fun (v,addrl) ->
-    rl := !rl @ addrl; OK v
+    rl := addrl @ !rl; OK v
   let init n = Array.init n (fun _ -> 0), ref [], ref []
-  let read_log (_,rl,_) () = let r = !rl in rl := []; r
-  let write_log (_,_,wl) () = let w = !wl in wl := []; w
+  let read_log (_,rl,_) () = let r = !rl in rl := []; List.rev r
+  let write_log (_,_,wl) () = let w = !wl in wl := []; List.rev w
 end
 
 let assoc_opti k l =
   let rec aux l n =
     match l with
     | [] -> None
-    | (a,v)::l when a = k -> Some (n, v)
+    | (a,v)::_ when a = k -> Some (n, v)
     | _::l -> aux l (n+1)
   in
   aux l 0
@@ -170,7 +168,7 @@ let assoc_map_res f l =
       OK (acc@[(k,v)])
     ) (OK []) l
 
-let rec assoc_split fl fr l =
+let assoc_split fl fr l =
   let rec aux l (accl, accr) =
   match l with
   | [] -> (accl, accr)
@@ -246,8 +244,104 @@ 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
   | None -> Error (Format.sprintf "%s %s not found." word k)
 
+
+let remove_dups l : 'a list =
+  List.fold_left (fun acc elt -> if List.mem elt acc then acc else elt::acc) [] l
+
+let rec take n l =
+  if n = 0 then []
+  else match l with
+    | [] -> []
+    | a::r -> a::take (n-1) r
+
+let char_list_of_string l : char list =
+  String.to_list l
+
+let string_of_char_list cl =
+  String.of_list cl
+
+let string_of_char_set s =
+  string_of_char_list (Set.to_list s)
+
+let string_of_int_list l =
+  Printf.sprintf "%s" (String.concat "_" (List.map string_of_int l))
+
+let string_of_int_set s =
+  string_of_int_list (Set.to_list s)
+
+let string_of_string_set v =
+  String.concat ", " (Set.to_list v)
+
+let string_of_int_int_set v =
+  String.concat ", " (List.map (fun (x,y) -> Printf.sprintf "(%d,%d)" x y) (Set.to_list v))
+
+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
+
+
+let process_output_to_list2 = fun command ->
+  let chan = Unix.open_process_in command in
+  let res = ref ([] : string list) in
+  let rec process_otl_aux () =
+    let e = input_line chan in
+    res := e::!res;
+    process_otl_aux() in
+  try process_otl_aux ()
+  with End_of_file ->
+    let stat = Unix.close_process_in chan in (List.rev !res,stat)
+
+let cmd_to_list command =
+  let (l,_) = process_output_to_list2 command in l
+
+let file_contents file =
+  match
+    let ic = open_in file in
+    let rec aux s () =
+      try
+        let line = input_line ic in  (* read line from in_channel and discard \n *)
+        aux (s ^ line ^ "\n") ()   (* close the input channel *)
+      with _ ->                      (* some unexpected exception occurs *)
+        close_in_noerr ic;           (* emergency closing *)
+        s in
+    aux "" ()
+  with
+  | exception Sys_error _ -> failwith (Printf.sprintf "Could not open file %s\n" file)
+  | x -> x

src/yaccparser.mly

+%{
+    (* open Symbols *)
+    open Ast
+%}
+
+%token SYM_EOF
+%token SYM_VOID SYM_CHAR SYM_INT SYM_STRUCT SYM_POINT SYM_BOOL_NOT SYM_BOOL_AND SYM_BOOL_OR
+%token SYM_ARROW SYM_BITWISE_OR SYM_BITWISE_AND SYM_BIT_NOT SYM_XOR SYM_LBRACKET SYM_RBRACKET
+%token SYM_ALLOC SYM_EXTERN SYM_AMPERSAND
+%token<char> SYM_CHARACTER
+%token<string> SYM_STRING
+%token<string> SYM_INCLUDE
+%token<string> SYM_IDENTIFIER
+%token<int> SYM_INTEGER
+%token SYM_PLUS SYM_MINUS SYM_ASTERISK SYM_DIV SYM_MOD
+%token SYM_LPARENTHESIS SYM_RPARENTHESIS SYM_LBRACE SYM_RBRACE
+%token SYM_ASSIGN SYM_SEMICOLON SYM_RETURN SYM_IF SYM_WHILE SYM_ELSE SYM_COMMA SYM_PRINT
+%token SYM_EQUALITY SYM_NOTEQ SYM_LT SYM_LEQ SYM_GT SYM_GEQ
+
+%left SYM_EQUALITY SYM_NOTEQ
+%left SYM_GEQ SYM_LEQ SYM_LT SYM_GT
+%left SYM_PLUS SYM_MINUS
+%left SYM_ASTERISK SYM_DIV SYM_MOD
+%nonassoc UMINUS
+
+%start main
+%type <Ast.tree> main
+
+%%
+
+  main:
+    | fundefs SYM_EOF { Node(Tlistglobdef, $1) }
+    ;
+      fundefs:
+        | fundef fundefs { $1 :: $2 }
+        | { [] }
+    ;
+      fundef:
+        identifier SYM_LPARENTHESIS lparams SYM_RPARENTHESIS instr {
+            let fargs = $3 in
+            let instr = $5 in
+            Node (Tfundef, [$1; Node (Tfunargs, fargs) ; instr ])
+          }
+    ;
+      identifier:
+        SYM_IDENTIFIER {  StringLeaf ($1) }
+    ;
+
+      integer : SYM_INTEGER { IntLeaf ($1) };
+
+    lparams :
+      identifier rest_params { Node (Targ, [$1]) :: $2 }
+      | { [] };
+    rest_params :
+      SYM_COMMA identifier rest_params {
+          Node (Targ, [$2]) :: $3
+        }
+      | { [] };
+    instrs :
+      | instr instrs { $1 :: $2 }
+      | { [] };
+    linstrs :
+      SYM_LBRACE instrs SYM_RBRACE { Node (Tblock, $2) };
+    instr :
+      identifier SYM_ASSIGN expr SYM_SEMICOLON {
+          Node (Tassign, [Node (Tassignvar,[$1; $3])])
+        }
+      | SYM_IF SYM_LPARENTHESIS expr SYM_RPARENTHESIS linstrs ntelse { Node (Tif, [$3; $5; $6]) }
+      | SYM_WHILE SYM_LPARENTHESIS expr SYM_RPARENTHESIS instr { Node( Twhile, [$3; $5]) }
+      | SYM_RETURN expr SYM_SEMICOLON { Node(Treturn, [$2]) }
+      | SYM_PRINT expr SYM_SEMICOLON { Node(Tprint, [$2]) }
+      | linstrs { $1 };
+      ntelse :
+        SYM_ELSE linstrs { $2 }
+        | { Node(Tblock, []) };
+
+      expr :
+        | expr SYM_EQUALITY expr { Node (Tceq, [$1; $3]) }
+        | expr SYM_NOTEQ expr { Node (Tne, [$1; $3]) }
+        | expr SYM_PLUS expr { Node (Tadd, [$1; $3]) }
+        | expr SYM_MINUS expr { Node (Tsub, [$1; $3]) }
+        | expr SYM_ASTERISK expr { Node (Tmul, [$1; $3]) }
+        | expr SYM_DIV expr { Node (Tdiv, [$1; $3]) }
+        | expr SYM_MOD expr { Node (Tmod, [$1; $3]) }
+        | expr SYM_LT expr { Node (Tclt, [$1; $3]) }
+        | expr SYM_GT expr { Node (Tcgt, [$1; $3]) }
+        | expr SYM_LEQ expr { Node (Tcle, [$1; $3]) }
+        | expr SYM_GEQ expr { Node (Tcge, [$1; $3]) }
+        | SYM_MINUS expr %prec UMINUS { Node (Tneg, [$2])}
+        | integer { Node(Tint, [$1])}
+        | identifier { $1 }
+        | SYM_LPARENTHESIS expr SYM_RPARENTHESIS { $2 }
+      ;