From 3410d085513f045e2215419da85dccd3cc88779a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 6 Oct 2020 17:48:59 +0200 Subject: [BROKEN] Some progress, need to figure out conversion HashedPSet -> List --- backend/Duplicateaux.ml | 125 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 111 insertions(+), 14 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index fe062e73..b54ac5dc 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -484,11 +484,11 @@ let rec make_identity_ptree_rec = function let make_identity_ptree code = make_identity_ptree_rec (PTree.elements code) -(* Change the pointers of preds nodes to point to n' instead of n *) +(* Change the pointers of nodes to point to n' instead of n *) let rec change_pointers code n n' = function | [] -> code - | pred :: preds -> - let new_pred_inst = match ptree_get_some pred code with + | node :: nodes -> + let new_pred_inst = match ptree_get_some node code with | Icall(a, b, c, d, n0) -> assert (n0 == n); Icall(a, b, c, d, n') | Ibuiltin(a, b, c, n0) -> assert (n0 == n); Ibuiltin(a, b, c, n') | Ijumptable(a, ln) -> assert (optbool @@ List.find_opt (fun e -> e == n) ln); @@ -502,8 +502,8 @@ let rec change_pointers code n n' = function | Iload (a, b, c, d, e, n0) -> assert (n0 == n); Iload (a, b, c, d, e, n') | Istore (a, b, c, d, n0) -> assert (n0 == n); Istore (a, b, c, d, n') | Itailcall _ | Ireturn _ -> failwith "That instruction cannot be a predecessor" - in let new_code = PTree.set pred new_pred_inst code - in change_pointers new_code n n' preds + in let new_code = PTree.set node new_pred_inst code + in change_pointers new_code n n' nodes (* parent: parent of n to keep as parent * preds: all the other parents of n @@ -527,13 +527,15 @@ let is_empty = function | [] -> true | _ -> false +let next_free_pc code = maxint (List.map (fun e -> let (n, _) = e in P.to_int n) (PTree.elements code)) + 1 + (* code: RTL code * preds: mapping node -> predecessors * ptree: the revmap * trace: the trace to follow tail duplication on *) let tail_duplicate code preds ptree trace = (* next_int: unused integer that can be used for the next duplication *) - let next_int = ref (maxint (List.map (fun e -> let (n, _) = e in P.to_int n) (PTree.elements code)) + 1) + let next_int = ref (next_free_pc code) (* last_node and last_duplicate store resp. the last processed node of the trace, and its duplication *) in let last_node = ref None in let last_duplicate = ref None @@ -567,9 +569,8 @@ let tail_duplicate code preds ptree trace = in let new_code, new_ptree = f code ptree true trace in (new_code, new_ptree, !nb_duplicated) -let superblockify_traces code preds traces = +let superblockify_traces code preds traces ptree = let max_nb_duplicated = !Clflags.option_fduplicate (* FIXME - should be architecture dependent *) - in let ptree = make_identity_ptree code in let rec f code ptree = function | [] -> (code, ptree, 0) | trace :: traces -> @@ -652,27 +653,123 @@ let get_inner_loops f = ) all_loops end -let unroll_inner_loops f = +let generate_fwmap ln ln' = + let rec f ln ln' fwmap = + match ln with + | [] -> begin + match ln' with + | [] -> fwmap + | _ -> failwith "ln and ln' have different lengths" + end + | n :: ln -> begin + match ln' with + | n' :: ln' -> f ln ln' (PTree.set n n' fwmap) + | _ -> failwith "ln and ln' have different lengths" + end + in f ln ln' PTree.empty + +let generate_revmap ln ln' = generate_fwmap ln' ln + +let apply_map fw n = P.of_int @@ ptree_get_some n fw + +let change_nexts fwmap = function + | Icall (a, b, c, d, n) -> Icall (a, b, c, d, apply_map fwmap n) + | Ibuiltin (a, b, c, n) -> Ibuiltin (a, b, c, apply_map fwmap n) + | Ijumptable (a, ln) -> Ijumptable (a, List.map (apply_map fwmap) ln) + | Icond (a, b, n1, n2, i) -> Icond (a, b, apply_map fwmap n1, apply_map fwmap n2, i) + | Inop n -> Inop (apply_map fwmap n) + | Iop (a, b, c, n) -> Iop (a, b, c, apply_map fwmap n) + | Iload (a, b, c, d, e, n) -> Iload (a, b, c, d, e, apply_map fwmap n) + | Istore (a, b, c, d, n) -> Istore (a, b, c, d, apply_map fwmap n) + | Itailcall (a, b, c) -> Itailcall (a, b, c) + | Ireturn o -> Ireturn o + +(* let change_single_next n' = function + | Icall (a, b, c, d, n) -> Icall (a, b, c, d, n') + | Ibuiltin (a, b, c, n) -> Ibuiltin (a, b, c, n') + | Inop n -> Inop n' + | Iop (a, b, c, n) -> Iop (a, b, c, n') + | Iload (a, b, c, d, e, n) -> Iload (a, b, c, d, e, n') + | Istore (a, b, c, d, n) -> Istore (a, b, c, d, n') + | _ -> failwith "Not an instruction with single successor" + *) + +(** Clone a list of instructions into free pc indexes + * + * The list of instructions should be contiguous, and not include any loop. + * It is assumed that the first instruction of the list is the head. + * Also, the last instruction of the list should be the loop backedge. + * + * Returns: (code', revmap', ln', fwmap) + * code' is the updated code, after cloning + * revmap' is the updated revmap + * ln' is the list of the new indexes used to reference the cloned instructions + * fwmap is a map from ln to ln' + *) +let clone code revmap ln = begin + assert (List.length ln > 0); + let head' = next_free_pc code in + let head = P.to_int @@ List.hd ln in + let ln' = List.map (fun n -> n + (head' - head)) @@ List.map P.to_int ln in + let fwmap = generate_fwmap ln ln' in + let revmap' = generate_revmap ln (List.map P.of_int ln') in + let code' = ref code in + List.iter (fun n -> + let instr = get_some @@ PTree.get n code in + let instr' = change_nexts fwmap instr in + code' := PTree.set (apply_map fwmap n) instr' !code' + ) ln; + (!code', revmap', ln') +end + +(** Unrolls a single interation of the inner loop + * 1) Clones the body into body' + * 2) Links the preds to the first instruction of body' + * 3) Links the last instruction of body' into the first instruction of body + *) +(** FIXME - we expect a list, not a hashed PSet! + * Either we need a notion of first element / last element + * Or we need to explicitly label the head and final instructions of the inner loop + *) +let unroll_inner_loop_single code revmap iloop = + let (code2, revmap2, dupbody, fwmap) = clone code revmap (iloop.body) in + let code' = ref code2 in + let first_n = List.hd (iloop.body) in + let first_n' = List.hd dupbody in + let last_n' = List.hd @@ List.rev dupbody in + begin + code' := change_pointers !code' first_n first_n' (iloop.preds); + code' := change_pointers !code' first_n' first_n [last_n']; + (* code' := PTree.set last_n' (change_single_next first_n @@ ptree_get_some last_n' !code') !code' *) + (!code', revmap2) + end + +let unroll_inner_loops_single f revmap = let inner_loops = get_inner_loops f in + let code' = ref f.fn_code in + let revmap' = ref revmap in begin - debug_flag := true; print_inner_loops inner_loops; - debug_flag := false; + List.iter (fun iloop -> + let (new_code, new_revmap) = unroll_inner_loop_single !code' !revmap' iloop in + code' := new_code; revmap' := new_revmap + ) inner_loops; + (!code', !revmap') end let duplicate_aux f = begin - unroll_inner_loops f; let entrypoint = f.fn_entrypoint in if !Clflags.option_fduplicate < 0 then ((f.fn_code, entrypoint), make_identity_ptree f.fn_code) else - let code = update_directions (f.fn_code) entrypoint in + let (code, revmap) = unroll_inner_loops_single f (make_identity_ptree code) in + let code = update_directions code entrypoint in let traces = select_traces code entrypoint in let icond_code = invert_iconds code traces in let preds = get_predecessors_rtl icond_code in if !Clflags.option_fduplicate >= 1 then - let (new_code, pTreeId) = ((* print_traces traces; *) superblockify_traces icond_code preds traces) in + let (new_code, pTreeId) = superblockify_traces icond_code preds traces revmap in ((new_code, f.fn_entrypoint), pTreeId) else ((icond_code, entrypoint), make_identity_ptree code) -- cgit