aboutsummaryrefslogtreecommitdiffstats
path: root/src/SoftwarePipelining/SPBasic.ml
diff options
context:
space:
mode:
authorYann Herklotz <git@yannherklotz.com>2020-12-17 12:36:28 +0000
committerYann Herklotz <git@yannherklotz.com>2020-12-17 12:36:28 +0000
commit051b2d07e66a89281fde102e850a4fc386dabdae (patch)
tree90d8b5f5681fb4dc9ab87e90218b5be4adf9d850 /src/SoftwarePipelining/SPBasic.ml
parent520ce1b13a7843efe110d0ae3b9ae16795a92b08 (diff)
downloadvericert-051b2d07e66a89281fde102e850a4fc386dabdae.tar.gz
vericert-051b2d07e66a89281fde102e850a4fc386dabdae.zip
Fix whitespace
Diffstat (limited to 'src/SoftwarePipelining/SPBasic.ml')
-rw-r--r--src/SoftwarePipelining/SPBasic.ml834
1 files changed, 417 insertions, 417 deletions
diff --git a/src/SoftwarePipelining/SPBasic.ml b/src/SoftwarePipelining/SPBasic.ml
index 1269faf..dd2b5c1 100644
--- a/src/SoftwarePipelining/SPBasic.ml
+++ b/src/SoftwarePipelining/SPBasic.ml
@@ -23,8 +23,8 @@ open SPSymbolic_evaluation
type node = instruction * int
module G = Graph.Persistent.Digraph.AbstractLabeled
- (struct type t = node end)
- (struct type t = int let compare = compare let default = 0 end)
+ (struct type t = node end)
+ (struct type t = int let compare = compare let default = 0 end)
module Topo = Graph.Topological.Make (G)
module Dom = Graph.Dominator.Make (G)
module Index = Map.Make (struct type t = int let compare = compare end)
@@ -37,7 +37,7 @@ let string_of_instruction node =
| (Istore (chunk, mode, args, src),n) -> Printf.sprintf "%i store %i %s" n (to_int src) (string_of_args args)
| (Icall (sign, id, args, dst),n) -> Printf.sprintf "%i call" n
| (Itailcall (sign, id, args),n) -> Printf.sprintf "%i tailcall" n
-(* | (Ialloc (dst, size),n) -> Printf.sprintf "%i %i := alloc" n (to_int dst) *)
+ (* | (Ialloc (dst, size),n) -> Printf.sprintf "%i %i := alloc" n (to_int dst) *)
| (Icond (cond, args),n) -> Printf.sprintf "%i cond %s %s" n (string_of_cond cond) (string_of_args args)
| (Ireturn (res),n) -> Printf.sprintf "%i return" n
@@ -66,7 +66,7 @@ let display g name =
ignore (Sys.command ("(dot -Tpng " ^ addr ^ " -o " ^ addr ^ ".png ; rm -f " ^ addr ^ ") & "))
(******************************************)
-
+
type cfg = {graph : G.t; start : G.V.t}
(* convert traduit un graphe RTL compcert en un graphe RTL ocamlgraph*)
@@ -79,58 +79,58 @@ let convert f =
in
let (graph, index) = Maps.PTree.fold (fun (g,m) key inst ->
- let node = make_node inst key in
- (G.add_vertex g node, Index.add (to_int key) node m)
- ) f.fn_code (G.empty,Index.empty)
+ let node = make_node inst key in
+ (G.add_vertex g node, Index.add (to_int key) node m)
+ ) f.fn_code (G.empty,Index.empty)
in
let succ = RTL.successors_map f in
let rec link n succs g =
match succs with
- | [] -> g
- | pos::[] ->
- G.add_edge g (Index.find (to_int n) index) (Index.find (to_int pos) index)
- | pos1::pos2::[] ->
- let g = G.add_edge_e g (G.E.create (Index.find (to_int n) index) 1 (Index.find (to_int pos1) index)) in
- G.add_edge_e g (G.E.create (Index.find (to_int n) index) 2 (Index.find (to_int pos2) index))
- | _ -> failwith "convert : trop de successeurs"
-
+ | [] -> g
+ | pos::[] ->
+ G.add_edge g (Index.find (to_int n) index) (Index.find (to_int pos) index)
+ | pos1::pos2::[] ->
+ let g = G.add_edge_e g (G.E.create (Index.find (to_int n) index) 1 (Index.find (to_int pos1) index)) in
+ G.add_edge_e g (G.E.create (Index.find (to_int n) index) 2 (Index.find (to_int pos2) index))
+ | _ -> failwith "convert : trop de successeurs"
+
in
let graph = Maps.PTree.fold ( fun g key inst ->
- link key (match Maps.PTree.get key succ with
+ link key (match Maps.PTree.get key succ with
Some x -> x | _ -> failwith "Could not index") g
- ) f.fn_code graph
+ ) f.fn_code graph
in
-
+
{graph = graph; start = Index.find (to_int (f.fn_entrypoint)) index}
-
-
+
+
let convert_back g =
-
- G.fold_vertex (fun node m ->
- let v = G.V.label node in
- match (fst v) with
- | Icond (_,_) ->
- begin
- let l =
- match G.succ_e g node with
- | [e1;e2] ->
- if G.E.label e1 > G.E.label e2
- then [G.E.dst e2;G.E.dst e1]
- else [G.E.dst e1;G.E.dst e2]
- | _ -> failwith "convert_back: nombre de successeurs incoherent"
- in
- let succs = List.map (fun s -> to_binpos (snd (G.V.label s))) l in
- Maps.PTree.set (to_binpos (snd v)) (inst_caml_to_coq (fst v) succs) m
- end
- | _ ->
- let succs = List.map (fun s -> to_binpos (snd (G.V.label s))) (G.succ g node) in
- Maps.PTree.set (to_binpos (snd v)) (inst_caml_to_coq (fst v) succs) m
- ) g Maps.PTree.empty
-
-
-
+
+ G.fold_vertex (fun node m ->
+ let v = G.V.label node in
+ match (fst v) with
+ | Icond (_,_) ->
+ begin
+ let l =
+ match G.succ_e g node with
+ | [e1;e2] ->
+ if G.E.label e1 > G.E.label e2
+ then [G.E.dst e2;G.E.dst e1]
+ else [G.E.dst e1;G.E.dst e2]
+ | _ -> failwith "convert_back: nombre de successeurs incoherent"
+ in
+ let succs = List.map (fun s -> to_binpos (snd (G.V.label s))) l in
+ Maps.PTree.set (to_binpos (snd v)) (inst_caml_to_coq (fst v) succs) m
+ end
+ | _ ->
+ let succs = List.map (fun s -> to_binpos (snd (G.V.label s))) (G.succ g node) in
+ Maps.PTree.set (to_binpos (snd v)) (inst_caml_to_coq (fst v) succs) m
+ ) g Maps.PTree.empty
+
+
+
(* dominator_tree calcule l'arbre de domination grace au code de FP *)
let dominator_tree f =
@@ -142,16 +142,16 @@ let dominator_tree f =
let detect_loops graph dom_tree =
let rec is_dominating v1 v2 l = (* does v1 dominate v2 *)
match dom_tree v2 with
- | v -> if v1 = v then Some (v :: l)
- else is_dominating v1 v (v :: l)
- | exception (Not_found) -> None
+ | v -> if v1 = v then Some (v :: l)
+ else is_dominating v1 v (v :: l)
+ | exception (Not_found) -> None
in
G.fold_edges (fun v1 v2 loops ->
- match is_dominating v2 v1 [v1] with
- | None -> loops
- | Some loop -> (v2,loop) :: loops
- ) graph []
+ match is_dominating v2 v1 [v1] with
+ | None -> loops
+ | Some loop -> (v2,loop) :: loops
+ ) graph []
let print_index node =
Printf.printf "%i " (snd (G.V.label node))
@@ -167,43 +167,43 @@ let print_instruction node =
(*| (Ialloc (dst, size),n) -> Printf.printf "%i : Ialloc \n" n *)
| (Icond (cond, args),n) -> Printf.printf "%i : Icond \n" n
| (Ireturn (res),n) -> Printf.printf "%i : Ireturn \n" n
-
+
let is_rewritten node r =
match fst (G.V.label node) with
- | Inop -> false
- | Iop (op, args, dst) -> if dst = r then true else false
- | Iload (chunk, mode, args, dst) -> if dst = r then failwith "J'ai degote une boucle ZARBI !!!" else false
- | Istore (chunk, mode, args, src) -> false
- | Icall (sign, id, args, dst) -> failwith "call in a loop"
- | Itailcall (sign, id, args) -> failwith "tailcall in a loop"
-(* | Ialloc (dst, size) -> if dst = r then failwith "J'ai degote une boucle ZARBI !!!" else false *)
- | Icond (cond, args) -> false
- | Ireturn (res) -> failwith "return in a loop"
+ | Inop -> false
+ | Iop (op, args, dst) -> if dst = r then true else false
+ | Iload (chunk, mode, args, dst) -> if dst = r then failwith "J'ai degote une boucle ZARBI !!!" else false
+ | Istore (chunk, mode, args, src) -> false
+ | Icall (sign, id, args, dst) -> failwith "call in a loop"
+ | Itailcall (sign, id, args) -> failwith "tailcall in a loop"
+ (* | Ialloc (dst, size) -> if dst = r then failwith "J'ai degote une boucle ZARBI !!!" else false *)
+ | Icond (cond, args) -> false
+ | Ireturn (res) -> failwith "return in a loop"
let is_variant r loop =
List.fold_right (fun node b ->
- is_rewritten node r || b
- ) loop false
+ is_rewritten node r || b
+ ) loop false
let is_pipelinable loop = (* true if loop is innermost and without control *)
-
+
let is_acceptable node =
match fst (G.V.label node) with
- | Icall _ | Itailcall _ | Ireturn _ | Icond _ (*| Ialloc _*) | Iop ((Ocmp _),_,_)-> false
- | _ -> true
+ | Icall _ | Itailcall _ | Ireturn _ | Icond _ (*| Ialloc _*) | Iop ((Ocmp _),_,_)-> false
+ | _ -> true
in
-
+
let is_branching node =
match fst (G.V.label node) with
- | Icond _ -> true
- | _ -> false
+ | Icond _ -> true
+ | _ -> false
in
let is_nop node =
match fst (G.V.label node) with
- | Inop -> true
- | _ -> false
+ | Inop -> true
+ | _ -> false
in
let is_OK_aux l =
@@ -212,160 +212,160 @@ let is_pipelinable loop = (* true if loop is innermost and without control *)
let is_bounded node loop =
match G.V.label node with
- | (Icond (cond, args),n) ->
- let args = to_caml_list args in
- begin
- match args with
- | [] -> false
- | r :: [] -> is_variant r loop (* used to be not *)
- | r1 :: r2 :: [] ->
- begin
- match is_variant r1 loop, is_variant r2 loop with
- | true, true -> false
- | false, true -> true
- | true, false -> true
- | false, false -> false
- end
- | _ -> false
- end
- | _ -> false
+ | (Icond (cond, args),n) ->
+ let args = to_caml_list args in
+ begin
+ match args with
+ | [] -> false
+ | r :: [] -> not (is_variant r loop) (* used to be not *)
+ | r1 :: r2 :: [] ->
+ begin
+ match is_variant r1 loop, is_variant r2 loop with
+ | true, true -> false
+ | false, true -> true
+ | true, false -> true
+ | false, false -> false
+ end
+ | _ -> false
+ end
+ | _ -> false
in
match List.rev loop with
- | v2 :: v1 :: l -> ((*Printf.printf "is_nop: %s | " (is_nop v1 |> string_of_bool);*)
- Printf.printf "is_branching: %s | " (is_branching v2 |> string_of_bool);
- Printf.printf "is_OK_aux: %s | " (is_OK_aux l |> string_of_bool);
- Printf.printf "is_bounded: %s\n" (is_bounded v2 loop |> string_of_bool);
- (*is_nop v1 && *)is_branching v2 && is_OK_aux l && is_bounded v2 loop)
- | _ -> false
-
+ | v2 :: v1 :: l -> ((*Printf.printf "is_nop: %s | " (is_nop v1 |> string_of_bool);*)
+ Printf.printf "is_branching: %s | " (is_branching v2 |> string_of_bool);
+ Printf.printf "is_OK_aux: %s | " (is_OK_aux l |> string_of_bool);
+ Printf.printf "is_bounded: %s\n" (is_bounded v2 loop |> string_of_bool);
+ (*is_nop v1 && *)is_branching v2 && is_OK_aux l && is_bounded v2 loop)
+ | _ -> false
+
let print_loops loops =
List.iter (fun loop -> print_index (fst(loop));
- print_newline ();
- List.iter print_index (snd(loop));
- print_newline ();
- if is_pipelinable (snd(loop)) then print_string "PIPELINABLE !" else print_string "WASTE";
- print_newline ();
- List.iter print_instruction (snd(loop));
- print_newline ()
- ) loops
-
+ print_newline ();
+ List.iter print_index (snd(loop));
+ print_newline ();
+ if is_pipelinable (snd(loop)) then print_string "PIPELINABLE !" else print_string "WASTE";
+ print_newline ();
+ List.iter print_instruction (snd(loop));
+ print_newline ()
+ ) loops
+
(* type resource = Reg of reg | Mem *)
module Sim = Map.Make (struct type t = resource let compare = compare end)
let map_get key map =
try Some (Sim.find key map)
with
- | Not_found -> None
+ | Not_found -> None
let rec to_res l =
match l with
- | [] -> []
- | e :: l -> Reg e :: to_res l
+ | [] -> []
+ | e :: l -> Reg e :: to_res l
let resources_reads_of node =
match fst (G.V.label node) with
- | Inop -> []
- | Iop (op, args, dst) -> to_res args
- | Iload (chunk, mode, args, dst) -> Mem :: (to_res args)
- | Istore (chunk, mode, args, src) -> Mem :: Reg src :: (to_res args)
- | Icall (sign, id, args, dst) -> failwith "Resource read of call"
- | Itailcall (sign, id, args) -> failwith "Resource read of tailcall"
- (*| Ialloc (dst, size) -> [Mem] *)
- | Icond (cond, args) -> to_res args
- | Ireturn (res) -> failwith "Resource read of return"
-
+ | Inop -> []
+ | Iop (op, args, dst) -> to_res args
+ | Iload (chunk, mode, args, dst) -> Mem :: (to_res args)
+ | Istore (chunk, mode, args, src) -> Mem :: Reg src :: (to_res args)
+ | Icall (sign, id, args, dst) -> failwith "Resource read of call"
+ | Itailcall (sign, id, args) -> failwith "Resource read of tailcall"
+ (*| Ialloc (dst, size) -> [Mem] *)
+ | Icond (cond, args) -> to_res args
+ | Ireturn (res) -> failwith "Resource read of return"
+
let resources_writes_of node =
match fst (G.V.label node) with
- | Inop -> []
- | Iop (op, args, dst) -> [Reg dst]
- | Iload (chunk, mode, args, dst) -> [Reg dst]
- | Istore (chunk, mode, args, src) -> [Mem]
- | Icall (sign, id, args, dst) -> failwith "Resource read of call"
- | Itailcall (sign, id, args) -> failwith "Resource read of tailcall"
- (*| Ialloc (dst, size) -> (Reg dst) :: [Mem]*)
- | Icond (cond, args) -> []
- | Ireturn (res) -> failwith "Resource read of return"
-
+ | Inop -> []
+ | Iop (op, args, dst) -> [Reg dst]
+ | Iload (chunk, mode, args, dst) -> [Reg dst]
+ | Istore (chunk, mode, args, src) -> [Mem]
+ | Icall (sign, id, args, dst) -> failwith "Resource read of call"
+ | Itailcall (sign, id, args) -> failwith "Resource read of tailcall"
+ (*| Ialloc (dst, size) -> (Reg dst) :: [Mem]*)
+ | Icond (cond, args) -> []
+ | Ireturn (res) -> failwith "Resource read of return"
+
let build_intra_dependency_graph loop =
-
+
let rec build_aux graph read write l =
match l with
- | [] -> (graph,(read,write))
- | v :: l->
- let g = G.add_vertex graph v in
- let reads = resources_reads_of v in
- let writes = resources_writes_of v in
- (* dependances RAW *)
- let g = List.fold_right (fun r g ->
- match map_get r write with
- | Some n -> G.add_edge_e g (G.E.create n 1 v)
- | None -> g
- ) reads g in
- (* dependances WAR *)
- let g = List.fold_right (fun r g ->
- match map_get r read with
- | Some l -> List.fold_right (fun n g -> G.add_edge_e g (G.E.create n 2 v)) l g
- | None -> g
- ) writes g in
- (* dependances WAW *)
- let g = List.fold_right (fun r g ->
- match map_get r write with
- | Some n -> G.add_edge_e g (G.E.create n 3 v)
- | None -> g
- ) writes g in
- let write = List.fold_right (fun r m -> Sim.add r v m) writes write in
- let read_tmp = List.fold_right (fun r m ->
- match map_get r read with
- | Some al -> Sim.add r (v :: al) m
- | None -> Sim.add r (v :: []) m
- ) reads read
- in
- let read = List.fold_right (fun r m -> Sim.add r [] m) writes read_tmp in
-
- build_aux g read write l
+ | [] -> (graph,(read,write))
+ | v :: l->
+ let g = G.add_vertex graph v in
+ let reads = resources_reads_of v in
+ let writes = resources_writes_of v in
+ (* dependances RAW *)
+ let g = List.fold_right (fun r g ->
+ match map_get r write with
+ | Some n -> G.add_edge_e g (G.E.create n 1 v)
+ | None -> g
+ ) reads g in
+ (* dependances WAR *)
+ let g = List.fold_right (fun r g ->
+ match map_get r read with
+ | Some l -> List.fold_right (fun n g -> G.add_edge_e g (G.E.create n 2 v)) l g
+ | None -> g
+ ) writes g in
+ (* dependances WAW *)
+ let g = List.fold_right (fun r g ->
+ match map_get r write with
+ | Some n -> G.add_edge_e g (G.E.create n 3 v)
+ | None -> g
+ ) writes g in
+ let write = List.fold_right (fun r m -> Sim.add r v m) writes write in
+ let read_tmp = List.fold_right (fun r m ->
+ match map_get r read with
+ | Some al -> Sim.add r (v :: al) m
+ | None -> Sim.add r (v :: []) m
+ ) reads read
+ in
+ let read = List.fold_right (fun r m -> Sim.add r [] m) writes read_tmp in
+
+ build_aux g read write l
in
build_aux G.empty Sim.empty Sim.empty (List.tl loop)
-
+
let build_inter_dependency_graph loop =
let rec build_aux2 graph read write l =
match l with
- | [] -> graph
- | v :: l->
- let g = graph in
- let reads = resources_reads_of v in
- let writes = resources_writes_of v in
- (* dependances RAW *)
- let g = List.fold_right (fun r g ->
- match map_get r write with
- | Some n -> (* if n = v then g else *) G.add_edge_e g (G.E.create n 4 v)
- | None -> g
- ) reads g in
- (* dependances WAR *)
- let g = List.fold_right (fun r g ->
- match map_get r read with
- | Some l -> List.fold_right
- (fun n g -> (* if n = v then g else *) G.add_edge_e g (G.E.create n 5 v)) l g
- | None -> g
- ) writes g in
- (* dependances WAW *)
- let g = List.fold_right (fun r g ->
- match map_get r write with
- | Some n -> (* if n = v then g else *) G.add_edge_e g (G.E.create n 6 v)
- | None -> g
- ) writes g in
- let write = List.fold_right (fun r m -> Sim.remove r m) writes write in
- let read = List.fold_right (fun r m -> Sim.remove r m) writes read in
-
-
- build_aux2 g read write l
+ | [] -> graph
+ | v :: l->
+ let g = graph in
+ let reads = resources_reads_of v in
+ let writes = resources_writes_of v in
+ (* dependances RAW *)
+ let g = List.fold_right (fun r g ->
+ match map_get r write with
+ | Some n -> (* if n = v then g else *) G.add_edge_e g (G.E.create n 4 v)
+ | None -> g
+ ) reads g in
+ (* dependances WAR *)
+ let g = List.fold_right (fun r g ->
+ match map_get r read with
+ | Some l -> List.fold_right
+ (fun n g -> (* if n = v then g else *) G.add_edge_e g (G.E.create n 5 v)) l g
+ | None -> g
+ ) writes g in
+ (* dependances WAW *)
+ let g = List.fold_right (fun r g ->
+ match map_get r write with
+ | Some n -> (* if n = v then g else *) G.add_edge_e g (G.E.create n 6 v)
+ | None -> g
+ ) writes g in
+ let write = List.fold_right (fun r m -> Sim.remove r m) writes write in
+ let read = List.fold_right (fun r m -> Sim.remove r m) writes read in
+
+
+ build_aux2 g read write l
in
let (g,(r,w)) = build_intra_dependency_graph loop in
build_aux2 g r w (List.tl loop)
-
+
(* patch_graph prepare le graphe pour la boucle commencant au noeud entry
qui a une borne de boucle bound et pour un software pipelining
de au minimum min tours et de deroulement ur *)
@@ -390,7 +390,7 @@ let patch_graph graph entry lastone loop bound min ur r1 r2 r3 r4 next_pc prolog
let wannabes = List.filter (fun e -> not (e = lastone)) wannabes in
let graph = List.fold_right (fun e g -> G.remove_edge_e g e) preds_e graph in
let graph = G.add_edge graph lastone entry in
-
+
(* 2. Add the test for minimal iterations and link it*)
let cond = G.V.create (Icond ((Ccompimm (Integers.Cle,min)),to_coq_list [bound]), next_pc) in
@@ -400,11 +400,11 @@ let patch_graph graph entry lastone loop bound min ur r1 r2 r3 r4 next_pc prolog
(* 3. Link its predecessors and successors *)
(* It is false in case there is a condition that points to the entry:
inthis case, the edge should not be labeled with 0 !*)
-
+
let graph = List.fold_right (fun n g -> G.add_edge g n cond) wannabes graph in
let graph = G.add_edge_e graph (G.E.create cond 1 entry) in
-
+
(* 4. Add the div and modulo code, link it *)
let n1 = G.V.create (Iop ((Ointconst ur),to_coq_list [],r1),next_pc) in
let next_pc = next_pc + 1 in
@@ -426,56 +426,56 @@ let patch_graph graph entry lastone loop bound min ur r1 r2 r3 r4 next_pc prolog
let graph = G.add_edge graph n2 n3 in
let graph = G.add_edge graph n3 n4 in
let graph = G.add_edge graph n4 n5 in
-
+
(* 5. Fabriquer la pipelined loop et la linker, sans la condition d entree *)
-
+
let (graph,next_pc,l) = List.fold_right (fun e (g,npc,l) ->
- let n = G.V.create (e,npc) in
- (G.add_vertex g n, npc+1, n :: l)
- ) loop (graph,next_pc,[]) in
+ let n = G.V.create (e,npc) in
+ (G.add_vertex g n, npc+1, n :: l)
+ ) loop (graph,next_pc,[]) in
let pipe_cond = List.hd l in
let pipeline = List.tl l in
-
+
let rec link l graph node =
match l with
- | n1 :: n2 :: l -> link (n2 :: l) (G.add_edge graph n1 n2) node
- | n1 :: [] -> G.add_edge graph n1 node
- | _ -> graph
+ | n1 :: n2 :: l -> link (n2 :: l) (G.add_edge graph n1 n2) node
+ | n1 :: [] -> G.add_edge graph n1 node
+ | _ -> graph
in
-
+
let graph = link pipeline graph pipe_cond in
-
+
(* link de l entree de la boucle *)
-
+
let (graph,next_pc,prolog) = List.fold_right (fun e (g,npc,l) ->
- let n = G.V.create (e,npc) in
- (G.add_vertex g n, npc+1, n :: l)
- ) prolog (graph,next_pc,[]) in
+ let n = G.V.create (e,npc) in
+ (G.add_vertex g n, npc+1, n :: l)
+ ) prolog (graph,next_pc,[]) in
let (graph,next_pc,epilog) = List.fold_right (fun e (g,npc,l) ->
- let n = G.V.create (e,npc) in
- (G.add_vertex g n, npc+1, n :: l)
- ) epilog (graph,next_pc,[]) in
+ let n = G.V.create (e,npc) in
+ (G.add_vertex g n, npc+1, n :: l)
+ ) epilog (graph,next_pc,[]) in
(* 6. Creation du reste et branchement et la condition *)
let n6 = G.V.create (Iop (Omove,to_coq_list [r4],bound),next_pc) in (* Iop (Omove,to_coq_list [r4],bound) *)
let next_pc = next_pc + 1 in
-
+
(* 7. Creation du ramp up *)
let ramp_up = List.map (fun (a,b) -> Iop (Omove, [b], a)) ramp_up in
let (graph,next_pc,ramp_up) = List.fold_right (fun e (g,npc,l) ->
- let n = G.V.create (e,npc) in
- (G.add_vertex g n, npc+1, n :: l)
- ) ramp_up (graph,next_pc,[]) in
+ let n = G.V.create (e,npc) in
+ (G.add_vertex g n, npc+1, n :: l)
+ ) ramp_up (graph,next_pc,[]) in
let next_pc = next_pc + 1 in
let ramp_down = List.map (fun (a,b) -> Iop (Omove,[b],a)) ramp_down in
let (graph,next_pc,ramp_down) = List.fold_right (fun e (g,npc,l) ->
- let n = G.V.create (e,npc) in
- (G.add_vertex g n, npc+1, n :: l)
- ) ramp_down (graph,next_pc,[]) in
+ let n = G.V.create (e,npc) in
+ (G.add_vertex g n, npc+1, n :: l)
+ ) ramp_down (graph,next_pc,[]) in
(* let next_pc = next_pc + 1 in *)
@@ -494,7 +494,7 @@ let patch_graph graph entry lastone loop bound min ur r1 r2 r3 r4 next_pc prolog
let graph = G.add_edge graph n6 entry in
graph
-
+
let regs_of_node node =
match G.V.label node with
| (Inop,n) -> []
@@ -510,45 +510,45 @@ let regs_of_node node =
let max_reg_of_graph graph params =
Printf.fprintf SPDebug.dc "Calcul du registre de depart.\n";
let regs = G.fold_vertex (fun node regs ->
- (regs_of_node node) @ regs
- ) graph [] in
+ (regs_of_node node) @ regs
+ ) graph [] in
let regs = regs @ params in
let max_reg = List.fold_right (fun reg max ->
- Printf.fprintf SPDebug.dc "%i " (P.to_int reg);
- if Int32.compare (P.to_int32 reg) max > 0
- then (P.to_int32 reg)
- else max
- ) regs Int32.zero in
-
+ Printf.fprintf SPDebug.dc "%i " (P.to_int reg);
+ if Int32.compare (P.to_int32 reg) max > 0
+ then (P.to_int32 reg)
+ else max
+ ) regs Int32.zero in
+
Printf.fprintf SPDebug.dc "MAX REG = %i\n" (Int32.to_int max_reg);
BinPos.Pos.succ (P.of_int32 max_reg)
-
+
let get_bound node loop =
match G.V.label node with
- | (Icond (cond, args),n) ->
- let args = to_caml_list args in
- begin
- match args with
- | [] -> failwith "get_bound: condition sans variables"
- | r :: [] -> if is_variant r loop then failwith "Pas de borne dans la boucle" else r
- | r1 :: r2 :: [] ->
- begin
- match is_variant r1 loop, is_variant r2 loop with
- | true, true -> failwith "Pas de borne dans la boucle "
- | false, true -> r1
- | true, false -> r2
- | false, false -> failwith "deux bornes possibles dans la boucle"
- end
- | _ -> failwith "get_bound: condition avec nombre de variables superieur a 2"
- end
- | _ -> failwith "get_bound: the node I was given is not a condition\n"
+ | (Icond (cond, args),n) ->
+ let args = to_caml_list args in
+ begin
+ match args with
+ | [] -> failwith "get_bound: condition sans variables"
+ | r :: [] -> if is_variant r loop then failwith "Pas de borne dans la boucle" else r
+ | r1 :: r2 :: [] ->
+ begin
+ match is_variant r1 loop, is_variant r2 loop with
+ | true, true -> failwith "Pas de borne dans la boucle "
+ | false, true -> r1
+ | true, false -> r2
+ | false, false -> failwith "deux bornes possibles dans la boucle"
+ end
+ | _ -> failwith "get_bound: condition avec nombre de variables superieur a 2"
+ end
+ | _ -> failwith "get_bound: the node I was given is not a condition\n"
let get_nextpc graph =
(G.fold_vertex (fun node max ->
- if (snd (G.V.label node)) > max
- then (snd (G.V.label node))
- else max
- ) graph 0) + 1
+ if (snd (G.V.label node)) > max
+ then (snd (G.V.label node))
+ else max
+ ) graph 0) + 1
let substitute_pipeline graph loop steady_state prolog epilog min unrolling ru rd params =
let n1 = max_reg_of_graph graph params in
@@ -562,7 +562,7 @@ let substitute_pipeline graph loop steady_state prolog epilog min unrolling ru r
let unrolling = Z.of_sint unrolling in
let next_pc = get_nextpc graph in
patch_graph graph way_in way_out steady_state bound min unrolling n1 n2 n3 n4 next_pc prolog epilog ru rd
-
+
let get_loops cfg =
let domi = dominator_tree cfg in
let loops = detect_loops cfg.graph domi in
@@ -571,7 +571,7 @@ let get_loops cfg =
loops
type pipeline = {steady_state : G.V.t list; prolog : G.V.t list; epilog : G.V.t list;
- min : int; unrolling : int; ramp_up : (reg * reg) list; ramp_down : (reg * reg) list}
+ min : int; unrolling : int; ramp_up : (reg * reg) list; ramp_down : (reg * reg) list}
let delete_indexes l = List.map (fun e -> fst (G.V.label e) ) l
@@ -581,107 +581,107 @@ let fresh = ref BinNums.Coq_xH
let distance e =
match G.E.label e with
- | 1 | 2 | 3 -> 0
- | _ -> 1
+ | 1 | 2 | 3 -> 0
+ | _ -> 1
type et = IntraRAW | IntraWAW | IntraWAR | InterRAW | InterWAW | InterWAR
let edge_type e =
match G.E.label e with
- | 1 -> IntraRAW
- | 2 -> IntraWAR
- | 3 -> IntraWAW
- | 4 -> InterRAW
- | 5 -> InterWAR
- | 6 -> InterWAW
- | _ -> failwith "Unknown edge type"
+ | 1 -> IntraRAW
+ | 2 -> IntraWAR
+ | 3 -> IntraWAW
+ | 4 -> InterRAW
+ | 5 -> InterWAR
+ | 6 -> InterWAW
+ | _ -> failwith "Unknown edge type"
let latency n = (* A raffiner *)
match fst (G.V.label n) with
- | Iop (op,args, dst) ->
- begin
- match op with
- | Omove -> 1
- (*| Oaddimm _ -> 1*)
- (*| Oadd -> 2*)
- | Omul -> 3
- | Odiv -> 30
- | Omulimm _ -> 5
- | _ -> 2
- end
- | Iload _ -> 10
-(* | Ialloc _ -> 20*)
- | _ -> 1
-
+ | Iop (op,args, dst) ->
+ begin
+ match op with
+ | Omove -> 1
+ (*| Oaddimm _ -> 1*)
+ (*| Oadd -> 2*)
+ | Omul -> 3
+ | Odiv -> 30
+ | Omulimm _ -> 5
+ | _ -> 2
+ end
+ | Iload _ -> 10
+ (* | Ialloc _ -> 20*)
+ | _ -> 1
+
let reforge_writes inst r =
G.V.create ((match fst (G.V.label inst) with
- | Inop -> Inop
- | Iop (op, args, dst) -> Iop (op, args, r)
- | Iload (chunk, mode, args, dst) -> Iload (chunk, mode, args, r)
- | Istore (chunk, mode, args, src) -> Istore (chunk, mode, args, src)
- | Icall (sign, id, args, dst) -> failwith "reforge_writes: call"
- | Itailcall (sign, id, args) -> failwith "reforge_writes: tailcall"
-(* | Ialloc (dst, size) -> Ialloc (r, size)*)
- | Icond (cond, args) -> Icond (cond, args)
- | Ireturn (res) -> failwith "reforge_writes: return")
- , snd (G.V.label inst))
+ | Inop -> Inop
+ | Iop (op, args, dst) -> Iop (op, args, r)
+ | Iload (chunk, mode, args, dst) -> Iload (chunk, mode, args, r)
+ | Istore (chunk, mode, args, src) -> Istore (chunk, mode, args, src)
+ | Icall (sign, id, args, dst) -> failwith "reforge_writes: call"
+ | Itailcall (sign, id, args) -> failwith "reforge_writes: tailcall"
+ (* | Ialloc (dst, size) -> Ialloc (r, size)*)
+ | Icond (cond, args) -> Icond (cond, args)
+ | Ireturn (res) -> failwith "reforge_writes: return")
+ , snd (G.V.label inst))
let rec reforge_args args oldr newr =
match args with
- | [] -> []
- | e :: l -> (if e = oldr then newr else e) :: (reforge_args l oldr newr)
+ | [] -> []
+ | e :: l -> (if e = oldr then newr else e) :: (reforge_args l oldr newr)
let rec mem_args args r =
match args with
- | [] -> false
- | e :: l -> if e = r then true else mem_args l r
+ | [] -> false
+ | e :: l -> if e = r then true else mem_args l r
let check_read_exists inst r =
match fst (G.V.label inst) with
- | Inop -> false
- | Iop (op, args, dst) -> mem_args args r
- | Iload (chunk, mode, args, dst) -> mem_args args r
- | Istore (chunk, mode, args, src) -> src = r || mem_args args r
- | Icall (sign, id, args, dst) -> mem_args args r
- | Itailcall (sign, id, args) -> false
- (*| Ialloc (dst, size) -> false*)
- | Icond (cond, args) -> mem_args args r
- | Ireturn (res) -> false
+ | Inop -> false
+ | Iop (op, args, dst) -> mem_args args r
+ | Iload (chunk, mode, args, dst) -> mem_args args r
+ | Istore (chunk, mode, args, src) -> src = r || mem_args args r
+ | Icall (sign, id, args, dst) -> mem_args args r
+ | Itailcall (sign, id, args) -> false
+ (*| Ialloc (dst, size) -> false*)
+ | Icond (cond, args) -> mem_args args r
+ | Ireturn (res) -> false
let reforge_reads inst oldr newr =
assert (check_read_exists inst oldr);
G.V.create ((match fst (G.V.label inst) with
- | Inop -> Inop
- | Iop (op, args, dst) -> Iop (op, reforge_args args oldr newr, dst)
- | Iload (chunk, mode, args, dst) -> Iload (chunk, mode, reforge_args args oldr newr, dst)
- | Istore (chunk, mode, args, src) -> Istore (chunk, mode, reforge_args args oldr newr , if src = oldr then newr else src)
- | Icall (sign, id, args, dst) -> failwith "reforge_reads: call"
- | Itailcall (sign, id, args) -> failwith "reforge_reads: tailcall"
- (*| Ialloc (dst, size) -> Ialloc (dst, size)*)
- | Icond (cond, args) -> Icond (cond, reforge_args args oldr newr)
- | Ireturn (res) -> failwith "reforge_reads: return")
- , snd (G.V.label inst))
+ | Inop -> Inop
+ | Iop (op, args, dst) -> Iop (op, reforge_args args oldr newr, dst)
+ | Iload (chunk, mode, args, dst) -> Iload (chunk, mode, reforge_args args oldr newr, dst)
+ | Istore (chunk, mode, args, src) -> Istore (chunk, mode, reforge_args args oldr newr , if src = oldr then newr else src)
+ | Icall (sign, id, args, dst) -> failwith "reforge_reads: call"
+ | Itailcall (sign, id, args) -> failwith "reforge_reads: tailcall"
+ (*| Ialloc (dst, size) -> Ialloc (dst, size)*)
+ | Icond (cond, args) -> Icond (cond, reforge_args args oldr newr)
+ | Ireturn (res) -> failwith "reforge_reads: return")
+ , snd (G.V.label inst))
let get_succs_raw ddg node =
let succs = G.succ_e ddg node in
let succs = List.filter (fun succ ->
- match G.E.label succ with
- | 1 | 4 -> true
- | _ -> false
- ) succs in
+ match G.E.label succ with
+ | 1 | 4 -> true
+ | _ -> false
+ ) succs in
List.map (fun e -> G.E.dst e) succs
let written inst =
match fst (G.V.label inst) with
- | Inop -> None
- | Iop (op, args, dst) -> Some dst
- | Iload (chunk, mode, args, dst) -> Some dst
- | Istore (chunk, mode, args, src) -> None
- | Icall (sign, id, args, dst) -> failwith "written: call"
- | Itailcall (sign, id, args) -> failwith "written: tailcall"
- (*| Ialloc (dst, size) -> Some dst*)
- | Icond (cond, args) -> None
- | Ireturn (res) -> failwith "written: return"
+ | Inop -> None
+ | Iop (op, args, dst) -> Some dst
+ | Iload (chunk, mode, args, dst) -> Some dst
+ | Istore (chunk, mode, args, src) -> None
+ | Icall (sign, id, args, dst) -> failwith "written: call"
+ | Itailcall (sign, id, args) -> failwith "written: tailcall"
+ (*| Ialloc (dst, size) -> Some dst*)
+ | Icond (cond, args) -> None
+ | Ireturn (res) -> failwith "written: return"
let fresh_regs n =
let t = Array.make n (BinNums.Coq_xH) in
@@ -690,27 +690,27 @@ let fresh_regs n =
fresh := BinPos.Pos.succ !fresh
done;
t
-
+
let print_reg r = Printf.fprintf SPDebug.dc "%i " (P.to_int r)
let is_cond node =
match fst (G.V.label node) with
- | Icond _ -> true
- | _ -> false
-
-
+ | Icond _ -> true
+ | _ -> false
+
+
(*******************************************)
-
+
let watch_regs l = List.fold_right (fun (a,b) l ->
- if List.mem a l then l else a :: l
- ) l []
+ if List.mem a l then l else a :: l
+ ) l []
let make_moves = List.map (fun (a,b) -> Iop (Omove,[b],a))
let rec repeat l n =
match n with
- | 0 -> []
- | n -> l @ repeat l (n-1)
+ | 0 -> []
+ | n -> l @ repeat l (n-1)
let fv = ref 0
@@ -722,98 +722,98 @@ let apply_pipeliner f p ?(debug=false) =
let loops = get_loops cfg in
Printf.fprintf SPDebug.dc "Loops: %d\n" (List.length loops);
let ddgs = List.map (fun (qqch,loop) -> (loop,build_inter_dependency_graph loop)) loops in
-
+
let lv = ref 0 in
let graph = List.fold_right (fun (loop,ddg) graph ->
- Printf.fprintf SPDebug.dc "__________________ NEW LOOP ____________________\n";
- Printf.printf "Pipelinable loop: ";
- incr lv;
- fresh := (BinPos.Pos.succ
- (BinPos.Pos.succ
- (BinPos.Pos.succ
- (BinPos.Pos.succ
- (BinPos.Pos.succ
- (max_reg_of_graph graph (to_caml_list f.fn_params)
- ))))));
- Printf.fprintf SPDebug.dc "FRESH = %i \n"
- (P.to_int !fresh);
- match p ddg with
- | Some pipe ->
- Printf.printf "Rock On ! Min = %i - Unroll = %i\n" pipe.min pipe.unrolling;
- let p = (make_moves pipe.ramp_up) @ (delete_indexes pipe.prolog) in
- let e = (delete_indexes pipe.epilog) @ (make_moves pipe.ramp_down) in
- let b = delete_indexes (List.tl (List.rev loop)) in
- let bt = (List.tl (delete_indexes pipe.steady_state)) in
- let cond1 = fst (G.V.label (List.hd (List.rev loop))) in
- let cond2 = (List.hd (delete_indexes pipe.steady_state)) in
-
- let bu = symbolic_evaluation (repeat b (pipe.min + 1)) in
- let pe = symbolic_evaluation (p @ e) in
- let bte = symbolic_evaluation (bt @ e) in
- let ebu = symbolic_evaluation (e @ repeat b pipe.unrolling) in
- let regs = watch_regs pipe.ramp_down in
- let c1 = symbolic_condition cond1 (repeat b pipe.unrolling) in
- let d1 = symbolic_condition cond1 (repeat b (pipe.min + 1)) in
- (*let c2 = symbolic_condition cond2 p in
- let d2 = symbolic_condition cond2 ((make_moves pipe.ramp_up) @ bt) in*)
-
-
-
- let sbt = symbolic_evaluation (bt) in
- let sep = symbolic_evaluation (e @ repeat b (pipe.unrolling - (pipe.min + 1)) @ p) in (* er @ pr *)
-
- Printf.printf "Initialisation : %s \n"
- (if symbolic_equivalence bu pe regs then "OK" else "FAIL");
- Printf.printf "Etat stable : %s \n"
- (if symbolic_equivalence bte ebu regs then "OK" else "FAIL");
- Printf.printf "Egalite fondamentale : %s \n"
- (if symbolic_equivalence sbt sep (watch_regs pipe.ramp_up) then "OK" else "FAIL");
- (* Printf.printf "Condition initiale : %s \n"
- (if c1 = c2 then "OK" else "FAIL");
- Printf.printf "Condition stable : %s \n"
- (if d1 = d2 then "OK" else "FAIL");
-
-
- Printf.fprintf SPDebug.dc "pbte\n";*)
- List.iter (fun e ->
- Printf.fprintf SPDebug.dc "%s\n"
- (string_of_node (G.V.create (e,0)))
- ) (p @ bt @ e);
- Printf.fprintf SPDebug.dc "bu\n";
- List.iter (fun e -> Printf.fprintf SPDebug.dc "%s\n"
- (string_of_node (G.V.create (e,0)))
- ) (repeat b (pipe.unrolling + pipe.min));
-
-
-
- if debug then
- display_st ("pbte"^ (string_of_int !fv) ^ (string_of_int !lv)) (p @ bt @ e) (watch_regs pipe.ramp_down);
- if debug then
- display_st ("bu"^ (string_of_int !fv) ^ (string_of_int !lv)) (repeat b (pipe.min + pipe.unrolling)) (watch_regs pipe.ramp_down);
-
- if debug then display_st ("bt"^ (string_of_int !fv) ^ (string_of_int !lv)) (bt) (watch_regs pipe.ramp_up);
- if debug then display_st ("ep"^ (string_of_int !fv) ^ (string_of_int !lv)) (e @ repeat b (pipe.unrolling - (pipe.min + 1)) @ p) (watch_regs pipe.ramp_up);
-
- substitute_pipeline graph loop
- (delete_indexes pipe.steady_state) (delete_indexes pipe.prolog)
- (delete_indexes pipe.epilog) (pipe.min + pipe.unrolling)
- pipe.unrolling pipe.ramp_up
- pipe.ramp_down
- (to_caml_list f.fn_params)
- | None -> Printf.printf "Damn It ! \n"; graph
- ) ddgs cfg.graph in
+ Printf.fprintf SPDebug.dc "__________________ NEW LOOP ____________________\n";
+ Printf.printf "Pipelinable loop: ";
+ incr lv;
+ fresh := (BinPos.Pos.succ
+ (BinPos.Pos.succ
+ (BinPos.Pos.succ
+ (BinPos.Pos.succ
+ (BinPos.Pos.succ
+ (max_reg_of_graph graph (to_caml_list f.fn_params)
+ ))))));
+ Printf.fprintf SPDebug.dc "FRESH = %i \n"
+ (P.to_int !fresh);
+ match p ddg with
+ | Some pipe ->
+ Printf.printf "Rock On ! Min = %i - Unroll = %i\n" pipe.min pipe.unrolling;
+ let p = (make_moves pipe.ramp_up) @ (delete_indexes pipe.prolog) in
+ let e = (delete_indexes pipe.epilog) @ (make_moves pipe.ramp_down) in
+ let b = delete_indexes (List.tl (List.rev loop)) in
+ let bt = (List.tl (delete_indexes pipe.steady_state)) in
+ let cond1 = fst (G.V.label (List.hd (List.rev loop))) in
+ let cond2 = (List.hd (delete_indexes pipe.steady_state)) in
+
+ let bu = symbolic_evaluation (repeat b (pipe.min + 1)) in
+ let pe = symbolic_evaluation (p @ e) in
+ let bte = symbolic_evaluation (bt @ e) in
+ let ebu = symbolic_evaluation (e @ repeat b pipe.unrolling) in
+ let regs = watch_regs pipe.ramp_down in
+ let c1 = symbolic_condition cond1 (repeat b pipe.unrolling) in
+ let d1 = symbolic_condition cond1 (repeat b (pipe.min + 1)) in
+ (*let c2 = symbolic_condition cond2 p in
+ let d2 = symbolic_condition cond2 ((make_moves pipe.ramp_up) @ bt) in*)
+
+
+
+ let sbt = symbolic_evaluation (bt) in
+ let sep = symbolic_evaluation (e @ repeat b (pipe.unrolling - (pipe.min + 1)) @ p) in (* er @ pr *)
+
+ Printf.printf "Initialisation : %s \n"
+ (if symbolic_equivalence bu pe regs then "OK" else "FAIL");
+ Printf.printf "Etat stable : %s \n"
+ (if symbolic_equivalence bte ebu regs then "OK" else "FAIL");
+ Printf.printf "Egalite fondamentale : %s \n"
+ (if symbolic_equivalence sbt sep (watch_regs pipe.ramp_up) then "OK" else "FAIL");
+ (* Printf.printf "Condition initiale : %s \n"
+ (if c1 = c2 then "OK" else "FAIL");
+ Printf.printf "Condition stable : %s \n"
+ (if d1 = d2 then "OK" else "FAIL");
+
+
+ Printf.fprintf SPDebug.dc "pbte\n";*)
+ List.iter (fun e ->
+ Printf.fprintf SPDebug.dc "%s\n"
+ (string_of_node (G.V.create (e,0)))
+ ) (p @ bt @ e);
+ Printf.fprintf SPDebug.dc "bu\n";
+ List.iter (fun e -> Printf.fprintf SPDebug.dc "%s\n"
+ (string_of_node (G.V.create (e,0)))
+ ) (repeat b (pipe.unrolling + pipe.min));
+
+
+
+ if debug then
+ display_st ("pbte"^ (string_of_int !fv) ^ (string_of_int !lv)) (p @ bt @ e) (watch_regs pipe.ramp_down);
+ if debug then
+ display_st ("bu"^ (string_of_int !fv) ^ (string_of_int !lv)) (repeat b (pipe.min + pipe.unrolling)) (watch_regs pipe.ramp_down);
+
+ if debug then display_st ("bt"^ (string_of_int !fv) ^ (string_of_int !lv)) (bt) (watch_regs pipe.ramp_up);
+ if debug then display_st ("ep"^ (string_of_int !fv) ^ (string_of_int !lv)) (e @ repeat b (pipe.unrolling - (pipe.min + 1)) @ p) (watch_regs pipe.ramp_up);
+
+ substitute_pipeline graph loop
+ (delete_indexes pipe.steady_state) (delete_indexes pipe.prolog)
+ (delete_indexes pipe.epilog) (pipe.min + pipe.unrolling)
+ pipe.unrolling pipe.ramp_up
+ pipe.ramp_down
+ (to_caml_list f.fn_params)
+ | None -> Printf.printf "Damn It ! \n"; graph
+ ) ddgs cfg.graph in
if debug then display graph ("output"^ (string_of_int !fv));
let tg = convert_back graph in
let tg_to_type = {fn_sig = f.fn_sig;
- fn_params = f.fn_params;
- fn_stacksize = f.fn_stacksize;
- fn_code = tg;
- fn_entrypoint = f.fn_entrypoint;
- (*fn_nextpc = P.of_int ((get_nextpc (graph)))*)
- } in
+ fn_params = f.fn_params;
+ fn_stacksize = f.fn_stacksize;
+ fn_code = tg;
+ fn_entrypoint = f.fn_entrypoint;
+ (*fn_nextpc = P.of_int ((get_nextpc (graph)))*)
+ } in
(*SPTyping.type_function tg_to_type;*)
tg_to_type