aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Compiler.v316
-rw-r--r--src/SoftwarePipelining/SPBase_types.ml128
-rw-r--r--src/SoftwarePipelining/SPBasic.ml819
-rw-r--r--src/SoftwarePipelining/SPBasic.mli57
-rw-r--r--src/SoftwarePipelining/SPDebug.ml21
-rw-r--r--src/SoftwarePipelining/SPIMS.ml189
-rw-r--r--src/SoftwarePipelining/SPIMS.mli22
-rw-r--r--src/SoftwarePipelining/SPMVE.ml299
-rw-r--r--src/SoftwarePipelining/SPMVE.mli17
-rw-r--r--src/SoftwarePipelining/SPSymbolic_evaluation.ml226
-rw-r--r--src/SoftwarePipelining/SPTyping.ml526
-rw-r--r--src/SoftwarePipelining/SPTyping.mli14
-rw-r--r--src/SoftwarePipelining/SoftwarePipelining.ml74
-rw-r--r--src/VericertClflags.ml2
-rw-r--r--src/common/IntegerExtra.v328
-rw-r--r--src/common/Maps.v31
-rw-r--r--src/common/Monad.v19
-rw-r--r--src/common/Statemonad.v18
-rw-r--r--src/common/Vericertlib.v35
-rw-r--r--src/common/ZExtra.v266
-rw-r--r--src/extraction/Extraction.v22
-rw-r--r--src/hls/Array.v (renamed from src/verilog/Array.v)34
-rw-r--r--src/hls/AssocMap.v (renamed from src/verilog/AssocMap.v)7
-rw-r--r--src/hls/HTL.v (renamed from src/verilog/HTL.v)20
-rw-r--r--src/hls/HTLBlockgen.v724
-rw-r--r--src/hls/HTLPargen.v855
-rw-r--r--src/hls/HTLgen.v (renamed from src/translation/HTLgen.v)201
-rw-r--r--src/hls/HTLgenproof.v (renamed from src/translation/HTLgenproof.v)137
-rw-r--r--src/hls/HTLgenspec.v (renamed from src/translation/HTLgenspec.v)19
-rw-r--r--src/hls/IfConversion.v122
-rw-r--r--src/hls/Partition.ml124
-rw-r--r--src/hls/Pipeline.v28
-rw-r--r--src/hls/PrintHTL.ml (renamed from src/verilog/PrintHTL.ml)1
-rw-r--r--src/hls/PrintRTLBlock.ml72
-rw-r--r--src/hls/PrintRTLBlockInstr.ml87
-rw-r--r--src/hls/PrintVerilog.ml (renamed from src/verilog/PrintVerilog.ml)62
-rw-r--r--src/hls/PrintVerilog.mli (renamed from src/verilog/PrintVerilog.mli)0
-rw-r--r--src/hls/RTLBlock.v102
-rw-r--r--src/hls/RTLBlockInstr.v469
-rw-r--r--src/hls/RTLBlockgen.v30
-rw-r--r--src/hls/RTLPar.v128
-rw-r--r--src/hls/RTLPargen.v697
-rw-r--r--src/hls/RTLPargenproof.v288
-rw-r--r--src/hls/Schedule.ml549
-rw-r--r--src/hls/Value.v (renamed from src/verilog/Value.v)3
-rw-r--r--src/hls/ValueInt.v (renamed from src/verilog/ValueInt.v)10
-rw-r--r--src/hls/ValueVal.v207
-rw-r--r--src/hls/Verilog.v (renamed from src/verilog/Verilog.v)7
-rw-r--r--src/hls/Veriloggen.v (renamed from src/translation/Veriloggen.v)21
-rw-r--r--src/hls/Veriloggenproof.v (renamed from src/translation/Veriloggenproof.v)0
50 files changed, 8150 insertions, 283 deletions
diff --git a/src/Compiler.v b/src/Compiler.v
index a643074..1f71b1e 100644
--- a/src/Compiler.v
+++ b/src/Compiler.v
@@ -1,3 +1,7 @@
+(*|
+.. coq:: none
+|*)
+
(*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2019-2020 Yann Herklotz <yann@yannherklotz.com>
@@ -16,47 +20,67 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From vericert Require Import HTLgenproof.
-
-From compcert.common Require Import
- Errors
- Linking.
-
-From compcert.lib Require Import
- Coqlib.
-
-From compcert.backend Require
- Selection
- RTL
- RTLgen
- Tailcall
- Inlining
- Renumber
- Constprop
- CSE
- Deadcode
- Unusedglob.
-
-From compcert.cfrontend Require
- Csyntax
- SimplExpr
- SimplLocals
- Cshmgen
- Cminorgen.
-
-From compcert.driver Require
- Compiler.
-
-From vericert Require
- Verilog
- Veriloggen
- Veriloggenproof
- HTLgen.
-
-From compcert Require Import Smallstep.
+(*|
+==============
+Compiler Proof
+==============
+
+.. contents:: Table of Contents
+ :depth: 2
+
+This is the top-level module of the correctness proof and proves the final backwards simulation correct.
+
+Imports
+=======
+
+We first need to import all of the modules that are used in the correctness proof, which includes all of the passes that are performed in Vericert and the CompCert front end.
+|*)
+
+Require compcert.backend.Selection.
+Require compcert.backend.RTL.
+Require compcert.backend.RTLgen.
+Require compcert.backend.Tailcall.
+Require compcert.backend.Inlining.
+Require compcert.backend.Renumber.
+Require compcert.backend.Constprop.
+Require compcert.backend.CSE.
+Require compcert.backend.Deadcode.
+Require compcert.backend.Unusedglob.
+Require compcert.cfrontend.Csyntax.
+Require compcert.cfrontend.SimplExpr.
+Require compcert.cfrontend.SimplLocals.
+Require compcert.cfrontend.Cshmgen.
+Require compcert.cfrontend.Cminorgen.
+Require compcert.driver.Compiler.
+
+Require Import compcert.common.Errors.
+Require Import compcert.common.Linking.
+Require Import compcert.common.Smallstep.
+Require Import compcert.lib.Coqlib.
+
+Require vericert.hls.Verilog.
+Require vericert.hls.Veriloggen.
+Require vericert.hls.Veriloggenproof.
+Require vericert.hls.HTLgen.
+Require vericert.hls.RTLBlock.
+Require vericert.hls.RTLBlockgen.
+Require vericert.hls.RTLPargen.
+Require vericert.hls.HTLPargen.
+Require vericert.hls.Pipeline.
+Require vericert.hls.IfConversion.
+
+Require Import vericert.hls.HTLgenproof.
+
+(*|
+Declarations
+============
+
+We then need to declare the external OCaml functions used to print out intermediate steps in the compilation, such as ``print_RTL``, ``print_HTL`` and ``print_RTLBlock``.
+|*)
Parameter print_RTL: Z -> RTL.program -> unit.
Parameter print_HTL: HTL.program -> unit.
+Parameter print_RTLBlock: Z -> RTLBlock.program -> unit.
Definition print {A: Type} (printer: A -> unit) (prog: A) : A :=
let unused := printer prog in prog.
@@ -68,11 +92,19 @@ Proof.
intros; unfold print. destruct (printer prog); auto.
Qed.
+(*|
+We also declare some new notation, which is also used in CompCert to combine the monadic results of each pass.
+|*)
+
Notation "a @@@ b" :=
(Compiler.apply_partial _ _ a b) (at level 50, left associativity).
Notation "a @@ b" :=
(Compiler.apply_total _ _ a b) (at level 50, left associativity).
+(*|
+As printing is used in the translation but does not change the output, we need to prove that it has no effect so that it can be removed during the proof.
+|*)
+
Lemma compose_print_identity:
forall (A: Type) (x: res A) (f: A -> unit),
x @@ print f = x.
@@ -80,12 +112,84 @@ Proof.
intros. destruct x; simpl. rewrite print_identity. auto. auto.
Qed.
+(*|
+Finally, some optimisation passes are only activated by a flag, which is handled by the following functions for partial and total passes.
+|*)
+
+Definition total_if {A: Type}
+ (flag: unit -> bool) (f: A -> A) (prog: A) : A :=
+ if flag tt then f prog else prog.
+
+Definition partial_if {A: Type}
+ (flag: unit -> bool) (f: A -> res A) (prog: A) : res A :=
+ if flag tt then f prog else OK prog.
+
+Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f.
+
+Definition match_if {A: Type} (flag: unit -> bool) (R: A -> A -> Prop): A -> A -> Prop :=
+ if flag tt then R else eq.
+
+Lemma total_if_match:
+ forall (A: Type) (flag: unit -> bool) (f: A -> A) (rel: A -> A -> Prop) (prog: A),
+ (forall p, rel p (f p)) ->
+ match_if flag rel prog (total_if flag f prog).
+Proof.
+ intros. unfold match_if, total_if. destruct (flag tt); auto.
+Qed.
+
+Lemma partial_if_match:
+ forall (A: Type) (flag: unit -> bool) (f: A -> res A) (rel: A -> A -> Prop) (prog tprog: A),
+ (forall p tp, f p = OK tp -> rel p tp) ->
+ partial_if flag f prog = OK tprog ->
+ match_if flag rel prog tprog.
+Proof.
+ intros. unfold match_if, partial_if in *. destruct (flag tt). auto. congruence.
+Qed.
+
+Remark forward_simulation_identity:
+ forall sem, forward_simulation sem sem.
+Proof.
+ intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros.
+- auto.
+- exists s1; auto.
+- subst s2; auto.
+- subst s2. exists s1'; auto.
+Qed.
+
+Lemma match_if_simulation:
+ forall (A: Type) (sem: A -> semantics) (flag: unit -> bool) (transf: A -> A -> Prop) (prog tprog: A),
+ match_if flag transf prog tprog ->
+ (forall p tp, transf p tp -> forward_simulation (sem p) (sem tp)) ->
+ forward_simulation (sem prog) (sem tprog).
+Proof.
+ intros. unfold match_if in *. destruct (flag tt). eauto. subst. apply forward_simulation_identity.
+Qed.
+
+(*|
+Top-level Translation
+---------------------
+
+An optimised transformation function from ``RTL`` to ``Verilog`` can then be defined, which applies the front end compiler optimisations of CompCert to the RTL that is generated and then performs the two Vericert passes from RTL to HTL and then from HTL to Verilog.
+|*)
+
Definition transf_backend (r : RTL.program) : res Verilog.program :=
OK r
- (* @@@ Inlining.transf_program *)
- (* @@ print (print_RTL 1) *)
+ @@@ Inlining.transf_program
+ @@ print (print_RTL 1)
+ @@ Renumber.transf_program
+ @@ print (print_RTL 2)
+ @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program)
+ @@ print (print_RTL 3)
+ @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program)
+ @@ print (print_RTL 4)
+ @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program)
+ @@ print (print_RTL 5)
+ @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program)
+ @@ print (print_RTL 6)
+ @@@ time "Unused globals" Unusedglob.transform_program
+ @@ print (print_RTL 7)
@@@ HTLgen.transl_program
- @@ print print_HTL
+ @@ print print_HTL
@@@ Veriloggen.transl_program.
Definition transf_hls (p : Csyntax.program) : res Verilog.program :=
@@ -96,9 +200,51 @@ Definition transf_hls (p : Csyntax.program) : res Verilog.program :=
@@@ Cminorgen.transl_program
@@@ Selection.sel_program
@@@ RTLgen.transl_program
- @@ print (print_RTL 0)
+ @@ print (print_RTL 0)
@@@ transf_backend.
+(*|
+.. coq:: none
+|*)
+
+Definition transf_hls_temp (p : Csyntax.program) : res Verilog.program :=
+ OK p
+ @@@ SimplExpr.transl_program
+ @@@ SimplLocals.transf_program
+ @@@ Cshmgen.transl_program
+ @@@ Cminorgen.transl_program
+ @@@ Selection.sel_program
+ @@@ RTLgen.transl_program
+ @@@ Inlining.transf_program
+ @@ print (print_RTL 1)
+ @@ Renumber.transf_program
+ @@ print (print_RTL 2)
+ @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program)
+ @@ print (print_RTL 3)
+ @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program)
+ @@ print (print_RTL 4)
+ @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program)
+ @@ print (print_RTL 5)
+ @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program)
+ @@ print (print_RTL 6)
+ @@@ time "Unused globals" Unusedglob.transform_program
+ @@ print (print_RTL 7)
+ @@@ RTLBlockgen.transl_program
+ @@ print (print_RTLBlock 1)
+ @@ IfConversion.transf_program
+ @@ print (print_RTLBlock 2)
+ @@@ RTLPargen.transl_program
+ @@@ HTLPargen.transl_program
+ @@ print print_HTL
+ @@ Veriloggen.transl_program.
+
+(*|
+Correctness Proof
+=================
+
+Finally, the top-level definition for all the passes is defined, which combines the ``match_prog`` predicates of each translation pass from C until Verilog.
+|*)
+
Local Open Scope linking_scope.
Definition verilog_transflink : TransfLink Veriloggenproof.match_prog.
@@ -111,20 +257,35 @@ Definition CompCert's_passes :=
::: mkpass Cminorgenproof.match_prog
::: mkpass Selectionproof.match_prog
::: mkpass RTLgenproof.match_prog
+ ::: mkpass Inliningproof.match_prog
+ ::: mkpass Renumberproof.match_prog
+ ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog)
+ ::: mkpass (match_if Compopts.optim_constprop Renumberproof.match_prog)
+ ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog)
+ ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog)
+ ::: mkpass Unusedglobproof.match_prog
::: (@mkpass _ _ HTLgenproof.match_prog (HTLgenproof.TransfHTLLink HTLgen.transl_program))
::: (@mkpass _ _ Veriloggenproof.match_prog verilog_transflink)
::: pass_nil _.
+(*|
+These passes are then composed into a larger, top-level ``match_prog`` predicate which matches a C program directly with a Verilog program.
+|*)
+
Definition match_prog: Csyntax.program -> Verilog.program -> Prop :=
pass_match (compose_passes CompCert's_passes).
+(*|
+We then need to prove that this predicate holds, assuming that the translation is performed using the ``transf_hls`` function declared above.
+|*)
+
Theorem transf_hls_match:
forall p tp,
transf_hls p = OK tp ->
match_prog p tp.
Proof.
intros p tp T.
- unfold transf_hls in T. simpl in T.
+ unfold transf_hls, time in T. simpl in T.
destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate.
destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate.
destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate.
@@ -132,10 +293,16 @@ Proof.
destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate.
rewrite ! compose_print_identity in T.
destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate.
- unfold transf_backend in T. simpl in T. rewrite ! compose_print_identity in T.
- (* destruct (Inlining.transf_program p6) as [p7|e] eqn:P7; simpl in T; try discriminate. *)
- destruct (HTLgen.transl_program p6) as [p7|e] eqn:P7; simpl in T; try discriminate.
- destruct (Veriloggen.transl_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate.
+ unfold transf_backend, time in T. simpl in T. rewrite ! compose_print_identity in T.
+ destruct (Inlining.transf_program p6) as [p7|e] eqn:P7; simpl in T; try discriminate.
+ set (p8 := Renumber.transf_program p7) in *.
+ set (p9 := total_if Compopts.optim_constprop Constprop.transf_program p8) in *.
+ set (p10 := total_if Compopts.optim_constprop Renumber.transf_program p9) in *.
+ destruct (partial_if Compopts.optim_CSE CSE.transf_program p10) as [p11|e] eqn:P11; simpl in T; try discriminate.
+ destruct (partial_if Compopts.optim_redundancy Deadcode.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate.
+ destruct (Unusedglob.transform_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate.
+ destruct (HTLgen.transl_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate.
+ destruct (Veriloggen.transl_program p14) as [p15|e] eqn:P15; simpl in T; try discriminate.
unfold match_prog; simpl.
exists p1; split. apply SimplExprproof.transf_program_match; auto.
exists p2; split. apply SimplLocalsproof.match_transf_program; auto.
@@ -143,20 +310,16 @@ Proof.
exists p4; split. apply Cminorgenproof.transf_program_match; auto.
exists p5; split. apply Selectionproof.transf_program_match; auto.
exists p6; split. apply RTLgenproof.transf_program_match; auto.
- (* exists p7; split. apply Inliningproof.transf_program_match; auto. *)
- exists p7; split. apply HTLgenproof.transf_program_match; auto.
- (* exists p8; split. apply Veriloggenproof.transf_program_match; auto. *)
- (* inv T. reflexivity. *)
-Admitted.
-
-Remark forward_simulation_identity:
- forall sem, forward_simulation sem sem.
-Proof.
- intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros.
-- auto.
-- exists s1; auto.
-- subst s2; auto.
-- subst s2. exists s1'; auto.
+ exists p7; split. apply Inliningproof.transf_program_match; auto.
+ exists p8; split. apply Renumberproof.transf_program_match; auto.
+ exists p9; split. apply total_if_match. apply Constpropproof.transf_program_match.
+ exists p10; split. apply total_if_match. apply Renumberproof.transf_program_match.
+ exists p11; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match.
+ exists p12; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match.
+ exists p13; split. apply Unusedglobproof.transf_program_match; auto.
+ exists p14; split. apply HTLgenproof.transf_program_match; auto.
+ exists p15; split. apply Veriloggenproof.transf_program_match; auto.
+ inv T. reflexivity.
Qed.
Theorem cstrategy_semantic_preservation:
@@ -174,7 +337,7 @@ Ltac DestructM :=
destruct H as (p & M & MM); clear H
end.
repeat DestructM. subst tp.
- assert (F: forward_simulation (Cstrategy.semantics p) (Verilog.semantics p8)).
+ assert (F: forward_simulation (Cstrategy.semantics p) (Verilog.semantics p15)).
{
eapply compose_forward_simulations.
eapply SimplExprproof.transl_program_correct; eassumption.
@@ -189,6 +352,20 @@ Ltac DestructM :=
eapply compose_forward_simulations.
eapply RTLgenproof.transf_program_correct; eassumption.
eapply compose_forward_simulations.
+ eapply Inliningproof.transf_program_correct; eassumption.
+ eapply compose_forward_simulations.
+ eapply Renumberproof.transf_program_correct; eassumption.
+ eapply compose_forward_simulations.
+ eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct.
+ eapply compose_forward_simulations.
+ eapply match_if_simulation. eassumption. exact Renumberproof.transf_program_correct.
+ eapply compose_forward_simulations.
+ eapply match_if_simulation. eassumption. exact CSEproof.transf_program_correct.
+ eapply compose_forward_simulations.
+ eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption.
+ eapply compose_forward_simulations.
+ eapply Unusedglobproof.transf_program_correct; eassumption.
+ eapply compose_forward_simulations.
eapply HTLgenproof.transf_program_correct. eassumption.
(* eapply Veriloggenproof.transf_program_correct; eassumption. *)
admit.
@@ -200,6 +377,13 @@ Ltac DestructM :=
apply Verilog.semantics_determinate.
Admitted.
+(*|
+Backward Simulation
+-------------------
+
+The following theorem is a *backward simulation* between the C and Verilog, which proves the semantics preservation of the translation. We can assume that the C and Verilog programs match, as we have proven previously in ``transf_hls_match`` that our translation implies that the ``match_prog`` predicate will hold.
+|*)
+
Theorem c_semantic_preservation:
forall p tp,
match_prog p tp ->
@@ -215,6 +399,10 @@ Proof.
exact (proj2 (cstrategy_semantic_preservation _ _ H)).
Qed.
+(*|
+We can then use ``transf_hls_match`` to prove the backward simulation where the assumption is that the translation is performed using the ``transf_hls`` function and that it succeeds.
+|*)
+
Theorem transf_c_program_correct:
forall p tp,
transf_hls p = OK tp ->
@@ -223,6 +411,10 @@ Proof.
intros. apply c_semantic_preservation. apply transf_hls_match; auto.
Qed.
+(*|
+The final theorem of the semantic preservation of the translation of separate translation units can also be proven correct, however, this is only because the translation fails if more than one translation unit is passed to Vericert at the moment.
+|*)
+
Theorem separate_transf_c_program_correct:
forall c_units verilog_units c_program,
nlist_forall2 (fun cu tcu => transf_hls cu = OK tcu) c_units verilog_units ->
diff --git a/src/SoftwarePipelining/SPBase_types.ml b/src/SoftwarePipelining/SPBase_types.ml
new file mode 100644
index 0000000..ba92340
--- /dev/null
+++ b/src/SoftwarePipelining/SPBase_types.ml
@@ -0,0 +1,128 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open Camlcoq
+open Op
+open Registers
+open Memory
+open Mem
+open AST
+
+type ('a,'b) sum = ('a,'b) Datatypes.sum
+
+type instruction =
+ | Inop
+ | Iop of operation * reg list * reg
+ | Iload of memory_chunk * addressing * reg list * reg
+ | Istore of memory_chunk * addressing * reg list * reg
+ | Icall of signature * (reg, ident) sum * reg list * reg
+ | Itailcall of signature * (reg, ident) sum * reg list
+ | Icond of condition * reg list
+ | Ireturn of reg option
+
+type resource = Reg of reg | Mem
+
+let inst_coq_to_caml = function
+ | RTL.Inop succ -> Inop
+ | RTL.Iop (op, args, dst, succ) -> Iop (op, args, dst)
+ | RTL.Iload (chunk, mode, args, dst, succ) -> Iload (chunk, mode, args, dst)
+ | RTL.Istore (chunk, mode, args, src, succ) -> Istore (chunk, mode, args, src)
+ | RTL.Icall (sign, id, args, dst, succ) -> Icall (sign, id, args, dst)
+ | RTL.Itailcall (sign, id, args) -> Itailcall (sign, id, args)
+ | RTL.Icond (cond, args, succ1, succ2) -> Icond (cond, args)
+ | RTL.Ireturn (res) -> Ireturn (res)
+
+let inst_caml_to_coq i (links : RTL.node list) =
+ match i,links with
+ | Inop,[p] -> RTL.Inop p
+ | Iop (op, args, dst),[p] -> RTL.Iop (op, args, dst,p)
+ | Iload (chunk, mode, args, dst),[p] -> RTL.Iload (chunk, mode, args,dst,p)
+ | Istore (chunk, mode, args, src),[p] -> RTL.Istore (chunk, mode, args, src,p)
+ | Icall (sign, id, args, dst),[p] -> RTL.Icall (sign, id, args, dst,p)
+ | Itailcall (sign, id, args),[] -> RTL.Itailcall (sign, id, args)
+ | Icond (cond, args),[p1;p2] -> RTL.Icond (cond,args,p1,p2)
+ | Ireturn (res),[] -> RTL.Ireturn res
+ | _,_ -> failwith "Echec lors de la conversion des instrucitons internes vers compcert"
+
+
+let print_inst node = string_of_int (snd node)
+
+let to_int = fun n -> P.to_int n
+let to_binpos = fun n -> P.of_int n
+
+let rec string_of_args args =
+ match args with
+ | [] -> ""
+ | arg :: args -> "r" ^ (string_of_int (to_int arg)) ^ " " ^ string_of_args args
+
+let string_of_z z = string_of_int (Z.to_int z)
+
+let string_of_comparison = function
+ | Integers.Ceq -> "eq"
+ | Integers.Cne -> "ne"
+ | Integers.Clt -> "lt"
+ | Integers.Cle -> "le"
+ | Integers.Cgt -> "gt"
+ | Integers.Cge -> "ge"
+
+let string_of_cond = function
+ | Ccomp c -> Printf.sprintf "comp %s" (string_of_comparison c)
+ | Ccompu c -> Printf.sprintf "compu %s" (string_of_comparison c)
+ | Ccompimm (c,i) -> Printf.sprintf "compimm %s %s" (string_of_comparison c) (string_of_z i)
+ | Ccompuimm (c,i) -> Printf.sprintf "compuimm %s %s" (string_of_comparison c) (string_of_z i)
+ | Ccompf c -> Printf.sprintf "compf %s" (string_of_comparison c)
+ | Cnotcompf c -> Printf.sprintf "notcompf %s" (string_of_comparison c)
+ | Cmaskzero i -> Printf.sprintf "maskzero %s" (string_of_z i)
+ | Cmasknotzero i -> Printf.sprintf "masknotzero %s" (string_of_z i)
+
+let string_of_op = function
+ | Omove -> "move"
+ | Ointconst i -> Printf.sprintf "intconst %s" (string_of_z i)
+ | Ofloatconst f -> Printf.sprintf "floatconst %s" (string_of_float (camlfloat_of_coqfloat32 f))
+ | Ocast8signed -> "cast8signed"
+ | Ocast8unsigned -> "cast8unsigned"
+ | Ocast16signed -> "cast16signed"
+ | Ocast16unsigned -> "cast16unsigned"
+ | Osub -> "sub"
+ | Omul -> "mul"
+ | Omulimm i -> Printf.sprintf "mulimm %s" (string_of_z i)
+ | Odiv -> "div"
+ | Odivu -> "divu"
+ | Oand -> "and"
+ | Oandimm i -> Printf.sprintf "andimm %s" (string_of_z i)
+ | Oor -> "or"
+ | Oorimm i -> Printf.sprintf "orimm %s" (string_of_z i)
+ | Oxor -> "xor"
+ | Oxorimm i -> Printf.sprintf "xorimm %s" (string_of_z i)
+ | Oshl -> "shl"
+ | Oshr -> "shr"
+ | Oshrimm i -> Printf.sprintf "shrimm %s" (string_of_z i)
+ | Oshrximm i -> Printf.sprintf "shrximm %s" (string_of_z i)
+ | Oshru -> "shru"
+ | Onegf -> "negf"
+ | Oabsf -> "absf"
+ | Oaddf -> "addf"
+ | Osubf -> "subf"
+ | Omulf -> "mulf"
+ | Odivf -> "divf"
+ | Osingleoffloat -> "singleoffloat"
+ | Ofloatofint -> "floatofint"
+ | Ocmp c -> Printf.sprintf "cmpcmpcmp"
+ | Olea _ -> "lea"
+
+let to_coq_list = function
+ | [] -> []
+ | e :: l -> e :: l
+
+let to_caml_list = function
+ | [] -> []
+ | e :: l -> e :: l
diff --git a/src/SoftwarePipelining/SPBasic.ml b/src/SoftwarePipelining/SPBasic.ml
new file mode 100644
index 0000000..32234b8
--- /dev/null
+++ b/src/SoftwarePipelining/SPBasic.ml
@@ -0,0 +1,819 @@
+(***********************************************************************)
+ (* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open RTL
+open Camlcoq
+open Graph.Pack.Digraph
+open Op
+open Registers
+open Memory
+open Mem
+open AST
+open SPBase_types
+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)
+module Topo = Graph.Topological.Make (G)
+module Dom = Graph.Dominator.Make (G)
+module Index = Map.Make (struct type t = int let compare = compare end)
+
+let string_of_instruction node =
+ match G.V.label node with
+ | (Inop,n) -> Printf.sprintf "%i nop" n
+ | (Iop (op, args, dst),n) -> Printf.sprintf "%i r%i := %s %s" n (to_int dst) (string_of_op op) (string_of_args args)
+ | (Iload (chunk, mode, args, dst),n) -> Printf.sprintf "%i r%i := load %s" n (to_int dst) (string_of_args args)
+ | (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) *)
+ | (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
+
+let string_of_node = string_of_instruction
+
+module Display = struct
+ include G
+ let vertex_name v = print_inst (V.label v)
+ let graph_attributes _ = []
+ let default_vertex_attributes _ = []
+ let vertex_attributes v = [`Label (string_of_instruction v)]
+ let default_edge_attributes _ = []
+ let edge_attributes e = [`Label (string_of_int (G.E.label e))]
+ let get_subgraph _ = None
+end
+module Dot_ = Graph.Graphviz.Dot(Display)
+
+let dot_output g f =
+ let oc = open_out f in
+ Dot_.output_graph oc g;
+ close_out oc
+
+let display g name =
+ let addr = SPDebug.name ^ name in
+ dot_output g addr ;
+ 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*)
+
+let convert f =
+
+ let make_node inst key =
+ let inst = inst_coq_to_caml inst in
+ G.V.create (inst, to_int key)
+ 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)
+ 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"
+
+ in
+
+ let graph = Maps.PTree.fold ( fun g key inst ->
+ link key (match Maps.PTree.get key succ with
+ Some x -> x | _ -> failwith "Could not index") g
+ ) 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
+
+
+
+
+(* dominator_tree calcule l'arbre de domination grace au code de FP *)
+let dominator_tree f =
+ Dom.compute_idom f.graph f.start
+
+(* detect_loops, find the loops in the graph and returns the list of nodes in it,
+ in dominating order !!! This is of great importance, we suppose that it is ordered
+ when we build the dependency graph *)
+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
+ in
+
+ G.fold_edges (fun v1 v2 loops ->
+ 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))
+
+let print_instruction node =
+ match G.V.label node with
+ | (Inop,n) -> Printf.printf "%i : Inop \n" n
+ | (Iop (op, args, dst),n) -> Printf.printf "%i : Iop \n" n
+ | (Iload (chunk, mode, args, dst),n) -> Printf.printf "%i : Iload \n" n
+ | (Istore (chunk, mode, args, src),n) -> Printf.printf "%i : Istore \n" n
+ | (Icall (sign, id, args, dst),n) -> Printf.printf "%i : Icall \n" n
+ | (Itailcall (sign, id, args),n) -> Printf.printf "%i : Itailcall \n" n
+ (*| (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"
+
+let is_variant r loop =
+ List.fold_right (fun node b ->
+ 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
+ in
+
+ let is_branching node =
+ match fst (G.V.label node) with
+ | Icond _ -> true
+ | _ -> false
+ in
+
+ let is_nop node =
+ match fst (G.V.label node) with
+ | Inop -> true
+ | _ -> false
+ in
+
+ let is_OK_aux l =
+ List.fold_right (fun n b -> is_acceptable n && b) l true
+ in
+
+ 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
+ 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
+
+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
+
+(* 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
+
+let rec to_res l =
+ match l with
+ | [] -> []
+ | 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"
+
+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"
+
+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
+ 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
+ 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 *)
+(* this is rather technical so we give many comments *)
+
+(* let n1 = G.V.create (Iop ((Ointconst ur),to_coq_list [],r1),next_pc) in *)
+(* let next_pc = next_pc + 1 in *)
+(* let n2 = G.V.create (Iop (Odiv,to_coq_list [bound;r1],r2),next_pc) in *)
+(* let next_pc = next_pc + 1 in *)
+(* let n3 = G.V.create (Iop ((Omulimm ur),to_coq_list [r2],r3),next_pc) in *)
+(* let next_pc = next_pc + 1 in *)
+(* let n4 = G.V.create (Iop (Osub,to_coq_list [bound;r3],r4),next_pc) in *)
+(* let next_pc = next_pc + 1 in *)
+(* let n5 = G.V.create (Iop (Omove,to_coq_list [r3],bound),next_pc) in (\* retouchee, [r3],bound *\) *)
+
+
+let patch_graph graph entry lastone loop bound min ur r1 r2 r3 r4 next_pc prolog epilog ramp_up ramp_down =
+
+ (* 1. Break the edge that enters the loop, except for the backedge *)
+ let preds_e = G.pred_e graph entry in
+ let wannabes = List.map G.E.src preds_e in
+ 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
+ let graph = G.add_vertex graph cond in
+ let next_pc = next_pc + 1 in
+
+ (* 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
+ let n2 = G.V.create (Iop (Odiv,to_coq_list [bound;r1],r2),next_pc) in
+ let next_pc = next_pc + 1 in
+ let n3 = G.V.create (Iop (Omove,to_coq_list [bound],r4),next_pc) in
+ let next_pc = next_pc + 1 in
+ let n4 = G.V.create (Iop ((Omulimm ur ),to_coq_list [r2],r3),next_pc) in
+ let next_pc = next_pc + 1 in
+ let n5 = G.V.create (Iop ((Olea (Aindexed (Z.of_sint (-1)))),to_coq_list [r3],bound),next_pc) in (* retouchee, [r3],bound *)
+ let next_pc = next_pc + 1 in
+ let graph = G.add_vertex graph n1 in
+ let graph = G.add_vertex graph n2 in
+ let graph = G.add_vertex graph n3 in
+ let graph = G.add_vertex graph n4 in
+ let graph = G.add_vertex graph n5 in
+ let graph = G.add_edge_e graph (G.E.create cond 2 n1) in
+ let graph = G.add_edge graph n1 n2 in
+ 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 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
+ 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 (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
+
+ (* 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 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 next_pc = next_pc + 1 in *)
+
+ (* Creation des proloque et epilogue *)
+
+ let graph = link prolog graph pipe_cond in
+ let graph = link ramp_up graph (List.hd prolog) in
+ let graph = link epilog graph (List.hd ramp_down) in
+ let graph = link ramp_down graph n6 in
+
+ let graph = G.add_edge graph n5 (List.hd ramp_up) in
+ let graph = G.add_edge_e graph (G.E.create pipe_cond 1 (List.hd epilog)) in
+ let graph = G.add_edge_e graph (G.E.create pipe_cond 2 (List.hd pipeline)) in
+
+ (* 8. Retour sur la boucle classique *)
+ let graph = G.add_edge graph n6 entry in
+
+ graph
+
+let regs_of_node node =
+ match G.V.label node with
+ | (Inop,n) -> []
+ | (Iop (op, args, dst),n) -> dst :: (to_caml_list args)
+ | (Iload (chunk, mode, args, dst),n) -> dst :: (to_caml_list args)
+ | (Istore (chunk, mode, args, src),n) -> src :: (to_caml_list args)
+ | (Icall (sign, id, args, dst),n) -> dst :: (to_caml_list args)
+ | (Itailcall (sign, id, args),n) -> (to_caml_list args)
+ (*| (Ialloc (dst, size),n) -> [dst]*)
+ | (Icond (cond, args),n) -> (to_caml_list args)
+ | (Ireturn (res),n) -> match res with Some res -> [res] | _ -> []
+
+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
+ 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 "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 (* Modified false to true condition. *)
+ | 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
+
+let substitute_pipeline graph loop steady_state prolog epilog min unrolling ru rd params =
+ let n1 = max_reg_of_graph graph params in
+ let n2 = (BinPos.Pos.succ n1) in
+ let n3 = (BinPos.Pos.succ n2) in
+ let n4 = (BinPos.Pos.succ n3) in
+ let way_in = (List.hd loop) in
+ let way_out = (List.hd (List.rev loop)) in
+ let bound = (get_bound way_out loop) in
+ let min = Z.of_sint min in
+ 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
+ print_loops loops;
+ let loops = List.filter (fun loop -> is_pipelinable (snd (loop))) loops in
+ 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}
+
+let delete_indexes l = List.map (fun e -> fst (G.V.label e) ) l
+
+type reg = Registers.reg
+
+let fresh = ref BinNums.Coq_xH
+
+let distance e =
+ match G.E.label e with
+ | 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"
+
+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 -> 4
+ | Odiv -> 30
+ | Omulimm _ -> 4
+ | _ -> 2
+ end
+ | Iload _ -> 1
+ (* | 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))
+
+let rec reforge_args args oldr newr =
+ match args with
+ | [] -> []
+ | 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
+
+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
+
+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))
+
+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
+ 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"
+
+let fresh_regs n =
+ let t = Array.make n (BinNums.Coq_xH) in
+ for i = 0 to (n - 1) do
+ Array.set t i (!fresh);
+ 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
+
+
+(*******************************************)
+
+let watch_regs l = List.fold_right (fun (a,b) 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)
+
+let fv = ref 0
+
+let apply_pipeliner f p ?(debug=false) =
+ Printf.fprintf SPDebug.dc "******************** NEW FUNCTION ***********************\n";
+ let cfg = convert f in
+ incr fv;
+ if debug then display cfg.graph ("input" ^ (string_of_int !fv));
+ 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
+
+ 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
+ (*SPTyping.type_function tg_to_type;*)
+
+ tg_to_type
diff --git a/src/SoftwarePipelining/SPBasic.mli b/src/SoftwarePipelining/SPBasic.mli
new file mode 100644
index 0000000..f16e524
--- /dev/null
+++ b/src/SoftwarePipelining/SPBasic.mli
@@ -0,0 +1,57 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open Graph.Pack.Digraph
+
+(* DATA DEPENDENCY GRAPHS *)
+module G : Graph.Sig.P
+
+(* We abstract the register type to make sure that the user won't mess up *)
+type reg
+
+(* The scheduling should return a value of type pipeline *)
+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
+}
+
+(* Operations on ddg *)
+
+val display : G.t -> string -> unit
+val apply_pipeliner : RTL.coq_function -> (G.t -> pipeline option) -> ?debug:bool -> RTL.coq_function
+val get_succs_raw : G.t -> G.V.t -> G.V.t list
+
+(* Operations on instructions, the nodes of the data dependency graph *)
+
+val string_of_node : G.V.t -> string
+val latency : G.V.t -> int
+val reforge_reads : G.V.t -> reg -> reg -> G.V.t
+val reforge_writes : G.V.t -> reg -> G.V.t
+val written : G.V.t -> reg option
+val is_cond : G.V.t -> bool
+
+(* Operations on dependencies, the edges of the data dependency graph *)
+
+type et = IntraRAW | IntraWAW | IntraWAR | InterRAW | InterWAW | InterWAR
+
+val edge_type : G.E.t -> et
+val distance : G.E.t -> int
+
+(* Getting fresh registers, int is the number of required registers *)
+
+val fresh_regs : int -> reg array
+val print_reg : reg -> unit
diff --git a/src/SoftwarePipelining/SPDebug.ml b/src/SoftwarePipelining/SPDebug.ml
new file mode 100644
index 0000000..34d1c0c
--- /dev/null
+++ b/src/SoftwarePipelining/SPDebug.ml
@@ -0,0 +1,21 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open Unix
+
+let tm = localtime (time ());;
+let name = "debug/" ^ (string_of_int tm.tm_year) ^ "-" ^(string_of_int tm.tm_mon) ^ "-" ^(string_of_int tm.tm_mday) ^
+ "-" ^(string_of_int tm.tm_hour) ^"-" ^(string_of_int tm.tm_min) ^ "-" ^(string_of_int tm.tm_sec) ^ "/";;
+mkdir name 0o777;;
+Printf.printf "Debug informations: %s \n" name ;;
+let dc = open_out (name ^ "debug.log");;
+let () = at_exit(fun () -> close_out dc);;
diff --git a/src/SoftwarePipelining/SPIMS.ml b/src/SoftwarePipelining/SPIMS.ml
new file mode 100644
index 0000000..0e19dec
--- /dev/null
+++ b/src/SoftwarePipelining/SPIMS.ml
@@ -0,0 +1,189 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open Graph.Pack.Digraph
+open SPBasic
+
+module NI = Map.Make (struct type t = G.V.t let compare = compare end)
+
+let find key map def =
+ try NI.find key map
+ with
+ | Not_found -> def
+
+let unpack v =
+ match v with
+ | Some v -> v
+ | None -> failwith "unpack abusif"
+
+let dep_latency edge =
+ match edge_type edge with
+ | IntraRAW | InterRAW -> latency (G.E.src edge)
+ | _ -> 1
+
+let estart ddg schedule node ii =
+ let preds = G.pred_e ddg node in
+ let starts = List.map (fun edge ->
+ match find (G.E.src edge) schedule None with
+ | Some t ->
+ let start = t + dep_latency edge - ii * distance edge in
+ (*Printf.printf "start : %i \n" start;*)
+ if start < 0 then 0 else start
+ | None -> 0
+ ) preds in
+ List.fold_left (fun max e -> if max > e then max else e) 0 starts
+
+let resource_conflict time mrt ii =
+ match Array.get mrt (time mod ii) with
+ | None -> false
+ | Some v -> true
+
+let rec scan_time time maxtime mrt ii =
+ if time <= maxtime
+ then
+ begin
+ if resource_conflict time mrt ii
+ then scan_time (time + 1) maxtime mrt ii
+ else Some time
+ end
+ else None
+
+let finished ddg schedule =
+ let unscheduled = G.fold_vertex (fun node l ->
+ match find node schedule None with
+ | Some v -> l
+ | None -> node :: l
+ ) ddg [] in
+ (* Printf.printf "R %i R \n" (List.length unscheduled); *)
+ if List.length unscheduled = 0 then true else false
+
+let bad_successors ddg schedule node ii =
+ let succs = G.succ_e ddg node in (* Le succs_ddg initial *)
+ (* let reftime = NI.find node schedule in *)
+ (* let succs_sched = NI.fold (fun node time succs -> *)
+ (* if time > reftime then node :: succs else succs *)
+ (* ) schedule [] in *)
+ (* let succs = List.filter (fun edge -> List.mem (G.E.dst edge) succs_sched) succs_ddg in*)
+ List.fold_right (fun edge bad ->
+ match find (G.E.dst edge) schedule None with
+ | Some t ->
+ if unpack (NI.find node schedule) + dep_latency edge - ii * distance edge > t
+ then (G.E.dst edge) :: bad
+ else bad
+ | None -> bad
+ ) succs []
+
+let get_condition ddg =
+ let cond = G.fold_vertex (fun node cond ->
+ if is_cond node then Some node else cond
+ ) ddg None in
+ match cond with
+ | Some cond -> cond
+ | None -> failwith "The loop does not contain a condition. Aborting\n"
+
+(* Perform iterative modulo scheduling, using a heuristic for the next instruction to schedule
+ * [heightr], the data dependency graph to schedule [ddg], the minimum II [min_ii] and the maximum
+ * II [max_interval].
+ *)
+let modulo_schedule heightr ddg min_ii max_interval =
+
+ let ii = ref (min_ii - 1) in
+ let notfound = ref true in
+ let sched = ref NI.empty in
+
+ let cond = get_condition ddg in
+
+ while (!ii < max_interval && !notfound) do
+ (* Printf.printf "."; flush stdout; *)
+ ii := !ii + 1;
+ (* Printf.printf "NOUVEAU II %i \n" !ii; *)
+ let budget = ref (G.nb_vertex ddg * 10) in
+ let lasttime = ref NI.empty in
+ (* Create the map with schedules, and add the schedule for the condition. This should go at the
+ * end, but in this case is set to the start. *)
+ let schedtime = ref (NI.add cond (Some 0) NI.empty) in
+ (* Create an array that is as large as the current II, which will determine where each
+ * instruction will be placed. *)
+ let mrt = Array.make !ii None in
+ (* Set the condition to be the initial instruction at time 0. *)
+ Array.set mrt 0 (Some cond);
+
+ while (!budget > 0 && not (finished ddg !schedtime)) do (* Pretty inefficient *)
+ budget := !budget - 1;
+ (* Get next instruction to schedule. *)
+ let h = heightr ddg !schedtime in
+ let mintime = estart ddg !schedtime h !ii in
+ (* Printf.printf "tmin (%s) = %i \n" (string_of_node h) mintime; *)
+ let maxtime = mintime + !ii -1 in
+ let time =
+ match scan_time mintime maxtime mrt !ii with
+ | Some t -> t
+ | None -> (*Printf.printf "backtrack" ; *)
+ if mintime = 0 then 1 + find h !lasttime 0
+ else max mintime (1 + find h !lasttime 0)
+ in
+ (* Printf.printf "Chosen time for %s : %i \n" (string_of_node h) time; *)
+ schedtime := NI.add h (Some time) !schedtime;
+ lasttime := NI.add h time !lasttime;
+
+ let killed = bad_successors ddg !schedtime h !ii in
+ List.iter (fun n -> (* Printf.printf "Killing %s" (string_of_node n) ; *)schedtime := NI.add n None !schedtime) killed;
+
+ begin
+ match Array.get mrt (time mod !ii) with
+ | None -> Array.set mrt (time mod !ii) (Some h)
+ | Some n ->
+ begin
+ (*Printf.printf "Deleting : %s \n" (string_of_node n); *)
+ (* Printf.printf "."; *)
+ schedtime := NI.add n None !schedtime;
+ Array.set mrt (time mod !ii) (Some h)
+ end
+ end;
+ (* if finished ddg !schedtime then Printf.printf "Fini ! \n" *)
+
+ done;
+
+ let success = G.fold_vertex (fun node b ->
+ b &&
+ match find node !schedtime None with
+ | Some _ -> true
+ | None -> false
+ ) ddg true in
+
+ if success then (notfound := false; sched := !schedtime);
+
+ done;
+
+ if (not !notfound)
+ then (!sched,!ii)
+ else failwith "IMS failure"
+
+(* Take the number of vertices as the minimum resource-constrained II. However, the II might
+ actually be less than that in some cases, so this should be adjusted accordingly. *)
+let res_m_ii ddg =
+ G.nb_vertex ddg
+
+let pipeliner ddg heightr =
+ let mii = res_m_ii ddg in
+ Printf.fprintf SPDebug.dc "MII: %i\n" mii;
+ let (schedule,ii) = modulo_schedule heightr ddg mii (10 * mii) in
+ (NI.fold (fun n v map ->
+ match v with
+ | Some v -> NI.add n v map
+ | None -> failwith "pipeliner: schedule unfinished"
+ ) schedule NI.empty,ii)
+
+let print_schedule sched =
+ NI.iter (fun node time ->
+ Printf.fprintf SPDebug.dc "%s |---> %i \n" (string_of_node node) time
+ ) sched
diff --git a/src/SoftwarePipelining/SPIMS.mli b/src/SoftwarePipelining/SPIMS.mli
new file mode 100644
index 0000000..7c1d9a7
--- /dev/null
+++ b/src/SoftwarePipelining/SPIMS.mli
@@ -0,0 +1,22 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open Graph.Pack.Digraph
+open SPBasic
+
+module NI : Map.S with type key = SPBasic.G.V.t
+
+(* piepeliner takes a data dependency graph and returns a schedule with an initiation interval
+ fails if cannot find any schedule *)
+val pipeliner : G.t -> (G.t -> int option NI.t -> G.V.t) -> int NI.t * int
+
+val print_schedule : int NI.t -> unit
diff --git a/src/SoftwarePipelining/SPMVE.ml b/src/SoftwarePipelining/SPMVE.ml
new file mode 100644
index 0000000..28381c1
--- /dev/null
+++ b/src/SoftwarePipelining/SPMVE.ml
@@ -0,0 +1,299 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open SPBasic
+open SPIMS
+
+module Mult = Map.Make (struct type t = reg let compare = compare end)
+
+let size_of_map1 m =
+ NI.fold (fun key v size -> size + 1) m 0
+
+let size_of_map2 m =
+ Mult.fold (fun key v size -> size + 1) m 0
+
+let sched_max_time sched =
+ NI.fold (fun node time max ->
+ if time > max then time else max
+ ) sched 0
+
+let print_table t s =
+ Printf.fprintf SPDebug.dc "%s : \n" s;
+ let string_of_node_ev node =
+ match node with
+ | Some node -> string_of_node node
+ | None -> "_"
+ in
+ Array.iteri (fun i node -> Printf.fprintf SPDebug.dc "%i :: %s \n" i (string_of_node_ev node)) t
+
+let durations ddg sched ii =
+
+ G.fold_vertex (fun node mult ->
+ match written node with
+ | None -> mult
+ | Some r ->
+ let raw_succs = get_succs_raw ddg node in
+ let durations = List.map (fun succ ->
+ let d = NI.find succ sched - NI.find node sched in
+ if d >= 0 then d
+ else ((sched_max_time sched - NI.find node sched) + NI.find succ sched)
+ ) raw_succs in
+ let duration = List.fold_left (fun max e -> if max > e then max else e) 0 durations in
+ Mult.add r ((duration / ii) + 1) mult (* cette division est surement fdausse*)
+ ) ddg Mult.empty
+
+let minimizer qi ur =
+
+ let rec fill n =
+ if n <= ur then n :: fill (n + 1) else []
+ in
+
+ let l = fill qi in
+ let l = List.map (fun e -> (e,ur mod e)) l in
+ let l = List.filter (fun e -> snd e = 0) l in
+ let l = List.map fst l in
+ List.fold_left (fun min e -> if min < e then min else e) ur l
+
+let multiplicity ddg sched ii =
+ let qs = durations ddg sched ii in
+ (* Printf.printf "Quantite de variables necessaires : \n"; *)
+ (* Mult.iter (fun key mu -> print_reg key ; Printf.printf " |-> %i\n" mu) qs; *)
+ let unroll = Mult.fold (fun reg mult max ->
+ if mult > max then mult else max
+ ) qs 0 in
+ let mult = Mult.fold (fun reg mult mult ->
+ Mult.add reg (minimizer (Mult.find reg qs) unroll) mult
+ ) qs Mult.empty
+ in
+ (mult,unroll)
+
+let mve_kernel t ddg sched ii mult unroll =
+
+ let regs = Array.make ii (fresh_regs 0) in
+ for i = 0 to (ii - 1) do
+ let fregs = fresh_regs unroll in
+ Array.iter print_reg fregs;
+ Printf.fprintf SPDebug.dc "\n";
+ Array.set regs i fregs
+ done;
+
+ let used_regs = ref [] in
+
+ let index r i = Mult.find r mult - ( ((i / ii) + 1) mod Mult.find r mult) in
+ (* let pos i node inst = *)
+ (* let separation = *)
+ (* let b= NI.find node sched - NI.find inst sched in *)
+ (* if b >= 0 then b *)
+ (* else ((sched_max_time sched - NI.find inst sched) + NI.find node sched) *)
+ (* in *)
+ (* (i + separation) mod (ii * unroll) in *)
+
+ let new_t = Array.copy t in
+
+ for i = 0 to (Array.length t - 1) do
+ (* print_table new_t "Nouvelle table"; *)
+ match t.(i),new_t.(i) with
+ | Some insti, Some insti_mod ->
+ begin
+ match written insti with
+ | None -> ()
+ | Some r ->
+ begin
+ let new_reg =
+ if Mult.find r mult = 0 then r
+ else regs.(i mod ii).(index r i - 1) in
+ if (not (List.mem (r,new_reg) !used_regs)) then used_regs := (r,new_reg) :: !used_regs;
+ let inst = reforge_writes insti_mod new_reg in
+ Printf.fprintf SPDebug.dc "Reecriture : %s --> %s \n" (string_of_node insti) (string_of_node inst);
+ Array.set new_t i (Some inst);
+ let succs = get_succs_raw ddg insti in
+ List.iter (fun node ->
+
+ (* let lifetime = *)
+ (* let d = NI.find node sched - NI.find insti sched in *)
+ (* if d >= 0 then d *)
+ (* else ((sched_max_time sched - NI.find insti sched) + 1 + NI.find node sched) *)
+ (* in *)
+
+
+ (* ___Version 1___ *)
+ (* let lifetime = lifetime / ii in *)
+ (* let schedtime = *)
+ (* ((NI.find node sched) mod ii) (\* Position dans le premier bloc *\) *)
+ (* + (ii * (i / ii)) (\* Commencement du bloc ou on travail *\) *)
+ (* + (ii * lifetime ) (\* Decalage (Mult.find r mult - 1) *\) *)
+ (* + ((if (NI.find node sched mod ii) < (NI.find insti sched mod ii) then 0 else 0) * ii) *)
+ (* in *)
+
+ (* Printf.printf "seed = %i - bloc = %i - slide = %i - corr = %i - id = %i \n" *)
+ (* ((NI.find node sched) mod ii) *)
+ (* (ii * (i / ii)) (ii * lifetime) *)
+ (* ((if (NI.find node sched mod ii) < (NI.find insti sched mod ii) then 1 else 0 ) * ii) *)
+ (* id; *)
+ (* Printf.printf "Successeur a traiter : %s ooo %i ooo\n" (string_of_node node) (Mult.find r mult); *)
+
+ (* ___Version 2___ *)
+ let schedtime =
+ if (NI.find node sched > NI.find insti sched)
+ then i + (NI.find node sched - NI.find insti sched)
+ else i - NI.find insti sched + ii + NI.find node sched
+ (* let delta = NI.find insti sched - NI.find node sched in *)
+ (* (i - delta) + (((delta / ii) + 1) * ii) (\* (i - delta) + ii*\) *)
+ in
+
+ (* then *)
+
+ Printf.fprintf SPDebug.dc "i = %i - def = %i - use = %i - time = %i \n"
+ i (NI.find insti sched) (NI.find node sched) schedtime;
+
+
+ (* let id = pos i node insti in *)
+ let id = schedtime mod (unroll * ii) (* le tout modulo la tabl *) in
+ let id = (id + (unroll * ii)) mod (unroll * ii) in
+ Printf.fprintf SPDebug.dc "Positions to treat : %i \n" id;
+ let insttt = match new_t.(id) with
+ | Some inst -> inst
+ | None -> failwith "There should be an instruction"
+ in
+ let inst = reforge_reads insttt r new_reg in
+ Array.set new_t id (Some inst)
+ ) succs
+ end
+ end
+ | None, _ -> ()
+ | _, None -> failwith "MVE : qqch mal compris"
+ done;
+ new_t,!used_regs
+
+let crunch_and_unroll sched ii ur =
+ let steady_s = Array.make ii None in
+ NI.iter (fun inst time ->
+ Array.set steady_s (time mod ii) (Some inst)
+ ) sched;
+ (* Printf.printf "Etat stable : \n"; *)
+ (* let string_of_node_ev node = *)
+ (* match node with *)
+ (* | Some node -> string_of_node node *)
+ (* | None -> "_" *)
+ (* in *)
+ (* Array.iteri (fun i node -> Printf.printf "%i :: %s \n" i (string_of_node_ev node)) steady_s; *)
+ let steady = Array.make (ii * ur) None in
+ for i = 0 to (ur - 1) do
+ for time = 0 to (ii - 1) do
+ Array.set steady (time + i * ii) (steady_s.(time))
+ done
+ done;
+ steady
+
+let compute_iteration_table sched ii =
+ let t = Array.make ii None in
+ NI.iter (fun node time ->
+ Array.set t (NI.find node sched mod ii) (Some ((NI.find node sched / ii) + 1))
+ ) sched;
+ t
+
+let compute_prolog steady min ii unroll schedule it =
+
+ let prolog = ref [] in
+ let prolog_piece = ref [] in
+
+ for i = (min - 1) downto 0 do
+
+ let index = ((ii * (unroll - (min - i)))) mod (unroll * ii) in
+ prolog_piece := [];
+
+ for j = 0 to (ii - 1) do (* copie du sous tableau *)
+ (* Printf.printf "i : %i - j : %i - index : %i \n" i j index; *)
+ match steady.(index + j), it.(j) with
+ | Some inst , Some iter ->
+ if iter <= (i + 1) then prolog_piece := inst :: !prolog_piece; (* i + 1 au lieu de i *)
+ | None, _ -> ()
+ | _, _ -> failwith "compute_prolog: quelquechose est mal compris"
+ done;
+
+ prolog := List.rev (!prolog_piece) @ !prolog
+ done;
+
+ !prolog
+
+
+let compute_epilog steady min ii unroll schedule it =
+
+ let epilog = ref [] in
+
+ for i = 0 to (min - 1) do
+ let index = (i mod unroll) * ii in
+ for j = 0 to (ii - 1) do
+ match steady.(index + j), it.(j) with
+ | Some inst , Some iter ->
+ if iter > (i + 1) then epilog := inst :: !epilog;
+ | None, _ -> ()
+ | _, _ -> failwith "compute_prolog: quelquechose est mal compris"
+ done;
+ done;
+ List.rev (!epilog)
+
+let entrance = List.map (fun (a,b) -> (b,a))
+
+let way_out prolog epilog used_regs =
+ let l = List.rev (prolog @ epilog) in
+
+ let rec way_out_rec l wo =
+ match l with
+ | [] -> wo
+ | i :: l ->
+ begin
+ match written i with
+ | Some r ->
+ let mov = List.find (fun (a,b) -> r = b) used_regs in
+ if List.mem mov wo
+ then way_out_rec l wo
+ else way_out_rec l (mov :: wo)
+ | None -> way_out_rec l wo
+ end
+ in
+
+ way_out_rec l []
+
+let mve ddg sched ii =
+ assert (size_of_map1 sched = G.nb_vertex ddg);
+ Printf.fprintf SPDebug.dc "L'intervalle d'initiation est de : %i \n" ii;
+ Printf.fprintf SPDebug.dc "L'ordonnancement est le suivant : \n";
+ print_schedule sched;
+ let (mult,unroll) = multiplicity ddg sched ii in
+ let unroll = unroll in (* changer pour tester, default doit etre egal a unroll *)
+ Printf.fprintf SPDebug.dc "Table de multiplicite : \n";
+ Mult.iter (fun key mu -> print_reg key ; Printf.fprintf SPDebug.dc " |-> %i\n" mu) mult;
+ Printf.fprintf SPDebug.dc "Taux de deroulement de : %i \n" unroll;
+ let steady_state = crunch_and_unroll sched ii unroll in
+ let (steady_state,used_regs) = mve_kernel steady_state ddg sched ii mult unroll in
+ print_table steady_state "Table finale";
+ let min = ((sched_max_time sched) / ii) + 1 in
+ Printf.fprintf SPDebug.dc "min : %i \n" min;
+ let iteration_table = compute_iteration_table sched ii in
+ Printf.fprintf SPDebug.dc "Table d'iteration \n";
+ Array.iteri (fun i elt ->
+ match elt with
+ | Some elt ->
+ Printf.fprintf SPDebug.dc "%i : %i\n" i elt
+ | None -> Printf.fprintf SPDebug.dc "%i : _ \n" i
+ ) iteration_table;
+ let prolog = compute_prolog steady_state min ii unroll sched iteration_table in
+ let prolog = List.filter (fun e -> not (is_cond e)) prolog in
+ let epilog = compute_epilog steady_state min ii unroll sched iteration_table in
+ let epilog = List.filter (fun e -> not (is_cond e)) epilog in
+ Printf.fprintf SPDebug.dc "Prologue: \n";
+ List.iter (fun node -> Printf.fprintf SPDebug.dc "%s \n" (string_of_node node)) prolog;
+ Printf.fprintf SPDebug.dc "Epilogue: \n";
+ List.iter (fun node -> Printf.fprintf SPDebug.dc "%s \n" (string_of_node node)) epilog;
+ let way_out = way_out prolog epilog used_regs in
+ (steady_state,prolog,epilog,min - 1,unroll,entrance used_regs, way_out)
diff --git a/src/SoftwarePipelining/SPMVE.mli b/src/SoftwarePipelining/SPMVE.mli
new file mode 100644
index 0000000..2da367d
--- /dev/null
+++ b/src/SoftwarePipelining/SPMVE.mli
@@ -0,0 +1,17 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open SPBasic
+open SPIMS
+
+val mve : G.t -> int NI.t -> int ->
+ (G.V.t option) array * G.V.t list * G.V.t list * int * int * (reg * reg) list * (reg * reg) list
diff --git a/src/SoftwarePipelining/SPSymbolic_evaluation.ml b/src/SoftwarePipelining/SPSymbolic_evaluation.ml
new file mode 100644
index 0000000..c99afc8
--- /dev/null
+++ b/src/SoftwarePipelining/SPSymbolic_evaluation.ml
@@ -0,0 +1,226 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open Registers
+open Op
+open AST
+open SPBase_types
+open Camlcoq
+
+type symbolic_value =
+ | Sreg of reg
+ | Sop of operation * symbolic_value list
+ | Sload of memory_chunk * addressing * symbolic_value list * symbolic_mem
+
+and symbolic_mem =
+ | Smem
+ | Sstore of memory_chunk * addressing * symbolic_value list * symbolic_value * symbolic_mem
+
+module State = Map.Make (struct type t = reg let compare = compare end)
+
+module Cons = Set.Make (struct type t = symbolic_value let compare = compare end)
+
+type symbolic_state = symbolic_value State.t * Cons.t
+
+let initial_state = State.empty
+let initial_mem = Smem
+let initial_cons = Cons.empty
+
+exception Not_straight
+
+let find res st =
+ try State.find res st
+ with
+ | Not_found -> Sreg res
+
+let rec get_args st = function
+ | [] -> []
+ | arg::args -> find arg st :: get_args st args
+
+let rec symbolic_evaluation st sm cs = function
+ | [] -> (st,sm,cs)
+ | Inop :: l -> symbolic_evaluation st sm cs l
+
+ | Iop (Omove, [src], dst) :: l ->
+ symbolic_evaluation (State.add dst (find src st) st) sm cs l
+
+ | Iop (op, args, dst) :: l ->
+ let sym_val = Sop (op,get_args st args) in
+ symbolic_evaluation (State.add dst sym_val st) sm (Cons.add sym_val cs) l
+
+ | Iload (chunk, mode, args, dst) :: l ->
+ let sym_val = Sload (chunk, mode, get_args st args, sm) in
+ symbolic_evaluation (State.add dst sym_val st) sm (Cons.add sym_val cs) l
+
+ | Istore (chunk, mode, args, src) :: l ->
+ let sym_mem = Sstore (chunk, mode, get_args st args, find src st, sm) in
+ symbolic_evaluation st sym_mem cs l
+
+ | _ :: l -> raise Not_straight
+
+type osv =
+ | Oresource of resource
+ | Oop of operation
+ | Oload of memory_chunk * addressing
+ | Ostore of memory_chunk * addressing
+
+let string_of_osv = function
+ | Oresource (Reg r) -> Printf.sprintf "reg %i" (P.to_int r)
+ | Oresource Mem -> "mem"
+ | Oop op -> string_of_op op
+ | Oload (mc,addr) -> "load"
+ | Ostore (mc,addr) -> "store"
+
+type ident = int
+
+module S = Graph.Persistent.Digraph.Abstract
+ (struct type t = osv * ident end)
+
+let name_of_vertex v =
+ let (osv,id) = S.V.label v in
+ Printf.sprintf "%i" id
+
+let string_of_vertex v =
+ let (osv,_) = S.V.label v in
+ Printf.sprintf "%s" (string_of_osv osv)
+
+module DisplayTree = struct
+ include S
+ let vertex_name v = name_of_vertex v
+ let graph_attributes _ = []
+ let default_vertex_attributes _ = []
+ let vertex_attributes v = [`Label (string_of_vertex v)]
+ let default_edge_attributes _ = []
+ let edge_attributes _ = []
+ let get_subgraph _ = None
+end
+module DotTree = Graph.Graphviz.Dot(DisplayTree)
+
+let dot_output_ss g f =
+ let oc = open_out f in
+ DotTree.output_graph oc g;
+ close_out oc
+
+module Build = Graph.Builder.P (S)
+module Op = Graph.Oper.Make (Build)
+
+let counter = ref 0
+
+let rec convert_sv_rec sv graph =
+ incr counter;
+ match sv with
+ | Sreg res ->
+ let node = S.V.create (Oresource (Reg res), !counter) in
+ let graph = S.add_vertex graph node in
+ (graph,node)
+
+ | Sop (op, svl) ->
+ let node = S.V.create (Oop op, !counter) in
+ let (graph, node_l) = List.fold_right (fun sv (graph,node_l) ->
+ let (graph,node) = convert_sv_rec sv graph in
+ graph, node :: node_l
+ ) svl (graph,[]) in
+ let graph = S.add_vertex graph node in
+ let graph = List.fold_right (fun n graph ->
+ S.add_edge graph node n
+ ) node_l graph in
+ (graph,node)
+
+
+ | Sload (mc,addr,svl,sm) ->
+ let node = S.V.create (Oload (mc, addr), !counter) in
+ let (graph, node_l) = List.fold_right (fun sv (graph,node_l) ->
+ let (graph,node) = convert_sv_rec sv graph in
+ graph, node :: node_l
+ ) svl (graph,[]) in
+ let (graph,node_m) = convert_sm_rec sm graph in
+ let graph = S.add_vertex graph node in
+ let graph = List.fold_right (fun n graph ->
+ S.add_edge graph node n
+ ) node_l graph in
+ let graph = S.add_edge graph node node_m in
+ (graph,node)
+
+and convert_sm_rec sm graph =
+ incr counter;
+ match sm with
+ | Smem ->
+ let node = S.V.create (Oresource Mem, !counter) in
+ let graph = S.add_vertex graph node in
+ (graph,node)
+
+ | Sstore (mc,addr,svl,sv,sm) ->
+ let node = S.V.create (Ostore (mc, addr), !counter) in
+ let (graph, node_l) = List.fold_right (fun sv (graph,node_l) ->
+ let (graph,node) = convert_sv_rec sv graph in
+ graph, node :: node_l
+ ) svl (graph,[]) in
+ let (graph, n) = convert_sv_rec sv graph in
+ let (graph, node_m) = convert_sm_rec sm graph in
+ let graph = S.add_vertex graph node in
+ let graph = List.fold_right (fun n graph ->
+ S.add_edge graph node n
+ ) node_l graph in
+ let graph = S.add_edge graph node n in
+ let graph = S.add_edge graph node node_m in
+ (graph,node)
+
+let convert_sv sv = convert_sv_rec sv S.empty
+let convert_sm sm = convert_sm_rec sm S.empty
+
+let convert_sym st sm regs =
+ let graph = State.fold (fun res sv g ->
+ if (not (List.mem res regs)) then g
+ else
+ let (graph,head) = convert_sv sv in
+ incr counter;
+ let src = S.V.create (Oresource (Reg res), !counter) in
+ let graph = S.add_vertex graph src in
+ let graph = S.add_edge graph src head in
+ Op.union g graph
+ ) st S.empty
+ in
+ let graph' =
+ let (graph,head) = convert_sm sm in
+ incr counter;
+ let src = S.V.create (Oresource Mem, !counter) in
+ let graph = S.add_vertex graph src in
+ let graph = S.add_edge graph src head in
+ graph
+ in
+ Op.union graph graph'
+
+let display_st name l regs =
+ let (st,sm,_) = symbolic_evaluation initial_state initial_mem initial_cons l in
+ let g = convert_sym st sm regs in
+ let addr = SPDebug.name ^ name in
+ dot_output_ss g addr ;
+ ignore (Sys.command ("(dot -Tpng " ^ addr ^ " -o " ^ addr ^ ".png ; rm -f " ^ addr ^ ") & ")) (* & *)
+
+
+let symbolic_equivalence (st1,sm1,cs1) (st2,sm2,cs2) regs =
+ Printf.printf "|cs1| = %i - |cs2| = %i \n" (Cons.cardinal cs1) (Cons.cardinal cs2);
+ (List.fold_right (fun res b ->
+ find res st1 = find res st2 && b
+ ) regs true
+ && sm1 = sm2
+ && Cons.equal cs1 cs2)
+
+let symbolic_evaluation = symbolic_evaluation initial_state initial_mem initial_cons
+
+let symbolic_condition i l =
+ match i with
+ | Icond (cond,args) ->
+ let args = to_caml_list args in
+ let (st,sm,cs) = symbolic_evaluation l in
+ (cond,List.map (fun r -> find r st) args)
+ | _ -> failwith "Not a condition !\n"
diff --git a/src/SoftwarePipelining/SPTyping.ml b/src/SoftwarePipelining/SPTyping.ml
new file mode 100644
index 0000000..9b9c679
--- /dev/null
+++ b/src/SoftwarePipelining/SPTyping.ml
@@ -0,0 +1,526 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+(*open Datatypes
+open List
+open Camlcoq
+open Maps
+open AST
+open Op
+open Registers
+open RTL
+
+open Conventions
+open Coqlib
+open Errors
+open Specif
+
+exception Type_error of string
+
+let env = ref (PTree.empty : typ PTree.t)
+
+let set_type r ty =
+ match PTree.get r !env with
+ | None -> env := PTree.set r ty !env
+ | Some ty' -> if ty <> ty' then
+ begin
+ Printf.fprintf SPDebug.dc "Failed to type register : %i " (P.to_int r);
+ raise (Type_error "type mismatch")
+ end
+
+let rec set_types rl tyl =
+ match rl, tyl with
+ | [], [] -> ()
+ | r1 :: rs, ty1 :: tys -> set_type r1 ty1; set_types rs tys
+ | _, _ -> raise (Type_error "arity mismatch")
+
+(* First pass: process constraints of the form typeof(r) = ty *)
+
+let type_instr retty (pc, i) =
+ Printf.fprintf SPDebug.dc "typage de l'instruction : %i \n" (P.to_int pc);
+ match i with
+ | Inop(_) ->
+ ()
+ | Iop(Omove, _, _, _) ->
+ ()
+ | Iop(op, args, res, _) ->
+ let (targs, tres) = type_of_operation op in
+ set_types args targs; set_type res tres
+ | Iload(chunk, addr, args, dst, _) ->
+ set_types args (type_of_addressing addr);
+ set_type dst (type_of_chunk chunk)
+ | Istore(chunk, addr, args, src, _) ->
+ set_types args (type_of_addressing addr);
+ set_type src (type_of_chunk chunk)
+ | Icall(sg, ros, args, res, _) ->
+ begin try
+ begin match ros with
+ | Coq_inl r -> set_type r Tint
+ | Coq_inr _ -> ()
+ end;
+ set_types args sg.sig_args;
+ set_type res (match sg.sig_res with Tret t -> t | _ -> Tint);
+ with Type_error msg ->
+ let name =
+ match ros with
+ | Coq_inl _ -> "<reg>"
+ | Coq_inr id -> extern_atom id in
+ raise(Type_error (Printf.sprintf "type mismatch in Icall(%s): %s"
+ name msg))
+ end
+ | Itailcall(sg, ros, args) ->
+ begin try
+ begin match ros with
+ | Coq_inl r -> set_type r Tint
+ | Coq_inr _ -> ()
+ end;
+ set_types args sg.sig_args;
+ if sg.sig_res <> retty then
+ raise (Type_error "mismatch on return type")
+ with Type_error msg ->
+ let name =
+ match ros with
+ | Coq_inl _ -> "<reg>"
+ | Coq_inr id -> extern_atom id in
+ raise(Type_error (Printf.sprintf "type mismatch in Itailcall(%s): %s"
+ name msg))
+ end
+(* | Ialloc(arg, res, _) ->
+ set_type arg Tint; set_type res Tint*)
+ | Icond(cond, args, _, _) ->
+ set_types args (type_of_condition cond)
+ | Ireturn(optres) ->
+ begin match optres, retty with
+ | None, Tvoid -> ()
+ | Some r, Tret ty -> set_type r ty
+ | _, _ -> raise (Type_error "type mismatch in Ireturn")
+ end
+
+let type_pass1 retty instrs =
+ List.iter (type_instr retty) instrs
+
+(* Second pass: extract move constraints typeof(r1) = typeof(r2)
+ and solve them iteratively *)
+
+let rec extract_moves = function
+ | [] -> []
+ | (pc, i) :: rem ->
+ match i with
+ | Iop(Omove, [r1], r2, _) ->
+ (r1, r2) :: extract_moves rem
+ | Iop(Omove, _, _, _) ->
+ raise (Type_error "wrong Omove")
+ | _ ->
+ extract_moves rem
+
+let changed = ref false
+
+let rec solve_moves = function
+ | [] -> []
+ | (r1, r2) :: rem ->
+ match (PTree.get r1 !env, PTree.get r2 !env) with
+ | Some ty1, Some ty2 ->
+ if ty1 = ty2
+ then (changed := true; solve_moves rem)
+ else raise (Type_error "type mismatch in Omove")
+ | Some ty1, None ->
+ env := PTree.set r2 ty1 !env; changed := true; solve_moves rem
+ | None, Some ty2 ->
+ env := PTree.set r1 ty2 !env; changed := true; solve_moves rem
+ | None, None ->
+ (r1, r2) :: solve_moves rem
+
+let rec iter_solve_moves mvs =
+ changed := false;
+ let mvs' = solve_moves mvs in
+ if !changed then iter_solve_moves mvs'
+
+let type_pass2 instrs =
+ iter_solve_moves (extract_moves instrs)
+
+let typeof e r =
+ match PTree.get r e with Some ty -> ty | None -> Tint
+
+let infer_type_environment f instrs =
+ try
+ env := PTree.empty;
+ set_types f.fn_params f.fn_sig.sig_args;
+ type_pass1 f.fn_sig.sig_res instrs;
+ type_pass2 instrs;
+ let e = !env in
+ env := PTree.empty;
+ Some(typeof e)
+ with Type_error msg ->
+ Printf.eprintf "Error during RTL type inference: %s\n" msg;
+ None
+
+(** val typ_eq : typ -> typ -> bool **)
+
+let typ_eq t1 t2 =
+ match t1 with
+ | Tint -> (match t2 with
+ | Tint -> true
+ | Tfloat -> false)
+ | Tfloat -> (match t2 with
+ | Tint -> false
+ | Tfloat -> true)
+
+(** val opt_typ_eq : typ option -> typ option -> bool **)
+
+let opt_typ_eq t1 t2 =
+ match t1 with
+ | Some x -> (match t2 with
+ | Some t -> typ_eq x t
+ | None -> false)
+ | None -> (match t2 with
+ | Some t -> false
+ | None -> true)
+
+(** val check_reg : regenv -> reg -> typ -> bool **)
+
+let check_reg env r ty =
+ match typ_eq (env r) ty with
+ | true -> true
+ | false -> false
+
+(** val check_regs : regenv -> reg list -> typ list -> bool **)
+
+let rec check_regs env rl tyl =
+ match rl with
+ | [] ->
+ (match tyl with
+ | [] -> true
+ | (t :: l) -> false)
+ | r1 :: rs ->
+ (match tyl with
+ | [] -> false
+ | (ty :: tys) ->
+ (match typ_eq (env r1) ty with
+ | true -> check_regs env rs tys
+ | false -> false))
+
+(** val check_op : regenv -> operation -> reg list -> reg -> bool **)
+
+let check_op env op args res0 =
+ let (targs, tres) = type_of_operation op in
+ (match check_regs env args targs with
+ | true ->
+ (match typ_eq (env res0) tres with
+ | true -> true
+ | false -> false)
+ | false -> false)
+
+(** val check_successor : coq_function -> node -> bool **)
+
+let check_successor funct s =
+ match Maps.PTree.get s funct.fn_code with
+ | Some i -> true
+ | None -> false
+
+(** val check_instr : coq_function -> regenv -> instruction -> bool **)
+
+let check_instr funct env = function
+ | Inop s -> check_successor funct s
+ | Iop (op, args, res0, s) ->
+ (match op with
+ | Omove ->
+ (match args with
+ | Coq_nil -> false
+ | Coq_cons (arg, l) ->
+ (match l with
+ | Coq_nil ->
+ (match typ_eq (env arg) (env res0) with
+ | true -> check_successor funct s
+ | false -> false)
+ | Coq_cons (r, l0) -> false))
+ | Ointconst i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ofloatconst f ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+(* | Oaddrsymbol (i0, i1) ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)*)
+(* | Oaddrstack i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)*)
+ | Ocast8signed ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ocast8unsigned ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ocast16signed ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ocast16unsigned ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+(* | Oadd ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oaddimm i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)*)
+ | Osub ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Osubimm i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Omul ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Omulimm i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Odiv ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Odivu ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oand ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oandimm i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oor ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oorimm i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oxor ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oxorimm i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Onand ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Onor ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Onxor ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oshl ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oshr ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oshrimm i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oshrximm i0 ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oshru ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Orolm (i0, i1) ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Onegf ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oabsf ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Oaddf ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Osubf ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Omulf ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Odivf ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Omuladdf ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Omulsubf ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Osingleoffloat ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ointoffloat ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ointuoffloat ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ofloatofint ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ofloatofintu ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false)
+ | Ocmp c ->
+ (match check_op env op args res0 with
+ | true -> check_successor funct s
+ | false -> false))
+ | Iload (chunk, addr, args, dst, s) ->
+ (match check_regs env args (type_of_addressing addr) with
+ | true ->
+ (match typ_eq (env dst) (type_of_chunk chunk) with
+ | true -> check_successor funct s
+ | false -> false)
+ | false -> false)
+ | Istore (chunk, addr, args, src, s) ->
+ (match check_regs env args (type_of_addressing addr) with
+ | true ->
+ (match typ_eq (env src) (type_of_chunk chunk) with
+ | true -> check_successor funct s
+ | false -> false)
+ | false -> false)
+ | Icall (sig0, ros, args, res0, s) ->
+ (match match ros with
+ | Coq_inl r ->
+ (match typ_eq (env r) Tint with
+ | true -> check_regs env args sig0.sig_args
+ | false -> false)
+ | Coq_inr s0 -> check_regs env args sig0.sig_args with
+ | true ->
+ (match typ_eq (env res0) (proj_sig_res sig0) with
+ | true -> check_successor funct s
+ | false -> false)
+ | false -> false)
+ | Itailcall (sig0, ros, args) ->
+ (match match match ros with
+ | Coq_inl r ->
+ (match typ_eq (env r) Tint with
+ | true -> check_regs env args sig0.sig_args
+ | false -> false)
+ | Coq_inr s -> check_regs env args sig0.sig_args with
+ | true ->
+ proj_sumbool
+ (opt_typ_eq sig0.sig_res funct.fn_sig.sig_res)
+ | false -> false with
+ | true -> tailcall_is_possible sig0
+ | false -> false)
+(* | Ialloc (arg, res0, s) ->
+ (match typ_eq (env arg) Tint with
+ | true ->
+ (match typ_eq (env res0) Tint with
+ | true -> check_successor funct s
+ | false -> false)
+ | false -> false)*)
+ | Icond (cond, args, s1, s2) ->
+ (match match check_regs env args (type_of_condition cond) with
+ | true -> check_successor funct s1
+ | false -> false with
+ | true -> check_successor funct s2
+ | false -> false)
+ | Ireturn optres ->
+ (match optres with
+ | Some r ->
+ (match funct.fn_sig.sig_res with
+ | Some t ->
+ (match typ_eq (env r) t with
+ | true -> true
+ | false -> false)
+ | None -> false)
+ | None ->
+ (match funct.fn_sig.sig_res with
+ | Some t -> false
+ | None -> true))
+
+(** val check_params_norepet : reg list -> bool **)
+
+let check_params_norepet params =
+ match list_norepet_dec Registers.Reg.eq params with
+ | true -> true
+ | false -> false
+
+(** val check_instrs : coq_function -> regenv -> (node, instruction) prod
+ list -> bool **)
+
+let rec check_instrs funct env = function
+ | Coq_nil -> true
+ | Coq_cons (p, rem) ->
+ let Coq_pair (pc, i) = p in
+ (match check_instr funct env i with
+ | true -> check_instrs funct env rem
+ | false -> false)
+
+(** val type_function : coq_function -> unit **)
+
+let type_function f =
+ let instrs = Maps.PTree.elements f.fn_code in
+ match infer_type_environment f instrs with
+ | Some env ->
+ (match match match match check_regs env f.fn_params
+ f.fn_sig.sig_args with
+ | true -> check_params_norepet f.fn_params
+ | false -> false with
+ | true -> check_instrs f env instrs
+ | false -> false with
+ | true -> check_successor f f.fn_entrypoint
+ | false -> false with
+ | true -> Printf.fprintf SPDebug.dc "The code is well typed\n"
+ | false -> failwith "Type checking failure\n")
+ | None -> failwith "Type inference failure\n"
+*)
diff --git a/src/SoftwarePipelining/SPTyping.mli b/src/SoftwarePipelining/SPTyping.mli
new file mode 100644
index 0000000..dd27875
--- /dev/null
+++ b/src/SoftwarePipelining/SPTyping.mli
@@ -0,0 +1,14 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+
+(*val type_function : RTL.coq_function -> unit*)
diff --git a/src/SoftwarePipelining/SoftwarePipelining.ml b/src/SoftwarePipelining/SoftwarePipelining.ml
new file mode 100644
index 0000000..0ba6d9d
--- /dev/null
+++ b/src/SoftwarePipelining/SoftwarePipelining.ml
@@ -0,0 +1,74 @@
+(***********************************************************************)
+(* *)
+(* Compcert Extensions *)
+(* *)
+(* Jean-Baptiste Tristan *)
+(* *)
+(* All rights reserved. This file is distributed under the terms *)
+(* described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+
+open SPBasic
+open SPIMS
+open SPMVE
+open RTL
+
+let clean t =
+
+ let rec clean_rec i =
+ match i with
+ | 0 -> []
+ | n ->
+ begin
+ match t.(i - 1) with
+ | None -> clean_rec (i - 1)
+ | Some inst -> inst :: clean_rec (i - 1)
+ end
+ in
+ let l = List.rev (clean_rec (Array.length t)) in
+ List.hd l :: (List.filter (fun e -> not (is_cond e)) (List.tl l))
+
+let print_nodes = List.iter (fun n -> Printf.printf "%s \n" (string_of_node n))
+
+(* random heuristic *)
+
+let find node schedule opt =
+ try NI.find node schedule with
+ | Not_found -> opt
+
+(* A random heuristic is used to pick the next instruction to be scheduled from the unscheduled
+ * instructions. The scheduled instructions are given to the function, and the unscheduled
+ * instructions are created by taking all the instructions that are not in the scheduled list.
+ *)
+let random ddg schedule =
+ let unscheduled = G.fold_vertex (fun node l ->
+ match find node schedule None with
+ | Some v -> l
+ | None -> node :: l
+ ) ddg [] in
+ let bound = List.length unscheduled in
+ Random.self_init ();
+ List.nth unscheduled (Random.int bound)
+
+(* tought heuristics *)
+
+module Topo = Graph.Topological.Make (G)
+module Scc = Graph.Components.Make (G)
+
+let order = ref []
+
+let pipeliner ddg =
+ order := List.flatten (Scc.scc_list ddg);
+ let (sched,ii) = SPIMS.pipeliner ddg random in
+ let (steady,prolog,epilog,min,unroll,entrance,way_out) = SPMVE.mve ddg sched ii in
+ let steady_state = clean steady in
+ if min <= 0 then None
+ else
+ Some {steady_state = steady_state; prolog = prolog; epilog = epilog; min = min; unrolling = unroll;
+ ramp_up = entrance; ramp_down = way_out}
+
+
+let pipeline f =
+ SPBasic.apply_pipeliner f pipeliner ~debug:false
diff --git a/src/VericertClflags.ml b/src/VericertClflags.ml
index ca591de..26b4053 100644
--- a/src/VericertClflags.ml
+++ b/src/VericertClflags.ml
@@ -4,3 +4,5 @@ let option_hls = ref true
let option_debug_hls = ref false
let option_initial = ref false
let option_dhtl = ref false
+let option_drtlblock = ref false
+let option_hls_schedule = ref false
diff --git a/src/common/IntegerExtra.v b/src/common/IntegerExtra.v
index c9b5dbd..2b6cded 100644
--- a/src/common/IntegerExtra.v
+++ b/src/common/IntegerExtra.v
@@ -1,11 +1,30 @@
-Require Import BinInt.
-Require Import Lia.
-Require Import ZBinary.
-
-From bbv Require Import ZLib.
-From compcert Require Import Integers Coqlib.
-
-Require Import Vericertlib.
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020-2021 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
+ *
+ * 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import Coq.ZArith.BinInt.
+Require Import Coq.micromega.Lia.
+Require Import Coq.Numbers.Integer.Binary.ZBinary.
+
+Require Import compcert.lib.Coqlib.
+Require Import compcert.lib.Integers.
+
+Require Import vericert.common.Vericertlib.
Local Open Scope Z_scope.
@@ -319,7 +338,7 @@ Module IntExtra.
assert (zwordsize = 4 * Byte.zwordsize) by reflexivity.
fold (testbit (shru n (repr Byte.zwordsize)) i). rewrite bits_shru.
change (unsigned (repr Byte.zwordsize)) with Byte.zwordsize.
- apply zlt_true. omega. omega.
+ apply zlt_true. lia. lia.
Qed.
Lemma bits_byte3:
@@ -329,7 +348,7 @@ Module IntExtra.
assert (zwordsize = 4 * Byte.zwordsize) by reflexivity.
fold (testbit (shru n (repr (2 * Byte.zwordsize))) i). rewrite bits_shru.
change (unsigned (repr (2 * Byte.zwordsize))) with (2 * Byte.zwordsize).
- apply zlt_true. omega. omega.
+ apply zlt_true. lia. lia.
Qed.
Lemma bits_byte4:
@@ -339,7 +358,7 @@ Module IntExtra.
assert (zwordsize = 4 * Byte.zwordsize) by reflexivity.
fold (testbit (shru n (repr (3 * Byte.zwordsize))) i). rewrite bits_shru.
change (unsigned (repr (3 * Byte.zwordsize))) with (3 * Byte.zwordsize).
- apply zlt_true. omega. omega.
+ apply zlt_true. lia. lia.
Qed.
Lemma bits_ofwords:
@@ -362,4 +381,291 @@ Module IntExtra.
rewrite testbit_repr; auto.
Abort.
+ Lemma div_divs_equiv :
+ forall x y,
+ signed x >= 0 ->
+ signed y >= 0 ->
+ divs x y = divu x y.
+ Proof.
+ unfold divs, divu.
+ intros.
+ rewrite !signed_eq_unsigned;
+ try rewrite Zquot.Zquot_Zdiv_pos; try reflexivity;
+ lazymatch goal with
+ | |- unsigned _ <= max_signed =>
+ solve [rewrite <- signed_positive; assumption]
+ | |- 0 <= unsigned _ => solve [apply unsigned_range_2]
+ end.
+ Qed.
+
+ Lemma neg_signed' :
+ forall x : int,
+ unsigned x <> 2147483648 ->
+ signed (neg x) = - signed x.
+ Proof.
+ intros x Hhalf.
+ Transparent repr.
+ unfold signed.
+ simpl.
+ rewrite Z_mod_modulus_eq.
+ replace modulus with 4294967296; auto.
+ replace half_modulus with 2147483648; auto.
+ repeat match goal with | |- context[if ?x then _ else _] => destruct x end.
+ - destruct (Z.eq_dec (unsigned x) 0).
+ + rewrite e. auto.
+ + pose proof (Z.mod_opp_l_nz (unsigned x) 4294967296).
+ assert (4294967296 <> 0) by lia.
+ apply H in H0.
+ rewrite H0 in l.
+ pose proof (Z.mod_small (unsigned x) 4294967296).
+ assert (0 <= unsigned x < 4294967296).
+ pose proof (unsigned_range_2 x). lia.
+ apply H1 in H2. rewrite H2 in l. lia.
+ rewrite Z.mod_small. assumption.
+ pose proof (unsigned_range_2 x). lia.
+ - destruct (Z.eq_dec (unsigned x) 0).
+ + lia.
+ + rewrite Z.mod_opp_l_nz; try lia.
+ rewrite Z.opp_sub_distr.
+ rewrite Z.mod_small. lia.
+ pose proof (unsigned_range_2 x).
+ simplify; lia.
+ rewrite Z.mod_small. assumption.
+ pose proof (unsigned_range_2 x).
+ simplify; lia.
+ - destruct (Z.eq_dec (unsigned x) 0).
+ + rewrite e in *. rewrite Z.opp_0 in *. rewrite Zmod_0_l in g. lia.
+ + rewrite Z.mod_opp_l_nz; try lia.
+ rewrite Z.mod_small. lia.
+ pose proof (unsigned_range_2 x). lia.
+ rewrite Z.mod_small. assumption.
+ pose proof (unsigned_range_2 x). lia.
+ - destruct (Z.eq_dec (unsigned x) 0).
+ + lia.
+ + rewrite Z.mod_opp_l_nz in g; try lia.
+ rewrite Z.mod_small in g.
+ assert (unsigned x < 2147483648) by lia. lia.
+ pose proof (unsigned_range_2 x).
+ replace max_unsigned with 4294967295 in * by auto. lia.
+ rewrite Z.mod_small. assumption.
+ pose proof (unsigned_range_2 x).
+ replace max_unsigned with 4294967295 in * by auto. lia.
+ Qed.
+
+ Lemma neg_divs_distr_l :
+ forall x y,
+ unsigned x <> 2147483648 ->
+ neg (divs x y) = divs (neg x) y.
+ Proof.
+ intros x y Hhalf. unfold divs, neg.
+ set (x' := signed x). set (y' := signed y).
+ apply eqm_samerepr.
+ apply eqm_trans with (- (Z.quot x' y')).
+ auto with ints.
+ replace (- (Z.quot x' y')) with (Z.quot (- x') y')
+ by (rewrite Zquot.Zquot_opp_l; auto).
+ unfold x'.
+ rewrite <- neg_signed'.
+ auto with ints.
+ assumption.
+ Qed.
+
+ Lemma neg_signed :
+ forall x : int,
+ unsigned x <> 2147483648 ->
+ signed x < 0 ->
+ signed (neg x) >= 0.
+ Proof.
+ intros.
+ rewrite neg_signed'. lia.
+ assumption.
+ Qed.
+
+ Lemma shl_signed_positive :
+ forall y,
+ unsigned y <= 30 ->
+ signed (shl one y) >= 0.
+ Proof.
+ intros.
+ unfold signed, shl.
+ destruct (zlt (unsigned (repr (Z.shiftl (unsigned one) (unsigned y)))) half_modulus).
+ - rewrite unsigned_repr.
+ + rewrite Z.shiftl_1_l.
+ apply Z.le_ge. apply Z.pow_nonneg. lia.
+ + rewrite Z.shiftl_1_l. split.
+ apply Z.pow_nonneg. lia.
+ simplify.
+ replace (4294967295) with (2 ^ 32 - 1); try lia.
+ transitivity (2 ^ 31); try lia.
+ apply Z.pow_le_mono_r; lia.
+ - simplify. rewrite Z.shiftl_1_l in g.
+ unfold half_modulus, modulus, wordsize,
+ Wordsize_32.wordsize in *. unfold two_power_nat in *. simplify.
+ unfold Z_mod_modulus in *.
+ destruct (2 ^ unsigned y) eqn:?.
+ apply Z.ge_le in g. exfalso.
+ replace (4294967296 / 2) with (2147483648) in g; auto.
+ rewrite Z.shiftl_1_l. rewrite Heqz.
+ unfold wordsize in *. unfold Wordsize_32.wordsize in *.
+ rewrite Zbits.P_mod_two_p_eq in *.
+ replace (4294967296 / 2) with (2147483648) in g; auto.
+ rewrite <- Heqz in g.
+ rewrite Z.mod_small in g.
+ replace (2147483648) with (2 ^ 31) in g.
+ pose proof (Z.pow_le_mono_r 2 (unsigned y) 30).
+ apply Z.ge_le in g.
+ assert (0 < 2) by lia. apply H0 in H1. lia. assumption. lia.
+ split. lia. rewrite two_power_nat_equiv.
+ apply Z.pow_lt_mono_r; lia.
+
+ pose proof (Zlt_neg_0 p).
+ pose proof (Z.pow_nonneg 2 (unsigned y)). rewrite <- Heqz in H0.
+ lia.
+ Qed.
+
+ Lemma is_power2_shl :
+ forall y,
+ unsigned y <= 30 ->
+ is_power2 (shl one y) = Some y.
+ Proof.
+ intros.
+ unfold is_power2, shl.
+ destruct (Zbits.Z_is_power2 (unsigned (repr (Z.shiftl (unsigned one) (unsigned y))))) eqn:?.
+ - simplify.
+ rewrite Z_mod_modulus_eq in Heqo.
+ rewrite Z.mod_small in Heqo. rewrite Z.shiftl_1_l in Heqo.
+ rewrite <- two_p_correct in Heqo.
+ rewrite Zbits.Z_is_power2_complete in Heqo. inv Heqo.
+ rewrite repr_unsigned. auto.
+ pose proof (unsigned_range_2 y). lia.
+ rewrite Z.shiftl_1_l. unfold modulus, wordsize, Wordsize_32.wordsize.
+ rewrite two_power_nat_equiv.
+ split. apply Z.pow_nonneg. lia.
+ apply Z.pow_lt_mono_r; lia.
+ - simplify.
+ rewrite Z_mod_modulus_eq in Heqo.
+ rewrite Z.mod_small in Heqo. rewrite Z.shiftl_1_l in Heqo.
+ rewrite <- two_p_correct in Heqo.
+ rewrite Zbits.Z_is_power2_complete in Heqo. discriminate.
+ pose proof (unsigned_range_2 y). lia.
+ rewrite Z.shiftl_1_l. unfold modulus, wordsize, Wordsize_32.wordsize.
+ rewrite two_power_nat_equiv.
+ split. apply Z.pow_nonneg. lia.
+ apply Z.pow_lt_mono_r; lia.
+ Qed.
+
+ Definition shrx_alt (x y : int) : int :=
+ if zlt (signed x) 0
+ then neg (shru (neg x) y)
+ else shru x y.
+
+ Lemma shrx_shrx_alt_equiv_ne :
+ forall x y,
+ unsigned x <> 2147483648 ->
+ unsigned y <= 30 ->
+ shrx x y = shrx_alt x y.
+ Proof.
+ intros x y Hhalf H.
+ unfold shrx, shrx_alt, lt.
+ destruct (Z_ge_lt_dec (signed x) 0);
+ [rewrite zlt_false | rewrite zlt_true];
+
+ repeat lazymatch goal with
+ | |- is_power2 _ = Some _ => apply is_power2_shl
+ | |- signed (shl one _) >= 0 => apply shl_signed_positive
+ | |- signed (neg _) >= 0 => apply neg_signed
+ | |- divs _ _ = divu _ _ => apply div_divs_equiv
+ | |- divs ?x (shl one ?y) = neg (shru (neg ?x) ?y) =>
+ rewrite <- neg_involutive at 1; rewrite neg_divs_distr_l;
+ try assumption; f_equal
+ | |- divs ?x (shl one ?y) = shru ?x ?y =>
+ let H := fresh "H" in
+ pose proof (divu_pow2 x (shl one y) y) as H;
+ rewrite <- H
+ end; try assumption.
+ Qed.
+
+ Lemma shrx_shrx_alt_equiv_eq :
+ forall x y,
+ unsigned x = 2147483648 ->
+ unsigned y <= 30 ->
+ shrx x y = shrx_alt x y.
+ Proof.
+ intros.
+ repeat unfold shrx, shrx_alt, signed, divs, neg.
+ replace half_modulus with 2147483648 by auto.
+ replace modulus with 4294967296 by auto.
+ simplify.
+ rewrite !Z_mod_modulus_eq.
+ rewrite !H.
+ simplify.
+ assert (Hshl: Z.shiftl 1 (unsigned y) mod 4294967296 = Z.shiftl 1 (unsigned y)).
+ { apply Z.mod_small.
+ rewrite Z.shiftl_1_l.
+ split.
+ apply Z.pow_nonneg. lia.
+ replace 4294967296 with (2^32) by auto.
+ apply Z.le_lt_trans with (m := 2 ^ 31); try lia.
+ apply Z.pow_le_mono_r; lia.
+ }
+ rewrite !Hshl.
+ f_equal.
+ assert ((Z.shiftl 1 (unsigned y)) < 2147483648).
+ rewrite Z.shiftl_1_l.
+ replace 2147483648 with (2^31) by auto.
+ apply Z.le_lt_trans with (m := 2 ^ 30); try lia.
+ apply Z.pow_le_mono_r; lia.
+ destruct (zlt (Z.shiftl 1 (unsigned y)) 2147483648); try lia.
+ replace (-2147483648 mod 4294967296) with 2147483648 by auto.
+ assert (Hmodeq : Z.shiftr 2147483648 (unsigned y) mod 4294967296
+ = Z.shiftr 2147483648 (unsigned y)).
+ { apply Z.mod_small. split.
+ apply Z.shiftr_nonneg. lia.
+ rewrite Z.shiftr_div_pow2.
+ replace 4294967296 with (Z.succ 4294967295); auto.
+ apply Zle_lt_succ.
+ replace 4294967295 with (4294967295 * (2 ^ unsigned y) / (2 ^ unsigned y)).
+ 2: {
+ apply Z.div_mul.
+ pose proof (Z.pow_pos_nonneg 2 (unsigned y)).
+ apply not_eq_sym.
+ apply Z.le_neq. apply H2; try lia.
+ apply unsigned_range_2.
+ }
+
+ apply Z.div_le_mono.
+ apply Z.pow_pos_nonneg. lia.
+ apply unsigned_range_2.
+ transitivity 4294967295; try lia.
+ apply Z.le_mul_diag_r; try lia.
+ replace 1 with (Z.succ 0) by auto.
+ apply Z.le_succ_l.
+ apply Z.pow_pos_nonneg; try lia.
+ apply unsigned_range_2. apply unsigned_range_2.
+ }
+ rewrite !Hmodeq.
+ replace (-2147483648) with (Z.opp 2147483648) by auto.
+ rewrite Zquot.Zquot_opp_l.
+ f_equal.
+ rewrite Zquot.Zquot_Zdiv_pos.
+ rewrite Z.shiftr_div_pow2.
+ rewrite Z.shiftl_1_l. auto.
+ apply unsigned_range_2.
+ lia.
+ rewrite Z.shiftl_1_l.
+ apply Z.lt_le_incl.
+ apply Z.pow_pos_nonneg; try lia.
+ apply unsigned_range_2.
+ Qed.
+
+ Theorem shrx_shrx_alt_equiv :
+ forall x y,
+ unsigned y <= 30 ->
+ shrx x y = shrx_alt x y.
+ Proof.
+ intros.
+ destruct (Z.eq_dec (unsigned x) 2147483648);
+ [ apply shrx_shrx_alt_equiv_eq | apply shrx_shrx_alt_equiv_ne]; auto.
+ Qed.
+
End IntExtra.
diff --git a/src/common/Maps.v b/src/common/Maps.v
index 7a45259..2db5114 100644
--- a/src/common/Maps.v
+++ b/src/common/Maps.v
@@ -1,11 +1,32 @@
-From vericert Require Import Vericertlib.
-
-From compcert Require Export Maps.
-From compcert Require Import Errors.
-Import PTree.
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
+ *
+ * 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
Set Implicit Arguments.
+Require Export compcert.lib.Maps.
+
+Require Import compcert.common.Errors.
+
+Require Import vericert.common.Vericertlib.
+
+Import PTree.
+
Local Open Scope error_monad_scope.
(** Instance of traverse for [PTree] and [Errors]. This should maybe be generalised
diff --git a/src/common/Monad.v b/src/common/Monad.v
index c42f4a3..68233b1 100644
--- a/src/common/Monad.v
+++ b/src/common/Monad.v
@@ -1,3 +1,22 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2021 Michalis Pardalos <mpardalos@gmail.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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
From Coq Require Import BinNums Lists.List.
From compcert Require Import Maps.
diff --git a/src/common/Statemonad.v b/src/common/Statemonad.v
index 2eada2f..16dcbbf 100644
--- a/src/common/Statemonad.v
+++ b/src/common/Statemonad.v
@@ -1,3 +1,21 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
From compcert Require Errors.
From vericert Require Import Monad.
From Coq Require Import Lists.List.
diff --git a/src/common/Vericertlib.v b/src/common/Vericertlib.v
index 8b56c7d..a0d2af1 100644
--- a/src/common/Vericertlib.v
+++ b/src/common/Vericertlib.v
@@ -1,6 +1,7 @@
(*
* Vericert: Verified high-level synthesis.
- * Copyright (C) 2019-2020 Yann Herklotz <yann@yannherklotz.com>
+ * Copyright (C) 2019-2021 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
*
* 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,21 +17,23 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From Coq Require Export
- String
- ZArith
- Znumtheory
- List
- Bool.
+Set Implicit Arguments.
-Require Import Lia.
+Require Export Coq.Bool.Bool.
+Require Export Coq.Lists.List.
+Require Export Coq.Strings.String.
+Require Export Coq.ZArith.ZArith.
+Require Export Coq.ZArith.Znumtheory.
+Require Import Coq.micromega.Lia.
-From vericert Require Import Show.
+Require Export compcert.lib.Coqlib.
+Require Import compcert.lib.Integers.
+
+Require Export vericert.common.VericertTactics.
+Require Import vericert.common.Show.
(* Depend on CompCert for the basic library, as they declare and prove some
useful theorems. *)
-From compcert.lib Require Export Coqlib.
-From compcert Require Import Integers.
Local Open Scope Z_scope.
@@ -70,7 +73,12 @@ Ltac solve_by_invert := solve_by_inverts 1.
Ltac invert x := inversion x; subst; clear x.
Ltac destruct_match :=
- match goal with | [ |- context[match ?x with | _ => _ end ] ] => destruct x end.
+ match goal with
+ | [ |- context[match ?x with | _ => _ end ] ] => destruct x eqn:?
+ | [ H: context[match ?x with | _ => _ end] |- _ ] => destruct x eqn:?
+ end.
+
+Ltac auto_destruct x := destruct x eqn:?; simpl in *; try discriminate; try congruence.
Ltac nicify_hypotheses :=
repeat match goal with
@@ -180,7 +188,8 @@ Ltac liapp :=
| _ => idtac
end.
-Ltac crush := simplify; try discriminate; try congruence; try lia; liapp; try assumption.
+Ltac crush := simplify; try discriminate; try congruence; try lia; liapp;
+ try assumption; try (solve [auto]).
Global Opaque Nat.div.
Global Opaque Z.mul.
diff --git a/src/common/ZExtra.v b/src/common/ZExtra.v
index 519ee7c..62ca54d 100644
--- a/src/common/ZExtra.v
+++ b/src/common/ZExtra.v
@@ -1,8 +1,270 @@
-Require Import ZArith.
-Require Import Lia.
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
+ *
+ * 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import Coq.ZArith.BinInt.
+Require Import Coq.micromega.Lia.
+Require Import Coq.ZArith.ZArith.
Local Open Scope Z_scope.
+Module ZLib.
+
+Lemma mod2_cases: forall (n: Z), n mod 2 = 0 \/ n mod 2 = 1.
+Proof.
+ intros. pose proof (Z.mod_pos_bound n 2). lia.
+Qed.
+
+Lemma div_mul_undo: forall a b,
+ b <> 0 ->
+ a mod b = 0 ->
+ a / b * b = a.
+Proof.
+ intros.
+ pose proof Z.div_mul_cancel_l as A. specialize (A a 1 b).
+ replace (b * 1) with b in A by lia.
+ rewrite Z.div_1_r in A.
+ rewrite Z.mul_comm.
+ rewrite <- Z.divide_div_mul_exact; try assumption.
+ - apply A; congruence.
+ - apply Z.mod_divide; assumption.
+Qed.
+
+Lemma mod_0_r: forall (m: Z),
+ m mod 0 = 0.
+Proof.
+ intros. destruct m; reflexivity.
+Qed.
+
+Lemma sub_mod_0: forall (a b m: Z),
+ a mod m = 0 ->
+ b mod m = 0 ->
+ (a - b) mod m = 0.
+Proof.
+ intros *. intros E1 E2.
+ rewrite Zminus_mod.
+ rewrite E1. rewrite E2.
+ reflexivity.
+Qed.
+
+Lemma add_mod_0: forall a b m : Z,
+ a mod m = 0 ->
+ b mod m = 0 ->
+ (a + b) mod m = 0.
+Proof.
+ intros *. intros E1 E2.
+ rewrite Zplus_mod.
+ rewrite E1. rewrite E2.
+ reflexivity.
+Qed.
+
+Lemma Z_mod_mult': forall a b : Z,
+ (a * b) mod a = 0.
+Proof.
+ intros. rewrite Z.mul_comm. apply Z_mod_mult.
+Qed.
+
+Lemma mod_add_r: forall a b,
+ b <> 0 ->
+ (a + b) mod b = a mod b.
+Proof.
+ intros. rewrite <- Z.add_mod_idemp_r by lia.
+ rewrite Z.mod_same by lia.
+ rewrite Z.add_0_r.
+ reflexivity.
+Qed.
+
+Lemma mod_pow2_same_cases: forall a n,
+ a mod 2 ^ n = a ->
+ 2 ^ n = 0 /\ a = 0 \/ 0 <= a < 2 ^ n.
+Proof.
+ intros.
+ assert (n < 0 \/ 0 <= n) as C by lia. destruct C as [C | C].
+ - left. rewrite (Z.pow_neg_r 2 n C) in *. rewrite mod_0_r in H. auto.
+ - right.
+ rewrite <- H. apply Z.mod_pos_bound.
+ apply Z.pow_pos_nonneg; lia.
+Qed.
+
+Lemma mod_pow2_same_bounds: forall a n,
+ a mod 2 ^ n = a ->
+ 0 <= n ->
+ 0 <= a < 2 ^ n.
+Proof.
+ intros. rewrite <- H. apply Z.mod_pos_bound.
+ apply Z.pow_pos_nonneg; lia.
+Qed.
+
+Lemma pow2_nonneg: forall n,
+ 0 <= 2 ^ n.
+Proof.
+ intros. apply Z.pow_nonneg. lia.
+Qed.
+
+Lemma pow2_pos: forall n,
+ 0 <= n ->
+ 0 < 2 ^ n.
+Proof.
+ intros. apply Z.pow_pos_nonneg; lia.
+Qed.
+
+Lemma pow2_times2: forall i,
+ 0 < i ->
+ 2 ^ i = 2 * 2 ^ (i - 1).
+Proof.
+ intros.
+ rewrite <- Z.pow_succ_r by lia.
+ f_equal.
+ lia.
+Qed.
+
+Lemma pow2_div2: forall i,
+ 0 <= i ->
+ 2 ^ (i - 1) = 2 ^ i / 2.
+Proof.
+ intros.
+ assert (i = 0 \/ 0 < i) as C by lia. destruct C as [C | C].
+ - subst. reflexivity.
+ - rewrite Z.pow_sub_r by lia.
+ reflexivity.
+Qed.
+
+Lemma div_mul_undo_le: forall a b,
+ 0 <= a ->
+ 0 < b ->
+ a / b * b <= a.
+Proof.
+ intros.
+ pose proof (Zmod_eq_full a b) as P.
+ pose proof (Z.mod_bound_pos a b) as Q.
+ lia.
+Qed.
+
+Lemma testbit_true_nonneg: forall a i,
+ 0 <= a ->
+ 0 <= i ->
+ Z.testbit a i = true ->
+ 2 ^ i <= a.
+Proof.
+ intros.
+ apply Z.testbit_true in H1; [|assumption].
+ pose proof (pow2_pos i H0).
+ eapply Z.le_trans; [| apply (div_mul_undo_le a (2 ^ i)); lia].
+ replace (2 ^ i) with (1 * 2 ^ i) at 1 by lia.
+ apply Z.mul_le_mono_nonneg_r; [lia|].
+ pose proof (Z.div_pos a (2 ^ i)).
+ assert (a / 2 ^ i <> 0); [|lia].
+ intro E. rewrite E in H1. cbv in H1. discriminate H1.
+Qed.
+
+Lemma range_div_pos: forall a b c d,
+ 0 < d ->
+ a <= b <= c ->
+ a / d <= b / d <= c / d.
+Proof.
+ intuition idtac.
+ - apply (Z.div_le_mono _ _ _ H H1).
+ - apply (Z.div_le_mono _ _ _ H H2).
+Qed.
+
+Lemma testbit_true_nonneg': forall a i,
+ 0 <= i ->
+ 2 ^ i <= a < 2 ^ (i + 1) ->
+ Z.testbit a i = true.
+Proof.
+ intros.
+ apply Z.testbit_true; [assumption|].
+ destruct H0 as [A B].
+ pose proof (pow2_pos i H) as Q.
+ apply (Z.div_le_mono _ _ _ Q) in A.
+ rewrite Z_div_same in A by lia.
+ pose proof (Z.div_lt_upper_bound a (2 ^ i) 2 Q) as P.
+ rewrite Z.mul_comm in P.
+ replace i with (i + 1 - 1) in P by lia.
+ rewrite <- pow2_times2 in P by lia.
+ specialize (P B).
+ replace (i + 1 - 1) with i in P by lia.
+ replace (a / 2 ^ i) with 1 by lia.
+ reflexivity.
+Qed.
+
+Lemma testbit_false_nonneg: forall a i,
+ 0 <= a < 2 ^ i ->
+ 0 < i ->
+ Z.testbit a (i - 1) = false ->
+ a < 2 ^ (i - 1).
+Proof.
+ intros.
+ assert (2 ^ (i - 1) <= a < 2 ^ i \/ a < 2 ^ (i - 1)) as C by lia.
+ destruct C as [C | C]; [exfalso|assumption].
+ assert (Z.testbit a (i - 1) = true); [|congruence].
+ replace i with (i - 1 + 1) in C at 2 by lia.
+ apply testbit_true_nonneg'; lia.
+Qed.
+
+Lemma signed_bounds_to_sz_pos: forall sz n,
+ - 2 ^ (sz - 1) <= n < 2 ^ (sz - 1) ->
+ 0 < sz.
+Proof.
+ intros.
+ assert (0 < sz \/ sz - 1 < 0) as C by lia.
+ destruct C as [C | C]; [assumption|exfalso].
+ rewrite Z.pow_neg_r in H by assumption.
+ lia.
+Qed.
+
+Lemma two_digits_encoding_inj_lo: forall base a b c d: Z,
+ 0 <= b < base ->
+ 0 <= d < base ->
+ base * a + b = base * c + d ->
+ b = d.
+Proof.
+ intros.
+ pose proof Z.mod_unique as P.
+ specialize P with (b := base) (q := c) (r := d).
+ specialize P with (2 := H1).
+ rewrite P by lia.
+ rewrite <- Z.add_mod_idemp_l by lia.
+ rewrite Z.mul_comm.
+ rewrite Z.mod_mul by lia.
+ rewrite Z.add_0_l.
+ rewrite Z.mod_small by lia.
+ reflexivity.
+Qed.
+
+Lemma two_digits_encoding_inj_hi: forall base a b c d: Z,
+ 0 <= b < base ->
+ 0 <= d < base ->
+ base * a + b = base * c + d ->
+ a = c.
+Proof.
+ intros. nia.
+Qed.
+
+Lemma Z_to_nat_neg: forall (n: Z),
+ n < 0 ->
+ Z.to_nat n = 0%nat.
+Proof.
+ intros. destruct n; (lia||reflexivity).
+Qed.
+
+End ZLib.
+
Module ZExtra.
Lemma mod_0_bounds :
diff --git a/src/extraction/Extraction.v b/src/extraction/Extraction.v
index b1a885e..a4d0bde 100644
--- a/src/extraction/Extraction.v
+++ b/src/extraction/Extraction.v
@@ -16,7 +16,15 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From vericert Require Verilog Value Compiler.
+From vericert Require
+ Verilog
+ Compiler
+ RTLBlockgen
+ RTLBlock
+ RTLPar
+ RTLBlockInstr
+ HTLgen
+ Pipeline.
From Coq Require DecidableClass.
@@ -128,6 +136,7 @@ Extract Constant Compiler.print_Clight => "PrintClight.print_if".
Extract Constant Compiler.print_Cminor => "PrintCminor.print_if".
Extract Constant driver.Compiler.print_RTL => "PrintRTL.print_if".
Extract Constant Compiler.print_RTL => "PrintRTL.print_if".
+Extract Constant Compiler.print_RTLBlock => "PrintRTLBlock.print_if".
Extract Constant Compiler.print_HTL => "PrintHTL.print_if".
Extract Constant Compiler.print_LTL => "PrintLTL.print_if".
Extract Constant Compiler.print_Mach => "PrintMach.print_if".
@@ -162,12 +171,21 @@ Extract Inlined Constant Binary.B2R => "fun _ -> assert false".
Extract Inlined Constant Binary.round_mode => "fun _ -> assert false".
Extract Inlined Constant Bracket.inbetween_loc => "fun _ -> assert false".
+Extract Constant Pipeline.pipeline => "SoftwarePipelining.pipeline".
+Extract Constant RTLBlockgen.partition => "Partition.partition".
+Extract Constant RTLPargen.schedule => "Schedule.schedule_fn".
+
(* Needed in Coq 8.4 to avoid problems with Function definitions. *)
Set Extraction AccessOpaque.
Cd "src/extraction".
Separate Extraction
- Verilog.module Value.uvalueToZ vericert.Compiler.transf_hls
+ Verilog.module vericert.Compiler.transf_hls
+ vericert.Compiler.transf_hls_temp
+ RTLBlockgen.transl_program RTLBlockInstr.successors_instr
+ HTLgen.tbl_to_case_expr
+ Pipeline.pipeline
+ RTLBlockInstr.sat_pred_temp
Compiler.transf_c_program Compiler.transf_cminor_program
Cexec.do_initial_state Cexec.do_step Cexec.at_final_state
diff --git a/src/verilog/Array.v b/src/hls/Array.v
index fe0f6b2..dec1335 100644
--- a/src/verilog/Array.v
+++ b/src/hls/Array.v
@@ -1,8 +1,28 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 James Pollard <j@mes.dev>
+ *
+ * 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
Set Implicit Arguments.
-Require Import Lia.
-Require Import Vericertlib.
-From Coq Require Import Lists.List Datatypes.
+Require Import Coq.Init.Datatypes.
+Require Import Coq.Lists.List.
+Require Import Coq.micromega.Lia.
+
+Require Import vericert.common.Vericertlib.
Import ListNotations.
@@ -29,7 +49,7 @@ Lemma list_set_spec1 {A : Type} :
forall l i (x : A),
i < length l -> nth_error (list_set i x l) i = Some x.
Proof.
- induction l; intros; destruct i; crush; firstorder.
+ induction l; intros; destruct i; crush; firstorder. intuition.
Qed.
Hint Resolve list_set_spec1 : array.
@@ -37,7 +57,7 @@ Lemma list_set_spec2 {A : Type} :
forall l i (x : A) d,
i < length l -> nth i (list_set i x l) d = x.
Proof.
- induction l; intros; destruct i; crush; firstorder.
+ induction l; intros; destruct i; crush; firstorder. intuition.
Qed.
Hint Resolve list_set_spec2 : array.
@@ -56,7 +76,7 @@ Lemma array_set_wf {A : Type} :
Proof.
induction l; intros; destruct i; auto.
- invert H; crush; auto.
+ invert H; crush.
Qed.
Definition array_set {A : Type} (i : nat) (x : A) (a : Array A) :=
@@ -280,7 +300,7 @@ Proof.
destruct i; crush.
rewrite list_repeat_cons.
- destruct i; crush; firstorder.
+ destruct i; crush; firstorder. intuition.
Qed.
Definition arr_repeat {A : Type} (a : A) (n : nat) : Array A := make_array (list_repeat a n).
diff --git a/src/verilog/AssocMap.v b/src/hls/AssocMap.v
index 8d8788a..1d1b77f 100644
--- a/src/verilog/AssocMap.v
+++ b/src/hls/AssocMap.v
@@ -1,6 +1,7 @@
(*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
*
* 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,8 +17,10 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From vericert Require Import Vericertlib ValueInt.
-From compcert Require Import Maps.
+Require Import compcert.lib.Maps.
+
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.ValueInt.
Definition reg := positive.
diff --git a/src/verilog/HTL.v b/src/hls/HTL.v
index a3a13f2..4e8c08e 100644
--- a/src/verilog/HTL.v
+++ b/src/hls/HTL.v
@@ -1,6 +1,7 @@
(*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
*
* 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,11 +17,20 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From Coq Require Import FSets.FMapPositive.
-From vericert Require Import Vericertlib ValueInt AssocMap Array.
-From vericert Require Verilog.
-From compcert Require Events Globalenvs Smallstep Integers Values.
-From compcert Require Import Maps.
+Require Import Coq.FSets.FMapPositive.
+
+Require compcert.common.Events.
+Require compcert.common.Globalenvs.
+Require compcert.common.Smallstep.
+Require compcert.common.Values.
+Require compcert.lib.Integers.
+Require Import compcert.lib.Maps.
+
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.ValueInt.
+Require Import vericert.hls.AssocMap.
+Require Import vericert.hls.Array.
+Require vericert.hls.Verilog.
(** The purpose of the hardware transfer language (HTL) is to create a more
hardware-like layout that is still similar to the register transfer language
diff --git a/src/hls/HTLBlockgen.v b/src/hls/HTLBlockgen.v
new file mode 100644
index 0000000..b9fc1d9
--- /dev/null
+++ b/src/hls/HTLBlockgen.v
@@ -0,0 +1,724 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+(*From compcert Require Import Maps.
+From compcert Require Errors Globalenvs Integers.
+From compcert Require Import AST.
+From vericert Require Import RTLBlock Verilog HTL Vericertlib AssocMap ValueInt Statemonad.
+
+Hint Resolve AssocMap.gempty : htlh.
+Hint Resolve AssocMap.gso : htlh.
+Hint Resolve AssocMap.gss : htlh.
+Hint Resolve Ple_refl : htlh.
+Hint Resolve Ple_succ : htlh.
+
+Record state: Type := mkstate {
+ st_st : reg;
+ st_freshreg: reg;
+ st_freshstate: node;
+ st_scldecls: AssocMap.t (option io * scl_decl);
+ st_arrdecls: AssocMap.t (option io * arr_decl);
+ st_datapath: datapath;
+ st_controllogic: controllogic;
+}.
+
+Definition init_state (st : reg) : state :=
+ mkstate st
+ 1%positive
+ 1%positive
+ (AssocMap.empty (option io * scl_decl))
+ (AssocMap.empty (option io * arr_decl))
+ (AssocMap.empty datapath_stmnt)
+ (AssocMap.empty control_stmnt).
+
+Module HTLState <: State.
+
+ Definition st := state.
+
+ Inductive st_incr: state -> state -> Prop :=
+ state_incr_intro:
+ forall (s1 s2: state),
+ st_st s1 = st_st s2 ->
+ Ple s1.(st_freshreg) s2.(st_freshreg) ->
+ Ple s1.(st_freshstate) s2.(st_freshstate) ->
+ (forall n,
+ s1.(st_datapath)!n = None \/ s2.(st_datapath)!n = s1.(st_datapath)!n) ->
+ (forall n,
+ s1.(st_controllogic)!n = None
+ \/ s2.(st_controllogic)!n = s1.(st_controllogic)!n) ->
+ st_incr s1 s2.
+ Hint Constructors st_incr : htlh.
+
+ Definition st_prop := st_incr.
+ Hint Unfold st_prop : htlh.
+
+ Lemma st_refl : forall s, st_prop s s. Proof. auto with htlh. Qed.
+
+ Lemma st_trans :
+ forall s1 s2 s3, st_prop s1 s2 -> st_prop s2 s3 -> st_prop s1 s3.
+ Proof.
+ intros. inv H. inv H0. apply state_incr_intro; eauto using Ple_trans; intros; try congruence.
+ - destruct H4 with n; destruct H8 with n; intuition congruence.
+ - destruct H5 with n; destruct H9 with n; intuition congruence.
+ Qed.
+
+End HTLState.
+Export HTLState.
+
+Module HTLMonad := Statemonad(HTLState).
+Export HTLMonad.
+
+Module HTLMonadExtra := Monad.MonadExtra(HTLMonad).
+Import HTLMonadExtra.
+Export MonadNotation.
+
+Definition data_vstmnt : Verilog.stmnt -> HTL.datapath_stmnt := HTLDataVstmnt.
+Definition ctrl_vstmnt : Verilog.stmnt -> HTL.control_stmnt := HTLCtrlVstmnt.
+
+Definition state_goto (st : reg) (n : node) : control_stmnt :=
+ ctrl_vstmnt (Vnonblock (Vvar st) (Vlit (posToValue n))).
+
+Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : control_stmnt :=
+ ctrl_vstmnt (Vnonblock (Vvar st) (Vternary c (posToExpr n1) (posToExpr n2))).
+
+Definition nonblock (dst : reg) (e : expr) := (Vnonblock (Vvar dst) e).
+Definition block (dst : reg) (e : expr) := (Vblock (Vvar dst) e).
+
+Definition check_empty_node_datapath:
+ forall (s: state) (n: node), { s.(st_datapath)!n = None } + { True }.
+Proof.
+ intros. case (s.(st_datapath)!n); tauto.
+Defined.
+
+Definition check_empty_node_controllogic:
+ forall (s: state) (n: node), { s.(st_controllogic)!n = None } + { True }.
+Proof.
+ intros. case (s.(st_controllogic)!n); tauto.
+Defined.
+
+Lemma declare_reg_state_incr :
+ forall i s r sz,
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ s.(st_freshstate)
+ (AssocMap.set r (i, VScalar sz) s.(st_scldecls))
+ s.(st_arrdecls)
+ s.(st_datapath)
+ s.(st_controllogic)).
+Proof. auto with htlh. Qed.
+
+Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit :=
+ fun s => OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ s.(st_freshstate)
+ (AssocMap.set r (i, VScalar sz) s.(st_scldecls))
+ s.(st_arrdecls)
+ s.(st_datapath)
+ s.(st_controllogic))
+ (declare_reg_state_incr i s r sz).
+
+Lemma create_state_state_incr:
+ forall s,
+ st_incr s (mkstate
+ s.(st_st)
+ (st_freshreg s)
+ (Pos.succ (st_freshstate s))
+ (st_scldecls s)
+ (st_arrdecls s)
+ (st_datapath s)
+ (st_controllogic s)).
+Proof. constructor; simpl; auto with htlh. Qed.
+
+Definition create_state : mon node :=
+ fun s => let r := s.(st_freshstate) in
+ OK r (mkstate
+ s.(st_st)
+ (st_freshreg s)
+ (Pos.succ (st_freshstate s))
+ (st_scldecls s)
+ (st_arrdecls s)
+ (st_datapath s)
+ (st_controllogic s))
+ (create_state_state_incr s).
+
+Lemma add_instr_state_incr :
+ forall s n n' st,
+ (st_datapath s)!n = None ->
+ (st_controllogic s)!n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Definition add_instr (n : node) (n' : node) (st : datapath_stmnt) : mon unit :=
+ fun s =>
+ match check_empty_node_datapath s n, check_empty_node_controllogic s n with
+ | left STM, left TRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic)))
+ (add_instr_state_incr s n n' st STM TRANS)
+ | _, _ => Error (Errors.msg "HTL.add_instr")
+ end.
+
+Lemma add_instr_skip_state_incr :
+ forall s n st,
+ (st_datapath s)!n = None ->
+ (st_controllogic s)!n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (ctrl_vstmnt Vskip) s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Lemma add_instr_wait_state_incr :
+ forall wait_mod s n n' st,
+ (st_datapath s)!n = None ->
+ (st_controllogic s)!n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (HTLwait wait_mod s.(st_st) (Vlit (posToValue n'))) s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Definition add_instr_wait (wait_mod : ident) (n : node) (n' : node) (st : datapath_stmnt) : mon unit :=
+ fun s =>
+ match check_empty_node_datapath s n, check_empty_node_controllogic s n with
+ | left STM, left TRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (HTLwait wait_mod s.(st_st) (Vlit (posToValue n'))) s.(st_controllogic)))
+ (add_instr_wait_state_incr wait_mod s n n' st STM TRANS)
+ | _, _ => Error (Errors.msg "HTL.add_instr_wait")
+ end.
+
+Definition add_instr_skip (n : node) (st : datapath_stmnt) : mon unit :=
+ fun s =>
+ match check_empty_node_datapath s n, check_empty_node_controllogic s n with
+ | left STM, left TRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (ctrl_vstmnt Vskip) s.(st_controllogic)))
+ (add_instr_skip_state_incr s n st STM TRANS)
+ | _, _ => Error (Errors.msg "HTL.add_instr")
+ end.
+
+Lemma add_node_skip_state_incr :
+ forall s n st,
+ (st_datapath s)!n = None ->
+ (st_controllogic s)!n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n (data_vstmnt Vskip) s.(st_datapath))
+ (AssocMap.set n st s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Definition add_node_skip (n : node) (st : control_stmnt) : mon unit :=
+ fun s =>
+ match check_empty_node_datapath s n, check_empty_node_controllogic s n with
+ | left STM, left TRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n (data_vstmnt Vskip) s.(st_datapath))
+ (AssocMap.set n st s.(st_controllogic)))
+ (add_node_skip_state_incr s n st STM TRANS)
+ | _, _ => Error (Errors.msg "HTL.add_instr")
+ end.
+
+Definition bop (op : binop) (r1 r2 : reg) : expr :=
+ Vbinop op (Vvar r1) (Vvar r2).
+
+Definition boplit (op : binop) (r : reg) (l : Integers.int) : expr :=
+ Vbinop op (Vvar r) (Vlit (intToValue l)).
+
+Definition boplitz (op: binop) (r: reg) (l: Z) : expr :=
+ Vbinop op (Vvar r) (Vlit (ZToValue l)).
+
+Definition translate_comparison (c : Integers.comparison) (args : list reg) : mon expr :=
+ match c, args with
+ | Integers.Ceq, r1::r2::nil => ret (bop Veq r1 r2)
+ | Integers.Cne, r1::r2::nil => ret (bop Vne r1 r2)
+ | Integers.Clt, r1::r2::nil => ret (bop Vlt r1 r2)
+ | Integers.Cgt, r1::r2::nil => ret (bop Vgt r1 r2)
+ | Integers.Cle, r1::r2::nil => ret (bop Vle r1 r2)
+ | Integers.Cge, r1::r2::nil => ret (bop Vge r1 r2)
+ | _, _ => error (Errors.msg "Htlgen: comparison instruction not implemented: other")
+ end.
+
+Definition translate_comparison_imm (c : Integers.comparison) (args : list reg) (i: Integers.int)
+ : mon expr :=
+ match c, args with
+ | Integers.Ceq, r1::nil => ret (boplit Veq r1 i)
+ | Integers.Cne, r1::nil => ret (boplit Vne r1 i)
+ | Integers.Clt, r1::nil => ret (boplit Vlt r1 i)
+ | Integers.Cgt, r1::nil => ret (boplit Vgt r1 i)
+ | Integers.Cle, r1::nil => ret (boplit Vle r1 i)
+ | Integers.Cge, r1::nil => ret (boplit Vge r1 i)
+ | _, _ => error (Errors.msg "Htlgen: comparison_imm instruction not implemented: other")
+ end.
+
+Definition translate_comparisonu (c : Integers.comparison) (args : list reg) : mon expr :=
+ match c, args with
+ | Integers.Clt, r1::r2::nil => ret (bop Vltu r1 r2)
+ | Integers.Cgt, r1::r2::nil => ret (bop Vgtu r1 r2)
+ | Integers.Cle, r1::r2::nil => ret (bop Vleu r1 r2)
+ | Integers.Cge, r1::r2::nil => ret (bop Vgeu r1 r2)
+ | _, _ => error (Errors.msg "Htlgen: comparison instruction not implemented: other")
+ end.
+
+Definition translate_comparison_immu (c : Integers.comparison) (args : list reg) (i: Integers.int)
+ : mon expr :=
+ match c, args with
+ | Integers.Clt, r1::nil => ret (boplit Vltu r1 i)
+ | Integers.Cgt, r1::nil => ret (boplit Vgtu r1 i)
+ | Integers.Cle, r1::nil => ret (boplit Vleu r1 i)
+ | Integers.Cge, r1::nil => ret (boplit Vgeu r1 i)
+ | _, _ => error (Errors.msg "Htlgen: comparison_imm instruction not implemented: other")
+ end.
+
+Definition translate_condition (c : Op.condition) (args : list reg) : mon expr :=
+ match c, args with
+ | Op.Ccomp c, _ => translate_comparison c args
+ | Op.Ccompu c, _ => translate_comparisonu c args
+ | Op.Ccompimm c i, _ => translate_comparison_imm c args i
+ | Op.Ccompuimm c i, _ => translate_comparison_immu c args i
+ | Op.Cmaskzero n, _ => error (Errors.msg "Htlgen: condition instruction not implemented: Cmaskzero")
+ | Op.Cmasknotzero n, _ => error (Errors.msg "Htlgen: condition instruction not implemented: Cmasknotzero")
+ | _, _ => error (Errors.msg "Htlgen: condition instruction not implemented: other")
+ end.
+
+Definition check_address_parameter_signed (p : Z) : bool :=
+ Z.leb Integers.Ptrofs.min_signed p
+ && Z.leb p Integers.Ptrofs.max_signed.
+
+Definition check_address_parameter_unsigned (p : Z) : bool :=
+ Z.leb p Integers.Ptrofs.max_unsigned.
+
+Definition translate_eff_addressing (a: Op.addressing) (args: list reg) : mon expr :=
+ match a, args with (* TODO: We should be more methodical here; what are the possibilities?*)
+ | Op.Aindexed off, r1::nil =>
+ if (check_address_parameter_signed off)
+ then ret (boplitz Vadd r1 off)
+ else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed): address out of bounds")
+ | Op.Ascaled scale offset, r1::nil =>
+ if (check_address_parameter_signed scale) && (check_address_parameter_signed offset)
+ then ret (Vbinop Vadd (boplitz Vmul r1 scale) (Vlit (ZToValue offset)))
+ else error (Errors.msg "Veriloggen: translate_eff_addressing (Ascaled): address out of bounds")
+ | Op.Aindexed2 offset, r1::r2::nil =>
+ if (check_address_parameter_signed offset)
+ then ret (Vbinop Vadd (bop Vadd r1 r2) (Vlit (ZToValue offset)))
+ else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed2): address out of bounds")
+ | Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *)
+ if (check_address_parameter_signed scale) && (check_address_parameter_signed offset)
+ then ret (Vbinop Vadd (Vvar r1) (Vbinop Vadd (boplitz Vmul r2 scale) (Vlit (ZToValue offset))))
+ else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed2scaled): address out of bounds")
+ | Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *)
+ let a := Integers.Ptrofs.unsigned a in
+ if (check_address_parameter_unsigned a)
+ then ret (Vlit (ZToValue a))
+ else error (Errors.msg "Veriloggen: translate_eff_addressing (Ainstack): address out of bounds")
+ | _, _ => error (Errors.msg "Veriloggen: translate_eff_addressing unsuported addressing")
+ end.
+
+(** Translate an instruction to a statement. FIX mulhs mulhu *)
+Definition translate_instr (op : Op.operation) (args : list reg) : mon expr :=
+ match op, args with
+ | Op.Omove, r::nil => ret (Vvar r)
+ | Op.Ointconst n, _ => ret (Vlit (intToValue n))
+ | Op.Oneg, r::nil => ret (Vunop Vneg (Vvar r))
+ | Op.Osub, r1::r2::nil => ret (bop Vsub r1 r2)
+ | Op.Omul, r1::r2::nil => ret (bop Vmul r1 r2)
+ | Op.Omulimm n, r::nil => ret (boplit Vmul r n)
+ | Op.Omulhs, r1::r2::nil => error (Errors.msg "Htlgen: Instruction not implemented: mulhs")
+ | Op.Omulhu, r1::r2::nil => error (Errors.msg "Htlgen: Instruction not implemented: mulhu")
+ | Op.Odiv, r1::r2::nil => ret (bop Vdiv r1 r2)
+ | Op.Odivu, r1::r2::nil => ret (bop Vdivu r1 r2)
+ | Op.Omod, r1::r2::nil => ret (bop Vmod r1 r2)
+ | Op.Omodu, r1::r2::nil => ret (bop Vmodu r1 r2)
+ | Op.Oand, r1::r2::nil => ret (bop Vand r1 r2)
+ | Op.Oandimm n, r::nil => ret (boplit Vand r n)
+ | Op.Oor, r1::r2::nil => ret (bop Vor r1 r2)
+ | Op.Oorimm n, r::nil => ret (boplit Vor r n)
+ | Op.Oxor, r1::r2::nil => ret (bop Vxor r1 r2)
+ | Op.Oxorimm n, r::nil => ret (boplit Vxor r n)
+ | Op.Onot, r::nil => ret (Vunop Vnot (Vvar r))
+ | Op.Oshl, r1::r2::nil => ret (bop Vshl r1 r2)
+ | Op.Oshlimm n, r::nil => ret (boplit Vshl r n)
+ | Op.Oshr, r1::r2::nil => ret (bop Vshr r1 r2)
+ | Op.Oshrimm n, r::nil => ret (boplit Vshr r n)
+ | Op.Oshrximm n, r::nil => error (Errors.msg "Htlgen: Instruction not implemented: Oshrximm")
+ (*ret (Vbinop Vdiv (Vvar r)
+ (Vbinop Vshl (Vlit (ZToValue 1))
+ (Vlit (intToValue n))))*)
+ | Op.Oshru, r1::r2::nil => ret (bop Vshru r1 r2)
+ | Op.Oshruimm n, r::nil => ret (boplit Vshru r n)
+ | Op.Ororimm n, r::nil => error (Errors.msg "Htlgen: Instruction not implemented: Ororimm")
+ (*ret (Vbinop Vor (boplit Vshru r (Integers.Int.modu n (Integers.Int.repr 32)))
+ (boplit Vshl r (Integers.Int.sub (Integers.Int.repr 32) (Integers.Int.modu n (Integers.Int.repr 32)))))*)
+ | Op.Oshldimm n, r::nil => ret (Vbinop Vor (boplit Vshl r n) (boplit Vshr r (Integers.Int.sub (Integers.Int.repr 32) n)))
+ | Op.Ocmp c, _ => translate_condition c args
+ | Op.Osel c AST.Tint, r1::r2::rl =>
+ do tc <- translate_condition c rl;
+ ret (Vternary tc (Vvar r1) (Vvar r2))
+ | Op.Olea a, _ => translate_eff_addressing a args
+ | _, _ => error (Errors.msg "Htlgen: Instruction not implemented: other")
+ end.
+
+Lemma add_branch_instr_state_incr:
+ forall s e n n1 n2,
+ (st_datapath s) ! n = None ->
+ (st_controllogic s) ! n = None ->
+ st_incr s (mkstate
+ s.(st_st)
+ (st_freshreg s)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n (data_vstmnt Vskip) (st_datapath s))
+ (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))).
+Proof.
+ intros. apply state_incr_intro; simpl;
+ try (intros; destruct (peq n0 n); subst);
+ auto with htlh.
+Qed.
+
+Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit :=
+ fun s =>
+ match check_empty_node_datapath s n, check_empty_node_controllogic s n with
+ | left NSTM, left NTRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ (st_freshreg s)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n (data_vstmnt Vskip) (st_datapath s))
+ (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s)))
+ (add_branch_instr_state_incr s e n n1 n2 NSTM NTRANS)
+ | _, _ => Error (Errors.msg "Htlgen: add_branch_instr")
+ end.
+
+Definition translate_arr_access (mem : AST.memory_chunk) (addr : Op.addressing)
+ (args : list reg) (stack : reg) : mon expr :=
+ match mem, addr, args with (* TODO: We should be more methodical here; what are the possibilities?*)
+ | Mint32, Op.Aindexed off, r1::nil =>
+ if (check_address_parameter_signed off)
+ then ret (Vvari stack (Vbinop Vdivu (boplitz Vadd r1 off) (Vlit (ZToValue 4))))
+ else error (Errors.msg "HTLgen: translate_arr_access address out of bounds")
+ | Mint32, Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *)
+ if (check_address_parameter_signed scale) && (check_address_parameter_signed offset)
+ then ret (Vvari stack
+ (Vbinop Vdivu
+ (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale))
+ (Vlit (ZToValue 4))))
+ else error (Errors.msg "HTLgen: translate_arr_access address out of bounds")
+ | Mint32, Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *)
+ let a := Integers.Ptrofs.unsigned a in
+ if (check_address_parameter_unsigned a)
+ then ret (Vvari stack (Vlit (ZToValue (a / 4))))
+ else error (Errors.msg "HTLgen: eff_addressing out of bounds stack offset")
+ | _, _, _ => error (Errors.msg "HTLgen: translate_arr_access unsuported addressing")
+ end.
+
+Fixpoint enumerate (i : nat) (ns : list node) {struct ns} : list (nat * node) :=
+ match ns with
+ | n :: ns' => (i, n) :: enumerate (i+1) ns'
+ | nil => nil
+ end.
+
+Definition tbl_to_case_expr (st : reg) (ns : list node) : list (expr * stmnt) :=
+ List.map (fun a => match a with
+ (i, n) => (Vlit (natToValue i), Vnonblock (Vvar st) (Vlit (posToValue n)))
+ end)
+ (enumerate 0 ns).
+
+Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon unit :=
+ match ni with
+ (n, i) =>
+ match i with
+ | Inop n' =>
+ if Z.leb (Z.pos n') Integers.Int.max_unsigned then
+ add_instr n n' (data_vstmnt Vskip)
+ else error (Errors.msg "State is larger than 2^32.")
+ | Iop op args dst n' =>
+ if Z.leb (Z.pos n') Integers.Int.max_unsigned then
+ do instr <- translate_instr op args;
+ do _ <- declare_reg None dst 32;
+ add_instr n n' (data_vstmnt (nonblock dst instr))
+ else error (Errors.msg "State is larger than 2^32.")
+ | Iload mem addr args dst n' =>
+ if Z.leb (Z.pos n') Integers.Int.max_unsigned then
+ do src <- translate_arr_access mem addr args stack;
+ do _ <- declare_reg None dst 32;
+ add_instr n n' (data_vstmnt (nonblock dst src))
+ else error (Errors.msg "State is larger than 2^32.")
+ | Istore mem addr args src n' =>
+ if Z.leb (Z.pos n') Integers.Int.max_unsigned then
+ do dst <- translate_arr_access mem addr args stack;
+ add_instr n n' (data_vstmnt (Vnonblock dst (Vvar src))) (* TODO: Could juse use add_instr? reg exists. *)
+ else error (Errors.msg "State is larger than 2^32.")
+ | Icall sig (inl fn) args dst n' => error (Errors.msg "Indirect calls are not implemented.")
+ | Icall sig (inr fn) args dst n' =>
+ if Z.leb (Z.pos n') Integers.Int.max_unsigned then
+ do _ <- declare_reg None dst 32;
+ do join_state <- create_state;
+ do _ <- add_instr n join_state (HTLfork fn args);
+ add_instr_wait fn join_state n' (HTLjoin fn dst)
+ else error (Errors.msg "State is larger than 2^32.")
+ | Itailcall _ _ _ => error (Errors.msg "Tailcalls are not implemented.")
+ | Ibuiltin _ _ _ _ => error (Errors.msg "Builtin functions not implemented.")
+ | Icond cond args n1 n2 =>
+ if Z.leb (Z.pos n1) Integers.Int.max_unsigned && Z.leb (Z.pos n2) Integers.Int.max_unsigned then
+ do e <- translate_condition cond args;
+ add_branch_instr e n n1 n2
+ else error (Errors.msg "State is larger than 2^32.")
+ | Ijumptable r tbl =>
+ (*do s <- get;
+ add_node_skip n (Vcase (Vvar r) (tbl_to_case_expr s.(st_st) tbl) (Some Vskip))*)
+ error (Errors.msg "Ijumptable: Case statement not supported.")
+ | Ireturn r =>
+ match r with
+ | Some r' =>
+ add_instr_skip n (data_vstmnt (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r'))))
+ | None =>
+ add_instr_skip n (data_vstmnt (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z)))))
+ end
+ end
+ end.
+
+Lemma create_reg_state_incr:
+ forall s sz i,
+ st_incr s (mkstate
+ s.(st_st)
+ (Pos.succ (st_freshreg s))
+ (st_freshstate s)
+ (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls))
+ s.(st_arrdecls)
+ (st_datapath s)
+ (st_controllogic s)).
+Proof. constructor; simpl; auto with htlh. Qed.
+
+Definition create_reg (i : option io) (sz : nat) : mon reg :=
+ fun s => let r := s.(st_freshreg) in
+ OK r (mkstate
+ s.(st_st)
+ (Pos.succ r)
+ (st_freshstate s)
+ (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls))
+ (st_arrdecls s)
+ (st_datapath s)
+ (st_controllogic s))
+ (create_reg_state_incr s sz i).
+
+Lemma create_arr_state_incr:
+ forall s sz ln i,
+ st_incr s (mkstate
+ s.(st_st)
+ (Pos.succ (st_freshreg s))
+ (st_freshstate s)
+ s.(st_scldecls)
+ (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls))
+ (st_datapath s)
+ (st_controllogic s)).
+Proof. constructor; simpl; auto with htlh. Qed.
+
+Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) :=
+ fun s => let r := s.(st_freshreg) in
+ OK (r, ln) (mkstate
+ s.(st_st)
+ (Pos.succ r)
+ (st_freshstate s)
+ s.(st_scldecls)
+ (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls))
+ (st_datapath s)
+ (st_controllogic s))
+ (create_arr_state_incr s sz ln i).
+
+Definition stack_correct (sz : Z) : bool :=
+ (0 <=? sz) && (sz <? Integers.Ptrofs.modulus) && (Z.modulo sz 4 =? 0).
+
+Definition max_pc_map {A: Type} (m : Maps.PTree.t A) :=
+ PTree.fold (fun m pc i => Pos.max m pc) m 1%positive.
+
+Lemma max_pc_map_sound:
+ forall A m pc i, m!pc = Some i -> Ple pc (@max_pc_map A m).
+Proof.
+ intros until i. unfold max_pc_function.
+ apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m).
+ (* extensionality *)
+ intros. apply H0. rewrite H; auto.
+ (* base case *)
+ rewrite PTree.gempty. congruence.
+ (* inductive case *)
+ intros. rewrite PTree.gsspec in H2. destruct (peq pc k).
+ inv H2. xomega.
+ apply Ple_trans with a. auto. xomega.
+Qed.
+
+Lemma max_pc_wf :
+ forall T m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned ->
+ @map_well_formed T m.
+Proof.
+ unfold map_well_formed. intros.
+ exploit list_in_map_inv. eassumption. intros [x [A B]]. destruct x.
+ apply Maps.PTree.elements_complete in B. apply max_pc_map_sound in B.
+ unfold Ple in B. apply Pos2Z.pos_le_pos in B. subst.
+ simplify. transitivity (Z.pos (max_pc_map m)); eauto.
+Qed.
+
+Definition transf_module (f: function) : mon module :=
+ if stack_correct f.(fn_stacksize) then
+ do fin <- create_reg (Some Voutput) 1;
+ do rtrn <- create_reg (Some Voutput) 32;
+ do (stack, stack_len) <- create_arr None 32 (Z.to_nat (f.(fn_stacksize) / 4));
+ do _ <- collectlist (transf_instr fin rtrn stack) (Maps.PTree.elements f.(RTL.fn_code));
+ do _ <- collectlist (fun r => declare_reg (Some Vinput) r 32) f.(RTL.fn_params);
+ do start <- create_reg (Some Vinput) 1;
+ do rst <- create_reg (Some Vinput) 1;
+ do clk <- create_reg (Some Vinput) 1;
+ do current_state <- get;
+ match zle (Z.pos (max_pc_map current_state.(st_datapath))) Integers.Int.max_unsigned,
+ zle (Z.pos (max_pc_map current_state.(st_controllogic))) Integers.Int.max_unsigned with
+ | left LEDATA, left LECTRL =>
+ ret (mkmodule
+ f.(RTL.fn_params)
+ current_state.(st_datapath)
+ current_state.(st_controllogic)
+ f.(fn_entrypoint)
+ current_state.(st_st)
+ stack
+ stack_len
+ fin
+ rtrn
+ start
+ rst
+ clk
+ current_state.(st_scldecls)
+ current_state.(st_arrdecls)
+ (conj (max_pc_wf _ _ LECTRL) (max_pc_wf _ _ LEDATA)))
+ | _, _ => error (Errors.msg "More than 2^32 states.")
+ end
+ else error (Errors.msg "Stack size misalignment.").
+
+Definition max_state (f: function) : state :=
+ let st := Pos.succ (max_reg_function f) in
+ mkstate st
+ (Pos.succ st)
+ (Pos.succ (max_pc_function f))
+ (AssocMap.set st (None, VScalar 32) (st_scldecls (init_state st)))
+ (st_arrdecls (init_state st))
+ (st_datapath (init_state st))
+ (st_controllogic (init_state st)).
+
+Definition transl_module (f : function) : Errors.res module :=
+ run_mon (max_state f) (transf_module f).
+
+Definition transl_fundef := transf_partial_fundef transl_module.
+
+(* Definition transl_program (p : RTL.program) := transform_partial_program transl_fundef p. *)
+
+(*Definition transl_main_fundef f : Errors.res HTL.fundef :=
+ match f with
+ | Internal f => transl_fundef (Internal f)
+ | External f => Errors.Error (Errors.msg "Could not find internal main function")
+ end.
+
+(** Translation of a whole program. *)
+
+Definition transl_program (p: RTL.program) : Errors.res HTL.program :=
+ transform_partial_program2 (fun i f => if Pos.eqb p.(AST.prog_main) i
+ then transl_fundef f
+ else transl_main_fundef f)
+ (fun i v => Errors.OK v) p.
+*)
+
+Definition main_is_internal (p : RTLBlock.program) : bool :=
+ let ge := Globalenvs.Genv.globalenv p in
+ match Globalenvs.Genv.find_symbol ge p.(AST.prog_main) with
+ | Some b =>
+ match Globalenvs.Genv.find_funct_ptr ge b with
+ | Some (AST.Internal _) => true
+ | _ => false
+ end
+ | _ => false
+ end.
+
+Definition transl_program (p : RTLBlock.program) : Errors.res HTL.program :=
+ if main_is_internal p
+ then transform_partial_program transl_fundef p
+ else Errors.Error (Errors.msg "Main function is not Internal.").
+*)
diff --git a/src/hls/HTLPargen.v b/src/hls/HTLPargen.v
new file mode 100644
index 0000000..fcd4441
--- /dev/null
+++ b/src/hls/HTLPargen.v
@@ -0,0 +1,855 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import Coq.micromega.Lia.
+
+Require Import compcert.common.AST.
+Require compcert.common.Errors.
+Require compcert.common.Globalenvs.
+Require compcert.lib.Integers.
+Require Import compcert.lib.Maps.
+
+Require Import vericert.common.Statemonad.
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.AssocMap.
+Require Import vericert.hls.HTL.
+Require Import vericert.hls.RTLBlockInstr.
+Require Import vericert.hls.RTLPar.
+Require Import vericert.hls.ValueInt.
+Require Import vericert.hls.Verilog.
+
+Hint Resolve AssocMap.gempty : htlh.
+Hint Resolve AssocMap.gso : htlh.
+Hint Resolve AssocMap.gss : htlh.
+Hint Resolve Ple_refl : htlh.
+Hint Resolve Ple_succ : htlh.
+
+Record state: Type := mkstate {
+ st_st: reg;
+ st_freshreg: reg;
+ st_freshstate: node;
+ st_scldecls: AssocMap.t (option io * scl_decl);
+ st_arrdecls: AssocMap.t (option io * arr_decl);
+ st_datapath: datapath;
+ st_controllogic: controllogic;
+}.
+
+Definition init_state (st : reg) : state :=
+ mkstate st
+ 1%positive
+ 1%positive
+ (AssocMap.empty (option io * scl_decl))
+ (AssocMap.empty (option io * arr_decl))
+ (AssocMap.empty stmnt)
+ (AssocMap.empty stmnt).
+
+Module HTLState <: State.
+
+ Definition st := state.
+
+ Inductive st_incr: state -> state -> Prop :=
+ state_incr_intro:
+ forall (s1 s2: state),
+ st_st s1 = st_st s2 ->
+ Ple s1.(st_freshreg) s2.(st_freshreg) ->
+ Ple s1.(st_freshstate) s2.(st_freshstate) ->
+ (forall n,
+ s1.(st_controllogic)!n = None
+ \/ s2.(st_controllogic)!n = s1.(st_controllogic)!n) ->
+ st_incr s1 s2.
+ Hint Constructors st_incr : htlh.
+
+ Definition st_prop := st_incr.
+ Hint Unfold st_prop : htlh.
+
+ Lemma st_refl : forall s, st_prop s s.
+ Proof. auto with htlh. Qed.
+
+ Lemma st_trans :
+ forall s1 s2 s3, st_prop s1 s2 -> st_prop s2 s3 -> st_prop s1 s3.
+ Proof.
+ intros. inv H. inv H0.
+ apply state_incr_intro; eauto using Ple_trans; intros; try congruence.
+ destruct H4 with n; destruct H7 with n; intuition congruence.
+ Qed.
+
+End HTLState.
+Export HTLState.
+
+Module HTLMonad := Statemonad(HTLState).
+Export HTLMonad.
+
+Module HTLMonadExtra := Monad.MonadExtra(HTLMonad).
+Import HTLMonadExtra.
+Export MonadNotation.
+
+Definition state_goto (st : reg) (n : node) : stmnt :=
+ Vnonblock (Vvar st) (Vlit (posToValue n)).
+
+Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : stmnt :=
+ Vnonblock (Vvar st) (Vternary c (posToExpr n1) (posToExpr n2)).
+
+Definition check_empty_node_datapath:
+ forall (s: state) (n: node), { s.(st_datapath)!n = None } + { True }.
+Proof.
+ intros. case (s.(st_datapath)!n); tauto.
+Defined.
+
+Definition check_empty_node_controllogic:
+ forall (s: state) (n: node), { s.(st_controllogic)!n = None } + { True }.
+Proof.
+ intros. case (s.(st_controllogic)!n); tauto.
+Defined.
+
+Lemma declare_reg_state_incr :
+ forall i s r sz,
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ s.(st_freshstate)
+ (AssocMap.set r (i, VScalar sz) s.(st_scldecls))
+ s.(st_arrdecls)
+ s.(st_datapath)
+ s.(st_controllogic)).
+Proof. auto with htlh. Qed.
+
+Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit :=
+ fun s => OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ s.(st_freshstate)
+ (AssocMap.set r (i, VScalar sz) s.(st_scldecls))
+ s.(st_arrdecls)
+ s.(st_datapath)
+ s.(st_controllogic))
+ (declare_reg_state_incr i s r sz).
+
+Lemma add_instr_state_incr :
+ forall s n n' st,
+ (st_controllogic s)!n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Definition add_instr (n : node) (n' : node) (st : stmnt) : mon unit :=
+ fun s =>
+ match check_empty_node_controllogic s n with
+ | left TRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic)))
+ (add_instr_state_incr s n n' st TRANS)
+ | _ => Error (Errors.msg "HTL.add_instr")
+ end.
+
+Lemma add_instr_skip_state_incr :
+ forall s n st,
+ (st_controllogic s)!n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n Vskip s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Definition add_instr_skip (n : node) (st : stmnt) : mon unit :=
+ fun s =>
+ match check_empty_node_controllogic s n with
+ | left TRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n Vskip s.(st_controllogic)))
+ (add_instr_skip_state_incr s n st TRANS)
+ | _ => Error (Errors.msg "HTL.add_instr_skip")
+ end.
+
+Lemma add_node_skip_state_incr :
+ forall s n st,
+ (st_controllogic s)!n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n Vskip s.(st_datapath))
+ (AssocMap.set n st s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Definition add_node_skip (n : node) (st : stmnt) : mon unit :=
+ fun s =>
+ match check_empty_node_controllogic s n with
+ | left TRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n Vskip s.(st_datapath))
+ (AssocMap.set n st s.(st_controllogic)))
+ (add_node_skip_state_incr s n st TRANS)
+ | _ => Error (Errors.msg "HTL.add_node_skip")
+ end.
+
+Definition nonblock (dst : reg) (e : expr) := Vnonblock (Vvar dst) e.
+Definition block (dst : reg) (e : expr) := Vblock (Vvar dst) e.
+
+Definition bop (op : binop) (r1 r2 : reg) : expr :=
+ Vbinop op (Vvar r1) (Vvar r2).
+
+Definition boplit (op : binop) (r : reg) (l : Integers.int) : expr :=
+ Vbinop op (Vvar r) (Vlit (intToValue l)).
+
+Definition boplitz (op: binop) (r: reg) (l: Z) : expr :=
+ Vbinop op (Vvar r) (Vlit (ZToValue l)).
+
+Definition translate_comparison (c : Integers.comparison) (args : list reg)
+ : mon expr :=
+ match c, args with
+ | Integers.Ceq, r1::r2::nil => ret (bop Veq r1 r2)
+ | Integers.Cne, r1::r2::nil => ret (bop Vne r1 r2)
+ | Integers.Clt, r1::r2::nil => ret (bop Vlt r1 r2)
+ | Integers.Cgt, r1::r2::nil => ret (bop Vgt r1 r2)
+ | Integers.Cle, r1::r2::nil => ret (bop Vle r1 r2)
+ | Integers.Cge, r1::r2::nil => ret (bop Vge r1 r2)
+ | _, _ => error (Errors.msg
+ "Htlgen: comparison instruction not implemented: other")
+ end.
+
+Definition translate_comparison_imm (c : Integers.comparison) (args : list reg)
+ (i: Integers.int) : mon expr :=
+ match c, args with
+ | Integers.Ceq, r1::nil => ret (boplit Veq r1 i)
+ | Integers.Cne, r1::nil => ret (boplit Vne r1 i)
+ | Integers.Clt, r1::nil => ret (boplit Vlt r1 i)
+ | Integers.Cgt, r1::nil => ret (boplit Vgt r1 i)
+ | Integers.Cle, r1::nil => ret (boplit Vle r1 i)
+ | Integers.Cge, r1::nil => ret (boplit Vge r1 i)
+ | _, _ => error (Errors.msg
+ "Htlgen: comparison_imm instruction not implemented: other")
+ end.
+
+Definition translate_comparisonu (c : Integers.comparison) (args : list reg)
+ : mon expr :=
+ match c, args with
+ | Integers.Clt, r1::r2::nil => ret (bop Vltu r1 r2)
+ | Integers.Cgt, r1::r2::nil => ret (bop Vgtu r1 r2)
+ | Integers.Cle, r1::r2::nil => ret (bop Vleu r1 r2)
+ | Integers.Cge, r1::r2::nil => ret (bop Vgeu r1 r2)
+ | _, _ => error (Errors.msg
+ "Htlgen: comparison instruction not implemented: other")
+ end.
+
+Definition translate_comparison_immu (c : Integers.comparison)
+ (args : list reg) (i: Integers.int) : mon expr :=
+ match c, args with
+ | Integers.Clt, r1::nil => ret (boplit Vltu r1 i)
+ | Integers.Cgt, r1::nil => ret (boplit Vgtu r1 i)
+ | Integers.Cle, r1::nil => ret (boplit Vleu r1 i)
+ | Integers.Cge, r1::nil => ret (boplit Vgeu r1 i)
+ | _, _ => error (Errors.msg
+ "Htlgen: comparison_imm instruction not implemented: other")
+ end.
+
+Definition translate_condition (c : Op.condition) (args : list reg)
+ : mon expr :=
+ match c, args with
+ | Op.Ccomp c, _ => translate_comparison c args
+ | Op.Ccompu c, _ => translate_comparisonu c args
+ | Op.Ccompimm c i, _ => translate_comparison_imm c args i
+ | Op.Ccompuimm c i, _ => translate_comparison_immu c args i
+ | Op.Cmaskzero n, _ =>
+ error (Errors.msg "Htlgen: condition instruction not implemented: Cmaskzero")
+ | Op.Cmasknotzero n, _ =>
+ error (Errors.msg
+ "Htlgen: condition instruction not implemented: Cmasknotzero")
+ | _, _ =>
+ error (Errors.msg "Htlgen: condition instruction not implemented: other")
+ end.
+
+Definition check_address_parameter_signed (p : Z) : bool :=
+ Z.leb Integers.Ptrofs.min_signed p
+ && Z.leb p Integers.Ptrofs.max_signed.
+
+Definition check_address_parameter_unsigned (p : Z) : bool :=
+ Z.leb p Integers.Ptrofs.max_unsigned.
+
+Definition translate_eff_addressing (a: Op.addressing) (args: list reg)
+ : mon expr :=
+ match a, args with (* TODO: We should be more methodical here; what are the possibilities?*)
+ | Op.Aindexed off, r1::nil =>
+ if (check_address_parameter_signed off)
+ then ret (boplitz Vadd r1 off)
+ else error (Errors.msg ("HTLPargen: translate_eff_addressing (Aindexed): address out of bounds"))
+ | Op.Ascaled scale offset, r1::nil =>
+ if (check_address_parameter_signed scale) && (check_address_parameter_signed offset)
+ then ret (Vbinop Vadd (boplitz Vmul r1 scale) (Vlit (ZToValue offset)))
+ else error (Errors.msg "HTLPargen: translate_eff_addressing (Ascaled): address out of bounds")
+ | Op.Aindexed2 offset, r1::r2::nil =>
+ if (check_address_parameter_signed offset)
+ then ret (Vbinop Vadd (bop Vadd r1 r2) (Vlit (ZToValue offset)))
+ else error (Errors.msg "HTLPargen: translate_eff_addressing (Aindexed2): address out of bounds")
+ | Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *)
+ if (check_address_parameter_signed scale) && (check_address_parameter_signed offset)
+ then ret (Vbinop Vadd (Vvar r1) (Vbinop Vadd (boplitz Vmul r2 scale) (Vlit (ZToValue offset))))
+ else error (Errors.msg "HTLPargen: translate_eff_addressing (Aindexed2scaled): address out of bounds")
+ | Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *)
+ let a := Integers.Ptrofs.unsigned a in
+ if (check_address_parameter_unsigned a)
+ then ret (Vlit (ZToValue a))
+ else error (Errors.msg "HTLPargen: translate_eff_addressing (Ainstack): address out of bounds")
+ | _, _ => error (Errors.msg "HTLPargen: translate_eff_addressing unsuported addressing")
+ end.
+
+(** Translate an instruction to a statement. FIX mulhs mulhu *)
+Definition translate_instr (op : Op.operation) (args : list reg) : mon expr :=
+ match op, args with
+ | Op.Omove, r::nil => ret (Vvar r)
+ | Op.Ointconst n, _ => ret (Vlit (intToValue n))
+ | Op.Oneg, r::nil => ret (Vunop Vneg (Vvar r))
+ | Op.Osub, r1::r2::nil => ret (bop Vsub r1 r2)
+ | Op.Omul, r1::r2::nil => ret (bop Vmul r1 r2)
+ | Op.Omulimm n, r::nil => ret (boplit Vmul r n)
+ | Op.Omulhs, r1::r2::nil => error (Errors.msg "Htlgen: Instruction not implemented: mulhs")
+ | Op.Omulhu, r1::r2::nil => error (Errors.msg "Htlgen: Instruction not implemented: mulhu")
+ | Op.Odiv, r1::r2::nil => ret (bop Vdiv r1 r2)
+ | Op.Odivu, r1::r2::nil => ret (bop Vdivu r1 r2)
+ | Op.Omod, r1::r2::nil => ret (bop Vmod r1 r2)
+ | Op.Omodu, r1::r2::nil => ret (bop Vmodu r1 r2)
+ | Op.Oand, r1::r2::nil => ret (bop Vand r1 r2)
+ | Op.Oandimm n, r::nil => ret (boplit Vand r n)
+ | Op.Oor, r1::r2::nil => ret (bop Vor r1 r2)
+ | Op.Oorimm n, r::nil => ret (boplit Vor r n)
+ | Op.Oxor, r1::r2::nil => ret (bop Vxor r1 r2)
+ | Op.Oxorimm n, r::nil => ret (boplit Vxor r n)
+ | Op.Onot, r::nil => ret (Vunop Vnot (Vvar r))
+ | Op.Oshl, r1::r2::nil => ret (bop Vshl r1 r2)
+ | Op.Oshlimm n, r::nil => ret (boplit Vshl r n)
+ | Op.Oshr, r1::r2::nil => ret (bop Vshr r1 r2)
+ | Op.Oshrimm n, r::nil => ret (boplit Vshr r n)
+ | Op.Oshrximm n, r::nil =>
+ ret (Vternary (Vbinop Vlt (Vvar r) (Vlit (ZToValue 0)))
+ (Vunop Vneg (Vbinop Vshru (Vunop Vneg (Vvar r)) (Vlit n)))
+ (Vbinop Vshru (Vvar r) (Vlit n)))
+ | Op.Oshru, r1::r2::nil => ret (bop Vshru r1 r2)
+ | Op.Oshruimm n, r::nil => ret (boplit Vshru r n)
+ | Op.Ororimm n, r::nil => error (Errors.msg "Htlgen: Instruction not implemented: Ororimm")
+ (*ret (Vbinop Vor (boplit Vshru r (Integers.Int.modu n (Integers.Int.repr 32)))
+ (boplit Vshl r (Integers.Int.sub (Integers.Int.repr 32) (Integers.Int.modu n (Integers.Int.repr 32)))))*)
+ | Op.Oshldimm n, r::nil => ret (Vbinop Vor (boplit Vshl r n) (boplit Vshr r (Integers.Int.sub (Integers.Int.repr 32) n)))
+ | Op.Ocmp c, _ => translate_condition c args
+ | Op.Osel c AST.Tint, r1::r2::rl =>
+ do tc <- translate_condition c rl;
+ ret (Vternary tc (Vvar r1) (Vvar r2))
+ | Op.Olea a, _ => translate_eff_addressing a args
+ | _, _ => error (Errors.msg "Htlgen: Instruction not implemented: other")
+ end.
+
+Lemma add_branch_instr_state_incr:
+ forall s e n n1 n2,
+ (st_controllogic s) ! n = None ->
+ st_incr s (mkstate
+ s.(st_st)
+ (st_freshreg s)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n Vskip (st_datapath s))
+ (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))).
+Proof.
+ intros. apply state_incr_intro; simpl;
+ try (intros; destruct (peq n0 n); subst);
+ auto with htlh.
+Qed.
+
+Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit :=
+ fun s =>
+ match check_empty_node_controllogic s n with
+ | left NTRANS =>
+ OK tt (mkstate
+ s.(st_st)
+ (st_freshreg s)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n Vskip (st_datapath s))
+ (AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s)))
+ (add_branch_instr_state_incr s e n n1 n2 NTRANS)
+ | _ => Error (Errors.msg "Htlgen: add_branch_instr")
+ end.
+
+Definition translate_arr_access (mem : AST.memory_chunk) (addr : Op.addressing)
+ (args : list reg) (stack : reg) : mon expr :=
+ match mem, addr, args with (* TODO: We should be more methodical here; what are the possibilities?*)
+ | Mint32, Op.Aindexed off, r1::nil =>
+ if (check_address_parameter_signed off)
+ then ret (Vvari stack (Vbinop Vdivu (boplitz Vadd r1 off) (Vlit (ZToValue 4))))
+ else error (Errors.msg "HTLgen: translate_arr_access address out of bounds")
+ | Mint32, Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *)
+ if (check_address_parameter_signed scale) && (check_address_parameter_signed offset)
+ then ret (Vvari stack
+ (Vbinop Vdivu
+ (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale))
+ (Vlit (ZToValue 4))))
+ else error (Errors.msg "HTLgen: translate_arr_access address out of bounds")
+ | Mint32, Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *)
+ let a := Integers.Ptrofs.unsigned a in
+ if (check_address_parameter_unsigned a)
+ then ret (Vvari stack (Vlit (ZToValue (a / 4))))
+ else error (Errors.msg "HTLgen: eff_addressing out of bounds stack offset")
+ | _, _, _ => error (Errors.msg "HTLgen: translate_arr_access unsuported addressing")
+ end.
+
+Fixpoint enumerate (i : nat) (ns : list node) {struct ns} : list (nat * node) :=
+ match ns with
+ | n :: ns' => (i, n) :: enumerate (i+1) ns'
+ | nil => nil
+ end.
+
+Definition tbl_to_case_expr (st : reg) (ns : list node) : list (expr * stmnt) :=
+ List.map (fun a => match a with
+ (i, n) => (Vlit (natToValue i), Vnonblock (Vvar st) (Vlit (posToValue n)))
+ end)
+ (enumerate 0 ns).
+
+Definition stack_correct (sz : Z) : bool :=
+ (0 <=? sz) && (sz <? Integers.Ptrofs.modulus) && (Z.modulo sz 4 =? 0).
+
+Lemma create_reg_state_incr:
+ forall s sz i,
+ st_incr s (mkstate
+ s.(st_st)
+ (Pos.succ (st_freshreg s))
+ (st_freshstate s)
+ (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls))
+ s.(st_arrdecls)
+ (st_datapath s)
+ (st_controllogic s)).
+Proof. constructor; simpl; auto with htlh. Qed.
+
+Definition create_reg (i : option io) (sz : nat) : mon reg :=
+ fun s => let r := s.(st_freshreg) in
+ OK r (mkstate
+ s.(st_st)
+ (Pos.succ r)
+ (st_freshstate s)
+ (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls))
+ (st_arrdecls s)
+ (st_datapath s)
+ (st_controllogic s))
+ (create_reg_state_incr s sz i).
+
+Lemma create_arr_state_incr:
+ forall s sz ln i,
+ st_incr s (mkstate
+ s.(st_st)
+ (Pos.succ (st_freshreg s))
+ (st_freshstate s)
+ s.(st_scldecls)
+ (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls))
+ (st_datapath s)
+ (st_controllogic s)).
+Proof. constructor; simpl; auto with htlh. Qed.
+
+Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) :=
+ fun s => let r := s.(st_freshreg) in
+ OK (r, ln) (mkstate
+ s.(st_st)
+ (Pos.succ r)
+ (st_freshstate s)
+ s.(st_scldecls)
+ (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls))
+ (st_datapath s)
+ (st_controllogic s))
+ (create_arr_state_incr s sz ln i).
+
+Definition max_pc_map (m : Maps.PTree.t stmnt) :=
+ PTree.fold (fun m pc i => Pos.max m pc) m 1%positive.
+
+Lemma max_pc_map_sound:
+ forall m pc i, m!pc = Some i -> Ple pc (max_pc_map m).
+Proof.
+ intros until i.
+ apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m).
+ (* extensionality *)
+ intros. apply H0. rewrite H; auto.
+ (* base case *)
+ rewrite PTree.gempty. congruence.
+ (* inductive case *)
+ intros. rewrite PTree.gsspec in H2. destruct (peq pc k).
+ inv H2. unfold Ple, Plt in *. lia.
+ apply Ple_trans with a. auto.
+ unfold Ple, Plt in *. lia.
+Qed.
+
+Lemma max_pc_wf :
+ forall m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned ->
+ map_well_formed m.
+Proof.
+ unfold map_well_formed. intros.
+ exploit list_in_map_inv. eassumption. intros [x [A B]]. destruct x.
+ apply Maps.PTree.elements_complete in B. apply max_pc_map_sound in B.
+ unfold Ple in B. apply Pos2Z.pos_le_pos in B. subst.
+ simplify. transitivity (Z.pos (max_pc_map m)); eauto.
+Qed.
+
+Definition poslength {A : Type} (l : list A) : positive :=
+ match Zlength l with
+ | Z.pos p => p
+ | _ => 1
+ end.
+
+Fixpoint penumerate {A : Type} (p : positive) (l : list A) {struct l}
+ : list (positive * A) :=
+ match l with
+ | x :: xs => (p, x) :: penumerate (Pos.pred p) xs
+ | nil => nil
+ end.
+
+Fixpoint prange {A: Type} (p1 p2: positive) (l: list A) {struct l} :=
+ match l with
+ | x :: xs => (p1, p2, x) :: prange p2 (Pos.pred p2) xs
+ | nil => nil
+ end.
+
+Lemma add_data_instr_state_incr :
+ forall s n st,
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n (Vseq (AssocMapExt.get_default
+ _ Vskip n s.(st_datapath)) st) s.(st_datapath))
+ s.(st_controllogic)).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Definition add_data_instr (n : node) (st : stmnt) : mon unit :=
+ fun s =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n (Vseq (AssocMapExt.get_default _ Vskip n s.(st_datapath)) st) s.(st_datapath))
+ s.(st_controllogic))
+ (add_data_instr_state_incr s n st).
+
+Lemma add_control_instr_state_incr :
+ forall s n st,
+ (st_controllogic s) ! n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ s.(st_datapath)
+ (AssocMap.set n st s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
+Definition add_control_instr (n : node) (st : stmnt) : mon unit :=
+ fun s =>
+ match check_empty_node_controllogic s n with
+ | left CTRL =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ s.(st_datapath)
+ (AssocMap.set n st s.(st_controllogic)))
+ (add_control_instr_state_incr s n st CTRL)
+ | _ =>
+ Error (Errors.msg "HTLPargen.add_control_instr: control logic is not empty")
+ end.
+
+Definition add_control_instr_force_state_incr :
+ forall s n st,
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ s.(st_datapath)
+ (AssocMap.set n st s.(st_controllogic))).
+Admitted.
+
+Definition add_control_instr_force (n : node) (st : stmnt) : mon unit :=
+ fun s =>
+ OK tt (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ s.(st_datapath)
+ (AssocMap.set n st s.(st_controllogic)))
+ (add_control_instr_force_state_incr s n st).
+
+
+Fixpoint pred_expr (preg: reg) (p: pred_op) :=
+ match p with
+ | Pvar pred =>
+ Vrange preg (Vlit (natToValue pred)) (Vlit (natToValue pred))
+ | Pnot pred =>
+ Vunop Vnot (pred_expr preg pred)
+ | Pand p1 p2 =>
+ Vbinop Vand (pred_expr preg p1) (pred_expr preg p2)
+ | Por p1 p2 =>
+ Vbinop Vor (pred_expr preg p1) (pred_expr preg p2)
+ end.
+
+Definition translate_predicate (preg: reg) (p: option pred_op) (dst e: expr) :=
+ match p with
+ | None => ret (Vnonblock dst e)
+ | Some pos =>
+ ret (Vnonblock dst (Vternary (pred_expr preg pos) e dst))
+ end.
+
+Definition translate_inst (fin rtrn stack preg : reg) (n : node) (i : instr)
+ : mon unit :=
+ match i with
+ | RBnop =>
+ add_data_instr n Vskip
+ | RBop p op args dst =>
+ do instr <- translate_instr op args;
+ do _ <- declare_reg None dst 32;
+ do pred <- translate_predicate preg p (Vvar dst) instr;
+ add_data_instr n pred
+ | RBload p chunk addr args dst =>
+ do src <- translate_arr_access chunk addr args stack;
+ do _ <- declare_reg None dst 32;
+ do pred <- translate_predicate preg p (Vvar dst) src;
+ add_data_instr n pred
+ | RBstore p chunk addr args src =>
+ do dst <- translate_arr_access chunk addr args stack;
+ do pred <- translate_predicate preg p dst (Vvar src);
+ add_data_instr n pred
+ | RBsetpred c args p =>
+ do cond <- translate_condition c args;
+ add_data_instr n (Vnonblock (pred_expr preg (Pvar p)) cond)
+ end.
+
+Lemma create_new_state_state_incr:
+ forall s p,
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (s.(st_freshstate) + p)%positive
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ s.(st_datapath)
+ s.(st_controllogic)).
+Admitted.
+
+Definition create_new_state (p: node): mon node :=
+ fun s => OK s.(st_freshstate)
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (s.(st_freshstate) + p)%positive
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ s.(st_datapath)
+ s.(st_controllogic))
+ (create_new_state_state_incr s p).
+
+Definition translate_inst_list (fin rtrn stack preg: reg) (ni : node * node * list instr) :=
+ match ni with
+ | (n, p, li) =>
+ do _ <- collectlist (translate_inst fin rtrn stack preg n) li;
+ do st <- get;
+ add_control_instr n (state_goto st.(st_st) p)
+ end.
+
+Fixpoint translate_cfi' (fin rtrn stack preg: reg) (cfi: cf_instr)
+ : mon (stmnt * stmnt) :=
+ match cfi with
+ | RBgoto n' =>
+ do st <- get;
+ ret (Vskip, state_goto st.(st_st) n')
+ | RBcond c args n1 n2 =>
+ do st <- get;
+ do e <- translate_condition c args;
+ ret (Vskip, state_cond st.(st_st) e n1 n2)
+ | RBreturn r =>
+ match r with
+ | Some r' =>
+ ret ((Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r'))),
+ Vskip)
+ | None =>
+ ret ((Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z)))),
+ Vskip)
+ end
+ | RBpred_cf p c1 c2 =>
+ do (tc1s, tc1c) <- translate_cfi' fin rtrn stack preg c1;
+ do (tc2s, tc2c) <- translate_cfi' fin rtrn stack preg c2;
+ ret ((Vcond (pred_expr preg p) tc1s tc2s), (Vcond (pred_expr preg p) tc1c tc2c))
+ | RBjumptable r tbl =>
+ do s <- get;
+ ret (Vskip, Vcase (Vvar r) (tbl_to_case_expr s.(st_st) tbl) (Some Vskip))
+ | RBcall sig ri rl r n =>
+ error (Errors.msg "HTLPargen: RPcall not supported.")
+ | RBtailcall sig ri lr =>
+ error (Errors.msg "HTLPargen: RPtailcall not supported.")
+ | RBbuiltin e lb b n =>
+ error (Errors.msg "HTLPargen: RPbuildin not supported.")
+ end.
+
+Definition translate_cfi (fin rtrn stack preg: reg) (ni: node * cf_instr)
+ : mon unit :=
+ let (n, cfi) := ni in
+ do (s, c) <- translate_cfi' fin rtrn stack preg cfi;
+ do _ <- add_control_instr n c;
+ add_data_instr n s.
+
+Definition transf_bblock (fin rtrn stack preg: reg) (ni : node * bblock)
+ : mon unit :=
+ let (n, bb) := ni in
+ do nstate <- create_new_state ((poslength bb.(bb_body)))%positive;
+ do _ <- collectlist (translate_inst_list fin rtrn stack preg)
+ (prange n (nstate + poslength bb.(bb_body) - 1)%positive
+ bb.(bb_body));
+ match bb.(bb_body) with
+ | nil => translate_cfi fin rtrn stack preg (n, bb.(bb_exit))
+ | _ => translate_cfi fin rtrn stack preg (nstate, bb.(bb_exit))
+ end.
+
+Definition transf_module (f: function) : mon HTL.module :=
+ if stack_correct f.(fn_stacksize) then
+ do fin <- create_reg (Some Voutput) 1;
+ do rtrn <- create_reg (Some Voutput) 32;
+ do (stack, stack_len) <- create_arr None 32
+ (Z.to_nat (f.(fn_stacksize) / 4));
+ do preg <- create_reg None 32;
+ do _ <- collectlist (transf_bblock fin rtrn stack preg)
+ (Maps.PTree.elements f.(fn_code));
+ do _ <- collectlist (fun r => declare_reg (Some Vinput) r 32)
+ f.(fn_params);
+ do start <- create_reg (Some Vinput) 1;
+ do rst <- create_reg (Some Vinput) 1;
+ do clk <- create_reg (Some Vinput) 1;
+ do current_state <- get;
+ match zle (Z.pos (max_pc_map current_state.(st_datapath)))
+ Integers.Int.max_unsigned,
+ zle (Z.pos (max_pc_map current_state.(st_controllogic)))
+ Integers.Int.max_unsigned with
+ | left LEDATA, left LECTRL =>
+ ret (HTL.mkmodule
+ f.(fn_params)
+ current_state.(st_datapath)
+ current_state.(st_controllogic)
+ f.(fn_entrypoint)
+ current_state.(st_st)
+ stack
+ stack_len
+ fin
+ rtrn
+ start
+ rst
+ clk
+ current_state.(st_scldecls)
+ current_state.(st_arrdecls)
+ (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)))
+ | _, _ => error (Errors.msg "More than 2^32 states.")
+ end
+ else error (Errors.msg "Stack size misalignment.").
+
+Definition max_state (f: function) : state :=
+ let st := Pos.succ (max_reg_function f) in
+ mkstate st
+ (Pos.succ st)
+ (Pos.succ (max_pc_function f))
+ (AssocMap.set st (None, VScalar 32) (st_scldecls (init_state st)))
+ (st_arrdecls (init_state st))
+ (st_datapath (init_state st))
+ (st_controllogic (init_state st)).
+
+Definition transl_module (f : function) : Errors.res HTL.module :=
+ run_mon (max_state f) (transf_module f).
+
+Definition transl_fundef := transf_partial_fundef transl_module.
+
+Definition main_is_internal (p : RTLPar.program) : bool :=
+ let ge := Globalenvs.Genv.globalenv p in
+ match Globalenvs.Genv.find_symbol ge p.(AST.prog_main) with
+ | Some b =>
+ match Globalenvs.Genv.find_funct_ptr ge b with
+ | Some (AST.Internal _) => true
+ | _ => false
+ end
+ | _ => false
+ end.
+
+Definition transl_program (p : RTLBlockInstr.program) : Errors.res HTL.program :=
+ if main_is_internal p
+ then transform_partial_program transl_fundef p
+ else Errors.Error (Errors.msg "Main function is not Internal.").
diff --git a/src/translation/HTLgen.v b/src/hls/HTLgen.v
index 43c3d04..def5ca7 100644
--- a/src/translation/HTLgen.v
+++ b/src/hls/HTLgen.v
@@ -1,6 +1,7 @@
(*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
*
* 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,10 +17,21 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From compcert Require Import Maps.
-From compcert Require Errors Globalenvs Integers.
-From compcert Require Import AST RTL.
-From vericert Require Import Verilog HTL Vericertlib AssocMap ValueInt Statemonad.
+Require Import Coq.micromega.Lia.
+
+Require Import compcert.lib.Maps.
+Require compcert.common.Errors.
+Require compcert.common.Globalenvs.
+Require compcert.lib.Integers.
+Require Import compcert.common.AST.
+Require Import compcert.backend.RTL.
+
+Require Import vericert.common.Statemonad.
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.AssocMap.
+Require Import vericert.hls.HTL.
+Require Import vericert.hls.ValueInt.
+Require Import vericert.hls.Verilog.
Hint Resolve AssocMap.gempty : htlh.
Hint Resolve AssocMap.gso : htlh.
@@ -87,17 +99,11 @@ Module HTLMonadExtra := Monad.MonadExtra(HTLMonad).
Import HTLMonadExtra.
Export MonadNotation.
-Definition data_vstmnt : Verilog.stmnt -> HTL.datapath_stmnt := HTLDataVstmnt.
-Definition ctrl_vstmnt : Verilog.stmnt -> HTL.control_stmnt := HTLCtrlVstmnt.
-
-Definition state_goto (st : reg) (n : node) : control_stmnt :=
- ctrl_vstmnt (Vnonblock (Vvar st) (Vlit (posToValue n))).
+Definition state_goto (st : reg) (n : node) : stmnt :=
+ Vnonblock (Vvar st) (Vlit (posToValue n)).
-Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : control_stmnt :=
- ctrl_vstmnt (Vnonblock (Vvar st) (Vternary c (posToExpr n1) (posToExpr n2))).
-
-Definition nonblock (dst : reg) (e : expr) := (Vnonblock (Vvar dst) e).
-Definition block (dst : reg) (e : expr) := (Vblock (Vvar dst) e).
+Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : stmnt :=
+ Vnonblock (Vvar st) (Vternary c (posToExpr n1) (posToExpr n2)).
Definition check_empty_node_datapath:
forall (s: state) (n: node), { s.(st_datapath)!n = None } + { True }.
@@ -111,6 +117,25 @@ Proof.
intros. case (s.(st_controllogic)!n); tauto.
Defined.
+Lemma add_instr_state_incr :
+ forall s n n' st,
+ (st_datapath s)!n = None ->
+ (st_controllogic s)!n = None ->
+ st_incr s
+ (mkstate
+ s.(st_st)
+ s.(st_freshreg)
+ (st_freshstate s)
+ s.(st_scldecls)
+ s.(st_arrdecls)
+ (AssocMap.set n st s.(st_datapath))
+ (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))).
+Proof.
+ constructor; intros;
+ try (simpl; destruct (peq n n0); subst);
+ auto with htlh.
+Qed.
+
Lemma declare_reg_state_incr :
forall i s r sz,
st_incr s
@@ -135,50 +160,7 @@ Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit :=
s.(st_controllogic))
(declare_reg_state_incr i s r sz).
-Lemma create_state_state_incr:
- forall s,
- st_incr s (mkstate
- s.(st_st)
- (st_freshreg s)
- (Pos.succ (st_freshstate s))
- (st_scldecls s)
- (st_arrdecls s)
- (st_datapath s)
- (st_controllogic s)).
-Proof. constructor; simpl; auto with htlh. Qed.
-
-Definition create_state : mon node :=
- fun s => let r := s.(st_freshstate) in
- OK r (mkstate
- s.(st_st)
- (st_freshreg s)
- (Pos.succ (st_freshstate s))
- (st_scldecls s)
- (st_arrdecls s)
- (st_datapath s)
- (st_controllogic s))
- (create_state_state_incr s).
-
-Lemma add_instr_state_incr :
- forall s n n' st,
- (st_datapath s)!n = None ->
- (st_controllogic s)!n = None ->
- st_incr s
- (mkstate
- s.(st_st)
- s.(st_freshreg)
- (st_freshstate s)
- s.(st_scldecls)
- s.(st_arrdecls)
- (AssocMap.set n st s.(st_datapath))
- (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))).
-Proof.
- constructor; intros;
- try (simpl; destruct (peq n n0); subst);
- auto with htlh.
-Qed.
-
-Definition add_instr (n : node) (n' : node) (st : datapath_stmnt) : mon unit :=
+Definition add_instr (n : node) (n' : node) (st : stmnt) : mon unit :=
fun s =>
match check_empty_node_datapath s n, check_empty_node_controllogic s n with
| left STM, left TRANS =>
@@ -206,33 +188,14 @@ Lemma add_instr_skip_state_incr :
s.(st_scldecls)
s.(st_arrdecls)
(AssocMap.set n st s.(st_datapath))
- (AssocMap.set n (ctrl_vstmnt Vskip) s.(st_controllogic))).
+ (AssocMap.set n Vskip s.(st_controllogic))).
Proof.
constructor; intros;
try (simpl; destruct (peq n n0); subst);
auto with htlh.
Qed.
-Lemma add_instr_wait_state_incr :
- forall wait_mod s n n' st,
- (st_datapath s)!n = None ->
- (st_controllogic s)!n = None ->
- st_incr s
- (mkstate
- s.(st_st)
- s.(st_freshreg)
- (st_freshstate s)
- s.(st_scldecls)
- s.(st_arrdecls)
- (AssocMap.set n st s.(st_datapath))
- (AssocMap.set n (HTLwait wait_mod s.(st_st) (Vlit (posToValue n'))) s.(st_controllogic))).
-Proof.
- constructor; intros;
- try (simpl; destruct (peq n n0); subst);
- auto with htlh.
-Qed.
-
-Definition add_instr_wait (wait_mod : ident) (n : node) (n' : node) (st : datapath_stmnt) : mon unit :=
+Definition add_instr_skip (n : node) (st : stmnt) : mon unit :=
fun s =>
match check_empty_node_datapath s n, check_empty_node_controllogic s n with
| left STM, left TRANS =>
@@ -243,23 +206,7 @@ Definition add_instr_wait (wait_mod : ident) (n : node) (n' : node) (st : datapa
s.(st_scldecls)
s.(st_arrdecls)
(AssocMap.set n st s.(st_datapath))
- (AssocMap.set n (HTLwait wait_mod s.(st_st) (Vlit (posToValue n'))) s.(st_controllogic)))
- (add_instr_wait_state_incr wait_mod s n n' st STM TRANS)
- | _, _ => Error (Errors.msg "HTL.add_instr_wait")
- end.
-
-Definition add_instr_skip (n : node) (st : datapath_stmnt) : mon unit :=
- fun s =>
- match check_empty_node_datapath s n, check_empty_node_controllogic s n with
- | left STM, left TRANS =>
- OK tt (mkstate
- s.(st_st)
- s.(st_freshreg)
- (st_freshstate s)
- s.(st_scldecls)
- s.(st_arrdecls)
- (AssocMap.set n st s.(st_datapath))
- (AssocMap.set n (ctrl_vstmnt Vskip) s.(st_controllogic)))
+ (AssocMap.set n Vskip s.(st_controllogic)))
(add_instr_skip_state_incr s n st STM TRANS)
| _, _ => Error (Errors.msg "HTL.add_instr")
end.
@@ -275,7 +222,7 @@ Lemma add_node_skip_state_incr :
(st_freshstate s)
s.(st_scldecls)
s.(st_arrdecls)
- (AssocMap.set n (data_vstmnt Vskip) s.(st_datapath))
+ (AssocMap.set n Vskip s.(st_datapath))
(AssocMap.set n st s.(st_controllogic))).
Proof.
constructor; intros;
@@ -283,7 +230,7 @@ Proof.
auto with htlh.
Qed.
-Definition add_node_skip (n : node) (st : control_stmnt) : mon unit :=
+Definition add_node_skip (n : node) (st : stmnt) : mon unit :=
fun s =>
match check_empty_node_datapath s n, check_empty_node_controllogic s n with
| left STM, left TRANS =>
@@ -293,12 +240,15 @@ Definition add_node_skip (n : node) (st : control_stmnt) : mon unit :=
(st_freshstate s)
s.(st_scldecls)
s.(st_arrdecls)
- (AssocMap.set n (data_vstmnt Vskip) s.(st_datapath))
+ (AssocMap.set n Vskip s.(st_datapath))
(AssocMap.set n st s.(st_controllogic)))
(add_node_skip_state_incr s n st STM TRANS)
| _, _ => Error (Errors.msg "HTL.add_instr")
end.
+Definition nonblock (dst : reg) (e : expr) := Vnonblock (Vvar dst) e.
+Definition block (dst : reg) (e : expr) := Vblock (Vvar dst) e.
+
Definition bop (op : binop) (r1 r2 : reg) : expr :=
Vbinop op (Vvar r1) (Vvar r2).
@@ -420,10 +370,10 @@ Definition translate_instr (op : Op.operation) (args : list reg) : mon expr :=
| Op.Oshlimm n, r::nil => ret (boplit Vshl r n)
| Op.Oshr, r1::r2::nil => ret (bop Vshr r1 r2)
| Op.Oshrimm n, r::nil => ret (boplit Vshr r n)
- | Op.Oshrximm n, r::nil => error (Errors.msg "Htlgen: Instruction not implemented: Oshrximm")
- (*ret (Vbinop Vdiv (Vvar r)
- (Vbinop Vshl (Vlit (ZToValue 1))
- (Vlit (intToValue n))))*)
+ | Op.Oshrximm n, r::nil =>
+ ret (Vternary (Vbinop Vlt (Vvar r) (Vlit (ZToValue 0)))
+ (Vunop Vneg (Vbinop Vshru (Vunop Vneg (Vvar r)) (Vlit n)))
+ (Vbinop Vshru (Vvar r) (Vlit n)))
| Op.Oshru, r1::r2::nil => ret (bop Vshru r1 r2)
| Op.Oshruimm n, r::nil => ret (boplit Vshru r n)
| Op.Ororimm n, r::nil => error (Errors.msg "Htlgen: Instruction not implemented: Ororimm")
@@ -448,7 +398,7 @@ Lemma add_branch_instr_state_incr:
(st_freshstate s)
s.(st_scldecls)
s.(st_arrdecls)
- (AssocMap.set n (data_vstmnt Vskip) (st_datapath s))
+ (AssocMap.set n Vskip (st_datapath s))
(AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s))).
Proof.
intros. apply state_incr_intro; simpl;
@@ -466,7 +416,7 @@ Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit :=
(st_freshstate s)
s.(st_scldecls)
s.(st_arrdecls)
- (AssocMap.set n (data_vstmnt Vskip) (st_datapath s))
+ (AssocMap.set n Vskip (st_datapath s))
(AssocMap.set n (state_cond s.(st_st) e n1 n2) (st_controllogic s)))
(add_branch_instr_state_incr s e n n1 n2 NSTM NTRANS)
| _, _ => Error (Errors.msg "Htlgen: add_branch_instr")
@@ -512,33 +462,26 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni
match i with
| Inop n' =>
if Z.leb (Z.pos n') Integers.Int.max_unsigned then
- add_instr n n' (data_vstmnt Vskip)
+ add_instr n n' Vskip
else error (Errors.msg "State is larger than 2^32.")
| Iop op args dst n' =>
if Z.leb (Z.pos n') Integers.Int.max_unsigned then
do instr <- translate_instr op args;
do _ <- declare_reg None dst 32;
- add_instr n n' (data_vstmnt (nonblock dst instr))
+ add_instr n n' (nonblock dst instr)
else error (Errors.msg "State is larger than 2^32.")
| Iload mem addr args dst n' =>
if Z.leb (Z.pos n') Integers.Int.max_unsigned then
do src <- translate_arr_access mem addr args stack;
do _ <- declare_reg None dst 32;
- add_instr n n' (data_vstmnt (nonblock dst src))
+ add_instr n n' (nonblock dst src)
else error (Errors.msg "State is larger than 2^32.")
| Istore mem addr args src n' =>
if Z.leb (Z.pos n') Integers.Int.max_unsigned then
do dst <- translate_arr_access mem addr args stack;
- add_instr n n' (data_vstmnt (Vnonblock dst (Vvar src))) (* TODO: Could juse use add_instr? reg exists. *)
- else error (Errors.msg "State is larger than 2^32.")
- | Icall sig (inl fn) args dst n' => error (Errors.msg "Indirect calls are not implemented.")
- | Icall sig (inr fn) args dst n' =>
- if Z.leb (Z.pos n') Integers.Int.max_unsigned then
- do _ <- declare_reg None dst 32;
- do join_state <- create_state;
- do _ <- add_instr n join_state (HTLfork fn args);
- add_instr_wait fn join_state n' (HTLjoin fn dst)
+ add_instr n n' (Vnonblock dst (Vvar src)) (* TODO: Could juse use add_instr? reg exists. *)
else error (Errors.msg "State is larger than 2^32.")
+ | Icall _ _ _ _ _ => error (Errors.msg "Calls are not implemented.")
| Itailcall _ _ _ => error (Errors.msg "Tailcalls are not implemented.")
| Ibuiltin _ _ _ _ => error (Errors.msg "Builtin functions not implemented.")
| Icond cond args n1 n2 =>
@@ -553,9 +496,9 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni
| Ireturn r =>
match r with
| Some r' =>
- add_instr_skip n (data_vstmnt (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r'))))
+ add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r')))
| None =>
- add_instr_skip n (data_vstmnt (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z)))))
+ add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z))))
end
end
end.
@@ -611,11 +554,11 @@ Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) :=
Definition stack_correct (sz : Z) : bool :=
(0 <=? sz) && (sz <? Integers.Ptrofs.modulus) && (Z.modulo sz 4 =? 0).
-Definition max_pc_map {A: Type} (m : Maps.PTree.t A) :=
+Definition max_pc_map (m : Maps.PTree.t stmnt) :=
PTree.fold (fun m pc i => Pos.max m pc) m 1%positive.
Lemma max_pc_map_sound:
- forall A m pc i, m!pc = Some i -> Ple pc (@max_pc_map A m).
+ forall m pc i, m!pc = Some i -> Ple pc (max_pc_map m).
Proof.
intros until i. unfold max_pc_function.
apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m).
@@ -625,13 +568,13 @@ Proof.
rewrite PTree.gempty. congruence.
(* inductive case *)
intros. rewrite PTree.gsspec in H2. destruct (peq pc k).
- inv H2. xomega.
- apply Ple_trans with a. auto. xomega.
+ inv H2. unfold Ple; lia.
+ apply Ple_trans with a. auto. unfold Ple; lia.
Qed.
Lemma max_pc_wf :
- forall T m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned ->
- @map_well_formed T m.
+ forall m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned ->
+ map_well_formed m.
Proof.
unfold map_well_formed. intros.
exploit list_in_map_inv. eassumption. intros [x [A B]]. destruct x.
@@ -640,7 +583,7 @@ Proof.
simplify. transitivity (Z.pos (max_pc_map m)); eauto.
Qed.
-Definition transf_module (f: function) : mon module :=
+Definition transf_module (f: function) : mon HTL.module :=
if stack_correct f.(fn_stacksize) then
do fin <- create_reg (Some Voutput) 1;
do rtrn <- create_reg (Some Voutput) 32;
@@ -654,7 +597,7 @@ Definition transf_module (f: function) : mon module :=
match zle (Z.pos (max_pc_map current_state.(st_datapath))) Integers.Int.max_unsigned,
zle (Z.pos (max_pc_map current_state.(st_controllogic))) Integers.Int.max_unsigned with
| left LEDATA, left LECTRL =>
- ret (mkmodule
+ ret (HTL.mkmodule
f.(RTL.fn_params)
current_state.(st_datapath)
current_state.(st_controllogic)
@@ -669,7 +612,7 @@ Definition transf_module (f: function) : mon module :=
clk
current_state.(st_scldecls)
current_state.(st_arrdecls)
- (conj (max_pc_wf _ _ LECTRL) (max_pc_wf _ _ LEDATA)))
+ (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)))
| _, _ => error (Errors.msg "More than 2^32 states.")
end
else error (Errors.msg "Stack size misalignment.").
@@ -684,7 +627,7 @@ Definition max_state (f: function) : state :=
(st_datapath (init_state st))
(st_controllogic (init_state st)).
-Definition transl_module (f : function) : Errors.res module :=
+Definition transl_module (f : function) : Errors.res HTL.module :=
run_mon (max_state f) (transf_module f).
Definition transl_fundef := transf_partial_fundef transl_module.
diff --git a/src/translation/HTLgenproof.v b/src/hls/HTLgenproof.v
index c0a8f75..98b57ae 100644
--- a/src/translation/HTLgenproof.v
+++ b/src/hls/HTLgenproof.v
@@ -1,6 +1,7 @@
-(*
+ (*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
*
* 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,10 +17,24 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From compcert Require RTL Registers AST.
-From compcert Require Import Integers Globalenvs Memory Linking.
-From vericert Require Import Vericertlib HTLgenspec HTLgen ValueInt AssocMap Array IntegerExtra ZExtra.
-From vericert Require HTL Verilog.
+Require compcert.backend.RTL.
+Require compcert.backend.Registers.
+Require compcert.common.AST.
+Require Import compcert.common.Globalenvs.
+Require Import compcert.common.Linking.
+Require Import compcert.common.Memory.
+Require Import compcert.lib.Integers.
+
+Require Import vericert.common.IntegerExtra.
+Require Import vericert.common.Vericertlib.
+Require Import vericert.common.ZExtra.
+Require Import vericert.hls.Array.
+Require Import vericert.hls.AssocMap.
+Require vericert.hls.HTL.
+Require Import vericert.hls.HTLgen.
+Require Import vericert.hls.HTLgenspec.
+Require Import vericert.hls.ValueInt.
+Require vericert.hls.Verilog.
Require Import Lia.
@@ -470,7 +485,11 @@ Section CORRECTNESS.
| |- context[match ?d with _ => _ end] => destruct d eqn:?; try discriminate
| H : match ?d with _ => _ end = _ |- _ => repeat unfold_match H
| H : match ?d with _ => _ end _ = _ |- _ => repeat unfold_match H
- | |- Verilog.expr_runp _ _ _ _ _ => econstructor
+ | |- Verilog.expr_runp _ _ _ ?f _ =>
+ match f with
+ | Verilog.Vternary _ _ _ => idtac
+ | _ => econstructor
+ end
| |- val_value_lessdef (?f _ _) _ => unfold f
| |- val_value_lessdef (?f _) _ => unfold f
| H : ?f (Registers.Regmap.get _ _) _ = Some _ |- _ =>
@@ -716,6 +735,71 @@ Section CORRECTNESS.
repeat unfold_match TR_INSTR; inv TR_INSTR; repeat econstructor.
Qed.
+ Lemma eval_correct_Oshrximm :
+ forall s sp rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st n,
+ match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) ->
+ (RTL.fn_code f) ! pc = Some (RTL.Iop (Op.Oshrximm n) args res0 pc') ->
+ Op.eval_operation ge sp (Op.Oshrximm n)
+ (List.map (fun r : BinNums.positive =>
+ Registers.Regmap.get r rs) args) m = Some v ->
+ translate_instr (Op.Oshrximm n) args s = OK e s' i ->
+ exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'.
+ Proof.
+ intros s sp rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st n MSTATE INSTR EVAL TR_INSTR.
+ pose proof MSTATE as MSTATE_2. inv MSTATE.
+ inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR;
+ unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); inv EVAL.
+ (*repeat (simplify; eval_correct_tac; unfold valueToInt in * ).
+ destruct (Z_lt_ge_dec (Int.signed i0) 0).
+ econstructor.*)
+ unfold Values.Val.shrx in *.
+ destruct v0; try discriminate.
+ destruct (Int.ltu n (Int.repr 31)) eqn:?; try discriminate.
+ inversion H1. clear H1.
+ assert (Int.unsigned n <= 30).
+ { unfold Int.ltu in *. destruct (zlt (Int.unsigned n) (Int.unsigned (Int.repr 31))); try discriminate.
+ rewrite Int.unsigned_repr in l by (simplify; lia).
+ replace 31 with (Z.succ 30) in l by auto.
+ apply Zlt_succ_le in l.
+ auto.
+ }
+ rewrite IntExtra.shrx_shrx_alt_equiv in H2 by auto.
+ unfold IntExtra.shrx_alt in *.
+ destruct (zlt (Int.signed i0) 0).
+ - repeat econstructor; unfold valueToBool, boolToValue, uvalueToZ, natToValue;
+ repeat (simplify; eval_correct_tac).
+ inv_lessdef. unfold valueToInt in *. rewrite H3 in H1.
+ inv H1.
+ unfold Int.lt in *. rewrite zlt_true in Heqb0. simplify.
+ rewrite Int.unsigned_repr in Heqb0. discriminate.
+ simplify; lia.
+ unfold ZToValue. rewrite Int.signed_repr by (simplify; lia).
+ auto.
+ rewrite H3 in H1; discriminate.
+ rewrite H3 in H2; discriminate.
+ rewrite IntExtra.shrx_shrx_alt_equiv; auto. unfold IntExtra.shrx_alt. rewrite zlt_true; try lia.
+ simplify. inv_lessdef. unfold valueToInt in *.
+ rewrite H3 in H1. auto. inv H1. auto.
+ rewrite H3 in H1. discriminate.
+ rewrite H3 in H2. discriminate.
+ - econstructor; econstructor; [eapply Verilog.erun_Vternary_false|idtac]; repeat econstructor; unfold valueToBool, boolToValue, uvalueToZ, natToValue;
+ repeat (simplify; eval_correct_tac).
+ inv_lessdef. unfold valueToInt in *. rewrite H3 in H1.
+ inv H1.
+ unfold Int.lt in *. rewrite zlt_false in Heqb0. simplify.
+ rewrite Int.unsigned_repr in Heqb0. lia.
+ simplify; lia.
+ unfold ZToValue. rewrite Int.signed_repr by (simplify; lia).
+ auto.
+ rewrite H3 in H1; discriminate.
+ rewrite H3 in H2; discriminate.
+ rewrite IntExtra.shrx_shrx_alt_equiv; auto. unfold IntExtra.shrx_alt. rewrite zlt_false; try lia.
+ simplify. inv_lessdef. unfold valueToInt in *.
+ rewrite H3 in H1. auto. inv H1. auto.
+ rewrite H3 in H1. discriminate.
+ rewrite H3 in H2. discriminate.
+ Qed.
+
Lemma eval_correct :
forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st,
match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) ->
@@ -754,6 +838,47 @@ Section CORRECTNESS.
- rewrite Heqb in Heqb0. discriminate.
(*- unfold Int.ror. unfold Int.or. unfold Int.shru, Int.shl, Int.sub. unfold intToValue. unfold Int.modu,
repeat (rewrite Int.unsigned_repr). auto.*)
+ - assert (Int.unsigned n <= 30).
+ { unfold Int.ltu in *. destruct (zlt (Int.unsigned n) (Int.unsigned (Int.repr 31))); try discriminate.
+ rewrite Int.unsigned_repr in l by (simplify; lia).
+ replace 31 with (Z.succ 30) in l by auto.
+ apply Zlt_succ_le in l.
+ auto.
+ }
+ destruct (zlt (Int.signed i0) 0).
+ + repeat econstructor; unfold valueToBool, boolToValue, uvalueToZ, natToValue;
+ repeat (simplify; eval_correct_tac).
+ rewrite IntExtra.shrx_shrx_alt_equiv; auto. unfold IntExtra.shrx_alt. rewrite zlt_true; try lia.
+ simplify. inv_lessdef. unfold valueToInt in *.
+ rewrite Heqv0 in H0. auto. inv H0. auto.
+ rewrite Heqv0 in H2. discriminate.
+ unfold valueToInt in l. auto.
+ inv_lessdef. unfold valueToInt in *. rewrite Heqv0 in H0.
+ inv H0.
+ unfold Int.lt in *. rewrite zlt_true in Heqb0. simplify.
+ rewrite Int.unsigned_repr in Heqb0. discriminate.
+ simplify; lia.
+ unfold ZToValue. rewrite Int.signed_repr by (simplify; lia).
+ auto.
+ rewrite Heqv0 in H0; discriminate.
+ rewrite Heqv0 in H2; discriminate.
+ + eapply Verilog.erun_Vternary_false; repeat econstructor; unfold valueToBool, boolToValue, uvalueToZ, natToValue;
+ repeat (simplify; eval_correct_tac).
+ rewrite IntExtra.shrx_shrx_alt_equiv; auto. unfold IntExtra.shrx_alt. rewrite zlt_false; try lia.
+ simplify. inv_lessdef. unfold valueToInt in *.
+ rewrite Heqv0 in H0. auto. inv H0. auto.
+ rewrite Heqv0 in H2. discriminate.
+ unfold valueToInt in *. auto.
+ inv_lessdef. unfold valueToInt in *.
+ rewrite Heqv0 in H0.
+ inv H0.
+ unfold Int.lt in *. rewrite zlt_false in Heqb0. simplify.
+ rewrite Int.unsigned_repr in Heqb0. lia.
+ simplify; lia.
+ unfold ZToValue. rewrite Int.signed_repr by (simplify; lia).
+ auto.
+ rewrite Heqv0 in H0; discriminate.
+ rewrite Heqv0 in H2; discriminate.
- unfold Op.eval_addressing32 in *. repeat (unfold_match H2); inv H2.
+ unfold translate_eff_addressing in *. repeat (unfold_match H1).
destruct v0; inv Heql; rewrite H2; inv H1; repeat eval_correct_tac.
diff --git a/src/translation/HTLgenspec.v b/src/hls/HTLgenspec.v
index 10e48f7..b76b8ec 100644
--- a/src/translation/HTLgenspec.v
+++ b/src/hls/HTLgenspec.v
@@ -1,6 +1,7 @@
(*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
*
* 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,10 +17,20 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From compcert Require RTL Op Maps Errors.
-From compcert Require Import Maps Integers.
-From vericert Require Import Vericertlib Verilog ValueInt HTL HTLgen AssocMap.
-Require Import Lia.
+Require Import Coq.micromega.Lia.
+
+Require compcert.backend.RTL.
+Require compcert.common.Errors.
+Require Import compcert.lib.Integers.
+Require Import compcert.lib.Maps.
+Require compcert.verilog.Op.
+
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.Verilog.
+Require Import vericert.hls.ValueInt.
+Require Import vericert.hls.HTL.
+Require Import vericert.hls.HTLgen.
+Require Import vericert.hls.AssocMap.
Hint Resolve Maps.PTree.elements_keys_norepet : htlspec.
Hint Resolve Maps.PTree.elements_correct : htlspec.
diff --git a/src/hls/IfConversion.v b/src/hls/IfConversion.v
new file mode 100644
index 0000000..39d9fd2
--- /dev/null
+++ b/src/hls/IfConversion.v
@@ -0,0 +1,122 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2021 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import compcert.common.AST.
+Require Import compcert.common.Errors.
+Require Import compcert.common.Globalenvs.
+Require Import compcert.lib.Integers.
+Require Import compcert.lib.Maps.
+
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.RTLBlockInstr.
+Require Import vericert.hls.RTLBlock.
+
+(*|
+=============
+If conversion
+=============
+
+This conversion is a verified conversion from RTLBlock back to itself, which performs if-conversion
+on basic blocks to make basic blocks larger.
+|*)
+
+Definition combine_pred (p: pred_op) (optp: option pred_op) :=
+ match optp with
+ | Some p' => Pand p p'
+ | None => p
+ end.
+
+Definition map_if_convert (p: pred_op) (i: instr) :=
+ match i with
+ | RBop p' op args dst => RBop (Some (combine_pred p p')) op args dst
+ | RBload p' chunk addr args dst =>
+ RBload (Some (combine_pred p p')) chunk addr args dst
+ | RBstore p' chunk addr args src =>
+ RBstore (Some (combine_pred p p')) chunk addr args src
+ | _ => i
+ end.
+
+Definition if_convert_block (c: code) (p: predicate) (bb: bblock) : bblock :=
+ let cfi := bb_exit bb in
+ match cfi with
+ | RBcond cond args n1 n2 =>
+ match PTree.get n1 c, PTree.get n2 c with
+ | Some bb1, Some bb2 =>
+ let bb1' := List.map (map_if_convert (Pvar p)) bb1.(bb_body) in
+ let bb2' := List.map (map_if_convert (Pnot (Pvar p))) bb2.(bb_body) in
+ mk_bblock (List.concat (bb.(bb_body) :: ((RBsetpred cond args p) :: bb1') :: bb2' :: nil))
+ (RBpred_cf (Pvar p) bb1.(bb_exit) bb2.(bb_exit))
+ | _, _ => bb
+ end
+ | _ => bb
+ end.
+
+Definition is_cond_cfi (cfi: cf_instr) :=
+ match cfi with
+ | RBcond _ _ _ _ => true
+ | _ => false
+ end.
+
+Fixpoint any {A: Type} (f: A -> bool) (a: list A) :=
+ match a with
+ | x :: xs => f x || any f xs
+ | nil => false
+ end.
+
+Fixpoint all {A: Type} (f: A -> bool) (a: list A) :=
+ match a with
+ | x :: xs => f x && all f xs
+ | nil => true
+ end.
+
+Definition find_backedge (nb: node * bblock) :=
+ let (n, b) := nb in
+ let succs := successors_instr b.(bb_exit) in
+ filter (fun x => Pos.ltb n x) succs.
+
+Definition find_all_backedges (c: code) : list node :=
+ List.concat (List.map find_backedge (PTree.elements c)).
+
+Definition has_backedge (entry: node) (be: list node) :=
+ any (fun x => Pos.eqb entry x) be.
+
+Definition find_blocks_with_cond (c: code) : list (node * bblock) :=
+ let backedges := find_all_backedges c in
+ List.filter (fun x => is_cond_cfi (snd x).(bb_exit) &&
+ negb (has_backedge (fst x) backedges) &&
+ all (fun x' => negb (has_backedge x' backedges))
+ (successors_instr (snd x).(bb_exit))
+ ) (PTree.elements c).
+
+Definition if_convert_code (p: nat * code) (nb: node * bblock) :=
+ let (n, bb) := nb in
+ let (p', c) := p in
+ let nbb := if_convert_block c p' bb in
+ (S p', PTree.set n nbb c).
+
+Definition transf_function (f: function) : function :=
+ let (_, c) := List.fold_left if_convert_code
+ (find_blocks_with_cond f.(fn_code))
+ (1%nat, f.(fn_code)) in
+ mkfunction f.(fn_sig) f.(fn_params) f.(fn_stacksize) c f.(fn_entrypoint).
+
+Definition transf_fundef (fd: fundef) : fundef :=
+ transf_fundef transf_function fd.
+
+Definition transf_program (p: program) : program :=
+ transform_program transf_fundef p.
diff --git a/src/hls/Partition.ml b/src/hls/Partition.ml
new file mode 100644
index 0000000..19c6048
--- /dev/null
+++ b/src/hls/Partition.ml
@@ -0,0 +1,124 @@
+ (*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+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 = []; bb_exit = RBgoto s }
+ else
+ Errors.OK { bb_body = []; 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 = []; 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
diff --git a/src/hls/Pipeline.v b/src/hls/Pipeline.v
new file mode 100644
index 0000000..7f1485a
--- /dev/null
+++ b/src/hls/Pipeline.v
@@ -0,0 +1,28 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020-2021 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import compcert.lib.Maps.
+Require Import compcert.common.AST.
+Require Import compcert.backend.RTL.
+
+Parameter pipeline : function -> function.
+
+Definition transf_fundef := transf_fundef pipeline.
+
+Definition transf_program : program -> program :=
+ transform_program transf_fundef.
diff --git a/src/verilog/PrintHTL.ml b/src/hls/PrintHTL.ml
index aa90dbe..836222e 100644
--- a/src/verilog/PrintHTL.ml
+++ b/src/hls/PrintHTL.ml
@@ -16,7 +16,6 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-open Value
open Datatypes
open Camlcoq
open AST
diff --git a/src/hls/PrintRTLBlock.ml b/src/hls/PrintRTLBlock.ml
new file mode 100644
index 0000000..8fef401
--- /dev/null
+++ b/src/hls/PrintRTLBlock.ml
@@ -0,0 +1,72 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Pretty-printers for RTL code *)
+
+open Printf
+open Camlcoq
+open Datatypes
+open Maps
+open AST
+open RTLBlockInstr
+open RTLBlock
+open PrintAST
+open PrintRTLBlockInstr
+
+(* Printing of RTL code *)
+
+let reg pp r =
+ fprintf pp "x%d" (P.to_int r)
+
+let rec regs pp = function
+ | [] -> ()
+ | [r] -> reg pp r
+ | r1::rl -> fprintf pp "%a, %a" reg r1 regs rl
+
+let ros pp = function
+ | Coq_inl r -> reg pp r
+ | Coq_inr s -> fprintf pp "\"%s\"" (extern_atom s)
+
+let print_bblock pp (pc, i) =
+ fprintf pp "%5d:{\n" pc;
+ List.iter (print_bblock_body pp) i.bb_body;
+ print_bblock_exit pp i.bb_exit;
+ fprintf pp "\t}\n\n"
+
+let print_function pp id f =
+ fprintf pp "%s(%a) {\n" (extern_atom id) regs f.fn_params;
+ let instrs =
+ List.sort
+ (fun (pc1, _) (pc2, _) -> compare pc2 pc1)
+ (List.rev_map
+ (fun (pc, i) -> (P.to_int pc, i))
+ (PTree.elements f.fn_code)) in
+ List.iter (print_bblock pp) instrs;
+ fprintf pp "}\n\n"
+
+let print_globdef pp (id, gd) =
+ match gd with
+ | Gfun(Internal f) -> print_function pp id f
+ | _ -> ()
+
+let print_program pp (prog: program) =
+ List.iter (print_globdef pp) prog.prog_defs
+
+let destination : string option ref = ref None
+
+let print_if passno prog =
+ match !destination with
+ | None -> ()
+ | Some f ->
+ let oc = open_out (f ^ "." ^ Z.to_string passno) in
+ print_program oc prog;
+ close_out oc
diff --git a/src/hls/PrintRTLBlockInstr.ml b/src/hls/PrintRTLBlockInstr.ml
new file mode 100644
index 0000000..ba7241b
--- /dev/null
+++ b/src/hls/PrintRTLBlockInstr.ml
@@ -0,0 +1,87 @@
+open Printf
+open Camlcoq
+open Datatypes
+open Maps
+open AST
+open RTLBlockInstr
+open PrintAST
+
+let reg pp r =
+ fprintf pp "x%d" (P.to_int r)
+
+let pred pp r =
+ fprintf pp "p%d" (Nat.to_int r)
+
+let rec regs pp = function
+ | [] -> ()
+ | [r] -> reg pp r
+ | r1::rl -> fprintf pp "%a, %a" reg r1 regs rl
+
+let ros pp = function
+ | Coq_inl r -> reg pp r
+ | Coq_inr s -> fprintf pp "\"%s\"" (extern_atom s)
+
+let rec print_pred_op pp = function
+ | Pvar p -> pred pp p
+ | Pnot p -> fprintf pp "(~ %a)" print_pred_op p
+ | Pand (p1, p2) -> fprintf pp "(%a & %a)" print_pred_op p1 print_pred_op p2
+ | Por (p1, p2) -> fprintf pp "(%a | %a)" print_pred_op p1 print_pred_op p2
+
+let print_pred_option pp = function
+ | Some x -> fprintf pp "(%a)" print_pred_op x
+ | None -> ()
+
+let print_bblock_body pp i =
+ fprintf pp "\t\t";
+ match i with
+ | RBnop -> fprintf pp "nop\n"
+ | RBop(p, op, ls, dst) ->
+ fprintf pp "%a %a = %a\n"
+ print_pred_option p reg dst (PrintOp.print_operation reg) (op, ls)
+ | RBload(p, chunk, addr, args, dst) ->
+ fprintf pp "%a %a = %s[%a]\n"
+ print_pred_option p reg dst (name_of_chunk chunk)
+ (PrintOp.print_addressing reg) (addr, args)
+ | RBstore(p, chunk, addr, args, src) ->
+ fprintf pp "%a %s[%a] = %a\n"
+ print_pred_option p
+ (name_of_chunk chunk)
+ (PrintOp.print_addressing reg) (addr, args)
+ reg src
+ | RBsetpred (c, args, p) ->
+ fprintf pp "%a = %a\n"
+ pred p
+ (PrintOp.print_condition reg) (c, args)
+
+let rec print_bblock_exit pp i =
+ fprintf pp "\t\t";
+ match i with
+ | RBcall(_, fn, args, res, _) ->
+ fprintf pp "%a = %a(%a)\n"
+ reg res ros fn regs args;
+ | RBtailcall(_, fn, args) ->
+ fprintf pp "tailcall %a(%a)\n"
+ ros fn regs args
+ | RBbuiltin(ef, args, res, _) ->
+ fprintf pp "%a = %s(%a)\n"
+ (print_builtin_res reg) res
+ (name_of_external ef)
+ (print_builtin_args reg) args
+ | RBcond(cond, args, s1, s2) ->
+ fprintf pp "if (%a) goto %d else goto %d\n"
+ (PrintOp.print_condition reg) (cond, args)
+ (P.to_int s1) (P.to_int s2)
+ | RBjumptable(arg, tbl) ->
+ let tbl = Array.of_list tbl in
+ fprintf pp "jumptable (%a)\n" reg arg;
+ for i = 0 to Array.length tbl - 1 do
+ fprintf pp "\tcase %d: goto %d\n" i (P.to_int tbl.(i))
+ done
+ | RBreturn None ->
+ fprintf pp "return\n"
+ | RBreturn (Some arg) ->
+ fprintf pp "return %a\n" reg arg
+ | RBgoto n ->
+ fprintf pp "goto %d\n" (P.to_int n)
+ | RBpred_cf (p, c1, c2) ->
+ fprintf pp "if %a then (%a) else (%a)\n" print_pred_op p print_bblock_exit c1 print_bblock_exit c2
diff --git a/src/verilog/PrintVerilog.ml b/src/hls/PrintVerilog.ml
index b3fb6c8..e67b567 100644
--- a/src/verilog/PrintVerilog.ml
+++ b/src/hls/PrintVerilog.ml
@@ -1,6 +1,7 @@
(* -*- mode: tuareg -*-
* Vericert: Verified high-level synthesis.
* Copyright (C) 2019-2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
*
* 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
@@ -28,6 +29,14 @@ open Printf
open VericertClflags
+module PMap = Map.Make (struct
+ type t = P.t
+
+ let compare = P.compare
+end)
+
+let name_map = ref PMap.empty
+
let concat = String.concat ""
let indent i = String.make (2 * i) ' '
@@ -65,14 +74,26 @@ let pprint_binop l r =
| Vshru -> unsigned ">>"
let unop = function
- | Vneg -> " ~ "
+ | Vneg -> " - "
| Vnot -> " ! "
-let register a = sprintf "reg_%d" (P.to_int a)
+let register a =
+ match PMap.find_opt a !name_map with
+ | Some s -> s
+ | None -> sprintf "reg_%d" (P.to_int a)
(*let literal l = sprintf "%d'd%d" (Nat.to_int l.vsize) (Z.to_int (uvalueToZ l))*)
-let literal l = sprintf "32'd%ld" (camlint_of_coqint l)
+let literal l =
+ let l' = camlint_of_coqint l in
+ if l' < Int32.zero
+ then sprintf "(- 32'd%ld)" (Int32.neg l')
+ else sprintf "32'd%ld" l'
+
+let compare_expr es1 es2 =
+ match es1, es2 with
+ | (Vlit p1, _), (Vlit p2, _) -> compare (camlint_of_coqint p1) (camlint_of_coqint p2)
+ | _, _ -> -1
let rec pprint_expr = function
| Vlit l -> literal l
@@ -82,6 +103,7 @@ let rec pprint_expr = function
| Vunop (u, e) -> concat ["("; unop u; pprint_expr e; ")"]
| Vbinop (op, a, b) -> concat [pprint_binop (pprint_expr a) (pprint_expr b) op]
| Vternary (c, t, f) -> concat ["("; pprint_expr c; " ? "; pprint_expr t; " : "; pprint_expr f; ")"]
+ | Vrange (r, e1, e2) -> concat [register r; "["; pprint_expr e1; ":"; pprint_expr e2; "]"]
let rec pprint_stmnt i =
let pprint_case (e, s) = concat [ indent (i + 1); pprint_expr e; ": begin\n"; pprint_stmnt (i + 2) s;
@@ -96,9 +118,10 @@ let rec pprint_stmnt i =
indent i; "end\n"
]
| Vcase (e, es, d) -> concat [ indent i; "case ("; pprint_expr e; ")\n";
- fold_map pprint_case es; indent (i+1); "default:;\n";
- indent i; "endcase\n"
- ]
+ fold_map pprint_case (List.sort compare_expr es |> List.rev);
+ indent (i+1); "default:;\n";
+ indent i; "endcase\n"
+ ]
| Vblock (a, b) -> concat [indent i; pprint_expr a; " = "; pprint_expr b; ";\n"]
| Vnonblock (a, b) -> concat [indent i; pprint_expr a; " <= "; pprint_expr b; ";\n"]
@@ -173,7 +196,7 @@ let testbench = "module testbench;
always @(posedge clk) begin
if (finish == 1) begin
- $display(\"finished: %d\", return_val);
+ $display(\"finished: %0d\", return_val);
$finish;
end
end
@@ -199,15 +222,22 @@ let print_initial i n stk = concat [
]
let pprint_module debug i n m =
- let inputs = m.mod_start :: m.mod_reset :: m.mod_clk :: m.mod_args in
- let outputs = [m.mod_finish; m.mod_return] in
- concat [ indent i; "module "; (extern_atom n);
- "("; concat (intersperse ", " (List.map register (inputs @ outputs))); ");\n";
- fold_map (pprint_module_item (i+1)) m.mod_body;
- if !option_initial then print_initial i (Nat.to_int m.mod_stk_len) m.mod_stk else "";
- if debug then debug_always i m.mod_clk m.mod_st else "";
- indent i; "endmodule\n\n"
- ]
+ if (extern_atom n) = "main" then
+ let inputs = m.mod_start :: m.mod_reset :: m.mod_clk :: m.mod_args in
+ let outputs = [m.mod_finish; m.mod_return] in
+ name_map := List.fold_left (fun a -> (function (n, s) -> PMap.add n s a)) PMap.empty
+ [ (m.mod_finish, "finish"); (m.mod_return, "return_val");
+ (m.mod_start, "start"); (m.mod_reset, "reset");
+ (m.mod_clk, "clk"); (m.mod_st, "state"); (m.mod_stk, "stack")
+ ];
+ concat [ indent i; "module "; (extern_atom n);
+ "("; concat (intersperse ", " (List.map register (inputs @ outputs))); ");\n";
+ fold_map (pprint_module_item (i+1)) m.mod_body;
+ if !option_initial then print_initial i (Nat.to_int m.mod_stk_len) m.mod_stk else "";
+ if debug then debug_always i m.mod_clk m.mod_st else "";
+ indent i; "endmodule\n\n"
+ ]
+ else ""
let print_result pp lst =
let rec print_result_in pp = function
diff --git a/src/verilog/PrintVerilog.mli b/src/hls/PrintVerilog.mli
index dbb8ba0..dbb8ba0 100644
--- a/src/verilog/PrintVerilog.mli
+++ b/src/hls/PrintVerilog.mli
diff --git a/src/hls/RTLBlock.v b/src/hls/RTLBlock.v
new file mode 100644
index 0000000..6a3487a
--- /dev/null
+++ b/src/hls/RTLBlock.v
@@ -0,0 +1,102 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020-2021 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import compcert.backend.Registers.
+Require Import compcert.common.AST.
+Require Import compcert.common.Events.
+Require Import compcert.common.Globalenvs.
+Require Import compcert.common.Memory.
+Require Import compcert.common.Smallstep.
+Require Import compcert.common.Values.
+Require Import compcert.lib.Coqlib.
+Require Import compcert.lib.Integers.
+Require Import compcert.lib.Maps.
+Require Import compcert.verilog.Op.
+
+Require Import vericert.hls.RTLBlockInstr.
+
+Definition bb := list instr.
+
+Definition bblock := @bblock bb.
+Definition code := @code bb.
+Definition function := @function bb.
+Definition fundef := @fundef bb.
+Definition program := @program bb.
+Definition funsig := @funsig bb.
+Definition stackframe := @stackframe bb.
+Definition state := @state bb.
+Definition genv := @genv bb.
+
+Section RELSEM.
+
+ Context (ge: genv).
+
+ Inductive step_instr_list: val -> instr_state -> list instr -> instr_state -> Prop :=
+ | exec_RBcons:
+ forall state i state' state'' instrs sp,
+ step_instr ge sp state i state' ->
+ step_instr_list sp state' instrs state'' ->
+ step_instr_list sp state (i :: instrs) state''
+ | exec_RBnil:
+ forall state sp,
+ step_instr_list sp state nil state.
+
+ Inductive step: state -> trace -> state -> Prop :=
+ | exec_bblock:
+ forall s f sp pc rs rs' m m' t s' bb,
+ f.(fn_code)!pc = Some bb ->
+ step_instr_list sp (InstrState rs m) bb.(bb_body) (InstrState rs' m') ->
+ step_cf_instr ge (State s f sp pc rs' m') bb.(bb_exit) t s' ->
+ step (State s f sp pc rs m) t s'
+ | exec_function_internal:
+ forall s f args m m' stk,
+ Mem.alloc m 0 f.(fn_stacksize) = (m', stk) ->
+ step (Callstate s (Internal f) args m)
+ E0 (State s
+ f
+ (Vptr stk Ptrofs.zero)
+ f.(fn_entrypoint)
+ (init_regs args f.(fn_params))
+ m')
+ | exec_function_external:
+ forall s ef args res t m m',
+ external_call ef ge args m t res m' ->
+ step (Callstate s (External ef) args m)
+ t (Returnstate s res m')
+ | exec_return:
+ forall res f sp pc rs s vres m,
+ step (Returnstate (Stackframe res f sp pc rs :: s) vres m)
+ E0 (State s f sp pc (rs#res <- vres) m).
+
+End RELSEM.
+
+Inductive initial_state (p: program): state -> Prop :=
+ | initial_state_intro: forall b f m0,
+ let ge := Genv.globalenv p in
+ Genv.init_mem p = Some m0 ->
+ Genv.find_symbol ge p.(prog_main) = Some b ->
+ Genv.find_funct_ptr ge b = Some f ->
+ funsig f = signature_main ->
+ initial_state p (Callstate nil f nil m0).
+
+Inductive final_state: state -> int -> Prop :=
+ | final_state_intro: forall r m,
+ final_state (Returnstate nil (Vint r) m) r.
+
+Definition semantics (p: program) :=
+ Semantics step (initial_state p) final_state (Genv.globalenv p).
diff --git a/src/hls/RTLBlockInstr.v b/src/hls/RTLBlockInstr.v
new file mode 100644
index 0000000..86f8eba
--- /dev/null
+++ b/src/hls/RTLBlockInstr.v
@@ -0,0 +1,469 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2021 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import Coq.micromega.Lia.
+
+Require Import compcert.backend.Registers.
+Require Import compcert.common.AST.
+Require Import compcert.common.Events.
+Require Import compcert.common.Globalenvs.
+Require Import compcert.common.Memory.
+Require Import compcert.common.Values.
+Require Import compcert.lib.Integers.
+Require Import compcert.lib.Maps.
+Require Import compcert.verilog.Op.
+
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.Sat.
+
+Local Open Scope rtl.
+
+Definition node := positive.
+Definition predicate := nat.
+
+Inductive pred_op : Type :=
+| Pvar: predicate -> pred_op
+| Pnot: pred_op -> pred_op
+| Pand: pred_op -> pred_op -> pred_op
+| Por: pred_op -> pred_op -> pred_op.
+
+Fixpoint sat_predicate (p: pred_op) (a: asgn) : bool :=
+ match p with
+ | Pvar p' => a p'
+ | Pnot p' => negb (sat_predicate p' a)
+ | Pand p1 p2 => sat_predicate p1 a && sat_predicate p2 a
+ | Por p1 p2 => sat_predicate p1 a || sat_predicate p2 a
+ end.
+
+Fixpoint mult {A: Type} (a b: list (list A)) : list (list A) :=
+ match a with
+ | nil => nil
+ | l :: ls => mult ls b ++ (List.map (fun x => l ++ x) b)
+ end.
+
+Lemma satFormula_concat:
+ forall a b agn,
+ satFormula a agn ->
+ satFormula b agn ->
+ satFormula (a ++ b) agn.
+Proof. induction a; crush. Qed.
+
+Lemma satFormula_concat2:
+ forall a b agn,
+ satFormula (a ++ b) agn ->
+ satFormula a agn /\ satFormula b agn.
+Proof.
+ induction a; simplify;
+ try apply IHa in H1; crush.
+Qed.
+
+Lemma satClause_concat:
+ forall a a1 a0,
+ satClause a a1 ->
+ satClause (a0 ++ a) a1.
+Proof. induction a0; crush. Qed.
+
+Lemma satClause_concat2:
+ forall a a1 a0,
+ satClause a0 a1 ->
+ satClause (a0 ++ a) a1.
+Proof.
+ induction a0; crush.
+ inv H; crush.
+Qed.
+
+Lemma satClause_concat3:
+ forall a b c,
+ satClause (a ++ b) c ->
+ satClause a c \/ satClause b c.
+Proof.
+ induction a; crush.
+ inv H; crush.
+ apply IHa in H0; crush.
+ inv H0; crush.
+Qed.
+
+Lemma satFormula_mult':
+ forall p2 a a0,
+ satFormula p2 a0 \/ satClause a a0 ->
+ satFormula (map (fun x : list lit => a ++ x) p2) a0.
+Proof.
+ induction p2; crush.
+ - inv H. inv H0. apply satClause_concat. auto.
+ apply satClause_concat2; auto.
+ - apply IHp2.
+ inv H; crush; inv H0; crush.
+Qed.
+
+Lemma satFormula_mult2':
+ forall p2 a a0,
+ satFormula (map (fun x : list lit => a ++ x) p2) a0 ->
+ satClause a a0 \/ satFormula p2 a0.
+Proof.
+ induction p2; crush.
+ apply IHp2 in H1. inv H1; crush.
+ apply satClause_concat3 in H0.
+ inv H0; crush.
+Qed.
+
+Lemma satFormula_mult:
+ forall p1 p2 a,
+ satFormula p1 a \/ satFormula p2 a ->
+ satFormula (mult p1 p2) a.
+Proof.
+ induction p1; crush.
+ apply satFormula_concat; crush.
+ inv H. inv H0.
+ apply IHp1. auto.
+ apply IHp1. auto.
+ apply satFormula_mult';
+ inv H; crush.
+Qed.
+
+Lemma satFormula_mult2:
+ forall p1 p2 a,
+ satFormula (mult p1 p2) a ->
+ satFormula p1 a \/ satFormula p2 a.
+Proof.
+ induction p1; crush.
+ apply satFormula_concat2 in H; crush.
+ apply IHp1 in H0.
+ inv H0; crush.
+ apply satFormula_mult2' in H1. inv H1; crush.
+Qed.
+
+Fixpoint trans_pred_temp (bound: nat) (p: pred_op) : option formula :=
+ match bound with
+ | O => None
+ | S n =>
+ match p with
+ | Pvar p' => Some (((true, p') :: nil) :: nil)
+ | Pand p1 p2 =>
+ match trans_pred_temp n p1, trans_pred_temp n p2 with
+ | Some p1', Some p2' =>
+ Some (p1' ++ p2')
+ | _, _ => None
+ end
+ | Por p1 p2 =>
+ match trans_pred_temp n p1, trans_pred_temp n p2 with
+ | Some p1', Some p2' =>
+ Some (mult p1' p2')
+ | _, _ => None
+ end
+ | Pnot (Pvar p') => Some (((false, p') :: nil) :: nil)
+ | Pnot (Pnot p) => trans_pred_temp n p
+ | Pnot (Pand p1 p2) => trans_pred_temp n (Por (Pnot p1) (Pnot p2))
+ | Pnot (Por p1 p2) => trans_pred_temp n (Pand (Pnot p1) (Pnot p2))
+ end
+ end.
+
+Fixpoint trans_pred (bound: nat) (p: pred_op) :
+ option {fm: formula | forall a,
+ sat_predicate p a = true <-> satFormula fm a}.
+ refine
+ (match bound with
+ | O => None
+ | S n =>
+ match p with
+ | Pvar p' => Some (exist _ (((true, p') :: nil) :: nil) _)
+ | Pand p1 p2 =>
+ match trans_pred n p1, trans_pred n p2 with
+ | Some (exist p1' _), Some (exist p2' _) =>
+ Some (exist _ (p1' ++ p2') _)
+ | _, _ => None
+ end
+ | Por p1 p2 =>
+ match trans_pred n p1, trans_pred n p2 with
+ | Some (exist p1' _), Some (exist p2' _) =>
+ Some (exist _ (mult p1' p2') _)
+ | _, _ => None
+ end
+ | Pnot (Pvar p') => Some (exist _ (((false, p') :: nil) :: nil) _)
+ | _ => None
+ end
+ end); split; intros; simpl in *; auto.
+ - inv H. inv H0; auto.
+ - admit.
+ - admit.
+ - apply satFormula_concat.
+ apply andb_prop in H. inv H. apply i in H0. auto.
+ apply andb_prop in H. inv H. apply i0 in H1. auto.
+ - apply satFormula_concat2 in H. simplify. apply andb_true_intro.
+ split. apply i in H0. auto.
+ apply i0 in H1. auto.
+ - apply orb_prop in H. inv H; apply satFormula_mult. apply i in H0. auto.
+ apply i0 in H0. auto.
+ - apply orb_true_intro.
+ apply satFormula_mult2 in H. inv H. apply i in H0. auto.
+ apply i0 in H0. auto.
+Admitted.
+
+Definition sat_pred (bound: nat) (p: pred_op) :
+ option ({al : alist | sat_predicate p (interp_alist al) = true}
+ + {forall a : asgn, sat_predicate p a = false}).
+ refine
+ ( match trans_pred bound p with
+ | Some (exist fm _) =>
+ match boundedSat bound fm with
+ | Some (inleft (exist a _)) => Some (inleft (exist _ a _))
+ | Some (inright _) => Some (inright _)
+ | None => None
+ end
+ | None => None
+ end ).
+ - apply i in s2. auto.
+ - intros. specialize (n a). specialize (i a).
+ destruct (sat_predicate p a). exfalso.
+ apply n. apply i. auto. auto.
+Qed.
+
+Definition sat_pred_simple (bound: nat) (p: pred_op) :=
+ match sat_pred bound p with
+ | Some (inleft (exist al _)) => Some (Some al)
+ | Some (inright _) => Some None
+ | None => None
+ end.
+
+Definition sat_pred_temp (bound: nat) (p: pred_op) :=
+ match trans_pred_temp bound p with
+ | Some fm => boundedSatSimple bound fm
+ | None => None
+ end.
+
+Inductive instr : Type :=
+| RBnop : instr
+| RBop : option pred_op -> operation -> list reg -> reg -> instr
+| RBload : option pred_op -> memory_chunk -> addressing -> list reg -> reg -> instr
+| RBstore : option pred_op -> memory_chunk -> addressing -> list reg -> reg -> instr
+| RBsetpred : condition -> list reg -> predicate -> instr.
+
+Inductive cf_instr : Type :=
+| RBcall : signature -> reg + ident -> list reg -> reg -> node -> cf_instr
+| RBtailcall : signature -> reg + ident -> list reg -> cf_instr
+| RBbuiltin : external_function -> list (builtin_arg reg) ->
+ builtin_res reg -> node -> cf_instr
+| RBcond : condition -> list reg -> node -> node -> cf_instr
+| RBjumptable : reg -> list node -> cf_instr
+| RBreturn : option reg -> cf_instr
+| RBgoto : node -> cf_instr
+| RBpred_cf : pred_op -> cf_instr -> cf_instr -> cf_instr.
+
+Fixpoint successors_instr (i : cf_instr) : list node :=
+ match i with
+ | RBcall sig ros args res s => s :: nil
+ | RBtailcall sig ros args => nil
+ | RBbuiltin ef args res s => s :: nil
+ | RBcond cond args ifso ifnot => ifso :: ifnot :: nil
+ | RBjumptable arg tbl => tbl
+ | RBreturn optarg => nil
+ | RBgoto n => n :: nil
+ | RBpred_cf p c1 c2 => concat (successors_instr c1 :: successors_instr c2 :: nil)
+ end.
+
+Definition max_reg_instr (m: positive) (i: instr) :=
+ match i with
+ | RBnop => m
+ | RBop p op args res =>
+ fold_left Pos.max args (Pos.max res m)
+ | RBload p chunk addr args dst =>
+ fold_left Pos.max args (Pos.max dst m)
+ | RBstore p chunk addr args src =>
+ fold_left Pos.max args (Pos.max src m)
+ | RBsetpred c args p =>
+ fold_left Pos.max args m
+ end.
+
+Fixpoint max_reg_cfi (m : positive) (i : cf_instr) :=
+ match i with
+ | RBcall sig (inl r) args res s =>
+ fold_left Pos.max args (Pos.max r (Pos.max res m))
+ | RBcall sig (inr id) args res s =>
+ fold_left Pos.max args (Pos.max res m)
+ | RBtailcall sig (inl r) args =>
+ fold_left Pos.max args (Pos.max r m)
+ | RBtailcall sig (inr id) args =>
+ fold_left Pos.max args m
+ | RBbuiltin ef args res s =>
+ fold_left Pos.max (params_of_builtin_args args)
+ (fold_left Pos.max (params_of_builtin_res res) m)
+ | RBcond cond args ifso ifnot => fold_left Pos.max args m
+ | RBjumptable arg tbl => Pos.max arg m
+ | RBreturn None => m
+ | RBreturn (Some arg) => Pos.max arg m
+ | RBgoto n => m
+ | RBpred_cf p c1 c2 => Pos.max (max_reg_cfi m c1) (max_reg_cfi m c2)
+ end.
+
+Definition regset := Regmap.t val.
+
+Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset :=
+ match rl, vl with
+ | r1 :: rs, v1 :: vs => Regmap.set r1 v1 (init_regs vs rs)
+ | _, _ => Regmap.init Vundef
+ end.
+
+Inductive instr_state : Type :=
+| InstrState:
+ forall (rs: regset)
+ (m: mem),
+ instr_state.
+
+Section DEFINITION.
+
+ Context {bblock_body: Type}.
+
+ Record bblock : Type := mk_bblock {
+ bb_body: bblock_body;
+ bb_exit: cf_instr
+ }.
+
+ Definition code: Type := PTree.t bblock.
+
+ Record function: Type := mkfunction {
+ fn_sig: signature;
+ fn_params: list reg;
+ fn_stacksize: Z;
+ fn_code: code;
+ fn_entrypoint: node
+ }.
+
+ Definition fundef := AST.fundef function.
+
+ Definition program := AST.program fundef unit.
+
+ Definition funsig (fd: fundef) :=
+ match fd with
+ | Internal f => fn_sig f
+ | External ef => ef_sig ef
+ end.
+
+ Inductive stackframe : Type :=
+ | Stackframe:
+ forall (res: reg) (**r where to store the result *)
+ (f: function) (**r calling function *)
+ (sp: val) (**r stack pointer in calling function *)
+ (pc: node) (**r program point in calling function *)
+ (rs: regset), (**r register state in calling function *)
+ stackframe.
+
+ Inductive state : Type :=
+ | State:
+ forall (stack: list stackframe) (**r call stack *)
+ (f: function) (**r current function *)
+ (sp: val) (**r stack pointer *)
+ (pc: node) (**r current program point in [c] *)
+ (rs: regset) (**r register state *)
+ (m: mem), (**r memory state *)
+ state
+ | Callstate:
+ forall (stack: list stackframe) (**r call stack *)
+ (f: fundef) (**r function to call *)
+ (args: list val) (**r arguments to the call *)
+ (m: mem), (**r memory state *)
+ state
+ | Returnstate:
+ forall (stack: list stackframe) (**r call stack *)
+ (v: val) (**r return value for the call *)
+ (m: mem), (**r memory state *)
+ state.
+
+End DEFINITION.
+
+Section RELSEM.
+
+ Context {bblock_body : Type}.
+
+ Definition genv := Genv.t (@fundef bblock_body) unit.
+
+ Context (ge: genv).
+
+ Definition find_function
+ (ros: reg + ident) (rs: regset) : option fundef :=
+ match ros with
+ | inl r => Genv.find_funct ge rs#r
+ | inr symb =>
+ match Genv.find_symbol ge symb with
+ | None => None
+ | Some b => Genv.find_funct_ptr ge b
+ end
+ end.
+
+ Inductive step_instr: val -> instr_state -> instr -> instr_state -> Prop :=
+ | exec_RBnop:
+ forall rs m sp,
+ step_instr sp (InstrState rs m) RBnop (InstrState rs m)
+ | exec_RBop:
+ forall op v res args rs m sp p,
+ eval_operation ge sp op rs##args m = Some v ->
+ step_instr sp (InstrState rs m)
+ (RBop p op args res)
+ (InstrState (rs#res <- v) m)
+ | exec_RBload:
+ forall addr rs args a chunk m v dst sp p,
+ eval_addressing ge sp addr rs##args = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ step_instr sp (InstrState rs m)
+ (RBload p chunk addr args dst)
+ (InstrState (rs#dst <- v) m)
+ | exec_RBstore:
+ forall addr rs args a chunk m src m' sp p,
+ eval_addressing ge sp addr rs##args = Some a ->
+ Mem.storev chunk m a rs#src = Some m' ->
+ step_instr sp (InstrState rs m)
+ (RBstore p chunk addr args src)
+ (InstrState rs m').
+
+ Inductive step_cf_instr: state -> cf_instr -> trace -> state -> Prop :=
+ | exec_RBcall:
+ forall s f sp rs m res fd ros sig args pc pc',
+ find_function ros rs = Some fd ->
+ funsig fd = sig ->
+ step_cf_instr (State s f sp pc rs m) (RBcall sig ros args res pc')
+ E0 (Callstate (Stackframe res f sp pc' rs :: s) fd rs##args m)
+ | exec_RBtailcall:
+ forall s f stk rs m sig ros args fd m' pc,
+ find_function ros rs = Some fd ->
+ funsig fd = sig ->
+ Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
+ step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs m) (RBtailcall sig ros args)
+ E0 (Callstate s fd rs##args m')
+ | exec_RBbuiltin:
+ forall s f sp rs m ef args res pc' vargs t vres m' pc,
+ eval_builtin_args ge (fun r => rs#r) sp m args vargs ->
+ external_call ef ge vargs m t vres m' ->
+ step_cf_instr (State s f sp pc rs m) (RBbuiltin ef args res pc')
+ t (State s f sp pc' (regmap_setres res vres rs) m')
+ | exec_RBcond:
+ forall s f sp rs m cond args ifso ifnot b pc pc',
+ eval_condition cond rs##args m = Some b ->
+ pc' = (if b then ifso else ifnot) ->
+ step_cf_instr (State s f sp pc rs m) (RBcond cond args ifso ifnot)
+ E0 (State s f sp pc' rs m)
+ | exec_RBjumptable:
+ forall s f sp rs m arg tbl n pc pc',
+ rs#arg = Vint n ->
+ list_nth_z tbl (Int.unsigned n) = Some pc' ->
+ step_cf_instr (State s f sp pc rs m) (RBjumptable arg tbl)
+ E0 (State s f sp pc' rs m)
+ | exec_Ireturn:
+ forall s f stk rs m or pc m',
+ Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
+ step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs m) (RBreturn or)
+ E0 (Returnstate s (regmap_optget or Vundef rs) m').
+
+End RELSEM.
diff --git a/src/hls/RTLBlockgen.v b/src/hls/RTLBlockgen.v
new file mode 100644
index 0000000..889e104
--- /dev/null
+++ b/src/hls/RTLBlockgen.v
@@ -0,0 +1,30 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require compcert.backend.RTL.
+Require Import compcert.common.AST.
+Require Import compcert.lib.Maps.
+
+Require Import vericert.hls.RTLBlock.
+
+Parameter partition : RTL.function -> Errors.res function.
+
+Definition transl_fundef := transf_partial_fundef partition.
+
+Definition transl_program : RTL.program -> Errors.res program :=
+ transform_partial_program transl_fundef.
diff --git a/src/hls/RTLPar.v b/src/hls/RTLPar.v
new file mode 100644
index 0000000..be9ff22
--- /dev/null
+++ b/src/hls/RTLPar.v
@@ -0,0 +1,128 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020-2021 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import compcert.backend.Registers.
+Require Import compcert.common.AST.
+Require Import compcert.common.Events.
+Require Import compcert.common.Globalenvs.
+Require Import compcert.common.Memory.
+Require Import compcert.common.Smallstep.
+Require Import compcert.common.Values.
+Require Import compcert.lib.Coqlib.
+Require Import compcert.lib.Integers.
+Require Import compcert.lib.Maps.
+Require Import compcert.verilog.Op.
+
+Require Import vericert.hls.RTLBlockInstr.
+
+Definition bb := list (list instr).
+
+Definition bblock := @bblock bb.
+Definition code := @code bb.
+Definition function := @function bb.
+Definition fundef := @fundef bb.
+Definition program := @program bb.
+Definition funsig := @funsig bb.
+Definition stackframe := @stackframe bb.
+Definition state := @state bb.
+Definition genv := @genv bb.
+
+Section RELSEM.
+
+ Context (ge: genv).
+
+ Inductive step_instr_list: val -> instr_state -> list instr -> instr_state -> Prop :=
+ | exec_RBcons:
+ forall state i state' state'' instrs sp,
+ step_instr ge sp state i state' ->
+ step_instr_list sp state' instrs state'' ->
+ step_instr_list sp state (i :: instrs) state''
+ | exec_RBnil:
+ forall state sp,
+ step_instr_list sp state nil state.
+
+ Inductive step_instr_block (sp : val)
+ : instr_state -> bb -> instr_state -> Prop :=
+ | exec_instr_block_cons:
+ forall state i state' state'' instrs,
+ step_instr_list sp state i state' ->
+ step_instr_block sp state' instrs state'' ->
+ step_instr_block sp state (i :: instrs) state''
+ | exec_instr_block_nil:
+ forall state,
+ step_instr_block sp state nil state.
+
+ Inductive step: state -> trace -> state -> Prop :=
+ | exec_bblock:
+ forall s f sp pc rs rs' m m' t s' bb,
+ f.(fn_code)!pc = Some bb ->
+ step_instr_block sp (InstrState rs m) bb.(bb_body) (InstrState rs' m') ->
+ step_cf_instr ge (State s f sp pc rs' m') bb.(bb_exit) t s' ->
+ step (State s f sp pc rs m) t s'
+ | exec_function_internal:
+ forall s f args m m' stk,
+ Mem.alloc m 0 f.(fn_stacksize) = (m', stk) ->
+ step (Callstate s (Internal f) args m)
+ E0 (State s
+ f
+ (Vptr stk Ptrofs.zero)
+ f.(fn_entrypoint)
+ (init_regs args f.(fn_params))
+ m')
+ | exec_function_external:
+ forall s ef args res t m m',
+ external_call ef ge args m t res m' ->
+ step (Callstate s (External ef) args m)
+ t (Returnstate s res m')
+ | exec_return:
+ forall res f sp pc rs s vres m,
+ step (Returnstate (Stackframe res f sp pc rs :: s) vres m)
+ E0 (State s f sp pc (rs#res <- vres) m).
+
+End RELSEM.
+
+Inductive initial_state (p: program): state -> Prop :=
+ | initial_state_intro: forall b f m0,
+ let ge := Genv.globalenv p in
+ Genv.init_mem p = Some m0 ->
+ Genv.find_symbol ge p.(prog_main) = Some b ->
+ Genv.find_funct_ptr ge b = Some f ->
+ funsig f = signature_main ->
+ initial_state p (Callstate nil f nil m0).
+
+Inductive final_state: state -> int -> Prop :=
+ | final_state_intro: forall r m,
+ final_state (Returnstate nil (Vint r) m) r.
+
+Definition semantics (p: program) :=
+ Semantics step (initial_state p) final_state (Genv.globalenv p).
+
+Definition max_reg_bblock (m : positive) (pc : node) (bb : bblock) :=
+ let max_body := fold_left (fun x l => fold_left max_reg_instr l x) bb.(bb_body) m in
+ max_reg_cfi max_body bb.(bb_exit).
+
+Definition max_reg_function (f: function) :=
+ Pos.max
+ (PTree.fold max_reg_bblock f.(fn_code) 1%positive)
+ (fold_left Pos.max f.(fn_params) 1%positive).
+
+Definition max_pc_function (f: function) : positive :=
+ PTree.fold (fun m pc i => (Pos.max m
+ (pc + match Zlength i.(bb_body)
+ with Z.pos p => p | _ => 1 end))%positive)
+ f.(fn_code) 1%positive.
diff --git a/src/hls/RTLPargen.v b/src/hls/RTLPargen.v
new file mode 100644
index 0000000..39c57df
--- /dev/null
+++ b/src/hls/RTLPargen.v
@@ -0,0 +1,697 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import compcert.backend.Registers.
+Require Import compcert.common.AST.
+Require Import compcert.common.Globalenvs.
+Require compcert.common.Memory.
+Require Import compcert.common.Values.
+Require Import compcert.lib.Floats.
+Require Import compcert.lib.Integers.
+Require Import compcert.lib.Maps.
+Require compcert.verilog.Op.
+
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.RTLBlock.
+Require Import vericert.hls.RTLPar.
+Require Import vericert.hls.RTLBlockInstr.
+
+(*|
+Schedule Oracle
+===============
+
+This oracle determines if a schedule was valid by performing symbolic execution on the input and
+output and showing that these behave the same. This acts on each basic block separately, as the
+rest of the functions should be equivalent.
+|*)
+
+Definition reg := positive.
+
+Inductive resource : Set :=
+| Reg : reg -> resource
+| Mem : resource.
+
+(*|
+The following defines quite a few equality comparisons automatically, however, these can be
+optimised heavily if written manually, as their proofs are not needed.
+|*)
+
+Lemma resource_eq : forall (r1 r2 : resource), {r1 = r2} + {r1 <> r2}.
+Proof.
+ decide equality. apply Pos.eq_dec.
+Defined.
+
+Lemma comparison_eq: forall (x y : comparison), {x = y} + {x <> y}.
+Proof.
+ decide equality.
+Defined.
+
+Lemma condition_eq: forall (x y : Op.condition), {x = y} + {x <> y}.
+Proof.
+ generalize comparison_eq; intro.
+ generalize Int.eq_dec; intro.
+ generalize Int64.eq_dec; intro.
+ decide equality.
+Defined.
+
+Lemma addressing_eq : forall (x y : Op.addressing), {x = y} + {x <> y}.
+Proof.
+ generalize Int.eq_dec; intro.
+ generalize AST.ident_eq; intro.
+ generalize Z.eq_dec; intro.
+ generalize Ptrofs.eq_dec; intro.
+ decide equality.
+Defined.
+
+Lemma typ_eq : forall (x y : AST.typ), {x = y} + {x <> y}.
+Proof.
+ decide equality.
+Defined.
+
+Lemma operation_eq: forall (x y : Op.operation), {x = y} + {x <> y}.
+Proof.
+ generalize Int.eq_dec; intro.
+ generalize Int64.eq_dec; intro.
+ generalize Float.eq_dec; intro.
+ generalize Float32.eq_dec; intro.
+ generalize AST.ident_eq; intro.
+ generalize condition_eq; intro.
+ generalize addressing_eq; intro.
+ generalize typ_eq; intro.
+ decide equality.
+Defined.
+
+Lemma memory_chunk_eq : forall (x y : AST.memory_chunk), {x = y} + {x <> y}.
+Proof.
+ decide equality.
+Defined.
+
+Lemma list_typ_eq: forall (x y : list AST.typ), {x = y} + {x <> y}.
+Proof.
+ generalize typ_eq; intro.
+ decide equality.
+Defined.
+
+Lemma option_typ_eq : forall (x y : option AST.typ), {x = y} + {x <> y}.
+Proof.
+ generalize typ_eq; intro.
+ decide equality.
+Defined.
+
+Lemma signature_eq: forall (x y : AST.signature), {x = y} + {x <> y}.
+Proof.
+ repeat decide equality.
+Defined.
+
+Lemma list_operation_eq : forall (x y : list Op.operation), {x = y} + {x <> y}.
+Proof.
+ generalize operation_eq; intro.
+ decide equality.
+Defined.
+
+Lemma list_reg_eq : forall (x y : list reg), {x = y} + {x <> y}.
+Proof.
+ generalize Pos.eq_dec; intros.
+ decide equality.
+Defined.
+
+Lemma sig_eq : forall (x y : AST.signature), {x = y} + {x <> y}.
+Proof.
+ repeat decide equality.
+Defined.
+
+Lemma instr_eq: forall (x y : instr), {x = y} + {x <> y}.
+Proof.
+ generalize Pos.eq_dec; intro.
+ generalize typ_eq; intro.
+ generalize Int.eq_dec; intro.
+ generalize memory_chunk_eq; intro.
+ generalize addressing_eq; intro.
+ generalize operation_eq; intro.
+ generalize condition_eq; intro.
+ generalize signature_eq; intro.
+ generalize list_operation_eq; intro.
+ generalize list_reg_eq; intro.
+ generalize AST.ident_eq; intro.
+ repeat decide equality.
+Defined.
+
+Lemma cf_instr_eq: forall (x y : cf_instr), {x = y} + {x <> y}.
+Proof.
+ generalize Pos.eq_dec; intro.
+ generalize typ_eq; intro.
+ generalize Int.eq_dec; intro.
+ generalize Int64.eq_dec; intro.
+ generalize Float.eq_dec; intro.
+ generalize Float32.eq_dec; intro.
+ generalize Ptrofs.eq_dec; intro.
+ generalize memory_chunk_eq; intro.
+ generalize addressing_eq; intro.
+ generalize operation_eq; intro.
+ generalize condition_eq; intro.
+ generalize signature_eq; intro.
+ generalize list_operation_eq; intro.
+ generalize list_reg_eq; intro.
+ generalize AST.ident_eq; intro.
+ repeat decide equality.
+Defined.
+
+(*|
+We then create equality lemmas for a resource and a module to index resources uniquely. The
+indexing is done by setting Mem to 1, whereas all other infinitely many registers will all be
+shifted right by 1. This means that they will never overlap.
+|*)
+
+Module R_indexed.
+ Definition t := resource.
+ Definition index (rs: resource) : positive :=
+ match rs with
+ | Reg r => xO r
+ | Mem => 1%positive
+ end.
+
+ Lemma index_inj: forall (x y: t), index x = index y -> x = y.
+ Proof. destruct x; destruct y; crush. Qed.
+
+ Definition eq := resource_eq.
+End R_indexed.
+
+(*|
+We can then create expressions that mimic the expressions defined in RTLBlock and RTLPar, which use
+expressions instead of registers as their inputs and outputs. This means that we can accumulate all
+the results of the operations as general expressions that will be present in those registers.
+
+- Ebase: the starting value of the register.
+- Eop: Some arithmetic operation on a number of registers.
+- Eload: A load from a memory location into a register.
+- Estore: A store from a register to a memory location.
+
+Then, to make recursion over expressions easier, expression_list is also defined in the datatype, as
+that enables mutual recursive definitions over the datatypes.
+|*)
+
+Inductive expression : Set :=
+| Ebase : resource -> expression
+| Eop : Op.operation -> expression_list -> expression
+| Eload : AST.memory_chunk -> Op.addressing -> expression_list -> expression -> expression
+| Estore : expression -> AST.memory_chunk -> Op.addressing -> expression_list -> expression -> expression
+with expression_list : Set :=
+| Enil : expression_list
+| Econs : expression -> expression_list -> expression_list.
+
+(*|
+Using IMap we can create a map from resources to any other type, as resources can be uniquely
+identified as positive numbers.
+|*)
+
+Module Rtree := ITree(R_indexed).
+
+Definition forest : Type := Rtree.t expression.
+
+Definition regset := Registers.Regmap.t val.
+
+Definition get_forest v f :=
+ match Rtree.get v f with
+ | None => Ebase v
+ | Some v' => v'
+ end.
+
+Notation "a # b" := (get_forest b a) (at level 1).
+Notation "a # b <- c" := (Rtree.set b c a) (at level 1, b at next level).
+
+Record sem_state := mk_sem_state {
+ sem_state_regset : regset;
+ sem_state_memory : Memory.mem
+ }.
+
+(*|
+Finally we want to define the semantics of execution for the expressions with symbolic values, so
+the result of executing the expressions will be an expressions.
+|*)
+
+Section SEMANTICS.
+
+Context (A : Set) (genv : Genv.t A unit).
+
+Inductive sem_value :
+ val -> sem_state -> expression -> val -> Prop :=
+ | Sbase_reg:
+ forall sp st r,
+ sem_value sp st (Ebase (Reg r)) (Registers.Regmap.get r (sem_state_regset st))
+ | Sop:
+ forall st op args v lv sp,
+ sem_val_list sp st args lv ->
+ Op.eval_operation genv sp op lv (sem_state_memory st) = Some v ->
+ sem_value sp st (Eop op args) v
+ | Sload :
+ forall st mem_exp addr chunk args a v m' lv sp,
+ sem_mem sp st mem_exp m' ->
+ sem_val_list sp st args lv ->
+ Op.eval_addressing genv sp addr lv = Some a ->
+ Memory.Mem.loadv chunk m' a = Some v ->
+ sem_value sp st (Eload chunk addr args mem_exp) v
+with sem_mem :
+ val -> sem_state -> expression -> Memory.mem -> Prop :=
+ | Sstore :
+ forall st mem_exp val_exp m'' addr v a m' chunk args lv sp,
+ sem_mem sp st mem_exp m' ->
+ sem_value sp st val_exp v ->
+ sem_val_list sp st args lv ->
+ Op.eval_addressing genv sp addr lv = Some a ->
+ Memory.Mem.storev chunk m' a v = Some m'' ->
+ sem_mem sp st (Estore mem_exp chunk addr args val_exp) m''
+ | Sbase_mem :
+ forall st m sp,
+ sem_mem sp st (Ebase Mem) m
+with sem_val_list :
+ val -> sem_state -> expression_list -> list val -> Prop :=
+ | Snil :
+ forall st sp,
+ sem_val_list sp st Enil nil
+ | Scons :
+ forall st e v l lv sp,
+ sem_value sp st e v ->
+ sem_val_list sp st l lv ->
+ sem_val_list sp st (Econs e l) (v :: lv).
+
+Inductive sem_regset :
+ val -> sem_state -> forest -> regset -> Prop :=
+ | Sregset:
+ forall st f rs' sp,
+ (forall x, sem_value sp st (f # (Reg x)) (Registers.Regmap.get x rs')) ->
+ sem_regset sp st f rs'.
+
+Inductive sem :
+ val -> sem_state -> forest -> sem_state -> Prop :=
+ | Sem:
+ forall st rs' m' f sp,
+ sem_regset sp st f rs' ->
+ sem_mem sp st (f # Mem) m' ->
+ sem sp st f (mk_sem_state rs' m').
+
+End SEMANTICS.
+
+Fixpoint beq_expression (e1 e2: expression) {struct e1}: bool :=
+ match e1, e2 with
+ | Ebase r1, Ebase r2 => if resource_eq r1 r2 then true else false
+ | Eop op1 el1, Eop op2 el2 =>
+ if operation_eq op1 op2 then beq_expression_list el1 el2 else false
+ | Eload chk1 addr1 el1 e1, Eload chk2 addr2 el2 e2 =>
+ if memory_chunk_eq chk1 chk2
+ then if addressing_eq addr1 addr2
+ then if beq_expression_list el1 el2
+ then beq_expression e1 e2 else false else false else false
+ | Estore m1 chk1 addr1 el1 e1, Estore m2 chk2 addr2 el2 e2=>
+ if memory_chunk_eq chk1 chk2
+ then if addressing_eq addr1 addr2
+ then if beq_expression_list el1 el2
+ then if beq_expression m1 m2
+ then beq_expression e1 e2 else false else false else false else false
+ | _, _ => false
+ end
+with beq_expression_list (el1 el2: expression_list) {struct el1} : bool :=
+ match el1, el2 with
+ | Enil, Enil => true
+ | Econs e1 t1, Econs e2 t2 => beq_expression e1 e2 && beq_expression_list t1 t2
+ | _, _ => false
+ end.
+
+Scheme expression_ind2 := Induction for expression Sort Prop
+ with expression_list_ind2 := Induction for expression_list Sort Prop.
+
+Lemma beq_expression_correct:
+ forall e1 e2, beq_expression e1 e2 = true -> e1 = e2.
+Proof.
+ intro e1;
+ apply expression_ind2 with
+ (P := fun (e1 : expression) =>
+ forall e2, beq_expression e1 e2 = true -> e1 = e2)
+ (P0 := fun (e1 : expression_list) =>
+ forall e2, beq_expression_list e1 e2 = true -> e1 = e2); simplify;
+ repeat match goal with
+ | [ H : context[match ?x with _ => _ end] |- _ ] => destruct x eqn:?
+ | [ H : context[if ?x then _ else _] |- _ ] => destruct x eqn:?
+ end; subst; f_equal; crush.
+Qed.
+
+Definition empty : forest := Rtree.empty _.
+
+(*|
+This function checks if all the elements in [fa] are in [fb], but not the other way round.
+|*)
+
+Definition check := Rtree.beq beq_expression.
+
+Lemma check_correct: forall (fa fb : forest) (x : resource),
+ check fa fb = true -> (forall x, fa # x = fb # x).
+Proof.
+ unfold check, get_forest; intros;
+ pose proof beq_expression_correct;
+ match goal with
+ [ Hbeq : context[Rtree.beq], y : Rtree.elt |- _ ] =>
+ apply (Rtree.beq_sound beq_expression fa fb) with (x := y) in Hbeq
+ end;
+ repeat destruct_match; crush.
+Qed.
+
+Lemma get_empty:
+ forall r, empty#r = Ebase r.
+Proof.
+ intros; unfold get_forest;
+ destruct_match; auto; [ ];
+ match goal with
+ [ H : context[Rtree.get _ empty] |- _ ] => rewrite Rtree.gempty in H
+ end; discriminate.
+Qed.
+
+Fixpoint beq2 {A B : Type} (beqA : A -> B -> bool) (m1 : PTree.t A) (m2 : PTree.t B) {struct m1} : bool :=
+ match m1, m2 with
+ | PTree.Leaf, _ => PTree.bempty m2
+ | _, PTree.Leaf => PTree.bempty m1
+ | PTree.Node l1 o1 r1, PTree.Node l2 o2 r2 =>
+ match o1, o2 with
+ | None, None => true
+ | Some y1, Some y2 => beqA y1 y2
+ | _, _ => false
+ end
+ && beq2 beqA l1 l2 && beq2 beqA r1 r2
+ end.
+
+Lemma beq2_correct:
+ forall A B beqA m1 m2,
+ @beq2 A B beqA m1 m2 = true <->
+ (forall (x: PTree.elt),
+ match PTree.get x m1, PTree.get x m2 with
+ | None, None => True
+ | Some y1, Some y2 => beqA y1 y2 = true
+ | _, _ => False
+ end).
+Proof.
+ induction m1; intros.
+ - simpl. rewrite PTree.bempty_correct. split; intros.
+ rewrite PTree.gleaf. rewrite H. auto.
+ generalize (H x). rewrite PTree.gleaf. destruct (PTree.get x m2); tauto.
+ - destruct m2.
+ + unfold beq2. rewrite PTree.bempty_correct. split; intros.
+ rewrite H. rewrite PTree.gleaf. auto.
+ generalize (H x). rewrite PTree.gleaf.
+ destruct (PTree.get x (PTree.Node m1_1 o m1_2)); tauto.
+ + simpl. split; intros.
+ * destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0).
+ rewrite IHm1_1 in H3. rewrite IHm1_2 in H1.
+ destruct x; simpl. apply H1. apply H3.
+ destruct o; destruct o0; auto || congruence.
+ * apply andb_true_intro. split. apply andb_true_intro. split.
+ generalize (H xH); simpl. destruct o; destruct o0; tauto.
+ apply IHm1_1. intros; apply (H (xO x)).
+ apply IHm1_2. intros; apply (H (xI x)).
+Qed.
+
+Lemma map0:
+ forall r,
+ empty # r = Ebase r.
+Proof. intros; eapply get_empty. Qed.
+
+Lemma map1:
+ forall w dst dst',
+ dst <> dst' ->
+ (empty # dst <- w) # dst' = Ebase dst'.
+Proof. intros; unfold get_forest; rewrite Rtree.gso; auto; apply map0. Qed.
+
+Lemma genmap1:
+ forall (f : forest) w dst dst',
+ dst <> dst' ->
+ (f # dst <- w) # dst' = f # dst'.
+Proof. intros; unfold get_forest; rewrite Rtree.gso; auto. Qed.
+
+Lemma map2:
+ forall (v : expression) x rs,
+ (rs # x <- v) # x = v.
+Proof. intros; unfold get_forest; rewrite Rtree.gss; trivial. Qed.
+
+Lemma tri1:
+ forall x y,
+ Reg x <> Reg y -> x <> y.
+Proof. crush. Qed.
+
+Definition ge_preserved {A B C D: Type} (ge: Genv.t A B) (tge: Genv.t C D) : Prop :=
+ (forall sp op vl, Op.eval_operation ge sp op vl =
+ Op.eval_operation tge sp op vl)
+ /\ (forall sp addr vl, Op.eval_addressing ge sp addr vl =
+ Op.eval_addressing tge sp addr vl).
+
+Lemma ge_preserved_same:
+ forall A B ge, @ge_preserved A B A B ge ge.
+Proof. unfold ge_preserved; auto. Qed.
+Hint Resolve ge_preserved_same : rtlpar.
+
+Inductive sem_state_ld : sem_state -> sem_state -> Prop :=
+| sem_state_ld_intro:
+ forall rs rs' m m',
+ regs_lessdef rs rs' ->
+ m = m' ->
+ sem_state_ld (mk_sem_state rs m) (mk_sem_state rs' m').
+
+Lemma sems_det:
+ forall A ge tge sp st f,
+ ge_preserved ge tge ->
+ forall v v' mv mv',
+ (sem_value A ge sp st f v /\ sem_value A tge sp st f v' -> v = v') /\
+ (sem_mem A ge sp st f mv /\ sem_mem A tge sp st f mv' -> mv = mv').
+Proof. Admitted.
+
+Lemma sem_value_det:
+ forall A ge tge sp st f v v',
+ ge_preserved ge tge ->
+ sem_value A ge sp st f v ->
+ sem_value A tge sp st f v' ->
+ v = v'.
+Proof.
+ intros;
+ generalize (sems_det A ge tge sp st f H v v'
+ st.(sem_state_memory) st.(sem_state_memory));
+ crush.
+Qed.
+Hint Resolve sem_value_det : rtlpar.
+
+Lemma sem_value_det':
+ forall FF ge sp s f v v',
+ sem_value FF ge sp s f v ->
+ sem_value FF ge sp s f v' ->
+ v = v'.
+Proof.
+ simplify; eauto with rtlpar.
+Qed.
+
+Lemma sem_mem_det:
+ forall A ge tge sp st f m m',
+ ge_preserved ge tge ->
+ sem_mem A ge sp st f m ->
+ sem_mem A tge sp st f m' ->
+ m = m'.
+Proof.
+ intros;
+ generalize (sems_det A ge tge sp st f H sp sp m m');
+ crush.
+Qed.
+Hint Resolve sem_mem_det : rtlpar.
+
+Lemma sem_mem_det':
+ forall FF ge sp s f m m',
+ sem_mem FF ge sp s f m ->
+ sem_mem FF ge sp s f m' ->
+ m = m'.
+Proof.
+ simplify; eauto with rtlpar.
+Qed.
+
+Hint Resolve Val.lessdef_same : rtlpar.
+
+Lemma sem_regset_det:
+ forall FF ge tge sp st f v v',
+ ge_preserved ge tge ->
+ sem_regset FF ge sp st f v ->
+ sem_regset FF tge sp st f v' ->
+ regs_lessdef v v'.
+Proof.
+ intros; unfold regs_lessdef.
+ inv H0; inv H1;
+ eauto with rtlpar.
+Qed.
+Hint Resolve sem_regset_det : rtlpar.
+
+Lemma sem_det:
+ forall FF ge tge sp st f st' st'',
+ ge_preserved ge tge ->
+ sem FF ge sp st f st' ->
+ sem FF tge sp st f st'' ->
+ sem_state_ld st' st''.
+Proof.
+ intros.
+ destruct st; destruct st'; destruct st''.
+ inv H0; inv H1.
+ constructor; eauto with rtlpar.
+Qed.
+Hint Resolve sem_det : rtlpar.
+
+Lemma sem_det':
+ forall FF ge sp st f st' st'',
+ sem FF ge sp st f st' ->
+ sem FF ge sp st f st'' ->
+ sem_state_ld st' st''.
+Proof. eauto with rtlpar. Qed.
+
+(*|
+Update functions.
+|*)
+
+Fixpoint list_translation (l : list reg) (f : forest) {struct l} : expression_list :=
+ match l with
+ | nil => Enil
+ | i :: l => Econs (f # (Reg i)) (list_translation l f)
+ end.
+
+Definition update (f : forest) (i : instr) : forest :=
+ match i with
+ | RBnop => f
+ | RBop p op rl r =>
+ f # (Reg r) <- (Eop op (list_translation rl f))
+ | RBload p chunk addr rl r =>
+ f # (Reg r) <- (Eload chunk addr (list_translation rl f) (f # Mem))
+ | RBstore p chunk addr rl r =>
+ f # Mem <- (Estore (f # Mem) chunk addr (list_translation rl f) (f # (Reg r)))
+ | RBsetpred c addr p => f
+ end.
+
+(*|
+Implementing which are necessary to show the correctness of the translation validation by showing
+that there aren't any more effects in the resultant RTLPar code than in the RTLBlock code.
+
+Get a sequence from the basic block.
+|*)
+
+Fixpoint abstract_sequence (f : forest) (b : list instr) : forest :=
+ match b with
+ | nil => f
+ | i :: l => update (abstract_sequence f l) i
+ end.
+
+Fixpoint abstract_sequence_par (f : forest) (b : list (list instr)) : forest :=
+ match b with
+ | nil => f
+ | i :: l => abstract_sequence (abstract_sequence_par f l) i
+ end.
+
+(*|
+Check equivalence of control flow instructions. As none of the basic blocks should have been moved,
+none of the labels should be different, meaning the control-flow instructions should match exactly.
+|*)
+
+Definition check_control_flow_instr (c1 c2: cf_instr) : bool :=
+ if cf_instr_eq c1 c2 then true else false.
+
+(*|
+We define the top-level oracle that will check if two basic blocks are equivalent after a scheduling
+transformation.
+|*)
+
+Definition empty_trees (bb: RTLBlock.bb) (bbt: RTLPar.bb) : bool :=
+ match bb with
+ | nil =>
+ match bbt with
+ | nil => true
+ | _ => false
+ end
+ | _ => true
+ end.
+
+Definition schedule_oracle (bb: RTLBlock.bblock) (bbt: RTLPar.bblock) : bool :=
+ check (abstract_sequence empty (bb_body bb))
+ (abstract_sequence_par empty (bb_body bbt)) &&
+ check_control_flow_instr (bb_exit bb) (bb_exit bbt) &&
+ empty_trees (bb_body bb) (bb_body bbt).
+
+Definition check_scheduled_trees := beq2 schedule_oracle.
+
+Ltac solve_scheduled_trees_correct :=
+ intros; unfold check_scheduled_trees in *;
+ match goal with
+ | [ H: context[beq2 _ _ _], x: positive |- _ ] =>
+ rewrite beq2_correct in H; specialize (H x)
+ end; repeat destruct_match; crush.
+
+Lemma check_scheduled_trees_correct:
+ forall f1 f2,
+ check_scheduled_trees f1 f2 = true ->
+ (forall x y1,
+ PTree.get x f1 = Some y1 ->
+ exists y2, PTree.get x f2 = Some y2 /\ schedule_oracle y1 y2 = true).
+Proof. solve_scheduled_trees_correct; eexists; crush. Qed.
+
+Lemma check_scheduled_trees_correct2:
+ forall f1 f2,
+ check_scheduled_trees f1 f2 = true ->
+ (forall x,
+ PTree.get x f1 = None ->
+ PTree.get x f2 = None).
+Proof. solve_scheduled_trees_correct. Qed.
+
+(*|
+Abstract computations
+=====================
+|*)
+
+Lemma abstract_execution_correct:
+ forall bb bb' cfi ge tge sp rs m rs' m',
+ ge_preserved ge tge ->
+ schedule_oracle (mk_bblock bb cfi) (mk_bblock bb' cfi) = true ->
+ RTLBlock.step_instr_list ge sp (InstrState rs m) bb (InstrState rs' m') ->
+ exists rs'', RTLPar.step_instr_block tge sp (InstrState rs m) bb' (InstrState rs'' m')
+ /\ regs_lessdef rs' rs''.
+Proof. Admitted.
+
+(*|
+Top-level functions
+===================
+|*)
+
+Parameter schedule : RTLBlock.function -> RTLPar.function.
+
+Definition transl_function (f: RTLBlock.function) : Errors.res RTLPar.function :=
+ let tfcode := fn_code (schedule f) in
+ if check_scheduled_trees f.(fn_code) tfcode then
+ Errors.OK (mkfunction f.(fn_sig)
+ f.(fn_params)
+ f.(fn_stacksize)
+ tfcode
+ f.(fn_entrypoint))
+ else
+ Errors.Error (Errors.msg "RTLPargen: Could not prove the blocks equivalent.").
+
+Definition transl_function_temp (f: RTLBlock.function) : Errors.res RTLPar.function :=
+ let tfcode := fn_code (schedule f) in
+ Errors.OK (mkfunction f.(fn_sig)
+ f.(fn_params)
+ f.(fn_stacksize)
+ tfcode
+ f.(fn_entrypoint)).
+
+Definition transl_fundef := transf_partial_fundef transl_function_temp.
+
+Definition transl_program (p : RTLBlock.program) : Errors.res RTLPar.program :=
+ transform_partial_program transl_fundef p.
diff --git a/src/hls/RTLPargenproof.v b/src/hls/RTLPargenproof.v
new file mode 100644
index 0000000..eb7931e
--- /dev/null
+++ b/src/hls/RTLPargenproof.v
@@ -0,0 +1,288 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2021 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+Require Import compcert.backend.Registers.
+Require Import compcert.common.AST.
+Require Import compcert.common.Errors.
+Require Import compcert.common.Linking.
+Require Import compcert.common.Globalenvs.
+Require Import compcert.common.Memory.
+Require Import compcert.common.Values.
+Require Import compcert.lib.Maps.
+
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.RTLBlock.
+Require Import vericert.hls.RTLPar.
+Require Import vericert.hls.RTLBlockInstr.
+Require Import vericert.hls.RTLPargen.
+
+Definition match_prog (prog : RTLBlock.program) (tprog : RTLPar.program) :=
+ match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq prog tprog.
+
+Inductive match_stackframes: RTLBlock.stackframe -> RTLPar.stackframe -> Prop :=
+| match_stackframe:
+ forall f tf res sp pc rs rs',
+ transl_function f = OK tf ->
+ regs_lessdef rs rs' ->
+ match_stackframes (Stackframe res f sp pc rs)
+ (Stackframe res tf sp pc rs').
+
+Inductive match_states: RTLBlock.state -> RTLPar.state -> Prop :=
+| match_state:
+ forall sf f sp pc rs rs' m m' sf' tf
+ (TRANSL: transl_function f = OK tf)
+ (STACKS: list_forall2 match_stackframes sf sf')
+ (REG: regs_lessdef rs rs')
+ (MEM: Mem.extends m m'),
+ match_states (State sf f sp pc rs m)
+ (State sf' tf sp pc rs' m')
+| match_returnstate:
+ forall stack stack' v v' m m'
+ (STACKS: list_forall2 match_stackframes stack stack')
+ (MEM: Mem.extends m m')
+ (LD: Val.lessdef v v'),
+ match_states (Returnstate stack v m)
+ (Returnstate stack' v' m')
+| match_callstate:
+ forall stack stack' f tf args args' m m'
+ (TRANSL: transl_fundef f = OK tf)
+ (STACKS: list_forall2 match_stackframes stack stack')
+ (LD: Val.lessdef_list args args')
+ (MEM: Mem.extends m m'),
+ match_states (Callstate stack f args m)
+ (Callstate stack' tf args' m').
+
+Section CORRECTNESS.
+
+ Context (prog: RTLBlock.program) (tprog : RTLPar.program).
+ Context (TRANSL: match_prog prog tprog).
+
+ Let ge : RTLBlock.genv := Globalenvs.Genv.globalenv prog.
+ Let tge : RTLPar.genv := Globalenvs.Genv.globalenv tprog.
+
+ Lemma symbols_preserved:
+ forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+ Proof using TRANSL. intros. eapply (Genv.find_symbol_match TRANSL). Qed.
+ Hint Resolve symbols_preserved : rtlgp.
+
+ Lemma function_ptr_translated:
+ forall (b: Values.block) (f: RTLBlock.fundef),
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf,
+ Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Errors.OK tf.
+ Proof using TRANSL.
+ intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto.
+ intros (cu & tf & P & Q & R); exists tf; auto.
+ Qed.
+
+ Lemma functions_translated:
+ forall (v: Values.val) (f: RTLBlock.fundef),
+ Genv.find_funct ge v = Some f ->
+ exists tf,
+ Genv.find_funct tge v = Some tf /\ transl_fundef f = Errors.OK tf.
+ Proof using TRANSL.
+ intros. exploit (Genv.find_funct_match TRANSL); eauto.
+ intros (cu & tf & P & Q & R); exists tf; auto.
+ Qed.
+
+ Lemma senv_preserved:
+ Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge).
+ Proof (Genv.senv_transf_partial TRANSL).
+ Hint Resolve senv_preserved : rtlgp.
+
+ Lemma sig_transl_function:
+ forall (f: RTLBlock.fundef) (tf: RTLPar.fundef),
+ transl_fundef f = OK tf ->
+ funsig tf = funsig f.
+ Proof using .
+ unfold transl_fundef, transf_partial_fundef, transl_function; intros;
+ repeat destruct_match; crush;
+ match goal with H: OK _ = OK _ |- _ => inv H end; auto.
+ Qed.
+ Hint Resolve sig_transl_function : rtlgp.
+
+ Hint Resolve Val.lessdef_same : rtlgp.
+ Hint Resolve regs_lessdef_regs : rtlgp.
+
+ Lemma find_function_translated:
+ forall ros rs rs' f,
+ regs_lessdef rs rs' ->
+ find_function ge ros rs = Some f ->
+ exists tf, find_function tge ros rs' = Some tf
+ /\ transl_fundef f = OK tf.
+ Proof using TRANSL.
+ Ltac ffts := match goal with
+ | [ H: forall _, Val.lessdef _ _, r: Registers.reg |- _ ] =>
+ specialize (H r); inv H
+ | [ H: Vundef = ?r, H1: Genv.find_funct _ ?r = Some _ |- _ ] =>
+ rewrite <- H in H1
+ | [ H: Genv.find_funct _ Vundef = Some _ |- _] => solve [inv H]
+ | _ => solve [exploit functions_translated; eauto]
+ end.
+ unfold regs_lessdef; destruct ros; simplify; try rewrite <- H;
+ [| rewrite symbols_preserved; destruct_match;
+ try (apply function_ptr_translated); crush ];
+ intros;
+ repeat ffts.
+ Qed.
+
+ Lemma schedule_oracle_nil:
+ forall bb cfi,
+ schedule_oracle {| bb_body := nil; bb_exit := cfi |} bb = true ->
+ bb_body bb = nil /\ bb_exit bb = cfi.
+ Proof using .
+ unfold schedule_oracle, check_control_flow_instr.
+ simplify; repeat destruct_match; crush.
+ Qed.
+
+ Lemma schedule_oracle_nil2:
+ forall cfi,
+ schedule_oracle {| bb_body := nil; bb_exit := cfi |}
+ {| bb_body := nil; bb_exit := cfi |} = true.
+ Proof using .
+ unfold schedule_oracle, check_control_flow_instr.
+ simplify; repeat destruct_match; crush.
+ Qed.
+
+ Lemma eval_op_eq:
+ forall (sp0 : Values.val) (op : Op.operation) (vl : list Values.val),
+ Op.eval_operation ge sp0 op vl = Op.eval_operation tge sp0 op vl.
+ Proof using TRANSL.
+ intros.
+ destruct op; auto; unfold Op.eval_operation, Genv.symbol_address, Op.eval_addressing32;
+ [| destruct a; unfold Genv.symbol_address ];
+ try rewrite symbols_preserved; auto.
+ Qed.
+ Hint Resolve eval_op_eq : rtlgp.
+
+ Lemma eval_addressing_eq:
+ forall sp addr vl,
+ Op.eval_addressing ge sp addr vl = Op.eval_addressing tge sp addr vl.
+ Proof using TRANSL.
+ intros.
+ destruct addr;
+ unfold Op.eval_addressing, Op.eval_addressing32;
+ unfold Genv.symbol_address;
+ try rewrite symbols_preserved; auto.
+ Qed.
+ Hint Resolve eval_addressing_eq : rtlgp.
+
+ Lemma ge_preserved_lem:
+ ge_preserved ge tge.
+ Proof using TRANSL.
+ unfold ge_preserved.
+ eauto with rtlgp.
+ Qed.
+ Hint Resolve ge_preserved_lem : rtlgp.
+
+ Lemma lessdef_regmap_optget:
+ forall or rs rs',
+ regs_lessdef rs rs' ->
+ Val.lessdef (regmap_optget or Vundef rs) (regmap_optget or Vundef rs').
+ Proof using. destruct or; crush. Qed.
+ Hint Resolve lessdef_regmap_optget : rtlgp.
+
+ Lemma int_lessdef:
+ forall rs rs',
+ regs_lessdef rs rs' ->
+ (forall arg v,
+ rs !! arg = Vint v ->
+ rs' !! arg = Vint v).
+ Proof using. intros ? ? H; intros; specialize (H arg); inv H; crush. Qed.
+ Hint Resolve int_lessdef : rtlgp.
+
+ Ltac semantics_simpl :=
+ match goal with
+ | [ H: match_states _ _ |- _ ] =>
+ let H2 := fresh "H" in
+ learn H as H2; inv H2
+ | [ H: transl_function ?f = OK _ |- _ ] =>
+ let H2 := fresh "TRANSL" in
+ learn H as H2;
+ unfold transl_function in H2;
+ destruct (check_scheduled_trees
+ (@fn_code RTLBlock.bb f)
+ (@fn_code RTLPar.bb (schedule f))) eqn:?;
+ [| discriminate ]; inv H2
+ | [ H: context[check_scheduled_trees] |- _ ] =>
+ let H2 := fresh "CHECK" in
+ learn H as H2;
+ eapply check_scheduled_trees_correct in H2; [| solve [eauto] ]
+ | [ H: schedule_oracle {| bb_body := nil; bb_exit := _ |} ?bb = true |- _ ] =>
+ let H2 := fresh "SCHED" in
+ learn H as H2;
+ apply schedule_oracle_nil in H2
+ | [ H: find_function _ _ _ = Some _ |- _ ] =>
+ learn H; exploit find_function_translated; eauto; inversion 1
+ | [ H: Mem.free ?m _ _ _ = Some ?m', H2: Mem.extends ?m ?m'' |- _ ] =>
+ learn H; exploit Mem.free_parallel_extends; eauto; intros
+ | [ H: Events.eval_builtin_args _ _ _ _ _ _, H2: regs_lessdef ?rs ?rs' |- _ ] =>
+ let H3 := fresh "H" in
+ learn H; exploit Events.eval_builtin_args_lessdef; [apply H2 | | |];
+ eauto with rtlgp; intro H3; learn H3
+ | [ H: Events.external_call _ _ _ _ _ _ _ |- _ ] =>
+ let H2 := fresh "H" in
+ learn H; exploit Events.external_call_mem_extends;
+ eauto; intro H2; learn H2
+ | [ H: exists _, _ |- _ ] => inv H
+ | _ => progress simplify
+ end.
+
+ Hint Resolve Events.eval_builtin_args_preserved : rtlgp.
+ Hint Resolve Events.external_call_symbols_preserved : rtlgp.
+ Hint Resolve set_res_lessdef : rtlgp.
+ Hint Resolve set_reg_lessdef : rtlgp.
+ Hint Resolve Op.eval_condition_lessdef : rtlgp.
+
+ Lemma step_cf_instr_correct:
+ forall cfi t s s',
+ step_cf_instr ge s cfi t s' ->
+ forall r,
+ match_states s r ->
+ exists r', step_cf_instr tge r cfi t r' /\ match_states s' r'.
+ Proof using TRANSL.
+ induction 1; repeat semantics_simpl;
+ repeat (econstructor; eauto with rtlgp).
+ Qed.
+
+ Theorem transl_step_correct :
+ forall (S1 : RTLBlock.state) t S2,
+ RTLBlock.step ge S1 t S2 ->
+ forall (R1 : RTLPar.state),
+ match_states S1 R1 ->
+ exists R2, Smallstep.plus RTLPar.step tge R1 t R2 /\ match_states S2 R2.
+ Proof.
+
+ induction 1; repeat semantics_simpl.
+ Abort.
+
+(* { destruct bb as [bbc bbe]; destruct x as [bbc' bbe'].
+ assert (bbe = bbe') by admit.
+ rewrite H3 in H5.
+ eapply abstract_execution_correct in H5; eauto with rtlgp.
+ repeat econstructor; eauto with rtlgp. simplify.
+ exploit step_cf_instr_correct. eauto.
+ econstructor; eauto with rtlgp.
+ }
+ { unfold bind in *. destruct_match; try discriminate. repeat semantics_simpl. inv TRANSL0.
+ repeat econstructor; eauto. }
+ { inv TRANSL0. repeat econstructor; eauto using Events.external_call_symbols_preserved, symbols_preserved, senv_preserved, Events.E0_right. }
+ { inv STACKS. inv H2. repeat econstructor; eauto. }
+ Qed.*)
+
+End CORRECTNESS.
diff --git a/src/hls/Schedule.ml b/src/hls/Schedule.ml
new file mode 100644
index 0000000..b9ee741
--- /dev/null
+++ b/src/hls/Schedule.ml
@@ -0,0 +1,549 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+open Printf
+open Clflags
+open Camlcoq
+open Datatypes
+open Coqlib
+open Maps
+open AST
+open Kildall
+open Op
+open RTLBlockInstr
+open RTLBlock
+open HTL
+open Verilog
+open HTLgen
+open HTLMonad
+open HTLMonadExtra
+
+module SS = Set.Make(P)
+
+module IMap = Map.Make (struct
+ type t = int
+
+ let compare = compare
+end)
+
+type dfg = { nodes : instr list; edges : (int * int) list }
+(** The DFG type defines a list of instructions with their data dependencies as [edges], which are
+ the pairs of integers that represent the index of the instruction in the [nodes]. The edges
+ always point from left to right. *)
+
+let print_list f out_chan a =
+ fprintf out_chan "[ ";
+ List.iter (fprintf out_chan "%a " f) a;
+ fprintf out_chan "]"
+
+let print_tuple out_chan a =
+ let l, r = a in
+ fprintf out_chan "(%d,%d)" l r
+
+let print_dfg out_chan dfg =
+ fprintf out_chan "{ nodes = %a, edges = %a }"
+ (print_list PrintRTLBlockInstr.print_bblock_body)
+ dfg.nodes (print_list print_tuple) dfg.edges
+
+let read_process command =
+ let buffer_size = 2048 in
+ let buffer = Buffer.create buffer_size in
+ let string = Bytes.create buffer_size in
+ let in_channel = Unix.open_process_in command in
+ let chars_read = ref 1 in
+ while !chars_read <> 0 do
+ chars_read := input in_channel string 0 buffer_size;
+ Buffer.add_substring buffer (Bytes.to_string string) 0 !chars_read
+ done;
+ ignore (Unix.close_process_in in_channel);
+ Buffer.contents buffer
+
+(** Add a dependency if it uses a register that was written to previously. *)
+let add_dep i tree deps curr =
+ match PTree.get curr tree with None -> deps | Some ip -> (ip, i) :: deps
+
+(** This function calculates the dependencies of each instruction. The nodes correspond to previous
+ registers that were allocated and show which instruction caused it.
+
+ This function only gathers the RAW constraints, and will therefore only be active for operations
+ that modify registers, which is this case only affects loads and operations. *)
+let accumulate_RAW_deps dfg curr =
+ let i, dst_map, { edges; nodes } = dfg in
+ let acc_dep_instruction rs dst =
+ ( i + 1,
+ PTree.set dst i dst_map,
+ {
+ nodes;
+ edges = List.append (List.fold_left (add_dep i dst_map) [] rs) edges;
+ } )
+ in
+ let acc_dep_instruction_nodst rs =
+ ( i + 1,
+ dst_map,
+ {
+ nodes;
+ edges = List.append (List.fold_left (add_dep i dst_map) [] rs) edges;
+ } )
+ in
+ match curr with
+ | RBop (op, _, rs, dst) -> acc_dep_instruction rs dst
+ | RBload (op, _mem, _addr, rs, dst) -> acc_dep_instruction rs dst
+ | RBstore (op, _mem, _addr, rs, src) -> acc_dep_instruction_nodst (src :: rs)
+ | _ -> (i + 1, dst_map, { edges; nodes })
+
+(** Finds the next write to the [dst] register. This is a small optimisation so that only one
+ dependency is generated for a data dependency. *)
+let rec find_next_dst_write i dst i' curr =
+ let check_dst dst' curr' =
+ if dst = dst' then Some (i, i')
+ else find_next_dst_write i dst (i' + 1) curr'
+ in
+ match curr with
+ | [] -> None
+ | RBop (_, _, _, dst') :: curr' -> check_dst dst' curr'
+ | RBload (_, _, _, _, dst') :: curr' -> check_dst dst' curr'
+ | _ :: curr' -> find_next_dst_write i dst (i' + 1) curr'
+
+let rec find_all_next_dst_read i dst i' curr =
+ let check_dst rs curr' =
+ if List.exists (fun x -> x = dst) rs
+ then (i, i') :: find_all_next_dst_read i dst (i' + 1) curr'
+ else find_all_next_dst_read i dst (i' + 1) curr'
+ in
+ match curr with
+ | [] -> []
+ | RBop (_, _, rs, _) :: curr' -> check_dst rs curr'
+ | RBload (_, _, _, rs, _) :: curr' -> check_dst rs curr'
+ | RBstore (_, _, _, rs, src) :: curr' -> check_dst (src :: rs) curr'
+ | RBnop :: curr' -> find_all_next_dst_read i dst (i' + 1) curr'
+ | RBsetpred (_, rs, _) :: curr' -> check_dst rs curr'
+
+let drop i lst =
+ let rec drop' i' lst' =
+ match lst' with
+ | _ :: ls -> if i' = i then ls else drop' (i' + 1) ls
+ | [] -> []
+ in
+ if i = 0 then lst else drop' 1 lst
+
+let take i lst =
+ let rec take' i' lst' =
+ match lst' with
+ | l :: ls -> if i' = i then [ l ] else l :: take' (i' + 1) ls
+ | [] -> []
+ in
+ if i = 0 then [] else take' 1 lst
+
+let rec next_store i = function
+ | [] -> None
+ | RBstore (_, _, _, _, _) :: _ -> Some i
+ | _ :: rst -> next_store (i + 1) rst
+
+let rec next_load i = function
+ | [] -> None
+ | RBload (_, _, _, _, _) :: _ -> Some i
+ | _ :: rst -> next_load (i + 1) rst
+
+let accumulate_RAW_mem_deps dfg curr =
+ let i, { nodes; edges } = dfg in
+ match curr with
+ | RBload (_, _, _, _, _) -> (
+ match next_store 0 (take i nodes |> List.rev) with
+ | None -> (i + 1, { nodes; edges })
+ | Some d -> (i + 1, { nodes; edges = (i - d - 1, i) :: edges }) )
+ | _ -> (i + 1, { nodes; edges })
+
+let accumulate_WAR_mem_deps dfg curr =
+ let i, { nodes; edges } = dfg in
+ match curr with
+ | RBstore (_, _, _, _, _) -> (
+ match next_load 0 (take i nodes |> List.rev) with
+ | None -> (i + 1, { nodes; edges })
+ | Some d -> (i + 1, { nodes; edges = (i - d - 1, i) :: edges }) )
+ | _ -> (i + 1, { nodes; edges })
+
+let accumulate_WAW_mem_deps dfg curr =
+ let i, { nodes; edges } = dfg in
+ match curr with
+ | RBstore (_, _, _, _, _) -> (
+ match next_store 0 (take i nodes |> List.rev) with
+ | None -> (i + 1, { nodes; edges })
+ | Some d -> (i + 1, { nodes; edges = (i - d - 1, i) :: edges }) )
+ | _ -> (i + 1, { nodes; edges })
+
+(** Predicate dependencies. *)
+
+let rec in_predicate p p' =
+ match p' with
+ | Pvar p'' -> Nat.to_int p = Nat.to_int p''
+ | Pnot p'' -> in_predicate p p''
+ | Pand (p1, p2) -> in_predicate p p1 || in_predicate p p2
+ | Por (p1, p2) -> in_predicate p p1 || in_predicate p p2
+
+let rec get_predicate = function
+ | RBop (p, _, _, _) -> p
+ | RBload (p, _, _, _, _) -> p
+ | RBstore (p, _, _, _, _) -> p
+ | _ -> None
+
+let rec next_setpred p i = function
+ | [] -> None
+ | RBsetpred (_, _, p') :: rst ->
+ if in_predicate p' p then
+ Some i
+ else
+ next_setpred p (i + 1) rst
+ | _ :: rst -> next_setpred p (i + 1) rst
+
+let rec next_preduse p i instr=
+ let next p' rst =
+ if in_predicate p p' then
+ Some i
+ else
+ next_preduse p (i + 1) rst
+ in
+ match instr with
+ | [] -> None
+ | RBload (Some p', _, _, _, _) :: rst -> next p' rst
+ | RBstore (Some p', _, _, _, _) :: rst -> next p' rst
+ | RBop (Some p', _, _, _) :: rst -> next p' rst
+ | _ :: rst -> next_load (i + 1) rst
+
+let accumulate_RAW_pred_deps dfg curr =
+ let i, { nodes; edges } = dfg in
+ match get_predicate curr with
+ | Some p -> (
+ match next_setpred p 0 (take i nodes |> List.rev) with
+ | None -> (i + 1, { nodes; edges })
+ | Some d -> (i + 1, { nodes; edges = (i - d - 1, i) :: edges }) )
+ | _ -> (i + 1, { nodes; edges })
+
+let accumulate_WAR_pred_deps dfg curr =
+ let i, { nodes; edges } = dfg in
+ match curr with
+ | RBsetpred (_, _, p) -> (
+ match next_preduse p 0 (take i nodes |> List.rev) with
+ | None -> (i + 1, { nodes; edges })
+ | Some d -> (i + 1, { nodes; edges = (i - d - 1, i) :: edges }) )
+ | _ -> (i + 1, { nodes; edges })
+
+let accumulate_WAW_pred_deps dfg curr =
+ let i, { nodes; edges } = dfg in
+ match curr with
+ | RBsetpred (_, _, p) -> (
+ match next_setpred (Pvar p) 0 (take i nodes |> List.rev) with
+ | None -> (i + 1, { nodes; edges })
+ | Some d -> (i + 1, { nodes; edges = (i - d - 1, i) :: edges }) )
+ | _ -> (i + 1, { nodes; edges })
+
+(** This function calculates the WAW dependencies, which happen when two writes are ordered one
+ after another and therefore have to be kept in that order. This accumulation might be redundant
+ if register renaming is done before hand, because then these dependencies can be avoided. *)
+let accumulate_WAW_deps dfg curr =
+ let i, { edges; nodes } = dfg in
+ let dst_dep dst =
+ match find_next_dst_write i dst (i + 1) (drop (i + 1) nodes) with
+ | Some d -> (i + 1, { nodes; edges = d :: edges })
+ | _ -> (i + 1, { nodes; edges })
+ in
+ match curr with
+ | RBop (_, _, _, dst) -> dst_dep dst
+ | RBload (_, _, _, _, dst) -> dst_dep dst
+ | RBstore (_, _, _, _, _) -> (
+ match next_store (i + 1) (drop (i + 1) nodes) with
+ | None -> (i + 1, { nodes; edges })
+ | Some i' -> (i + 1, { nodes; edges = (i, i') :: edges }) )
+ | _ -> (i + 1, { nodes; edges })
+
+let accumulate_WAR_deps dfg curr =
+ let i, { edges; nodes } = dfg in
+ let dst_dep dst =
+ let dep_list = find_all_next_dst_read i dst 0 (take i nodes |> List.rev)
+ |> List.map (function (d, d') -> (i - d' - 1, d))
+ in
+ (i + 1, { nodes; edges = List.append dep_list edges })
+ in
+ match curr with
+ | RBop (_, _, _, dst) -> dst_dep dst
+ | RBload (_, _, _, _, dst) -> dst_dep dst
+ | _ -> (i + 1, { nodes; edges })
+
+let assigned_vars vars = function
+ | RBnop -> vars
+ | RBop (_, _, _, dst) -> dst :: vars
+ | RBload (_, _, _, _, dst) -> dst :: vars
+ | RBstore (_, _, _, _, _) -> vars
+ | RBsetpred (_, _, _) -> vars
+
+let get_pred = function
+ | RBnop -> None
+ | RBop (op, _, _, _) -> op
+ | RBload (op, _, _, _, _) -> op
+ | RBstore (op, _, _, _, _) -> op
+ | RBsetpred (_, _, _) -> None
+
+let independant_pred p p' =
+ match sat_pred_temp (Nat.of_int 100000) (Pand (p, p')) with
+ | Some None -> true
+ | _ -> false
+
+let check_dependent op1 op2 =
+ match op1, op2 with
+ | Some p, Some p' -> not (independant_pred p p')
+ | _, _ -> true
+
+let remove_unnecessary_deps dfg =
+ let { edges; nodes } = dfg in
+ let is_dependent = function (i1, i2) ->
+ let instr1 = List.nth nodes i1 in
+ let instr2 = List.nth nodes i2 in
+ check_dependent (get_pred instr1) (get_pred instr2)
+ in
+ { edges = List.filter is_dependent edges; nodes }
+
+(** All the nodes in the DFG have to come after the source of the basic block, and should terminate
+ before the sink of the basic block. After that, there should be constraints for data
+ dependencies between nodes. *)
+let gather_bb_constraints debug bb =
+ let _, _, dfg =
+ List.fold_left accumulate_RAW_deps
+ (0, PTree.empty, { nodes = bb.bb_body; edges = [] })
+ bb.bb_body
+ in
+ if debug then printf "DFG : %a\n" print_dfg dfg else ();
+ let _, dfg1 = List.fold_left accumulate_WAW_deps (0, dfg) bb.bb_body in
+ if debug then printf "DFG': %a\n" print_dfg dfg1 else ();
+ let _, dfg2 = List.fold_left accumulate_WAR_deps (0, dfg1) bb.bb_body in
+ if debug then printf "DFG'': %a\n" print_dfg dfg2 else ();
+ let _, dfg3 =
+ List.fold_left accumulate_RAW_mem_deps (0, dfg2) bb.bb_body
+ in
+ if debug then printf "DFG''': %a\n" print_dfg dfg3 else ();
+ let _, dfg4 =
+ List.fold_left accumulate_WAR_mem_deps (0, dfg3) bb.bb_body
+ in
+ if debug then printf "DFG'''': %a\n" print_dfg dfg4 else ();
+ let _, dfg5 =
+ List.fold_left accumulate_WAW_mem_deps (0, dfg4) bb.bb_body
+ in
+ let _, dfg6 =
+ List.fold_left accumulate_RAW_pred_deps (0, dfg5) bb.bb_body
+ in
+ let _, dfg7 =
+ List.fold_left accumulate_WAR_pred_deps (0, dfg6) bb.bb_body
+ in
+ let _, dfg8 =
+ List.fold_left accumulate_WAW_pred_deps (0, dfg7) bb.bb_body
+ in
+ let dfg9 = remove_unnecessary_deps dfg8 in
+ if debug then printf "DFG''''': %a\n" print_dfg dfg9 else ();
+ (List.length bb.bb_body, dfg9, successors_instr bb.bb_exit)
+
+let gen_bb_name s i = sprintf "bb%d%s" (P.to_int i) s
+
+let gen_bb_name_ssrc = gen_bb_name "ssrc"
+
+let gen_bb_name_ssnk = gen_bb_name "ssnk"
+
+let gen_var_name s c i = sprintf "v%d%s_%d" (P.to_int i) s c
+
+let gen_var_name_b = gen_var_name "b"
+
+let gen_var_name_e = gen_var_name "e"
+
+let print_lt0 = sprintf "%s - %s <= 0;\n"
+
+let print_bb_order i c = if P.to_int c < P.to_int i then
+ print_lt0 (gen_bb_name_ssnk i) (gen_bb_name_ssrc c) else
+ ""
+
+let print_src_order i c =
+ print_lt0 (gen_bb_name_ssrc i) (gen_var_name_b c i)
+ ^ print_lt0 (gen_var_name_e c i) (gen_bb_name_ssnk i)
+ ^ sprintf "%s - %s = 1;\n" (gen_var_name_e c i) (gen_var_name_b c i)
+
+let print_src_type i c =
+ sprintf "int %s;\n" (gen_var_name_e c i)
+ ^ sprintf "int %s;\n" (gen_var_name_b c i)
+
+let print_data_dep_order c (i, j) =
+ print_lt0 (gen_var_name_e i c) (gen_var_name_b j c)
+
+let gather_cfg_constraints (completed, (bvars, constraints, types)) c curr =
+ if List.exists (P.eq curr) completed then
+ (completed, (bvars, constraints, types))
+ else
+ match PTree.get curr c with
+ | None -> assert false
+ | Some (num_iters, dfg, next) ->
+ let constraints' =
+ constraints
+ ^ String.concat "" (List.map (print_bb_order curr) next)
+ ^ String.concat ""
+ (List.map (print_src_order curr)
+ (List.init num_iters (fun x -> x)))
+ ^ String.concat "" (List.map (print_data_dep_order curr) dfg.edges)
+ in
+ let types' =
+ types
+ ^ String.concat ""
+ (List.map (print_src_type curr)
+ (List.init num_iters (fun x -> x)))
+ ^ sprintf "int %s;\n" (gen_bb_name_ssrc curr)
+ ^ sprintf "int %s;\n" (gen_bb_name_ssnk curr)
+ in
+ let bvars' =
+ List.append
+ (List.map
+ (fun x -> gen_var_name_b x curr)
+ (List.init num_iters (fun x -> x)))
+ bvars
+ in
+ (curr :: completed, (bvars', constraints', types'))
+
+let rec intersperse s = function
+ | [] -> []
+ | [ a ] -> [ a ]
+ | x :: xs -> x :: s :: intersperse s xs
+
+let update_schedule v = function Some l -> Some (v :: l) | None -> Some [ v ]
+
+let parse_soln tree s =
+ let r = Str.regexp "v\\([0-9]+\\)b_\\([0-9]+\\)[ ]+\\([0-9]+\\)" in
+ if Str.string_match r s 0 then
+ IMap.update
+ (Str.matched_group 1 s |> int_of_string)
+ (update_schedule
+ ( Str.matched_group 2 s |> int_of_string,
+ Str.matched_group 3 s |> int_of_string ))
+ tree
+ else tree
+
+let solve_constraints vars constraints types =
+ let oc = open_out "lpsolve.txt" in
+ fprintf oc "min: ";
+ List.iter (fprintf oc "%s") (intersperse " + " vars);
+ fprintf oc ";\n";
+ fprintf oc "%s" constraints;
+ fprintf oc "%s" types;
+ close_out oc;
+ Str.split (Str.regexp_string "\n") (read_process "lp_solve lpsolve.txt")
+ |> drop 3
+ |> List.fold_left parse_soln IMap.empty
+
+let find_min = function
+ | [] -> assert false
+ | l :: ls ->
+ let rec find_min' current = function
+ | [] -> current
+ | l' :: ls' ->
+ if snd l' < current then find_min' (snd l') ls'
+ else find_min' current ls'
+ in
+ find_min' (snd l) ls
+
+let find_max = function
+ | [] -> assert false
+ | l :: ls ->
+ let rec find_max' current = function
+ | [] -> current
+ | l' :: ls' ->
+ if snd l' > current then find_max' (snd l') ls'
+ else find_max' current ls'
+ in
+ find_max' (snd l) ls
+
+let ( >>= ) = bind
+
+let combine_bb_schedule schedule s =
+ let i, st = s in
+ IMap.update st (update_schedule i) schedule
+
+let compare_tuple (a, _) (b, _) = compare a b
+
+(** Should generate the [RTLPar] code based on the input [RTLBlock] description. *)
+let transf_rtlpar c (schedule : (int * int) list IMap.t) =
+ let f i bb : RTLPar.bblock =
+ match bb with
+ | { bb_body = []; bb_exit = c } ->
+ { bb_body = [];
+ bb_exit = c
+ }
+ | { bb_body = bb_body'; bb_exit = ctrl_flow } ->
+ let i_sched =
+ try IMap.find (P.to_int i) schedule
+ with Not_found -> (
+ printf "Could not find %d\n" (P.to_int i);
+ IMap.iter
+ (fun d -> printf "%d: %a\n" d (print_list print_tuple))
+ schedule;
+ assert false
+ )
+ in
+ let min_state = find_min i_sched in
+ let max_state = find_max i_sched in
+ let i_sched_tree =
+ List.fold_left combine_bb_schedule IMap.empty i_sched
+ in
+ (*printf "--------------- curr: %d, max: %d, min: %d, next: %d\n" (P.to_int i) max_state min_state (P.to_int i - max_state + min_state - 1);
+ printf "HIIIII: %d orig: %d\n" (P.to_int i - max_state + min_state - 1) (P.to_int i);*)
+ { bb_body = (IMap.to_seq i_sched_tree |> List.of_seq |> List.sort compare_tuple |> List.map snd
+ |> List.map (List.map (fun x -> List.nth bb_body' x)));
+ bb_exit = ctrl_flow
+ }
+ in
+ PTree.map f c
+
+let second = function (_, a, _) -> a
+
+let schedule entry (c : RTLBlock.bb RTLBlockInstr.code) =
+ let debug = false in
+ let c' = PTree.map1 (gather_bb_constraints false) c in
+ (*let _ = if debug then PTree.map (fun r o -> printf "##### %d #####\n%a\n\n" (P.to_int r) print_dfg (second o)) c' else PTree.empty in*)
+ let _, (vars, constraints, types) =
+ List.map fst (PTree.elements c') |>
+ List.fold_left (fun compl ->
+ gather_cfg_constraints compl c') ([], ([], "", ""))
+ in
+ let schedule' = solve_constraints vars constraints types in
+ (*IMap.iter (fun a b -> printf "##### %d #####\n%a\n\n" a (print_list print_tuple) b) schedule';*)
+ (*printf "Schedule: %a\n" (fun a x -> IMap.iter (fun d -> fprintf a "%d: %a\n" d (print_list print_tuple)) x) schedule';*)
+ transf_rtlpar c schedule'
+
+let rec find_reachable_states c e =
+ match PTree.get e c with
+ | Some { bb_exit = ex; _ } ->
+ e :: List.fold_left (fun x a -> List.concat [x; find_reachable_states c a]) []
+ (successors_instr ex |> List.filter (fun x -> P.lt x e))
+ | None -> assert false
+
+let add_to_tree c nt i =
+ match PTree.get i c with
+ | Some p -> PTree.set i p nt
+ | None -> assert false
+
+let schedule_fn (f : RTLBlock.coq_function) : RTLPar.coq_function =
+ let scheduled = schedule f.fn_entrypoint f.fn_code in
+ let reachable = find_reachable_states scheduled f.fn_entrypoint
+ |> List.to_seq |> SS.of_seq |> SS.to_seq |> List.of_seq in
+ { fn_sig = f.fn_sig;
+ fn_params = f.fn_params;
+ fn_stacksize = f.fn_stacksize;
+ fn_code = List.fold_left (add_to_tree scheduled) PTree.empty reachable;
+ fn_entrypoint = f.fn_entrypoint
+ }
diff --git a/src/verilog/Value.v b/src/hls/Value.v
index d6a3d8b..0d3ea66 100644
--- a/src/verilog/Value.v
+++ b/src/hls/Value.v
@@ -1,4 +1,4 @@
-(*
+(*(*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
*
@@ -549,3 +549,4 @@ Proof.
apply Nat2Z.inj_lt in H2.
assumption.
Qed.
+*)
diff --git a/src/verilog/ValueInt.v b/src/hls/ValueInt.v
index f1fd056..e434abc 100644
--- a/src/verilog/ValueInt.v
+++ b/src/hls/ValueInt.v
@@ -17,8 +17,6 @@
*)
(* begin hide *)
-From bbv Require Import Word.
-From bbv Require HexNotation WordScope.
From Coq Require Import ZArith.ZArith FSets.FMapPositive Lia.
From compcert Require Import lib.Integers common.Values.
From vericert Require Import Vericertlib.
@@ -98,14 +96,6 @@ Definition boolToValue (b : bool) : value :=
(** ** Arithmetic operations *)
-Definition unify_word (sz1 sz2 : nat) (w1 : word sz2): sz1 = sz2 -> word sz1.
-intros; subst; assumption. Defined.
-
-Lemma unify_word_unfold :
- forall sz w,
- unify_word sz sz w eq_refl = w.
-Proof. auto. Qed.
-
Inductive val_value_lessdef: val -> value -> Prop :=
| val_value_lessdef_int:
forall i v',
diff --git a/src/hls/ValueVal.v b/src/hls/ValueVal.v
new file mode 100644
index 0000000..96e0b1c
--- /dev/null
+++ b/src/hls/ValueVal.v
@@ -0,0 +1,207 @@
+(*
+ * Vericert: Verified high-level synthesis.
+ * Copyright (C) 2020 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
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program. If not, see <https://www.gnu.org/licenses/>.
+ *)
+
+(* begin hide *)
+From Coq Require Import ZArith.ZArith FSets.FMapPositive Lia.
+From compcert Require Export lib.Integers common.Values.
+From vericert Require Import Vericertlib.
+(* end hide *)
+
+(** * Value
+
+A [value] is a bitvector with a specific size. We are using the implementation
+of the bitvector by mit-plv/bbv, because it has many theorems that we can reuse.
+However, we need to wrap it with an [Inductive] so that we can specify and match
+on the size of the [value]. This is necessary so that we can easily store
+[value]s of different sizes in a list or in a map.
+
+Using the default [word], this would not be possible, as the size is part of the type. *)
+
+(* Definition value : Type := val.
+
+(** ** Value conversions
+
+Various conversions to different number types such as [N], [Z], [positive] and
+[int], where the last one is a theory of integers of powers of 2 in CompCert. *)
+
+Definition valueToNat (v : value) : nat :=
+ match v with
+ | value_bool b => Nat.b2n b
+ | value_int i => Z.to_nat (Int.unsigned i)
+ | value_int64 i => Z.to_nat (Int64.unsigned i)
+ end.
+
+Definition natToValue (n : nat) : value :=
+ value_int (Int.repr (Z.of_nat n)).
+
+Definition natToValue64 (n : nat) : value :=
+ value_int64 (Int64.repr (Z.of_nat n)).
+
+Definition valueToN (v : value) : N :=
+ match v with
+ | value_bool b => N.b2n b
+ | value_int i => Z.to_N (Int.unsigned i)
+ | value_int64 i => Z.to_N (Int64.unsigned i)
+ end.
+
+Definition NToValue (n : N) : value :=
+ value_int (Int.repr (Z.of_N n)).
+
+Definition NToValue64 (n : N) : value :=
+ value_int64 (Int64.repr (Z.of_N n)).
+
+Definition ZToValue (z : Z) : value :=
+ value_int (Int.repr z).
+
+Definition ZToValue64 (z : Z) : value :=
+ value_int64 (Int64.repr z).
+
+Definition valueToZ (v : value) : Z :=
+ match v with
+ | value_bool b => Z.b2z b
+ | value_int i => Int.signed i
+ | value_int64 i => Int64.signed i
+ end.
+
+Definition uvalueToZ (v : value) : Z :=
+ match v with
+ | value_bool b => Z.b2z b
+ | value_int i => Int.unsigned i
+ | value_int64 i => Int64.unsigned i
+ end.
+
+Definition posToValue (p : positive) : value :=
+ value_int (Int.repr (Z.pos p)).
+
+Definition posToValue64 (p : positive) : value :=
+ value_int64 (Int64.repr (Z.pos p)).
+
+Definition valueToPos (v : value) : positive :=
+ match v with
+ | value_bool b => 1%positive
+ | value_int i => Z.to_pos (Int.unsigned i)
+ | value_int64 i => Z.to_pos (Int64.unsigned i)
+ end.
+
+Definition intToValue (i : Integers.int) : value := value_int i.
+
+Definition int64ToValue (i : Integers.int64) : value := value_int64 i.
+
+Definition valueToInt (v : value) : Integers.int :=
+ match v with
+ | value_bool b => Int.repr (if b then 1 else 0)
+ | value_int i => i
+ | value_int64 i => Int.repr (Int64.unsigned i)
+ end.
+
+(*Definition ptrToValue (i : ptrofs) : value :=
+ value_int (Ptrofs.to_int i).
+
+Definition valueToPtr (i : value) : Integers.ptrofs :=
+ Ptrofs.of_int i.
+
+Definition valToValue (v : Values.val) : option value :=
+ match v with
+ | Values.Vint i => Some (intToValue i)
+ | Values.Vint64 i => Some (intToValue i)
+ | Values.Vptr b off => Some (ptrToValue off)
+ | Values.Vundef => Some (ZToValue 0%Z)
+ | _ => None
+ end.
+
+(** Convert a [value] to a [bool], so that choices can be made based on the
+result. This is also because comparison operators will give back [value] instead
+of [bool], so if they are in a condition, they will have to be converted before
+they can be used. *)
+
+Definition valueToBool (v : value) : bool :=
+ if Z.eqb (uvalueToZ v) 0 then false else true.
+
+Definition boolToValue (b : bool) : value :=
+ natToValue (if b then 1 else 0).
+
+(** ** Arithmetic operations *)
+
+Definition unify_word (sz1 sz2 : nat) (w1 : word sz2): sz1 = sz2 -> word sz1.
+intros; subst; assumption. Defined.
+
+Lemma unify_word_unfold :
+ forall sz w,
+ unify_word sz sz w eq_refl = w.
+Proof. auto. Qed.
+
+Inductive val_value_lessdef: val -> value -> Prop :=
+| val_value_lessdef_int:
+ forall i v',
+ i = valueToInt v' ->
+ val_value_lessdef (Vint i) v'
+| val_value_lessdef_ptr:
+ forall b off v',
+ off = valueToPtr v' ->
+ val_value_lessdef (Vptr b off) v'
+| lessdef_undef: forall v, val_value_lessdef Vundef v.
+
+Inductive opt_val_value_lessdef: option val -> value -> Prop :=
+| opt_lessdef_some:
+ forall v v', val_value_lessdef v v' -> opt_val_value_lessdef (Some v) v'
+| opt_lessdef_none: forall v, opt_val_value_lessdef None v.
+
+Lemma valueToZ_ZToValue :
+ forall z,
+ (Int.min_signed <= z <= Int.max_signed)%Z ->
+ valueToZ (ZToValue z) = z.
+Proof. auto using Int.signed_repr. Qed.
+
+Lemma uvalueToZ_ZToValue :
+ forall z,
+ (0 <= z <= Int.max_unsigned)%Z ->
+ uvalueToZ (ZToValue z) = z.
+Proof. auto using Int.unsigned_repr. Qed.
+
+Lemma valueToPos_posToValue :
+ forall v,
+ 0 <= Z.pos v <= Int.max_unsigned ->
+ valueToPos (posToValue v) = v.
+Proof.
+ unfold valueToPos, posToValue.
+ intros. rewrite Int.unsigned_repr.
+ apply Pos2Z.id. assumption.
+Qed.
+
+Lemma valueToInt_intToValue :
+ forall v,
+ valueToInt (intToValue v) = v.
+Proof. auto. Qed.
+
+Lemma valToValue_lessdef :
+ forall v v',
+ valToValue v = Some v' ->
+ val_value_lessdef v v'.
+Proof.
+ intros.
+ destruct v; try discriminate; constructor.
+ unfold valToValue in H. inversion H.
+ unfold valueToInt. unfold intToValue in H1. auto.
+ inv H. symmetry. unfold valueToPtr, ptrToValue. apply Ptrofs.of_int_to_int. trivial.
+Qed.
+
+Ltac simplify_val := repeat (simplify; unfold uvalueToZ, valueToPtr, Ptrofs.of_int, valueToInt, intToValue,
+ ptrToValue in *)
+
+(*Ltac crush_val := simplify_val; try discriminate; try congruence; try lia; liapp; try assumption.*)
+*)
diff --git a/src/verilog/Verilog.v b/src/hls/Verilog.v
index e5583fc..ca5abd4 100644
--- a/src/verilog/Verilog.v
+++ b/src/hls/Verilog.v
@@ -1,6 +1,7 @@
(*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2019-2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2020 James Pollard <j@mes.dev>
*
* 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
@@ -29,7 +30,7 @@ Require Import Lia.
Import ListNotations.
-From vericert Require Import common.Vericertlib common.Show verilog.ValueInt AssocMap Array.
+From vericert Require Import Vericertlib Show ValueInt AssocMap Array.
From compcert Require Events.
From compcert Require Import Integers Errors Smallstep Globalenvs.
@@ -149,7 +150,7 @@ Inductive binop : Type :=
(** ** Unary Operators *)
Inductive unop : Type :=
-| Vneg (** negation ([~]) *)
+| Vneg (** negation ([-]) *)
| Vnot. (** not operation [!] *)
(** ** Expressions *)
@@ -158,6 +159,7 @@ Inductive expr : Type :=
| Vlit : value -> expr
| Vvar : reg -> expr
| Vvari : reg -> expr -> expr
+| Vrange : reg -> expr -> expr -> expr
| Vinputvar : reg -> expr
| Vbinop : binop -> expr -> expr -> expr
| Vunop : unop -> expr -> expr
@@ -793,6 +795,7 @@ Proof.
| [ H : expr_runp _ _ _ (Vbinop _ _ _) _ |- _ ] => invert H
| [ H : expr_runp _ _ _ (Vunop _ _) _ |- _ ] => invert H
| [ H : expr_runp _ _ _ (Vternary _ _ _) _ |- _ ] => invert H
+ | [ H : expr_runp _ _ _ (Vrange _ _ _) _ |- _ ] => invert H
| [ H1 : forall asr asa v, expr_runp _ asr asa ?e v -> _,
H2 : expr_runp _ _ _ ?e _ |- _ ] =>
diff --git a/src/translation/Veriloggen.v b/src/hls/Veriloggen.v
index 009571f..a7a8c2a 100644
--- a/src/translation/Veriloggen.v
+++ b/src/hls/Veriloggen.v
@@ -1,6 +1,7 @@
(*
* Vericert: Verified high-level synthesis.
* Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
+ * 2021 Michalis Pardalos <mpardalos@gmail.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,11 +17,16 @@
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*)
-From compcert Require Import Maps.
-From compcert Require Import Errors.
-From compcert Require Import AST.
-From vericert Require Import Vericertlib AssocMap ValueInt Statemonad Maps.
-From vericert Require Import HTL Verilog.
+Require Import compcert.common.AST.
+Require Import compcert.common.Errors.
+
+Require Import vericert.common.Maps.
+Require Import vericert.common.Statemonad.
+Require Import vericert.common.Vericertlib.
+Require Import vericert.hls.AssocMap.
+Require Import vericert.hls.HTL.
+Require Import vericert.hls.ValueInt.
+Require Import vericert.hls.Verilog.
Import ListNotations.
Local Open Scope error_monad_scope.
@@ -112,6 +118,11 @@ Section RENUMBER.
do e2' <- renumber_expr e2;
do e3' <- renumber_expr e3;
ret (Vternary e1' e2' e3')
+ | Vrange r e1 e2 =>
+ do e1' <- renumber_expr e1;
+ do e2' <- renumber_expr e2;
+ do r' <- renumber_reg r;
+ ret (Vrange r e1 e2)
end.
Fixpoint renumber_stmnt (stmnt : Verilog.stmnt) :=
diff --git a/src/translation/Veriloggenproof.v b/src/hls/Veriloggenproof.v
index 59267f7..59267f7 100644
--- a/src/translation/Veriloggenproof.v
+++ b/src/hls/Veriloggenproof.v
generated by cgit (git 2.34.1) at 2024-07-02 17:18:29 +0000