From 3408be46000279a5282658375053f9a83a88cf58 Mon Sep 17 00:00:00 2001 From: Pierre Goutagny Date: Wed, 16 Jun 2021 16:23:52 +0200 Subject: Add Tunneling factorisation module --- backend/Tunnelinglibs.ml | 237 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 237 insertions(+) create mode 100644 backend/Tunnelinglibs.ml (limited to 'backend') diff --git a/backend/Tunnelinglibs.ml b/backend/Tunnelinglibs.ml new file mode 100644 index 00000000..ce384dac --- /dev/null +++ b/backend/Tunnelinglibs.ml @@ -0,0 +1,237 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* TODO: Proper author information *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(* + +This file implements the core functions of the tunneling passes, for both RTL +and LTL, by using a simplified CFG as a transparent interface + +See [Tunneling.v] and [RTLTunneling.v] + +*) + +open Coqlib +open Maps +open Camlcoq + +(* type of labels in the cfg *) +type label = int * P.t + +(* instructions under analyzis *) +type simple_inst = (* a simplified view of instructions *) + BRANCH of node +| COND of node * node +| OTHER +and node = { + lab: label; + mutable inst: simple_inst; + mutable link: node; (* link in the union-find: itself for non "nop"-nodes, target of the "nop" otherwise *) + mutable dist: int; + mutable tag: int + } + +type cfg_node = (int, node) Hashtbl.t + +type lnode = P.t + +(* type of the (simplified) CFG *) +type cfg = { + nodes: cfg_node; + mutable rems: node list; (* remaining conditions that may become lbranch or not *) + mutable num_rems: int; + mutable iter_num: int (* number of iterations in elimination of conditions *) + } + +module Tunneling = functor + (LANG: sig + type code_unit (* the type of a node of the code cfg (an instruction or a bblock *) + type funct + end) + (OPT: sig + val langname: string + val limit_tunneling: int option (* for debugging: [Some x] limit the number of iterations *) + val debug_flag: bool ref + val final_dump: bool (* set to true to have a more verbose debugging *) + end) + (FUNS: sig + type lang + type code_type + + (* build [c.nodes] and accumulate in [acc] conditions at beginning of LTL basic-blocks *) + val build_simplified_cfg: cfg -> cfg_node list -> lnode -> + LANG.code_unit -> cfg_node list + + val print_code_unit: cfg -> bool -> (int * LANG.code_unit) -> bool + + val fn_code: LANG.funct -> LANG.code_unit PTree.t + val fn_entrypoint: LANG.funct -> lnode + + val check_code_unit: LANG.code_unit PTree.t -> lnode -> LANG.code_unit -> unit + end) +-> struct + +let debug fmt = + if !OPT.debug_flag then Printf.eprintf fmt + else Printf.ifprintf stderr fmt + +exception BugOnPC of int + +let lab_i (n: node): int = fst n.lab +let lab_p (n: node): P.t = snd n.lab + +let rec target c n = (* inspired from the "find" of union-find algorithm *) + match n.inst with + | COND(s1,s2) -> + if n.link != n + then update c n + else if n.tag < c.iter_num then ( + (* we try to change the condition ... *) + n.tag <- c.iter_num; (* ... but at most once by iteration *) + let ts1 = target c s1 in + let ts2 = target c s2 in + if ts1 == ts2 then (n.link <- ts1; ts1) else n + ) else n + | _ -> + if n.link != n + then update c n + else n +and update c n = + let t = target c n.link in + n.link <- t; t + +let get_node c p = + let li = P.to_int p in + try + Hashtbl.find c.nodes li + with + Not_found -> + let rec n = { lab = (li, p); inst = OTHER; link = n ; dist = 0; tag = 0 } in + Hashtbl.add c.nodes li n; + n + +let set_branch c p s = + let li = P.to_int p in + try + let n = Hashtbl.find c.nodes li in + n.inst <- BRANCH s; + n.link <- target c s + with + Not_found -> + let n = { lab = (li,p); inst = BRANCH s; link = target c s; dist = 0; tag = 0 } in + Hashtbl.add c.nodes li n + + + +(* try to change a condition into a branch +[acc] is the current accumulator of conditions to consider in the next iteration of repeat_change_cond +*) +let try_change_cond c acc pc = + match pc.inst with + | COND(s1,s2) -> + let ts1 = target c s1 in + let ts2 = target c s2 in + if ts1 == ts2 then ( + pc.link <- ts1; + c.num_rems <- c.num_rems - 1; + acc + ) else + pc::acc + | _ -> raise (BugOnPC (lab_i pc)) (* COND expected *) + +(* repeat [try_change_cond] until no condition is changed into a branch *) +let rec repeat_change_cond c = + c.iter_num <- c.iter_num + 1; + debug "++ %sTunneling.branch_target %d: remaining number of conds to consider + = %d\n" OPT.langname (c.iter_num) (c.num_rems); + let old = c.num_rems in + c.rems <- List.fold_left (try_change_cond c) [] c.rems; + let curr = c.num_rems in + let continue = + match OPT.limit_tunneling with + | Some n -> curr < old && c.iter_num < n + | None -> curr < old + in + if continue + then repeat_change_cond c + + +(* compute the final distance of each nop nodes to its target *) +let undef_dist = -1 +let self_dist = undef_dist-1 +let rec dist n = + if n.dist = undef_dist + then ( + n.dist <- self_dist; (* protection against an unexpected loop in the data-structure *) + n.dist <- + (match n.inst with + | OTHER -> 0 + | BRANCH p -> 1 + dist p + | COND (p1,p2) -> 1 + (max (dist p1) (dist p2))); + n.dist + ) else if n.dist=self_dist then raise (BugOnPC (lab_i n)) + else n.dist + +let final_export f c = + let count = ref 0 in + let filter_nops_init_dist _ n acc = + let tn = target c n in + if tn == n + then ( + n.dist <- 0; (* force [n] to be a base case in the recursion of [dist] *) + acc + ) else ( + n.dist <- undef_dist; (* force [dist] to compute the actual [n.dist] *) + count := !count+1; + n::acc + ) + in + let nops = Hashtbl.fold filter_nops_init_dist c.nodes [] in + let res = List.fold_left (fun acc n -> PTree.set (lab_p n) (lab_p n.link, Z.of_uint (dist n)) acc) PTree.empty nops in + debug "* %sTunneling.branch_target: final number of eliminated nops = %d\n" + OPT.langname !count; + res + +(*********************************************) +(*** START: printing and debugging functions *) + +let string_of_labeli nodes ipc = + try + let pc = Hashtbl.find nodes ipc in + if pc.link == pc + then Printf.sprintf "(Target@%d)" (dist pc) + else Printf.sprintf "(Nop %d @%d)" (lab_i pc.link) (dist pc) + with + Not_found -> "" + +let print_cfg (f: LANG.funct) c = + let a = Array.of_list (PTree.fold (fun acc pc cu -> (P.to_int pc,cu)::acc) (FUNS.fn_code f) []) in + Array.fast_sort (fun (i1,_) (i2,_) -> i2 - i1) a; + let ep = P.to_int (FUNS.fn_entrypoint f) in + debug "entrypoint: %d %s\n" ep (string_of_labeli c.nodes ep); + let println = Array.fold_left (FUNS.print_code_unit c) false a in + (if println then debug "\n");debug "remaining cond:"; + List.iter (fun n -> debug "%d " (lab_i n)) c.rems; + debug "\n" + +(*************************************************************) +(* Copy-paste of the extracted code of the verifier *) +(* with [raise (BugOnPC (P.to_int pc))] instead of [Error.*] *) + +(** val check_code : coq_UF -> code -> unit res **) + +let check_code td c = + PTree.fold (fun _ pc cu -> FUNS.check_code_unit td pc cu) c (()) + +(*** END: copy-paste & debugging functions *******) + +end -- cgit