1 files changed, 89 insertions, 126 deletions

diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml
index 66910bdf..a294d0b5 100644
--- a/scheduling/RTLpathScheduleraux.ml
+++ b/scheduling/RTLpathScheduleraux.ml
@@ -4,6 +4,10 @@ open Maps
 open RTLpathLivegenaux
 open Registers
 open Camlcoq
+open Machine
+open DebugPrint
+
+let config = Machine.config
 
 type superblock = {
   instructions: P.t array; (* pointers to code instructions *)
@@ -15,54 +19,26 @@ type superblock = {
   typing: RTLtyping.regenv
 }
 
-let print_instructions insts code =
-  if (!debug_flag) then begin
-    dprintf "[ ";
-    List.iter (
-      fun n -> (PrintRTL.print_instruction stdout (P.to_int n, get_some @@ PTree.get n code))
-    ) insts; dprintf "]"
-  end
-
 let print_superblock sb code =
   let insts = sb.instructions in
   let li = sb.liveins in
   let outs = sb.output_regs in
   begin
-    dprintf "{ instructions = "; print_instructions (Array.to_list insts) code; dprintf "\n";
-    dprintf "  liveins = "; print_ptree_regset li; dprintf "\n";
-    dprintf "  output_regs = "; print_regset outs; dprintf "}"
+    debug "{ instructions = "; print_instructions (Array.to_list insts) code; debug "\n";
+    debug "  liveins = "; print_ptree_regset li; debug "\n";
+    debug "  output_regs = "; print_regset outs; debug "}"
   end
 
 let print_superblocks lsb code =
   let rec f = function
     | [] -> ()
-    | sb :: lsb -> (print_superblock sb code; dprintf ",\n"; f lsb)
+    | sb :: lsb -> (print_superblock sb code; debug ",\n"; f lsb)
   in begin
-    dprintf "[\n";
+    debug "[\n";
     f lsb;
-    dprintf "]"
+    debug "]"
   end
 
-(* Adapted from backend/PrintRTL.ml: print_function *)
-let print_code code = let open PrintRTL in let open Printf in
-  if (!debug_flag) then begin
-    fprintf stdout "{\n";
-    let instrs =
-      List.sort
-        (fun (pc1, _) (pc2, _) -> compare pc2 pc1)
-        (List.rev_map
-          (fun (pc, i) -> (P.to_int pc, i))
-          (PTree.elements code)) in
-    List.iter (print_instruction stdout) instrs;
-    fprintf stdout "}"
-  end
-
-let print_arrayp arr = begin
-  dprintf "[| ";
-  Array.iter (fun n -> dprintf "%d, " (P.to_int n)) arr;
-  dprintf "|]"
-end
-
 let get_superblocks code entry pm typing =
   let visited = ref (PTree.map (fun n i -> false) code) in
   let rec get_superblocks_rec pc =
@@ -100,7 +76,7 @@ let get_superblocks code entry pm typing =
     end
   in let lsb = get_superblocks_rec entry in begin
     (* debug_flag := true; *)
-    dprintf "Superblocks identified:"; print_superblocks lsb code; dprintf "\n";
+    debug "Superblocks identified:"; print_superblocks lsb code; debug "\n";
     (* debug_flag := false; *)
     lsb
 end
@@ -219,11 +195,45 @@ let sinst_to_rinst = function
       )
   | Send i -> i
 
+let is_a_cb = function Icond _ -> true | _ -> false
+let is_a_load = function Iload _ -> true | _ -> false
+
+let find_array arr n =
+  let index = ref None in
+  begin
+    Array.iteri (fun i n' ->
+      if n = n' then
+        match !index with
+        | Some _ -> failwith "More than one element present"
+        | None -> index := Some i
+    ) arr;
+    !index
+  end
+
+let rec hashedset_from_list = function
+  | [] -> HashedSet.PSet.empty
+  | n::ln -> HashedSet.PSet.add n (hashedset_from_list ln)
+
+let hashedset_map f hs = hashedset_from_list @@ List.map f @@ HashedSet.PSet.elements hs
+
 let apply_schedule code sb new_order =
   let tc = ref code in
   let old_order = sb.instructions in
-  begin
+  let count_cbs order code =
+    let current_cbs = ref HashedSet.PSet.empty in
+    let cbs_above = ref PTree.empty in
+    Array.iter (fun n ->
+      let inst = get_some @@ PTree.get n code in
+      if is_a_cb inst then current_cbs := HashedSet.PSet.add n !current_cbs
+      else if is_a_load inst then cbs_above := PTree.set n !current_cbs !cbs_above
+    ) order;
+    !cbs_above
+  in let fmap n =
+    let index = get_some @@ find_array new_order n in
+    old_order.(index)
+  in begin
     check_order code old_order new_order;
+    (* First pass - modify the positions, nothing else *)
     Array.iteri (fun i n' ->
       let inst' = get_some @@ PTree.get n' code in
       let iend = Array.length old_order - 1 in
@@ -246,103 +256,56 @@ let apply_schedule code sb new_order =
           @@ rinst_to_sinst inst'
       in tc := PTree.set (Array.get old_order i) new_inst !tc
     ) new_order;
+    (* Second pass - turn the loads back into trapping when it was not needed *)
+    (* 1) We remember which CBs are "above" a given load *)
+    let cbs_above = count_cbs old_order code in
+    (* 2) We do the same for new_order *)
+    let cbs_above' = count_cbs (Array.map fmap new_order) !tc in
+    (* 3) We examine each load, turn it back into trapping if cbs_above is included in cbs_above' *)
+    Array.iter (fun n ->
+      let n' = fmap n in
+      let inst' = get_some @@ PTree.get n' !tc in
+      match inst' with
+      | Iload (t,a,b,c,d,s) ->
+          let pset = hashedset_map fmap @@ get_some @@ PTree.get n cbs_above in
+          let pset' = get_some @@ PTree.get n' cbs_above' in
+          if HashedSet.PSet.is_subset pset pset' then tc := PTree.set n' (Iload (AST.TRAP,a,b,c,d,s)) !tc
+          else assert !config.has_non_trapping_loads
+      | _ -> ()
+    ) old_order;
     !tc
   end
 
-  (*
-let main_successors = function
-| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n]
-| Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> [n]
-| Icond (_,_,n1,n2,p) -> (
-    match p with
-    | Some true -> [n1; n2]
-    | Some false ->  [n2; n1]
-    | None -> [n1; n2] )
-| Ijumptable _ | Itailcall _ | Ireturn _ -> []
-
-let change_predicted_successor i s = match i with
-  | Itailcall _ | Ireturn _ -> failwith "Wrong instruction (5) - Tailcalls and returns should not be moved in the middle of a superblock"
-  | Ijumptable _ -> failwith "Wrong instruction (6) - Jumptables should not be moved in the middle of a superblock"
-  | Inop n -> Inop s
-  | Iop (a,b,c,n) -> Iop (a,b,c,s)
-  | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s)
-  | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s)
-  | Icall (a,b,c,d,n) -> Icall (a,b,c,d,s)
-  | Ibuiltin (a,b,c,n) -> Ibuiltin (a,b,c,s)
-  | Icond (a,b,n1,n2,p) -> (
-      match p with
-      | Some true -> Icond (a,b,s,n2,p)
-      | Some false -> Icond (a,b,n1,s,p)
-      | None -> failwith "Predicted a successor for an Icond with p=None - unpredicted CB should not be moved in the middle of the superblock"
-      )
-
-let rec change_successors i = function
-  | [] -> (
-      match i with
-      | Itailcall _ | Ireturn _ -> i
-      | _ -> failwith "Wrong instruction (1)")
-  | [s] -> (
-      match i with
-      | Inop n -> Inop s
-      | Iop (a,b,c,n) -> Iop (a,b,c,s)
-      | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s)
-      | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s)
-      | Icall (a,b,c,d,n) -> Icall (a,b,c,d,s)
-      | Ibuiltin (a,b,c,n) -> Ibuiltin (a,b,c,s)
-      | Ijumptable (a,[n]) -> Ijumptable (a,[s])
-      | Icond (a,b,n1,n2,p) -> (
-          match p with
-          | Some true -> Icond (a,b,s,n2,p)
-          | Some false -> Icond (a,b,n1,s,p)
-          | None -> failwith "Icond Wrong instruction (2) ; should not happen?"
-        )
-      | _ -> failwith "Wrong instruction (2)")
-  | [s1; s2] -> (
-      match i with
-      | Icond (a,b,n1,n2,p) -> Icond (a,b,s1,s2,p)
-      | Ijumptable (a, [n1; n2]) -> Ijumptable (a, [s1; s2])
-      | _ -> change_successors i [s1])
-  | ls -> (
-      match i with
-      | Ijumptable (a, ln) -> begin
-          assert ((List.length ln) == (List.length ls));
-          Ijumptable (a, ls)
-        end
-      | _ -> failwith "Wrong instruction (4)")
-
-
-let apply_schedule code sb new_order =
-  let tc = ref code in
-  let old_order = sb.instructions in
-  let last_node = Array.get old_order (Array.length old_order - 1) in
-  let last_successors = main_successors
-    @@ get_some @@ PTree.get last_node code in
-  begin
-    check_order code old_order new_order;
-    Array.iteri (fun i n' ->
-      let inst' = get_some @@ PTree.get n' code in
-      let new_inst =
-        if (i == (Array.length old_order - 1)) then
-          change_successors inst' last_successors
-        else
-          change_predicted_successor inst' (Array.get old_order (i+1))
-      in tc := PTree.set (Array.get old_order i) new_inst !tc
-    ) new_order;
-    !tc
+let turn_all_loads_nontrap sb code =
+  if not !config.has_non_trapping_loads then code
+  else begin
+    let code' = ref code in
+    Array.iter (fun n ->
+      let inst = get_some @@ PTree.get n code in
+      match inst with
+      | Iload (t,a,b,c,d,s) -> code' := PTree.set n (Iload (AST.NOTRAP,a,b,c,d,s)) !code'
+      | _ -> ()
+    ) sb.instructions;
+    !code'
   end
-*)
 
 let rec do_schedule code = function
   | [] -> code
   | sb :: lsb ->
-      let schedule = schedule_superblock sb code in
-      let new_code = apply_schedule code sb schedule in
+      (* Trick: instead of turning loads into non trap as needed..
+       * First, we turn them all into non-trap.
+       * Then, we turn back those who didn't need to be turned, into TRAP again
+       * This is because the scheduler (rightfully) refuses to schedule ahead of a branch
+       * operations that might trap *)
+      let code' = turn_all_loads_nontrap sb code in
+      let schedule = schedule_superblock sb code' in
+      let new_code = apply_schedule code' sb schedule in
       begin
         (* debug_flag := true; *)
-        dprintf "Old Code: "; print_code code;
-        dprintf "\nSchedule to apply: "; print_arrayp schedule;
-        dprintf "\nNew Code: "; print_code new_code;
-        dprintf "\n";
+        debug "Old Code: "; print_code code;
+        debug "\nSchedule to apply: "; print_arrayp schedule;
+        debug "\nNew Code: "; print_code new_code;
+        debug "\n";
         (* debug_flag := false; *)
         do_schedule new_code lsb
       end
@@ -358,10 +321,10 @@ let scheduler f =
   let lsb = get_superblocks code entry pm typing in
   begin
     (* debug_flag := true; *)
-    dprintf "Pathmap:\n"; dprintf "\n";
+    debug "Pathmap:\n"; debug "\n";
     print_path_map pm;
-    dprintf "Superblocks:\n";
-    print_superblocks lsb code; dprintf "\n";
+    debug "Superblocks:\n";
+    print_superblocks lsb code; debug "\n";
     (* debug_flag := false; *)
     let tc = do_schedule code lsb in
     (((tc, entry), pm), id_ptree)