Partially fixing turning loads into non trap

There are now too many loads turned into non trap. To be investigated

1 files changed, 56 insertions, 22 deletions

diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml
index e57ac3f1..22ac47c9 100644
--- a/scheduling/RTLpathScheduleraux.ml
+++ b/scheduling/RTLpathScheduleraux.ml
@@ -6,7 +6,7 @@ open Registers
 open Camlcoq
 open Machine
 
-let has_non_trapping_loads = !(Machine.config).has_non_trapping_loads
+let config = Machine.config
 
 type superblock = {
   instructions: P.t array; (* pointers to code instructions *)
@@ -225,10 +225,22 @@ let sinst_to_rinst = function
 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 apply_schedule code sb new_order =
   let tc = ref code in
   let old_order = sb.instructions in
-  let count_cbs order =
+  let count_cbs order code =
     let current_cbs = ref HashedSet.PSet.empty in
     let cbs_above = ref PTree.empty in
     Array.iter (fun n ->
@@ -237,9 +249,12 @@ let apply_schedule code sb new_order =
       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 successors, nothing else *)
+    (* 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
@@ -262,31 +277,50 @@ 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 into non-trapping when needed, if the architecture supports it *)
-    if has_non_trapping_loads then begin
-      (* 1) We remember which CBs are "above" a given load *)
-      let cbs_above = count_cbs old_order in
-      (* 2) We do the same for new_order *)
-      let cbs_above' = count_cbs new_order in
-      (* 3) We examine each load, turn it into non-trapping if cbs_above is not included in cbs_above' *)
-      Array.iter (fun n ->
-        let inst = get_some @@ PTree.get n !tc in
-        match inst with
-        | Iload (t,a,b,c,d,s) -> 
-            let pset = get_some @@ PTree.get n cbs_above in
-            let pset' = get_some @@ PTree.get n cbs_above' in
-            if not @@ HashedSet.PSet.is_subset pset pset' then tc := PTree.set n (Iload (AST.NOTRAP,a,b,c,d,s)) !tc
-        | _ -> ()
-      ) old_order
-    end;
+    (* 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 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) -> dprintf "Examining load number %d\n" (P.to_int n');
+          let pset = 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 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;