From 93f9aa39b2885f98bf2be89583102d5c7f4c6f22 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 16 Sep 2020 09:13:59 +0200 Subject: just missing OpWeights for AARCH64 --- scheduling/RTLpathScheduleraux.ml | 368 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 368 insertions(+) create mode 100644 scheduling/RTLpathScheduleraux.ml (limited to 'scheduling/RTLpathScheduleraux.ml') diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml new file mode 100644 index 00000000..88f777a5 --- /dev/null +++ b/scheduling/RTLpathScheduleraux.ml @@ -0,0 +1,368 @@ +open RTLpath +open RTL +open Maps +open RTLpathLivegenaux +open Registers +open Camlcoq + +type superblock = { + instructions: P.t array; (* pointers to code instructions *) + (* each predicted Pcb has its attached liveins *) + (* This is indexed by the pc value *) + liveins: Regset.t PTree.t; + (* Union of the input_regs of the last successors *) + output_regs: Regset.t; + 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 "}" + end + +let print_superblocks lsb code = + let rec f = function + | [] -> () + | sb :: lsb -> (print_superblock sb code; dprintf ",\n"; f lsb) + in begin + dprintf "[\n"; + f lsb; + dprintf "]" + 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 = + let liveins = ref (PTree.empty) in + let rec follow pc n = + let inst = get_some @@ PTree.get pc code in + if (n == 0) then begin + (match (non_predicted_successors inst) with + | [pcout] -> + let live = (get_some @@ PTree.get pcout pm).input_regs in + liveins := PTree.set pc live !liveins + | _ -> ()); + ([pc], successors_inst inst) + end else + let nexts_from_exit = match (non_predicted_successors inst) with + | [pcout] -> + let live = (get_some @@ PTree.get pcout pm).input_regs in begin + liveins := PTree.set pc live !liveins; + [pcout] + end + | [] -> [] + | _ -> failwith "Having more than one non_predicted_successor is not handled" + in match (predicted_successor inst) with + | None -> failwith "Incorrect path" + | Some succ -> + let (insts, nexts) = follow succ (n-1) in (pc :: insts, nexts_from_exit @ nexts) + in if (get_some @@ PTree.get pc !visited) then [] + else begin + visited := PTree.set pc true !visited; + let pi = get_some @@ PTree.get pc pm in + let (insts, nexts) = follow pc (Camlcoq.Nat.to_int pi.psize) in + let superblock = { instructions = Array.of_list insts; liveins = !liveins; + output_regs = pi.output_regs; typing = typing } in + superblock :: (List.concat @@ List.map get_superblocks_rec nexts) + end + in let lsb = get_superblocks_rec entry in begin + (* debug_flag := true; *) + dprintf "Superblocks identified:"; print_superblocks lsb code; dprintf "\n"; + (* debug_flag := false; *) + lsb +end + +(* TODO David *) +let schedule_superblock sb code = + if not !Clflags.option_fprepass + then sb.instructions + else + let old_flag = !debug_flag in + debug_flag := true; + print_endline "ORIGINAL SUPERBLOCK"; + print_superblock sb code; + debug_flag := old_flag; + let nr_instr = Array.length sb.instructions in + let trailer_length = + match PTree.get (sb.instructions.(nr_instr-1)) code with + | None -> 0 + | Some ii -> + match predicted_successor ii with + | Some _ -> 0 + | None -> 1 in + match PrepassSchedulingOracle.schedule_sequence + (Array.map (fun i -> + (match PTree.get i code with + | Some ii -> ii + | None -> failwith "RTLpathScheduleraux.schedule_superblock"), + (match PTree.get i sb.liveins with + | Some s -> s + | None -> Regset.empty)) + (Array.sub sb.instructions 0 (nr_instr-trailer_length))) with + | None -> sb.instructions + | Some order -> + let ins' = + Array.append + (Array.map (fun i -> sb.instructions.(i)) order) + (Array.sub sb.instructions (nr_instr-trailer_length) trailer_length) in + Printf.printf "REORDERED SUPERBLOCK %d\n" (Array.length ins'); + debug_flag := true; + print_instructions (Array.to_list ins') code; + debug_flag := old_flag; + flush stdout; + assert ((Array.length sb.instructions) = (Array.length ins')); + (*sb.instructions; *) + ins';; + + (* stub2: reverse function *) + (* + let reversed = Array.of_list @@ List.rev @@ Array.to_list (sb.instructions) in + let tmp = reversed.(0) in + let last_index = Array.length reversed - 1 in + begin + reversed.(0) <- reversed.(last_index); + reversed.(last_index) <- tmp; + reversed + end *) + (* stub: identity function *) + +(** + * Perform basic checks on the new order : + * - must have the same length as the old order + * - non basic instructions (call, tailcall, return, jumptable, non predicted CB) must not move + *) +let check_order code old_order new_order = begin + assert ((Array.length old_order) == (Array.length new_order)); + let length = Array.length new_order in + if length > 0 then + let last_inst = Array.get old_order (length - 1) in + let instr = get_some @@ PTree.get last_inst code in + match predicted_successor instr with + | None -> + if (last_inst != Array.get new_order (length - 1)) then + failwith "The last instruction of the superblock is not basic, but was moved" + | _ -> () +end + +type sinst = + (* Each middle instruction has a direct successor *) + (* A Smid can be the last instruction of a superblock, but a Send cannot be moved *) + | Smid of RTL.instruction * node + | Send of RTL.instruction + +let rinst_to_sinst inst = + match inst with + | Inop n -> Smid(inst, n) + | Iop (_,_,_,n) -> Smid(inst, n) + | Iload (_,_,_,_,_,n) -> Smid(inst, n) + | Istore (_,_,_,_,n) -> Smid(inst, n) + | Icond (_,_,n1,n2,p) -> ( + match p with + | Some true -> Smid(inst, n1) + | Some false -> Smid(inst, n2) + | None -> Send(inst) + ) + | Icall _ | Ibuiltin _ | Ijumptable _ | Itailcall _ | Ireturn _ -> Send(inst) + +let change_predicted_successor s = function + | Smid(i, n) -> Smid(i, s) + | Send _ -> failwith "Called change_predicted_successor on Send. Are you trying to move a non-basic instruction in the middle of the block?" + +(* Forwards the successor changes into an RTL instruction *) +let sinst_to_rinst = function + | Smid(inst, s) -> ( + match inst 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) + | 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 "Non predicted Icond as a middle instruction!" + ) + | _ -> failwith "That instruction shouldn't be a middle instruction" + ) + | Send i -> i + +let apply_schedule code sb new_order = + let tc = ref code in + let old_order = sb.instructions in + begin + check_order code old_order new_order; + Array.iteri (fun i n' -> + let inst' = get_some @@ PTree.get n' code in + let iend = Array.length old_order - 1 in + let new_inst = + if (i == iend) then + let final_inst_node = Array.get old_order iend in + let sinst' = rinst_to_sinst inst' in + match sinst' with + (* The below assert fails if a Send is in the middle of the original superblock *) + | Send i -> (assert (final_inst_node == n'); i) + | Smid _ -> + let final_inst = get_some @@ PTree.get final_inst_node code in + match rinst_to_sinst final_inst with + | Smid (_, s') -> sinst_to_rinst @@ change_predicted_successor s' sinst' + | Send _ -> assert(false) (* should have failed earlier *) + else + sinst_to_rinst + (* this will fail if the moved instruction is a Send *) + @@ change_predicted_successor (Array.get old_order (i+1)) + @@ rinst_to_sinst inst' + in tc := PTree.set (Array.get old_order i) new_inst !tc + ) new_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 + 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 + 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_flag := false; *) + do_schedule new_code lsb + end + +let get_ok r = match r with Errors.OK x -> x | _ -> failwith "Did not get OK" + +let scheduler f = + let code = f.fn_RTL.fn_code in + let id_ptree = PTree.map (fun n i -> n) (f.fn_path) in + let entry = f.fn_RTL.fn_entrypoint in + let pm = f.fn_path in + let typing = get_ok @@ RTLtyping.type_function f.fn_RTL in + let lsb = get_superblocks code entry pm typing in + begin + (* debug_flag := true; *) + dprintf "Pathmap:\n"; dprintf "\n"; + print_path_map pm; + dprintf "Superblocks:\n"; + print_superblocks lsb code; dprintf "\n"; + (* debug_flag := false; *) + let tc = do_schedule code lsb in + (((tc, entry), pm), id_ptree) + end -- cgit