diff options
Diffstat (limited to 'backend/Duplicateaux.ml')
| -rw-r--r-- | backend/Duplicateaux.ml | 164 |
1 files changed, 36 insertions, 128 deletions
diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index ac960945..324acd99 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -99,39 +99,27 @@ let rtl_successors = LICMaux.rtl_successors * Excludes any node given in excluded function *) let bfs_until code entrypoint (predicate: node->bool) (excluded: node->bool) = begin debug "bfs\n"; - let module E = struct - exception Done - end in - - let num_nodes = ref 0 in - let num_visited = ref 0 in - let visited = ref (PTree.map (fun n i -> num_nodes := !num_nodes + 1; false) code) + let visited = ref (PTree.map (fun n i -> false) code) and bfs_list = ref [] and to_visit = Queue.create () and node = ref entrypoint in begin Queue.add entrypoint to_visit; - try - while not (Queue.is_empty to_visit) do - node := Queue.pop to_visit; - if (not (get_some @@ PTree.get !node !visited)) then begin - visited := PTree.set !node true !visited; - num_visited := !num_visited + 1; - if not (excluded !node) then begin - match PTree.get !node code with - | None -> failwith "No such node" - | Some i -> - bfs_list := !node :: !bfs_list; - if !num_visited = !num_nodes then raise_notrace E.Done - else begin - if not (predicate !node) then - let succ = rtl_successors i in List.iter (fun n -> Queue.add n to_visit) succ - end - end + while not (Queue.is_empty to_visit) do + node := Queue.pop to_visit; + if (not (get_some @@ PTree.get !node !visited)) then begin + visited := PTree.set !node true !visited; + if not (excluded !node) then begin + match PTree.get !node code with + | None -> failwith "No such node" + | Some i -> + bfs_list := !node :: !bfs_list; + if not (predicate !node) then + let succ = rtl_successors i in List.iter (fun n -> Queue.add n to_visit) succ end - done; - List.rev !bfs_list - with E.Done -> List.rev !bfs_list + end + done; + List.rev !bfs_list end end @@ -312,9 +300,7 @@ let rec find_last_node_before_loop code node trace is_loop_header = (* The computation of sb_final requires to already have branch prediction *) let get_inner_loops f code is_loop_header = let fake_f = { fn_sig = f.fn_sig; fn_params = f.fn_params; - fn_stacksize = f.fn_stacksize; fn_code = code; fn_entrypoint = f.fn_entrypoint; - fn_untrusted_analysis = { answer_to_life_the_universe_and_everything = None; - staged_header_dup = None } } in + fn_stacksize = f.fn_stacksize; fn_code = code; fn_entrypoint = f.fn_entrypoint } in let (_, predmap, loopmap) = LICMaux.inner_loops fake_f in begin debug "PREDMAP: "; print_ptree print_intlist predmap; @@ -942,21 +928,6 @@ let clone code revmap ln = begin (!code', revmap', ln', fwmap) end -let clone_only_new code next_pc ln = begin - assert (List.length ln > 0); - let len = List.length ln in - let ln' = List.init len (fun n -> n + next_pc) in - let fwmap = generate_fwmap ln ln' PTree.empty in - let revmap' = generate_revmap ln (List.map P.of_int ln') PTree.empty in - let code' = ref PTree.empty 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', fwmap, next_pc + len) -end - let rec count_ignore_nops code = function | [] -> 0 | n::ln -> @@ -1063,45 +1034,31 @@ let extract_upto_icond f code head = let rec extract h = let inst = get_some @@ PTree.get h code in match inst with - | Icond _ -> Some [h] + | Icond _ -> [h] | _ -> ( match rtl_successors inst with - | [n] -> begin - (* testing if we reached the starting point - * (this could happen in the case of an unconditional infinite loop in the source code) - *) - if n = head then None - else match extract n with - | Some l -> Some (h :: l) - | None -> None - end + | [n] -> h :: (extract n) | _ -> failwith "Found a node with more than one successor??" ) - in - match extract head with - | None -> None - | Some(res) -> Some (List.rev res) + in List.rev @@ extract head let rotate_inner_loop f code revmap iloop = - let header_opt = extract_upto_icond f code iloop.head in - match header_opt with - | None -> (code, revmap) - | Some header -> - let limit = !Clflags.option_flooprotate in - let nb_duplicated = count_ignore_nops code header in - if nb_duplicated > limit then begin - debug "Loop Rotate: too many nodes to duplicate (%d > %d)" (List.length header) limit; - (code, revmap) - end else if nb_duplicated == count_ignore_nops code iloop.body then begin - debug "The conditional branch is already at the end! No need to rotate."; - (code, revmap) - end else - let (code2, revmap2, dupheader, fwmap) = clone code revmap header in - let code' = ref code2 in - let head' = apply_map fwmap iloop.head in - begin - code' := change_pointers !code' iloop.head head' iloop.preds; - (!code', revmap2) - end + let header = extract_upto_icond f code iloop.head in + let limit = !Clflags.option_flooprotate in + let nb_duplicated = count_ignore_nops code header in + if nb_duplicated > limit then begin + debug "Loop Rotate: too many nodes to duplicate (%d > %d)" (List.length header) limit; + (code, revmap) + end else if nb_duplicated == count_ignore_nops code iloop.body then begin + debug "The conditional branch is already at the end! No need to rotate."; + (code, revmap) + end else + let (code2, revmap2, dupheader, fwmap) = clone code revmap header in + let code' = ref code2 in + let head' = apply_map fwmap iloop.head in + begin + code' := change_pointers !code' iloop.head head' iloop.preds; + (!code', revmap2) + end let rotate_inner_loops f code revmap = let is_loop_header = get_loop_headers code (f.fn_entrypoint) in @@ -1178,52 +1135,3 @@ let tail_duplicate f = superblockify_traces code preds is_loop_header traces revmap else (code, revmap) in ((code, entrypoint), revmap) - -(* TODO: copied here to avoid cyclic dependency... *) -let my_merge_no_overwrite m1 m2 = - PTree.combine (fun x y -> match (x, y) with - | None, None -> None - | Some x, None - | None, Some x -> Some x - | Some _, Some _ -> failwith "Merge conflict." - ) m1 m2 - -let my_merge_overwrite m1 m2 = - PTree.combine (fun x y -> match (x, y) with - | None, None -> None - | Some x, None - | None, Some x -> Some x - | Some _, Some y -> Some y - ) m1 m2 - -let lift_if f = - (* do nothing for now *) - let entrypoint = f.fn_entrypoint in - let code = f.fn_code in - let revmap = make_identity_ptree code in - (* TODO predicate this transformation on a compiler flag *) - let (code', revmap') = - if !Clflags.option_fliftif > 0 then ( - Clflags.option_fcse3_only_conditions := true; - (* lift_if_inner_loops f code revmap *) - match f.fn_untrusted_analysis.staged_header_dup with - | None -> (code, revmap) - | Some(staged_revmap, staged_dupcode) -> - let code = my_merge_overwrite code staged_dupcode in - let revmap = my_merge_no_overwrite revmap staged_revmap in - (code, revmap) ) - else - (code, revmap) - in - - let old_debug_flag = !debug_flag in - debug_flag := false; - debug "Old entrypoint = %d, new entrypoint = %d\n" (P.to_int entrypoint) (P.to_int @@ get_some @@ PTree.get entrypoint revmap'); - debug "Code before if-lifting:\n"; flush_all (); - print_code code; flush_all (); - debug "Code after if-lifting:\n"; flush_all (); - print_code code'; flush_all (); - debug_flag := old_debug_flag; - - (* TODO: may the entrypoint change? *) - ((code', entrypoint), revmap')
\ No newline at end of file |