diff options
Diffstat (limited to 'backend/Duplicateaux.ml')
| -rw-r--r-- | backend/Duplicateaux.ml | 164 |
1 files changed, 128 insertions, 36 deletions
diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 324acd99..ac960945 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -99,27 +99,39 @@ 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 visited = ref (PTree.map (fun n i -> false) code) + 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) and bfs_list = ref [] and to_visit = Queue.create () and node = ref entrypoint in begin Queue.add entrypoint to_visit; - 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 + 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 end - end - done; - List.rev !bfs_list + done; + List.rev !bfs_list + with E.Done -> List.rev !bfs_list end end @@ -300,7 +312,9 @@ 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 } in + 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 let (_, predmap, loopmap) = LICMaux.inner_loops fake_f in begin debug "PREDMAP: "; print_ptree print_intlist predmap; @@ -928,6 +942,21 @@ 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 -> @@ -1034,31 +1063,45 @@ let extract_upto_icond f code head = let rec extract h = let inst = get_some @@ PTree.get h code in match inst with - | Icond _ -> [h] + | Icond _ -> Some [h] | _ -> ( match rtl_successors inst with - | [n] -> h :: (extract n) + | [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 | _ -> failwith "Found a node with more than one successor??" ) - in List.rev @@ extract head + in + match extract head with + | None -> None + | Some(res) -> Some (List.rev res) let rotate_inner_loop f code revmap iloop = - 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 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 rotate_inner_loops f code revmap = let is_loop_header = get_loop_headers code (f.fn_entrypoint) in @@ -1135,3 +1178,52 @@ 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 |