Fixes defined variables, fixes live variables, implements reduces registers, fixes risc semantic

lib/miniImp/liveVariables.ml

@@ -24,45 +24,33 @@ let variables_used (instr : DVCfg.elt) : DVCfg.internal list =
     | Nop
     | LoadI (_, _) ->
       acc
-    | BRegOp (_, r1, r2, _) ->
+    | BRegOp (_, r1, r2, _)
+    | Store (r1, r2) ->
       DVCeltSet.add r1.index acc |>
       DVCeltSet.add r2.index
     | BImmOp (_, r1, _, _)
     | URegOp (_, r1, _)
-    | Load (r1, _)
-    | Store (r1, _) ->
+    | Load (r1, _) ->
       DVCeltSet.add r1.index acc
   in
 
   helper DVCeltSet.empty instr |> DVCeltSet.to_list
 
-let _variables_used_all (instructions : DVCfg.elt list) : DVCfg.internal list =
-  List.fold_left (fun (acc: DVCeltSet.t) (instr: DVCfg.elt) ->
-      DVCeltSet.union acc (variables_used instr |> DVCeltSet.of_list)
-    ) DVCeltSet.empty instructions |> DVCeltSet.to_list
-
-
 let variables_defined (instructions : DVCfg.elt) : DVCfg.internal list =
   let helper (acc: DVCeltSet.t) (instr: DVCfg.elt) =
     match instr with
-    | Nop -> acc
+    | Nop
+    | Store (_, _) -> acc
     | BRegOp (_, _, _, r3)
     | BImmOp (_, _, _, r3)
     | URegOp (_, _, r3)
     | Load (_, r3)
-    | LoadI (_, r3)
-    | Store (_, r3) ->
+    | LoadI (_, r3) ->
       DVCeltSet.add r3.index acc
   in
 
   helper DVCeltSet.empty instructions |> DVCeltSet.to_list
 
-let _variables_defined_all (instructions : DVCfg.elt list) : DVCfg.internal list =
-  List.fold_left (fun (acc: DVCeltSet.t) (instr: DVCfg.elt) ->
-      DVCeltSet.union acc (variables_defined instr |> DVCeltSet.of_list)
-    ) DVCeltSet.empty instructions |> DVCeltSet.to_list
-
-
 (* init function, assign the bottom to everything *)
 let init : (DVCfg.elt list -> DVCfg.internalnode) =
   (fun l -> {internalin = [];
@@ -75,58 +63,68 @@ let lub (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
       None -> []
     | Some c -> c
   in
+
+  let newinternalbetween = (
+    List.map
+      (fun (code, (_i, o)) ->
+         (Utility.unique_union
+            (variables_used code)
+            (Utility.subtraction o (variables_defined code)), o))
+      (Utility.combine_twice code previnternalvar.internalbetween)
+  ) in
+
+  let newinternalin =
+    match newinternalbetween with
+    | [] -> previnternalvar.internalout
+    | (i, _)::_ -> i
+  in
+
   { previnternalvar with
-    internalbetween =
-      List.map (fun (prevbtw, code, nextprevbtw) ->
-          let newin = Utility.unique_union (variables_used code)
-              (Utility.subtraction (snd prevbtw) (variables_defined code))
-          in
-          match nextprevbtw with
-            None -> (newin, snd prevbtw)
-          | Some (newout, _) -> (newin, newout)
-        )
-        (Utility.combine_thrice previnternalvar.internalbetween code
-           (Utility.pad (List.tl previnternalvar.internalbetween) None (List.length previnternalvar.internalbetween)))
-    ;
-    internalin = fst (List.hd previnternalvar.internalbetween);
-  }
+    internalbetween = newinternalbetween;
+    internalin = newinternalin; }
 
 let lucf (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
   let previnternalvar = Cfg.NodeMap.find node t.internalvar in
-  if Option.equal (=) (Some node) t.t.terminal then
-    let outputvarlist = match t.t.inputOutputVar with
+
+  let newinternalout = (
+    if Option.equal (=) (Some node) t.t.terminal then (
+      match t.t.inputOutputVar with
         Some (_, o) -> [o]
       | None -> []
-    in
-    { previnternalvar with
-      internalout = outputvarlist;
-      internalbetween = (
-        let last_elem = Utility.last_list previnternalvar.internalbetween in
-        (Utility.drop_last_element_list previnternalvar.internalbetween) @
-        [(fst last_elem, outputvarlist)]
-      )
-    }
-  else
-    let nextnodes = Cfg.NodeMap.find_opt node t.t.edges in
-    let newinternalout = match nextnodes with
-        None -> []
-      | Some (node, None) -> (Cfg.NodeMap.find node t.internalvar).internalin
+    ) else (
+      let nextnodes = Cfg.NodeMap.find_opt node t.t.edges in
+      match nextnodes with
+      | None -> []
+      | Some (node, None) ->
+        (Cfg.NodeMap.find node t.internalvar).internalin
       | Some (node1, Some node2) ->
         Utility.unique_union
           (Cfg.NodeMap.find node1 t.internalvar).internalin
           (Cfg.NodeMap.find node2 t.internalvar).internalin
-    in
-    { previnternalvar with
-      internalout = newinternalout;
-      internalbetween = (
-        let last_elem = Utility.last_list previnternalvar.internalbetween in
-        (Utility.drop_last_element_list previnternalvar.internalbetween) @
-        [(fst last_elem, newinternalout)]
-      )
-    }
+    )
+  ) in
+
+  let newinternalbetween = (
+    match List.rev previnternalvar.internalbetween with
+    | [] -> []
+    | (i, _o) :: btwrest ->
+      let btwrest = List.rev btwrest in
+      let newbtwrest = List.map2
+          (fun (i, _o) (nexti, _nexto) -> (i, nexti))
+          btwrest
+          (Utility.drop_first_element_list previnternalvar.internalbetween)
+      in
+      newbtwrest @ [(i, newinternalout)]
+  ) in
+
+  { previnternalvar with
+    internalout = newinternalout;
+    internalbetween = newinternalbetween; }
 
 let update (t: DVCfg.t) (node: Cfg.Node.t) : DVCfg.internalnode =
-  let newt = {t with internalvar = (Cfg.NodeMap.add node (lucf t node) t.internalvar)} in
+  let newt = {t with internalvar = (Cfg.NodeMap.add node
+                                      (lucf t node)
+                                      t.internalvar)} in
   lub newt node
 
 
@@ -135,10 +133,136 @@ let compute_live_variables (cfg: RISCCfg.t) : DVCfg.t =
   |> DVCfg.fixed_point ~init:init ~update:update
 
 
+
+module VariableMap = struct
+  include Map.Make(Variable)
+
+  let first_empty next start m l =
+    let bindings =
+      List.fold_left (
+        fun acc x ->
+          match find_opt x m with
+          | None -> acc
+          | Some x -> x :: acc) [] l |> List.sort Variable.compare in
+
+    let rec aux x =
+      if List.mem x bindings
+      then aux (next x)
+      else x
+    in
+    aux start
+
+  let first_empty_Variable m l =
+    let next = fun x -> x |> int_of_string |> (+) 1 |> string_of_int in
+    let start = "1" in
+    first_empty next start m l
+
+  let get_mapping m l r =
+    match find_opt r m with
+    | None -> (
+        let newr = first_empty_Variable m l in
+        let newm = add r newr m in
+        (newm, newr)
+      )
+    | Some r -> (m, r)
+end
+
+
 (* just rename the registers that dont share live status *)
 let optimize_cfg (t: DVCfg.t) : DVCfg.t =
-  t
+  let replace_code ((vin, vout): Variable.t list * Variable.t list)
+      (a: Variable.t VariableMap.t)
+      (code: DVCfg.elt)
+    : (Variable.t VariableMap.t * DVCfg.elt) =
+    match code with
+    | Nop -> (
+        (a, Nop)
+      )
+    | BRegOp (brop, r1, r2, r3) -> (
+        let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
+        let (newa, newr2) = VariableMap.get_mapping newa vin r2.index in
+        let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
+        (newa, BRegOp (brop, {index = newr1}, {index = newr2}, {index = newr3}))
+      )
+    | BImmOp (biop, r1, i, r3) -> (
+        let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
+        let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
+        (newa, BImmOp (biop, {index = newr1}, i, {index = newr3}))
+      )
+    | URegOp (urop, r1, r3) -> (
+        let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
+        let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
+        (newa, URegOp (urop, {index = newr1}, {index = newr3}))
+      )
+    | Load (r1, r3) -> (
+        let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
+        let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
+        (newa, Load ({index = newr1}, {index = newr3}))
+      )
+    | LoadI (i, r3) -> (
+        let (newa, newr3) = VariableMap.get_mapping a vout r3.index in
+        (newa, LoadI (i, {index = newr3}))
+      )
+    | Store (r1, r3) -> (
+        let (newa, newr1) = VariableMap.get_mapping a vin r1.index in
+        let (newa, newr3) = VariableMap.get_mapping newa vout r3.index in
+        (newa, Store ({index = newr1}, {index = newr3}))
+      )
+  in
 
+  let aux (assignments: Variable.t VariableMap.t) (t: DVCfg.t) (node: Cfg.Node.t)
+    : (Variable.t VariableMap.t * DVCfg.t) =
+    let livevars = Cfg.NodeMap.find node t.internalvar in
+    let code =
+      match Cfg.NodeMap.find_opt node t.t.content with
+      | None -> []
+      | Some x -> x
+    in
+    let newcode, newassignments =
+      (List.fold_left2
+         (fun (acc, assignments) btw code ->
+            let na, nc = replace_code btw assignments code in
+            (acc @ [nc], na)
+         )
+         ([], assignments)
+         livevars.internalbetween
+         code)
+    in
+    let newcontent = Cfg.NodeMap.add
+        node
+        newcode
+        t.t.content
+    in
+
+    let newt = { t with t = { t.t with content = newcontent } } in
+    (newassignments, newt)
+  in
+
+  (* --------- *)
+
+  let assignments = VariableMap.empty in
+
+  let a, newt =
+    Cfg.NodeSet.fold (* for each node we replace all the variables with the
+                        optimized ones *)
+      (fun node (ass, t) -> aux ass t node)
+      t.t.nodes
+      (assignments, t)
+  in
+
+  { newt with
+    t = { newt.t with
+          inputOutputVar =
+            match newt.t.inputOutputVar with
+              None -> None
+            | Some (i, o) -> (
+                match VariableMap.find_opt i a, VariableMap.find_opt o a with
+                | None, None -> Some (i, o)
+                | Some i, None -> Some (i, o)
+                | None, Some o -> Some (i, o)
+                | Some i, Some o -> Some (i, o)
+              )
+        }}
 
 
 let compute_cfg (dvcfg: DVCfg.t) : RISCCfg.t =