diff options
-rw-r--r-- | docs/basic-block-generation.org (renamed from lit/basic-block-generation.org) | 119 | ||||
-rw-r--r-- | docs/scheduler-languages.org (renamed from lit/scheduler-languages.org) | 0 | ||||
-rw-r--r-- | docs/scheduler.org (renamed from lit/scheduler.org) | 0 | ||||
-rw-r--r-- | src/hls/Partition.ml | 6 | ||||
-rw-r--r-- | src/hls/RTLBlock.v | 2 | ||||
-rw-r--r-- | src/hls/RTLBlockInstr.v | 14 | ||||
-rw-r--r-- | src/hls/RTLBlockgen.v | 4 | ||||
-rw-r--r-- | src/hls/RTLBlockgenproof.v | 6 | ||||
-rw-r--r-- | src/hls/RTLPar.v | 2 |
9 files changed, 137 insertions, 16 deletions
diff --git a/lit/basic-block-generation.org b/docs/basic-block-generation.org index b835e61..1d78dad 100644 --- a/lit/basic-block-generation.org +++ b/docs/basic-block-generation.org @@ -354,6 +354,125 @@ Section CORRECTNESS. End CORRECTNESS. #+end_src +* Partition +:PROPERTIES: +:header-args:ocaml: :comments noweb :noweb no-export :padline yes :tangle ../src/hls/Partition.ml +:END: + +#+begin_src ocaml :comments no :padline no :exports none +<<license>> +#+end_src + +#+name: partition-main +#+begin_src ocaml +open Printf +open Clflags +open Camlcoq +open Datatypes +open Coqlib +open Maps +open AST +open Kildall +open Op +open RTLBlockInstr +open RTLBlock + +(** Assuming that the nodes of the CFG [code] are numbered in reverse postorder (cf. pass + [Renumber]), an edge from [n] to [s] is a normal edge if [s < n] and a back-edge otherwise. *) +let find_edge i n = + let succ = RTL.successors_instr i in + let filt = List.filter (fun s -> P.lt n s || P.lt s (P.pred n)) succ in + ((match filt with [] -> [] | _ -> [n]), filt) + +let find_edges c = + PTree.fold (fun l n i -> + let f = find_edge i n in + (List.append (fst f) (fst l), List.append (snd f) (snd l))) c ([], []) + +let prepend_instr i = function + | {bb_body = bb; bb_exit = e} -> {bb_body = (i :: bb); bb_exit = e} + +let translate_inst = function + | RTL.Inop _ -> Some RBnop + | RTL.Iop (op, ls, dst, _) -> Some (RBop (None, op, ls, dst)) + | RTL.Iload (m, addr, ls, dst, _) -> Some (RBload (None, m, addr, ls, dst)) + | RTL.Istore (m, addr, ls, src, _) -> Some (RBstore (None, m, addr, ls, src)) + | _ -> None + +let translate_cfi = function + | RTL.Icall (s, r, ls, dst, n) -> Some (RBcall (s, r, ls, dst, n)) + | RTL.Itailcall (s, r, ls) -> Some (RBtailcall (s, r, ls)) + | RTL.Ibuiltin (e, ls, r, n) -> Some (RBbuiltin (e, ls, r, n)) + | RTL.Icond (c, ls, dst1, dst2) -> Some (RBcond (c, ls, dst1, dst2)) + | RTL.Ijumptable (r, ls) -> Some (RBjumptable (r, ls)) + | RTL.Ireturn r -> Some (RBreturn r) + | _ -> None + +let rec next_bblock_from_RTL is_start e (c : RTL.code) s i = + let succ = List.map (fun i -> (i, PTree.get i c)) (RTL.successors_instr i) in + let trans_inst = (translate_inst i, translate_cfi i) in + match trans_inst, succ with + | (None, Some i'), _ -> + if List.exists (fun x -> x = s) (snd e) && not is_start then + Errors.OK { bb_body = [RBnop]; bb_exit = RBgoto s } + else + Errors.OK { bb_body = [RBnop]; bb_exit = i' } + | (Some i', None), (s', Some i_n)::[] -> + if List.exists (fun x -> x = s) (fst e) then + Errors.OK { bb_body = [i']; bb_exit = RBgoto s' } + else if List.exists (fun x -> x = s) (snd e) && not is_start then + Errors.OK { bb_body = [RBnop]; bb_exit = RBgoto s } + else begin + match next_bblock_from_RTL false e c s' i_n with + | Errors.OK bb -> + Errors.OK (prepend_instr i' bb) + | Errors.Error msg -> Errors.Error msg + end + | _, _ -> + Errors.Error (Errors.msg (coqstring_of_camlstring "next_bblock_from_RTL went wrong.")) + +let rec traverseacc f l c = + match l with + | [] -> Errors.OK c + | x::xs -> + match f x c with + | Errors.Error msg -> Errors.Error msg + | Errors.OK x' -> + match traverseacc f xs x' with + | Errors.Error msg -> Errors.Error msg + | Errors.OK xs' -> Errors.OK xs' + +let rec translate_all edge c s res = + let c_bb, translated = res in + if List.exists (fun x -> P.eq x s) translated then Errors.OK (c_bb, translated) else + (match PTree.get s c with + | None -> Errors.Error (Errors.msg (coqstring_of_camlstring "Could not translate all.")) + | Some i -> + match next_bblock_from_RTL true edge c s i with + | Errors.Error msg -> Errors.Error msg + | Errors.OK {bb_body = bb; bb_exit = e} -> + let succ = List.filter (fun x -> P.lt x s) (successors_instr e) in + (match traverseacc (translate_all edge c) succ (c_bb, s :: translated) with + | Errors.Error msg -> Errors.Error msg + | Errors.OK (c', t') -> + Errors.OK (PTree.set s {bb_body = bb; bb_exit = e} c', t'))) + +(* Partition a function and transform it into RTLBlock. *) +let function_from_RTL f = + let e = find_edges f.RTL.fn_code in + match translate_all e f.RTL.fn_code f.RTL.fn_entrypoint (PTree.empty, []) with + | Errors.Error msg -> Errors.Error msg + | Errors.OK (c, _) -> + Errors.OK { fn_sig = f.RTL.fn_sig; + fn_stacksize = f.RTL.fn_stacksize; + fn_params = f.RTL.fn_params; + fn_entrypoint = f.RTL.fn_entrypoint; + fn_code = c + } + +let partition = function_from_RTL +#+end_src + * License #+name: license diff --git a/lit/scheduler-languages.org b/docs/scheduler-languages.org index cf03b3a..cf03b3a 100644 --- a/lit/scheduler-languages.org +++ b/docs/scheduler-languages.org diff --git a/lit/scheduler.org b/docs/scheduler.org index 018633c..018633c 100644 --- a/lit/scheduler.org +++ b/docs/scheduler.org diff --git a/src/hls/Partition.ml b/src/hls/Partition.ml index d7972e5..545277b 100644 --- a/src/hls/Partition.ml +++ b/src/hls/Partition.ml @@ -1,6 +1,6 @@ - (* +(* * Vericert: Verified high-level synthesis. - * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> + * Copyright (C) 2020-2022 Yann Herklotz <yann@yannherklotz.com> * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -16,6 +16,7 @@ * along with this program. If not, see <https://www.gnu.org/licenses/>. *) +(* [[file:../../docs/basic-block-generation.org::partition-main][partition-main]] *) open Printf open Clflags open Camlcoq @@ -122,3 +123,4 @@ let function_from_RTL f = } let partition = function_from_RTL +(* partition-main ends here *) diff --git a/src/hls/RTLBlock.v b/src/hls/RTLBlock.v index 539d5bc..50bff90 100644 --- a/src/hls/RTLBlock.v +++ b/src/hls/RTLBlock.v @@ -16,7 +16,7 @@ * along with this program. If not, see <https://www.gnu.org/licenses/>. *) -(* [[file:../../lit/scheduler-languages.org::rtlblock-main][rtlblock-main]] *) +(* [[file:../../docs/scheduler-languages.org::rtlblock-main][rtlblock-main]] *) Require Import compcert.backend.Registers. Require Import compcert.common.AST. Require Import compcert.common.Events. diff --git a/src/hls/RTLBlockInstr.v b/src/hls/RTLBlockInstr.v index 19b3928..801a5ea 100644 --- a/src/hls/RTLBlockInstr.v +++ b/src/hls/RTLBlockInstr.v @@ -16,7 +16,7 @@ * along with this program. If not, see <https://www.gnu.org/licenses/>. *) -(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-imports][rtlblockinstr-imports]] *) +(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-imports][rtlblockinstr-imports]] *) Require Import Coq.micromega.Lia. Require Import compcert.backend.Registers. @@ -33,7 +33,7 @@ Require Import Predicate. Require Import Vericertlib. (* rtlblockinstr-imports ends here *) -(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-instr-def][rtlblockinstr-instr-def]] *) +(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-instr-def][rtlblockinstr-instr-def]] *) Definition node := positive. Inductive instr : Type := @@ -44,7 +44,7 @@ Inductive instr : Type := | RBsetpred : option pred_op -> condition -> list reg -> predicate -> instr. (* rtlblockinstr-instr-def ends here *) -(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-cf-instr-def][rtlblockinstr-cf-instr-def]] *) +(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-cf-instr-def][rtlblockinstr-cf-instr-def]] *) Inductive cf_instr : Type := | RBcall : signature -> reg + ident -> list reg -> reg -> node -> cf_instr | RBtailcall : signature -> reg + ident -> list reg -> cf_instr @@ -57,7 +57,7 @@ Inductive cf_instr : Type := | RBpred_cf : pred_op -> cf_instr -> cf_instr -> cf_instr. (* rtlblockinstr-cf-instr-def ends here *) -(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-helpers][rtlblockinstr-helpers]] *) +(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-helpers][rtlblockinstr-helpers]] *) Fixpoint successors_instr (i : cf_instr) : list node := match i with | RBcall sig ros args res s => s :: nil @@ -148,7 +148,7 @@ Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := end. (* rtlblockinstr-helpers ends here *) -(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-instr-state][rtlblockinstr-instr-state]] *) +(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-instr-state][rtlblockinstr-instr-state]] *) Record instr_state := mk_instr_state { is_rs: regset; is_ps: predset; @@ -156,7 +156,7 @@ Record instr_state := mk_instr_state { }. (* rtlblockinstr-instr-state ends here *) -(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-type-def][rtlblockinstr-type-def]] *) +(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-type-def][rtlblockinstr-type-def]] *) Section DEFINITION. Context {bblock_body: Type}. @@ -221,7 +221,7 @@ Section DEFINITION. End DEFINITION. (* rtlblockinstr-type-def ends here *) -(* [[file:../../lit/scheduler-languages.org::rtlblockinstr-semantics][rtlblockinstr-semantics]] *) +(* [[file:../../docs/scheduler-languages.org::rtlblockinstr-semantics][rtlblockinstr-semantics]] *) Section RELSEM. Context {bblock_body : Type}. diff --git a/src/hls/RTLBlockgen.v b/src/hls/RTLBlockgen.v index 6d38e4f..beca0ea 100644 --- a/src/hls/RTLBlockgen.v +++ b/src/hls/RTLBlockgen.v @@ -16,7 +16,7 @@ * along with this program. If not, see <https://www.gnu.org/licenses/>. *) -(* [[file:../../lit/basic-block-generation.org::rtlblockgen-imports][rtlblockgen-imports]] *) +(* [[file:../../docs/basic-block-generation.org::rtlblockgen-imports][rtlblockgen-imports]] *) Require compcert.backend.RTL. Require Import compcert.common.AST. Require Import compcert.lib.Maps. @@ -148,7 +148,7 @@ Defined. Definition ceq {A: Type} (eqd: forall a b: A, {a = b} + {a <> b}) (a b: A): bool := if eqd a b then true else false. -(* [[file:../../lit/basic-block-generation.org::rtlblockgen-main][rtlblockgen-main]] *) +(* [[file:../../docs/basic-block-generation.org::rtlblockgen-main][rtlblockgen-main]] *) Parameter partition : RTL.function -> Errors.res function. (** [find_block max nodes index]: Does not need to be sorted, because we use filter and the max fold diff --git a/src/hls/RTLBlockgenproof.v b/src/hls/RTLBlockgenproof.v index 4433d52..d51e5d4 100644 --- a/src/hls/RTLBlockgenproof.v +++ b/src/hls/RTLBlockgenproof.v @@ -16,7 +16,7 @@ * along with this program. If not, see <https://www.gnu.org/licenses/>. *) -(* [[file:../../lit/basic-block-generation.org::rtlblockgenproof-imports][rtlblockgenproof-imports]] *) +(* [[file:../../docs/basic-block-generation.org::rtlblockgenproof-imports][rtlblockgenproof-imports]] *) Require compcert.backend.RTL. Require Import compcert.common.AST. Require Import compcert.lib.Maps. @@ -25,7 +25,7 @@ Require Import vericert.hls.RTLBlock. Require Import vericert.hls.RTLBlockgen. (* rtlblockgenproof-imports ends here *) -(* [[file:../../lit/basic-block-generation.org::rtlblockgenproof-match-states][rtlblockgenproof-match-states]] *) +(* [[file:../../docs/basic-block-generation.org::rtlblockgenproof-match-states][rtlblockgenproof-match-states]] *) Inductive match_states : RTL.state -> RTLBlock.state -> Prop := | match_state : forall stk f tf sp pc rs m @@ -34,7 +34,7 @@ Inductive match_states : RTL.state -> RTLBlock.state -> Prop := (RTLBlock.State stk tf sp (find_block max n i) rs m). (* rtlblockgenproof-match-states ends here *) -(* [[file:../../lit/basic-block-generation.org::rtlblockgenproof-correctness][rtlblockgenproof-correctness]] *) +(* [[file:../../docs/basic-block-generation.org::rtlblockgenproof-correctness][rtlblockgenproof-correctness]] *) Section CORRECTNESS. Context (prog : RTL.program). diff --git a/src/hls/RTLPar.v b/src/hls/RTLPar.v index 160f71c..f380d19 100644 --- a/src/hls/RTLPar.v +++ b/src/hls/RTLPar.v @@ -16,7 +16,7 @@ * along with this program. If not, see <https://www.gnu.org/licenses/>. *) -(* [[file:../../lit/scheduler-languages.org::rtlpar-main][rtlpar-main]] *) +(* [[file:../../docs/scheduler-languages.org::rtlpar-main][rtlpar-main]] *) Require Import compcert.backend.Registers. Require Import compcert.common.AST. Require Import compcert.common.Events. |