diff options
Diffstat (limited to 'src')
39 files changed, 9229 insertions, 1538 deletions
diff --git a/src/Compiler.v b/src/Compiler.v index e9d76dc..ff0938e 100644 --- a/src/Compiler.v +++ b/src/Compiler.v @@ -65,11 +65,13 @@ Require vericert.hls.HTLgen. Require vericert.hls.RTLBlock. Require vericert.hls.RTLBlockgen. Require vericert.hls.RTLPargen. +Require vericert.hls.RTLParFUgen. Require vericert.hls.HTLPargen. Require vericert.hls.Pipeline. Require vericert.hls.IfConversion. -Require vericert.hls.PipelineOp. +(*Require vericert.hls.PipelineOp.*) Require vericert.HLSOpts. +Require vericert.hls.Memorygen. Require Import vericert.hls.HTLgenproof. @@ -81,7 +83,7 @@ We then need to declare the external OCaml functions used to print out intermedi |*) Parameter print_RTL: Z -> RTL.program -> unit. -Parameter print_HTL: HTL.program -> unit. +Parameter print_HTL: Z -> HTL.program -> unit. Parameter print_RTLBlock: Z -> RTLBlock.program -> unit. Parameter print_RTLPar: Z -> RTLPar.program -> unit. @@ -192,7 +194,9 @@ Definition transf_backend (r : RTL.program) : res Verilog.program := @@@ time "Unused globals" Unusedglob.transform_program @@ print (print_RTL 7) @@@ HTLgen.transl_program - @@ print print_HTL + @@ print (print_HTL 0) + @@ total_if HLSOpts.optim_ram Memorygen.transf_program + @@ print (print_HTL 1) @@ Veriloggen.transl_program. (*| @@ -214,6 +218,8 @@ Definition transf_hls (p : Csyntax.program) : res Verilog.program := .. coq:: none |*) +(* This is an unverified version of transf_hls with some experimental additions such as scheduling +that aren't completed yet. *) Definition transf_hls_temp (p : Csyntax.program) : res Verilog.program := OK p @@@ SimplExpr.transl_program @@ -237,15 +243,14 @@ Definition transf_hls_temp (p : Csyntax.program) : res Verilog.program := @@@ time "Unused globals" Unusedglob.transform_program @@ print (print_RTL 7) @@@ RTLBlockgen.transl_program - @@ print (print_RTLBlock 1) + @@ print (print_RTLBlock 0) @@ total_if HLSOpts.optim_if_conversion IfConversion.transf_program - @@ print (print_RTLBlock 2) + @@ print (print_RTLBlock 1) @@@ RTLPargen.transl_program - @@ print (print_RTLPar 1) - @@ PipelineOp.transf_program - @@ print (print_RTLPar 2) + @@ print (print_RTLPar 0) + @@@ RTLParFUgen.transl_program @@@ HTLPargen.transl_program - @@ print print_HTL + @@ print (print_HTL 0) @@ Veriloggen.transl_program. (*| @@ -272,6 +277,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) ::: mkpass Unusedglobproof.match_prog ::: (@mkpass _ _ HTLgenproof.match_prog (HTLgenproof.TransfHTLLink HTLgen.transl_program)) + ::: mkpass (match_if HLSOpts.optim_ram Memorygen.match_prog) ::: mkpass Veriloggenproof.match_prog ::: pass_nil _. @@ -309,7 +315,8 @@ Proof. 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. - set (p15 := Veriloggen.transl_program p14) in *. + set (p15 := total_if HLSOpts.optim_ram Memorygen.transf_program p14) in *. + set (p16 := Veriloggen.transl_program p15) in *. unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. exists p2; split. apply SimplLocalsproof.match_transf_program; auto. @@ -325,7 +332,8 @@ Proof. 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. + exists p15; split. apply total_if_match. apply Memorygen.transf_program_match; auto. + exists p16; split. apply Veriloggenproof.transf_program_match; auto. inv T. reflexivity. Qed. @@ -343,7 +351,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 p15)). + assert (F: forward_simulation (Cstrategy.semantics p) (Verilog.semantics p16)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -373,6 +381,8 @@ Ltac DestructM := eapply Unusedglobproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply HTLgenproof.transf_program_correct. eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Memorygen.transf_program_correct; eassumption. eapply Veriloggenproof.transf_program_correct; eassumption. } split. auto. diff --git a/src/HLSOpts.v b/src/HLSOpts.v index 173300d..efa7ed0 100644 --- a/src/HLSOpts.v +++ b/src/HLSOpts.v @@ -17,3 +17,5 @@ *) Parameter optim_if_conversion: unit -> bool. + +Parameter optim_ram: unit -> bool. diff --git a/src/SoftwarePipelining/LICENSE b/src/SoftwarePipelining/LICENSE new file mode 100644 index 0000000..e275fa0 --- /dev/null +++ b/src/SoftwarePipelining/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2008,2009,2010 Jean-Baptiste Tristan and INRIA + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/src/VericertClflags.ml b/src/VericertClflags.ml index 930b613..ab3c949 100644 --- a/src/VericertClflags.ml +++ b/src/VericertClflags.ml @@ -8,3 +8,4 @@ let option_drtlblock = ref false let option_drtlpar = ref false let option_hls_schedule = ref false let option_fif_conv = ref false +let option_fram = ref true diff --git a/src/common/Monad.v b/src/common/Monad.v index 5e8385e..fcbe527 100644 --- a/src/common/Monad.v +++ b/src/common/Monad.v @@ -40,10 +40,10 @@ Module MonadExtra(M : Monad). Notation "'do' X <- A ; B" := (bind A (fun X => B)) - (at level 200, X ident, A at level 100, B at level 200). + (at level 200, X name, A at level 100, B at level 200). Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B)) - (at level 200, X ident, Y ident, A at level 100, B at level 200). + (at level 200, X name, Y name, A at level 100, B at level 200). End MonadNotation. Import MonadNotation. diff --git a/src/common/Vericertlib.v b/src/common/Vericertlib.v index b58ebd4..389a74f 100644 --- a/src/common/Vericertlib.v +++ b/src/common/Vericertlib.v @@ -34,7 +34,7 @@ Require Import vericert.common.Show. (* Depend on CompCert for the basic library, as they declare and prove some useful theorems. *) -Local Open Scope Z_scope. +#[local] Open Scope Z_scope. (* This tactic due to Clement Pit-Claudel with some minor additions by JDP to allow the result to be named: https://pit-claudel.fr/clement/MSc/#org96a1b5f *) @@ -190,8 +190,8 @@ Ltac liapp := Ltac crush := simplify; try discriminate; try congruence; try lia; liapp; try assumption; try (solve [auto]). -Global Opaque Nat.div. -Global Opaque Z.mul. +#[global] Opaque Nat.div. +#[global] Opaque Z.mul. (* Definition const (A B : Type) (a : A) (b : B) : A := a. @@ -231,7 +231,7 @@ Definition join {A : Type} (a : option (option A)) : option A := Module Notation. Notation "'do' X <- A ; B" := (bind A (fun X => B)) - (at level 200, X ident, A at level 100, B at level 200). + (at level 200, X name, A at level 100, B at level 200). End Notation. End Option. diff --git a/src/extraction/Extraction.v b/src/extraction/Extraction.v index 5c1dac5..bca8fb5 100644 --- a/src/extraction/Extraction.v +++ b/src/extraction/Extraction.v @@ -25,7 +25,9 @@ From vericert Require RTLBlockInstr HTLgen Pipeline - HLSOpts. + HLSOpts + Predicate +. From Coq Require DecidableClass. @@ -134,6 +136,8 @@ Extract Constant Compopts.debug => Extract Constant HLSOpts.optim_if_conversion => "fun _ -> !VericertClflags.option_fif_conv". +Extract Constant HLSOpts.optim_ram => + "fun _ -> !VericertClflags.option_fram". (* Compiler *) Extract Constant Compiler.print_Clight => "PrintClight.print_if". @@ -143,6 +147,7 @@ Extract Constant Compiler.print_RTL => "PrintRTL.print_if". Extract Constant Compiler.print_RTLBlock => "PrintRTLBlock.print_if". Extract Constant Compiler.print_RTLPar => "PrintRTLPar.print_if". Extract Constant Compiler.print_HTL => "PrintHTL.print_if". +Extract Constant Compiler.print_RTLPar => "PrintRTLPar.print_if". Extract Constant Compiler.print_LTL => "PrintLTL.print_if". Extract Constant Compiler.print_Mach => "PrintMach.print_if". Extract Constant Compiler.print => "fun (f: 'a -> unit) (x: 'a) -> f x; x". @@ -190,7 +195,8 @@ Separate Extraction RTLBlockgen.transl_program RTLBlockInstr.successors_instr HTLgen.tbl_to_case_expr Pipeline.pipeline - RTLBlockInstr.sat_pred_temp + Predicate.sat_pred_simple + Verilog.stmnt_to_list Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state diff --git a/src/hls/Abstr.v b/src/hls/Abstr.v new file mode 100644 index 0000000..2ab79cf --- /dev/null +++ b/src/hls/Abstr.v @@ -0,0 +1,1443 @@ +(* + * 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.Logic.Decidable. + +Require Import compcert.backend.Registers. +Require Import compcert.common.AST. +Require Import compcert.common.Globalenvs. +Require Import 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. +Require Import vericert.hls.HashTree. +Require Import vericert.hls.Predicate. + +#[local] Open Scope positive. +#[local] Open Scope pred_op. + +(*| +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 +| Pred : 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 (xO r) + | Pred r => xI (xI 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 : Type := +| 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 +| Esetpred : Op.condition -> expression_list -> expression +with expression_list : Type := +| Enil : expression_list +| Econs : expression -> expression_list -> expression_list +. + +(*Inductive pred_expr : Type := +| PEsingleton : option pred_op -> expression -> pred_expr +| PEcons : option pred_op -> expression -> pred_expr -> pred_expr.*) + +Module NonEmpty. + +Inductive non_empty (A: Type) := +| singleton : A -> non_empty A +| cons : A -> non_empty A -> non_empty A +. + +Arguments singleton [A]. +Arguments cons [A]. + +Declare Scope non_empty_scope. +Delimit Scope non_empty_scope with non_empty. + +Module NonEmptyNotation. +Infix "::|" := cons (at level 60, right associativity) : non_empty_scope. +End NonEmptyNotation. +Import NonEmptyNotation. + +#[local] Open Scope non_empty_scope. + +Fixpoint map {A B} (f: A -> B) (l: non_empty A): non_empty B := + match l with + | singleton a => singleton (f a) + | a ::| b => f a ::| map f b + end. + +Fixpoint to_list {A} (l: non_empty A): list A := + match l with + | singleton a => a::nil + | a ::| b => a :: to_list b + end. + +Fixpoint app {A} (l1 l2: non_empty A) := + match l1 with + | singleton a => a ::| l2 + | a ::| b => a ::| app b l2 + end. + +Fixpoint non_empty_prod {A B} (l: non_empty A) (l': non_empty B) := + match l with + | singleton a => map (fun x => (a, x)) l' + | a ::| b => app (map (fun x => (a, x)) l') (non_empty_prod b l') + end. + +Fixpoint of_list {A} (l: list A): option (non_empty A) := + match l with + | a::b => + match of_list b with + | Some b' => Some (a ::| b') + | _ => None + end + | nil => None + end. + +Fixpoint replace {A} (f: A -> A -> bool) (a b: A) (l: non_empty A) := + match l with + | a' ::| l' => if f a a' then b ::| replace f a b l' else a' ::| replace f a b l' + | singleton a' => if f a a' then singleton b else singleton a' + end. + +Inductive In {A: Type} (x: A) : non_empty A -> Prop := +| In_cons : forall a b, x = a \/ In x b -> In x (a ::| b) +| In_single : In x (singleton x). + +Lemma in_dec: + forall A (a: A) (l: non_empty A), + (forall a b: A, {a = b} + {a <> b}) -> + {In a l} + {~ In a l}. +Proof. + induction l; intros. + { specialize (X a a0). inv X. + left. constructor. + right. unfold not. intros. apply H. inv H0. auto. } + { pose proof X as X2. + specialize (X a a0). inv X. + left. constructor; tauto. + apply IHl in X2. inv X2. + left. constructor; tauto. + right. unfold not in *; intros. apply H0. inv H1. now inv H3. } +Qed. + +End NonEmpty. + +Module NE := NonEmpty. +Import NE.NonEmptyNotation. + +#[local] Open Scope non_empty_scope. + +Definition predicated A := NE.non_empty (pred_op * A). + +Definition pred_expr := predicated expression. + +(*| +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 pred_expr. + +Definition get_forest v (f: forest) := + match Rtree.get v f with + | None => NE.singleton (T, (Ebase v)) + | Some v' => v' + end. + +Declare Scope forest. + +Notation "a # b" := (get_forest b a) (at level 1) : forest. +Notation "a # b <- c" := (Rtree.set b c a) (at level 1, b at next level) : forest. + +#[local] Open Scope forest. + +Definition maybe {A: Type} (vo: A) (pr: predset) p (v: A) := + match p with + | Some p' => if eval_predf pr p' then v else vo + | None => v + end. + +Definition get_pr i := match i with mk_instr_state a b c => b end. + +Definition get_m i := match i with mk_instr_state a b c => c end. + +Definition eval_predf_opt pr p := + match p with Some p' => eval_predf pr p' | None => true end. + +(*| +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 : Type}. + +Record ctx : Type := mk_ctx { + ctx_is: instr_state; + ctx_sp: val; + ctx_ge: Genv.t A unit; +}. + +Definition ctx_rs ctx := is_rs (ctx_is ctx). +Definition ctx_ps ctx := is_ps (ctx_is ctx). +Definition ctx_mem ctx := is_mem (ctx_is ctx). + +Inductive sem_value : ctx -> expression -> val -> Prop := +| Sbase_reg: + forall r ctx, + sem_value ctx (Ebase (Reg r)) ((ctx_rs ctx) !! r) +| Sop: + forall ctx op args v lv, + sem_val_list ctx args lv -> + Op.eval_operation (ctx_ge ctx) (ctx_sp ctx) op lv (ctx_mem ctx) = Some v -> + sem_value ctx (Eop op args) v +| Sload : + forall ctx mexp addr chunk args a v m' lv, + sem_mem ctx mexp m' -> + sem_val_list ctx args lv -> + Op.eval_addressing (ctx_ge ctx) (ctx_sp ctx) addr lv = Some a -> + Memory.Mem.loadv chunk m' a = Some v -> + sem_value ctx (Eload chunk addr args mexp) v +with sem_pred : ctx -> expression -> bool -> Prop := +| Spred: + forall ctx args c lv v, + sem_val_list ctx args lv -> + Op.eval_condition c lv (ctx_mem ctx) = Some v -> + sem_pred ctx (Esetpred c args) v +| Sbase_pred: + forall ctx p, + sem_pred ctx (Ebase (Pred p)) ((ctx_ps ctx) !! p) +with sem_mem : ctx -> expression -> Memory.mem -> Prop := +| Sstore : + forall ctx mexp vexp chunk addr args lv v a m' m'', + sem_mem ctx mexp m' -> + sem_value ctx vexp v -> + sem_val_list ctx args lv -> + Op.eval_addressing (ctx_ge ctx) (ctx_sp ctx) addr lv = Some a -> + Memory.Mem.storev chunk m' a v = Some m'' -> + sem_mem ctx (Estore vexp chunk addr args mexp) m'' +| Sbase_mem : + forall ctx, + sem_mem ctx (Ebase Mem) (ctx_mem ctx) +with sem_val_list : ctx -> expression_list -> list val -> Prop := +| Snil : + forall ctx, + sem_val_list ctx Enil nil +| Scons : + forall ctx e v l lv, + sem_value ctx e v -> + sem_val_list ctx l lv -> + sem_val_list ctx (Econs e l) (v :: lv) +. + +Inductive sem_pred_expr {B: Type} (sem: ctx -> expression -> B -> Prop): + ctx -> pred_expr -> B -> Prop := +| sem_pred_expr_cons_true : + forall ctx e pr p' v, + eval_predf (ctx_ps ctx) pr = true -> + sem ctx e v -> + sem_pred_expr sem ctx ((pr, e) ::| p') v +| sem_pred_expr_cons_false : + forall ctx e pr p' v, + eval_predf (ctx_ps ctx) pr = false -> + sem_pred_expr sem ctx p' v -> + sem_pred_expr sem ctx ((pr, e) ::| p') v +| sem_pred_expr_single : + forall ctx e pr v, + eval_predf (ctx_ps ctx) pr = true -> + sem ctx e v -> + sem_pred_expr sem ctx (NE.singleton (pr, e)) v +. + +Definition collapse_pe (p: pred_expr) : option expression := + match p with + | NE.singleton (T, p) => Some p + | _ => None + end. + +Inductive sem_predset : ctx -> forest -> predset -> Prop := +| Spredset: + forall ctx f rs', + (forall x, sem_pred_expr sem_pred ctx (f # (Pred x)) (rs' !! x)) -> + sem_predset ctx f rs'. + +Inductive sem_regset : ctx -> forest -> regset -> Prop := +| Sregset: + forall ctx f rs', + (forall x, sem_pred_expr sem_value ctx (f # (Reg x)) (rs' !! x)) -> + sem_regset ctx f rs'. + +Inductive sem : ctx -> forest -> instr_state -> Prop := +| Sem: + forall ctx rs' m' f pr', + sem_regset ctx f rs' -> + sem_predset ctx f pr' -> + sem_pred_expr sem_mem ctx (f # Mem) m' -> + sem ctx f (mk_instr_state rs' pr' 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 e1 chk1 addr1 el1 m1, Estore e2 chk2 addr2 el2 m2 => + 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 + | Esetpred c1 el1, Esetpred c2 el2 => + if condition_eq c1 c2 + then beq_expression_list el1 el2 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; + try solve [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; eauto using Peqb_true_eq]. +Qed. + +Lemma beq_expression_refl: forall e, beq_expression e e = true. +Proof. + intros. + induction e using expression_ind2 with (P0 := fun el => beq_expression_list el el = true); + crush; repeat (destruct_match; crush); []. + crush. rewrite IHe. rewrite IHe0. auto. +Qed. + +Lemma beq_expression_list_refl: forall e, beq_expression_list e e = true. +Proof. induction e; auto. simplify. rewrite beq_expression_refl. auto. Qed. + +Lemma beq_expression_correct2: + forall e1 e2, beq_expression e1 e2 = false -> e1 <> e2. +Proof. + induction e1 using expression_ind2 + with (P0 := fun el1 => forall el2, beq_expression_list el1 el2 = false -> el1 <> el2). + - intros. simplify. repeat (destruct_match; crush). + - intros. simplify. repeat (destruct_match; crush). subst. apply IHe1 in H. + unfold not in *. intros. apply H. inv H0. auto. + - intros. simplify. repeat (destruct_match; crush); subst. + unfold not in *; intros. inv H0. rewrite beq_expression_refl in H. discriminate. + unfold not in *; intros. inv H. rewrite beq_expression_list_refl in Heqb. discriminate. + - simplify. repeat (destruct_match; crush); subst; + unfold not in *; intros. + inv H0. rewrite beq_expression_refl in H; crush. + inv H. rewrite beq_expression_refl in Heqb0; crush. + inv H. rewrite beq_expression_list_refl in Heqb; crush. + - simplify. repeat (destruct_match; crush); subst. + unfold not in *; intros. inv H0. rewrite beq_expression_list_refl in H; crush. + - simplify. repeat (destruct_match; crush); subst. + - simplify. repeat (destruct_match; crush); subst. + apply andb_false_iff in H. inv H. unfold not in *; intros. + inv H. rewrite beq_expression_refl in H0; discriminate. + unfold not in *; intros. inv H. rewrite beq_expression_list_refl in H0; discriminate. +Qed. + +Lemma expression_dec: forall e1 e2: expression, {e1 = e2} + {e1 <> e2}. +Proof. + intros. + destruct (beq_expression e1 e2) eqn:?. apply beq_expression_correct in Heqb. auto. + apply beq_expression_correct2 in Heqb. auto. +Defined. + +Definition pred_expr_item_eq (pe1 pe2: pred_op * expression) : bool := + @equiv_dec _ SATSetoid _ (fst pe1) (fst pe2) && beq_expression (snd pe1) (snd pe2). + +Lemma pred_expr_dec: forall (pe1 pe2: pred_op * expression), + {pred_expr_item_eq pe1 pe2 = true} + {pred_expr_item_eq pe1 pe2 = false}. +Proof. + intros; destruct (pred_expr_item_eq pe1 pe2) eqn:?; unfold not; [tauto | now right]. +Qed. + +Lemma pred_expr_dec2: forall (pe1 pe2: pred_op * expression), + {pred_expr_item_eq pe1 pe2 = true} + {~ pred_expr_item_eq pe1 pe2 = true}. +Proof. + intros; destruct (pred_expr_item_eq pe1 pe2) eqn:?; unfold not; [tauto | now right]. +Qed. + +Module HashExpr <: Hashable. + Definition t := expression. + Definition eq_dec := expression_dec. +End HashExpr. + +Module HT := HashTree(HashExpr). +Import HT. + +Definition combine_option {A} (a b: option A) : option A := + match a, b with + | Some a', _ => Some a' + | _, Some b' => Some b' + | _, _ => None + end. + +Fixpoint norm_expression (max: predicate) (pe: pred_expr) (h: hash_tree) + : (PTree.t pred_op) * hash_tree := + match pe with + | NE.singleton (p, e) => + let (p', h') := hash_value max e h in + (PTree.set p' p (PTree.empty _), h') + | (p, e) ::| pr => + let (p', h') := hash_value max e h in + let (p'', h'') := norm_expression max pr h' in + match p'' ! p' with + | Some pr_op => + (PTree.set p' (pr_op ∨ p) p'', h'') + | None => + (PTree.set p' p p'', h'') + end + end. + +Definition mk_pred_stmnt' e p_e := ¬ p_e ∨ Plit (true, e). + +Definition mk_pred_stmnt t := PTree.fold (fun x a b => mk_pred_stmnt' a b ∧ x) t T. + +Definition mk_pred_stmnt_l (t: list (predicate * pred_op)) := fold_left (fun x a => uncurry mk_pred_stmnt' a ∧ x) t T. + +Definition encode_expression max pe h := + let (tree, h) := norm_expression max pe h in + (mk_pred_stmnt tree, h). + +(*Fixpoint encode_expression_ne (max: predicate) (pe: pred_expr_ne) (h: hash_tree) + : (PTree.t pred_op) * hash_tree := + match pe with + | NE.singleton (p, e) => + let (p', h') := hash_value max e h in + (Por (Pnot p) (Pvar p'), h') + | (p, e) ::| pr => + let (p', h') := hash_value max e h in + let (p'', h'') := encode_expression_ne max pr h' in + (Pand (Por (Pnot p) (Pvar p')) p'', h'') + end.*) + +Fixpoint max_pred_expr (pe: pred_expr) : positive := + match pe with + | NE.singleton (p, e) => max_predicate p + | (p, e) ::| pe' => Pos.max (max_predicate p) (max_pred_expr pe') + end. + +Definition empty : forest := Rtree.empty _. + +Definition ge_preserved {A B C D: Type} (ge: Genv.t A B) (tge: Genv.t C D) : Prop := + (forall sp op vl m, Op.eval_operation ge sp op vl m = + Op.eval_operation tge sp op vl m) + /\ (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. +#[local] Hint Resolve ge_preserved_same : core. + +Inductive match_states : instr_state -> instr_state -> Prop := +| match_states_intro: + forall ps ps' rs rs' m m', + (forall x, rs !! x = rs' !! x) -> + (forall x, ps !! x = ps' !! x) -> + m = m' -> + match_states (mk_instr_state rs ps m) (mk_instr_state rs' ps' m'). + +Lemma match_states_refl x : match_states x x. +Proof. destruct x; constructor; crush. Qed. + +Lemma match_states_commut x y : match_states x y -> match_states y x. +Proof. inversion 1; constructor; crush. Qed. + +Lemma match_states_trans x y z : + match_states x y -> match_states y z -> match_states x z. +Proof. repeat inversion 1; constructor; crush. Qed. + +#[global] +Instance match_states_Equivalence : Equivalence match_states := + { Equivalence_Reflexive := match_states_refl ; + Equivalence_Symmetric := match_states_commut ; + Equivalence_Transitive := match_states_trans ; }. + +Inductive similar {A B} : @ctx A -> @ctx B -> Prop := +| similar_intro : + forall ist ist' sp ge tge, + ge_preserved ge tge -> + match_states ist ist' -> + similar (mk_ctx ist sp ge) (mk_ctx ist' sp tge). + +Definition beq_pred_expr_once (pe1 pe2: pred_expr) : bool := + match pe1, pe2 with + (*| PEsingleton None e1, PEsingleton None e2 => beq_expression e1 e2 + | PEsingleton (Some p1) e1, PEsingleton (Some p2) e2 => + if beq_expression e1 e2 + then match sat_pred_simple bound (Por (Pand p1 (Pnot p2)) (Pand p2 (Pnot p1))) with + | Some None => true + | _ => false + end + else false + | PEsingleton (Some p) e1, PEsingleton None e2 + | PEsingleton None e1, PEsingleton (Some p) e2 => + if beq_expression e1 e2 + then match sat_pred_simple bound (Pnot p) with + | Some None => true + | _ => false + end + else false*) + | pe1, pe2 => + let max := Pos.max (max_pred_expr pe1) (max_pred_expr pe2) in + let (p1, h) := encode_expression max pe1 (PTree.empty _) in + let (p2, h') := encode_expression max pe2 h in + equiv_check p1 p2 + end. + +Definition forall_ptree {A:Type} (f:positive->A->bool) (m:Maps.PTree.t A) : bool := + Maps.PTree.fold (fun (res: bool) (i: positive) (x: A) => res && f i x) m true. + +Ltac boolInv := + match goal with + | [ H: _ && _ = true |- _ ] => + destruct (andb_prop _ _ H); clear H; boolInv + | [ H: proj_sumbool _ = true |- _ ] => + generalize (proj_sumbool_true _ H); clear H; + let EQ := fresh in (intro EQ; try subst; boolInv) + | _ => + idtac + end. + +Remark ptree_forall: + forall (A: Type) (f: positive -> A -> bool) (m: Maps.PTree.t A), + Maps.PTree.fold (fun (res: bool) (i: positive) (x: A) => res && f i x) m true = true -> + forall i x, Maps.PTree.get i m = Some x -> f i x = true. +Proof. + intros. + set (f' := fun (res: bool) (i: positive) (x: A) => res && f i x). + set (P := fun (m: Maps.PTree.t A) (res: bool) => + res = true -> Maps.PTree.get i m = Some x -> f i x = true). + assert (P m true). + rewrite <- H. fold f'. apply Maps.PTree_Properties.fold_rec. + unfold P; intros. rewrite <- H1 in H4. auto. + red; intros. now rewrite Maps.PTree.gempty in H2. + unfold P; intros. unfold f' in H4. boolInv. + rewrite Maps.PTree.gsspec in H5. destruct (peq i k). + subst. inv H5. auto. + apply H3; auto. + red in H1. auto. +Qed. + +Lemma forall_ptree_true: + forall (A: Type) (f: positive -> A -> bool) (m: Maps.PTree.t A), + forall_ptree f m = true -> + forall i x, Maps.PTree.get i m = Some x -> f i x = true. +Proof. + apply ptree_forall. +Qed. + +Definition tree_equiv_check_el (np2: PTree.t pred_op) (n: positive) (p: pred_op): bool := + match np2 ! n with + | Some p' => equiv_check p p' + | None => equiv_check p ⟂ + end. + +Definition tree_equiv_check_None_el (np2: PTree.t pred_op) (n: positive) (p: pred_op): bool := + match np2 ! n with + | Some p' => true + | None => equiv_check p ⟂ + end. + +Variant sem_pred_tree {A B: Type} (sem: ctx -> expression -> B -> Prop): + @ctx A -> PTree.t expression -> PTree.t pred_op -> B -> Prop := +| sem_pred_tree_intro : + forall ctx expr e pr v et pt, + eval_predf (ctx_ps ctx) pr = true -> + sem ctx expr v -> + pt ! e = Some pr -> + et ! e = Some expr -> + sem_pred_tree sem ctx et pt v. + +Variant predicated_mutexcl {A: Type} : predicated A -> Prop := +| predicated_mutexcl_intros : forall pe, + (forall x y, NE.In x pe -> NE.In y pe -> x <> y -> fst x ⇒ ¬ fst y) -> + predicated_mutexcl pe. + +Lemma hash_value_in : + forall max e et h h0, + hash_value max e et = (h, h0) -> + h0 ! h = Some e. +Proof. + intros. unfold hash_value in *. destruct_match; + match goal with + | H: (_, _) = (_, _) |- _ => inv H + end. + - now apply find_tree_Some in Heqo. + - apply PTree.gss. +Qed. + +Lemma norm_expr_constant : + forall x m h t h' e p, + norm_expression m x h = (t, h') -> + h ! e = Some p -> + h' ! e = Some p. +Proof. Admitted. + +Lemma predicated_cons : + forall A (a:pred_op * A) x, + predicated_mutexcl (a ::| x) -> + predicated_mutexcl x. +Proof. + intros. + inv H. constructor; intros. + apply H0; auto; constructor; tauto. +Qed. + +Lemma norm_expr_mutexcl : + forall m pe h t h' e e' p p', + norm_expression m pe h = (t, h') -> + predicated_mutexcl pe -> + t ! e = Some p -> + t ! e' = Some p' -> + e <> e' -> + p ⇒ ¬ p'. +Proof. Abort. + +Lemma norm_expression_sem_pred : + forall A B sem ctx pe v, + sem_pred_expr sem ctx pe v -> + forall pt et et' max, + predicated_mutexcl pe -> + max_pred_expr pe <= max -> + norm_expression max pe et = (pt, et') -> + @sem_pred_tree A B sem ctx et' pt v. +Proof. + induction 1; crush; repeat (destruct_match; []); try destruct_match; + match goal with + | H: (_, _) = (_, _) |- _ => inv H + end. + { econstructor. 3: { apply PTree.gss. } + 2: { eassumption. } + { unfold eval_predf in *. simplify. rewrite H. auto with bool. } + { apply hash_value_in in Heqp. eapply norm_expr_constant in Heqp0; eauto. } + } + { econstructor; eauto. apply PTree.gss. + apply hash_value_in in Heqp. + eapply norm_expr_constant in Heqp0; eauto. + } + { assert (sem_pred_tree sem0 ctx0 et' t v). + eapply IHsem_pred_expr. + eapply predicated_cons; eauto. + instantiate (1 := max). lia. + eassumption. + inv H3. + destruct (Pos.eq_dec e0 h); subst. rewrite H6 in Heqo. simplify. + econstructor; try apply PTree.gss; eauto. + unfold eval_predf in *. simplify. auto with bool. + econstructor; eauto. now rewrite PTree.gso. + } + { assert (X: sem_pred_tree sem0 ctx0 et' t v). + eapply IHsem_pred_expr. + eapply predicated_cons; eauto. + instantiate (1 := max). lia. + eassumption. + inv X. + destruct (Pos.eq_dec e0 h); crush. + econstructor; eauto. now rewrite PTree.gso. + } + { econstructor; eauto. apply PTree.gss. + eapply hash_value_in; eassumption. + } +Qed. + +Lemma norm_expression_sem_pred2 : + forall A B sem ctx v pt et et', + @sem_pred_tree A B sem ctx et' pt v -> + forall pe, + predicated_mutexcl pe -> + norm_expression (max_pred_expr pe) pe et = (pt, et') -> + sem_pred_expr sem ctx pe v. +Proof. Admitted. + +Definition beq_pred_expr (pe1 pe2: pred_expr) : bool := + let max := Pos.max (max_pred_expr pe1) (max_pred_expr pe2) in + let (np1, h) := norm_expression max pe1 (PTree.empty _) in + let (np2, h') := norm_expression max pe2 h in + forall_ptree (tree_equiv_check_el np2) np1 + && forall_ptree (tree_equiv_check_None_el np1) np2. + +Definition check := Rtree.beq beq_pred_expr. + +Compute (check (empty # (Reg 2) <- + ((((Pand (Plit (true, 4)) (¬ (Plit (true, 4))))), (Ebase (Reg 9))) ::| + (NE.singleton (((Plit (true, 2))), (Ebase (Reg 3)))))) + (empty # (Reg 2) <- (NE.singleton (((Por (Plit (true, 2)) (Pand (Plit (true, 3)) (¬ (Plit (true, 3)))))), + (Ebase (Reg 3)))))). + +Lemma inj_asgn_eg : forall a b, (a =? b)%nat = (a =? a)%nat -> a = b. +Proof. + intros. destruct (Nat.eq_dec a b); subst. + auto. apply Nat.eqb_neq in n. + rewrite n in H. rewrite Nat.eqb_refl in H. discriminate. +Qed. + +Lemma inj_asgn : + forall a b, (forall (f: nat -> bool), f a = f b) -> a = b. +Proof. intros. apply inj_asgn_eg. eauto. Qed. + +Lemma inj_asgn_false: + forall n1 n2 , ~ (forall c: nat -> bool, c n1 = negb (c n2)). +Proof. + unfold not; intros. specialize (H (fun x => true)). + simplify. discriminate. +Qed. + +Lemma negb_inj: + forall a b, + negb a = negb b -> a = b. +Proof. destruct a, b; crush. Qed. + +Lemma sat_predicate_Plit_inj : + forall p1 p2, + Plit p1 == Plit p2 -> p1 = p2. +Proof. + simplify. destruct p1, p2. + destruct b, b0. assert (p = p0). + { apply Pos2Nat.inj. eapply inj_asgn. eauto. } solve [subst; auto]. + exfalso; eapply inj_asgn_false; eauto. + exfalso; eapply inj_asgn_false; eauto. + assert (p = p0). apply Pos2Nat.inj. eapply inj_asgn. intros. specialize (H f). + apply negb_inj in H. auto. rewrite H0; auto. +Qed. + +Definition ind_preds t := + forall e1 e2 p1 p2 c, + e1 <> e2 -> + t ! e1 = Some p1 -> + t ! e2 = Some p2 -> + sat_predicate p1 c = true -> + sat_predicate p2 c = false. + +Definition ind_preds_l t := + forall (e1: predicate) e2 p1 p2 c, + e1 <> e2 -> + In (e1, p1) t -> + In (e2, p2) t -> + sat_predicate p1 c = true -> + sat_predicate p2 c = false. + +(*Lemma pred_equivalence_Some' : + forall ta tb e pe pe', + list_norepet (map fst ta) -> + list_norepet (map fst tb) -> + In (e, pe) ta -> + In (e, pe') tb -> + fold_right (fun p a => mk_pred_stmnt' (fst p) (snd p) ∧ a) T ta == + fold_right (fun p a => mk_pred_stmnt' (fst p) (snd p) ∧ a) T tb -> + pe == pe'. +Proof. + induction ta as [|hd tl Hta]; try solve [crush]. + - intros * NRP1 NRP2 IN1 IN2 FOLD. inv NRP1. inv IN1. + simpl in FOLD. + +Lemma pred_equivalence_Some : + forall (ta tb: PTree.t pred_op) e pe pe', + ta ! e = Some pe -> + tb ! e = Some pe' -> + mk_pred_stmnt ta == mk_pred_stmnt tb -> + pe == pe'. +Proof. + intros * SMEA SMEB EQ. unfold mk_pred_stmnt in *. + repeat rewrite PTree.fold_spec in EQ. + +Lemma pred_equivalence_None : + forall (ta tb: PTree.t pred_op) e pe, + (mk_pred_stmnt ta) == (mk_pred_stmnt tb) -> + ta ! e = Some pe -> + tb ! e = None -> + equiv pe ⟂. +Abort. + +Lemma pred_equivalence : + forall (ta tb: PTree.t pred_op) e pe, + equiv (mk_pred_stmnt ta) (mk_pred_stmnt tb) -> + ta ! e = Some pe -> + equiv pe ⟂ \/ (exists pe', tb ! e = Some pe' /\ equiv pe pe'). +Proof. + intros * EQ SME. destruct (tb ! e) eqn:HTB. + { right. econstructor. split; eauto. eapply pred_equivalence_Some; eauto. } + { left. eapply pred_equivalence_None; eauto. } +Qed.*) + +Section CORRECT. + + Definition fd := @fundef RTLBlock.bb. + Definition tfd := @fundef RTLPar.bb. + + Context (ictx: @ctx fd) (octx: @ctx tfd) (HSIM: similar ictx octx). + + Lemma sem_value_mem_det: + forall e v v' m m', + (sem_value ictx e v -> sem_value octx e v' -> v = v') + /\ (sem_mem ictx e m -> sem_mem octx e m' -> m = m'). + Proof using HSIM. + induction e using expression_ind2 + with (P0 := fun p => forall v v', + sem_val_list ictx p v -> sem_val_list octx p v' -> v = v'); + inv HSIM; match goal with H: context [match_states] |- _ => inv H end; repeat progress simplify; + try solve [match goal with + | H: sem_value _ _ _, H2: sem_value _ _ _ |- _ => inv H; inv H2; auto + | H: sem_mem _ _ _, H2: sem_mem _ _ _ |- _ => inv H; inv H2; auto + | H: sem_val_list _ _ _, H2: sem_val_list _ _ _ |- _ => inv H; inv H2; auto + end]. + - repeat match goal with + | H: sem_value _ _ _ |- _ => inv H + | H: sem_val_list {| ctx_ge := ge; |} ?e ?l1, + H2: sem_val_list {| ctx_ge := tge |} ?e ?l2, + IH: forall _ _, sem_val_list _ _ _ -> sem_val_list _ _ _ -> _ = _ |- _ => + assert (X: l1 = l2) by (apply IH; auto) + | H: ge_preserved _ _ |- _ => inv H + | |- context [ctx_rs] => unfold ctx_rs; cbn + | H: context [ctx_mem] |- _ => unfold ctx_mem in H; cbn + end; crush. + - repeat match goal with H: sem_value _ _ _ |- _ => inv H end; simplify; + assert (lv0 = lv) by (apply IHe; eauto); subst; + match goal with H: ge_preserved _ _ |- _ => inv H end; + match goal with H: context [Op.eval_addressing _ _ _ _ = Op.eval_addressing _ _ _ _] |- _ + => rewrite H in * end; + assert (a0 = a1) by crush; + assert (m'2 = m'1) by (apply IHe0; eauto); crush. + - inv H0; inv H3. simplify. + assert (lv = lv0) by ( apply IHe2; eauto). subst. + assert (a1 = a0). { inv H. rewrite H3 in *. crush. } + assert (v0 = v1). { apply IHe1; auto. } + assert (m'1 = m'2). { apply IHe3; auto. } crush. + - inv H0. inv H3. f_equal. apply IHe; auto. + apply IHe0; auto. + Qed. + + Lemma sem_value_mem_corr: + forall e v m, + (sem_value ictx e v -> sem_value octx e v) + /\ (sem_mem ictx e m -> sem_mem octx e m). + Proof using HSIM. + induction e using expression_ind2 + with (P0 := fun p => forall v, + sem_val_list ictx p v -> sem_val_list octx p v); + inv HSIM; match goal with H: context [match_states] |- _ => inv H end; repeat progress simplify. + - inv H0. unfold ctx_rs, ctx_ps, ctx_mem in *; cbn. rewrite H1. constructor. + - inv H0. unfold ctx_rs, ctx_ps, ctx_mem in *; cbn. constructor. + - inv H0. apply IHe in H6. econstructor; try eassumption. + unfold ctx_rs, ctx_ps, ctx_mem in *; cbn in *. inv H. crush. + - inv H0. + - inv H0. eapply IHe in H10. eapply IHe0 in H8; auto. + econstructor; try eassumption. + unfold ctx_rs, ctx_ps, ctx_mem in *; cbn in *. inv H; crush. + - inv H0. + - inv H0. + - inv H0. eapply IHe1 in H11; auto. eapply IHe2 in H12; auto. eapply IHe3 in H9; auto. + econstructor; try eassumption. + unfold ctx_rs, ctx_ps, ctx_mem in *; cbn in *. inv H; crush. + - inv H0. + - inv H0. + - inv H0. econstructor. + - inv H0. eapply IHe in H6; auto. eapply IHe0 in H8. + econstructor; eassumption. + Qed. + + Lemma sem_value_det: + forall e v v', + sem_value ictx e v -> sem_value octx e v' -> v = v'. + Proof using HSIM. + intros. eapply sem_value_mem_det; eauto; apply Mem.empty. + Qed. + + Lemma sem_value_corr: + forall e v, + sem_value ictx e v -> sem_value octx e v. + Proof using HSIM. + intros. eapply sem_value_mem_corr; eauto; apply Mem.empty. + Qed. + + Lemma sem_mem_det: + forall e v v', + sem_mem ictx e v -> sem_mem octx e v' -> v = v'. + Proof using HSIM. + intros. eapply sem_value_mem_det; eauto; apply (Vint (Int.repr 0%Z)). + Qed. + + Lemma sem_mem_corr: + forall e v, + sem_mem ictx e v -> sem_mem octx e v. + Proof using HSIM. + intros. eapply sem_value_mem_corr; eauto; apply (Vint (Int.repr 0%Z)). + Qed. + + Lemma sem_val_list_det: + forall e l l', + sem_val_list ictx e l -> sem_val_list octx e l' -> l = l'. + Proof using HSIM. + induction e; simplify. + - inv H; inv H0; auto. + - inv H; inv H0. f_equal. eapply sem_value_det; eauto; try apply Mem.empty. + apply IHe; eauto. + Qed. + + Lemma sem_val_list_corr: + forall e l, + sem_val_list ictx e l -> sem_val_list octx e l. + Proof using HSIM. + induction e; simplify. + - inv H; constructor. + - inv H. apply sem_value_corr in H3; auto; try apply Mem.empty; + apply IHe in H5; constructor; assumption. + Qed. + + Lemma sem_pred_det: + forall e v v', + sem_pred ictx e v -> sem_pred octx e v' -> v = v'. + Proof using HSIM. + try solve [inversion 1]; pose proof sem_value_det; pose proof sem_val_list_det; inv HSIM; + match goal with H: match_states _ _ |- _ => inv H end; simplify. + inv H2; inv H5; auto. assert (lv = lv0) by (eapply H0; eauto). subst. unfold ctx_mem in *. + crush. + Qed. + + Lemma sem_pred_corr: + forall e v, + sem_pred ictx e v -> sem_pred octx e v. + Proof using HSIM. + try solve [inversion 1]; pose proof sem_value_corr; pose proof sem_val_list_corr; inv HSIM; + match goal with H: match_states _ _ |- _ => inv H end; simplify. + inv H2; auto. apply H0 in H5. econstructor; eauto. + unfold ctx_ps; cbn. rewrite H4. constructor. + Qed. + + #[local] Opaque PTree.set. + + Lemma exists_norm_expr : + forall x pe expr m t h h', + NE.In (pe, expr) x -> + norm_expression m x h = (t, h') -> + exists e pe', t ! e = Some pe' /\ pe ⇒ pe' /\ h' ! e = Some expr. + Proof. Admitted. + +(* Lemma exists_norm_expr3 : + forall e x pe expr m t h h', + t ! e = None -> + norm_expression m x h = (t, h') -> + ~ NE.In (pe, expr) x. + Proof. + Abort.*) + + Lemma norm_expr_implies : + forall x m h t h' e expr p, + norm_expression m x h = (t, h') -> + h' ! e = Some expr -> + t ! e = Some p -> + exists p', NE.In (p', expr) x /\ p' ⇒ p. + Proof. Admitted. + + Lemma norm_expr_In : + forall A B sem ctx x pe expr v, + @sem_pred_expr A B sem ctx x v -> + NE.In (pe, expr) x -> + eval_predf (ctx_ps ctx) pe = true -> + sem ctx expr v. + Proof. Admitted. + + Lemma norm_expr_forall_impl : + forall m x h t h' e1 e2 p1 p2, + predicated_mutexcl x -> + norm_expression m x h = (t, h') -> + t ! e1 = Some p1 -> t ! e2 = Some p2 -> e1 <> e2 -> + p1 ⇒ ¬ p2. + Admitted. + + Lemma norm_expr_replace : + forall A B sem ctx x pe expr v, + @sem_pred_expr A B sem ctx x v -> + eval_predf (ctx_ps ctx) pe = false -> + @sem_pred_expr A B sem ctx (NE.replace pred_expr_item_eq (pe, expr) (⟂, expr) x) v. + Proof using. + induction x; simplify; destruct_match; auto; destruct a; + unfold pred_expr_item_eq in Heqb; simplify; + try (destruct (equiv_dec pe p) eqn:?; [|discriminate]; []). + - rewrite e0 in H0; inv H; crush. + - apply beq_expression_correct in H2; subst; + pose proof H0; rewrite e0 in H2; + apply sem_pred_expr_cons_false; auto; inv H; crush. + - inv H; constructor; auto; now apply sem_pred_expr_cons_false. + Qed. + + Section SEM_PRED. + + Context (B: Type). + Context (isem: @ctx fd -> expression -> B -> Prop). + Context (osem: @ctx tfd -> expression -> B -> Prop). + Context (SEMSIM: forall e v v', isem ictx e v -> osem octx e v' -> v = v'). + + Ltac simplify' l := intros; unfold_constants; cbn -[l] in *; + repeat (nicify_hypotheses; nicify_goals; kill_bools; substpp); + cbn -[l] in *. + + Lemma check_correct_sem_value: + forall x x' v v' t t' h h', + beq_pred_expr x x' = true -> + predicated_mutexcl x -> predicated_mutexcl x' -> + norm_expression (Pos.max (max_pred_expr x) (max_pred_expr x')) x (PTree.empty _) = (t, h) -> + norm_expression (Pos.max (max_pred_expr x) (max_pred_expr x')) x' h = (t', h') -> + sem_pred_tree isem ictx h t v -> + sem_pred_tree osem octx h' t' v' -> + v = v'. + Proof using HSIM SEMSIM. + intros. inv H4. inv H5. + destruct (Pos.eq_dec e e0); subst. + { eapply norm_expr_constant in H3; [|eassumption]. + assert (expr = expr0) by (setoid_rewrite H3 in H12; crush); subst. + eapply SEMSIM; eauto. } + { destruct (t ! e0) eqn:?. + { assert (p == pr0). + { unfold beq_pred_expr in H. repeat (destruct_match; []). inv H2. + rewrite Heqp1 in H3. inv H3. + simplify. + eapply forall_ptree_true in H2. 2: { eapply Heqo. } + unfold tree_equiv_check_el in H2. rewrite H11 in H2. + now apply equiv_check_correct in H2. } + pose proof H0. eapply norm_expr_forall_impl in H0; [| | | |eassumption]; try eassumption. + unfold "⇒" in H0. unfold eval_predf in *. apply H0 in H6. + rewrite negate_correct in H6. apply negb_true_iff in H6. + inv HSIM. match goal with H: match_states _ _ |- _ => inv H end. + unfold ctx_ps, ctx_mem, ctx_rs in *. simplify. + pose proof eval_predf_pr_equiv pr0 ps ps' H17. unfold eval_predf in *. + rewrite H5 in H6. crush. + } + { unfold beq_pred_expr in H. repeat (destruct_match; []). inv H2. + rewrite Heqp0 in H3. inv H3. simplify. + eapply forall_ptree_true in H3. 2: { eapply H11. } + unfold tree_equiv_check_None_el in H3. + rewrite Heqo in H3. apply equiv_check_correct in H3. rewrite H3 in H4. + unfold eval_predf in H4. crush. } } + Qed. + + Lemma check_correct_sem_value2: + forall x x' v v', + beq_pred_expr x x' = true -> + predicated_mutexcl x -> + predicated_mutexcl x' -> + sem_pred_expr isem ictx x v -> + sem_pred_expr osem octx x' v' -> + v = v'. + Proof. + intros. pose proof H. + unfold beq_pred_expr in H. intros. repeat (destruct_match; try discriminate; []). + eapply check_correct_sem_value; try eassumption. + eapply norm_expression_sem_pred; eauto. lia. + eapply norm_expression_sem_pred; eauto. lia. + Qed. + + Lemma check_correct_sem_value3: + forall x x' v v', + beq_pred_expr x x' = true -> + sem_pred_expr isem ictx x v -> + sem_pred_expr osem octx x' v' -> + v = v'. + Proof. + induction x. + - intros * BEQ SEM1 SEM2. + unfold beq_pred_expr in *. intros. repeat (destruct_match; try discriminate; []); subst. + rename Heqp into HNORM1. + rename Heqp0 into HNORM2. + inv SEM1. rename H0 into HEVAL. rename H2 into ISEM. + pose HNORM1 as X. + eapply exists_norm_expr in X; [|constructor]. + simplify' norm_expression. + rename H0 into HT1. + rename H1 into HH1. + rename H into HFORALL1. + rename H2 into HFORALL2. + destruct (t0 ! x) eqn:DSTR. +(* { eapply forall_ptree_true in HT1; eauto. unfold tree_equiv_check_el in *. rewrite DSTR in HT1. + apply equiv_check_dec in HT1. + eapply exists_norm_expr2 in DSTR; try solve [eapply norm_expr_constant; eassumption | eassumption]. + eapply norm_expr_In in DSTR; try eassumption. eauto. + inv HSIM; simplify. now setoid_rewrite <- HT1. + } + { + eapply forall_ptree_true in HT1; [|eassumption]. + unfold tree_equiv_check_el in *. rewrite DSTR in HT1. apply equiv_check_dec in HT1. + now setoid_rewrite HT1 in HEVAL. + } + - intros. unfold beq_pred_expr in H. intros. repeat (destruct_match; try discriminate; []); subst. + destruct a. + inv H0. + { pose Heqp as X. eapply exists_norm_expr in X; [|constructor; tauto]. simplify' norm_expression. + eapply forall_ptree_true in H0; [|eassumption]. + destruct (t0 ! x0) eqn:DSTR. + { + unfold tree_equiv_check_el in H0. rewrite DSTR in H0. apply equiv_check_dec in H0. + eapply exists_norm_expr2 in DSTR; try solve [eapply norm_expr_constant; eassumption | eassumption]. + eapply norm_expr_In in DSTR; try eassumption; eauto. + rewrite <- H0. inv HSIM; eauto. + } + { + unfold tree_equiv_check_el in *. rewrite DSTR in H0. apply equiv_check_dec in H0. + now rewrite H0 in H7. + } + } + { (* This is the inductive argument, which says that if the element is in the list, then + taking it out will result in two equivalent lists, otherwise just taking the current element + results in equivalent lists. *) + simplify' norm_expression. eapply exists_norm_expr in Heqp; [|constructor]; eauto. + simplify' norm_expression. + eapply forall_ptree_true in H0; [|eassumption]. + unfold tree_equiv_check_el in H0. + destruct (t0 ! x0) eqn:DSTR. + { + apply equiv_check_dec in H0. + eapply exists_norm_expr2 in DSTR; try solve [eapply norm_expr_constant; eassumption | eassumption]. + } + } + Admitted.*) Abort. + + End SEM_PRED. + + Section SEM_PRED_CORR. + + Context (B: Type). + Context (isem: @ctx fd -> expression -> B -> Prop). + Context (osem: @ctx tfd -> expression -> B -> Prop). + Context (SEMCORR: forall e v, isem ictx e v -> osem octx e v). + + Lemma sem_pred_tree_corr: + forall x x' v t t' h h', + beq_pred_expr x x' = true -> + predicated_mutexcl x -> predicated_mutexcl x' -> + norm_expression (Pos.max (max_pred_expr x) (max_pred_expr x')) x (PTree.empty _) = (t, h) -> + norm_expression (Pos.max (max_pred_expr x) (max_pred_expr x')) x' h = (t', h') -> + sem_pred_tree isem ictx h t v -> + sem_pred_tree osem octx h' t' v. + Proof using SEMCORR. Admitted. + + End SEM_PRED_CORR. + + Lemma check_correct: forall (fa fb : forest) i i', + check fa fb = true -> + sem ictx fa i -> + sem octx fb i' -> + match_states i i'. + Proof using HSIM. + intros. + unfold check, get_forest in *; intros; + pose proof beq_expression_correct. + pose proof (Rtree.beq_sound beq_pred_expr fa fb H). + inv H0; inv H1. + constructor; simplify. + { admit. } + { inv H0; inv H4. + repeat match goal with + | H: forall _ : reg, _ |- _ => specialize (H x) + | H: forall _ : Rtree.elt, _ |- _ => specialize (H (Reg x)) + end. + repeat (destruct_match; try contradiction). + unfold "#" in *. rewrite Heqo in H0. + rewrite Heqo0 in H1. admit. + unfold "#" in H1. rewrite Heqo0 in H1. + unfold "#" in H0. rewrite Heqo in H0. admit. + } +Admitted. + + Lemma check_correct2: + forall (fa fb : forest) i, + check fa fb = true -> + sem ictx fa i -> + exists i', sem octx fb i' /\ match_states i i'. + Proof. Admitted. + +End CORRECT. + +Lemma get_empty: + forall r, empty#r = NE.singleton (T, 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 map1: + forall w dst dst', + dst <> dst' -> + (empty # dst <- w) # dst' = NE.singleton (T, Ebase dst'). +Proof. intros; unfold get_forest; rewrite Rtree.gso; auto; apply get_empty. 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 : pred_expr) 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. diff --git a/src/hls/Array.v b/src/hls/Array.v index dec1335..0f5ae02 100644 --- a/src/hls/Array.v +++ b/src/hls/Array.v @@ -51,7 +51,7 @@ Lemma list_set_spec1 {A : Type} : Proof. induction l; intros; destruct i; crush; firstorder. intuition. Qed. -Hint Resolve list_set_spec1 : array. +#[export] Hint Resolve list_set_spec1 : array. Lemma list_set_spec2 {A : Type} : forall l i (x : A) d, @@ -59,7 +59,7 @@ Lemma list_set_spec2 {A : Type} : Proof. induction l; intros; destruct i; crush; firstorder. intuition. Qed. -Hint Resolve list_set_spec2 : array. +#[export] Hint Resolve list_set_spec2 : array. Lemma list_set_spec3 {A : Type} : forall l i1 i2 (x : A), @@ -68,7 +68,7 @@ Lemma list_set_spec3 {A : Type} : Proof. induction l; intros; destruct i1; destruct i2; crush; firstorder. Qed. -Hint Resolve list_set_spec3 : array. +#[export] Hint Resolve list_set_spec3 : array. Lemma array_set_wf {A : Type} : forall l ln i (x : A), @@ -95,7 +95,7 @@ Proof. unfold array_set. crush. eauto with array. Qed. -Hint Resolve array_set_spec1 : array. +#[export] Hint Resolve array_set_spec1 : array. Lemma array_set_spec2 {A : Type} : forall a i (x : A) d, @@ -107,7 +107,7 @@ Proof. unfold array_set. crush. eauto with array. Qed. -Hint Resolve array_set_spec2 : array. +#[export] Hint Resolve array_set_spec2 : array. Lemma array_set_len {A : Type} : forall a i (x : A), diff --git a/src/hls/AssocMap.v b/src/hls/AssocMap.v index 1d1b77f..8dbc6b2 100644 --- a/src/hls/AssocMap.v +++ b/src/hls/AssocMap.v @@ -29,9 +29,8 @@ Module AssocMap := Maps.PTree. Module AssocMapExt. Import AssocMap. - Hint Resolve elements_correct elements_complete - elements_keys_norepet : assocmap. - Hint Resolve gso gss : assocmap. + #[export] Hint Resolve elements_correct elements_complete elements_keys_norepet : assocmap. + #[export] Hint Resolve gso gss : assocmap. Section Operations. @@ -55,7 +54,6 @@ Module AssocMapExt. forall am, merge (empty A) am = am. Proof. auto. Qed. - Hint Resolve merge_base_1 : assocmap. Lemma merge_base_2 : forall am, @@ -65,7 +63,6 @@ Module AssocMapExt. destruct am; trivial. destruct o; trivial. Qed. - Hint Resolve merge_base_2 : assocmap. Lemma merge_add_assoc : forall r am am' v, @@ -74,7 +71,6 @@ Module AssocMapExt. induction r; intros; destruct am; destruct am'; try (destruct o); simpl; try rewrite IHr; try reflexivity. Qed. - Hint Resolve merge_add_assoc : assocmap. Lemma merge_correct_1 : forall am bm k v, @@ -84,7 +80,6 @@ Module AssocMapExt. induction am; intros; destruct k; destruct bm; try (destruct o); simpl; try rewrite gempty in H; try discriminate; try assumption; auto. Qed. - Hint Resolve merge_correct_1 : assocmap. Lemma merge_correct_2 : forall am bm k v, @@ -95,7 +90,16 @@ Module AssocMapExt. induction am; intros; destruct k; destruct bm; try (destruct o); simpl; try rewrite gempty in H; try discriminate; try assumption; auto. Qed. - Hint Resolve merge_correct_2 : assocmap. + + Lemma merge_correct_3 : + forall am bm k, + get k am = None -> + get k bm = None -> + get k (merge am bm) = None. + Proof. + induction am; intros; destruct k; destruct bm; try (destruct o); simpl; + try rewrite gempty in H; try discriminate; try assumption; auto. + Qed. Definition merge_fold (am bm : t A) : t A := fold_right (fun p a => set (fst p) (snd p) a) bm (elements am). @@ -119,7 +123,6 @@ Module AssocMapExt. apply IHl. contradiction. contradiction. simpl. rewrite gso; try assumption. apply IHl. assumption. inversion H0. subst. assumption. Qed. - Hint Resolve add_assoc : assocmap. Lemma not_in_assoc : forall k v l bm, @@ -134,7 +137,6 @@ Module AssocMapExt. simpl in *; apply Decidable.not_or in H; destruct H. contradiction. rewrite AssocMap.gso; auto. Qed. - Hint Resolve not_in_assoc : assocmap. Lemma elements_iff : forall am k, @@ -147,14 +149,22 @@ Module AssocMapExt. exists (snd x). apply elements_complete. assert (x = (fst x, snd x)) by apply surjective_pairing. rewrite H in H0; assumption. Qed. - Hint Resolve elements_iff : assocmap. + + #[local] Hint Resolve merge_base_1 : core. + #[local] Hint Resolve merge_base_2 : core. + #[local] Hint Resolve merge_add_assoc : core. + #[local] Hint Resolve merge_correct_1 : core. + #[local] Hint Resolve merge_correct_2 : core. + #[local] Hint Resolve merge_correct_3 : core. + #[local] Hint Resolve add_assoc : core. + #[local] Hint Resolve not_in_assoc : core. + #[local] Hint Resolve elements_iff : core. Lemma elements_correct' : forall am k, ~ (exists v, get k am = Some v) <-> ~ List.In k (List.map (@fst _ A) (elements am)). - Proof. auto using not_iff_compat with assocmap. Qed. - Hint Resolve elements_correct' : assocmap. + Proof. auto using not_iff_compat. Qed. Lemma elements_correct_none : forall am k, @@ -164,31 +174,46 @@ Module AssocMapExt. intros. apply elements_correct'. unfold not. intros. destruct H0. rewrite H in H0. discriminate. Qed. - Hint Resolve elements_correct_none : assocmap. Lemma merge_fold_add : forall k v am bm, am ! k = Some v -> (merge_fold am bm) ! k = Some v. Proof. unfold merge_fold; auto with assocmap. Qed. - Hint Resolve merge_fold_add : assocmap. + + #[local] Hint Resolve elements_correct' : core. + #[local] Hint Resolve elements_correct_none : core. + #[local] Hint Resolve merge_fold_add : core. Lemma merge_fold_not_in : forall k v am bm, get k am = None -> get k bm = Some v -> get k (merge_fold am bm) = Some v. - Proof. intros. apply not_in_assoc; auto with assocmap. Qed. - Hint Resolve merge_fold_not_in : assocmap. + Proof. intros. apply not_in_assoc; auto. Qed. Lemma merge_fold_base : forall am, merge_fold (empty A) am = am. Proof. auto. Qed. - Hint Resolve merge_fold_base : assocmap. End Operations. + #[export] Hint Resolve merge_base_1 : assocmap. + #[export] Hint Resolve merge_base_2 : assocmap. + #[export] Hint Resolve merge_add_assoc : assocmap. + #[export] Hint Resolve merge_correct_1 : assocmap. + #[export] Hint Resolve merge_correct_2 : assocmap. + #[export] Hint Resolve merge_correct_3 : assocmap. + #[export] Hint Resolve add_assoc : assocmap. + #[export] Hint Resolve not_in_assoc : assocmap. + #[export] Hint Resolve elements_iff : assocmap. + #[export] Hint Resolve elements_correct' : assocmap. + #[export] Hint Resolve merge_fold_not_in : assocmap. + #[export] Hint Resolve merge_fold_base : assocmap. + #[export] Hint Resolve elements_correct_none : assocmap. + #[export] Hint Resolve merge_fold_add : assocmap. + End AssocMapExt. Import AssocMapExt. diff --git a/src/hls/FunctionalUnits.v b/src/hls/FunctionalUnits.v index 392b1ae..9504bb1 100644 --- a/src/hls/FunctionalUnits.v +++ b/src/hls/FunctionalUnits.v @@ -21,23 +21,165 @@ Require Import compcert.lib.Maps. Require Import vericert.common.Vericertlib. -Definition funct_node := positive. +#[local] Open Scope positive. + +Record divider (signed: bool) : Type := + mk_divider { + div_stages: positive; + div_size: positive; + div_numer: reg; + div_denom: reg; + div_quot: reg; + div_rem: reg; + div_ordering: (div_numer < div_denom + /\ div_denom < div_quot + /\ div_quot < div_rem) + }. + +Arguments div_stages [signed]. +Arguments div_size [signed]. +Arguments div_numer [signed]. +Arguments div_denom [signed]. +Arguments div_quot [signed]. +Arguments div_rem [signed]. + +Record ram := mk_ram { + ram_size: nat; + ram_mem: reg; + ram_en: reg; + ram_u_en: reg; + ram_addr: reg; + ram_wr_en: reg; + ram_d_in: reg; + ram_d_out: reg; + ram_ordering: (ram_addr < ram_en + /\ ram_en < ram_d_in + /\ ram_d_in < ram_d_out + /\ ram_d_out < ram_wr_en + /\ ram_wr_en < ram_u_en) +}. Inductive funct_unit: Type := -| SignedDiv (size: positive) (numer denom quot rem: reg): funct_unit -| UnsignedDiv (size: positive) (numer denom quot rem: reg): funct_unit. +| SignedDiv: divider true -> funct_unit +| UnsignedDiv: divider false -> funct_unit +| Ram: ram -> funct_unit. -Record funct_units := mk_avail_funct_units { - avail_sdiv: option funct_node; - avail_udiv: option funct_node; - avail_units: PTree.t funct_unit; - }. +Definition funct_units := PTree.t funct_unit. + +Record arch := mk_arch { + arch_div: list positive; + arch_sdiv: list positive; + arch_ram: list positive; +}. -Definition initial_funct_units := - mk_avail_funct_units None None (PTree.empty funct_unit). +Record resources := mk_resources { + res_funct_units: funct_units; + res_arch: arch; +}. + +Definition index_div {b:bool} r (d: divider b) := + match r with + | 1 => div_numer d + | 2 => div_denom d + | 3 => div_quot d + | _ => div_rem d + end. + +Definition index_ram r (d: ram) := + match r with + | 1 => ram_mem d + | 2 => ram_en d + | 3 => ram_u_en d + | 4 => ram_addr d + | 5 => ram_wr_en d + | 6 => ram_d_in d + | _ => ram_d_out d + end. + +Definition index_res u r res := + match PTree.get u res with + | Some (SignedDiv d) => Some (index_div r d) + | Some (UnsignedDiv d) => Some (index_div r d) + | Some (Ram d) => Some (index_ram r d) + | None => None + end. + +Definition get_ram n res: option (positive * ram) := + match nth_error (arch_ram (res_arch res)) n with + | Some ri => + match PTree.get ri (res_funct_units res) with + | Some (Ram r) => Some (ri, r) + | _ => None + end + | None => None + end. + +Definition get_div n res := + match nth_error (arch_div (res_arch res)) n with + | Some ri => + match PTree.get ri (res_funct_units res) with + | Some (UnsignedDiv d) => Some (ri, d) + | _ => None + end + | None => None + end. + +Definition get_sdiv n res := + match nth_error (arch_sdiv (res_arch res)) n with + | Some ri => + match PTree.get ri (res_funct_units res) with + | Some (SignedDiv d) => Some (ri, d) + | _ => None + end + | None => None + end. + +Definition set_res fu res := + let max := ((fold_left Pos.max ((arch_sdiv (res_arch res)) + ++ (arch_div (res_arch res)) + ++ (arch_ram (res_arch res))) 1) + 1)%positive in + let nt := PTree.set max fu (res_funct_units res) in + match fu with + | UnsignedDiv _ => mk_resources nt (mk_arch (max :: arch_div (res_arch res)) + (arch_sdiv (res_arch res)) + (arch_ram (res_arch res))) + | SignedDiv _ => mk_resources nt (mk_arch (arch_div (res_arch res)) + (max :: arch_sdiv (res_arch res)) + (arch_ram (res_arch res))) + | Ram _ => mk_resources nt (mk_arch (arch_div (res_arch res)) + (arch_sdiv (res_arch res)) + (max :: arch_ram (res_arch res))) + end. + +Definition initial_funct_units: funct_units := PTree.empty _. + +Definition initial_arch := mk_arch nil nil nil. + +Definition initial_resources := + mk_resources initial_funct_units initial_arch. Definition funct_unit_stages (f: funct_unit) : positive := match f with - | SignedDiv s _ _ _ _ => s - | UnsignedDiv s _ _ _ _ => s + | SignedDiv d => div_stages d + | UnsignedDiv d => div_stages d + | _ => 1 end. + +Definition max_reg_ram r := + fold_right Pos.max 1 (ram_mem r::ram_en r::ram_u_en r::ram_addr r + ::ram_wr_en r::ram_d_in r::ram_d_out r::nil). + +Definition max_reg_divider {b: bool} (d: divider b) := + fold_right Pos.max 1 (div_numer d::div_denom d::div_quot d::div_rem d::nil). + +Definition max_reg_fu fu := + match fu with + | SignedDiv d | UnsignedDiv d => max_reg_divider d + | Ram r => max_reg_ram r + end. + +Definition max_reg_funct_units r := + PTree.fold (fun m _ a => Pos.max m (max_reg_fu a)) r 1. + +Definition max_reg_resources r := + max_reg_funct_units r.(res_funct_units). diff --git a/src/hls/HTL.v b/src/hls/HTL.v index d91a340..f4552a5 100644 --- a/src/hls/HTL.v +++ b/src/hls/HTL.v @@ -18,20 +18,23 @@ *) Require Import Coq.FSets.FMapPositive. +Require Import Coq.micromega.Lia. Require compcert.common.Events. Require compcert.common.Globalenvs. Require compcert.common.Smallstep. Require compcert.common.Values. -Require compcert.lib.Integers. +Require Import compcert.lib.Integers. Require Import compcert.lib.Maps. Require Import vericert.common.Vericertlib. Require Import vericert.hls.Array. -Require Import vericert.hls.AssocMap. Require Import vericert.hls.FunctionalUnits. -Require Import vericert.hls.ValueInt. Require vericert.hls.Verilog. +Require Import AssocMap. +Require Import ValueInt. + +Local Open Scope positive. (*| The purpose of the hardware transfer language (HTL) is to create a more @@ -52,7 +55,9 @@ Definition controllogic := PTree.t Verilog.stmnt. Definition map_well_formed {A : Type} (m : PTree.t A) : Prop := forall p0 : positive, In p0 (map fst (Maps.PTree.elements m)) -> - Z.pos p0 <= Integers.Int.max_unsigned. + (Z.pos p0 <= Integers.Int.max_unsigned)%Z. + +Definition module_ordering a b c d e f g := a < b < c /\ c < d < e /\ e < f < g. Record module: Type := mkmodule { @@ -68,10 +73,13 @@ Record module: Type := mod_start : reg; mod_reset : reg; mod_clk : reg; - mod_funct_units: funct_units; mod_scldecls : AssocMap.t (option Verilog.io * Verilog.scl_decl); mod_arrdecls : AssocMap.t (option Verilog.io * Verilog.arr_decl); - mod_wf : (map_well_formed mod_controllogic /\ map_well_formed mod_datapath); + mod_ram : option ram; + mod_wf : map_well_formed mod_controllogic /\ map_well_formed mod_datapath; + mod_ordering_wf : module_ordering mod_st mod_finish mod_return mod_stk mod_start mod_reset mod_clk; + mod_ram_wf : forall r', mod_ram = Some r' -> mod_clk < ram_addr r'; + mod_params_wf : Forall (Pos.gt mod_st) mod_params; }. Definition fundef := AST.fundef module. @@ -115,12 +123,47 @@ Inductive state : Type := (m : module) (args : list value), state. +Inductive exec_ram: + Verilog.reg_associations -> Verilog.arr_associations -> option ram -> + Verilog.reg_associations -> Verilog.arr_associations -> Prop := +| exec_ram_Some_idle: + forall ra ar r, + Int.eq (Verilog.assoc_blocking ra)#(ram_en r, 32) + (Verilog.assoc_blocking ra)#(ram_u_en r, 32) = true -> + exec_ram ra ar (Some r) ra ar +| exec_ram_Some_write: + forall ra ar r d_in addr en wr_en u_en, + Int.eq en u_en = false -> + Int.eq wr_en (ZToValue 0) = false -> + (Verilog.assoc_blocking ra)#(ram_en r, 32) = en -> + (Verilog.assoc_blocking ra)!(ram_u_en r) = Some u_en -> + (Verilog.assoc_blocking ra)!(ram_wr_en r) = Some wr_en -> + (Verilog.assoc_blocking ra)!(ram_d_in r) = Some d_in -> + (Verilog.assoc_blocking ra)!(ram_addr r) = Some addr -> + exec_ram ra ar (Some r) (Verilog.nonblock_reg (ram_en r) ra u_en) + (Verilog.nonblock_arr (ram_mem r) (valueToNat addr) ar d_in) +| exec_ram_Some_read: + forall ra ar r addr v_d_out en u_en, + Int.eq en u_en = false -> + (Verilog.assoc_blocking ra)#(ram_en r, 32) = en -> + (Verilog.assoc_blocking ra)!(ram_u_en r) = Some u_en -> + (Verilog.assoc_blocking ra)!(ram_wr_en r) = Some (ZToValue 0) -> + (Verilog.assoc_blocking ra)!(ram_addr r) = Some addr -> + Verilog.arr_assocmap_lookup (Verilog.assoc_blocking ar) + (ram_mem r) (valueToNat addr) = Some v_d_out -> + exec_ram ra ar (Some r) (Verilog.nonblock_reg (ram_en r) + (Verilog.nonblock_reg (ram_d_out r) ra v_d_out) u_en) ar +| exec_ram_None: + forall r a, + exec_ram r a None r a. + Inductive step : genv -> state -> Events.trace -> state -> Prop := | step_module : forall g m st sf ctrl data asr asa basr1 basa1 nasr1 nasa1 basr2 basa2 nasr2 nasa2 + basr3 basa3 nasr3 nasa3 asr' asa' f pstval, asr!(mod_reset m) = Some (ZToValue 0) -> @@ -141,10 +184,16 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := data (Verilog.mkassociations basr2 nasr2) (Verilog.mkassociations basa2 nasa2) -> - asr' = Verilog.merge_regs nasr2 basr2 -> - asa' = Verilog.merge_arrs nasa2 basa2 -> + exec_ram + (Verilog.mkassociations (Verilog.merge_regs nasr2 basr2) empty_assocmap) + (Verilog.mkassociations (Verilog.merge_arrs nasa2 basa2) (empty_stack m)) + (mod_ram m) + (Verilog.mkassociations basr3 nasr3) + (Verilog.mkassociations basa3 nasa3) -> + asr' = Verilog.merge_regs nasr3 basr3 -> + asa' = Verilog.merge_arrs nasa3 basa3 -> asr'!(m.(mod_st)) = Some (posToValue pstval) -> - Z.pos pstval <= Integers.Int.max_unsigned -> + (Z.pos pstval <= Integers.Int.max_unsigned)%Z -> step g (State sf m st asr asa) Events.E0 (State sf m pstval asr' asa') | step_finish : forall g m st asr asa retval sf, @@ -165,7 +214,7 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := mst = mod_st m -> step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) asa). -Hint Constructors step : htl. +#[export] Hint Constructors step : htl. Inductive initial_state (p: program): state -> Prop := | initial_state_intro: forall b m0 m, @@ -183,3 +232,110 @@ Inductive final_state : state -> Integers.int -> Prop := Definition semantics (m : program) := Smallstep.Semantics step (initial_state m) final_state (Globalenvs.Genv.globalenv m). + +Definition max_pc_function (m: module) := + List.fold_left Pos.max (List.map fst (PTree.elements m.(mod_controllogic))) 1. + +Definition max_list := fold_right Pos.max 1. + +Definition max_stmnt_tree t := + PTree.fold (fun i _ st => Pos.max (Verilog.max_reg_stmnt st) i) t 1. + +Definition max_reg_ram r := + match r with + | None => 1 + | Some ram => Pos.max (ram_mem ram) + (Pos.max (ram_en ram) + (Pos.max (ram_addr ram) + (Pos.max (ram_addr ram) + (Pos.max (ram_wr_en ram) + (Pos.max (ram_d_in ram) + (Pos.max (ram_d_out ram) (ram_u_en ram))))))) + end. + +Definition max_reg_module m := + Pos.max (max_list (mod_params m)) + (Pos.max (max_stmnt_tree (mod_datapath m)) + (Pos.max (max_stmnt_tree (mod_controllogic m)) + (Pos.max (mod_st m) + (Pos.max (mod_stk m) + (Pos.max (mod_finish m) + (Pos.max (mod_return m) + (Pos.max (mod_start m) + (Pos.max (mod_reset m) + (Pos.max (mod_clk m) (max_reg_ram (mod_ram m))))))))))). + +Lemma max_fold_lt : + forall m l n, m <= n -> m <= (fold_left Pos.max l n). +Proof. induction l; crush; apply IHl; lia. Qed. + +Lemma max_fold_lt2 : + forall (l: list (positive * Verilog.stmnt)) v n, + v <= n -> + v <= fold_left (fun a p => Pos.max (Verilog.max_reg_stmnt (snd p)) a) l n. +Proof. induction l; crush; apply IHl; lia. Qed. + +Lemma max_fold_lt3 : + forall (l: list (positive * Verilog.stmnt)) v v', + v <= v' -> + fold_left (fun a0 p => Pos.max (Verilog.max_reg_stmnt (snd p)) a0) l v + <= fold_left (fun a0 p => Pos.max (Verilog.max_reg_stmnt (snd p)) a0) l v'. +Proof. induction l; crush; apply IHl; lia. Qed. + +Lemma max_fold_lt4 : + forall (l: list (positive * Verilog.stmnt)) (a: positive * Verilog.stmnt), + fold_left (fun a0 p => Pos.max (Verilog.max_reg_stmnt (snd p)) a0) l 1 + <= fold_left (fun a0 p => Pos.max (Verilog.max_reg_stmnt (snd p)) a0) l + (Pos.max (Verilog.max_reg_stmnt (snd a)) 1). +Proof. intros; apply max_fold_lt3; lia. Qed. + +Lemma max_reg_stmnt_lt_stmnt_tree': + forall l (i: positive) v, + In (i, v) l -> + list_norepet (map fst l) -> + Verilog.max_reg_stmnt v <= fold_left (fun a p => Pos.max (Verilog.max_reg_stmnt (snd p)) a) l 1. +Proof. + induction l; crush. inv H; inv H0; simplify. apply max_fold_lt2. lia. + transitivity (fold_left (fun (a : positive) (p : positive * Verilog.stmnt) => + Pos.max (Verilog.max_reg_stmnt (snd p)) a) l 1). + eapply IHl; eauto. apply max_fold_lt4. +Qed. + +Lemma max_reg_stmnt_le_stmnt_tree : + forall d i v, + d ! i = Some v -> + Verilog.max_reg_stmnt v <= max_stmnt_tree d. +Proof. + intros. unfold max_stmnt_tree. rewrite PTree.fold_spec. + apply PTree.elements_correct in H. + eapply max_reg_stmnt_lt_stmnt_tree'; eauto. + apply PTree.elements_keys_norepet. +Qed. + +Lemma max_reg_stmnt_lt_stmnt_tree : + forall d i v, + d ! i = Some v -> + Verilog.max_reg_stmnt v < max_stmnt_tree d + 1. +Proof. intros. apply max_reg_stmnt_le_stmnt_tree in H; lia. Qed. + +Lemma max_stmnt_lt_module : + forall m d i, + (mod_controllogic m) ! i = Some d \/ (mod_datapath m) ! i = Some d -> + Verilog.max_reg_stmnt d < max_reg_module m + 1. +Proof. + inversion 1 as [ Hv | Hv ]; unfold max_reg_module; + apply max_reg_stmnt_le_stmnt_tree in Hv; lia. +Qed. + +Lemma max_list_correct l st : st > max_list l -> Forall (Pos.gt st) l. +Proof. induction l; crush; constructor; [|apply IHl]; lia. Qed. + +Definition max_list_dec (l: list reg) (st: reg) : {Forall (Pos.gt st) l} + {True}. + refine ( + match bool_dec (max_list l <? st) true with + | left _ => left _ + | _ => _ + end + ); auto. + apply max_list_correct. apply Pos.ltb_lt in e. lia. +Qed. diff --git a/src/hls/HTLPargen.v b/src/hls/HTLPargen.v index 629f53e..b66a704 100644 --- a/src/hls/HTLPargen.v +++ b/src/hls/HTLPargen.v @@ -1,6 +1,6 @@ (* * Vericert: Verified high-level synthesis. - * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> + * 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 @@ -29,16 +29,18 @@ Require Import vericert.common.Vericertlib. Require Import vericert.hls.AssocMap. Require Import vericert.hls.FunctionalUnits. Require Import vericert.hls.HTL. +Require Import vericert.hls.Predicate. Require Import vericert.hls.RTLBlockInstr. -Require Import vericert.hls.RTLPar. +Require Import vericert.hls.RTLParFU. +Require Import vericert.hls.FunctionalUnits. 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. +#[local] Hint Resolve AssocMap.gempty : htlh. +#[local] Hint Resolve AssocMap.gso : htlh. +#[local] Hint Resolve AssocMap.gss : htlh. +#[local] Hint Resolve Ple_refl : htlh. +#[local] Hint Resolve Ple_succ : htlh. Definition assignment : Type := expr -> expr -> stmnt. @@ -50,7 +52,6 @@ Record state: Type := mkstate { st_arrdecls: AssocMap.t (option io * arr_decl); st_datapath: datapath; st_controllogic: controllogic; - st_funct_units: funct_units; }. Definition init_state (st : reg) : state := @@ -60,8 +61,7 @@ Definition init_state (st : reg) : state := (AssocMap.empty (option io * scl_decl)) (AssocMap.empty (option io * arr_decl)) (AssocMap.empty stmnt) - (AssocMap.empty stmnt) - initial_funct_units. + (AssocMap.empty stmnt). Module HTLState <: State. @@ -77,10 +77,10 @@ Module HTLState <: State. s1.(st_controllogic)!n = None \/ s2.(st_controllogic)!n = s1.(st_controllogic)!n) -> st_incr s1 s2. - Hint Constructors st_incr : htlh. + #[local] Hint Constructors st_incr : htlh. Definition st_prop := st_incr. - Hint Unfold st_prop : htlh. + #[local] Hint Unfold st_prop : htlh. Lemma st_refl : forall s, st_prop s s. Proof. auto with htlh. Qed. @@ -131,9 +131,8 @@ Lemma declare_reg_state_incr : (AssocMap.set r (i, VScalar sz) s.(st_scldecls)) s.(st_arrdecls) s.(st_datapath) - s.(st_controllogic) - s.(st_funct_units)). -Proof. auto with htlh. Qed. + s.(st_controllogic)). +Proof. Admitted. Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit := fun s => OK tt (mkstate @@ -143,8 +142,7 @@ Definition declare_reg (i : option io) (r : reg) (sz : nat) : mon unit := (AssocMap.set r (i, VScalar sz) s.(st_scldecls)) s.(st_arrdecls) s.(st_datapath) - s.(st_controllogic) - s.(st_funct_units)) + s.(st_controllogic)) (declare_reg_state_incr i s r sz). Lemma add_instr_state_incr : @@ -158,8 +156,7 @@ Lemma add_instr_state_incr : 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)) - s.(st_funct_units)). + (AssocMap.set n (state_goto s.(st_st) n') s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -177,8 +174,7 @@ Definition add_instr (n : node) (n' : node) (st : stmnt) : mon unit := 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)) - s.(st_funct_units)) + (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. @@ -194,8 +190,7 @@ Lemma add_instr_skip_state_incr : s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n Vskip s.(st_controllogic)) - s.(st_funct_units)). + (AssocMap.set n Vskip s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -213,8 +208,7 @@ Definition add_instr_skip (n : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n st s.(st_datapath)) - (AssocMap.set n Vskip s.(st_controllogic)) - s.(st_funct_units)) + (AssocMap.set n Vskip s.(st_controllogic))) (add_instr_skip_state_incr s n st TRANS) | _ => Error (Errors.msg "HTL.add_instr_skip") end. @@ -230,8 +224,7 @@ Lemma add_node_skip_state_incr : s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n Vskip s.(st_datapath)) - (AssocMap.set n st s.(st_controllogic)) - s.(st_funct_units)). + (AssocMap.set n st s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -249,8 +242,7 @@ Definition add_node_skip (n : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) (AssocMap.set n Vskip s.(st_datapath)) - (AssocMap.set n st s.(st_controllogic)) - s.(st_funct_units)) + (AssocMap.set n st s.(st_controllogic))) (add_node_skip_state_incr s n st TRANS) | _ => Error (Errors.msg "HTL.add_node_skip") end. @@ -347,8 +339,7 @@ Lemma create_reg_state_incr: (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls)) s.(st_arrdecls) (st_datapath s) - (st_controllogic s) - s.(st_funct_units)). + (st_controllogic s)). Proof. constructor; simpl; auto with htlh. Qed. Definition create_reg (i : option io) (sz : nat) : mon reg := @@ -360,8 +351,7 @@ Definition create_reg (i : option io) (sz : nat) : mon reg := (AssocMap.set s.(st_freshreg) (i, VScalar sz) s.(st_scldecls)) (st_arrdecls s) (st_datapath s) - (st_controllogic s) - s.(st_funct_units)) + (st_controllogic s)) (create_reg_state_incr s sz i). Definition translate_eff_addressing (a: Op.addressing) (args: list reg) @@ -445,8 +435,7 @@ Lemma add_branch_instr_state_incr: 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)) - s.(st_funct_units)). + (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); @@ -464,8 +453,7 @@ Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit := 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)) - s.(st_funct_units)) + (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. @@ -516,8 +504,7 @@ Lemma create_arr_state_incr: s.(st_scldecls) (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls)) (st_datapath s) - (st_controllogic s) - s.(st_funct_units)). + (st_controllogic s)). Proof. constructor; simpl; auto with htlh. Qed. Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) := @@ -529,8 +516,7 @@ Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) := s.(st_scldecls) (AssocMap.set s.(st_freshreg) (i, VArray sz ln) s.(st_arrdecls)) (st_datapath s) - (st_controllogic s) - s.(st_funct_units)) + (st_controllogic s)) (create_arr_state_incr s sz ln i). Definition max_pc_map (m : Maps.PTree.t stmnt) := @@ -593,8 +579,7 @@ Lemma add_data_instr_state_incr : s.(st_arrdecls) (AssocMap.set n (Vseq (AssocMapExt.get_default _ Vskip n s.(st_datapath)) st) s.(st_datapath)) - s.(st_controllogic) - s.(st_funct_units)). + s.(st_controllogic)). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -610,8 +595,7 @@ Definition add_data_instr (n : node) (st : stmnt) : mon unit := 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) - s.(st_funct_units)) + s.(st_controllogic)) (add_data_instr_state_incr s n st). Lemma add_control_instr_state_incr : @@ -625,8 +609,7 @@ Lemma add_control_instr_state_incr : s.(st_scldecls) s.(st_arrdecls) s.(st_datapath) - (AssocMap.set n st s.(st_controllogic)) - s.(st_funct_units)). + (AssocMap.set n st s.(st_controllogic))). Proof. constructor; intros; try (simpl; destruct (peq n n0); subst); @@ -644,19 +627,45 @@ Definition add_control_instr (n : node) (st : stmnt) : mon unit := s.(st_scldecls) s.(st_arrdecls) s.(st_datapath) - (AssocMap.set n st s.(st_controllogic)) - s.(st_funct_units)) + (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) + | Plit (b, pred) => + if b + then Vrange preg (Vlit (posToValue pred)) (Vlit (posToValue pred)) + else Vunop Vnot (Vrange preg (Vlit (posToValue pred)) (Vlit (posToValue pred))) + | Ptrue => Vlit (ZToValue 1) + | Pfalse => Vlit (ZToValue 0) | Pand p1 p2 => Vbinop Vand (pred_expr preg p1) (pred_expr preg p2) | Por p1 p2 => @@ -671,33 +680,20 @@ Definition translate_predicate (a : assignment) ret (a dst (Vternary (pred_expr preg pos) e dst)) end. -Definition translate_inst a (fu : funct_units) (fin rtrn stack preg : reg) (n : node) (i : instr) +Definition translate_inst a (fin rtrn stack preg : reg) (n : node) (i : instr) : mon stmnt := match i with - | RBnop => + | FUnop => ret Vskip - | RBop p op args dst => + | FUop p op args dst => do instr <- translate_instr op args; do _ <- declare_reg None dst 32; translate_predicate a preg p (Vvar dst) instr - | RBload p chunk addr args dst => - do src <- translate_arr_access chunk addr args stack; - do _ <- declare_reg None dst 32; - translate_predicate a preg p (Vvar dst) src - | RBstore p chunk addr args src => - do dst <- translate_arr_access chunk addr args stack; - translate_predicate a preg p dst (Vvar src) - | RBsetpred c args p => + | FUread p1 p2 r => ret Vskip + | FUwrite p1 p2 r => ret Vskip + | FUsetpred _ c args p => do cond <- translate_condition c args; - ret (a (pred_expr preg (Pvar p)) cond) - | RBpiped p f args => - match PTree.get f fu.(avail_units), args with - | Some (SignedDiv s n d q _), r1::r2::nil => - ret (Vseq (a (Vvar n) (Vvar r1)) (a (Vvar d) (Vvar r2))) - | _, _ => error (Errors.msg "HTLPargen.translate_inst: not a signed divide.") - end - | RBassign p f src dst => - ret (a (Vvar dst) (Vvar src)) + ret (a (pred_expr preg (Plit (true, p))) cond) end. Lemma create_new_state_state_incr: @@ -710,8 +706,7 @@ Lemma create_new_state_state_incr: s.(st_scldecls) s.(st_arrdecls) s.(st_datapath) - s.(st_controllogic) - s.(st_funct_units)). + s.(st_controllogic)). Admitted. Definition create_new_state (p: node): mon node := @@ -723,17 +718,15 @@ Definition create_new_state (p: node): mon node := s.(st_scldecls) s.(st_arrdecls) s.(st_datapath) - s.(st_controllogic) - s.(st_funct_units)) + s.(st_controllogic)) (create_new_state_state_incr s p). -Definition translate_inst_list (fu: funct_units) - (fin rtrn stack preg: reg) (ni : node * node * list (list instr)) := +Definition translate_inst_list (fin rtrn stack preg: reg) (ni : node * node * list (list instr)) := match ni with | (n, p, li) => do _ <- collectlist (fun l => - do stmnt <- translate_inst Vblock fu fin rtrn stack preg n l; + do stmnt <- translate_inst Vblock fin rtrn stack preg n l; add_data_instr n stmnt) (concat li); do st <- get; add_control_instr n (state_goto st.(st_st) p) @@ -742,14 +735,14 @@ Definition translate_inst_list (fu: funct_units) Fixpoint translate_cfi' (fin rtrn stack preg: reg) (cfi: cf_instr) : mon (stmnt * stmnt) := match cfi with - | RBgoto n' => + | FUgoto n' => do st <- get; ret (Vskip, state_goto st.(st_st) n') - | RBcond c args n1 n2 => + | FUcond 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 => + | FUreturn r => match r with | Some r' => ret ((Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r'))), @@ -758,18 +751,18 @@ Fixpoint translate_cfi' (fin rtrn stack preg: reg) (cfi: cf_instr) ret ((Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z)))), Vskip) end - | RBpred_cf p c1 c2 => + | FUpred_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 => + | FUjumptable 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 => + ret (Vskip, Vcase (Vvar r) (list_to_stmnt (tbl_to_case_expr s.(st_st) tbl)) (Some Vskip)) + | FUcall sig ri rl r n => error (Errors.msg "HTLPargen: RPcall not supported.") - | RBtailcall sig ri lr => + | FUtailcall sig ri lr => error (Errors.msg "HTLPargen: RPtailcall not supported.") - | RBbuiltin e lb b n => + | FUbuiltin e lb b n => error (Errors.msg "HTLPargen: RPbuildin not supported.") end. @@ -780,11 +773,11 @@ Definition translate_cfi (fin rtrn stack preg: reg) (ni: node * cf_instr) do _ <- add_control_instr n c; add_data_instr n s. -Definition transf_bblock (fu: funct_units) (fin rtrn stack preg: reg) (ni : node * bblock) +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 fu fin rtrn stack preg) + 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 @@ -792,14 +785,31 @@ Definition transf_bblock (fu: funct_units) (fin rtrn stack preg: reg) (ni : node | _ => translate_cfi fin rtrn stack preg (nstate, bb.(bb_exit)) end. -Definition transf_module (f: function) : mon HTL.module := +Definition decide_order a b c d e f g : {module_ordering a b c d e f g} + {True}. + refine (match bool_dec ((a <? b) && (b <? c) && (c <? d) + && (d <? e) && (e <? f) && (f <? g))%positive true with + | left t => left _ + | _ => _ + end); auto. + simplify; repeat match goal with + | H: context[(_ <? _)%positive] |- _ => apply Pos.ltb_lt in H + end; unfold module_ordering; auto. +Defined. + +Lemma clk_greater : + forall ram clk r', + Some ram = Some r' -> (clk < ram_addr r')%positive. +Proof. Admitted. + +Definition transf_module (f: function) : mon HTL.module. + refine ( 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 f.(fn_funct_units) fin rtrn stack preg) + 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); @@ -810,8 +820,12 @@ Definition transf_module (f: function) : mon HTL.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 => + Integers.Int.max_unsigned, + decide_order (st_st current_state) fin rtrn stack start rst clk, + max_list_dec (fn_params f) (st_st current_state), + get_ram 0 (fn_funct_units f) + with + | left LEDATA, left LECTRL, left MORD, left WFPARAMS, Some (i, ram) => ret (HTL.mkmodule f.(fn_params) current_state.(st_datapath) @@ -825,13 +839,40 @@ Definition transf_module (f: function) : mon HTL.module := start rst clk - f.(fn_funct_units) 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.") + (Some ram) + (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)) + MORD + _ + WFPARAMS) + | left LEDATA, left LECTRL, left MORD, left WFPARAMS, _ => + 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) + None + (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)) + MORD + _ + WFPARAMS) + | _, _, _, _, _ => error (Errors.msg "More than 2^32 states.") end - else error (Errors.msg "Stack size misalignment."). + else error (Errors.msg "Stack size misalignment.")). + apply clk_greater. + discriminate. +Defined. Definition max_state (f: function) : state := let st := Pos.succ (max_reg_function f) in @@ -841,15 +882,14 @@ Definition max_state (f: function) : state := (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)) - (st_funct_units (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 := +Definition main_is_internal (p : RTLParFU.program) : bool := let ge := Globalenvs.Genv.globalenv p in match Globalenvs.Genv.find_symbol ge p.(AST.prog_main) with | Some b => @@ -860,7 +900,7 @@ Definition main_is_internal (p : RTLPar.program) : bool := | _ => false end. -Definition transl_program (p : RTLBlockInstr.program) : Errors.res HTL.program := +Definition transl_program (p : RTLParFU.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/HTLgen.v b/src/hls/HTLgen.v index 76616fb..b879c8d 100644 --- a/src/hls/HTLgen.v +++ b/src/hls/HTLgen.v @@ -34,11 +34,11 @@ Require Import vericert.hls.ValueInt. Require Import vericert.hls.Verilog. Require Import vericert.hls.FunctionalUnits. -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. +#[local] Hint Resolve AssocMap.gempty : htlh. +#[local] Hint Resolve AssocMap.gso : htlh. +#[local] Hint Resolve AssocMap.gss : htlh. +#[local] Hint Resolve Ple_refl : htlh. +#[local] Hint Resolve Ple_succ : htlh. Record state: Type := mkstate { st_st : reg; @@ -75,10 +75,10 @@ Module HTLState <: State. s1.(st_controllogic)!n = None \/ s2.(st_controllogic)!n = s1.(st_controllogic)!n) -> st_incr s1 s2. - Hint Constructors st_incr : htlh. + #[export] Hint Constructors st_incr : htlh. Definition st_prop := st_incr. - Hint Unfold st_prop : htlh. + #[export] Hint Unfold st_prop : htlh. Lemma st_refl : forall s, st_prop s s. Proof. auto with htlh. Qed. @@ -584,7 +584,19 @@ Proof. simplify. transitivity (Z.pos (max_pc_map m)); eauto. Qed. -Definition transf_module (f: function) : mon HTL.module := +Definition decide_order a b c d e f g : {module_ordering a b c d e f g} + {True}. + refine (match bool_dec ((a <? b) && (b <? c) && (c <? d) + && (d <? e) && (e <? f) && (f <? g))%positive true with + | left t => left _ + | _ => _ + end); auto. + simplify; repeat match goal with + | H: context[(_ <? _)%positive] |- _ => apply Pos.ltb_lt in H + end; unfold module_ordering; auto. +Defined. + +Definition transf_module (f: function) : mon HTL.module. + refine ( if stack_correct f.(fn_stacksize) then do fin <- create_reg (Some Voutput) 1; do rtrn <- create_reg (Some Voutput) 32; @@ -596,8 +608,11 @@ Definition transf_module (f: function) : mon HTL.module := 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 => + zle (Z.pos (max_pc_map current_state.(st_controllogic))) Integers.Int.max_unsigned, + decide_order (st_st current_state) fin rtrn stack start rst clk, + max_list_dec (RTL.fn_params f) (st_st current_state) + with + | left LEDATA, left LECTRL, left MORD, left WFPARAMS => ret (HTL.mkmodule f.(RTL.fn_params) current_state.(st_datapath) @@ -611,19 +626,23 @@ Definition transf_module (f: function) : mon HTL.module := start rst clk - initial_funct_units 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.") + None + (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA)) + MORD + _ + WFPARAMS) + | _, _, _, _ => error (Errors.msg "More than 2^32 states.") end - else error (Errors.msg "Stack size misalignment."). + else error (Errors.msg "Stack size misalignment.")); discriminate. +Defined. 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)) + (Pos.succ (RTL.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)) @@ -634,23 +653,6 @@ Definition transl_module (f : function) : Errors.res HTL.module := 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 : RTL.program) : bool := let ge := Globalenvs.Genv.globalenv p in match Globalenvs.Genv.find_symbol ge p.(AST.prog_main) with diff --git a/src/hls/HTLgenproof.v b/src/hls/HTLgenproof.v index 9a7e272..fc7af6b 100644 --- a/src/hls/HTLgenproof.v +++ b/src/hls/HTLgenproof.v @@ -1,4 +1,4 @@ - (* +(* * Vericert: Verified high-level synthesis. * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> * 2020 James Pollard <j@mes.dev> @@ -40,24 +40,24 @@ Require Import Lia. Local Open Scope assocmap. -Hint Resolve Smallstep.forward_simulation_plus : htlproof. -Hint Resolve AssocMap.gss : htlproof. -Hint Resolve AssocMap.gso : htlproof. +#[local] Hint Resolve Smallstep.forward_simulation_plus : htlproof. +#[local] Hint Resolve AssocMap.gss : htlproof. +#[local] Hint Resolve AssocMap.gso : htlproof. -Hint Unfold find_assocmap AssocMapExt.get_default : htlproof. +#[local] Hint Unfold find_assocmap AssocMapExt.get_default : htlproof. Inductive match_assocmaps : RTL.function -> RTL.regset -> assocmap -> Prop := match_assocmap : forall f rs am, (forall r, Ple r (RTL.max_reg_function f) -> val_value_lessdef (Registers.Regmap.get r rs) am#r) -> match_assocmaps f rs am. -Hint Constructors match_assocmaps : htlproof. +#[local] Hint Constructors match_assocmaps : htlproof. Definition state_st_wf (m : HTL.module) (s : HTL.state) := forall st asa asr res, s = HTL.State res m st asa asr -> asa!(m.(HTL.mod_st)) = Some (posToValue st). -Hint Unfold state_st_wf : htlproof. +#[local] Hint Unfold state_st_wf : htlproof. Inductive match_arrs (m : HTL.module) (f : RTL.function) (sp : Values.val) (mem : mem) : Verilog.assocmap_arr -> Prop := @@ -133,7 +133,7 @@ Inductive match_states : RTL.state -> HTL.state -> Prop := forall f m m0 (TF : tr_module f m), match_states (RTL.Callstate nil (AST.Internal f) nil m0) (HTL.Callstate nil m nil). -Hint Constructors match_states : htlproof. +#[local] Hint Constructors match_states : htlproof. Definition match_prog (p: RTL.program) (tp: HTL.program) := Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp /\ @@ -187,7 +187,7 @@ Proof. apply Pos.le_lt_trans with _ _ n in H2. unfold not. intros. subst. eapply Pos.lt_irrefl. eassumption. assumption. Qed. -Hint Resolve regs_lessdef_add_greater : htlproof. +#[local] Hint Resolve regs_lessdef_add_greater : htlproof. Lemma regs_lessdef_add_match : forall f rs am r v v', @@ -206,7 +206,7 @@ Proof. unfold find_assocmap. unfold AssocMapExt.get_default. rewrite AssocMap.gso; eauto. Qed. -Hint Resolve regs_lessdef_add_match : htlproof. +#[local] Hint Resolve regs_lessdef_add_match : htlproof. Lemma list_combine_none : forall n l, @@ -348,7 +348,7 @@ Proof. eexists. unfold Verilog.arr_assocmap_lookup. rewrite H5. reflexivity. Qed. -Hint Resolve arr_lookup_some : htlproof. +#[local] Hint Resolve arr_lookup_some : htlproof. Section CORRECTNESS. @@ -392,7 +392,7 @@ Section CORRECTNESS. Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof (Genv.senv_transf_partial TRANSL'). - Hint Resolve senv_preserved : htlproof. + #[local] Hint Resolve senv_preserved : htlproof. Lemma ptrofs_inj : forall a b, @@ -1030,6 +1030,7 @@ Section CORRECTNESS. Ltac tac0 := match goal with + | [ |- HTL.exec_ram _ _ _ _ _ ] => constructor | [ |- context[Verilog.merge_arrs _ _] ] => unfold Verilog.merge_arrs | [ |- context[Verilog.merge_arr] ] => unfold Verilog.merge_arr | [ |- context[Verilog.merge_regs _ _] ] => unfold Verilog.merge_regs; crush; unfold_merge @@ -1103,7 +1104,7 @@ Section CORRECTNESS. Unshelve. exact tt. Qed. - Hint Resolve transl_inop_correct : htlproof. + #[local] Hint Resolve transl_inop_correct : htlproof. Lemma transl_iop_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) @@ -1155,7 +1156,7 @@ Section CORRECTNESS. unfold Ple in HPle. lia. Unshelve. exact tt. Qed. - Hint Resolve transl_iop_correct : htlproof. + #[local] Hint Resolve transl_iop_correct : htlproof. Ltac tac := repeat match goal with @@ -1628,7 +1629,7 @@ Section CORRECTNESS. exact (Values.Vint (Int.repr 0)). exact tt. Qed. - Hint Resolve transl_iload_correct : htlproof. + #[local] Hint Resolve transl_iload_correct : htlproof. Lemma transl_istore_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) @@ -1701,7 +1702,7 @@ Section CORRECTNESS. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. - all: crush. + all: try constructor; crush. (** State Lookup *) unfold Verilog.merge_regs. @@ -1735,11 +1736,21 @@ Section CORRECTNESS. crush. unfold Verilog.merge_arrs. - rewrite AssocMap.gcombine. - 2: { reflexivity. } + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. + erewrite Verilog.merge_arr_empty2. unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. rewrite AssocMap.gss. unfold Verilog.merge_arr. + setoid_rewrite H7. + reflexivity. + + rewrite AssocMap.gcombine by reflexivity. + unfold Verilog.merge_arr. + unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gss. rewrite AssocMap.gss. setoid_rewrite H7. reflexivity. @@ -1747,12 +1758,23 @@ Section CORRECTNESS. rewrite combine_length. rewrite <- array_set_len. unfold arr_repeat. crush. + symmetry. apply list_repeat_len. rewrite <- array_set_len. unfold arr_repeat. crush. - rewrite list_repeat_len. - rewrite H4. reflexivity. + rewrite H4. + apply list_repeat_len. + + rewrite combine_length. + rewrite <- array_set_len. + unfold arr_repeat. crush. + apply list_repeat_len. + + rewrite <- array_set_len. + unfold arr_repeat. crush. + rewrite H4. + apply list_repeat_len. remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. @@ -1981,7 +2003,7 @@ Section CORRECTNESS. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. econstructor. - all: crush. + all: try constructor; crush. (** State Lookup *) unfold Verilog.merge_regs. @@ -2014,11 +2036,21 @@ Section CORRECTNESS. crush. unfold Verilog.merge_arrs. - rewrite AssocMap.gcombine. - 2: { reflexivity. } + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. + erewrite Verilog.merge_arr_empty2. unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gcombine by reflexivity. rewrite AssocMap.gss. + rewrite AssocMap.gss. + unfold Verilog.merge_arr. + setoid_rewrite H7. + reflexivity. + + rewrite AssocMap.gcombine by reflexivity. unfold Verilog.merge_arr. + unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gss. rewrite AssocMap.gss. setoid_rewrite H7. reflexivity. @@ -2026,12 +2058,23 @@ Section CORRECTNESS. rewrite combine_length. rewrite <- array_set_len. unfold arr_repeat. crush. + symmetry. apply list_repeat_len. rewrite <- array_set_len. unfold arr_repeat. crush. - rewrite list_repeat_len. - rewrite H4. reflexivity. + rewrite H4. + apply list_repeat_len. + + rewrite combine_length. + rewrite <- array_set_len. + unfold arr_repeat. crush. + apply list_repeat_len. + + rewrite <- array_set_len. + unfold arr_repeat. crush. + rewrite H4. + apply list_repeat_len. remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int @@ -2229,7 +2272,7 @@ Section CORRECTNESS. eapply Verilog.stmnt_runp_Vnonblock_arr. crush. econstructor. econstructor. econstructor. econstructor. - all: crush. + all: try constructor; crush. (** State Lookup *) unfold Verilog.merge_regs. @@ -2263,11 +2306,21 @@ Section CORRECTNESS. crush. unfold Verilog.merge_arrs. - rewrite AssocMap.gcombine. - 2: { reflexivity. } + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. + erewrite Verilog.merge_arr_empty2. unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gcombine by reflexivity. + rewrite AssocMap.gss. rewrite AssocMap.gss. unfold Verilog.merge_arr. + setoid_rewrite H7. + reflexivity. + + rewrite AssocMap.gcombine by reflexivity. + unfold Verilog.merge_arr. + unfold Verilog.arr_assocmap_set. + rewrite AssocMap.gss. rewrite AssocMap.gss. setoid_rewrite H7. reflexivity. @@ -2275,12 +2328,23 @@ Section CORRECTNESS. rewrite combine_length. rewrite <- array_set_len. unfold arr_repeat. crush. + symmetry. + apply list_repeat_len. + + rewrite <- array_set_len. + unfold arr_repeat. crush. + rewrite H4. + apply list_repeat_len. + + rewrite combine_length. + rewrite <- array_set_len. + unfold arr_repeat. crush. apply list_repeat_len. rewrite <- array_set_len. unfold arr_repeat. crush. - rewrite list_repeat_len. - rewrite H4. reflexivity. + rewrite H4. + apply list_repeat_len. remember i0 as OFFSET. destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). @@ -2435,7 +2499,7 @@ Section CORRECTNESS. exact tt. exact (Values.Vint (Int.repr 0)). Qed. - Hint Resolve transl_istore_correct : htlproof. + #[local] Hint Resolve transl_istore_correct : htlproof. Lemma transl_icond_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) @@ -2463,7 +2527,7 @@ Section CORRECTNESS. eapply eval_cond_correct; eauto. intros. intros. eapply RTL.max_reg_function_use. apply H22. auto. econstructor. auto. - simpl. econstructor. unfold Verilog.merge_regs. unfold_merge. simpl. + simpl. econstructor. constructor. unfold Verilog.merge_regs. unfold_merge. simpl. apply AssocMap.gss. inv MARR. inv CONST. @@ -2480,7 +2544,7 @@ Section CORRECTNESS. eapply eval_cond_correct; eauto. intros. intros. eapply RTL.max_reg_function_use. apply H22. auto. econstructor. auto. - simpl. econstructor. unfold Verilog.merge_regs. unfold_merge. simpl. + simpl. econstructor. constructor. unfold Verilog.merge_regs. unfold_merge. simpl. apply AssocMap.gss. inv MARR. inv CONST. @@ -2489,7 +2553,7 @@ Section CORRECTNESS. Unshelve. all: exact tt. Qed. - Hint Resolve transl_icond_correct : htlproof. + #[local] Hint Resolve transl_icond_correct : htlproof. (*Lemma transl_ijumptable_correct: forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) @@ -2505,7 +2569,7 @@ Section CORRECTNESS. Proof. intros s f sp pc rs m arg tbl n pc' H H0 H1 R1 MSTATE. - Hint Resolve transl_ijumptable_correct : htlproof.*) + #[local] Hint Resolve transl_ijumptable_correct : htlproof.*) Lemma transl_ireturn_correct: forall (s : list RTL.stackframe) (f : RTL.function) (stk : Values.block) @@ -2535,10 +2599,10 @@ Section CORRECTNESS. econstructor; simpl; trivial. constructor. - constructor. constructor. + constructor. constructor. constructor. unfold state_st_wf in WF; big_tac; eauto. - destruct wf as [HCTRL HDATA]. apply HCTRL. + destruct wf1 as [HCTRL HDATA]. apply HCTRL. apply AssocMapExt.elements_iff. eexists. match goal with H: control ! pc = Some _ |- _ => apply H end. @@ -2564,16 +2628,18 @@ Section CORRECTNESS. econstructor; simpl; trivial. constructor. constructor. constructor. constructor. constructor. constructor. + constructor. unfold state_st_wf in WF; big_tac; eauto. - destruct wf as [HCTRL HDATA]. apply HCTRL. + destruct wf1 as [HCTRL HDATA]. apply HCTRL. apply AssocMapExt.elements_iff. eexists. match goal with H: control ! pc = Some _ |- _ => apply H end. apply HTL.step_finish. unfold Verilog.merge_regs. unfold_merge. + unfold_merge. rewrite AssocMap.gso. apply AssocMap.gss. simpl; lia. apply AssocMap.gss. @@ -2591,7 +2657,7 @@ Section CORRECTNESS. Unshelve. all: constructor. Qed. - Hint Resolve transl_ireturn_correct : htlproof. + #[local] Hint Resolve transl_ireturn_correct : htlproof. Lemma transl_callstate_correct: forall (s : list RTL.stackframe) (f : RTL.function) (args : list Values.val) @@ -2699,7 +2765,7 @@ Section CORRECTNESS. Opaque Mem.load. Opaque Mem.store. Qed. - Hint Resolve transl_callstate_correct : htlproof. + #[local] Hint Resolve transl_callstate_correct : htlproof. Lemma transl_returnstate_correct: forall (res0 : Registers.reg) (f : RTL.function) (sp : Values.val) (pc : RTL.node) @@ -2713,7 +2779,7 @@ Section CORRECTNESS. intros res0 f sp pc rs s vres m R1 MSTATE. inversion MSTATE. inversion MF. Qed. - Hint Resolve transl_returnstate_correct : htlproof. + #[local] Hint Resolve transl_returnstate_correct : htlproof. Lemma option_inv : forall A x y, @@ -2773,7 +2839,7 @@ Section CORRECTNESS. rewrite <- H6. setoid_rewrite <- A. trivial. trivial. inv H7. assumption. Qed. - Hint Resolve transl_initial_states : htlproof. + #[local] Hint Resolve transl_initial_states : htlproof. Lemma transl_final_states : forall (s1 : Smallstep.state (RTL.semantics prog)) @@ -2785,7 +2851,7 @@ Section CORRECTNESS. Proof. intros. inv H0. inv H. inv H4. invert MF. constructor. reflexivity. Qed. - Hint Resolve transl_final_states : htlproof. + #[local] Hint Resolve transl_final_states : htlproof. Theorem transl_step_correct: forall (S1 : RTL.state) t S2, @@ -2796,7 +2862,7 @@ Section CORRECTNESS. Proof. induction 1; eauto with htlproof; (intros; inv_state). Qed. - Hint Resolve transl_step_correct : htlproof. + #[local] Hint Resolve transl_step_correct : htlproof. Theorem transf_program_correct: Smallstep.forward_simulation (RTL.semantics prog) (HTL.semantics tprog). diff --git a/src/hls/HTLgenspec.v b/src/hls/HTLgenspec.v index 556e3cc..75d5321 100644 --- a/src/hls/HTLgenspec.v +++ b/src/hls/HTLgenspec.v @@ -33,8 +33,8 @@ Require Import vericert.hls.HTLgen. Require Import vericert.hls.AssocMap. Require Import vericert.hls.FunctionalUnits. -Hint Resolve Maps.PTree.elements_keys_norepet : htlspec. -Hint Resolve Maps.PTree.elements_correct : htlspec. +#[local] Hint Resolve Maps.PTree.elements_keys_norepet : htlspec. +#[local] Hint Resolve Maps.PTree.elements_correct : htlspec. Remark bind_inversion: forall (A B: Type) (f: mon A) (g: A -> mon B) @@ -164,7 +164,7 @@ Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt - forall cexpr tbl r, cexpr = tbl_to_case_expr st tbl -> tr_instr fin rtrn st stk (RTL.Ijumptable r tbl) (Vskip) (Vcase (Vvar r) cexpr (Some Vskip)).*) -Hint Constructors tr_instr : htlspec. +#[local] Hint Constructors tr_instr : htlspec. Inductive tr_code (c : RTL.code) (pc : RTL.node) (i : RTL.instruction) (stmnts trans : PTree.t stmnt) (fin rtrn st stk : reg) : Prop := @@ -175,16 +175,16 @@ Inductive tr_code (c : RTL.code) (pc : RTL.node) (i : RTL.instruction) (stmnts t trans!pc = Some t -> tr_instr fin rtrn st stk i s t -> tr_code c pc i stmnts trans fin rtrn st stk. -Hint Constructors tr_code : htlspec. +#[local] Hint Constructors tr_code : htlspec. Inductive tr_module (f : RTL.function) : module -> Prop := tr_module_intro : - forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf, + forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf1 wf2 wf3 wf4, m = (mkmodule f.(RTL.fn_params) data control f.(RTL.fn_entrypoint) - st stk stk_len fin rtrn start rst clk initial_funct_units scldecls arrdecls wf) -> + st stk stk_len fin rtrn start rst clk scldecls arrdecls None wf1 wf2 wf3 wf4) -> (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> @@ -198,70 +198,70 @@ Inductive tr_module (f : RTL.function) : module -> Prop := rst = ((RTL.max_reg_function f) + 6)%positive -> clk = ((RTL.max_reg_function f) + 7)%positive -> tr_module f m. -Hint Constructors tr_module : htlspec. +#[local] Hint Constructors tr_module : htlspec. Lemma create_reg_datapath_trans : forall sz s s' x i iop, create_reg iop sz s = OK x s' i -> s.(st_datapath) = s'.(st_datapath). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_datapath_trans : htlspec. +#[local] Hint Resolve create_reg_datapath_trans : htlspec. Lemma create_reg_controllogic_trans : forall sz s s' x i iop, create_reg iop sz s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_controllogic_trans : htlspec. +#[local] Hint Resolve create_reg_controllogic_trans : htlspec. Lemma declare_reg_datapath_trans : forall sz s s' x i iop r, declare_reg iop r sz s = OK x s' i -> s.(st_datapath) = s'.(st_datapath). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_datapath_trans : htlspec. +#[local] Hint Resolve create_reg_datapath_trans : htlspec. Lemma declare_reg_controllogic_trans : forall sz s s' x i iop r, declare_reg iop r sz s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_controllogic_trans : htlspec. +#[local] Hint Resolve create_reg_controllogic_trans : htlspec. Lemma declare_reg_freshreg_trans : forall sz s s' x i iop r, declare_reg iop r sz s = OK x s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. inversion 1; auto. Qed. -Hint Resolve declare_reg_freshreg_trans : htlspec. +#[local] Hint Resolve declare_reg_freshreg_trans : htlspec. Lemma create_arr_datapath_trans : forall sz ln s s' x i iop, create_arr iop sz ln s = OK x s' i -> s.(st_datapath) = s'.(st_datapath). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_arr_datapath_trans : htlspec. +#[local] Hint Resolve create_arr_datapath_trans : htlspec. Lemma create_arr_controllogic_trans : forall sz ln s s' x i iop, create_arr iop sz ln s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic). Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_arr_controllogic_trans : htlspec. +#[local] Hint Resolve create_arr_controllogic_trans : htlspec. Lemma get_refl_x : forall s s' x i, get s = OK x s' i -> s = x. Proof. inversion 1. trivial. Qed. -Hint Resolve get_refl_x : htlspec. +#[local] Hint Resolve get_refl_x : htlspec. Lemma get_refl_s : forall s s' x i, get s = OK x s' i -> s = s'. Proof. inversion 1. trivial. Qed. -Hint Resolve get_refl_s : htlspec. +#[local] Hint Resolve get_refl_s : htlspec. Ltac inv_incr := repeat match goal with @@ -350,7 +350,7 @@ Lemma translate_eff_addressing_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. +#[local] Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. Lemma translate_comparison_freshreg_trans : forall op args s r s' i, @@ -359,7 +359,7 @@ Lemma translate_comparison_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_comparison_freshreg_trans : htlspec. +#[local] Hint Resolve translate_comparison_freshreg_trans : htlspec. Lemma translate_comparisonu_freshreg_trans : forall op args s r s' i, @@ -368,7 +368,7 @@ Lemma translate_comparisonu_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_comparisonu_freshreg_trans : htlspec. +#[local] Hint Resolve translate_comparisonu_freshreg_trans : htlspec. Lemma translate_comparison_imm_freshreg_trans : forall op args s r s' i n, @@ -377,7 +377,7 @@ Lemma translate_comparison_imm_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. +#[local] Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. Lemma translate_comparison_immu_freshreg_trans : forall op args s r s' i n, @@ -386,7 +386,7 @@ Lemma translate_comparison_immu_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. Qed. -Hint Resolve translate_comparison_immu_freshreg_trans : htlspec. +#[local] Hint Resolve translate_comparison_immu_freshreg_trans : htlspec. Lemma translate_condition_freshreg_trans : forall op args s r s' i, @@ -395,7 +395,7 @@ Lemma translate_condition_freshreg_trans : Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. Qed. -Hint Resolve translate_condition_freshreg_trans : htlspec. +#[local] Hint Resolve translate_condition_freshreg_trans : htlspec. Lemma translate_instr_freshreg_trans : forall op args s r s' i, @@ -405,7 +405,7 @@ Proof. destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. monadInv H1. eauto with htlspec. Qed. -Hint Resolve translate_instr_freshreg_trans : htlspec. +#[local] Hint Resolve translate_instr_freshreg_trans : htlspec. Lemma translate_arr_access_freshreg_trans : forall mem addr args st s r s' i, @@ -414,35 +414,35 @@ Lemma translate_arr_access_freshreg_trans : Proof. intros. unfold translate_arr_access in H. repeat (unfold_match H); inv H; eauto with htlspec. Qed. -Hint Resolve translate_arr_access_freshreg_trans : htlspec. +#[local] Hint Resolve translate_arr_access_freshreg_trans : htlspec. Lemma add_instr_freshreg_trans : forall n n' st s r s' i, add_instr n n' st s = OK r s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. intros. unfold add_instr in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_instr_freshreg_trans : htlspec. +#[local] Hint Resolve add_instr_freshreg_trans : htlspec. Lemma add_branch_instr_freshreg_trans : forall n n0 n1 e s r s' i, add_branch_instr e n n0 n1 s = OK r s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. intros. unfold add_branch_instr in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_branch_instr_freshreg_trans : htlspec. +#[local] Hint Resolve add_branch_instr_freshreg_trans : htlspec. Lemma add_node_skip_freshreg_trans : forall n1 n2 s r s' i, add_node_skip n1 n2 s = OK r s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. intros. unfold add_node_skip in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_node_skip_freshreg_trans : htlspec. +#[local] Hint Resolve add_node_skip_freshreg_trans : htlspec. Lemma add_instr_skip_freshreg_trans : forall n1 n2 s r s' i, add_instr_skip n1 n2 s = OK r s' i -> s.(st_freshreg) = s'.(st_freshreg). Proof. intros. unfold add_instr_skip in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_instr_skip_freshreg_trans : htlspec. +#[local] Hint Resolve add_instr_skip_freshreg_trans : htlspec. Lemma transf_instr_freshreg_trans : forall fin ret st instr s v s' i, @@ -460,7 +460,7 @@ Proof. congruence. (*- inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence.*) Qed. -Hint Resolve transf_instr_freshreg_trans : htlspec. +#[local] Hint Resolve transf_instr_freshreg_trans : htlspec. Lemma collect_trans_instr_freshreg_trans : forall fin ret st l s s' i, @@ -590,7 +590,7 @@ Proof. intros. specialize H1 with pc0 instr0. destruct H1. tauto. trivial. destruct H2. inv H2. contradiction. assumption. assumption. Qed. -Hint Resolve iter_expand_instr_spec : htlspec. +#[local] Hint Resolve iter_expand_instr_spec : htlspec. Lemma create_arr_inv : forall w x y z a b c d, create_arr w x y z = OK (a, b) c d -> @@ -649,5 +649,9 @@ Proof. replace (st_datapath s10) with (st_datapath s3) by congruence. replace (st_st s10) with (st_st s3) by congruence. eapply iter_expand_instr_spec; eauto with htlspec. + rewrite H5. rewrite H7. apply EQ2. apply PTree.elements_complete. + eauto with htlspec. + erewrite <- collect_declare_freshreg_trans; try eassumption. + lia. Qed. diff --git a/src/hls/HashTree.v b/src/hls/HashTree.v new file mode 100644 index 0000000..f3c57a8 --- /dev/null +++ b/src/hls/HashTree.v @@ -0,0 +1,438 @@ +(* + * 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.lib.Maps. + +Require Import vericert.common.Vericertlib. + +#[local] Open Scope positive. + +#[local] Hint Resolve in_eq : core. +#[local] Hint Resolve in_cons : core. + +Definition max_key {A} (t: PTree.t A) := + fold_right Pos.max 1%positive (map fst (PTree.elements t)). + +Lemma max_key_correct' : + forall l hi, In hi l -> hi <= fold_right Pos.max 1 l. +Proof. + induction l; crush. + inv H. lia. + destruct (Pos.max_dec a (fold_right Pos.max 1 l)); rewrite e. + - apply Pos.max_l_iff in e. + assert (forall a b c, a <= c -> c <= b -> a <= b) by lia. + eapply H; eauto. + - apply IHl; auto. +Qed. + +Lemma max_key_correct : + forall A h_tree hi (c: A), + h_tree ! hi = Some c -> + hi <= max_key h_tree. +Proof. + unfold max_key. intros. apply PTree.elements_correct in H. + apply max_key_correct'. + eapply in_map with (f := fst) in H. auto. +Qed. + +Lemma max_not_present : + forall A k (h: PTree.t A), k > max_key h -> h ! k = None. +Proof. + intros. destruct (h ! k) eqn:?; auto. + apply max_key_correct in Heqo. lia. +Qed. + +Lemma filter_none : + forall A f l (x: A), filter f l = nil -> In x l -> f x = false. +Proof. induction l; crush; inv H0; subst; destruct_match; crush. Qed. + +Lemma filter_set : + forall A l l' f (x: A), + (In x l -> In x l') -> + In x (filter f l) -> + In x (filter f l'). +Proof. + induction l; crush. + destruct_match; crush. inv H0; crush. + apply filter_In. simplify; crush. +Qed. + +Lemma filter_cons_true : + forall A f l (a: A) l', + filter f l = a :: l' -> f a = true. +Proof. + induction l; crush. destruct (f a) eqn:?. + inv H. auto. eapply IHl; eauto. +Qed. + +Lemma PTree_set_elements : + forall A t x x' (c: A), + In x (PTree.elements t) -> + x' <> (fst x) -> + In x (PTree.elements (PTree.set x' c t)). +Proof. + intros. destruct x. + eapply PTree.elements_correct. simplify. + rewrite PTree.gso; auto. apply PTree.elements_complete in H. auto. +Qed. + +Lemma filter_set2 : + forall A x y z (h: PTree.t A), + In z (PTree.elements (PTree.set x y h)) -> + In z (PTree.elements h) \/ fst z = x. +Proof. + intros. destruct z. + destruct (Pos.eq_dec p x); subst. + tauto. + left. apply PTree.elements_correct. apply PTree.elements_complete in H. + rewrite PTree.gso in H; auto. +Qed. + +Lemma in_filter : forall A f l (x: A), In x (filter f l) -> In x l. +Proof. induction l; crush. destruct_match; crush. inv H; crush. Qed. + +Lemma filter_norepet: + forall A f (l: list A), + list_norepet l -> + list_norepet (filter f l). +Proof. + induction l; crush. + inv H. destruct (f a). + constructor. unfold not in *; intros. apply H2. + eapply in_filter; eauto. + apply IHl; auto. + apply IHl; auto. +Qed. + +Lemma filter_norepet2: + forall A B g (l: list (A * B)), + list_norepet (map fst l) -> + list_norepet (map fst (filter g l)). +Proof. + induction l; crush. + inv H. destruct (g a) eqn:?. + simplify. constructor. unfold not in *. intros. + eapply H2. + apply list_in_map_inv in H. simplify; subst. + rewrite H. + apply filter_In in H1. simplify. + apply in_map. eauto. + eapply IHl. eauto. + eapply IHl. eauto. +Qed. + +Module Type Hashable. + + Parameter t: Type. + Parameter eq_dec: forall (t1 t2: t), {t1 = t2} + {t1 <> t2}. + +End Hashable. + +Module HashTree(H: Hashable). + + Import H. + + Definition hash := positive. + Definition hash_tree := PTree.t t. + + Definition find_tree (el: t) (h: hash_tree) : option hash := + match filter (fun x => if eq_dec el (snd x) then true else false) (PTree.elements h) with + | (p, _) :: nil => Some p + | _ => None + end. + + Definition hash_value (max: hash) (e: t) (h: hash_tree): hash * hash_tree := + match find_tree e h with + | Some p => (p, h) + | None => + let nkey := Pos.max max (max_key h) + 1 in + (nkey, PTree.set nkey e h) + end. + + Definition wf_hash_table h_tree := + forall x c, h_tree ! x = Some c -> find_tree c h_tree = Some x. + + Lemma find_tree_correct : + forall c h_tree p, + find_tree c h_tree = Some p -> + h_tree ! p = Some c. + Proof. + intros. + unfold find_tree in H. destruct_match; crush. + destruct_match; simplify. + destruct_match; crush. + assert (In (p, t0) (filter + (fun x : hash * t => + if eq_dec c (snd x) then true else false) (PTree.elements h_tree))). + { setoid_rewrite Heql. constructor; auto. } + apply filter_In in H. simplify. destruct_match; crush. subst. + apply PTree.elements_complete; auto. + Qed. + + Lemma find_tree_unique : + forall c h_tree p p', + find_tree c h_tree = Some p -> + h_tree ! p' = Some c -> + p = p'. + Proof. + intros. + unfold find_tree in H. + repeat (destruct_match; crush; []). + assert (In (p, t0) (filter + (fun x : hash * t => + if eq_dec c (snd x) then true else false) (PTree.elements h_tree))). + { setoid_rewrite Heql. constructor; auto. } + apply filter_In in H. simplify. + destruct (Pos.eq_dec p p'); auto. + exfalso. + destruct_match; subst; crush. + assert (In (p', t0) (PTree.elements h_tree) /\ (fun x : hash * t => + if eq_dec t0 (snd x) then true else false) (p', t0) = true). + { split. apply PTree.elements_correct. auto. setoid_rewrite Heqs. auto. } + apply filter_In in H. setoid_rewrite Heql in H. inv H. simplify. crush. crush. + Qed. + + Lemma hash_no_element' : + forall c h_tree, + find_tree c h_tree = None -> + wf_hash_table h_tree -> + ~ forall x, h_tree ! x = Some c. + Proof. + unfold not, wf_hash_table; intros. + specialize (H1 1). eapply H0 in H1. crush. + Qed. + + Lemma hash_no_element : + forall c h_tree, + find_tree c h_tree = None -> + wf_hash_table h_tree -> + ~ exists x, h_tree ! x = Some c. + Proof. + unfold not, wf_hash_table; intros. + simplify. apply H0 in H2. rewrite H in H2. crush. + Qed. + + Lemma wf_hash_table_set_gso' : + forall h x p0 c', + filter + (fun x : hash * t => + if eq_dec c' (snd x) then true else false) (PTree.elements h) = + (x, p0) :: nil -> + h ! x = Some p0 /\ p0 = c'. + Proof. + intros. + match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + assert (In x (filter f el)) by (rewrite H; crush) + end. + apply filter_In in H0. simplify. destruct_match; subst; crush. + apply PTree.elements_complete; auto. + destruct_match; crush. + Qed. + + Lemma wf_hash_table_set_gso : + forall x x' c' c h, + x <> x' -> + wf_hash_table h -> + find_tree c' h = Some x -> + find_tree c h = None -> + find_tree c' (PTree.set x' c h) = Some x. + Proof. + intros. pose proof H1 as X. unfold find_tree in H1. + destruct_match; crush. + destruct p. destruct l; crush. + apply wf_hash_table_set_gso' in Heql. simplify. + pose proof H2 as Z. apply hash_no_element in H2; auto. + destruct (eq_dec c c'); subst. + { exfalso. eapply H2. econstructor; eauto. } + unfold wf_hash_table in H0. + assert (In (x', c) (PTree.elements (PTree.set x' c h))). + { apply PTree.elements_correct. rewrite PTree.gss; auto. } + assert (In (x, c') (PTree.elements h)). + { apply PTree.elements_correct; auto. } + assert (In (x, c') (PTree.elements (PTree.set x' c h))). + { apply PTree.elements_correct. rewrite PTree.gso; auto. } + pose proof X as Y. + unfold find_tree in X. repeat (destruct_match; crush; []). + match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + assert (In x (filter f el)) by (rewrite H; crush) + end. + apply filter_In in H6. simplify. destruct_match; crush; subst. + unfold find_tree. repeat (destruct_match; crush). + { eapply filter_none in Heql0. + 2: { apply PTree.elements_correct. rewrite PTree.gso; eauto. } + destruct_match; crush. } + + { subst. + repeat match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + learn H; assert (In x (filter f el)) by (rewrite H; crush) + end. + eapply filter_set in H10. rewrite Heql0 in H10. inv H10. simplify. auto. + inv H11. auto. inv H11. intros. eapply PTree_set_elements; auto. } + + { exfalso. subst. + repeat match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + learn H; assert (In x (filter f el)) by (rewrite H; crush) + end. + + pose proof H8 as X2. destruct p1. + pose proof X2 as X4. + apply in_filter in X2. apply PTree.elements_complete in X2. + assert (In (p, t2) (filter + (fun x : positive * t => if eq_dec t0 (snd x) then true else false) + (PTree.elements (PTree.set x' c h)))) by (rewrite H6; eauto). + pose proof H11 as X3. + apply in_filter in H11. apply PTree.elements_complete in H11. + destruct (peq p0 p); subst. + { + assert (list_norepet (map fst (filter + (fun x : positive * t => if eq_dec t0 (snd x) then true else false) + (PTree.elements (PTree.set x' c h))))). + { eapply filter_norepet2. eapply PTree.elements_keys_norepet. } + rewrite Heql0 in H12. simplify. inv H12. eapply H15. apply in_eq. + } + { apply filter_In in X4. simplify. destruct_match; crush; subst. + apply filter_In in X3. simplify. destruct_match; crush; subst. + destruct (peq p x'); subst. + { rewrite PTree.gss in H11; crush. } + { destruct (peq p0 x'); subst. + { rewrite PTree.gss in X2; crush. } + { rewrite PTree.gso in X2 by auto. + rewrite PTree.gso in H11 by auto. + assert (p = p0) by (eapply find_tree_unique; eauto). + crush. } } } } + Qed. + + Lemma wf_hash_table_set : + forall h_tree c v (GT: v > max_key h_tree), + find_tree c h_tree = None -> + wf_hash_table h_tree -> + wf_hash_table (PTree.set v c h_tree). + Proof. + unfold wf_hash_table; simplify. + destruct (peq v x); subst. + pose proof (hash_no_element c h_tree H H0). + rewrite PTree.gss in H1. simplify. + unfold find_tree. + assert (In (x, c0) (PTree.elements (PTree.set x c0 h_tree)) + /\ (fun x : positive * t => if eq_dec c0 (snd x) then true else false) + (x, c0) = true). + { simplify. apply PTree.elements_correct. rewrite PTree.gss. auto. + destruct (eq_dec c0 c0); crush. } + destruct_match. + apply filter_In in H1. rewrite Heql in H1. crush. + apply filter_In in H1. repeat (destruct_match; crush; []). subst. + destruct l. simplify. rewrite Heql in H1. inv H1. inv H3. auto. + crush. + + exfalso. apply H2. destruct p. + pose proof Heql as X. apply filter_cons_true in X. destruct_match; crush; subst. + assert (In (p0, t0) (filter + (fun x : positive * t => if eq_dec t0 (snd x) then true else false) + (PTree.elements (PTree.set x t0 h_tree)))) by (rewrite Heql; eauto). + assert (In (p, t1) (filter + (fun x : positive * t => if eq_dec t0 (snd x) then true else false) + (PTree.elements (PTree.set x t0 h_tree)))) by (rewrite Heql; eauto). + apply filter_In in H4. simplify. destruct_match; crush; subst. + apply in_filter in H3. apply PTree.elements_complete in H5. apply PTree.elements_complete in H3. + assert (list_norepet (map fst (filter + (fun x : positive * t => if eq_dec t1 (snd x) then true else false) + (PTree.elements (PTree.set x t1 h_tree))))). + { eapply filter_norepet2. eapply PTree.elements_keys_norepet. } + rewrite Heql in H4. simplify. + destruct (peq p0 p); subst. + { inv H4. exfalso. eapply H8. eauto. } + destruct (peq x p); subst. + rewrite PTree.gso in H3; auto. econstructor; eauto. + rewrite PTree.gso in H5; auto. econstructor; eauto. + + rewrite PTree.gso in H1; auto. + destruct (eq_dec c c0); subst. + { apply H0 in H1. rewrite H in H1. discriminate. } + apply H0 in H1. + apply wf_hash_table_set_gso; eauto. + Qed. + + Lemma wf_hash_table_distr : + forall m p h_tree h h_tree', + hash_value m p h_tree = (h, h_tree') -> + wf_hash_table h_tree -> + wf_hash_table h_tree'. + Proof. + unfold hash_value; simplify. + destruct_match. + - inv H; auto. + - inv H. apply wf_hash_table_set; try lia; auto. + Qed. + + Lemma wf_hash_table_eq : + forall h_tree a b c, + wf_hash_table h_tree -> + h_tree ! a = Some c -> + h_tree ! b = Some c -> + a = b. + Proof. + unfold wf_hash_table; intros; apply H in H0; eapply find_tree_unique; eauto. + Qed. + + Lemma hash_constant : + forall p h h_tree hi c h_tree' m, + h_tree ! hi = Some c -> + hash_value m p h_tree = (h, h_tree') -> + h_tree' ! hi = Some c. + Proof. + intros. unfold hash_value in H0. destruct_match. + inv H0. eauto. + inv H0. + pose proof H. apply max_key_correct in H0. + rewrite PTree.gso; solve [eauto | lia]. + Qed. + + Lemma find_tree_Some : + forall el h v, + find_tree el h = Some v -> + h ! v = Some el. + Proof. + intros. unfold find_tree in *. + destruct_match; crush. destruct p. + destruct_match; crush. + match goal with + | H: filter ?f ?el = ?x::?xs |- _ => + assert (In x (filter f el)) by (rewrite H; crush) + end. + apply PTree.elements_complete. + apply filter_In in H. inv H. + destruct_match; crush. + Qed. + + Lemma hash_present_eq : + forall m e1 e2 p1 h h', + hash_value m e2 h = (p1, h') -> + h ! p1 = Some e1 -> e1 = e2. + Proof. + intros. unfold hash_value in *. destruct_match. + - inv H. apply find_tree_Some in Heqo. + rewrite Heqo in H0. inv H0. auto. + - inv H. assert (h ! (Pos.max m (max_key h) + 1) = None) + by (apply max_not_present; lia). crush. + Qed. + +End HashTree. diff --git a/src/hls/IfConversion.v b/src/hls/IfConversion.v index e893578..b397d43 100644 --- a/src/hls/IfConversion.v +++ b/src/hls/IfConversion.v @@ -25,6 +25,7 @@ Require Import compcert.lib.Maps. Require Import vericert.common.Vericertlib. Require Import vericert.hls.RTLBlockInstr. Require Import vericert.hls.RTLBlock. +Require Import vericert.hls.Predicate. (*| ============= @@ -57,10 +58,10 @@ Definition if_convert_block (c: code) (p: predicate) (bb: bblock) : bblock := | 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)) + let bb1' := List.map (map_if_convert (Plit (true, p))) bb1.(bb_body) in + let bb2' := List.map (map_if_convert (Plit (false, p))) bb2.(bb_body) in + mk_bblock (List.concat (bb.(bb_body) :: ((RBsetpred None cond args p) :: bb1') :: bb2' :: nil)) + (RBpred_cf (Plit (true, p)) bb1.(bb_exit) bb2.(bb_exit)) | _, _ => bb end | _ => bb @@ -104,16 +105,14 @@ Definition find_blocks_with_cond (c: code) : list (node * bblock) := ) (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). + let nbb := if_convert_block (snd p) (Pos.of_nat (fst p)) (snd nb) in + (S (fst p), PTree.set (fst nb) nbb (snd p)). 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_funct_units) f.(fn_entrypoint). + 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. diff --git a/src/hls/Memorygen.v b/src/hls/Memorygen.v new file mode 100644 index 0000000..4ff4a19 --- /dev/null +++ b/src/hls/Memorygen.v @@ -0,0 +1,3204 @@ +(* + * 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.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.common.Smallstep. +Require compcert.verilog.Op. + +Require Import vericert.common.Vericertlib. +Require Import vericert.hls.ValueInt. +Require Import vericert.hls.Verilog. +Require Import vericert.hls.HTL. +Require Import vericert.hls.AssocMap. +Require Import vericert.hls.Array. +Require Import vericert.hls.FunctionalUnits. + +Local Open Scope positive. +Local Open Scope assocmap. + +#[local] Hint Resolve max_reg_stmnt_le_stmnt_tree : mgen. +#[local] Hint Resolve max_reg_stmnt_lt_stmnt_tree : mgen. +#[local] Hint Resolve max_stmnt_lt_module : mgen. + +Lemma int_eq_not_false : forall x, Int.eq x (Int.not x) = false. +Proof. + intros. unfold Int.eq. + rewrite Int.unsigned_not. + replace Int.max_unsigned with 4294967295%Z by crush. + assert (X: forall x, (x <> 4294967295 - x)%Z) by lia. + specialize (X (Int.unsigned x)). apply zeq_false; auto. +Qed. + +Definition transf_maps state ram in_ (dc: PTree.t stmnt * PTree.t stmnt) := + match dc, in_ with + | (d, c), (i, n) => + match PTree.get i d, PTree.get i c with + | Some (Vnonblock (Vvari r e1) e2), Some c_s => + if r =? (ram_mem ram) then + let nd := Vseq (Vnonblock (Vvar (ram_u_en ram)) (Vunop Vnot (Vvar (ram_u_en ram)))) + (Vseq (Vnonblock (Vvar (ram_wr_en ram)) (Vlit (ZToValue 1))) + (Vseq (Vnonblock (Vvar (ram_d_in ram)) e2) + (Vnonblock (Vvar (ram_addr ram)) e1))) + in + (PTree.set i nd d, c) + else dc + | Some (Vnonblock (Vvar e1) (Vvari r e2)), Some (Vnonblock (Vvar st') e3) => + if (r =? (ram_mem ram)) && (st' =? state) && (Z.pos n <=? Int.max_unsigned)%Z + && (e1 <? state) && (max_reg_expr e2 <? state) && (max_reg_expr e3 <? state) + then + let nd := + Vseq (Vnonblock (Vvar (ram_u_en ram)) (Vunop Vnot (Vvar (ram_u_en ram)))) + (Vseq (Vnonblock (Vvar (ram_wr_en ram)) (Vlit (ZToValue 0))) + (Vnonblock (Vvar (ram_addr ram)) e2)) + in + let aout := Vnonblock (Vvar e1) (Vvar (ram_d_out ram)) in + let redirect := Vnonblock (Vvar state) (Vlit (posToValue n)) in + (PTree.set i nd (PTree.set n aout d), + PTree.set i redirect (PTree.set n (Vnonblock (Vvar st') e3) c)) + else dc + | _, _ => dc + end + end. + +Lemma transf_maps_wf : + forall state ram d c d' c' i, + map_well_formed c /\ map_well_formed d -> + transf_maps state ram i (d, c) = (d', c') -> + map_well_formed c' /\ map_well_formed d'. +Proof. + unfold transf_maps; intros; repeat destruct_match; + match goal with + | H: (_, _) = (_, _) |- _ => inv H + end; auto. + unfold map_well_formed. + simplify; intros. + destruct (Pos.eq_dec p0 p1); subst; auto. + destruct (Pos.eq_dec p p1); subst. unfold map_well_formed in *. + apply AssocMap.elements_correct in Heqo. + eapply in_map with (f := fst) in Heqo. simplify. + apply H1 in Heqo. auto. + apply AssocMapExt.elements_iff in H3. inv H3. + repeat rewrite AssocMap.gso in H8 by lia. + apply AssocMap.elements_correct in H8. + eapply in_map with (f := fst) in H8. simplify. + unfold map_well_formed in *. apply H0 in H8. auto. + apply AssocMapExt.elements_iff in H3. inv H3. + destruct (Pos.eq_dec p0 p1); subst; auto. + destruct (Pos.eq_dec p p1); subst. unfold map_well_formed in *. + apply AssocMap.elements_correct in Heqo. + eapply in_map with (f := fst) in Heqo. simplify. + apply H1 in Heqo. auto. + repeat rewrite AssocMap.gso in H8 by lia. + apply AssocMap.elements_correct in H8. + eapply in_map with (f := fst) in H8. simplify. + unfold map_well_formed in *. apply H1 in H8. auto. + unfold map_well_formed in *; simplify; intros. + destruct (Pos.eq_dec p0 p1); subst; auto. + destruct (Pos.eq_dec p p1); subst. unfold map_well_formed in *. + apply AssocMap.elements_correct in Heqo. + eapply in_map with (f := fst) in Heqo. simplify. + apply H1 in Heqo. auto. + apply AssocMapExt.elements_iff in H. inv H. + repeat rewrite AssocMap.gso in H2 by lia. + apply AssocMap.elements_correct in H2. + eapply in_map with (f := fst) in H2. simplify. + unfold map_well_formed in *. apply H1 in H2. auto. +Qed. + +Definition max_pc {A: Type} (m: PTree.t A) := + fold_right Pos.max 1%positive (map fst (PTree.elements m)). + +Fixpoint zip_range {A: Type} n (l: list A) {struct l} := + match l with + | nil => nil + | a :: b => (a, n) :: zip_range (n+1) b + end. + +Lemma zip_range_fst_idem : forall A (l: list A) a, map fst (zip_range a l) = l. +Proof. induction l; crush. Qed. + +Lemma zip_range_not_in_snd : + forall A (l: list A) a n, a < n -> ~ In a (map snd (zip_range n l)). +Proof. + unfold not; induction l; crush. + inv H0; try lia. eapply IHl. + assert (X: a0 < n + 1) by lia. apply X; auto. auto. +Qed. + +Lemma zip_range_snd_no_repet : + forall A (l: list A) a, list_norepet (map snd (zip_range a l)). +Proof. + induction l; crush; constructor; auto; []. + apply zip_range_not_in_snd; lia. +Qed. + +Lemma zip_range_in : + forall A (l: list A) a n i, In (a, i) (zip_range n l) -> In a l. +Proof. + induction l; crush. inv H. inv H0. auto. right. eapply IHl; eauto. +Qed. + +Lemma zip_range_not_in : + forall A (l: list A) a i n, ~ In a l -> ~ In (a, i) (zip_range n l). +Proof. + unfold not; induction l; crush. inv H0. inv H1. apply H. left. auto. + apply H. right. eapply zip_range_in; eauto. +Qed. + +Lemma zip_range_no_repet : + forall A (l: list A) a, list_norepet l -> list_norepet (zip_range a l). +Proof. + induction l; simplify; constructor; + match goal with H: list_norepet _ |- _ => inv H end; + [apply zip_range_not_in|]; auto. +Qed. + +Definition transf_code state ram d c := + fold_right (transf_maps state ram) (d, c) + (zip_range (Pos.max (max_pc c) (max_pc d) + 1) + (map fst (PTree.elements d))). + +Lemma transf_code_wf' : + forall l c d state ram c' d', + map_well_formed c /\ map_well_formed d -> + fold_right (transf_maps state ram) (d, c) l = (d', c') -> + map_well_formed c' /\ map_well_formed d'. +Proof. + induction l; intros; simpl in *. inv H0; auto. + remember (fold_right (transf_maps state ram) (d, c) l). destruct p. + apply transf_maps_wf in H0. auto. eapply IHl; eauto. +Qed. + +Lemma transf_code_wf : + forall c d state ram c' d', + map_well_formed c /\ map_well_formed d -> + transf_code state ram d c = (d', c') -> + map_well_formed c' /\ map_well_formed d'. +Proof. eauto using transf_code_wf'. Qed. + +Lemma ram_wf : + forall x, + x + 1 < x + 2 /\ x + 2 < x + 3 /\ x + 3 < x + 4 /\ x + 4 < x + 5 /\ x + 5 < x + 6. +Proof. lia. Qed. + +Lemma module_ram_wf' : + forall m addr, + addr = max_reg_module m + 1 -> + mod_clk m < addr. +Proof. unfold max_reg_module; lia. Qed. + +Definition transf_module (m: module): module. + refine ( + let max_reg := max_reg_module m in + let addr := max_reg+1 in + let en := max_reg+2 in + let d_in := max_reg+3 in + let d_out := max_reg+4 in + let wr_en := max_reg+5 in + let u_en := max_reg+6 in + let new_size := (mod_stk_len m) in + let ram := mk_ram new_size (mod_stk m) en u_en addr wr_en d_in d_out ltac:(eauto using ram_wf) in + let tc := transf_code (mod_st m) ram (mod_datapath m) (mod_controllogic m) in + match mod_ram m with + | None => + mkmodule m.(mod_params) + (fst tc) + (snd tc) + (mod_entrypoint m) + (mod_st m) + (mod_stk m) + (mod_stk_len m) + (mod_finish m) + (mod_return m) + (mod_start m) + (mod_reset m) + (mod_clk m) + (AssocMap.set u_en (None, VScalar 1) + (AssocMap.set en (None, VScalar 1) + (AssocMap.set wr_en (None, VScalar 1) + (AssocMap.set d_out (None, VScalar 32) + (AssocMap.set d_in (None, VScalar 32) + (AssocMap.set addr (None, VScalar 32) m.(mod_scldecls))))))) + (AssocMap.set m.(mod_stk) + (None, VArray 32 (2 ^ Nat.log2_up new_size))%nat m.(mod_arrdecls)) + (Some ram) + _ (mod_ordering_wf m) _ (mod_params_wf m) + | _ => m + end). + eapply transf_code_wf. apply (mod_wf m). destruct tc eqn:?; simpl. + rewrite <- Heqp. intuition. + inversion 1; subst. auto using module_ram_wf'. +Defined. + +Definition transf_fundef := transf_fundef transf_module. + +Definition transf_program (p : program) := + transform_program transf_fundef p. + +Inductive match_assocmaps : positive -> assocmap -> assocmap -> Prop := + match_assocmap: forall p rs rs', + (forall r, r < p -> rs!r = rs'!r) -> + match_assocmaps p rs rs'. + +Inductive match_arrs : assocmap_arr -> assocmap_arr -> Prop := +| match_assocmap_arr_intro: forall ar ar', + (forall s arr, + ar ! s = Some arr -> + exists arr', + ar' ! s = Some arr' + /\ (forall addr, + array_get_error addr arr = array_get_error addr arr') + /\ arr_length arr = arr_length arr')%nat -> + (forall s, ar ! s = None -> ar' ! s = None) -> + match_arrs ar ar'. + +Inductive match_arrs_size : assocmap_arr -> assocmap_arr -> Prop := + match_arrs_size_intro : + forall nasa basa, + (forall s arr, + nasa ! s = Some arr -> + exists arr', + basa ! s = Some arr' /\ arr_length arr = arr_length arr') -> + (forall s arr, + basa ! s = Some arr -> + exists arr', + nasa ! s = Some arr' /\ arr_length arr = arr_length arr') -> + (forall s, basa ! s = None <-> nasa ! s = None) -> + match_arrs_size nasa basa. + +Definition match_empty_size (m : module) (ar : assocmap_arr) : Prop := + match_arrs_size (empty_stack m) ar. +#[local] Hint Unfold match_empty_size : mgen. + +Definition disable_ram (ram: option ram) (asr : assocmap_reg) : Prop := + match ram with + | Some r => Int.eq (asr # ((ram_en r), 32)) (asr # ((ram_u_en r), 32)) = true + | None => True + end. + +Inductive match_stackframes : stackframe -> stackframe -> Prop := + match_stackframe_intro : + forall r m pc asr asa asr' asa' + (DISABLE_RAM: disable_ram (mod_ram (transf_module m)) asr') + (MATCH_ASSOC: match_assocmaps (max_reg_module m + 1) asr asr') + (MATCH_ARRS: match_arrs asa asa') + (MATCH_EMPT1: match_empty_size m asa) + (MATCH_EMPT2: match_empty_size m asa') + (MATCH_RES: r < mod_st m), + match_stackframes (Stackframe r m pc asr asa) + (Stackframe r (transf_module m) pc asr' asa'). + +Inductive match_states : state -> state -> Prop := +| match_state : + forall res res' m st asr asr' asa asa' + (ASSOC: match_assocmaps (max_reg_module m + 1) asr asr') + (ARRS: match_arrs asa asa') + (STACKS: list_forall2 match_stackframes res res') + (ARRS_SIZE: match_empty_size m asa) + (ARRS_SIZE2: match_empty_size m asa') + (DISABLE_RAM: disable_ram (mod_ram (transf_module m)) asr'), + match_states (State res m st asr asa) + (State res' (transf_module m) st asr' asa') +| match_returnstate : + forall res res' i + (STACKS: list_forall2 match_stackframes res res'), + match_states (Returnstate res i) (Returnstate res' i) +| match_initial_call : + forall m, + match_states (Callstate nil m nil) + (Callstate nil (transf_module m) nil). +#[local] Hint Constructors match_states : htlproof. + +Definition empty_stack_ram r := + AssocMap.set (ram_mem r) (Array.arr_repeat None (ram_size r)) (AssocMap.empty arr). + +Definition empty_stack' len st := + AssocMap.set st (Array.arr_repeat None len) (AssocMap.empty arr). + +Definition match_empty_size' l s (ar : assocmap_arr) : Prop := + match_arrs_size (empty_stack' l s) ar. +#[local] Hint Unfold match_empty_size : mgen. + +Definition merge_reg_assocs r := + Verilog.mkassociations (Verilog.merge_regs (assoc_nonblocking r) (assoc_blocking r)) empty_assocmap. + +Definition merge_arr_assocs st len r := + Verilog.mkassociations (Verilog.merge_arrs (assoc_nonblocking r) (assoc_blocking r)) (empty_stack' len st). + +Inductive match_reg_assocs : positive -> reg_associations -> reg_associations -> Prop := + match_reg_association: + forall p rab rab' ran ran', + match_assocmaps p rab rab' -> + match_assocmaps p ran ran' -> + match_reg_assocs p (mkassociations rab ran) (mkassociations rab' ran'). + +Inductive match_arr_assocs : arr_associations -> arr_associations -> Prop := + match_arr_association: + forall rab rab' ran ran', + match_arrs rab rab' -> + match_arrs ran ran' -> + match_arr_assocs (mkassociations rab ran) (mkassociations rab' ran'). + +Ltac mgen_crush := crush; eauto with mgen. + +Lemma match_assocmaps_equiv : forall p a, match_assocmaps p a a. +Proof. constructor; auto. Qed. +#[local] Hint Resolve match_assocmaps_equiv : mgen. + +Lemma match_arrs_equiv : forall a, match_arrs a a. +Proof. econstructor; mgen_crush. Qed. +#[local] Hint Resolve match_arrs_equiv : mgen. + +Lemma match_reg_assocs_equiv : forall p a, match_reg_assocs p a a. +Proof. destruct a; constructor; mgen_crush. Qed. +#[local] Hint Resolve match_reg_assocs_equiv : mgen. + +Lemma match_arr_assocs_equiv : forall a, match_arr_assocs a a. +Proof. destruct a; constructor; mgen_crush. Qed. +#[local] Hint Resolve match_arr_assocs_equiv : mgen. + +Lemma match_arrs_size_equiv : forall a, match_arrs_size a a. +Proof. intros; repeat econstructor; eauto. Qed. +#[local] Hint Resolve match_arrs_size_equiv : mgen. + +Lemma match_stacks_equiv : + forall m s l, + mod_stk m = s -> + mod_stk_len m = l -> + empty_stack' l s = empty_stack m. +Proof. unfold empty_stack', empty_stack; mgen_crush. Qed. +Hint Rewrite match_stacks_equiv : mgen. + +Lemma match_assocmaps_max1 : + forall p p' a b, + match_assocmaps (Pos.max p' p) a b -> + match_assocmaps p a b. +Proof. + intros. inv H. constructor. intros. + apply H0. lia. +Qed. +#[local] Hint Resolve match_assocmaps_max1 : mgen. + +Lemma match_assocmaps_max2 : + forall p p' a b, + match_assocmaps (Pos.max p p') a b -> + match_assocmaps p a b. +Proof. + intros. inv H. constructor. intros. + apply H0. lia. +Qed. +#[local] Hint Resolve match_assocmaps_max2 : mgen. + +Lemma match_assocmaps_ge : + forall p p' a b, + match_assocmaps p' a b -> + p <= p' -> + match_assocmaps p a b. +Proof. + intros. inv H. constructor. intros. + apply H1. lia. +Qed. +#[local] Hint Resolve match_assocmaps_ge : mgen. + +Lemma match_reg_assocs_max1 : + forall p p' a b, + match_reg_assocs (Pos.max p' p) a b -> + match_reg_assocs p a b. +Proof. intros; inv H; econstructor; mgen_crush. Qed. +#[local] Hint Resolve match_reg_assocs_max1 : mgen. + +Lemma match_reg_assocs_max2 : + forall p p' a b, + match_reg_assocs (Pos.max p p') a b -> + match_reg_assocs p a b. +Proof. intros; inv H; econstructor; mgen_crush. Qed. +#[local] Hint Resolve match_reg_assocs_max2 : mgen. + +Lemma match_reg_assocs_ge : + forall p p' a b, + match_reg_assocs p' a b -> + p <= p' -> + match_reg_assocs p a b. +Proof. intros; inv H; econstructor; mgen_crush. Qed. +#[local] Hint Resolve match_reg_assocs_ge : mgen. + +Definition forall_ram (P: reg -> Prop) ram := + P (ram_en ram) + /\ P (ram_u_en ram) + /\ P (ram_addr ram) + /\ P (ram_wr_en ram) + /\ P (ram_d_in ram) + /\ P (ram_d_out ram). + +Lemma forall_ram_lt : + forall m r, + (mod_ram m) = Some r -> + forall_ram (fun x => x < max_reg_module m + 1) r. +Proof. + assert (X: forall a b c, a < b + 1 -> a < Pos.max c b + 1) by lia. + unfold forall_ram; simplify; unfold HTL.max_reg_module; repeat apply X; + unfold HTL.max_reg_ram; rewrite H; try lia. +Qed. +#[local] Hint Resolve forall_ram_lt : mgen. + +Definition exec_all d_s c_s rs1 ar1 rs3 ar3 := + exists f rs2 ar2, + stmnt_runp f rs1 ar1 c_s rs2 ar2 + /\ stmnt_runp f rs2 ar2 d_s rs3 ar3. + +Definition exec_all_ram r d_s c_s rs1 ar1 rs4 ar4 := + exists f rs2 ar2 rs3 ar3, + stmnt_runp f rs1 ar1 c_s rs2 ar2 + /\ stmnt_runp f rs2 ar2 d_s rs3 ar3 + /\ exec_ram (merge_reg_assocs rs3) (merge_arr_assocs (ram_mem r) (ram_size r) ar3) (Some r) rs4 ar4. + +Lemma merge_reg_idempotent : + forall rs, merge_reg_assocs (merge_reg_assocs rs) = merge_reg_assocs rs. +Proof. auto. Qed. +Hint Rewrite merge_reg_idempotent : mgen. + +Lemma merge_arr_idempotent : + forall ar st len v v', + (assoc_nonblocking ar)!st = Some v -> + (assoc_blocking ar)!st = Some v' -> + arr_length v' = len -> + arr_length v = len -> + (assoc_blocking (merge_arr_assocs st len (merge_arr_assocs st len ar)))!st + = (assoc_blocking (merge_arr_assocs st len ar))!st + /\ (assoc_nonblocking (merge_arr_assocs st len (merge_arr_assocs st len ar)))!st + = (assoc_nonblocking (merge_arr_assocs st len ar))!st. +Proof. + split; simplify; eauto. + unfold merge_arrs. + rewrite AssocMap.gcombine by reflexivity. + unfold empty_stack'. + rewrite AssocMap.gss. + setoid_rewrite merge_arr_empty2; auto. + rewrite AssocMap.gcombine by reflexivity. + unfold merge_arr, arr. + rewrite H. rewrite H0. auto. + unfold combine. + simplify. + rewrite list_combine_length. + rewrite (arr_wf v). rewrite (arr_wf v'). + lia. +Qed. + +Lemma empty_arr : + forall m s, + (exists l, (empty_stack m) ! s = Some (arr_repeat None l)) + \/ (empty_stack m) ! s = None. +Proof. + unfold empty_stack. simplify. + destruct (Pos.eq_dec s (mod_stk m)); subst. + left. eexists. apply AssocMap.gss. + right. rewrite AssocMap.gso; auto. apply AssocMap.gempty. +Qed. + +Lemma merge_arr_empty': + forall m ar s v, + match_empty_size m ar -> + (merge_arrs (empty_stack m) ar) ! s = v -> + ar ! s = v. +Proof. + inversion 1; subst. + pose proof (empty_arr m s). + simplify. + destruct (merge_arrs (empty_stack m) ar) ! s eqn:?; subst. + - inv H3. inv H4. + learn H3 as H5. apply H0 in H5. inv H5. simplify. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. + rewrite H3 in Heqo. erewrite merge_arr_empty2 in Heqo. auto. eauto. + rewrite list_repeat_len in H6. auto. + learn H4 as H6. apply H2 in H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. + rewrite H4 in Heqo. unfold Verilog.arr in *. rewrite H6 in Heqo. + discriminate. + - inv H3. inv H4. learn H3 as H4. apply H0 in H4. inv H4. simplify. + rewrite list_repeat_len in H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. rewrite H3 in Heqo. + unfold Verilog.arr in *. rewrite H4 in Heqo. + discriminate. + apply H2 in H4; auto. +Qed. + +Lemma merge_arr_empty : + forall m ar ar', + match_empty_size m ar -> + match_arrs ar ar' -> + match_arrs (merge_arrs (empty_stack m) ar) ar'. +Proof. + inversion 1; subst; inversion 1; subst; + econstructor; intros; apply merge_arr_empty' in H6; auto. +Qed. +#[local] Hint Resolve merge_arr_empty : mgen. + +Lemma merge_arr_empty'': + forall m ar s v, + match_empty_size m ar -> + ar ! s = v -> + (merge_arrs (empty_stack m) ar) ! s = v. +Proof. + inversion 1; subst. + pose proof (empty_arr m s). + simplify. + destruct (merge_arrs (empty_stack m) ar) ! s eqn:?; subst. + - inv H3. inv H4. + learn H3 as H5. apply H0 in H5. inv H5. simplify. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. + rewrite H3 in Heqo. erewrite merge_arr_empty2 in Heqo. auto. eauto. + rewrite list_repeat_len in H6. auto. + learn H4 as H6. apply H2 in H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. + rewrite H4 in Heqo. unfold Verilog.arr in *. rewrite H6 in Heqo. + discriminate. + - inv H3. inv H4. learn H3 as H4. apply H0 in H4. inv H4. simplify. + rewrite list_repeat_len in H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in Heqo; auto. rewrite H3 in Heqo. + unfold Verilog.arr in *. rewrite H4 in Heqo. + discriminate. + apply H2 in H4; auto. +Qed. + +Lemma merge_arr_empty_match : + forall m ar, + match_empty_size m ar -> + match_empty_size m (merge_arrs (empty_stack m) ar). +Proof. + inversion 1; subst. + constructor; simplify. + learn H3 as H4. apply H0 in H4. inv H4. simplify. + eexists; split; eauto. apply merge_arr_empty''; eauto. + apply merge_arr_empty' in H3; auto. + split; simplify. + unfold merge_arrs in H3. rewrite AssocMap.gcombine in H3; auto. + unfold merge_arr in *. + destruct (empty_stack m) ! s eqn:?; + destruct ar ! s; try discriminate; eauto. + apply merge_arr_empty''; auto. apply H2 in H3; auto. +Qed. +#[local] Hint Resolve merge_arr_empty_match : mgen. + +Definition ram_present {A: Type} ar r v v' := + (assoc_nonblocking ar)!(ram_mem r) = Some v + /\ @arr_length A v = ram_size r + /\ (assoc_blocking ar)!(ram_mem r) = Some v' + /\ arr_length v' = ram_size r. + +Lemma find_assoc_get : + forall rs r trs, + rs ! r = trs ! r -> + rs # r = trs # r. +Proof. + intros; unfold find_assocmap, AssocMapExt.get_default; rewrite H; auto. +Qed. +#[local] Hint Resolve find_assoc_get : mgen. + +Lemma find_assoc_get2 : + forall rs p r v trs, + (forall r, r < p -> rs ! r = trs ! r) -> + r < p -> + rs # r = v -> + trs # r = v. +Proof. + intros; unfold find_assocmap, AssocMapExt.get_default; rewrite <- H; auto. +Qed. +#[local] Hint Resolve find_assoc_get2 : mgen. + +Lemma get_assoc_gt : + forall A (rs : AssocMap.t A) p r v trs, + (forall r, r < p -> rs ! r = trs ! r) -> + r < p -> + rs ! r = v -> + trs ! r = v. +Proof. intros. rewrite <- H; auto. Qed. +#[local] Hint Resolve get_assoc_gt : mgen. + +Lemma expr_runp_matches : + forall f rs ar e v, + expr_runp f rs ar e v -> + forall trs tar, + match_assocmaps (max_reg_expr e + 1) rs trs -> + match_arrs ar tar -> + expr_runp f trs tar e v. +Proof. + induction 1. + - intros. econstructor. + - intros. econstructor. inv H0. symmetry. + apply find_assoc_get. + apply H2. crush. + - intros. econstructor. apply IHexpr_runp; eauto. + inv H1. constructor. simplify. + assert (forall a b c, a < b + 1 -> a < Pos.max c b + 1) by lia. + eapply H4 in H1. eapply H3 in H1. auto. + inv H2. + unfold arr_assocmap_lookup in *. + destruct (stack ! r) eqn:?; [|discriminate]. + inv H1. + inv H0. + eapply H3 in Heqo. inv Heqo. inv H0. + unfold arr in *. rewrite H1. inv H5. + rewrite H0. auto. + - intros. econstructor; eauto. eapply IHexpr_runp1; eauto. + econstructor. inv H2. intros. + assert (forall a b c, a < b + 1 -> a < Pos.max b c + 1) by lia. + simplify. + eapply H5 in H2. apply H4 in H2. auto. + apply IHexpr_runp2; eauto. + econstructor. inv H2. intros. + assert (forall a b c, a < b + 1 -> a < Pos.max c b + 1) by lia. + simplify. eapply H5 in H2. apply H4 in H2. auto. + - intros. econstructor; eauto. + - intros. econstructor; eauto. apply IHexpr_runp1; eauto. + constructor. inv H2. intros. simplify. + assert (forall a b c, a < b + 1 -> a < Pos.max b c + 1) by lia. + eapply H5 in H2. apply H4 in H2. auto. + apply IHexpr_runp2; eauto. simplify. + assert (forall a b c d, a < b + 1 -> a < Pos.max c (Pos.max b d) + 1) by lia. + constructor. intros. eapply H4 in H5. inv H2. apply H6 in H5. auto. + - intros. eapply erun_Vternary_false. apply IHexpr_runp1; eauto. constructor. inv H2. + intros. simplify. assert (forall a b c, a < b + 1 -> a < Pos.max b c + 1) by lia. + eapply H5 in H2. apply H4 in H2. auto. + apply IHexpr_runp2; eauto. econstructor. inv H2. simplify. + assert (forall a b c d, a < b + 1 -> a < Pos.max c (Pos.max d b) + 1) by lia. + eapply H5 in H2. apply H4 in H2. auto. auto. +Qed. +#[local] Hint Resolve expr_runp_matches : mgen. + +Lemma expr_runp_matches2 : + forall f rs ar e v p, + expr_runp f rs ar e v -> + max_reg_expr e < p -> + forall trs tar, + match_assocmaps p rs trs -> + match_arrs ar tar -> + expr_runp f trs tar e v. +Proof. + intros. eapply expr_runp_matches; eauto. + assert (max_reg_expr e + 1 <= p) by lia. + mgen_crush. +Qed. +#[local] Hint Resolve expr_runp_matches2 : mgen. + +Lemma match_assocmaps_gss : + forall p rab rab' r rhsval, + match_assocmaps p rab rab' -> + match_assocmaps p rab # r <- rhsval rab' # r <- rhsval. +Proof. + intros. inv H. econstructor. + intros. + unfold find_assocmap. unfold AssocMapExt.get_default. + destruct (Pos.eq_dec r r0); subst. + repeat rewrite PTree.gss; auto. + repeat rewrite PTree.gso; auto. +Qed. +#[local] Hint Resolve match_assocmaps_gss : mgen. + +Lemma match_assocmaps_gt : + forall p s ra ra' v, + p <= s -> + match_assocmaps p ra ra' -> + match_assocmaps p ra (ra' # s <- v). +Proof. + intros. inv H0. constructor. + intros. rewrite AssocMap.gso; try lia. apply H1; auto. +Qed. +#[local] Hint Resolve match_assocmaps_gt : mgen. + +Lemma match_reg_assocs_block : + forall p rab rab' r rhsval, + match_reg_assocs p rab rab' -> + match_reg_assocs p (block_reg r rab rhsval) (block_reg r rab' rhsval). +Proof. inversion 1; econstructor; eauto with mgen. Qed. +#[local] Hint Resolve match_reg_assocs_block : mgen. + +Lemma match_reg_assocs_nonblock : + forall p rab rab' r rhsval, + match_reg_assocs p rab rab' -> + match_reg_assocs p (nonblock_reg r rab rhsval) (nonblock_reg r rab' rhsval). +Proof. inversion 1; econstructor; eauto with mgen. Qed. +#[local] Hint Resolve match_reg_assocs_nonblock : mgen. + +Lemma some_inj : + forall A (x: A) y, + Some x = Some y -> + x = y. +Proof. inversion 1; auto. Qed. + +Lemma arrs_present : + forall r i v ar arr, + (arr_assocmap_set r i v ar) ! r = Some arr -> + exists b, ar ! r = Some b. +Proof. + intros. unfold arr_assocmap_set in *. + destruct ar!r eqn:?. + rewrite AssocMap.gss in H. + inv H. eexists. auto. rewrite Heqo in H. discriminate. +Qed. + +Ltac inv_exists := + match goal with + | H: exists _, _ |- _ => inv H + end. + +Lemma array_get_error_bound_gt : + forall A i (a : Array A), + (i >= arr_length a)%nat -> + array_get_error i a = None. +Proof. + intros. unfold array_get_error. + apply nth_error_None. destruct a. simplify. + lia. +Qed. +#[local] Hint Resolve array_get_error_bound_gt : mgen. + +Lemma array_get_error_each : + forall A addr i (v : A) a x, + arr_length a = arr_length x -> + array_get_error addr a = array_get_error addr x -> + array_get_error addr (array_set i v a) = array_get_error addr (array_set i v x). +Proof. + intros. + destruct (Nat.eq_dec addr i); subst. + destruct (lt_dec i (arr_length a)). + repeat rewrite array_get_error_set_bound; auto. + rewrite <- H. auto. + apply Nat.nlt_ge in n. + repeat rewrite array_get_error_bound_gt; auto. + rewrite <- array_set_len. rewrite <- H. lia. + repeat rewrite array_gso; auto. +Qed. +#[local] Hint Resolve array_get_error_each : mgen. + +Lemma match_arrs_gss : + forall ar ar' r v i, + match_arrs ar ar' -> + match_arrs (arr_assocmap_set r i v ar) (arr_assocmap_set r i v ar'). +Proof. + Ltac mag_tac := + match goal with + | H: ?ar ! _ = Some _, H2: forall s arr, ?ar ! s = Some arr -> _ |- _ => + let H3 := fresh "H" in + learn H as H3; apply H2 in H3; inv_exists; simplify + | H: ?ar ! _ = None, H2: forall s, ?ar ! s = None -> _ |- _ => + let H3 := fresh "H" in + learn H as H3; apply H2 in H3; inv_exists; simplify + | H: ?ar ! _ = _ |- context[match ?ar ! _ with _ => _ end] => + unfold Verilog.arr in *; rewrite H + | H: ?ar ! _ = _, H2: context[match ?ar ! _ with _ => _ end] |- _ => + unfold Verilog.arr in *; rewrite H in H2 + | H: context[(_ # ?s <- _) ! ?s] |- _ => rewrite AssocMap.gss in H + | H: context[(_ # ?r <- _) ! ?s], H2: ?r <> ?s |- _ => rewrite AssocMap.gso in H; auto + | |- context[(_ # ?s <- _) ! ?s] => rewrite AssocMap.gss + | H: ?r <> ?s |- context[(_ # ?r <- _) ! ?s] => rewrite AssocMap.gso; auto + end. + intros. + inv H. econstructor; simplify. + destruct (Pos.eq_dec r s); subst. + - unfold arr_assocmap_set, Verilog.arr in *. + destruct ar!s eqn:?. + mag_tac. + econstructor; simplify. + repeat mag_tac; auto. + intros. repeat mag_tac. simplify. + apply array_get_error_each; auto. + repeat mag_tac; crush. + repeat mag_tac; crush. + - unfold arr_assocmap_set in *. + destruct ar ! r eqn:?. rewrite AssocMap.gso in H; auto. + apply H0 in Heqo. apply H0 in H. repeat inv_exists. simplify. + econstructor. unfold Verilog.arr in *. rewrite H3. simplify. + rewrite AssocMap.gso; auto. eauto. intros. auto. auto. + apply H1 in Heqo. apply H0 in H. repeat inv_exists; simplify. + econstructor. unfold Verilog.arr in *. rewrite Heqo. simplify; eauto. + - destruct (Pos.eq_dec r s); unfold arr_assocmap_set, Verilog.arr in *; simplify; subst. + destruct ar!s eqn:?; repeat mag_tac; crush. + apply H1 in H. mag_tac; crush. + destruct ar!r eqn:?; repeat mag_tac; crush. + apply H1 in Heqo. repeat mag_tac; auto. +Qed. +#[local] Hint Resolve match_arrs_gss : mgen. + +Lemma match_arr_assocs_block : + forall rab rab' r i rhsval, + match_arr_assocs rab rab' -> + match_arr_assocs (block_arr r i rab rhsval) (block_arr r i rab' rhsval). +Proof. inversion 1; econstructor; eauto with mgen. Qed. +#[local] Hint Resolve match_arr_assocs_block : mgen. + +Lemma match_arr_assocs_nonblock : + forall rab rab' r i rhsval, + match_arr_assocs rab rab' -> + match_arr_assocs (nonblock_arr r i rab rhsval) (nonblock_arr r i rab' rhsval). +Proof. inversion 1; econstructor; eauto with mgen. Qed. +#[local] Hint Resolve match_arr_assocs_nonblock : mgen. + +Lemma match_states_same : + forall f rs1 ar1 c rs2 ar2 p, + stmnt_runp f rs1 ar1 c rs2 ar2 -> + max_reg_stmnt c < p -> + forall trs1 tar1, + match_reg_assocs p rs1 trs1 -> + match_arr_assocs ar1 tar1 -> + exists trs2 tar2, + stmnt_runp f trs1 tar1 c trs2 tar2 + /\ match_reg_assocs p rs2 trs2 + /\ match_arr_assocs ar2 tar2. +Proof. + Ltac match_states_same_facts := + match goal with + | H: match_reg_assocs _ _ _ |- _ => + let H2 := fresh "H" in + learn H as H2; inv H2 + | H: match_arr_assocs _ _ |- _ => + let H2 := fresh "H" in + learn H as H2; inv H2 + | H1: context[exists _, _], H2: context[exists _, _] |- _ => + learn H1; learn H2; + exploit H1; mgen_crush; exploit H2; mgen_crush + | H1: context[exists _, _] |- _ => + learn H1; exploit H1; mgen_crush + end. + Ltac match_states_same_tac := + match goal with + | |- exists _, _ => econstructor + | |- _ < _ => lia + | H: context[_ <> _] |- stmnt_runp _ _ _ (Vcase _ (Stmntcons _ _ _) _) _ _ => + eapply stmnt_runp_Vcase_nomatch + | |- stmnt_runp _ _ _ (Vcase _ (Stmntcons _ _ _) _) _ _ => + eapply stmnt_runp_Vcase_match + | H: valueToBool _ = false |- stmnt_runp _ _ _ _ _ _ => + eapply stmnt_runp_Vcond_false + | |- stmnt_runp _ _ _ _ _ _ => econstructor + | |- expr_runp _ _ _ _ _ => eapply expr_runp_matches2 + end; mgen_crush; try lia. + induction 1; simplify; repeat match_states_same_facts; + try destruct_match; try solve [repeat match_states_same_tac]. + - inv H. exists (block_reg r {| assoc_blocking := rab'; assoc_nonblocking := ran' |} rhsval); + repeat match_states_same_tac; econstructor. + - exists (nonblock_reg r {| assoc_blocking := rab'; assoc_nonblocking := ran' |} rhsval); + repeat match_states_same_tac; inv H; econstructor. + - econstructor. exists (block_arr r i {| assoc_blocking := rab'0; assoc_nonblocking := ran'0 |} rhsval). + simplify; repeat match_states_same_tac. inv H. econstructor. + repeat match_states_same_tac. eauto. mgen_crush. + - econstructor. exists (nonblock_arr r i {| assoc_blocking := rab'0; assoc_nonblocking := ran'0 |} rhsval). + simplify; repeat match_states_same_tac. inv H. econstructor. + repeat match_states_same_tac. eauto. mgen_crush. +Qed. + +Lemma match_reg_assocs_merge : + forall p rs rs', + match_reg_assocs p rs rs' -> + match_reg_assocs p (merge_reg_assocs rs) (merge_reg_assocs rs'). +Proof. + inversion 1. + econstructor; econstructor; crush. inv H3. inv H. + inv H7. inv H9. + unfold merge_regs. + destruct (ran!r) eqn:?; destruct (rab!r) eqn:?. + erewrite AssocMapExt.merge_correct_1; eauto. + erewrite AssocMapExt.merge_correct_1; eauto. + rewrite <- H2; eauto. + erewrite AssocMapExt.merge_correct_1; eauto. + erewrite AssocMapExt.merge_correct_1; eauto. + rewrite <- H2; eauto. + erewrite AssocMapExt.merge_correct_2; eauto. + erewrite AssocMapExt.merge_correct_2; eauto. + rewrite <- H2; eauto. + rewrite <- H; eauto. + erewrite AssocMapExt.merge_correct_3; eauto. + erewrite AssocMapExt.merge_correct_3; eauto. + rewrite <- H2; eauto. + rewrite <- H; eauto. +Qed. +#[local] Hint Resolve match_reg_assocs_merge : mgen. + +Lemma transf_not_changed : + forall state ram n d c i d_s c_s, + (forall e1 e2 r, d_s <> Vnonblock (Vvari r e1) e2) -> + (forall e1 e2 r, d_s <> Vnonblock e1 (Vvari r e2)) -> + d!i = Some d_s -> + c!i = Some c_s -> + transf_maps state ram (i, n) (d, c) = (d, c). +Proof. intros; unfold transf_maps; repeat destruct_match; mgen_crush. Qed. + +Lemma transf_not_changed_neq : + forall state ram n d c d' c' i a d_s c_s, + transf_maps state ram (a, n) (d, c) = (d', c') -> + d!i = Some d_s -> + c!i = Some c_s -> + a <> i -> n <> i -> + d'!i = Some d_s /\ c'!i = Some c_s. +Proof. + unfold transf_maps; intros; repeat destruct_match; mgen_crush; + match goal with [ H: (_, _) = (_, _) |- _ ] => inv H end; + repeat (rewrite AssocMap.gso; auto). +Qed. + +Lemma forall_gt : + forall l, Forall (Pos.ge (fold_right Pos.max 1 l)) l. +Proof. + induction l; auto. + constructor. inv IHl; simplify; lia. + simplify. destruct (Pos.max_dec a (fold_right Pos.max 1 l)). + rewrite e. apply Pos.max_l_iff in e. apply Pos.le_ge in e. + apply Forall_forall. rewrite Forall_forall in IHl. + intros. + assert (X: forall a b c, a >= c -> c >= b -> a >= b) by lia. + apply X with (b := x) in e; auto. + rewrite e; auto. +Qed. + +Lemma max_index_list : + forall A (l : list (positive * A)) i d_s, + In (i, d_s) l -> + list_norepet (map fst l) -> + i <= fold_right Pos.max 1 (map fst l). +Proof. + induction l; crush. + inv H. inv H0. simplify. lia. + inv H0. + let H := fresh "H" in + assert (H: forall a b c, c <= b -> c <= Pos.max a b) by lia; + apply H; eapply IHl; eauto. +Qed. + +Lemma max_index : + forall A d i (d_s: A), d ! i = Some d_s -> i <= max_pc d. +Proof. + unfold max_pc; + eauto using max_index_list, + PTree.elements_correct, PTree.elements_keys_norepet. +Qed. + +Lemma max_index_2' : + forall l i, i > fold_right Pos.max 1 l -> Forall (Pos.gt i) l. +Proof. induction l; crush; constructor; [|apply IHl]; lia. Qed. + +Lemma max_index_2'' : + forall l i, Forall (Pos.gt i) l -> ~ In i l. +Proof. + induction l; crush. unfold not in *. + intros. inv H0. inv H. lia. eapply IHl. + inv H. apply H4. auto. +Qed. + +Lemma elements_correct_none : + forall A am k, + ~ List.In k (List.map (@fst _ A) (AssocMap.elements am)) -> + AssocMap.get k am = None. +Proof. + intros. apply AssocMapExt.elements_correct' in H. unfold not in *. + destruct am ! k eqn:?; auto. exfalso. apply H. eexists. auto. +Qed. +#[local] Hint Resolve elements_correct_none : assocmap. + +Lemma max_index_2 : + forall A (d: AssocMap.t A) i, i > max_pc d -> d ! i = None. +Proof. + intros. unfold max_pc in *. apply max_index_2' in H. + apply max_index_2'' in H. apply elements_correct_none. auto. +Qed. + +Definition match_prog (p: program) (tp: program) := + Linking.match_program (fun cu f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. unfold transf_program, match_prog. + apply Linking.match_transform_program. +Qed. + +Lemma exec_all_Vskip : + forall rs ar, + exec_all Vskip Vskip rs ar rs ar. +Proof. + unfold exec_all. + intros. repeat econstructor. + Unshelve. unfold fext. exact tt. +Qed. + +Lemma match_assocmaps_trans: + forall p rs1 rs2 rs3, + match_assocmaps p rs1 rs2 -> + match_assocmaps p rs2 rs3 -> + match_assocmaps p rs1 rs3. +Proof. + intros. inv H. inv H0. econstructor; eauto. + intros. rewrite H1 by auto. auto. +Qed. + +Lemma match_reg_assocs_trans: + forall p rs1 rs2 rs3, + match_reg_assocs p rs1 rs2 -> + match_reg_assocs p rs2 rs3 -> + match_reg_assocs p rs1 rs3. +Proof. + intros. inv H. inv H0. + econstructor; eapply match_assocmaps_trans; eauto. +Qed. + +Lemma empty_arrs_match : + forall m, + match_arrs (empty_stack m) (empty_stack (transf_module m)). +Proof. + intros; + unfold empty_stack, transf_module; repeat destruct_match; mgen_crush. +Qed. +#[local] Hint Resolve empty_arrs_match : mgen. + +Lemma max_module_stmnts : + forall m, + Pos.max (max_stmnt_tree (mod_controllogic m)) + (max_stmnt_tree (mod_datapath m)) < max_reg_module m + 1. +Proof. intros. unfold max_reg_module. lia. Qed. +#[local] Hint Resolve max_module_stmnts : mgen. + +Lemma transf_module_code : + forall m, + mod_ram m = None -> + transf_code (mod_st m) + {| ram_size := mod_stk_len m; + ram_mem := mod_stk m; + ram_en := max_reg_module m + 2; + ram_addr := max_reg_module m + 1; + ram_wr_en := max_reg_module m + 5; + ram_d_in := max_reg_module m + 3; + ram_d_out := max_reg_module m + 4; + ram_u_en := max_reg_module m + 6; + ram_ordering := ram_wf (max_reg_module m) |} + (mod_datapath m) (mod_controllogic m) + = ((mod_datapath (transf_module m)), mod_controllogic (transf_module m)). +Proof. unfold transf_module; intros; repeat destruct_match; crush. + apply surjective_pairing. Qed. +#[local] Hint Resolve transf_module_code : mgen. + +Lemma transf_module_code_ram : + forall m r, mod_ram m = Some r -> transf_module m = m. +Proof. unfold transf_module; intros; repeat destruct_match; crush. Qed. +#[local] Hint Resolve transf_module_code_ram : mgen. + +Lemma mod_reset_lt : forall m, mod_reset m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_reset_lt : mgen. + +Lemma mod_finish_lt : forall m, mod_finish m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_finish_lt : mgen. + +Lemma mod_return_lt : forall m, mod_return m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_return_lt : mgen. + +Lemma mod_start_lt : forall m, mod_start m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_start_lt : mgen. + +Lemma mod_stk_lt : forall m, mod_stk m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_stk_lt : mgen. + +Lemma mod_st_lt : forall m, mod_st m < max_reg_module m + 1. +Proof. intros; unfold max_reg_module; lia. Qed. +#[local] Hint Resolve mod_st_lt : mgen. + +Lemma mod_reset_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_reset m) = Some v -> + ar' ! (mod_reset (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_reset_modify : mgen. + +Lemma mod_finish_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_finish m) = Some v -> + ar' ! (mod_finish (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_finish_modify : mgen. + +Lemma mod_return_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_return m) = Some v -> + ar' ! (mod_return (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_return_modify : mgen. + +Lemma mod_start_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_start m) = Some v -> + ar' ! (mod_start (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_start_modify : mgen. + +Lemma mod_st_modify : + forall m ar ar' v, + match_assocmaps (max_reg_module m + 1) ar ar' -> + ar ! (mod_st m) = Some v -> + ar' ! (mod_st (transf_module m)) = Some v. +Proof. + inversion 1. intros. + unfold transf_module; repeat destruct_match; simplify; + rewrite <- H0; eauto with mgen. +Qed. +#[local] Hint Resolve mod_st_modify : mgen. + +Lemma match_arrs_read : + forall ra ra' addr v mem, + arr_assocmap_lookup ra mem addr = Some v -> + match_arrs ra ra' -> + arr_assocmap_lookup ra' mem addr = Some v. +Proof. + unfold arr_assocmap_lookup. intros. destruct_match; destruct_match; try discriminate. + inv H0. eapply H1 in Heqo0. inv Heqo0. simplify. unfold arr in *. + rewrite H in Heqo. inv Heqo. + rewrite H0. auto. + inv H0. eapply H1 in Heqo0. inv Heqo0. inv H0. unfold arr in *. + rewrite H3 in Heqo. discriminate. +Qed. +#[local] Hint Resolve match_arrs_read : mgen. + +Lemma match_reg_implies_equal : + forall ra ra' p a b c, + Int.eq (ra # a) (ra # b) = c -> + a < p -> b < p -> + match_assocmaps p ra ra' -> + Int.eq (ra' # a) (ra' # b) = c. +Proof. + unfold find_assocmap, AssocMapExt.get_default; intros. + inv H2. destruct (ra ! a) eqn:?; destruct (ra ! b) eqn:?; + repeat rewrite <- H3 by lia; rewrite Heqo; rewrite Heqo0; auto. +Qed. +#[local] Hint Resolve match_reg_implies_equal : mgen. + +Lemma exec_ram_same : + forall rs1 ar1 ram rs2 ar2 p, + exec_ram rs1 ar1 (Some ram) rs2 ar2 -> + forall_ram (fun x => x < p) ram -> + forall trs1 tar1, + match_reg_assocs p rs1 trs1 -> + match_arr_assocs ar1 tar1 -> + exists trs2 tar2, + exec_ram trs1 tar1 (Some ram) trs2 tar2 + /\ match_reg_assocs p rs2 trs2 + /\ match_arr_assocs ar2 tar2. +Proof. + Ltac exec_ram_same_facts := + match goal with + | H: match_reg_assocs _ _ _ |- _ => let H2 := fresh "H" in learn H as H2; inv H2 + | H: match_assocmaps _ _ _ |- _ => let H2 := fresh "H" in learn H as H2; inv H2 + | H: match_arr_assocs _ _ |- _ => let H2 := fresh "H" in learn H as H2; inv H2 + | H: match_arrs _ _ |- _ => let H2 := fresh "H" in learn H as H2; inv H2 + end. + inversion 1; subst; destruct ram; unfold forall_ram; simplify; repeat exec_ram_same_facts. + - repeat (econstructor; mgen_crush). + - do 2 econstructor; simplify; + [eapply exec_ram_Some_write; [ apply H1 | apply H2 | | | | | ] | | ]; + mgen_crush. + - do 2 econstructor; simplify; [eapply exec_ram_Some_read | | ]; + repeat (try econstructor; mgen_crush). +Qed. + +Lemma match_assocmaps_merge : + forall p nasr basr nasr' basr', + match_assocmaps p nasr nasr' -> + match_assocmaps p basr basr' -> + match_assocmaps p (merge_regs nasr basr) (merge_regs nasr' basr'). +Proof. + unfold merge_regs. + intros. inv H. inv H0. econstructor. + intros. + destruct nasr ! r eqn:?; destruct basr ! r eqn:?. + erewrite AssocMapExt.merge_correct_1; mgen_crush. + erewrite AssocMapExt.merge_correct_1; mgen_crush. + erewrite AssocMapExt.merge_correct_1; mgen_crush. + erewrite AssocMapExt.merge_correct_1; mgen_crush. + erewrite AssocMapExt.merge_correct_2; mgen_crush. + erewrite AssocMapExt.merge_correct_2; mgen_crush. + erewrite AssocMapExt.merge_correct_3; mgen_crush. + erewrite AssocMapExt.merge_correct_3; mgen_crush. +Qed. +#[local] Hint Resolve match_assocmaps_merge : mgen. + +Lemma list_combine_nth_error1 : + forall l l' addr v, + length l = length l' -> + nth_error l addr = Some (Some v) -> + nth_error (list_combine merge_cell l l') addr = Some (Some v). +Proof. induction l; destruct l'; destruct addr; crush. Qed. + +Lemma list_combine_nth_error2 : + forall l' l addr v, + length l = length l' -> + nth_error l addr = Some None -> + nth_error l' addr = Some (Some v) -> + nth_error (list_combine merge_cell l l') addr = Some (Some v). +Proof. induction l'; try rewrite nth_error_nil in *; destruct l; destruct addr; crush. Qed. + +Lemma list_combine_nth_error3 : + forall l l' addr, + length l = length l' -> + nth_error l addr = Some None -> + nth_error l' addr = Some None -> + nth_error (list_combine merge_cell l l') addr = Some None. +Proof. induction l; destruct l'; destruct addr; crush. Qed. + +Lemma list_combine_nth_error4 : + forall l l' addr, + length l = length l' -> + nth_error l addr = None -> + nth_error (list_combine merge_cell l l') addr = None. +Proof. induction l; destruct l'; destruct addr; crush. Qed. + +Lemma list_combine_nth_error5 : + forall l l' addr, + length l = length l' -> + nth_error l' addr = None -> + nth_error (list_combine merge_cell l l') addr = None. +Proof. induction l; destruct l'; destruct addr; crush. Qed. + +Lemma array_get_error_merge1 : + forall a a0 addr v, + arr_length a = arr_length a0 -> + array_get_error addr a = Some (Some v) -> + array_get_error addr (combine merge_cell a a0) = Some (Some v). +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error1; destruct a; destruct a0; crush. +Qed. + +Lemma array_get_error_merge2 : + forall a a0 addr v, + arr_length a = arr_length a0 -> + array_get_error addr a0 = Some (Some v) -> + array_get_error addr a = Some None -> + array_get_error addr (combine merge_cell a a0) = Some (Some v). +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error2; destruct a; destruct a0; crush. +Qed. + +Lemma array_get_error_merge3 : + forall a a0 addr, + arr_length a = arr_length a0 -> + array_get_error addr a0 = Some None -> + array_get_error addr a = Some None -> + array_get_error addr (combine merge_cell a a0) = Some None. +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error3; destruct a; destruct a0; crush. +Qed. + +Lemma array_get_error_merge4 : + forall a a0 addr, + arr_length a = arr_length a0 -> + array_get_error addr a = None -> + array_get_error addr (combine merge_cell a a0) = None. +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error4; destruct a; destruct a0; crush. +Qed. + +Lemma array_get_error_merge5 : + forall a a0 addr, + arr_length a = arr_length a0 -> + array_get_error addr a0 = None -> + array_get_error addr (combine merge_cell a a0) = None. +Proof. + unfold array_get_error, combine in *; intros; + apply list_combine_nth_error5; destruct a; destruct a0; crush. +Qed. + +Lemma match_arrs_merge' : + forall addr nasa basa arr s x x0 a a0 nasa' basa', + (AssocMap.combine merge_arr nasa basa) ! s = Some arr -> + nasa ! s = Some a -> + basa ! s = Some a0 -> + nasa' ! s = Some x0 -> + basa' ! s = Some x -> + arr_length x = arr_length x0 -> + array_get_error addr a0 = array_get_error addr x -> + arr_length a0 = arr_length x -> + array_get_error addr a = array_get_error addr x0 -> + arr_length a = arr_length x0 -> + array_get_error addr arr = array_get_error addr (combine merge_cell x0 x). +Proof. + intros. rewrite AssocMap.gcombine in H by auto. + unfold merge_arr in H. + rewrite H0 in H. rewrite H1 in H. inv H. + destruct (array_get_error addr a0) eqn:?; destruct (array_get_error addr a) eqn:?. + destruct o; destruct o0. + erewrite array_get_error_merge1; eauto. erewrite array_get_error_merge1; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge2; eauto. erewrite array_get_error_merge2; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge1; eauto. erewrite array_get_error_merge1; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge3; eauto. erewrite array_get_error_merge3; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge4; eauto. erewrite array_get_error_merge4; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge5; eauto. erewrite array_get_error_merge5; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. + erewrite array_get_error_merge5; eauto. erewrite array_get_error_merge5; eauto. + rewrite <- H6 in H4. rewrite <- H8 in H4. auto. +Qed. + +Lemma match_arrs_merge : + forall nasa nasa' basa basa', + match_arrs_size nasa basa -> + match_arrs nasa nasa' -> + match_arrs basa basa' -> + match_arrs (merge_arrs nasa basa) (merge_arrs nasa' basa'). +Proof. + unfold merge_arrs. + intros. inv H. inv H0. inv H1. econstructor. + - intros. destruct nasa ! s eqn:?; destruct basa ! s eqn:?; unfold Verilog.arr in *. + + pose proof Heqo. apply H in Heqo. pose proof Heqo0. apply H0 in Heqo0. + repeat inv_exists. simplify. + eexists. simplify. rewrite AssocMap.gcombine; eauto. + unfold merge_arr. unfold Verilog.arr in *. rewrite H11. rewrite H12. auto. + intros. eapply match_arrs_merge'; eauto. eapply H2 in H7; eauto. + inv_exists. simplify. congruence. + rewrite AssocMap.gcombine in H1; auto. unfold merge_arr in H1. + rewrite H7 in H1. rewrite H8 in H1. inv H1. + repeat rewrite combine_length; auto. + eapply H2 in H7; eauto. inv_exists; simplify; congruence. + eapply H2 in H7; eauto. inv_exists; simplify; congruence. + + apply H2 in Heqo; inv_exists; crush. + + apply H3 in Heqo0; inv_exists; crush. + + rewrite AssocMap.gcombine in H1 by auto. unfold merge_arr in *. + rewrite Heqo in H1. rewrite Heqo0 in H1. discriminate. + - intros. rewrite AssocMap.gcombine in H1 by auto. unfold merge_arr in H1. + repeat destruct_match; crush. + rewrite AssocMap.gcombine by auto; unfold merge_arr. + apply H5 in Heqo. apply H6 in Heqo0. + unfold Verilog.arr in *. + rewrite Heqo. rewrite Heqo0. auto. +Qed. +#[local] Hint Resolve match_arrs_merge : mgen. + +Lemma match_empty_size_merge : + forall nasa2 basa2 m, + match_empty_size m nasa2 -> + match_empty_size m basa2 -> + match_empty_size m (merge_arrs nasa2 basa2). +Proof. + intros. inv H. inv H0. constructor. + simplify. unfold merge_arrs. rewrite AssocMap.gcombine by auto. + pose proof H0 as H6. apply H1 in H6. inv_exists; simplify. + pose proof H0 as H9. apply H in H9. inv_exists; simplify. + eexists. simplify. unfold merge_arr. unfold Verilog.arr in *. rewrite H6. + rewrite H9. auto. rewrite H8. symmetry. apply combine_length. congruence. + intros. + destruct (nasa2 ! s) eqn:?; destruct (basa2 ! s) eqn:?. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. setoid_rewrite Heqo in H0. setoid_rewrite Heqo0 in H0. inv H0. + apply H2 in Heqo. apply H4 in Heqo0. repeat inv_exists; simplify. + eexists. simplify. eauto. rewrite list_combine_length. + rewrite (arr_wf a). rewrite (arr_wf a0). lia. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. setoid_rewrite Heqo in H0. setoid_rewrite Heqo0 in H0. + apply H2 in Heqo. inv_exists; simplify. + econstructor; eauto. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. setoid_rewrite Heqo in H0. setoid_rewrite Heqo0 in H0. + inv H0. apply H4 in Heqo0. inv_exists; simplify. econstructor; eauto. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. setoid_rewrite Heqo in H0. setoid_rewrite Heqo0 in H0. + discriminate. + split; intros. + unfold merge_arrs in H0. rewrite AssocMap.gcombine in H0 by auto. + unfold merge_arr in *. repeat destruct_match; crush. apply H5 in Heqo0; auto. + pose proof H0. + apply H5 in H0. + apply H3 in H6. unfold merge_arrs. rewrite AssocMap.gcombine by auto. + setoid_rewrite H0. setoid_rewrite H6. auto. +Qed. +#[local] Hint Resolve match_empty_size_merge : mgen. + +Lemma match_empty_size_match : + forall m nasa2 basa2, + match_empty_size m nasa2 -> + match_empty_size m basa2 -> + match_arrs_size nasa2 basa2. +Proof. + Ltac match_empty_size_match_solve := + match goal with + | H: context[forall s arr, ?ar ! s = Some arr -> _], H2: ?ar ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3; repeat inv_exists + | H: context[forall s, ?ar ! s = None <-> _], H2: ?ar ! _ = None |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3 + | H: context[forall s, _ <-> ?ar ! s = None], H2: ?ar ! _ = None |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3 + | |- exists _, _ => econstructor + | |- _ ! _ = Some _ => eassumption + | |- _ = _ => congruence + | |- _ <-> _ => split + end; simplify. + inversion 1; inversion 1; constructor; simplify; repeat match_empty_size_match_solve. +Qed. +#[local] Hint Resolve match_empty_size_match : mgen. + +Lemma match_get_merge : + forall p ran ran' rab rab' s v, + s < p -> + match_assocmaps p ran ran' -> + match_assocmaps p rab rab' -> + (merge_regs ran rab) ! s = Some v -> + (merge_regs ran' rab') ! s = Some v. +Proof. + intros. + assert (X: match_assocmaps p (merge_regs ran rab) (merge_regs ran' rab')) by auto with mgen. + inv X. rewrite <- H3; auto. +Qed. +#[local] Hint Resolve match_get_merge : mgen. + +Ltac masrp_tac := + match goal with + | H: context[forall s arr, ?ar ! s = Some arr -> _], H2: ?ar ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3; repeat inv_exists + | H: context[forall s, ?ar ! s = None <-> _], H2: ?ar ! _ = None |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3 + | H: context[forall s, _ <-> ?ar ! s = None], H2: ?ar ! _ = None |- _ => + let H3 := fresh "H" in + learn H; pose proof H2 as H3; apply H in H3 + | ra: arr_associations |- _ => + let ra1 := fresh "ran" in let ra2 := fresh "rab" in destruct ra as [ra1 ra2] + | |- _ ! _ = _ => solve [mgen_crush] + | |- _ = _ => congruence + | |- _ <> _ => lia + | H: ?ar ! ?s = _ |- context[match ?ar ! ?r with _ => _ end] => learn H; destruct (Pos.eq_dec s r); subst + | H: ?ar ! ?s = _ |- context[match ?ar ! ?s with _ => _ end] => setoid_rewrite H + | |- context[match ?ar ! ?s with _ => _ end] => destruct (ar ! s) eqn:? + | H: ?s <> ?r |- context[(_ # ?r <- _) ! ?s] => rewrite AssocMap.gso + | H: ?r <> ?s |- context[(_ # ?r <- _) ! ?s] => rewrite AssocMap.gso + | |- context[(_ # ?s <- _) ! ?s] => rewrite AssocMap.gss + | H: context[match ?ar ! ?r with _ => _ end ! ?s] |- _ => + destruct (ar ! r) eqn:?; destruct (Pos.eq_dec r s); subst + | H: ?ar ! ?s = _, H2: context[match ?ar ! ?s with _ => _ end] |- _ => + setoid_rewrite H in H2 + | H: context[match ?ar ! ?s with _ => _ end] |- _ => destruct (ar ! s) eqn:? + | H: ?s <> ?r, H2: context[(_ # ?r <- _) ! ?s] |- _ => rewrite AssocMap.gso in H2 + | H: ?r <> ?s, H2: context[(_ # ?r <- _) ! ?s] |- _ => rewrite AssocMap.gso in H2 + | H: context[(_ # ?s <- _) ! ?s] |- _ => rewrite AssocMap.gss in H + | |- context[match_empty_size] => constructor + | |- context[arr_assocmap_set] => unfold arr_assocmap_set + | H: context[arr_assocmap_set] |- _ => unfold arr_assocmap_set in H + | |- exists _, _ => econstructor + | |- _ <-> _ => split + end; simplify. + +Lemma match_empty_assocmap_set : + forall m r i rhsval asa, + match_empty_size m asa -> + match_empty_size m (arr_assocmap_set r i rhsval asa). +Proof. + inversion 1; subst; simplify. + constructor. intros. + repeat masrp_tac. + intros. do 5 masrp_tac; try solve [repeat masrp_tac]. + apply H1 in H3. inv_exists. simplify. + econstructor. simplify. apply H3. congruence. + repeat masrp_tac. destruct (Pos.eq_dec r s); subst. + rewrite AssocMap.gss in H8. discriminate. + rewrite AssocMap.gso in H8; auto. apply H2 in H8. auto. + destruct (Pos.eq_dec r s); subst. apply H1 in H5. inv_exists. simplify. + rewrite H5 in H8. discriminate. + rewrite AssocMap.gso; auto. + apply H2 in H5. auto. apply H2 in H5. auto. + Unshelve. auto. +Qed. +#[local] Hint Resolve match_empty_assocmap_set : mgen. + +Lemma match_arrs_size_stmnt_preserved : + forall m f rs1 ar1 ar2 c rs2, + stmnt_runp f rs1 ar1 c rs2 ar2 -> + match_empty_size m (assoc_nonblocking ar1) -> + match_empty_size m (assoc_blocking ar1) -> + match_empty_size m (assoc_nonblocking ar2) /\ match_empty_size m (assoc_blocking ar2). +Proof. + induction 1; inversion 1; inversion 1; eauto; simplify; try solve [repeat masrp_tac]. + subst. apply IHstmnt_runp2; apply IHstmnt_runp1; auto. + apply IHstmnt_runp2; apply IHstmnt_runp1; auto. + apply match_empty_assocmap_set. auto. + apply match_empty_assocmap_set. auto. +Qed. + +Lemma match_arrs_size_stmnt_preserved2 : + forall m f rs1 na ba na' ba' c rs2, + stmnt_runp f rs1 {| assoc_nonblocking := na; assoc_blocking := ba |} c rs2 + {| assoc_nonblocking := na'; assoc_blocking := ba' |} -> + match_empty_size m na -> + match_empty_size m ba -> + match_empty_size m na' /\ match_empty_size m ba'. +Proof. + intros. + remember ({| assoc_blocking := ba; assoc_nonblocking := na |}) as ar1. + remember ({| assoc_blocking := ba'; assoc_nonblocking := na' |}) as ar2. + assert (X1: na' = (assoc_nonblocking ar2)) by (rewrite Heqar2; auto). rewrite X1. + assert (X2: ba' = (assoc_blocking ar2)) by (rewrite Heqar2; auto). rewrite X2. + assert (X3: na = (assoc_nonblocking ar1)) by (rewrite Heqar1; auto). rewrite X3 in *. + assert (X4: ba = (assoc_blocking ar1)) by (rewrite Heqar1; auto). rewrite X4 in *. + eapply match_arrs_size_stmnt_preserved; mgen_crush. +Qed. +#[local] Hint Resolve match_arrs_size_stmnt_preserved2 : mgen. + +Lemma match_arrs_size_ram_preserved : + forall m rs1 ar1 ar2 ram rs2, + exec_ram rs1 ar1 ram rs2 ar2 -> + match_empty_size m (assoc_nonblocking ar1) -> + match_empty_size m (assoc_blocking ar1) -> + match_empty_size m (assoc_nonblocking ar2) + /\ match_empty_size m (assoc_blocking ar2). +Proof. + induction 1; inversion 1; inversion 1; subst; simplify; try solve [repeat masrp_tac]. + masrp_tac. masrp_tac. solve [repeat masrp_tac]. + masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. + masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. masrp_tac. + masrp_tac. apply H8 in H1; inv_exists; simplify. repeat masrp_tac. auto. + repeat masrp_tac. + repeat masrp_tac. + repeat masrp_tac. + destruct (Pos.eq_dec (ram_mem r) s); subst; repeat masrp_tac. + destruct (Pos.eq_dec (ram_mem r) s); subst; repeat masrp_tac. + apply H9 in H17; auto. apply H9 in H17; auto. + Unshelve. eauto. +Qed. +#[local] Hint Resolve match_arrs_size_ram_preserved : mgen. + +Lemma match_arrs_size_ram_preserved2 : + forall m rs1 na na' ba ba' ram rs2, + exec_ram rs1 {| assoc_nonblocking := na; assoc_blocking := ba |} ram rs2 + {| assoc_nonblocking := na'; assoc_blocking := ba' |} -> + match_empty_size m na -> match_empty_size m ba -> + match_empty_size m na' /\ match_empty_size m ba'. +Proof. + intros. + remember ({| assoc_blocking := ba; assoc_nonblocking := na |}) as ar1. + remember ({| assoc_blocking := ba'; assoc_nonblocking := na' |}) as ar2. + assert (X1: na' = (assoc_nonblocking ar2)) by (rewrite Heqar2; auto). rewrite X1. + assert (X2: ba' = (assoc_blocking ar2)) by (rewrite Heqar2; auto). rewrite X2. + assert (X3: na = (assoc_nonblocking ar1)) by (rewrite Heqar1; auto). rewrite X3 in *. + assert (X4: ba = (assoc_blocking ar1)) by (rewrite Heqar1; auto). rewrite X4 in *. + eapply match_arrs_size_ram_preserved; mgen_crush. +Qed. +#[local] Hint Resolve match_arrs_size_ram_preserved2 : mgen. + +Lemma empty_stack_m : + forall m, empty_stack m = empty_stack' (mod_stk_len m) (mod_stk m). +Proof. unfold empty_stack, empty_stack'; mgen_crush. Qed. +Hint Rewrite empty_stack_m : mgen. + +Ltac clear_forall := + repeat match goal with + | H: context[forall _, _] |- _ => clear H + end. + +Lemma list_combine_none : + forall n l, + length l = n -> + list_combine Verilog.merge_cell (list_repeat None n) l = l. +Proof. + induction n; intros; crush. + - symmetry. apply length_zero_iff_nil. auto. + - destruct l; crush. + rewrite list_repeat_cons. + crush. f_equal. + eauto. +Qed. + +Lemma combine_none : + forall n a, + a.(arr_length) = n -> + arr_contents (combine Verilog.merge_cell (arr_repeat None n) a) = arr_contents a. +Proof. + intros. + unfold combine. + crush. + + rewrite <- (arr_wf a) in H. + apply list_combine_none. + assumption. +Qed. + +Lemma combine_none2 : + forall n a addr, + arr_length a = n -> + array_get_error addr (combine Verilog.merge_cell (arr_repeat None n) a) + = array_get_error addr a. +Proof. intros; auto using array_get_error_equal, combine_none. Qed. + +Lemma list_combine_lookup_first : + forall l1 l2 n, + length l1 = length l2 -> + nth_error l1 n = Some None -> + nth_error (list_combine Verilog.merge_cell l1 l2) n = nth_error l2 n. +Proof. + induction l1; intros; crush. + + rewrite nth_error_nil in H0. + discriminate. + + destruct l2 eqn:EQl2. crush. + simpl in H. invert H. + destruct n; simpl in *. + invert H0. simpl. reflexivity. + eauto. +Qed. + +Lemma combine_lookup_first : + forall a1 a2 n, + a1.(arr_length) = a2.(arr_length) -> + array_get_error n a1 = Some None -> + array_get_error n (combine Verilog.merge_cell a1 a2) = array_get_error n a2. +Proof. + intros. + + unfold array_get_error in *. + apply list_combine_lookup_first; eauto. + rewrite a1.(arr_wf). rewrite a2.(arr_wf). + assumption. +Qed. + +Lemma list_combine_lookup_second : + forall l1 l2 n x, + length l1 = length l2 -> + nth_error l1 n = Some (Some x) -> + nth_error (list_combine Verilog.merge_cell l1 l2) n = Some (Some x). +Proof. + induction l1; intros; crush; auto. + + destruct l2 eqn:EQl2. crush. + simpl in H. invert H. + destruct n; simpl in *. + invert H0. simpl. reflexivity. + eauto. +Qed. + +Lemma combine_lookup_second : + forall a1 a2 n x, + a1.(arr_length) = a2.(arr_length) -> + array_get_error n a1 = Some (Some x) -> + array_get_error n (combine Verilog.merge_cell a1 a2) = Some (Some x). +Proof. + intros. + + unfold array_get_error in *. + apply list_combine_lookup_second; eauto. + rewrite a1.(arr_wf). rewrite a2.(arr_wf). + assumption. +Qed. + +Lemma match_get_arrs2 : + forall a i v l, + length a = l -> + list_combine merge_cell (list_set i (Some v) (list_repeat None l)) a = + list_combine merge_cell (list_repeat None l) (list_set i (Some v) a). +Proof. + induction a; crush; subst. + - destruct i. unfold list_repeat. unfold list_repeat'. auto. + unfold list_repeat. unfold list_repeat'. auto. + - destruct i. + rewrite list_repeat_cons. simplify. auto. + rewrite list_repeat_cons. simplify. f_equal. apply IHa. auto. +Qed. + +Lemma match_get_arrs : + forall addr i v x4 x x3, + x4 = arr_length x -> + x4 = arr_length x3 -> + array_get_error addr (combine merge_cell (array_set i (Some v) (arr_repeat None x4)) + (combine merge_cell x x3)) + = array_get_error addr (combine merge_cell (arr_repeat None x4) + (array_set i (Some v) (combine merge_cell x x3))). +Proof. + intros. apply array_get_error_equal. unfold combine. simplify. + destruct x; destruct x3; simplify. + apply match_get_arrs2. rewrite list_combine_length. subst. + rewrite H0. lia. +Qed. + +Lemma combine_array_set' : + forall a b i v, + length a = length b -> + list_combine merge_cell (list_set i (Some v) a) b = + list_set i (Some v) (list_combine merge_cell a b). +Proof. + induction a; simplify; crush. + - destruct i; crush. + - destruct i; destruct b; crush. + f_equal. apply IHa. auto. +Qed. + +Lemma combine_array_set : + forall a b i v addr, + arr_length a = arr_length b -> + array_get_error addr (combine merge_cell (array_set i (Some v) a) b) + = array_get_error addr (array_set i (Some v) (combine merge_cell a b)). +Proof. + intros. destruct a; destruct b. unfold array_set. simplify. + unfold array_get_error. simplify. f_equal. + apply combine_array_set'. crush. +Qed. + +Lemma array_get_combine' : + forall a b a' b' addr, + length a = length b -> + length a = length b' -> + length a = length a' -> + nth_error a addr = nth_error a' addr -> + nth_error b addr = nth_error b' addr -> + nth_error (list_combine merge_cell a b) addr = + nth_error (list_combine merge_cell a' b') addr. +Proof. + induction a; crush. + - destruct b; crush; destruct b'; crush; destruct a'; crush. + - destruct b; crush; destruct b'; crush; destruct a'; crush; + destruct addr; crush; apply IHa. +Qed. + +Lemma array_get_combine : + forall a b a' b' addr, + arr_length a = arr_length b -> + arr_length a = arr_length b' -> + arr_length a = arr_length a' -> + array_get_error addr a = array_get_error addr a' -> + array_get_error addr b = array_get_error addr b' -> + array_get_error addr (combine merge_cell a b) + = array_get_error addr (combine merge_cell a' b'). +Proof. + intros; unfold array_get_error, combine in *; destruct a; destruct b; + destruct a'; destruct b'; simplify; apply array_get_combine'; crush. +Qed. + +Lemma match_empty_size_exists_Some : + forall m rab s v, + match_empty_size m rab -> + rab ! s = Some v -> + exists v', (empty_stack m) ! s = Some v' /\ arr_length v = arr_length v'. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Lemma match_empty_size_exists_None : + forall m rab s, + match_empty_size m rab -> + rab ! s = None -> + (empty_stack m) ! s = None. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Lemma match_empty_size_exists_None' : + forall m rab s, + match_empty_size m rab -> + (empty_stack m) ! s = None -> + rab ! s = None. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Lemma match_empty_size_exists_Some' : + forall m rab s v, + match_empty_size m rab -> + (empty_stack m) ! s = Some v -> + exists v', rab ! s = Some v' /\ arr_length v = arr_length v'. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Lemma match_arrs_Some : + forall ra ra' s v, + match_arrs ra ra' -> + ra ! s = Some v -> + exists v', ra' ! s = Some v' + /\ (forall addr, array_get_error addr v = array_get_error addr v') + /\ arr_length v = arr_length v'. +Proof. inversion 1; intros; repeat masrp_tac. intros. rewrite H5. auto. Qed. + +Lemma match_arrs_None : + forall ra ra' s, + match_arrs ra ra' -> + ra ! s = None -> + ra' ! s = None. +Proof. inversion 1; intros; repeat masrp_tac. Qed. + +Ltac learn_next := + match goal with + | H: match_empty_size _ ?rab, H2: ?rab ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H2 as H3; eapply match_empty_size_exists_Some in H3; + eauto; inv_exists; simplify + | H: match_empty_size _ ?rab, H2: ?rab ! _ = None |- _ => + let H3 := fresh "H" in + learn H2 as H3; eapply match_empty_size_exists_None in H3; eauto + end. + +Ltac learn_empty := + match goal with + | H: match_empty_size _ _, H2: (empty_stack _) ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H as H3; eapply match_empty_size_exists_Some' in H3; + [| eassumption]; inv_exists; simplify + | H: match_arrs ?ar _, H2: ?ar ! _ = Some _ |- _ => + let H3 := fresh "H" in + learn H as H3; eapply match_arrs_Some in H3; + [| eassumption]; inv_exists; simplify + | H: match_empty_size _ _, H2: (empty_stack _) ! _ = None |- _ => + let H3 := fresh "H" in + learn H as H3; eapply match_empty_size_exists_None' in H3; + [| eassumption]; simplify + end. + +Lemma empty_set_none : + forall m ran rab s i v s0, + match_empty_size m ran -> + match_empty_size m rab -> + (arr_assocmap_set s i v ran) ! s0 = None -> + (arr_assocmap_set s i v rab) ! s0 = None. +Proof. + unfold arr_assocmap_set; inversion 1; subst; simplify. + destruct (Pos.eq_dec s s0); subst. + destruct ran ! s0 eqn:?. + rewrite AssocMap.gss in H4. inv H4. + learn_next. learn_empty. rewrite H6; auto. + destruct ran ! s eqn:?. rewrite AssocMap.gso in H4. + learn_next. learn_empty. rewrite H6. rewrite AssocMap.gso. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. clear Heqo. clear H5. clear H6. + learn_next. repeat learn_empty. auto. auto. auto. + pose proof Heqo. learn_next; repeat learn_empty. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + pose proof H4. learn_next; repeat learn_empty. + rewrite H7. auto. +Qed. + +Ltac clear_learnt := + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + +Lemma match_arrs_size_assoc : + forall a b, + match_arrs_size a b -> + match_arrs_size b a. +Proof. inversion 1; constructor; crush; split; apply H2. Qed. +#[local] Hint Resolve match_arrs_size_assoc : mgen. + +Lemma match_arrs_merge_set2 : + forall rab rab' ran ran' s m i v, + match_empty_size m rab -> + match_empty_size m ran -> + match_empty_size m rab' -> + match_empty_size m ran' -> + match_arrs rab rab' -> + match_arrs ran ran' -> + match_arrs (merge_arrs (arr_assocmap_set s i v ran) rab) + (merge_arrs (arr_assocmap_set s i v (empty_stack m)) + (merge_arrs ran' rab')). +Proof. + simplify. + constructor; intros. + unfold arr_assocmap_set in *. destruct (Pos.eq_dec s s0); subst. + destruct ran ! s0 eqn:?. unfold merge_arrs in *. rewrite AssocMap.gcombine in *; auto. + learn_next. repeat learn_empty. + econstructor. simplify. rewrite H6. rewrite AssocMap.gcombine by auto. + rewrite AssocMap.gss. simplify. setoid_rewrite H9. setoid_rewrite H7. simplify. + intros. rewrite AssocMap.gss in H5. setoid_rewrite H13 in H5. + simplify. pose proof (empty_arr m s0). inv H5. inv_exists. setoid_rewrite H5 in H6. inv H6. + unfold arr_repeat in H8. simplify. rewrite list_repeat_len in H8. rewrite list_repeat_len in H10. + rewrite match_get_arrs. crush. rewrite combine_none2. rewrite combine_array_set; try congruence. + apply array_get_error_each. rewrite combine_length; try congruence. + rewrite combine_length; try congruence. + apply array_get_combine; crush. + rewrite <- array_set_len. rewrite combine_length; crush. crush. crush. + setoid_rewrite H21 in H6; discriminate. rewrite combine_length. + rewrite <- array_set_len; crush. + unfold merge_arr in *. rewrite AssocMap.gss in H5. setoid_rewrite H13 in H5. + inv H5. rewrite combine_length. rewrite <- array_set_len; crush. + rewrite <- array_set_len; crush. + rewrite combine_length; crush. + destruct rab ! s0 eqn:?. learn_next. repeat learn_empty. + rewrite H11 in Heqo. discriminate. + unfold merge_arrs in H5. rewrite AssocMap.gcombine in H5; auto. rewrite Heqo in H5. + rewrite Heqo0 in H5. crush. + + destruct ran ! s eqn:?. + learn_next. repeat learn_empty. rewrite H6. + unfold merge_arrs in *. rewrite AssocMap.gcombine in H5; auto. + rewrite AssocMap.gcombine; auto. rewrite AssocMap.gso in H5; auto. + rewrite AssocMap.gso; auto. + destruct ran ! s0 eqn:?. + learn_next. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + repeat learn_empty. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + rewrite AssocMap.gcombine; auto. setoid_rewrite Heqo0 in H5. setoid_rewrite H29 in H5. + simplify. + pose proof (empty_arr m s0). inv H5. inv_exists. rewrite H5 in H21. inv H21. + econstructor. simplify. setoid_rewrite H23. rewrite H25. setoid_rewrite H5. + simplify. intros. rewrite combine_none2. apply array_get_combine; solve [crush]. + crush. rewrite list_combine_length. rewrite (arr_wf x5). rewrite (arr_wf x6). + rewrite <- H26. rewrite <- H28. rewrite list_repeat_len. lia. rewrite list_combine_length. + rewrite (arr_wf a). rewrite (arr_wf x7). rewrite combine_length. rewrite arr_repeat_length. + rewrite H24. rewrite <- H32. rewrite list_repeat_len. lia. + rewrite arr_repeat_length. rewrite combine_length. rewrite <- H26. symmetry. apply list_repeat_len. + congruence. + rewrite H37 in H21; discriminate. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. eapply match_empty_size_exists_None in H0; eauto. + clear H6. repeat learn_empty. setoid_rewrite Heqo0 in H5. + setoid_rewrite H29 in H5. discriminate. + pose proof (match_arrs_merge ran ran' rab rab'). + eapply match_empty_size_match in H; [|apply H0]. + apply H6 in H; auto. inv H. apply H7 in H5. inv_exists. simplify. + learn_next. rewrite H9. econstructor. simplify. + apply merge_arr_empty''; mgen_crush. + auto. auto. + unfold merge_arrs in *. rewrite AssocMap.gcombine in H5; auto. rewrite AssocMap.gcombine; auto. + destruct (arr_assocmap_set s i v ran) ! s0 eqn:?; destruct rab ! s0 eqn:?; crush. + learn_next. repeat learn_empty. + repeat match goal with + | H: Learnt _ |- _ => clear H + end. + erewrite empty_set_none. rewrite AssocMap.gcombine; auto. + simplify. rewrite H7. rewrite H8. auto. apply H0. mgen_crush. auto. +Qed. + +Definition all_match_empty_size m ar := + match_empty_size m (assoc_nonblocking ar) /\ match_empty_size m (assoc_blocking ar). +#[local] Hint Unfold all_match_empty_size : mgen. + +Definition match_module_to_ram m ram := + ram_size ram = mod_stk_len m /\ ram_mem ram = mod_stk m. +#[local] Hint Unfold match_module_to_ram : mgen. + +Lemma zip_range_forall_le : + forall A (l: list A) n, Forall (Pos.le n) (map snd (zip_range n l)). +Proof. + induction l; crush; constructor; [lia|]. + assert (forall n x, n+1 <= x -> n <= x) by lia. + apply Forall_forall. intros. apply H. generalize dependent x. + apply Forall_forall. apply IHl. +Qed. + +Lemma transf_code_fold_correct: + forall l m state ram d' c' n, + fold_right (transf_maps state ram) (mod_datapath m, mod_controllogic m) l = (d', c') -> + Forall (fun x => x < n) (map fst l) -> + Forall (Pos.le n) (map snd l) -> + list_norepet (map fst l) -> + list_norepet (map snd l) -> + (forall p i c_s rs1 ar1 rs2 ar2 trs1 tar1 d_s, + i < n -> + all_match_empty_size m ar1 -> + all_match_empty_size m tar1 -> + match_module_to_ram m ram -> + (mod_datapath m)!i = Some d_s -> + (mod_controllogic m)!i = Some c_s -> + match_reg_assocs p rs1 trs1 -> + match_arr_assocs ar1 tar1 -> + max_reg_module m < p -> + exec_all d_s c_s rs1 ar1 rs2 ar2 -> + exists d_s' c_s' trs2 tar2, + d'!i = Some d_s' /\ c'!i = Some c_s' + /\ exec_all_ram ram d_s' c_s' trs1 tar1 trs2 tar2 + /\ match_reg_assocs p (merge_reg_assocs rs2) (merge_reg_assocs trs2) + /\ match_arr_assocs (merge_arr_assocs (ram_mem ram) (ram_size ram) ar2) + (merge_arr_assocs (ram_mem ram) (ram_size ram) tar2)). +Proof. + induction l as [| a l IHl]; simplify. + - match goal with + | H: (_, _) = (_, _) |- _ => inv H + end; + unfold exec_all in *; repeat inv_exists; simplify. + exploit match_states_same; + try match goal with + | H: stmnt_runp _ _ _ ?c _ _, H2: (mod_controllogic _) ! _ = Some ?c |- _ => apply H + end; eauto; mgen_crush; + try match goal with + | H: (mod_controllogic _) ! _ = Some ?c |- _ => + apply max_reg_stmnt_le_stmnt_tree in H; unfold max_reg_module in *; lia + end; intros; + exploit match_states_same; + try match goal with + | H: stmnt_runp _ _ _ ?c _ _, H2: (mod_datapath _) ! _ = Some ?c |- _ => apply H + end; eauto; mgen_crush; + try match goal with + | H: (mod_datapath _) ! _ = Some ?c |- _ => + apply max_reg_stmnt_le_stmnt_tree in H; unfold max_reg_module in *; lia + end; intros; + repeat match goal with + | |- exists _, _ => eexists + end; simplify; eauto; + unfold exec_all_ram; + repeat match goal with + | |- exists _, _ => eexists + end; simplify; eauto. + constructor. admit. + Abort. + +Lemma empty_stack_transf : forall m, empty_stack (transf_module m) = empty_stack m. +Proof. unfold empty_stack, transf_module; intros; repeat destruct_match; crush. Qed. + +Definition alt_unchanged (d : AssocMap.t stmnt) (c: AssocMap.t stmnt) d' c' i := + d ! i = d' ! i /\ c ! i = c' ! i. + +Definition alt_store ram d (c : AssocMap.t stmnt) d' c' i := + exists e1 e2, + d' ! i = Some (Vseq (Vnonblock (Vvar (ram_u_en ram)) (Vunop Vnot (Vvar (ram_u_en ram)))) + (Vseq (Vnonblock (Vvar (ram_wr_en ram)) (Vlit (ZToValue 1))) + (Vseq (Vnonblock (Vvar (ram_d_in ram)) e2) + (Vnonblock (Vvar (ram_addr ram)) e1)))) + /\ c' ! i = c ! i + /\ d ! i = Some (Vnonblock (Vvari (ram_mem ram) e1) e2). + +Definition alt_load state ram d (c : AssocMap.t stmnt) d' c' i n := + exists ns e1 e2, + d' ! i = Some (Vseq (Vnonblock (Vvar (ram_u_en ram)) (Vunop Vnot (Vvar (ram_u_en ram)))) + (Vseq (Vnonblock (Vvar (ram_wr_en ram)) (Vlit (ZToValue 0))) + (Vnonblock (Vvar (ram_addr ram)) e2))) + /\ d' ! n = Some (Vnonblock (Vvar e1) (Vvar (ram_d_out ram))) + /\ c' ! i = Some (Vnonblock (Vvar state) (Vlit (posToValue n))) + /\ c' ! n = Some (Vnonblock (Vvar state) ns) + /\ c ! i = Some (Vnonblock (Vvar state) ns) + /\ d ! i = Some (Vnonblock (Vvar e1) (Vvari (ram_mem ram) e2)) + /\ e1 < state + /\ max_reg_expr e2 < state + /\ max_reg_expr ns < state + /\ (Z.pos n <= Int.max_unsigned)%Z. + +Definition alternatives state ram d c d' c' i n := + alt_unchanged d c d' c' i + \/ alt_store ram d c d' c' i + \/ alt_load state ram d c d' c' i n. + +Lemma transf_alternatives : + forall ram n d c state i d' c', + transf_maps state ram (i, n) (d, c) = (d', c') -> + i <> n -> + alternatives state ram d c d' c' i n. +Proof. + intros. unfold transf_maps in *. + repeat destruct_match; match goal with + | H: (_, _) = (_, _) |- _ => inv H + end; try solve [left; econstructor; crush]; simplify; + repeat match goal with + | H: (_ =? _) = true |- _ => apply Peqb_true_eq in H; subst + end; unfold alternatives; right; + match goal with + | H: context[Vnonblock (Vvari _ _) _] |- _ => left + | _ => right + end; repeat econstructor; simplify; + repeat match goal with + | |- ( _ # ?s <- _ ) ! ?s = Some _ => apply AssocMap.gss + | |- ( _ # ?s <- _ ) ! ?r = Some _ => rewrite AssocMap.gso by lia + | |- _ = None => apply max_index_2; lia + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end; auto. +Qed. + +Lemma transf_alternatives_neq : + forall state ram a n' n d'' c'' d' c' i d c, + transf_maps state ram (a, n) (d, c) = (d', c') -> + a <> i -> n' <> n -> i <> n' -> a <> n' -> + i <> n -> a <> n -> + alternatives state ram d'' c'' d c i n' -> + alternatives state ram d'' c'' d' c' i n'. +Proof. + unfold alternatives, alt_unchanged, alt_store, alt_load, transf_maps; intros; + repeat match goal with H: _ \/ _ |- _ => inv H | H: _ /\ _ |- _ => destruct H end; + [left | right; left | right; right]; + repeat inv_exists; simplify; + repeat destruct_match; + repeat match goal with + | H: (_, _) = (_, _) |- _ => inv H + | |- exists _, _ => econstructor + end; repeat split; repeat rewrite AssocMap.gso by lia; eauto; lia. +Qed. + +Lemma transf_alternatives_neq2 : + forall state ram a n' n d'' c'' d' c' i d c, + transf_maps state ram (a, n) (d', c') = (d, c) -> + a <> i -> n' <> n -> i <> n' -> a <> n' -> i <> n -> + alternatives state ram d c d'' c'' i n' -> + alternatives state ram d' c' d'' c'' i n'. +Proof. + unfold alternatives, alt_unchanged, alt_store, alt_load, transf_maps; intros; + repeat match goal with H: _ \/ _ |- _ => inv H | H: _ /\ _ |- _ => destruct H end; + [left | right; left | right; right]; + repeat inv_exists; simplify; + repeat destruct_match; + repeat match goal with + | H: (_, _) = (_, _) |- _ => inv H + | |- exists _, _ => econstructor + end; repeat split; repeat rewrite AssocMap.gso in * by lia; eauto; lia. +Qed. + +Lemma transf_alt_unchanged_neq : + forall i c'' d'' d c d' c', + alt_unchanged d' c' d'' c'' i -> + d' ! i = d ! i -> + c' ! i = c ! i -> + alt_unchanged d c d'' c'' i. +Proof. unfold alt_unchanged; simplify; congruence. Qed. + +Lemma transf_maps_neq : + forall state ram d c i n d' c' i' n' va vb vc vd, + transf_maps state ram (i, n) (d, c) = (d', c') -> + d ! i' = va -> d ! n' = vb -> + c ! i' = vc -> c ! n' = vd -> + i <> i' -> i <> n' -> n <> i' -> n <> n' -> + d' ! i' = va /\ d' ! n' = vb /\ c' ! i' = vc /\ c' ! n' = vd. +Proof. + unfold transf_maps; intros; repeat destruct_match; simplify; + repeat match goal with + | H: (_, _) = (_, _) |- _ => inv H + | H: (_ =? _) = true |- _ => apply Peqb_true_eq in H; subst + | |- context[( _ # ?s <- _ ) ! ?r] => rewrite AssocMap.gso by lia + end; crush. +Qed. + +Lemma alternatives_different_map : + forall l state ram d c d'' c'' d' c' n i p, + i <= p -> n > p -> + Forall (Pos.lt p) (map snd l) -> + Forall (Pos.ge p) (map fst l) -> + ~ In n (map snd l) -> + ~ In i (map fst l) -> + fold_right (transf_maps state ram) (d, c) l = (d', c') -> + alternatives state ram d' c' d'' c'' i n -> + alternatives state ram d c d'' c'' i n. +Proof. + Opaque transf_maps. + induction l; intros. + - crush. + - simplify; repeat match goal with + | H: context[_ :: _] |- _ => inv H + | H: transf_maps _ _ _ (fold_right (transf_maps ?s ?r) (?d, ?c) ?l) = (_, _) |- _ => + let X := fresh "X" in + remember (fold_right (transf_maps s r) (d, c) l) as X + | X: _ * _ |- _ => destruct X + | H: (_, _) = _ |- _ => symmetry in H + end; simplify. + remember p0 as i'. symmetry in Heqi'. subst. + remember p1 as n'. symmetry in Heqn'. subst. + assert (i <> n') by lia. + assert (n <> i') by lia. + assert (n <> n') by lia. + assert (i <> i') by lia. + eapply IHl; eauto. + eapply transf_alternatives_neq2; eauto; try lia. +Qed. + +Lemma transf_fold_alternatives : + forall l state ram d c d' c' i n d_s c_s, + fold_right (transf_maps state ram) (d, c) l = (d', c') -> + Pos.max (max_pc c) (max_pc d) < n -> + Forall (Pos.lt (Pos.max (max_pc c) (max_pc d))) (map snd l) -> + Forall (Pos.ge (Pos.max (max_pc c) (max_pc d))) (map fst l) -> + list_norepet (map fst l) -> + list_norepet (map snd l) -> + In (i, n) l -> + d ! i = Some d_s -> + c ! i = Some c_s -> + alternatives state ram d c d' c' i n. +Proof. + Opaque transf_maps. + induction l; crush; []. + repeat match goal with + | H: context[_ :: _] |- _ => inv H + | H: transf_maps _ _ _ (fold_right (transf_maps ?s ?r) (?d, ?c) ?l) = (_, _) |- _ => + let X := fresh "X" in + remember (fold_right (transf_maps s r) (d, c) l) as X + | X: _ * _ |- _ => destruct X + | H: (_, _) = _ |- _ => symmetry in H + end. + inv H5. inv H1. simplify. + eapply alternatives_different_map; eauto. + simplify; lia. simplify; lia. apply transf_alternatives; auto. lia. + simplify. + assert (X: In i (map fst l)). { replace i with (fst (i, n)) by auto. apply in_map; auto. } + assert (X2: In n (map snd l)). { replace n with (snd (i, n)) by auto. apply in_map; auto. } + assert (X3: n <> p0). { destruct (Pos.eq_dec n p0); subst; crush. } + assert (X4: i <> p). { destruct (Pos.eq_dec i p); subst; crush. } + eapply transf_alternatives_neq; eauto; apply max_index in H7; lia. + Transparent transf_maps. +Qed. + +Lemma zip_range_inv : + forall A (l: list A) i n, + In i l -> + exists n', In (i, n') (zip_range n l) /\ n' >= n. +Proof. + induction l; crush. + inv H. econstructor. + split. left. eauto. lia. + eapply IHl in H0. inv H0. inv H. + econstructor. split. right. apply H0. lia. +Qed. + +Lemma zip_range_not_in_fst : + forall A (l: list A) a n, ~ In a l -> ~ In a (map fst (zip_range n l)). +Proof. unfold not; induction l; crush; inv H0; firstorder. Qed. + +Lemma zip_range_no_repet_fst : + forall A (l: list A) a, list_norepet l -> list_norepet (map fst (zip_range a l)). +Proof. + induction l; simplify; constructor; inv H; firstorder; + eapply zip_range_not_in_fst; auto. +Qed. + +Lemma transf_code_alternatives : + forall state ram d c d' c' i d_s c_s, + transf_code state ram d c = (d', c') -> + d ! i = Some d_s -> + c ! i = Some c_s -> + exists n, alternatives state ram d c d' c' i n. +Proof. + unfold transf_code; + intros. + pose proof H0 as X. + apply PTree.elements_correct in X. assert (In i (map fst (PTree.elements d))). + { replace i with (fst (i, d_s)) by auto. apply in_map. auto. } + exploit zip_range_inv. apply H2. intros. inv H3. simplify. + instantiate (1 := (Pos.max (max_pc c) (max_pc d) + 1)) in H3. + exists x. + eapply transf_fold_alternatives; + eauto using forall_gt, PTree.elements_keys_norepet, max_index. lia. + assert (Forall (Pos.le (Pos.max (max_pc c) (max_pc d) + 1)) + (map snd (zip_range (Pos.max (max_pc c) (max_pc d) + 1) + (map fst (PTree.elements d))))) by apply zip_range_forall_le. + apply Forall_forall; intros. eapply Forall_forall in H4; eauto. lia. + rewrite zip_range_fst_idem. apply Forall_forall; intros. + apply AssocMapExt.elements_iff in H4. inv H4. apply max_index in H6. lia. + eapply zip_range_no_repet_fst. apply PTree.elements_keys_norepet. + eapply zip_range_snd_no_repet. +Qed. + +Lemma max_reg_stmnt_not_modified : + forall s f rs ar rs' ar', + stmnt_runp f rs ar s rs' ar' -> + forall r, + max_reg_stmnt s < r -> + (assoc_blocking rs) ! r = (assoc_blocking rs') ! r. +Proof. + induction 1; crush; + try solve [repeat destruct_match; apply IHstmnt_runp; try lia; auto]. + assert (X: (assoc_blocking asr1) ! r = (assoc_blocking asr2) ! r) by (apply IHstmnt_runp2; lia). + assert (X2: (assoc_blocking asr0) ! r = (assoc_blocking asr1) ! r) by (apply IHstmnt_runp1; lia). + congruence. + inv H. simplify. rewrite AssocMap.gso by lia; auto. +Qed. + +Lemma max_reg_stmnt_not_modified_nb : + forall s f rs ar rs' ar', + stmnt_runp f rs ar s rs' ar' -> + forall r, + max_reg_stmnt s < r -> + (assoc_nonblocking rs) ! r = (assoc_nonblocking rs') ! r. +Proof. + induction 1; crush; + try solve [repeat destruct_match; apply IHstmnt_runp; try lia; auto]. + assert (X: (assoc_nonblocking asr1) ! r = (assoc_nonblocking asr2) ! r) by (apply IHstmnt_runp2; lia). + assert (X2: (assoc_nonblocking asr0) ! r = (assoc_nonblocking asr1) ! r) by (apply IHstmnt_runp1; lia). + congruence. + inv H. simplify. rewrite AssocMap.gso by lia; auto. +Qed. + +Lemma int_eq_not_changed : + forall ar ar' r r2 b, + Int.eq (ar # r) (ar # r2) = b -> + ar ! r = ar' ! r -> + ar ! r2 = ar' ! r2 -> + Int.eq (ar' # r) (ar' # r2) = b. +Proof. + unfold find_assocmap, AssocMapExt.get_default. intros. + rewrite <- H0. rewrite <- H1. auto. +Qed. + +Lemma merge_find_assocmap : + forall ran rab x, + ran ! x = None -> + (merge_regs ran rab) # x = rab # x. +Proof. + unfold merge_regs, find_assocmap, AssocMapExt.get_default. + intros. destruct (rab ! x) eqn:?. + erewrite AssocMapExt.merge_correct_2; eauto. + erewrite AssocMapExt.merge_correct_3; eauto. +Qed. + +Lemma max_reg_module_controllogic_gt : + forall m i v p, + (mod_controllogic m) ! i = Some v -> + max_reg_module m < p -> + max_reg_stmnt v < p. +Proof. + intros. unfold max_reg_module in *. + apply max_reg_stmnt_le_stmnt_tree in H. lia. +Qed. + +Lemma max_reg_module_datapath_gt : + forall m i v p, + (mod_datapath m) ! i = Some v -> + max_reg_module m < p -> + max_reg_stmnt v < p. +Proof. + intros. unfold max_reg_module in *. + apply max_reg_stmnt_le_stmnt_tree in H. lia. +Qed. + +Lemma merge_arr_empty2 : + forall m ar ar', + match_empty_size m ar' -> + match_arrs ar ar' -> + match_arrs ar (merge_arrs (empty_stack m) ar'). +Proof. + inversion 1; subst; inversion 1; subst. + econstructor; intros. apply H4 in H6; inv_exists. simplify. + eapply merge_arr_empty'' in H6; eauto. + apply H5 in H6. pose proof H6. apply H2 in H7. + unfold merge_arrs. rewrite AssocMap.gcombine; auto. setoid_rewrite H6. + setoid_rewrite H7. auto. +Qed. +#[local] Hint Resolve merge_arr_empty2 : mgen. + +Lemma find_assocmap_gso : + forall ar x y v, x <> y -> (ar # y <- v) # x = ar # x. +Proof. + unfold find_assocmap, AssocMapExt.get_default; intros; rewrite AssocMap.gso; auto. +Qed. + +Lemma find_assocmap_gss : + forall ar x v, (ar # x <- v) # x = v. +Proof. + unfold find_assocmap, AssocMapExt.get_default; intros; rewrite AssocMap.gss; auto. +Qed. + +Lemma expr_lt_max_module_datapath : + forall m x, + max_reg_stmnt x <= max_stmnt_tree (mod_datapath m) -> + max_reg_stmnt x < max_reg_module m + 1. +Proof. unfold max_reg_module. lia. Qed. + +Lemma expr_lt_max_module_controllogic : + forall m x, + max_reg_stmnt x <= max_stmnt_tree (mod_controllogic m) -> + max_reg_stmnt x < max_reg_module m + 1. +Proof. unfold max_reg_module. lia. Qed. + +Lemma int_eq_not : + forall x y, Int.eq x y = true -> Int.eq x (Int.not y) = false. +Proof. + intros. pose proof (Int.eq_spec x y). rewrite H in H0. subst. + apply int_eq_not_false. +Qed. + +Lemma match_assocmaps_gt2 : + forall (p s : positive) (ra ra' : assocmap) (v : value), + p <= s -> match_assocmaps p ra ra' -> match_assocmaps p (ra # s <- v) ra'. +Proof. + intros; inv H0; constructor; intros. + destruct (Pos.eq_dec r s); subst. lia. + rewrite AssocMap.gso by lia. auto. +Qed. + +Lemma match_assocmaps_switch_neq : + forall p ra ra' r v' s v, + match_assocmaps p ra ((ra' # r <- v') # s <- v) -> + s <> r -> + match_assocmaps p ra ((ra' # s <- v) # r <- v'). +Proof. + inversion 1; constructor; simplify. + destruct (Pos.eq_dec r0 s); destruct (Pos.eq_dec r0 r); subst; try lia. + rewrite AssocMap.gso by lia. specialize (H0 s). apply H0 in H5. + rewrite AssocMap.gss in H5. rewrite AssocMap.gss. auto. + rewrite AssocMap.gss. apply H0 in H5. rewrite AssocMap.gso in H5 by lia. + rewrite AssocMap.gss in H5. auto. + repeat rewrite AssocMap.gso by lia. + apply H0 in H5. repeat rewrite AssocMap.gso in H5 by lia. + auto. +Qed. + +Lemma match_assocmaps_duplicate : + forall p ra ra' v' s v, + match_assocmaps p ra (ra' # s <- v) -> + match_assocmaps p ra ((ra' # s <- v') # s <- v). +Proof. + inversion 1; constructor; simplify. + destruct (Pos.eq_dec r s); subst. + rewrite AssocMap.gss. apply H0 in H4. rewrite AssocMap.gss in H4. auto. + repeat rewrite AssocMap.gso by lia. apply H0 in H4. rewrite AssocMap.gso in H4 by lia. + auto. +Qed. + +Lemma translation_correct : + forall m asr nasa1 basa1 nasr1 basr1 basr2 nasr2 nasa2 basa2 nasr3 basr3 + nasa3 basa3 asr'0 asa'0 res' st tge pstval sf asa ctrl data f, + asr ! (mod_reset m) = Some (ZToValue 0) -> + asr ! (mod_finish m) = Some (ZToValue 0) -> + asr ! (mod_st m) = Some (posToValue st) -> + (mod_controllogic m) ! st = Some ctrl -> + (mod_datapath m) ! st = Some data -> + stmnt_runp f {| assoc_blocking := asr; assoc_nonblocking := empty_assocmap |} + {| assoc_blocking := asa; assoc_nonblocking := empty_stack m |} ctrl + {| assoc_blocking := basr1; assoc_nonblocking := nasr1 |} + {| assoc_blocking := basa1; assoc_nonblocking := nasa1 |} -> + basr1 ! (mod_st m) = Some (posToValue st) -> + stmnt_runp f {| assoc_blocking := basr1; assoc_nonblocking := nasr1 |} + {| assoc_blocking := basa1; assoc_nonblocking := nasa1 |} data + {| assoc_blocking := basr2; assoc_nonblocking := nasr2 |} + {| assoc_blocking := basa2; assoc_nonblocking := nasa2 |} -> + exec_ram {| assoc_blocking := merge_regs nasr2 basr2; assoc_nonblocking := empty_assocmap |} + {| assoc_blocking := merge_arrs nasa2 basa2; assoc_nonblocking := empty_stack m |} None + {| assoc_blocking := basr3; assoc_nonblocking := nasr3 |} + {| assoc_blocking := basa3; assoc_nonblocking := nasa3 |} -> + (merge_regs nasr3 basr3) ! (mod_st m) = Some (posToValue pstval) -> + (Z.pos pstval <= 4294967295)%Z -> + match_states (State sf m st asr asa) (State res' (transf_module m) st asr'0 asa'0) -> + mod_ram m = None -> + exists R2 : state, + Smallstep.plus step tge (State res' (transf_module m) st asr'0 asa'0) Events.E0 R2 /\ + match_states (State sf m pstval (merge_regs nasr3 basr3) (merge_arrs nasa3 basa3)) R2. +Proof. + Ltac tac0 := + repeat match goal with + | H: match_reg_assocs _ _ _ |- _ => inv H + | H: match_arr_assocs _ _ |- _ => inv H + end. + intros. + repeat match goal with + | H: match_states _ _ |- _ => inv H + | H: context[exec_ram] |- _ => inv H + | H: mod_ram _ = None |- _ => + let H2 := fresh "TRANSF" in learn H as H2; apply transf_module_code in H2 + end. + eapply transf_code_alternatives in TRANSF; eauto; simplify; unfold alternatives in *. + repeat match goal with H: _ \/ _ |- _ => inv H end. + - unfold alt_unchanged in *; simplify. + assert (MATCH_SIZE1: match_empty_size m nasa1 /\ match_empty_size m basa1). + { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; eauto with mgen. } + assert (MATCH_SIZE2: match_empty_size m nasa2 /\ match_empty_size m basa2). + { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. + assert (MATCH_ARR3: match_arrs_size nasa2 basa2) by eauto with mgen. + exploit match_states_same; try solve [apply H4 | eapply max_stmnt_lt_module; eauto + | econstructor; eauto with mgen]; + intros; repeat inv_exists; simplify; tac0. + exploit match_states_same; try solve [eapply H6 | eapply max_stmnt_lt_module; eauto + | econstructor; eauto with mgen]; + intros; repeat inv_exists; simplify; tac0. + assert (MATCH_SIZE1': match_empty_size m ran'0 /\ match_empty_size m rab'0). + { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; eauto with mgen. + rewrite empty_stack_transf; eauto with mgen. } + assert (MATCH_SIZE2': match_empty_size m ran'2 /\ match_empty_size m rab'2). + { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. + assert (MATCH_ARR3': match_arrs_size ran'2 rab'2) by eauto with mgen. + do 2 econstructor. apply Smallstep.plus_one. econstructor. + eauto with mgen. eauto with mgen. eauto with mgen. + rewrite <- H12. eassumption. rewrite <- H7. eassumption. + eauto. eauto with mgen. eauto. + rewrite empty_stack_transf. unfold transf_module; repeat destruct_match; try discriminate. + econstructor. simplify. + unfold disable_ram in *. unfold transf_module in DISABLE_RAM. + repeat destruct_match; try discriminate; []. simplify. + pose proof H17 as R1. apply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in R1. + pose proof H17 as R2. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 2) in R2. + pose proof H18 as R3. eapply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in R3. + pose proof H18 as R4. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 2) in R4. + pose proof H17 as R1'. apply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in R1'. + pose proof H17 as R2'. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 6) in R2'. + pose proof H18 as R3'. eapply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in R3'. + pose proof H18 as R4'. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 6) in R4'. + simplify. + pose proof DISABLE_RAM as DISABLE_RAM1. + eapply int_eq_not_changed with (ar' := rab') in DISABLE_RAM; try congruence. + eapply int_eq_not_changed with (ar' := rab'1) in DISABLE_RAM; try congruence. + rewrite AssocMap.gempty in R2. rewrite <- R2 in R4. + rewrite AssocMap.gempty in R2'. rewrite <- R2' in R4'. + eapply int_eq_not_changed in DISABLE_RAM; auto. repeat (rewrite merge_find_assocmap; try congruence). + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + auto. auto. eauto with mgen. auto. + econstructor; mgen_crush. apply merge_arr_empty; mgen_crush. + unfold disable_ram in *. unfold transf_module in DISABLE_RAM. + repeat destruct_match; crush. unfold transf_module in Heqo; repeat destruct_match; crush. + pose proof H17 as R1. apply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in R1. + pose proof H17 as R2. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 2) in R2. + pose proof H18 as R3. eapply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in R3. + pose proof H18 as R4. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 2) in R4. + pose proof H17 as R1'. apply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in R1'. + pose proof H17 as R2'. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 6) in R2'. + pose proof H18 as R3'. eapply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in R3'. + pose proof H18 as R4'. eapply max_reg_stmnt_not_modified_nb with (r := max_reg_module m + 6) in R4'. + simplify. + pose proof DISABLE_RAM as DISABLE_RAM1. + eapply int_eq_not_changed with (ar' := rab') in DISABLE_RAM; try congruence. + eapply int_eq_not_changed with (ar' := rab'1) in DISABLE_RAM; try congruence. + rewrite AssocMap.gempty in R2. rewrite <- R2 in R4. + rewrite AssocMap.gempty in R2'. rewrite <- R2' in R4'. + eapply int_eq_not_changed in DISABLE_RAM; auto. repeat (rewrite merge_find_assocmap; try congruence). + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_datapath_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + eapply max_reg_module_controllogic_gt; eauto; remember (max_reg_module m); lia. + - unfold alt_store in *; simplify. inv H6. inv H19. inv H19. simplify. + exploit match_states_same; try solve [eapply H4 | eapply max_stmnt_lt_module; eauto + | econstructor; eauto with mgen]; + intros; repeat inv_exists; simplify; tac0. + do 2 econstructor. apply Smallstep.plus_one. econstructor. solve [eauto with mgen]. solve [eauto with mgen]. + solve [eauto with mgen]. + rewrite H7. eassumption. eassumption. eassumption. solve [eauto with mgen]. + econstructor. econstructor. econstructor. econstructor. econstructor. + auto. auto. auto. econstructor. econstructor. econstructor. + econstructor. econstructor. econstructor. econstructor. + eapply expr_runp_matches2. eassumption. 2: { eassumption. } + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + apply expr_lt_max_module_datapath in X; simplify; remember (max_reg_module m); lia. + auto. + econstructor. econstructor. eapply expr_runp_matches2; eauto. + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + apply expr_lt_max_module_datapath in X. + remember (max_reg_module m); simplify; lia. + + rewrite empty_stack_transf. + unfold transf_module; repeat destruct_match; try discriminate; simplify; []. + eapply exec_ram_Some_write. + 3: { + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite find_assocmap_gso by lia. + pose proof H12 as X. + eapply max_reg_stmnt_not_modified_nb with (r := (max_reg_module m + 2)) in X. + rewrite AssocMap.gempty in X. + apply merge_find_assocmap. auto. + apply max_reg_stmnt_le_stmnt_tree in H2. + apply expr_lt_max_module_controllogic in H2. lia. + } + 3: { + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + } + { unfold disable_ram in *. unfold transf_module in DISABLE_RAM; + repeat destruct_match; try discriminate. + simplify. + pose proof H12 as X2. + pose proof H12 as X4. + apply max_reg_stmnt_not_modified with (r := max_reg_module m + 2) in X2. + apply max_reg_stmnt_not_modified with (r := max_reg_module m + 6) in X4. + assert (forall ar ar' x, ar ! x = ar' ! x -> ar # x = ar' # x). + { intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H6. auto. } + apply H6 in X2. apply H6 in X4. simplify. rewrite <- X2. rewrite <- X4. + apply int_eq_not. auto. + apply max_reg_stmnt_le_stmnt_tree in H2. + apply expr_lt_max_module_controllogic in H2. simplify. remember (max_reg_module m). lia. + apply max_reg_stmnt_le_stmnt_tree in H2. + apply expr_lt_max_module_controllogic in H2. simplify. remember (max_reg_module m). lia. + } + 2: { + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + } + solve [auto]. + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + simplify. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + simplify. auto. + simplify. auto. + unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + unfold_merge. + assert (mod_st (transf_module m) < max_reg_module m + 1). + { unfold max_reg_module, transf_module; repeat destruct_match; try discriminate; simplify; lia. } + remember (max_reg_module m). + repeat rewrite AssocMap.gso by lia. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + replace (AssocMapExt.merge value ran' rab') with (merge_regs ran' rab'); + [|unfold merge_regs; auto]. + pose proof H19 as X. + eapply match_assocmaps_merge in X. + 2: { apply H21. } + inv X. rewrite <- H14. eassumption. unfold transf_module in H6; repeat destruct_match; + try discriminate; simplify. + lia. auto. + + econstructor. unfold merge_regs. repeat rewrite AssocMapExt.merge_add_assoc. + rewrite AssocMapExt.merge_base_1. + remember (max_reg_module m). + repeat (apply match_assocmaps_gt; [lia|]). + solve [eauto with mgen]. + + apply merge_arr_empty. apply match_empty_size_merge. + apply match_empty_assocmap_set. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + apply match_arrs_merge_set2; auto. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. + rewrite empty_stack_transf. mgen_crush. + eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. + rewrite empty_stack_transf. mgen_crush. + auto. + apply merge_arr_empty_match. + apply match_empty_size_merge. apply match_empty_assocmap_set. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + eapply match_arrs_size_stmnt_preserved in H4; mgen_crush. + apply match_empty_size_merge. apply match_empty_assocmap_set. + mgen_crush. eapply match_arrs_size_stmnt_preserved in H12; mgen_crush. + rewrite empty_stack_transf; mgen_crush. + unfold disable_ram. unfold transf_module; repeat destruct_match; try discriminate; simplify. + unfold merge_regs. unfold_merge. + remember (max_reg_module m). + rewrite find_assocmap_gss. + repeat rewrite find_assocmap_gso by lia. + rewrite find_assocmap_gss. apply Int.eq_true. + - unfold alt_load in *; simplify. inv H6. + 2: { match goal with H: context[location_is] |- _ => inv H end. } + match goal with H: context[location_is] |- _ => inv H end. + inv H30. simplify. inv H4. + 2: { match goal with H: context[location_is] |- _ => inv H end. } + inv H27. simplify. + do 2 econstructor. eapply Smallstep.plus_two. + econstructor. mgen_crush. mgen_crush. mgen_crush. eassumption. + eassumption. econstructor. simplify. econstructor. econstructor. + solve [eauto with mgen]. econstructor. econstructor. econstructor. + econstructor. econstructor. auto. auto. auto. + econstructor. econstructor. econstructor. + econstructor. econstructor. econstructor. eapply expr_runp_matches2; auto. eassumption. + 2: { eassumption. } + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + apply expr_lt_max_module_datapath in X. simplify. remember (max_reg_module m); lia. + auto. + + simplify. rewrite empty_stack_transf. unfold transf_module; repeat destruct_match; crush. + eapply exec_ram_Some_read; simplify. + 2: { + unfold merge_regs. unfold_merge. repeat rewrite find_assocmap_gso; try (remember (max_reg_module m); lia). + auto. unfold max_reg_module. lia. + } + 2: { + unfold merge_regs. unfold_merge. rewrite AssocMap.gso by lia. rewrite AssocMap.gso by lia. + rewrite AssocMap.gss. auto. + } + { unfold disable_ram, transf_module in DISABLE_RAM; + repeat destruct_match; try discriminate. simplify. apply int_eq_not. auto. } + { unfold merge_regs; unfold_merge. repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. } + { unfold merge_regs; unfold_merge. apply AssocMap.gss. } + { eapply match_arrs_read. eassumption. mgen_crush. } + { crush. } + { crush. } + { unfold merge_regs. unfold_merge. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + remember (max_reg_module m). repeat rewrite AssocMap.gso by lia. + apply AssocMap.gss. + } + { auto. } + + { econstructor. + { unfold merge_regs. unfold_merge. + assert (mod_reset m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + unfold transf_module; repeat destruct_match; try discriminate; simplify. + assert (mod_st m < mod_reset m). + { pose proof (mod_ordering_wf m); unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end; lia. + } + repeat rewrite AssocMap.gso by lia. + inv ASSOC. rewrite <- H19. auto. lia. + } + { unfold merge_regs. unfold_merge. + assert (mod_finish m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + unfold transf_module; repeat destruct_match; try discriminate; simplify. + assert (mod_st m < mod_finish m). + { pose proof (mod_ordering_wf m). unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end; lia. + } + repeat rewrite AssocMap.gso by lia. + inv ASSOC. rewrite <- H19. auto. lia. + } + { unfold merge_regs. unfold_merge. + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + unfold transf_module; repeat destruct_match; try discriminate; simplify. + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + } + { eassumption. } + { eassumption. } + { econstructor. econstructor. simplify. unfold merge_regs. unfold_merge. + eapply expr_runp_matches. eassumption. + assert (max_reg_expr x0 + 1 <= max_reg_module m + 1). + { pose proof H2 as X. apply max_reg_stmnt_le_stmnt_tree in X. + apply expr_lt_max_module_controllogic in X. simplify. remember (max_reg_module m). lia. } + assert (max_reg_expr x0 + 1 <= mod_st m). + { unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end. + pose proof H2 as X. apply max_reg_stmnt_le_stmnt_tree in X. + simplify. lia. + } + remember (max_reg_module m). + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_gt; [lia|]. + simplify. + eapply match_assocmaps_ge. eauto. lia. + mgen_crush. + } + { simplify. unfold merge_regs. unfold_merge. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + remember (max_reg_module m). + repeat rewrite AssocMap.gso by lia. apply AssocMap.gss. + } + { + simplify. econstructor. econstructor. econstructor. simplify. + unfold merge_regs; unfold_merge. + repeat rewrite find_assocmap_gso by lia. apply find_assocmap_gss. + } + { simplify. rewrite empty_stack_transf. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + econstructor. simplify. + unfold merge_regs; unfold_merge. simplify. + assert (r < max_reg_module m + 1). + { pose proof H3 as X. eapply max_reg_module_datapath_gt with (p := max_reg_module m + 1) in X. + unfold max_reg_stmnt in X. simplify. + lia. lia. } + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + repeat rewrite find_assocmap_gso by lia. rewrite find_assocmap_gss. + repeat rewrite find_assocmap_gso by lia. rewrite find_assocmap_gss. + apply Int.eq_true. + } + { crush. } + { crush. } + { unfold merge_regs. unfold_merge. simplify. + assert (r < mod_st m). + { unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end. + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + simplify. lia. + } + unfold merge_regs in H8. repeat rewrite AssocMapExt.merge_add_assoc in H8. + simplify. rewrite AssocMap.gso in H8 by lia. rewrite AssocMap.gss in H8. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + repeat rewrite AssocMap.gso by lia. + apply AssocMap.gss. } + { eassumption. } + } + { eauto. } + { econstructor. + { unfold merge_regs. unfold_merge. simplify. + apply match_assocmaps_gss. + unfold merge_regs in H8. repeat rewrite AssocMapExt.merge_add_assoc in H8. + rewrite AssocMap.gso in H8. rewrite AssocMap.gss in H8. inv H8. + remember (max_reg_module m). + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_switch_neq; [|lia]. + apply match_assocmaps_gt; [lia|]. + apply match_assocmaps_duplicate. + apply match_assocmaps_gss. auto. + assert (r < mod_st m). + { unfold module_ordering in *. simplify. + repeat match goal with + | H: context[_ <? _] |- _ => apply Pos.ltb_lt in H + end. + pose proof H3 as X. apply max_reg_stmnt_le_stmnt_tree in X. + simplify. lia. + } lia. + } + { + apply merge_arr_empty. mgen_crush. + apply merge_arr_empty2. mgen_crush. + apply merge_arr_empty2. mgen_crush. + apply merge_arr_empty2. mgen_crush. + mgen_crush. + } + { auto. } + { mgen_crush. } + { mgen_crush. } + { unfold disable_ram. + unfold transf_module; repeat destruct_match; try discriminate; simplify. + unfold merge_regs. unfold_merge. simplify. + assert (mod_st m < max_reg_module m + 1). + { unfold max_reg_module; lia. } + assert (r < max_reg_module m + 1). + { pose proof H3 as X. eapply max_reg_module_datapath_gt with (p := max_reg_module m + 1) in X. + unfold max_reg_stmnt in X. simplify. + lia. lia. } + repeat rewrite find_assocmap_gso by lia. + rewrite find_assocmap_gss. + repeat rewrite find_assocmap_gso by lia. + rewrite find_assocmap_gss. apply Int.eq_true. + } + } +Qed. + +Lemma exec_ram_resets_en : + forall rs ar rs' ar' r, + exec_ram rs ar (Some r) rs' ar' -> + assoc_nonblocking rs = empty_assocmap -> + Int.eq ((assoc_blocking (merge_reg_assocs rs')) # (ram_en r, 32)) + ((assoc_blocking (merge_reg_assocs rs')) # (ram_u_en r, 32)) = true. +Proof. + inversion 1; intros; subst; unfold merge_reg_assocs; simplify. + - rewrite H6. mgen_crush. + - unfold merge_regs. rewrite H12. unfold_merge. + unfold find_assocmap, AssocMapExt.get_default in *. + rewrite AssocMap.gss; auto. rewrite AssocMap.gso; auto. setoid_rewrite H4. apply Int.eq_true. + pose proof (ram_ordering r); lia. + - unfold merge_regs. rewrite H11. unfold_merge. + unfold find_assocmap, AssocMapExt.get_default in *. + rewrite AssocMap.gss; auto. + repeat rewrite AssocMap.gso by (pose proof (ram_ordering r); lia). + setoid_rewrite H3. apply Int.eq_true. +Qed. + +Lemma disable_ram_set_gso : + forall rs r i v, + disable_ram (Some r) rs -> + i <> (ram_en r) -> i <> (ram_u_en r) -> + disable_ram (Some r) (rs # i <- v). +Proof. + unfold disable_ram, find_assocmap, AssocMapExt.get_default; intros; + repeat rewrite AssocMap.gso by lia; auto. +Qed. +#[local] Hint Resolve disable_ram_set_gso : mgen. + +Lemma disable_ram_None rs : disable_ram None rs. +Proof. unfold disable_ram; auto. Qed. +#[local] Hint Resolve disable_ram_None : mgen. + +Lemma init_regs_equal_empty l st : + Forall (Pos.gt st) l -> (init_regs nil l) ! st = None. +Proof. induction l; simplify; apply AssocMap.gempty. Qed. + +Lemma forall_lt_num : + forall l p p', Forall (Pos.gt p) l -> p < p' -> Forall (Pos.gt p') l. +Proof. induction l; crush; inv H; constructor; [lia | eauto]. Qed. + +Section CORRECTNESS. + + Context (prog tprog: program). + Context (TRANSL: match_prog prog tprog). + + Let ge : genv := Genv.globalenv prog. + Let tge : genv := 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. + #[local] Hint Resolve symbols_preserved : mgen. + + Lemma function_ptr_translated: + forall (b: Values.block) (f: fundef), + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = tf. + Proof using TRANSL. + intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto. + intros (cu & tf & P & Q & R); exists tf; auto. + Qed. + #[local] Hint Resolve function_ptr_translated : mgen. + + Lemma functions_translated: + forall (v: Values.val) (f: fundef), + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = tf. + Proof using TRANSL. + intros. exploit (Genv.find_funct_match TRANSL); eauto. + intros (cu & tf & P & Q & R); exists tf; auto. + Qed. + #[local] Hint Resolve functions_translated : mgen. + + Lemma senv_preserved: + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). + Proof (Genv.senv_transf TRANSL). + #[local] Hint Resolve senv_preserved : mgen. + + Theorem transf_step_correct: + forall (S1 : state) t S2, + step ge S1 t S2 -> + forall R1, + match_states S1 R1 -> + exists R2, Smallstep.plus step tge R1 t R2 /\ match_states S2 R2. + Proof. + Ltac transf_step_correct_assum := + match goal with + | H: match_states _ _ |- _ => let H2 := fresh "MATCH" in learn H as H2; inv H2 + | H: mod_ram ?m = Some ?r |- _ => + let H2 := fresh "RAM" in learn H; + pose proof (transf_module_code_ram m r H) as H2 + | H: mod_ram ?m = None |- _ => + let H2 := fresh "RAM" in learn H; + pose proof (transf_module_code m H) as H2 + end. + Ltac transf_step_correct_tac := + match goal with + | |- Smallstep.plus _ _ _ _ _ => apply Smallstep.plus_one + end. + induction 1; destruct (mod_ram m) eqn:RAM; simplify; repeat transf_step_correct_assum; + repeat transf_step_correct_tac. + - assert (MATCH_SIZE1: match_empty_size m nasa1 /\ match_empty_size m basa1). + { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; mgen_crush. } + simplify. + assert (MATCH_SIZE2: match_empty_size m nasa2 /\ match_empty_size m basa2). + { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. + assert (MATCH_SIZE2: match_empty_size m nasa3 /\ match_empty_size m basa3). + { eapply match_arrs_size_ram_preserved2; mgen_crush. } simplify. + assert (MATCH_ARR3: match_arrs_size nasa3 basa3) by mgen_crush. + exploit match_states_same. apply H4. eauto with mgen. + econstructor; eauto. econstructor; eauto. econstructor; eauto. econstructor; eauto. + intros. repeat inv_exists. simplify. inv H18. inv H21. + exploit match_states_same. apply H6. eauto with mgen. + econstructor; eauto. econstructor; eauto. intros. repeat inv_exists. simplify. inv H18. inv H23. + exploit exec_ram_same; eauto. eauto with mgen. + econstructor. eapply match_assocmaps_merge; eauto. eauto with mgen. + econstructor. + apply match_arrs_merge; eauto with mgen. eauto with mgen. + intros. repeat inv_exists. simplify. inv H18. inv H28. + econstructor; simplify. apply Smallstep.plus_one. econstructor. + mgen_crush. mgen_crush. mgen_crush. rewrite RAM0; eassumption. rewrite RAM0; eassumption. + rewrite RAM0. eassumption. mgen_crush. eassumption. rewrite RAM0 in H21. rewrite RAM0. + rewrite RAM. eassumption. eauto. eauto. eauto with mgen. eauto. + econstructor. mgen_crush. apply match_arrs_merge; mgen_crush. eauto. + apply match_empty_size_merge; mgen_crush; mgen_crush. + assert (MATCH_SIZE1': match_empty_size m ran'0 /\ match_empty_size m rab'0). + { eapply match_arrs_size_stmnt_preserved2; eauto. unfold match_empty_size; mgen_crush. } + simplify. + assert (MATCH_SIZE2': match_empty_size m ran'2 /\ match_empty_size m rab'2). + { eapply match_arrs_size_stmnt_preserved2; mgen_crush. } simplify. + assert (MATCH_SIZE2': match_empty_size m ran'4 /\ match_empty_size m rab'4). + { eapply match_arrs_size_ram_preserved2; mgen_crush. + unfold match_empty_size, transf_module, empty_stack. + repeat destruct_match; crush. mgen_crush. } + apply match_empty_size_merge; mgen_crush; mgen_crush. + unfold disable_ram. + unfold transf_module; repeat destruct_match; crush. + apply exec_ram_resets_en in H21. unfold merge_reg_assocs in H21. + simplify. auto. auto. + - eapply translation_correct; eauto. + - do 2 econstructor. apply Smallstep.plus_one. + apply step_finish; mgen_crush. constructor; eauto. + - do 2 econstructor. apply Smallstep.plus_one. + apply step_finish; mgen_crush. econstructor; eauto. + - econstructor. econstructor. apply Smallstep.plus_one. econstructor. + replace (mod_entrypoint (transf_module m)) with (mod_entrypoint m) by (rewrite RAM0; auto). + replace (mod_reset (transf_module m)) with (mod_reset m) by (rewrite RAM0; auto). + replace (mod_finish (transf_module m)) with (mod_finish m) by (rewrite RAM0; auto). + replace (empty_stack (transf_module m)) with (empty_stack m) by (rewrite RAM0; auto). + replace (mod_params (transf_module m)) with (mod_params m) by (rewrite RAM0; auto). + replace (mod_st (transf_module m)) with (mod_st m) by (rewrite RAM0; auto). + repeat econstructor; mgen_crush. + unfold disable_ram. unfold transf_module; repeat destruct_match; crush. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (mod_params_wf m). + pose proof (mod_ram_wf m r Heqo0). + pose proof (ram_ordering r). + simplify. + repeat rewrite find_assocmap_gso by lia. + assert ((init_regs nil (mod_params m)) ! (ram_en r) = None). + { apply init_regs_equal_empty. eapply forall_lt_num. eassumption. lia. } + assert ((init_regs nil (mod_params m)) ! (ram_u_en r) = None). + { apply init_regs_equal_empty. eapply forall_lt_num. eassumption. lia. } + unfold find_assocmap, AssocMapExt.get_default. rewrite H7. rewrite H14. auto. + - econstructor. econstructor. apply Smallstep.plus_one. econstructor. + replace (mod_entrypoint (transf_module m)) with (mod_entrypoint m). + replace (mod_reset (transf_module m)) with (mod_reset m). + replace (mod_finish (transf_module m)) with (mod_finish m). + replace (empty_stack (transf_module m)) with (empty_stack m). + replace (mod_params (transf_module m)) with (mod_params m). + replace (mod_st (transf_module m)) with (mod_st m). + all: try solve [unfold transf_module; repeat destruct_match; mgen_crush]. + repeat econstructor; mgen_crush. + unfold disable_ram. unfold transf_module; repeat destruct_match; crush. + unfold max_reg_module. + repeat rewrite find_assocmap_gso by lia. + assert (max_reg_module m + 1 > max_list (mod_params m)). + { unfold max_reg_module. lia. } + apply max_list_correct in H0. + unfold find_assocmap, AssocMapExt.get_default. + rewrite init_regs_equal_empty. rewrite init_regs_equal_empty. auto. + eapply forall_lt_num. eassumption. unfold max_reg_module. lia. + eapply forall_lt_num. eassumption. unfold max_reg_module. lia. + - inv STACKS. destruct b1; subst. + econstructor. econstructor. apply Smallstep.plus_one. + econstructor. eauto. + clear Learn. inv H0. inv H3. inv STACKS. inv H3. constructor. + constructor. intros. + rewrite RAM0. + destruct (Pos.eq_dec r res); subst. + rewrite AssocMap.gss. + rewrite AssocMap.gss. auto. + rewrite AssocMap.gso; auto. + symmetry. rewrite AssocMap.gso; auto. + destruct (Pos.eq_dec (mod_st m) r); subst. + rewrite AssocMap.gss. + rewrite AssocMap.gss. auto. + rewrite AssocMap.gso; auto. + symmetry. rewrite AssocMap.gso; auto. inv MATCH_ASSOC0. apply H1. auto. + auto. auto. auto. auto. + rewrite RAM0. rewrite RAM. rewrite RAM0 in DISABLE_RAM. rewrite RAM in DISABLE_RAM. + apply disable_ram_set_gso. + apply disable_ram_set_gso. auto. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (ram_ordering r0). simplify. + pose proof (mod_ram_wf m r0 H). lia. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (ram_ordering r0). simplify. + pose proof (mod_ram_wf m r0 H). lia. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (ram_ordering r0). simplify. + pose proof (mod_ram_wf m r0 H). lia. + pose proof (mod_ordering_wf m); unfold module_ordering in *. + pose proof (ram_ordering r0). simplify. + pose proof (mod_ram_wf m r0 H). lia. + - inv STACKS. destruct b1; subst. + econstructor. econstructor. apply Smallstep.plus_one. + econstructor. eauto. + clear Learn. inv H0. inv H3. inv STACKS. constructor. + constructor. intros. + unfold transf_module. repeat destruct_match; crush. + destruct (Pos.eq_dec r res); subst. + rewrite AssocMap.gss. + rewrite AssocMap.gss. auto. + rewrite AssocMap.gso; auto. + symmetry. rewrite AssocMap.gso; auto. + destruct (Pos.eq_dec (mod_st m) r); subst. + rewrite AssocMap.gss. + rewrite AssocMap.gss. auto. + rewrite AssocMap.gso; auto. + symmetry. rewrite AssocMap.gso; auto. inv MATCH_ASSOC. apply H. auto. + auto. auto. auto. auto. + Opaque disable_ram. + unfold transf_module in *; repeat destruct_match; crush. + apply disable_ram_set_gso. + apply disable_ram_set_gso. + auto. + simplify. unfold max_reg_module. lia. + simplify. unfold max_reg_module. lia. + simplify. unfold max_reg_module. lia. + simplify. unfold max_reg_module. lia. + Qed. + #[local] Hint Resolve transf_step_correct : mgen. + + Lemma transf_initial_states : + forall s1 : state, + initial_state prog s1 -> + exists s2 : state, + initial_state tprog s2 /\ match_states s1 s2. + Proof using TRANSL. + simplify. inv H. + exploit function_ptr_translated. eauto. intros. + inv H. inv H3. + econstructor. econstructor. econstructor. + eapply (Genv.init_mem_match TRANSL); eauto. + setoid_rewrite (Linking.match_program_main TRANSL). + rewrite symbols_preserved. eauto. + eauto. + econstructor. + Qed. + #[local] Hint Resolve transf_initial_states : mgen. + + Lemma transf_final_states : + forall (s1 : state) + (s2 : state) + (r : Int.int), + match_states s1 s2 -> + final_state s1 r -> + final_state s2 r. + Proof using TRANSL. + intros. inv H0. inv H. inv STACKS. unfold valueToInt. constructor. auto. + Qed. + #[local] Hint Resolve transf_final_states : mgen. + + Theorem transf_program_correct: + Smallstep.forward_simulation (semantics prog) (semantics tprog). + Proof using TRANSL. + eapply Smallstep.forward_simulation_plus; mgen_crush. + apply senv_preserved. + Qed. + +End CORRECTNESS. diff --git a/src/hls/Partition.ml b/src/hls/Partition.ml index 270db14..19c6048 100644 --- a/src/hls/Partition.ml +++ b/src/hls/Partition.ml @@ -118,7 +118,6 @@ let function_from_RTL f = fn_stacksize = f.RTL.fn_stacksize; fn_params = f.RTL.fn_params; fn_entrypoint = f.RTL.fn_entrypoint; - fn_funct_units = FunctionalUnits.initial_funct_units; fn_code = c } diff --git a/src/hls/Predicate.v b/src/hls/Predicate.v new file mode 100644 index 0000000..b19ae98 --- /dev/null +++ b/src/hls/Predicate.v @@ -0,0 +1,683 @@ +Require Import Coq.Classes.RelationClasses. +Require Import Coq.Classes.DecidableClass. +Require Import Coq.Setoids.Setoid. +Require Export Coq.Classes.SetoidClass. +Require Export Coq.Classes.SetoidDec. +Require Import Coq.Logic.Decidable. + +Require Import vericert.common.Vericertlib. +Require Import vericert.hls.Sat. + +Definition predicate : Type := positive. + +Inductive pred_op : Type := +| Plit: (bool * predicate) -> pred_op +| Ptrue: pred_op +| Pfalse: pred_op +| Pand: pred_op -> pred_op -> pred_op +| Por: pred_op -> pred_op -> pred_op. + +Declare Scope pred_op. + +Notation "A ∧ B" := (Pand A B) (at level 20) : pred_op. +Notation "A ∨ B" := (Por A B) (at level 25) : pred_op. +Notation "⟂" := (Pfalse) : pred_op. +Notation "'T'" := (Ptrue) : pred_op. + +#[local] Open Scope pred_op. + +Fixpoint sat_predicate (p: pred_op) (a: asgn) : bool := + match p with + | Plit (b, p') => if b then a (Pos.to_nat p') else negb (a (Pos.to_nat p')) + | Ptrue => true + | Pfalse => false + | Pand p1 p2 => sat_predicate p1 a && sat_predicate p2 a + | Por p1 p2 => sat_predicate p1 a || sat_predicate p2 a + end. + +Definition sat_equiv p1 p2 := forall c, sat_predicate p1 c = sat_predicate p2 c. + +Lemma equiv_symm : forall a b, sat_equiv a b -> sat_equiv b a. +Proof. crush. Qed. + +Lemma equiv_trans : forall a b c, sat_equiv a b -> sat_equiv b c -> sat_equiv a c. +Proof. crush. Qed. + +Lemma equiv_refl : forall a, sat_equiv a a. +Proof. crush. Qed. + +#[global] +Instance Equivalence_SAT : Equivalence sat_equiv := + { Equivalence_Reflexive := equiv_refl ; + Equivalence_Symmetric := equiv_symm ; + Equivalence_Transitive := equiv_trans ; + }. + +#[global] +Instance SATSetoid : Setoid pred_op := + { equiv := sat_equiv; }. + +#[global] +Instance PandProper : Proper (equiv ==> equiv ==> equiv) Pand. +Proof. + unfold Proper. simplify. unfold "==>". + intros. + unfold sat_equiv in *. intros. + simplify. rewrite H0. rewrite H. + auto. +Qed. + +#[global] +Instance PorProper : Proper (equiv ==> equiv ==> equiv) Por. +Proof. + unfold Proper, "==>". simplify. + intros. + unfold sat_equiv in *. intros. + simplify. rewrite H0. rewrite H. + auto. +Qed. + +#[global] +Instance sat_predicate_Proper : Proper (equiv ==> eq ==> eq) sat_predicate. +Proof. + unfold Proper, "==>". simplify. + intros. + unfold sat_equiv in *. subst. + apply H. +Qed. + +Fixpoint negate (p: pred_op) := + match p with + | Plit (b, pr) => Plit (negb b, pr) + | T => ⟂ + | ⟂ => T + | A ∧ B => negate A ∨ negate B + | A ∨ B => negate A ∧ negate B + end. + +Notation "¬ A" := (negate A) (at level 15) : pred_op. + +Lemma negate_correct : + forall h a, sat_predicate (negate h) a = negb (sat_predicate h a). +Proof. + induction h; crush. + - repeat destruct_match; subst; crush; symmetry; apply negb_involutive. + - rewrite negb_andb; crush. + - rewrite negb_orb; crush. +Qed. + +Definition unsat p := forall a, sat_predicate p a = false. +Definition sat p := exists a, sat_predicate p a = true. + +Lemma unsat_correct1 : + forall a b c, + unsat (Pand a b) -> + sat_predicate a c = true -> + sat_predicate b c = false. +Proof. + unfold unsat in *. intros. + simplify. specialize (H c). + apply andb_false_iff in H. inv H. rewrite H0 in H1. discriminate. + auto. +Qed. + +Lemma unsat_correct2 : + forall a b c, + unsat (Pand a b) -> + sat_predicate b c = true -> + sat_predicate a c = false. +Proof. + unfold unsat in *. intros. + simplify. specialize (H c). + apply andb_false_iff in H. inv H. auto. rewrite H0 in H1. discriminate. +Qed. + +Lemma unsat_not a: unsat (a ∧ (¬ a)). +Proof. + unfold unsat; simplify. + rewrite negate_correct. + auto with bool. +Qed. + +Lemma unsat_commut a b: unsat (a ∧ b) -> unsat (b ∧ a). +Proof. unfold unsat; simplify; eauto with bool. Qed. + +Lemma sat_imp_equiv : + forall a b, + unsat (a ∧ ¬ b ∨ ¬ a ∧ b) -> a == b. +Proof. + simplify; unfold unsat, sat_equiv. + intros. specialize (H c); simplify. + rewrite negate_correct in *. + destruct (sat_predicate b c) eqn:X; + destruct (sat_predicate a c) eqn:X2; + crush. +Qed. + +Lemma sat_predicate_and : + forall a b c, + sat_predicate (a ∧ b) c = sat_predicate a c && sat_predicate b c. +Proof. crush. Qed. + +Lemma sat_predicate_or : + forall a b c, + sat_predicate (a ∨ b) c = sat_predicate a c || sat_predicate b c. +Proof. crush. Qed. + +Lemma sat_equiv2 : + forall a b, + a == b -> unsat (a ∧ ¬ b ∨ ¬ a ∧ b). +Proof. + unfold unsat, equiv; simplify. + repeat rewrite negate_correct. + repeat rewrite H. + rewrite andb_negb_r. + rewrite andb_negb_l. auto. +Qed. + +Lemma sat_equiv3 : + forall a b, + unsat (a ∧ ¬ b ∨ b ∧ ¬ a) -> a == b. +Proof. + simplify. unfold unsat, sat_equiv in *; intros. + specialize (H c); simplify. + rewrite negate_correct in *. + destruct (sat_predicate b c) eqn:X; + destruct (sat_predicate a c) eqn:X2; + crush. +Qed. + +Lemma sat_equiv4 : + forall a b, + a == b -> unsat (a ∧ ¬ b ∨ b ∧ ¬ a). +Proof. + unfold unsat, equiv; simplify. + repeat rewrite negate_correct. + repeat rewrite H. + rewrite andb_negb_r. auto. +Qed. + +Definition simplify' (p: pred_op) := + match p with + | (Plit (b1, a)) ∧ (Plit (b2, b)) as p' => + if Pos.eqb a b then + if negb (xorb b1 b2) then Plit (b1, a) else ⟂ + else p' + | (Plit (b1, a)) ∨ (Plit (b2, b)) as p' => + if Pos.eqb a b then + if negb (xorb b1 b2) then Plit (b1, a) else T + else p' + | A ∧ T => A + | T ∧ A => A + | _ ∧ ⟂ => ⟂ + | ⟂ ∧ _ => ⟂ + | _ ∨ T => T + | T ∨ _ => T + | A ∨ ⟂ => A + | ⟂ ∨ A => A + | A => A + end. + +Lemma pred_op_dec : + forall p1 p2: pred_op, + { p1 = p2 } + { p1 <> p2 }. +Proof. pose proof Pos.eq_dec. repeat decide equality. Qed. + +Fixpoint simplify (p: pred_op) := + match p with + | A ∧ B => + let A' := simplify A in + let B' := simplify B in + simplify' (A' ∧ B') + | A ∨ B => + let A' := simplify A in + let B' := simplify B in + simplify' (A' ∨ B') + | T => T + | ⟂ => ⟂ + | Plit a => Plit a + end. + +Lemma simplify'_correct : + forall h a, + sat_predicate (simplify' h) a = sat_predicate h a. +Proof. + (*destruct h; crush; repeat destruct_match; crush; + solve [rewrite andb_true_r; auto | rewrite orb_false_r; auto]. +Qed.*) Admitted. + +Lemma simplify_correct : + forall h a, + sat_predicate (simplify h) a = sat_predicate h a. +Proof. + Local Opaque simplify'. + induction h; crush. + - replace (sat_predicate h1 a && sat_predicate h2 a) + with (sat_predicate (simplify h1) a && sat_predicate (simplify h2) a) + by crush. + rewrite simplify'_correct. crush. + - replace (sat_predicate h1 a || sat_predicate h2 a) + with (sat_predicate (simplify h1) a || sat_predicate (simplify h2) a) + by crush. + rewrite simplify'_correct. crush. + Local Transparent simplify'. +Qed. + +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 (p: pred_op) : + {fm: formula | forall a, + sat_predicate p a = true <-> satFormula fm a}. + refine + (match p with + | Plit (b, p') => exist _ (((b, Pos.to_nat p') :: nil) :: nil) _ + | Ptrue => exist _ nil _ + | Pfalse => exist _ (nil::nil) _ + | Pand p1 p2 => + match trans_pred p1, trans_pred p2 with + | exist _ p1' _, exist _ p2' _ => exist _ (p1' ++ p2') _ + end + | Por p1 p2 => + match trans_pred p1, trans_pred p2 with + | exist _ p1' _, exist _ p2' _ => exist _ (mult p1' p2') _ + end + end); split; intros; simpl in *; auto; try solve [crush]. + - destruct b; auto. apply negb_true_iff in H. auto. + - destruct b. inv H. inv H0; auto. apply negb_true_iff. inv H. inv H0; eauto. contradiction. + - 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. +Defined. + +Definition bar (p1: lit): lit := (negb (fst p1), (snd p1)). + +Definition stseytin_or (cur p1 p2: lit) : formula := + (bar cur :: p1 :: p2 :: nil) + :: (cur :: bar p1 :: nil) + :: (cur :: bar p2 :: nil) :: nil. + +Definition stseytin_and (cur p1 p2: lit) : formula := + (cur :: bar p1 :: bar p2 :: nil) + :: (bar cur :: p1 :: nil) + :: (bar cur :: p2 :: nil) :: nil. + +Fixpoint xtseytin (next: nat) (p: pred_op) {struct p} : (nat * lit * formula) := + match p with + | Plit (b, p') => (next, (b, Pos.to_nat p'), nil) + | Ptrue => + ((next+1)%nat, (true, next), ((true, next)::nil)::nil) + | Pfalse => + ((next+1)%nat, (true, next), ((false, next)::nil)::nil) + | Por p1 p2 => + let '(m1, n1, f1) := xtseytin next p1 in + let '(m2, n2, f2) := xtseytin m1 p2 in + ((m2+1)%nat, (true, m2), stseytin_or (true, m2) n1 n2 ++ f1 ++ f2) + | Pand p1 p2 => + let '(m1, n1, f1) := xtseytin next p1 in + let '(m2, n2, f2) := xtseytin m1 p2 in + ((m2+1)%nat, (true, m2), stseytin_and (true, m2) n1 n2 ++ f1 ++ f2) + end. + +Lemma stseytin_and_correct : + forall cur p1 p2 fm c, + stseytin_and cur p1 p2 = fm -> + satLit cur c -> + satLit p1 c /\ satLit p2 c -> + satFormula fm c. +Proof. + intros. + unfold stseytin_and in *. rewrite <- H. + unfold satLit in *. destruct p1. destruct p2. destruct cur. + simpl in *|-. cbn. unfold satLit. cbn. crush. +Qed. + +Lemma stseytin_and_correct2 : + forall cur p1 p2 fm c, + stseytin_and cur p1 p2 = fm -> + satFormula fm c -> + satLit cur c <-> satLit p1 c /\ satLit p2 c. +Proof. + intros. split. intros. inv H1. unfold stseytin_and in *. + inv H0; try contradiction. Admitted. + +Lemma stseytin_or_correct : + forall cur p1 p2 fm c, + stseytin_or cur p1 p2 = fm -> + satLit cur c -> + satLit p1 c \/ satLit p2 c -> + satFormula fm c. +Proof. + intros. + unfold stseytin_or in *. rewrite <- H. inv H1. + unfold satLit in *. destruct p1. destruct p2. destruct cur. + simpl in *|-. cbn. unfold satLit. cbn. crush. + unfold satLit in *. destruct p1. destruct p2. destruct cur. + simpl in *|-. cbn. unfold satLit. cbn. crush. +Qed. + +Lemma stseytin_or_correct2 : + forall cur p1 p2 fm c, + stseytin_or cur p1 p2 = fm -> + satFormula fm c -> + satLit cur c <-> satLit p1 c \/ satLit p2 c. +Proof. Admitted. + +Lemma xtseytin_correct : + forall p next l n fm c, + xtseytin next p = (n, l, fm) -> + sat_predicate p c = true <-> satFormula ((l::nil)::fm) c. +Proof. + induction p. + - intros. simplify. destruct p. + inv H. split. + intros. destruct b. split; crush. + apply negb_true_iff in H. + split; crush. + intros. inv H. inv H0; try contradiction. + inv H. simplify. rewrite <- H0. + destruct b. + rewrite -> H0; auto. + rewrite -> H0; auto. + - admit. + - admit. + - intros. split. intros. simpl in H0. + apply andb_prop in H0. inv H0. + cbn in H. + repeat destruct_match; try discriminate; []. inv H. eapply IHp1 in Heqp. + eapply IHp2 in Heqp1. apply Heqp1 in H2. + apply Heqp in H1. inv H1. inv H2. + assert + (satFormula + (((true, n1) :: bar l0 :: bar l1 :: nil) + :: (bar (true, n1) :: l0 :: nil) + :: (bar (true, n1) :: l1 :: nil) :: nil) c). + eapply stseytin_and_correct. unfold stseytin_and. eauto. + unfold satLit. simpl. admit. + inv H; try contradiction. inv H1; try contradiction. eauto. +Admitted. + +Fixpoint max_predicate (p: pred_op) : positive := + match p with + | Plit (b, p) => p + | Ptrue => 1 + | Pfalse => 1 + | Pand a b => Pos.max (max_predicate a) (max_predicate b) + | Por a b => Pos.max (max_predicate a) (max_predicate b) + end. + +Definition tseytin (p: pred_op) : + {fm: formula | forall a, + sat_predicate p a = true <-> satFormula fm a}. + refine ( + (match xtseytin (Pos.to_nat (max_predicate p + 1)) p as X + return xtseytin (Pos.to_nat (max_predicate p + 1)) p = X -> + {fm: formula | forall a, sat_predicate p a = true <-> satFormula fm a} + with (m, n, fm) => fun H => exist _ ((n::nil) :: fm) _ + end) (eq_refl (xtseytin (Pos.to_nat (max_predicate p + 1)) p))). + intros. eapply xtseytin_correct; eauto. Defined. + +Definition tseytin_simple (p: pred_op) : formula := + let m := Pos.to_nat (max_predicate p + 1) in + let '(m, n, fm) := xtseytin m p in + (n::nil) :: fm. + +Definition sat_pred_tseytin (p: pred_op) : + ({al : alist | sat_predicate p (interp_alist al) = true} + + {forall a : asgn, sat_predicate p a = false}). + refine + ( match tseytin p with + | exist _ fm _ => + match satSolve fm with + | inleft (exist _ a _) => inleft (exist _ a _) + | inright _ => inright _ + end + end ). + - apply i in s0. auto. + - intros. specialize (n a). specialize (i a). + destruct (sat_predicate p a). exfalso. + apply n. apply i. auto. auto. +Defined. + +Definition sat_pred_simple (p: pred_op) : option alist := + match sat_pred_tseytin p with + | inleft (exist _ a _) => Some a + | inright _ => None + end. + +Definition sat_pred (p: pred_op) : + ({al : alist | sat_predicate p (interp_alist al) = true} + + {forall a : asgn, sat_predicate p a = false}). + refine + ( match trans_pred p with + | exist _ fm _ => + match satSolve fm with + | inleft (exist _ a _) => inleft (exist _ a _) + | inright _ => inright _ + end + end ). + - apply i in s0. auto. + - intros. specialize (n a). specialize (i a). + destruct (sat_predicate p a). exfalso. + apply n. apply i. auto. auto. +Defined. + +#[local] Open Scope positive. + +Compute tseytin_simple (Por (negate (Pand (Por (Plit (true, 1)) (Plit (true, 2))) (Plit (true, 3)))) (Plit (false, 4))). +Compute sat_pred_simple (Por Pfalse (Pand (Plit (true, 1)) (Plit (false, 1)))). + +Lemma sat_dec a: {sat a} + {unsat a}. +Proof. + unfold sat, unsat. + destruct (sat_pred a). + intros. left. destruct s. + exists (Sat.interp_alist x). auto. + intros. tauto. +Qed. + +Definition equiv_check p1 p2 := + match sat_pred_simple (simplify (p1 ∧ ¬ p2 ∨ p2 ∧ ¬ p1)) with + | None => true + | _ => false + end. + +Compute equiv_check Pfalse (Pand (Plit (true, 1%positive)) (Plit (false, 1%positive))). + +Lemma equiv_check_correct : + forall p1 p2, equiv_check p1 p2 = true -> p1 == p2. +Proof. + unfold equiv_check. unfold sat_pred_simple. intros. + destruct_match; try discriminate; []. + destruct_match. destruct_match. discriminate. + eapply sat_equiv3; eauto. + unfold unsat; intros. + rewrite <- simplify_correct. eauto. +Qed. + +Opaque simplify. +Opaque simplify'. + +Lemma equiv_check_correct2 : + forall p1 p2, p1 == p2 -> equiv_check p1 p2 = true. +Proof. + unfold equiv_check, equiv, sat_pred_simple. intros. + destruct_match; auto. destruct_match; try discriminate. + destruct_match. + simplify. + apply sat_equiv4 in H. unfold unsat in H. simplify. + clear Heqs. rewrite simplify_correct in e. + specialize (H (interp_alist a)). simplify. + rewrite H1 in e. rewrite H0 in e. discriminate. +Qed. + +Lemma equiv_check_dec : + forall p1 p2, equiv_check p1 p2 = true <-> p1 == p2. +Proof. + intros; split; eauto using equiv_check_correct, equiv_check_correct2. +Qed. + +Lemma equiv_check_decidable : + forall p1 p2, decidable (p1 == p2). +Proof. + intros. destruct (equiv_check p1 p2) eqn:?. + unfold decidable. + left. apply equiv_check_dec; auto. + unfold decidable, not; right; intros. + apply equiv_check_dec in H. crush. +Qed. + +Lemma equiv_check_decidable2 : + forall p1 p2, {p1 == p2} + {p1 =/= p2}. +Proof. + intros. destruct (equiv_check p1 p2) eqn:?. + unfold decidable. + left. apply equiv_check_dec; auto. + unfold decidable, not; right; intros. + simpl. unfold complement. intros. + apply not_true_iff_false in Heqb. apply Heqb. + apply equiv_check_dec. eauto. +Qed. + +#[global] +Instance DecidableSATSetoid : DecidableSetoid SATSetoid := + { setoid_decidable := equiv_check_decidable }. + +#[global] +Instance SATSetoidEqDec : EqDec SATSetoid := equiv_check_decidable2. + +Definition Pimplies p p' := ¬ p ∨ p'. + +Notation "A → B" := (Pimplies A B) (at level 30) : pred_op. + +Definition implies p p' := + forall c, sat_predicate p c = true -> sat_predicate p' c = true. + +Notation "A ⇒ B" := (implies A B) (at level 35) : pred_op. + +Lemma Pimplies_implies: forall p p', (p → p') ∧ p ⇒ p'. +Proof. + unfold "→", "⇒"; simplify. + apply orb_prop in H0. inv H0; auto. rewrite negate_correct in H. + apply negb_true_iff in H. crush. +Qed. + +#[global] +Instance PimpliesProper : Proper (equiv ==> equiv ==> equiv) Pimplies. +Proof. + unfold Proper, "==>". simplify. unfold "→". + intros. + unfold sat_equiv in *. intros. + simplify. repeat rewrite negate_correct. rewrite H0. rewrite H. + auto. +Qed. + +#[global] +Instance simplifyProper : Proper (equiv ==> equiv) simplify. +Proof. + unfold Proper, "==>". simplify. unfold "→". + intros. unfold sat_equiv; intros. + rewrite ! simplify_correct; auto. +Qed. diff --git a/src/hls/PrintAbstr.ml b/src/hls/PrintAbstr.ml new file mode 100644 index 0000000..c63fa02 --- /dev/null +++ b/src/hls/PrintAbstr.ml @@ -0,0 +1,39 @@ +(**open Camlcoq +open Datatypes +open Maps +open AST +open Abstr +open PrintAST +open Printf + +let rec expr_to_list = function + | Enil -> [] + | Econs (e, el) -> e :: expr_to_list el + +let res pp = function + | Reg r -> fprintf pp "r%d" (P.to_int r) + | Pred r -> fprintf pp "p%d" (P.to_int r) + | Mem -> fprintf pp "M" + +let rec print_expression pp = function + | Ebase r -> fprintf pp "%a'" res r + | Eop (op, el) -> fprintf pp "(%a)" (PrintOp.print_operation print_expression) (op, expr_to_list el) + | Eload (chunk, addr, el, e) -> + fprintf pp "(%s[%a][%a])" + (name_of_chunk chunk) print_expression e + (PrintOp.print_addressing print_expression) (addr, expr_to_list el) + | Estore (e, chunk, addr, el, m) -> + fprintf pp "(%s[%a][%a] = %a)" + (name_of_chunk chunk) print_expression m + (PrintOp.print_addressing print_expression) (addr, expr_to_list el) + print_expression e + | Esetpred (c, el) -> + fprintf pp "(%a)" (PrintOp.print_condition print_expression) (c, expr_to_list el) + +let rec print_predicated pp = function + | NE.Coq_singleton (p, e) -> + fprintf pp "%a %a" PrintRTLBlockInstr.print_pred_option p print_expression e + | NE.Coq_cons ((p, e), pr) -> + fprintf pp "%a %a\n%a" PrintRTLBlockInstr.print_pred_option p print_expression e + print_predicated pr +*) diff --git a/src/hls/PrintExpression.ml b/src/hls/PrintExpression.ml new file mode 100644 index 0000000..df5dc37 --- /dev/null +++ b/src/hls/PrintExpression.ml @@ -0,0 +1,40 @@ +(*open Printf +open Camlcoq +open Datatypes +open Maps +open PrintAST +open RTLPargen + +let reg pp r = + fprintf pp "x%d" (P.to_int r) + +let pred pp r = + fprintf pp "p%d" (P.to_int r) + +let print_resource pp = function + | Reg r -> reg pp r + | Pred r -> pred pp r + | Mem -> fprintf pp "M" + +let rec to_expr_list = function + | Enil -> [] + | Econs (e, elist) -> e :: to_expr_list elist + +let rec print_expression pp = function + | Ebase r -> print_resource pp r + | Eop (op, elist, e) -> + PrintOp.print_operation print_expression pp (op, to_expr_list elist); + Printf.printf "; "; + print_expression pp e + | Eload (chunk, addr, elist, e) -> + fprintf pp "%s[%a]; " (name_of_chunk chunk) (PrintOp.print_addressing print_expression) (addr, to_expr_list elist); + print_expression pp e + | Estore (e, chunk, addr, elist, e') -> + fprintf pp "%s[%a] = %a; " (name_of_chunk chunk) + (PrintOp.print_addressing print_expression) (addr, to_expr_list elist) + print_expression e; + print_expression pp e + | Esetpred (cond, elist, e) -> + fprintf pp "%a; " (PrintOp.print_condition print_expression) (cond, to_expr_list elist); + print_expression pp e +*) diff --git a/src/hls/PrintHTL.ml b/src/hls/PrintHTL.ml index a75d0ee..5963be0 100644 --- a/src/hls/PrintHTL.ml +++ b/src/hls/PrintHTL.ml @@ -71,10 +71,10 @@ let print_program pp prog = let destination : string option ref = ref None -let print_if prog = +let print_if passno prog = match !destination with | None -> () | Some f -> - let oc = open_out f in + 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 index 808d342..b8e1e2e 100644 --- a/src/hls/PrintRTLBlockInstr.ml +++ b/src/hls/PrintRTLBlockInstr.ml @@ -4,13 +4,14 @@ open Datatypes open Maps open AST open RTLBlockInstr +open Predicate 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) + fprintf pp "p%d" (P.to_int r) let rec regs pp = function | [] -> () @@ -22,10 +23,11 @@ let ros pp = function | 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 + | Plit p -> if fst p then pred pp (snd p) else fprintf pp "~%a" pred (snd 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 + | Ptrue -> fprintf pp "T" + | Pfalse -> fprintf pp "⟂" let print_pred_option pp = function | Some x -> fprintf pp "(%a)" print_pred_op x @@ -48,15 +50,11 @@ let print_bblock_body pp i = (name_of_chunk chunk) (PrintOp.print_addressing reg) (addr, args) reg src - | RBsetpred (c, args, p) -> - fprintf pp "%a = %a\n" + | RBsetpred (p', c, args, p) -> + fprintf pp "%a %a = %a\n" + print_pred_option p' pred p (PrintOp.print_condition reg) (c, args) - | RBpiped (p, fu, args) -> - fprintf pp "%a piped\n" print_pred_option p - | RBassign (p, fu, src, dst) -> - fprintf pp "%a %a = %a" print_pred_option p - reg src reg dst let rec print_bblock_exit pp i = fprintf pp "\t\t"; diff --git a/src/hls/printRTLPar.ml b/src/hls/PrintRTLPar.ml index 7fac0de..ab93fa5 100644 --- a/src/hls/printRTLPar.ml +++ b/src/hls/PrintRTLPar.ml @@ -38,9 +38,9 @@ let ros pp = function let print_bblock pp (pc, i) = fprintf pp "%5d:{\n" pc; - List.iter (fun x -> fprintf pp "["; - List.iter (fun x' -> fprintf pp "["; List.iter (print_bblock_body pp) x'; fprintf pp "]\n") x; - fprintf pp "]\n") i.bb_body; + List.iter (fun x -> fprintf pp "{\n"; + List.iter (fun x -> fprintf pp "( "; List.iter (print_bblock_body pp) x; fprintf pp " )") x; + fprintf pp "}\n") i.bb_body; print_bblock_exit pp i.bb_exit; fprintf pp "\t}\n\n" diff --git a/src/hls/PrintVerilog.ml b/src/hls/PrintVerilog.ml index da3bd6e..46b001e 100644 --- a/src/hls/PrintVerilog.ml +++ b/src/hls/PrintVerilog.ml @@ -76,14 +76,14 @@ let pprint_binop l r = let unop = function | Vneg -> " - " - | Vnot -> " ! " + | Vnot -> " ~ " 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 = s printf "%d'd%d" (Nat.to_int l.vsize) (Z.to_int (uvalueToZ l))*) let literal l = let l' = camlint_of_coqint l in @@ -119,7 +119,9 @@ 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 (List.sort compare_expr es |> List.rev); + fold_map pprint_case (stmnt_to_list es + |> List.sort compare_expr + |> List.rev); indent (i+1); "default:;\n"; indent i; "endcase\n" ] @@ -138,22 +140,22 @@ let pprint_edge_top i = function | Valledge -> "@*" | Voredge (e1, e2) -> concat ["@("; pprint_edge e1; " or "; pprint_edge e2; ")"] -let declare t = +let declare (t, i) = function (r, sz) -> concat [ t; " ["; sprintf "%d" (Nat.to_int sz - 1); ":0] "; - register r; ";\n" ] + register r; if i then " = 0;\n" else ";\n" ] -let declarearr t = +let declarearr (t, _) = function (r, sz, ln) -> concat [ t; " ["; sprintf "%d" (Nat.to_int sz - 1); ":0] "; register r; " ["; sprintf "%d" (Nat.to_int ln - 1); ":0];\n" ] let print_io = function - | Some Vinput -> "input logic" - | Some Voutput -> "output logic" - | Some Vinout -> "inout logic" - | None -> "logic" + | Some Vinput -> "input", false + | Some Voutput -> "output logic", true + | Some Vinout -> "inout", false + | None -> "logic", true let decl i = function | Vdecl (io, r, sz) -> concat [indent i; declare (print_io io) (r, sz)] @@ -163,11 +165,14 @@ let decl i = function let pprint_module_item i = function | Vdeclaration d -> decl i d | Valways (e, s) -> - concat [indent i; "always "; pprint_edge_top i e; "\n"; pprint_stmnt (i+1) s] + concat [indent i; "always "; pprint_edge_top i e; " begin\n"; + pprint_stmnt (i+1) s; indent i; "end\n"] | Valways_ff (e, s) -> - concat [indent i; "always "; pprint_edge_top i e; "\n"; pprint_stmnt (i+1) s] + concat [indent i; "always "; pprint_edge_top i e; " begin\n"; + pprint_stmnt (i+1) s; indent i; "end\n"] | Valways_comb (e, s) -> - concat [indent i; "always "; pprint_edge_top i e; "\n"; pprint_stmnt (i+1) s] + concat [indent i; "always "; pprint_edge_top i e; " begin\n"; + pprint_stmnt (i+1) s; indent i; "end\n"] let rec intersperse c = function | [] -> [] @@ -176,7 +181,7 @@ let rec intersperse c = function let make_io i io r = concat [indent i; io; " "; register r; ";\n"] -let print_funct_units clk = function +(**let print_funct_units clk = function | SignedDiv (stages, numer, denom, quot, rem) -> sprintf ("div_signed #(.stages(%d)) divs(.clk(%s), " ^^ ".clken(1'b1), .numer(%s), .denom(%s), " ^^ @@ -188,7 +193,7 @@ let print_funct_units clk = function ".clken(1'b1), .numer(%s), .denom(%s), " ^^ ".quotient(%s), .remain(%s))\n") (P.to_int stages) - (register clk) (register numer) (register denom) (register quot) (register rem) + (register clk) (register numer) (register denom) (register quot) (register rem)*) let compose f g x = g x |> f @@ -260,10 +265,7 @@ let pprint_module debug i n m = ]; 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; - concat (List.map (print_funct_units m.mod_clk) - (Maps.PTree.elements m.mod_funct_units.avail_units - |> List.map snd)); + fold_map (pprint_module_item (i+1)) (List.rev 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_verbose i m.mod_clk m.mod_st else ""; indent i; "endmodule\n\n" diff --git a/src/hls/RTLBlock.v b/src/hls/RTLBlock.v index 6a3487a..bf5c37a 100644 --- a/src/hls/RTLBlock.v +++ b/src/hls/RTLBlock.v @@ -58,11 +58,11 @@ Section RELSEM. Inductive step: state -> trace -> state -> Prop := | exec_bblock: - forall s f sp pc rs rs' m m' t s' bb, + forall s f sp pc rs rs' m m' t s' bb pr pr', 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' + step_instr_list sp (mk_instr_state rs pr m) bb.(bb_body) (mk_instr_state rs' pr' m') -> + step_cf_instr ge (State s f sp pc rs' pr' m') bb.(bb_exit) t s' -> + step (State s f sp pc rs pr m) t s' | exec_function_internal: forall s f args m m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> @@ -72,6 +72,7 @@ Section RELSEM. (Vptr stk Ptrofs.zero) f.(fn_entrypoint) (init_regs args f.(fn_params)) + (PMap.init false) m') | exec_function_external: forall s ef args res t m m', @@ -79,9 +80,9 @@ Section RELSEM. 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). + forall res f sp pc rs s vres m pr, + step (Returnstate (Stackframe res f sp pc rs pr :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) pr m). End RELSEM. diff --git a/src/hls/RTLBlockInstr.v b/src/hls/RTLBlockInstr.v index 69cc709..d9f3e74 100644 --- a/src/hls/RTLBlockInstr.v +++ b/src/hls/RTLBlockInstr.v @@ -28,232 +28,42 @@ 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. -Require Import vericert.hls.FunctionalUnits. +Require Import Predicate. +Require Import Vericertlib. -Local Open Scope rtl. +(*| +===================== +RTLBlock Instructions +===================== -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. +These instructions are used for ``RTLBlock`` and ``RTLPar``, so that they have consistent +instructions, which greatly simplifies the proofs, as they will by default have the same instruction +syntax and semantics. The only changes are therefore at the top-level of the instructions. -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. +Instruction Definition +====================== -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. +First, we define the instructions that can be placed into a basic block, meaning they won't branch. +The main changes to how instructions are defined in ``RTL``, is that these instructions don't have a +next node, as they will be in a basic block, and they also have an optional predicate (``pred_op``). +|*) -Definition sat_pred_temp (bound: nat) (p: pred_op) := - match trans_pred_temp bound p with - | Some fm => boundedSatSimple bound fm - | None => None - end. +Definition node := positive. 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 -| RBpiped : option pred_op -> funct_node -> list reg -> instr -| RBassign : option pred_op -> funct_node -> reg -> reg -> instr -| RBsetpred : condition -> list reg -> predicate -> instr. +| RBsetpred : option pred_op -> condition -> list reg -> predicate -> instr. + +(*| +Control-Flow Instruction Definition +=================================== + +These are the instructions that count as control-flow, and will be placed at the end of the basic +blocks. +|*) Inductive cf_instr : Type := | RBcall : signature -> reg + ident -> list reg -> reg -> node -> cf_instr @@ -266,6 +76,11 @@ Inductive cf_instr : Type := | RBgoto : node -> cf_instr | RBpred_cf : pred_op -> cf_instr -> cf_instr -> cf_instr. +(*| +Helper functions +================ +|*) + Fixpoint successors_instr (i : cf_instr) : list node := match i with | RBcall sig ros args res s => s :: nil @@ -287,11 +102,7 @@ Definition max_reg_instr (m: positive) (i: instr) := fold_left Pos.max args (Pos.max dst m) | RBstore p chunk addr args src => fold_left Pos.max args (Pos.max src m) - | RBpiped p f args => - fold_left Pos.max args m - | RBassign p f src dst => - Pos.max src (Pos.max dst m) - | RBsetpred c args p => + | RBsetpred p' c args p => fold_left Pos.max args m end. @@ -317,6 +128,41 @@ Fixpoint max_reg_cfi (m : positive) (i : cf_instr) := end. Definition regset := Regmap.t val. +Definition predset := PMap.t bool. + +Definition eval_predf (pr: predset) (p: pred_op) := + sat_predicate p (fun x => pr !! (Pos.of_nat x)). + +#[global] +Instance eval_predf_Proper : Proper (eq ==> equiv ==> eq) eval_predf. +Proof. + unfold Proper. simplify. unfold "==>". + intros. + unfold sat_equiv in *. intros. unfold eval_predf. subst. apply H0. +Qed. + +#[local] Open Scope pred_op. + +Lemma eval_predf_Pand : + forall ps p p', + eval_predf ps (p ∧ p') = eval_predf ps p && eval_predf ps p'. +Proof. unfold eval_predf; split; simplify; auto with bool. Qed. + +Lemma eval_predf_Por : + forall ps p p', + eval_predf ps (p ∨ p') = eval_predf ps p || eval_predf ps p'. +Proof. unfold eval_predf; split; simplify; auto with bool. Qed. + +Lemma eval_predf_pr_equiv : + forall p ps ps', + (forall x, ps !! x = ps' !! x) -> + eval_predf ps p = eval_predf ps' p. +Proof. + induction p; simplify; auto; + try (unfold eval_predf; simplify; repeat (destruct_match; []); inv Heqp0; rewrite <- H; auto); + [repeat rewrite eval_predf_Pand|repeat rewrite eval_predf_Por]; + erewrite IHp1; try eassumption; erewrite IHp2; eauto. +Qed. Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := match rl, vl with @@ -324,11 +170,28 @@ Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := | _, _ => Regmap.init Vundef end. -Inductive instr_state : Type := -| InstrState: - forall (rs: regset) - (m: mem), - instr_state. +(*| +Instruction State +----------------- + +Definition of the instruction state, which contains the following: + +:is_rs: This is the current state of the registers. +:is_ps: This is the current state of the predicate registers, which is in a separate namespace and + area compared to the standard registers in ``is_rs``. +:is_mem: The current state of the memory. +|*) + +Record instr_state := mk_instr_state { + is_rs: regset; + is_ps: predset; + is_mem: mem; +}. + +(*| +Top-Level Type Definitions +========================== +|*) Section DEFINITION. @@ -346,7 +209,6 @@ Section DEFINITION. fn_params: list reg; fn_stacksize: Z; fn_code: code; - fn_funct_units: funct_units; fn_entrypoint: node }. @@ -366,7 +228,8 @@ Section DEFINITION. (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 *) + (rs: regset) (**r register state in calling function *) + (pr: predset), (**r predicate state of the calling function *) stackframe. Inductive state : Type := @@ -376,6 +239,7 @@ Section DEFINITION. (sp: val) (**r stack pointer *) (pc: node) (**r current program point in [c] *) (rs: regset) (**r register state *) + (pr: predset) (**r predicate register state *) (m: mem), (**r memory state *) state | Callstate: @@ -392,6 +256,11 @@ Section DEFINITION. End DEFINITION. +(*| +Semantics +========= +|*) + Section RELSEM. Context {bblock_body : Type}. @@ -411,67 +280,88 @@ Section RELSEM. end end. + Inductive eval_pred: option pred_op -> instr_state -> instr_state -> instr_state -> Prop := + | eval_pred_true: + forall i i' p, + eval_predf (is_ps i) p = true -> + eval_pred (Some p) i i' i' + | eval_pred_false: + forall i i' p, + eval_predf (is_ps i) p = false -> + eval_pred (Some p) i i' i + | eval_pred_none: + forall i i', eval_pred None i i' i. + 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) + forall sp ist, + step_instr sp ist RBnop ist | 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) + forall op v res args rs m sp p ist pr, + eval_operation ge sp op rs##args m = Some v -> + eval_pred p (mk_instr_state rs pr m) (mk_instr_state (rs#res <- v) pr m) ist -> + step_instr sp (mk_instr_state rs pr m) (RBop p op args res) ist | 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) + forall addr rs args a chunk m v dst sp p pr ist, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = Some v -> + eval_pred p (mk_instr_state rs pr m) (mk_instr_state (rs#dst <- v) pr m) ist -> + step_instr sp (mk_instr_state rs pr m) (RBload p chunk addr args dst) ist | 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'). + forall addr rs args a chunk m src m' sp p pr ist, + eval_addressing ge sp addr rs##args = Some a -> + Mem.storev chunk m a rs#src = Some m' -> + eval_pred p (mk_instr_state rs pr m) (mk_instr_state rs pr m') ist -> + step_instr sp (mk_instr_state rs pr m) (RBstore p chunk addr args src) ist + | exec_RBsetpred: + forall sp rs pr m p c b args p' ist, + Op.eval_condition c rs##args m = Some b -> + eval_pred p' (mk_instr_state rs pr m) (mk_instr_state rs (pr#p <- b) m) ist -> + step_instr sp (mk_instr_state rs pr m) (RBsetpred p' c args p) ist. 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', + forall s f sp rs m res fd ros sig args pc pc' pr, 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) + step_cf_instr (State s f sp pc rs pr m) (RBcall sig ros args res pc') + E0 (Callstate (Stackframe res f sp pc' rs pr :: s) fd rs##args m) | exec_RBtailcall: - forall s f stk rs m sig ros args fd m' pc, + forall s f stk rs m sig ros args fd m' pc pr, 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) + step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs pr 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, + forall s f sp rs m ef args res pc' vargs t vres m' pc pr, 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') + step_cf_instr (State s f sp pc rs pr m) (RBbuiltin ef args res pc') + t (State s f sp pc' (regmap_setres res vres rs) pr m') | exec_RBcond: - forall s f sp rs m cond args ifso ifnot b pc pc', + forall s f sp rs m cond args ifso ifnot b pc pc' pr, 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) + step_cf_instr (State s f sp pc rs pr m) (RBcond cond args ifso ifnot) + E0 (State s f sp pc' rs pr m) | exec_RBjumptable: - forall s f sp rs m arg tbl n pc pc', + forall s f sp rs m arg tbl n pc pc' pr, 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', + step_cf_instr (State s f sp pc rs pr m) (RBjumptable arg tbl) + E0 (State s f sp pc' rs pr m) + | exec_RBreturn: + forall s f stk rs m or pc m' pr, 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'). + step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs pr m) (RBreturn or) + E0 (Returnstate s (regmap_optget or Vundef rs) m') + | exec_RBgoto: + forall s f sp pc rs pr m pc', + step_cf_instr (State s f sp pc rs pr m) (RBgoto pc') E0 (State s f sp pc' rs pr m) + | exec_RBpred_cf: + forall s f sp pc rs pr m cf1 cf2 st' p t, + step_cf_instr (State s f sp pc rs pr m) (if eval_predf pr p then cf1 else cf2) t st' -> + step_cf_instr (State s f sp pc rs pr m) (RBpred_cf p cf1 cf2) t st'. End RELSEM. diff --git a/src/hls/RTLPar.v b/src/hls/RTLPar.v index 2e78d36..4986cff 100644 --- a/src/hls/RTLPar.v +++ b/src/hls/RTLPar.v @@ -80,11 +80,11 @@ Section RELSEM. Inductive step: state -> trace -> state -> Prop := | exec_bblock: - forall s f sp pc rs rs' m m' t s' bb, + forall s f sp pc rs rs' m m' t s' bb pr pr', 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' + step_instr_block sp (mk_instr_state rs pr m) bb.(bb_body) (mk_instr_state rs' pr' m') -> + step_cf_instr ge (State s f sp pc rs' pr' m') bb.(bb_exit) t s' -> + step (State s f sp pc rs pr m) t s' | exec_function_internal: forall s f args m m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> @@ -94,6 +94,7 @@ Section RELSEM. (Vptr stk Ptrofs.zero) f.(fn_entrypoint) (init_regs args f.(fn_params)) + (PMap.init false) m') | exec_function_external: forall s ef args res t m m', @@ -101,9 +102,9 @@ Section RELSEM. 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). + forall res f sp pc rs s vres m pr, + step (Returnstate (Stackframe res f sp pc rs pr :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) pr m). End RELSEM. diff --git a/src/hls/RTLParFU.v b/src/hls/RTLParFU.v new file mode 100644 index 0000000..f0ceafd --- /dev/null +++ b/src/hls/RTLParFU.v @@ -0,0 +1,389 @@ +(* + * 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.FunctionalUnits. +Require Import Predicate. +Require Import Vericertlib. + +Definition node := positive. + +Inductive instr : Type := +| FUnop : instr +| FUop : option pred_op -> operation -> list reg -> reg -> instr +| FUread : positive -> positive -> reg -> instr +| FUwrite : positive -> positive -> reg -> instr +| FUsetpred : option pred_op -> condition -> list reg -> predicate -> instr. + +Inductive cf_instr : Type := +| FUcall : signature -> reg + ident -> list reg -> reg -> node -> cf_instr +| FUtailcall : signature -> reg + ident -> list reg -> cf_instr +| FUbuiltin : external_function -> list (builtin_arg reg) -> + builtin_res reg -> node -> cf_instr +| FUcond : condition -> list reg -> node -> node -> cf_instr +| FUjumptable : reg -> list node -> cf_instr +| FUreturn : option reg -> cf_instr +| FUgoto : node -> cf_instr +| FUpred_cf : pred_op -> cf_instr -> cf_instr -> cf_instr. + +Fixpoint successors_instr (i : cf_instr) : list node := + match i with + | FUcall sig ros args res s => s :: nil + | FUtailcall sig ros args => nil + | FUbuiltin ef args res s => s :: nil + | FUcond cond args ifso ifnot => ifso :: ifnot :: nil + | FUjumptable arg tbl => tbl + | FUreturn optarg => nil + | FUgoto n => n :: nil + | FUpred_cf p c1 c2 => concat (successors_instr c1 :: successors_instr c2 :: nil) + end. + +Definition max_reg_instr (m: positive) (i: instr) := + match i with + | FUnop => m + | FUop p op args res => + fold_left Pos.max args (Pos.max res m) + | FUread p1 p2 r => Pos.max m r + | FUwrite p1 p2 r => Pos.max m r + | FUsetpred p' c args p => + fold_left Pos.max args m + end. + +Fixpoint max_reg_cfi (m : positive) (i : cf_instr) := + match i with + | FUcall sig (inl r) args res s => + fold_left Pos.max args (Pos.max r (Pos.max res m)) + | FUcall sig (inr id) args res s => + fold_left Pos.max args (Pos.max res m) + | FUtailcall sig (inl r) args => + fold_left Pos.max args (Pos.max r m) + | FUtailcall sig (inr id) args => + fold_left Pos.max args m + | FUbuiltin ef args res s => + fold_left Pos.max (params_of_builtin_args args) + (fold_left Pos.max (params_of_builtin_res res) m) + | FUcond cond args ifso ifnot => fold_left Pos.max args m + | FUjumptable arg tbl => Pos.max arg m + | FUreturn None => m + | FUreturn (Some arg) => Pos.max arg m + | FUgoto n => m + | FUpred_cf p c1 c2 => Pos.max (max_reg_cfi m c1) (max_reg_cfi m c2) + end. + +Definition regset := Regmap.t val. +Definition predset := PMap.t bool. + +Definition eval_predf (pr: predset) (p: pred_op) := + sat_predicate p (fun x => pr !! (Pos.of_nat x)). + +#[global] + Instance eval_predf_Proper : Proper (eq ==> equiv ==> eq) eval_predf. +Proof. + unfold Proper. simplify. unfold "==>". + intros. + unfold sat_equiv in *. intros. unfold eval_predf. subst. apply H0. +Qed. + +#[local] Open Scope pred_op. + +Lemma eval_predf_Pand : + forall ps p p', + eval_predf ps (p ∧ p') = eval_predf ps p && eval_predf ps p'. +Proof. unfold eval_predf; split; simplify; auto with bool. Qed. + +Lemma eval_predf_Por : + forall ps p p', + eval_predf ps (p ∨ p') = eval_predf ps p || eval_predf ps p'. +Proof. unfold eval_predf; split; simplify; auto with bool. Qed. + +Lemma eval_predf_pr_equiv : + forall p ps ps', + (forall x, ps !! x = ps' !! x) -> + eval_predf ps p = eval_predf ps' p. +Proof. + induction p; simplify; auto; + try (unfold eval_predf; simplify; repeat (destruct_match; []); inv Heqp0; rewrite <- H; auto); + [repeat rewrite eval_predf_Pand|repeat rewrite eval_predf_Por]; + erewrite IHp1; try eassumption; erewrite IHp2; eauto. +Qed. + +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. + +Definition bblock_body := list (list (list instr)). + +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_funct_units: resources; + 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 *) + (pr: predset), (**r predicate state of the 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 *) + (pr: predset) (**r predicate 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. + +Record instr_state := mk_instr_state { + is_rs: regset; + is_ps: predset; + is_mem: mem; + }. + +Definition genv := Genv.t fundef unit. + +Section RELSEM. + + 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 eval_pred: option pred_op -> instr_state -> instr_state -> instr_state -> Prop := + | eval_pred_true: + forall i i' p, + eval_predf (is_ps i) p = true -> + eval_pred (Some p) i i' i' + | eval_pred_false: + forall i i' p, + eval_predf (is_ps i) p = false -> + eval_pred (Some p) i i' i + | eval_pred_none: + forall i i', eval_pred None i i' i. + + Inductive step_instr: val -> instr_state -> instr -> instr_state -> Prop := + | exec_FUnop: + forall sp ist, + step_instr sp ist FUnop ist + | exec_FUop: + forall op v res args rs m sp p ist pr, + eval_operation ge sp op rs##args m = Some v -> + eval_pred p (mk_instr_state rs pr m) (mk_instr_state (rs#res <- v) pr m) ist -> + step_instr sp (mk_instr_state rs pr m) (FUop p op args res) ist + | exec_FUsetpred: + forall sp rs pr m p c b args p' ist, + Op.eval_condition c rs##args m = Some b -> + eval_pred p' (mk_instr_state rs pr m) (mk_instr_state rs (pr#p <- b) m) ist -> + step_instr sp (mk_instr_state rs pr m) (FUsetpred p' c args p) ist. + + Inductive step_instr_list: val -> instr_state -> list instr -> instr_state -> Prop := + | exec_RBcons: + forall state i state' state'' instrs sp, + step_instr 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_seq (sp : val) + : instr_state -> list (list instr) -> instr_state -> Prop := + | exec_instr_seq_cons: + forall state i state' state'' instrs, + step_instr_list sp state i state' -> + step_instr_seq sp state' instrs state'' -> + step_instr_seq sp state (i :: instrs) state'' + | exec_instr_seq_nil: + forall state, + step_instr_seq sp state nil state. + + Inductive step_instr_block (sp : val) + : instr_state -> bblock_body -> instr_state -> Prop := + | exec_instr_block_cons: + forall state i state' state'' instrs, + step_instr_seq 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_cf_instr: state -> cf_instr -> trace -> state -> Prop := + | exec_FUcall: + forall s f sp rs m res fd ros sig args pc pc' pr, + find_function ros rs = Some fd -> + funsig fd = sig -> + step_cf_instr (State s f sp pc rs pr m) (FUcall sig ros args res pc') + E0 (Callstate (Stackframe res f sp pc' rs pr :: s) fd rs##args m) + | exec_FUtailcall: + forall s f stk rs m sig ros args fd m' pc pr, + 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 pr m) (FUtailcall sig ros args) + E0 (Callstate s fd rs##args m') + | exec_FUbuiltin: + forall s f sp rs m ef args res pc' vargs t vres m' pc pr, + 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 pr m) (FUbuiltin ef args res pc') + t (State s f sp pc' (regmap_setres res vres rs) pr m') + | exec_FUcond: + forall s f sp rs m cond args ifso ifnot b pc pc' pr, + eval_condition cond rs##args m = Some b -> + pc' = (if b then ifso else ifnot) -> + step_cf_instr (State s f sp pc rs pr m) (FUcond cond args ifso ifnot) + E0 (State s f sp pc' rs pr m) + | exec_FUjumptable: + forall s f sp rs m arg tbl n pc pc' pr, + rs#arg = Vint n -> + list_nth_z tbl (Int.unsigned n) = Some pc' -> + step_cf_instr (State s f sp pc rs pr m) (FUjumptable arg tbl) + E0 (State s f sp pc' rs pr m) + | exec_FUreturn: + forall s f stk rs m or pc m' pr, + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + step_cf_instr (State s f (Vptr stk Ptrofs.zero) pc rs pr m) (FUreturn or) + E0 (Returnstate s (regmap_optget or Vundef rs) m') + | exec_FUgoto: + forall s f sp pc rs pr m pc', + step_cf_instr (State s f sp pc rs pr m) (FUgoto pc') E0 (State s f sp pc' rs pr m) + | exec_FUpred_cf: + forall s f sp pc rs pr m cf1 cf2 st' p t, + step_cf_instr (State s f sp pc rs pr m) (if eval_predf pr p then cf1 else cf2) t st' -> + step_cf_instr (State s f sp pc rs pr m) (FUpred_cf p cf1 cf2) t st'. + + Inductive step: state -> trace -> state -> Prop := + | exec_bblock: + forall s f sp pc rs rs' m m' t s' bb pr pr', + f.(fn_code)!pc = Some bb -> + step_instr_block sp (mk_instr_state rs pr m) bb.(bb_body) (mk_instr_state rs' pr' m') -> + step_cf_instr (State s f sp pc rs' pr' m') bb.(bb_exit) t s' -> + step (State s f sp pc rs pr 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)) + (PMap.init false) 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 pr, + step (Returnstate (Stackframe res f sp pc rs pr :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) pr 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 (fun x' l' => fold_left max_reg_instr l' x') 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) + (Pos.max (fold_left Pos.max f.(fn_params) 1%positive) + (max_reg_resources f.(fn_funct_units))). + +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/RTLParFUgen.v b/src/hls/RTLParFUgen.v new file mode 100644 index 0000000..55fe4e7 --- /dev/null +++ b/src/hls/RTLParFUgen.v @@ -0,0 +1,178 @@ +(* + * 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.common.AST. +Require Import compcert.common.Errors. +Require compcert.common.Globalenvs. +Require Import 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.Predicate. +Require Import vericert.hls.ValueInt. +Require Import vericert.hls.Verilog. +Require Import vericert.hls.RTLBlockInstr. +Require Import vericert.hls.RTLPar. +Require Import vericert.hls.RTLParFU. +Require Import vericert.hls.FunctionalUnits. + +#[local] Open Scope error_monad_scope. + +Definition update {A: Type} (i: positive) (f: option A -> A) (pt: PTree.t A) := + PTree.set i (f (pt ! i)) pt. + +Definition add_instr (instr_: instr) x := + match x with Some i => instr_ :: i | None => instr_ :: nil end. + +Definition transl_instr (res: resources) (cycle: positive) (i: RTLBlockInstr.instr) + (li: Errors.res (list instr * PTree.t (list instr))): + Errors.res (list instr * PTree.t (list instr)) := + do (instr_list, d_tree) <- li; + match i with + | RBnop => Errors.OK (FUnop :: instr_list, d_tree) + | RBop po op args d => Errors.OK (FUop po op args d :: instr_list, d_tree) + | RBload po chunk addr args d => + match get_ram 0 res with + | Some (ri, r) => + Errors.OK (FUop po Op.Onot (ram_u_en r::nil) (ram_u_en r) + :: FUop po (Op.Ointconst (Int.repr 0)) nil (ram_wr_en r) + :: FUop po (Op.Olea addr) args (ram_addr r) + :: FUop po (Op.Oshruimm (Int.repr 2)) ((ram_addr r)::nil) (ram_addr r) + :: instr_list, update (cycle+1) + (add_instr (FUop po Op.Omove (ram_d_out r::nil) d)) + d_tree) + | _ => Errors.Error (Errors.msg "Could not find RAM") + end + | RBstore po chunk addr args d => + match get_ram 0 res with + | Some (ri, r) => + Errors.OK (FUop po Op.Onot (ram_u_en r::nil) (ram_u_en r) + :: FUop po (Op.Ointconst (Int.repr 1)) nil (ram_wr_en r) + :: FUop po Op.Omove (d::nil) (ram_d_in r) + :: FUop po (Op.Olea addr) args (ram_addr r) + :: FUop po (Op.Oshruimm (Int.repr 2)) ((ram_addr r)::nil) (ram_addr r) + :: instr_list, d_tree) + | _ => Errors.Error (Errors.msg "Could not find RAM") + end + | RBsetpred op c args p => Errors.OK (FUsetpred op c args p :: instr_list, d_tree) + end. + +Fixpoint transl_cf_instr (i: RTLBlockInstr.cf_instr): RTLParFU.cf_instr := + match i with + | RBcall sig r args d n => FUcall sig r args d n + | RBtailcall sig r args => FUtailcall sig r args + | RBbuiltin ef args r n => FUbuiltin ef args r n + | RBcond c args n1 n2 => FUcond c args n1 n2 + | RBjumptable r ns => FUjumptable r ns + | RBreturn r => FUreturn r + | RBgoto n => FUgoto n + | RBpred_cf po c1 c2 => FUpred_cf po (transl_cf_instr c1) (transl_cf_instr c2) + end. + +Definition list_split {A:Type} (l: list (Z * A)) : (list (Z * A)) * (list (Z * A)) := + (filter (fun x => Z.eqb 0 (fst x)) l, + map (fun x => (Z.pred (fst x), snd x)) (filter (fun x => negb (Z.eqb 0 (fst x))) l)). + +Fixpoint map_error {A B : Type} (f : A -> res B) (l : list A) {struct l} : res (list B) := + match l with + | nil => OK nil + | x::xs => + do y <- f x ; + do ys <- map_error f xs ; + OK (y::ys) + end. + +Definition transl_op_chain_block (res: resources) (cycle: positive) (instrs: list RTLBlockInstr.instr) + (state: Errors.res (list (list instr) * PTree.t (list instr))) + : Errors.res (list (list instr) * PTree.t (list instr)) := + do (li, tr) <- state; + do (li', tr') <- fold_right (transl_instr res cycle) (OK (nil, tr)) instrs; + OK (li' :: li, tr'). + +(*Compute transl_op_chain_block initial_resources 10%nat (RBop None (Op.Ointconst (Int.repr 1)) nil 1%positive::RBnop::RBnop::RBnop::nil) (OK (nil, PTree.empty _)).*) + +Definition transl_par_block (res: resources) (cycle: positive) (instrs: list (list RTLBlockInstr.instr)) + (state: Errors.res (list (list (list instr)) * PTree.t (list instr))) + : Errors.res (list (list (list instr)) * PTree.t (list instr)) := + do (li, tr) <- state; + do (li', tr') <- fold_right (transl_op_chain_block res cycle) (OK (nil, tr)) instrs; + OK (li' :: li, tr'). + +(*Compute transl_par_block initial_resources 10%nat ((RBop None (Op.Ointconst (Int.repr 1)) nil 1%positive::RBnop::nil)::(RBop None (Op.Ointconst (Int.repr 2)) nil 2%positive::RBnop::nil)::nil) (OK (((FUnop::nil)::nil)::nil, PTree.empty _)).*) + +Definition transl_seq_block (res: resources) (b: list (list RTLBlockInstr.instr)) + (a: Errors.res (list (list (list instr)) * PTree.t (list instr) * positive)) := + do (litr, n) <- a; + let (li, tr) := litr in + do (li', tr') <- transl_par_block res n b (OK (li, tr)); + OK (li', tr', (n+1)%positive). + +Definition insert_extra (pt: PTree.t (list instr)) (curr: list (list instr)) + (cycle_bb: (positive * list (list (list instr)))) := + let (cycle, bb) := cycle_bb in + match pt ! cycle with + | Some instrs => ((cycle + 1)%positive, (curr ++ (map (fun x => x :: nil) instrs)) :: bb) + | None => ((cycle + 1)%positive, curr :: bb) + end. + +Definition transl_bb (res: resources) (bb: RTLPar.bb): Errors.res RTLParFU.bblock_body := + do (litr, n) <- fold_right (transl_seq_block res) (OK (nil, PTree.empty _, 1%positive)) bb; + let (li, tr) := litr in + OK (snd (fold_right (insert_extra tr) (1%positive, nil) li)). + +Definition transl_bblock (res: resources) (bb: RTLPar.bblock): Errors.res bblock := + do bb' <- transl_bb res (RTLBlockInstr.bb_body bb); + OK (mk_bblock bb' (transl_cf_instr (RTLBlockInstr.bb_exit bb))). + +Definition error_map_ptree {A B: Type} (f: positive -> A -> res B) (pt: PTree.t A) := + do ptl' <- map_error (fun x => do x' <- uncurry f x; OK (fst x, x')) (PTree.elements pt); + OK (PTree_Properties.of_list ptl'). + +Definition transl_code (fu: resources) (c: RTLPar.code): res code := + error_map_ptree (fun _ => transl_bblock fu) c. + +Definition transl_function (f: RTLPar.function): Errors.res RTLParFU.function := + let max := RTLPar.max_reg_function f in + let fu := set_res (Ram (mk_ram + (Z.to_nat (RTLBlockInstr.fn_stacksize f)) + (max+1)%positive + (max+3)%positive + (max+7)%positive + (max+2)%positive + (max+6)%positive + (max+4)%positive + (max+5)%positive + ltac:(lia) + )) initial_resources in + do c' <- transl_code fu (RTLBlockInstr.fn_code f); + Errors.OK (mkfunction (RTLBlockInstr.fn_sig f) + (RTLBlockInstr.fn_params f) + (RTLBlockInstr.fn_stacksize f) + c' + fu + (RTLBlockInstr.fn_entrypoint f)). + +Definition transl_fundef p := + transf_partial_fundef transl_function p. + +Definition transl_program (p : RTLPar.program) : Errors.res RTLParFU.program := + transform_partial_program transl_fundef p. diff --git a/src/hls/RTLPargen.v b/src/hls/RTLPargen.v index aaabe5d..58b048c 100644 --- a/src/hls/RTLPargen.v +++ b/src/hls/RTLPargen.v @@ -1,6 +1,6 @@ (* * Vericert: Verified high-level synthesis. - * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com> + * 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 @@ -19,7 +19,7 @@ Require Import compcert.backend.Registers. Require Import compcert.common.AST. Require Import compcert.common.Globalenvs. -Require compcert.common.Memory. +Require Import compcert.common.Memory. Require Import compcert.common.Values. Require Import compcert.lib.Floats. Require Import compcert.lib.Integers. @@ -30,554 +30,165 @@ Require Import vericert.common.Vericertlib. Require Import vericert.hls.RTLBlock. Require Import vericert.hls.RTLPar. Require Import vericert.hls.RTLBlockInstr. +Require Import vericert.hls.Predicate. +Require Import vericert.hls.Abstr. +Import NE.NonEmptyNotation. (*| -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. +================= +RTLPar Generation +================= |*) -Definition reg := positive. - -Inductive resource : Set := -| Reg : reg -> resource -| Mem : resource. +#[local] Open Scope positive. +#[local] Open Scope forest. +#[local] Open Scope pred_op. (*| -The following defines quite a few equality comparisons automatically, however, these can be -optimised heavily if written manually, as their proofs are not needed. +Abstract Computations +===================== + +Define the abstract computation using the ``update`` function, which will set each register to its +symbolic value. First we need to define a few helper functions to correctly translate the +predicates. |*) -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. +Fixpoint list_translation (l : list reg) (f : forest) {struct l} : list pred_expr := + match l with + | nil => nil + | i :: l => (f # (Reg i)) :: (list_translation l f) + end. -(*| -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. -|*) +Fixpoint replicate {A} (n: nat) (l: A) := + match n with + | O => nil + | S n => l :: replicate n l + end. -Module R_indexed. - Definition t := resource. - Definition index (rs: resource) : positive := - match rs with - | Reg r => xO r - | Mem => 1%positive - end. +Definition merge''' x y := + match x, y with + | Some p1, Some p2 => Some (Pand p1 p2) + | Some p, None | None, Some p => Some p + | None, None => None + end. - Lemma index_inj: forall (x y: t), index x = index y -> x = y. - Proof. destruct x; destruct y; crush. Qed. +Definition merge'' x := + match x with + | ((a, e), (b, el)) => (merge''' a b, Econs e el) + end. - Definition eq := resource_eq. -End R_indexed. +Definition map_pred_op {A B} (pf: option pred_op * (A -> B)) (pa: option pred_op * A): option pred_op * B := + match pa, pf with + | (p, a), (p', f) => (merge''' p p', f a) + end. -(*| -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. +Definition predicated_prod {A B: Type} (p1: predicated A) (p2: predicated B) := + NE.map (fun x => match x with ((a, b), (c, d)) => (Pand a c, (b, d)) end) + (NE.non_empty_prod p1 p2). -- 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. +Definition predicated_map {A B: Type} (f: A -> B) (p: predicated A): predicated B := + NE.map (fun x => (fst x, f (snd x))) p. -Then, to make recursion over expressions easier, expression_list is also defined in the datatype, as -that enables mutual recursive definitions over the datatypes. -|*) +(*map (fun x => (fst x, Econs (snd x) Enil)) pel*) +Definition merge' (pel: pred_expr) (tpel: predicated expression_list) := + predicated_map (uncurry Econs) (predicated_prod pel tpel). -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. +Fixpoint merge (pel: list pred_expr): predicated expression_list := + match pel with + | nil => NE.singleton (T, Enil) + | a :: b => merge' a (merge b) + end. -(*| -Using IMap we can create a map from resources to any other type, as resources can be uniquely -identified as positive numbers. -|*) +Definition map_predicated {A B} (pf: predicated (A -> B)) (pa: predicated A): predicated B := + predicated_map (fun x => (fst x) (snd x)) (predicated_prod pf pa). -Module Rtree := ITree(R_indexed). +Definition predicated_apply1 {A B} (pf: predicated (A -> B)) (pa: A): predicated B := + NE.map (fun x => (fst x, (snd x) pa)) pf. -Definition forest : Type := Rtree.t expression. +Definition predicated_apply2 {A B C} (pf: predicated (A -> B -> C)) (pa: A) (pb: B): predicated C := + NE.map (fun x => (fst x, (snd x) pa pb)) pf. -Definition regset := Registers.Regmap.t val. +Definition predicated_apply3 {A B C D} (pf: predicated (A -> B -> C -> D)) (pa: A) (pb: B) (pc: C): predicated D := + NE.map (fun x => (fst x, (snd x) pa pb pc)) pf. -Definition get_forest v f := - match Rtree.get v f with - | None => Ebase v - | Some v' => v' +Definition predicated_from_opt {A: Type} (p: option pred_op) (a: A) := + match p with + | Some p' => NE.singleton (p', a) + | None => NE.singleton (T, a) 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). +#[local] Open Scope non_empty_scope. +#[local] Open Scope pred_op. -Record sem_state := mk_sem_state { - sem_state_regset : regset; - sem_state_memory : Memory.mem - }. +Fixpoint NEfold_left {A B} (f: A -> B -> A) (l: NE.non_empty B) (a: A) : A := + match l with + | NE.singleton a' => f a a' + | a' ::| b => NEfold_left f b (f a a') + end. -(*| -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. -|*) +Fixpoint NEapp {A} (l m: NE.non_empty A) := + match l with + | NE.singleton a => a ::| m + | a ::| b => a ::| NEapp b m + end. -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 +Definition app_predicated' {A: Type} (a b: predicated A) := + let negation := ¬ (NEfold_left (fun a b => a ∨ (fst b)) b ⟂) in + NEapp (NE.map (fun x => (negation ∧ fst x, snd x)) a) b. + +Definition app_predicated {A: Type} (p: option pred_op) (a b: predicated A) := + match p with + | Some p' => NEapp (NE.map (fun x => (¬ p' ∧ fst x, snd x)) a) + (NE.map (fun x => (p' ∧ fst x, snd x)) b) + | None => b 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 _. +Definition pred_ret {A: Type} (a: A) : predicated A := + NE.singleton (T, a). (*| -This function checks if all the elements in [fa] are in [fb], but not the other way round. -|*) +Update Function +--------------- -Definition check := Rtree.beq beq_expression. +The ``update`` function will generate a new forest given an existing forest and a new instruction, +so that it can evaluate a symbolic expression by folding over a list of instructions. The main +problem is that predicates need to be merged as well, so that: -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. +1. The predicates are *independent*. +2. The expression assigned to the register should still be correct. -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. +This is done by multiplying the predicates together, and assigning the negation of the expression to +the other predicates. |*) -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)) + f # (Reg r) <- + (app_predicated p + (f # (Reg r)) + (map_predicated (pred_ret (Eop op)) (merge (list_translation rl f)))) | RBload p chunk addr rl r => - f # (Reg r) <- (Eload chunk addr (list_translation rl f) (f # Mem)) + f # (Reg r) <- + (app_predicated p + (f # (Reg r)) + (map_predicated + (map_predicated (pred_ret (Eload chunk addr)) (merge (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 - | RBpiped p fu args => f - | RBassign p fu src dst => f + f # Mem <- + (app_predicated p + (f # Mem) + (map_predicated + (map_predicated + (predicated_apply2 (map_predicated (pred_ret Estore) (f # (Reg r))) chunk addr) + (merge (list_translation rl f))) (f # Mem))) + | RBsetpred p' c args p => + f # (Pred p) <- + (app_predicated p' + (f # (Pred p)) + (map_predicated (pred_ret (Esetpred c)) (merge (list_translation args f)))) end. (*| @@ -590,7 +201,7 @@ 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 + | i :: l => abstract_sequence (update f i) l end. (*| @@ -632,37 +243,21 @@ Ltac solve_scheduled_trees_correct := end; repeat destruct_match; crush. Lemma check_scheduled_trees_correct: - forall f1 f2, + forall f1 f2 x y1, 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). + 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, + forall f1 f2 x, check_scheduled_trees f1 f2 = true -> - (forall x, - PTree.get x f1 = None -> - PTree.get x f2 = None). + 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 +Top-level Functions =================== |*) @@ -675,21 +270,11 @@ Definition transl_function (f: RTLBlock.function) : Errors.res RTLPar.function : f.(fn_params) f.(fn_stacksize) tfcode - f.(fn_funct_units) 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_funct_units) - f.(fn_entrypoint)). - -Definition transl_fundef := transf_partial_fundef transl_function_temp. +Definition transl_fundef := transf_partial_fundef transl_function. 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 index eb7931e..588f67f 100644 --- a/src/hls/RTLPargenproof.v +++ b/src/hls/RTLPargenproof.v @@ -30,42 +30,797 @@ Require Import vericert.hls.RTLBlock. Require Import vericert.hls.RTLPar. Require Import vericert.hls.RTLBlockInstr. Require Import vericert.hls.RTLPargen. +Require Import vericert.hls.Predicate. +Require Import vericert.hls.Abstr. + +#[local] Open Scope positive. +#[local] Open Scope forest. +#[local] Open Scope pred_op. + +(*Definition is_regs i := match i with mk_instr_state rs _ => rs end. +Definition is_mem i := match i with mk_instr_state _ m => m end. + +Inductive state_lessdef : instr_state -> instr_state -> Prop := + state_lessdef_intro : + forall rs1 rs2 m1, + (forall x, rs1 !! x = rs2 !! x) -> + state_lessdef (mk_instr_state rs1 m1) (mk_instr_state rs2 m1). + +(*| +RTLBlock to abstract translation +-------------------------------- + +Correctness of translation from RTLBlock to the abstract interpretation language. +|*) + +Ltac inv_simp := + repeat match goal with + | H: exists _, _ |- _ => inv H + end; simplify. + +*) + +Definition check_dest i r' := + match i with + | RBop p op rl r => (r =? r')%positive + | RBload p chunk addr rl r => (r =? r')%positive + | _ => false + end. + +Lemma check_dest_dec i r : {check_dest i r = true} + {check_dest i r = false}. +Proof. destruct (check_dest i r); tauto. Qed. + +Fixpoint check_dest_l l r := + match l with + | nil => false + | a :: b => check_dest a r || check_dest_l b r + end. + +Lemma check_dest_l_forall : + forall l r, + check_dest_l l r = false -> + Forall (fun x => check_dest x r = false) l. +Proof. induction l; crush. Qed. + +Lemma check_dest_l_dec i r : {check_dest_l i r = true} + {check_dest_l i r = false}. +Proof. destruct (check_dest_l i r); tauto. Qed. + +Lemma check_dest_update : + forall f i r, + check_dest i r = false -> + (update f i) # (Reg r) = f # (Reg r). +Proof. + destruct i; crush; try apply Pos.eqb_neq in H; apply genmap1; crush. +Qed. + +Lemma check_dest_l_forall2 : + forall l r, + Forall (fun x => check_dest x r = false) l -> + check_dest_l l r = false. +Proof. + induction l; crush. + inv H. apply orb_false_intro; crush. +Qed. + +Lemma check_dest_l_ex2 : + forall l r, + (exists a, In a l /\ check_dest a r = true) -> + check_dest_l l r = true. +Proof. + induction l; crush. + specialize (IHl r). inv H. + apply orb_true_intro; crush. + apply orb_true_intro; crush. + right. apply IHl. exists x. auto. +Qed. + +Lemma check_list_l_false : + forall l x r, + check_dest_l (l ++ x :: nil) r = false -> + check_dest_l l r = false /\ check_dest x r = false. +Proof. + simplify. + apply check_dest_l_forall in H. apply Forall_app in H. + simplify. apply check_dest_l_forall2; auto. + apply check_dest_l_forall in H. apply Forall_app in H. + simplify. inv H1. auto. +Qed. + +Lemma check_dest_l_ex : + forall l r, + check_dest_l l r = true -> + exists a, In a l /\ check_dest a r = true. +Proof. + induction l; crush. + destruct (check_dest a r) eqn:?; try solve [econstructor; crush]. + simplify. + exploit IHl. apply H. simplify. econstructor. simplify. right. eassumption. + auto. +Qed. + +Lemma check_list_l_true : + forall l x r, + check_dest_l (l ++ x :: nil) r = true -> + check_dest_l l r = true \/ check_dest x r = true. +Proof. + simplify. + apply check_dest_l_ex in H; simplify. + apply in_app_or in H. inv H. left. + apply check_dest_l_ex2. exists x0. auto. + inv H0; auto. +Qed. + +Lemma check_dest_l_dec2 l r : + {Forall (fun x => check_dest x r = false) l} + + {exists a, In a l /\ check_dest a r = true}. +Proof. + destruct (check_dest_l_dec l r); [right | left]; + auto using check_dest_l_ex, check_dest_l_forall. +Qed. + +Lemma abstr_comp : + forall l i f x x0, + abstract_sequence f (l ++ i :: nil) = x -> + abstract_sequence f l = x0 -> + x = update x0 i. +Proof. induction l; intros; crush; eapply IHl; eauto. Qed. + +(* + +Lemma gen_list_base: + forall FF ge sp l rs exps st1, + (forall x, @sem_value FF ge sp st1 (exps # (Reg x)) (rs !! x)) -> + sem_val_list ge sp st1 (list_translation l exps) rs ## l. +Proof. + induction l. + intros. simpl. constructor. + intros. simpl. eapply Scons; eauto. +Qed. + +Lemma check_dest_update2 : + forall f r rl op p, + (update f (RBop p op rl r)) # (Reg r) = Eop op (list_translation rl f) (f # Mem). +Proof. crush; rewrite map2; auto. Qed. + +Lemma check_dest_update3 : + forall f r rl p addr chunk, + (update f (RBload p chunk addr rl r)) # (Reg r) = Eload chunk addr (list_translation rl f) (f # Mem). +Proof. crush; rewrite map2; auto. Qed. + +Lemma abstract_seq_correct_aux: + forall FF ge sp i st1 st2 st3 f, + @step_instr FF ge sp st3 i st2 -> + sem ge sp st1 f st3 -> + sem ge sp st1 (update f i) st2. +Proof. + intros; inv H; simplify. + { simplify; eauto. } (*apply match_states_refl. }*) + { inv H0. inv H6. destruct st1. econstructor. simplify. + constructor. intros. + destruct (resource_eq (Reg res) (Reg x)). inv e. + rewrite map2. econstructor. eassumption. apply gen_list_base; eauto. + rewrite Regmap.gss. eauto. + assert (res <> x). { unfold not in *. intros. apply n. rewrite H0. auto. } + rewrite Regmap.gso by auto. + rewrite genmap1 by auto. auto. + + rewrite genmap1; crush. } + { inv H0. inv H7. constructor. constructor. intros. + destruct (Pos.eq_dec dst x); subst. + rewrite map2. econstructor; eauto. + apply gen_list_base. auto. rewrite Regmap.gss. auto. + rewrite genmap1. rewrite Regmap.gso by auto. auto. + unfold not in *; intros. inv H0. auto. + rewrite genmap1; crush. + } + { inv H0. inv H7. constructor. constructor; intros. + rewrite genmap1; crush. + rewrite map2. econstructor; eauto. + apply gen_list_base; auto. + } +Qed. + +Lemma regmap_list_equiv : + forall A (rs1: Regmap.t A) rs2, + (forall x, rs1 !! x = rs2 !! x) -> + forall rl, rs1##rl = rs2##rl. +Proof. induction rl; crush. Qed. + +Lemma sem_update_Op : + forall A ge sp st f st' r l o0 o m rs v, + @sem A ge sp st f st' -> + Op.eval_operation ge sp o0 rs ## l m = Some v -> + match_states st' (mk_instr_state rs m) -> + exists tst, + sem ge sp st (update f (RBop o o0 l r)) tst /\ match_states (mk_instr_state (Regmap.set r v rs) m) tst. +Proof. + intros. inv H1. simplify. + destruct st. + econstructor. simplify. + { constructor. + { constructor. intros. destruct (Pos.eq_dec x r); subst. + { pose proof (H5 r). rewrite map2. pose proof H. inv H. econstructor; eauto. + { inv H9. eapply gen_list_base; eauto. } + { instantiate (1 := (Regmap.set r v rs0)). rewrite Regmap.gss. erewrite regmap_list_equiv; eauto. } } + { rewrite Regmap.gso by auto. rewrite genmap1; crush. inv H. inv H7; eauto. } } + { inv H. rewrite genmap1; crush. eauto. } } + { constructor; eauto. intros. + destruct (Pos.eq_dec r x); + subst; [repeat rewrite Regmap.gss | repeat rewrite Regmap.gso]; auto. } +Qed. + +Lemma sem_update_load : + forall A ge sp st f st' r o m a l m0 rs v a0, + @sem A ge sp st f st' -> + Op.eval_addressing ge sp a rs ## l = Some a0 -> + Mem.loadv m m0 a0 = Some v -> + match_states st' (mk_instr_state rs m0) -> + exists tst : instr_state, + sem ge sp st (update f (RBload o m a l r)) tst + /\ match_states (mk_instr_state (Regmap.set r v rs) m0) tst. +Proof. + intros. inv H2. pose proof H. inv H. inv H9. + destruct st. + econstructor; simplify. + { constructor. + { constructor. intros. + destruct (Pos.eq_dec x r); subst. + { rewrite map2. econstructor; eauto. eapply gen_list_base. intros. + rewrite <- H6. eauto. + instantiate (1 := (Regmap.set r v rs0)). rewrite Regmap.gss. auto. } + { rewrite Regmap.gso by auto. rewrite genmap1; crush. } } + { rewrite genmap1; crush. eauto. } } + { constructor; auto; intros. destruct (Pos.eq_dec r x); + subst; [repeat rewrite Regmap.gss | repeat rewrite Regmap.gso]; auto. } +Qed. + +Lemma sem_update_store : + forall A ge sp a0 m a l r o f st m' rs m0 st', + @sem A ge sp st f st' -> + Op.eval_addressing ge sp a rs ## l = Some a0 -> + Mem.storev m m0 a0 rs !! r = Some m' -> + match_states st' (mk_instr_state rs m0) -> + exists tst, sem ge sp st (update f (RBstore o m a l r)) tst + /\ match_states (mk_instr_state rs m') tst. +Proof. + intros. inv H2. pose proof H. inv H. inv H9. + destruct st. + econstructor; simplify. + { econstructor. + { econstructor; intros. rewrite genmap1; crush. } + { rewrite map2. econstructor; eauto. eapply gen_list_base. intros. rewrite <- H6. + eauto. specialize (H6 r). rewrite H6. eauto. } } + { econstructor; eauto. } +Qed. + +Lemma sem_update : + forall A ge sp st x st' st'' st''' f, + sem ge sp st f st' -> + match_states st' st''' -> + @step_instr A ge sp st''' x st'' -> + exists tst, sem ge sp st (update f x) tst /\ match_states st'' tst. +Proof. + intros. destruct x; inv H1. + { econstructor. split. + apply sem_update_RBnop. eassumption. + apply match_states_commut. auto. } + { eapply sem_update_Op; eauto. } + { eapply sem_update_load; eauto. } + { eapply sem_update_store; eauto. } +Qed. + +Lemma sem_update2_Op : + forall A ge sp st f r l o0 o m rs v, + @sem A ge sp st f (mk_instr_state rs m) -> + Op.eval_operation ge sp o0 rs ## l m = Some v -> + sem ge sp st (update f (RBop o o0 l r)) (mk_instr_state (Regmap.set r v rs) m). +Proof. + intros. destruct st. constructor. + inv H. inv H6. + { constructor; intros. simplify. + destruct (Pos.eq_dec r x); subst. + { rewrite map2. econstructor. eauto. + apply gen_list_base. eauto. + rewrite Regmap.gss. auto. } + { rewrite genmap1; crush. rewrite Regmap.gso; auto. } } + { simplify. rewrite genmap1; crush. inv H. eauto. } +Qed. + +Lemma sem_update2_load : + forall A ge sp st f r o m a l m0 rs v a0, + @sem A ge sp st f (mk_instr_state rs m0) -> + Op.eval_addressing ge sp a rs ## l = Some a0 -> + Mem.loadv m m0 a0 = Some v -> + sem ge sp st (update f (RBload o m a l r)) (mk_instr_state (Regmap.set r v rs) m0). +Proof. + intros. simplify. inv H. inv H7. constructor. + { constructor; intros. destruct (Pos.eq_dec r x); subst. + { rewrite map2. rewrite Regmap.gss. econstructor; eauto. + apply gen_list_base; eauto. } + { rewrite genmap1; crush. rewrite Regmap.gso; eauto. } + } + { simplify. rewrite genmap1; crush. } +Qed. + +Lemma sem_update2_store : + forall A ge sp a0 m a l r o f st m' rs m0, + @sem A ge sp st f (mk_instr_state rs m0) -> + Op.eval_addressing ge sp a rs ## l = Some a0 -> + Mem.storev m m0 a0 rs !! r = Some m' -> + sem ge sp st (update f (RBstore o m a l r)) (mk_instr_state rs m'). +Proof. + intros. simplify. inv H. inv H7. constructor; simplify. + { econstructor; intros. rewrite genmap1; crush. } + { rewrite map2. econstructor; eauto. apply gen_list_base; eauto. } +Qed. + +Lemma sem_update2 : + forall A ge sp st x st' st'' f, + sem ge sp st f st' -> + @step_instr A ge sp st' x st'' -> + sem ge sp st (update f x) st''. +Proof. + intros. + destruct x; inv H0; + eauto using sem_update_RBnop, sem_update2_Op, sem_update2_load, sem_update2_store. +Qed. + +Lemma abstr_sem_val_mem : + forall A B ge tge st tst sp a, + ge_preserved ge tge -> + forall v m, + (@sem_mem A ge sp st a m /\ match_states st tst -> @sem_mem B tge sp tst a m) /\ + (@sem_value A ge sp st a v /\ match_states st tst -> @sem_value B tge sp tst a v). +Proof. + intros * H. + apply expression_ind2 with + + (P := fun (e1: expression) => + forall v m, + (@sem_mem A ge sp st e1 m /\ match_states st tst -> @sem_mem B tge sp tst e1 m) /\ + (@sem_value A ge sp st e1 v /\ match_states st tst -> @sem_value B tge sp tst e1 v)) + + (P0 := fun (e1: expression_list) => + forall lv, @sem_val_list A ge sp st e1 lv /\ match_states st tst -> @sem_val_list B tge sp tst e1 lv); + simplify; intros; simplify. + { inv H1. inv H2. constructor. } + { inv H2. inv H1. rewrite H0. constructor. } + { inv H3. } + { inv H3. inv H4. econstructor. apply H1; auto. simplify. eauto. constructor. auto. auto. + apply H0; simplify; eauto. constructor; eauto. + unfold ge_preserved in *. simplify. rewrite <- H2. auto. + } + { inv H3. } + { inv H3. inv H4. econstructor. apply H1; eauto; simplify; eauto. constructor; eauto. + apply H0; simplify; eauto. constructor; eauto. + inv H. rewrite <- H4. eauto. + auto. + } + { inv H4. inv H5. econstructor. apply H0; eauto. simplify; eauto. constructor; eauto. + apply H2; eauto. simplify; eauto. constructor; eauto. + apply H1; eauto. simplify; eauto. constructor; eauto. + inv H. rewrite <- H5. eauto. auto. + } + { inv H4. } + { inv H1. constructor. } + { inv H3. constructor; auto. apply H0; eauto. apply Mem.empty. } +Qed. + +Lemma abstr_sem_value : + forall a A B ge tge sp st tst v, + @sem_value A ge sp st a v -> + ge_preserved ge tge -> + match_states st tst -> + @sem_value B tge sp tst a v. +Proof. intros; eapply abstr_sem_val_mem; eauto; apply Mem.empty. Qed. + +Lemma abstr_sem_mem : + forall a A B ge tge sp st tst v, + @sem_mem A ge sp st a v -> + ge_preserved ge tge -> + match_states st tst -> + @sem_mem B tge sp tst a v. +Proof. intros; eapply abstr_sem_val_mem; eauto. Qed. + +Lemma abstr_sem_regset : + forall a a' A B ge tge sp st tst rs, + @sem_regset A ge sp st a rs -> + ge_preserved ge tge -> + (forall x, a # x = a' # x) -> + match_states st tst -> + exists rs', @sem_regset B tge sp tst a' rs' /\ (forall x, rs !! x = rs' !! x). +Proof. + inversion 1; intros. + inv H7. + econstructor. simplify. econstructor. intros. + eapply abstr_sem_value; eauto. rewrite <- H6. + eapply H0. constructor; eauto. + auto. +Qed. + +Lemma abstr_sem : + forall a a' A B ge tge sp st tst st', + @sem A ge sp st a st' -> + ge_preserved ge tge -> + (forall x, a # x = a' # x) -> + match_states st tst -> + exists tst', @sem B tge sp tst a' tst' /\ match_states st' tst'. +Proof. + inversion 1; subst; intros. + inversion H4; subst. + exploit abstr_sem_regset; eauto; inv_simp. + do 3 econstructor; eauto. + rewrite <- H3. + eapply abstr_sem_mem; eauto. +Qed. + +Lemma abstract_execution_correct': + forall A B ge tge sp st' a a' st tst, + @sem A ge sp st a st' -> + ge_preserved ge tge -> + check a a' = true -> + match_states st tst -> + exists tst', @sem B tge sp tst a' tst' /\ match_states st' tst'. +Proof. + intros; + pose proof (check_correct a a' H1); + eapply abstr_sem; eauto. +Qed. + +Lemma states_match : + forall st1 st2 st3 st4, + match_states st1 st2 -> + match_states st2 st3 -> + match_states st3 st4 -> + match_states st1 st4. +Proof. + intros * H1 H2 H3; destruct st1; destruct st2; destruct st3; destruct st4. + inv H1. inv H2. inv H3; constructor. + unfold regs_lessdef in *. intros. + repeat match goal with + | H: forall _, _, r : positive |- _ => specialize (H r) + end. + congruence. + auto. +Qed. + +Lemma step_instr_block_same : + forall ge sp st st', + step_instr_block ge sp st nil st' -> + st = st'. +Proof. inversion 1; auto. Qed. + +Lemma step_instr_seq_same : + forall ge sp st st', + step_instr_seq ge sp st nil st' -> + st = st'. +Proof. inversion 1; auto. Qed. + +Lemma sem_update' : + forall A ge sp st a x st', + sem ge sp st (update (abstract_sequence empty a) x) st' -> + exists st'', + @step_instr A ge sp st'' x st' /\ + sem ge sp st (abstract_sequence empty a) st''. +Proof. + Admitted. + +Lemma rtlpar_trans_correct : + forall bb ge sp sem_st' sem_st st, + sem ge sp sem_st (abstract_sequence empty (concat (concat bb))) sem_st' -> + match_states sem_st st -> + exists st', RTLPar.step_instr_block ge sp st bb st' + /\ match_states sem_st' st'. +Proof. + induction bb using rev_ind. + { repeat econstructor. eapply abstract_interp_empty3 in H. + inv H. inv H0. constructor; congruence. } + { simplify. inv H0. repeat rewrite concat_app in H. simplify. + rewrite app_nil_r in H. + exploit sem_separate; eauto; inv_simp. + repeat econstructor. admit. admit. + } +Admitted. + +(*Lemma abstract_execution_correct_ld: + forall bb bb' cfi ge tge sp st st' tst, + RTLBlock.step_instr_list ge sp st bb st' -> + ge_preserved ge tge -> + schedule_oracle (mk_bblock bb cfi) (mk_bblock bb' cfi) = true -> + match_states_ld st tst -> + exists tst', RTLPar.step_instr_block tge sp tst bb' tst' + /\ match_states st' tst'. +Proof. + intros.*) +*) + +Lemma match_states_list : + forall A (rs: Regmap.t A) rs', + (forall r, rs !! r = rs' !! r) -> + forall l, rs ## l = rs' ## l. +Proof. induction l; crush. Qed. + +Lemma PTree_matches : + forall A (v: A) res rs rs', + (forall r, rs !! r = rs' !! r) -> + forall x, (Regmap.set res v rs) !! x = (Regmap.set res v rs') !! x. +Proof. + intros; destruct (Pos.eq_dec x res); subst; + [ repeat rewrite Regmap.gss by auto + | repeat rewrite Regmap.gso by auto ]; auto. +Qed. + +Lemma abstract_interp_empty3 : + forall A ctx st', + @sem A ctx empty st' -> match_states (ctx_is ctx) st'. +Proof. + inversion 1; subst; simplify. destruct ctx. + destruct ctx_is. + constructor; intros. + - inv H0. specialize (H3 x). inv H3. inv H8. reflexivity. + - inv H1. specialize (H3 x). inv H3. inv H8. reflexivity. + - inv H2. inv H8. reflexivity. +Qed. + +Lemma step_instr_matches : + forall A a ge sp st st', + @step_instr A ge sp st a st' -> + forall tst, + match_states st tst -> + exists tst', step_instr ge sp tst a tst' + /\ match_states st' tst'. +Proof. + induction 1; simplify; + match goal with H: match_states _ _ |- _ => inv H end; + try solve [repeat econstructor; try erewrite match_states_list; + try apply PTree_matches; eauto; + match goal with + H: forall _, _ |- context[Mem.storev] => erewrite <- H; eauto + end]. + - destruct p. match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + erewrite <- eval_predf_pr_equiv; eassumption. + apply PTree_matches; assumption. + repeat (econstructor; try apply eval_pred_false); eauto. try erewrite match_states_list; eauto. + erewrite <- eval_predf_pr_equiv; eassumption. + econstructor; auto. + match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + - destruct p. match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + erewrite <- eval_predf_pr_equiv; eassumption. + apply PTree_matches; assumption. + repeat (econstructor; try apply eval_pred_false); eauto. try erewrite match_states_list; eauto. + erewrite <- eval_predf_pr_equiv; eassumption. + econstructor; auto. + match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + - destruct p. match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + match goal with + H: forall _, _ |- context[Mem.storev] => erewrite <- H; eauto + end. + erewrite <- eval_predf_pr_equiv; eassumption. + repeat (econstructor; try apply eval_pred_false); eauto. try erewrite match_states_list; eauto. + match goal with + H: forall _, _ |- context[Mem.storev] => erewrite <- H; eauto + end. + erewrite <- eval_predf_pr_equiv; eassumption. + match goal with H: eval_pred _ _ _ _ |- _ => inv H end. + repeat econstructor; try erewrite match_states_list; eauto. + match goal with + H: forall _, _ |- context[Mem.storev] => erewrite <- H; eauto + end. + - admit. Admitted. + +Lemma step_instr_list_matches : + forall a ge sp st st', + step_instr_list ge sp st a st' -> + forall tst, match_states st tst -> + exists tst', step_instr_list ge sp tst a tst' + /\ match_states st' tst'. +Proof. + induction a; intros; inv H; + try (exploit step_instr_matches; eauto; []; simplify; + exploit IHa; eauto; []; simplify); repeat econstructor; eauto. +Qed. + +Lemma step_instr_seq_matches : + forall a ge sp st st', + step_instr_seq ge sp st a st' -> + forall tst, match_states st tst -> + exists tst', step_instr_seq ge sp tst a tst' + /\ match_states st' tst'. +Proof. + induction a; intros; inv H; + try (exploit step_instr_list_matches; eauto; []; simplify; + exploit IHa; eauto; []; simplify); repeat econstructor; eauto. +Qed. + +Lemma step_instr_block_matches : + forall bb ge sp st st', + step_instr_block ge sp st bb st' -> + forall tst, match_states st tst -> + exists tst', step_instr_block ge sp tst bb tst' + /\ match_states st' tst'. +Proof. + induction bb; intros; inv H; + try (exploit step_instr_seq_matches; eauto; []; simplify; + exploit IHbb; eauto; []; simplify); repeat econstructor; eauto. +Qed. + +Lemma rtlblock_trans_correct' : + forall bb ge sp st x st'', + RTLBlock.step_instr_list ge sp st (bb ++ x :: nil) st'' -> + exists st', RTLBlock.step_instr_list ge sp st bb st' + /\ step_instr ge sp st' x st''. +Proof. + induction bb. + crush. exists st. + split. constructor. inv H. inv H6. auto. + crush. inv H. exploit IHbb. eassumption. simplify. + econstructor. split. + econstructor; eauto. eauto. +Qed. + +Lemma abstract_interp_empty A st : @sem A st empty (ctx_is st). +Proof. destruct st, ctx_is. simpl. repeat econstructor. Qed. + +Lemma abstract_seq : + forall l f i, + abstract_sequence f (l ++ i :: nil) = update (abstract_sequence f l) i. +Proof. induction l; crush. Qed. + +Lemma abstract_sequence_update : + forall l r f, + check_dest_l l r = false -> + (abstract_sequence f l) # (Reg r) = f # (Reg r). +Proof. + induction l using rev_ind; crush. + rewrite abstract_seq. rewrite check_dest_update. apply IHl. + apply check_list_l_false in H. tauto. + apply check_list_l_false in H. tauto. +Qed. + +(*Lemma sem_separate : + forall A ctx b a st', + sem ctx (abstract_sequence empty (a ++ b)) st' -> + exists st'', + @sem A ctx (abstract_sequence empty a) st'' + /\ @sem A (mk_ctx st'' (ctx_sp ctx) (ctx_ge ctx)) (abstract_sequence empty b) st'. +Proof. + induction b using rev_ind; simplify. + { econstructor. simplify. rewrite app_nil_r in H. eauto. apply abstract_interp_empty. } + { simplify. rewrite app_assoc in H. rewrite abstract_seq in H. + exploit sem_update'; eauto; simplify. + exploit IHb; eauto; inv_simp. + econstructor; split; eauto. + rewrite abstract_seq. + eapply sem_update2; eauto. + } +Qed.*) + +Lemma sem_update_RBnop : + forall A ctx f st', + @sem A ctx f st' -> sem ctx (update f RBnop) st'. +Proof. auto. Qed. + +Lemma sem_update_Op : + forall A ge sp ist f st' r l o0 o m rs v ps, + @sem A (mk_ctx ist sp ge) f st' -> + eval_predf ps o = true -> + Op.eval_operation ge sp o0 (rs ## l) m = Some v -> + match_states st' (mk_instr_state rs ps m) -> + exists tst, + sem (mk_ctx ist sp ge) (update f (RBop (Some o) o0 l r)) tst + /\ match_states (mk_instr_state (Regmap.set r v rs) ps m) tst. +Proof. + intros. inv H1. inv H. inv H1. inv H3. simplify. + econstructor. simplify. + { constructor; try constructor; intros; try solve [rewrite genmap1; now eauto]. + destruct (Pos.eq_dec x r); subst. + { rewrite map2. specialize (H1 r). inv H1. +(*} + } + destruct st. + econstructor. simplify. + { constructor. + { constructor. intros. destruct (Pos.eq_dec x r); subst. + { pose proof (H5 r). rewrite map2. pose proof H. inv H. econstructor; eauto. + { inv H9. eapply gen_list_base; eauto. } + { instantiate (1 := (Regmap.set r v rs0)). rewrite Regmap.gss. erewrite regmap_list_equiv; eauto. } } + { rewrite Regmap.gso by auto. rewrite genmap1; crush. inv H. inv H7; eauto. } } + { inv H. rewrite genmap1; crush. eauto. } } + { constructor; eauto. intros. + destruct (Pos.eq_dec r x); + subst; [repeat rewrite Regmap.gss | repeat rewrite Regmap.gso]; auto. } +Qed.*) Admitted. + +Lemma sem_update : + forall A ge sp st x st' st'' st''' f, + sem (mk_ctx st sp ge) f st' -> + match_states st' st''' -> + @step_instr A ge sp st''' x st'' -> + exists tst, sem (mk_ctx st sp ge) (update f x) tst /\ match_states st'' tst. +Proof. + intros. destruct x. + - inv H1. econstructor. simplify. eauto. symmetry; auto. + - inv H1. inv H0. econstructor. + Admitted. + +Lemma rtlblock_trans_correct : + forall bb ge sp st st', + RTLBlock.step_instr_list ge sp st bb st' -> + forall tst, + match_states st tst -> + exists tst', sem (mk_ctx tst sp ge) (abstract_sequence empty bb) tst' + /\ match_states st' tst'. +Proof. + induction bb using rev_ind; simplify. + { econstructor. simplify. apply abstract_interp_empty. + inv H. auto. } + { apply rtlblock_trans_correct' in H. simplify. + rewrite abstract_seq. + exploit IHbb; try eassumption; []; simplify. + exploit sem_update. apply H1. symmetry; eassumption. + eauto. simplify. econstructor. split. apply H3. + auto. } +Qed. + +Lemma abstract_execution_correct: + forall bb bb' cfi cfi' ge tge sp st st' tst, + RTLBlock.step_instr_list ge sp st bb st' -> + ge_preserved ge tge -> + schedule_oracle (mk_bblock bb cfi) (mk_bblock bb' cfi') = true -> + match_states st tst -> + exists tst', RTLPar.step_instr_block tge sp tst bb' tst' + /\ match_states st' tst'. +Proof. + intros. + unfold schedule_oracle in *. simplify. unfold empty_trees in H4. + exploit rtlblock_trans_correct; try eassumption; []; simplify. +(*) exploit abstract_execution_correct'; + try solve [eassumption | apply state_lessdef_match_sem; eassumption]. + apply match_states_commut. eauto. inv_simp. + exploit rtlpar_trans_correct; try eassumption; []; inv_simp. + exploit step_instr_block_matches; eauto. apply match_states_commut; eauto. inv_simp. + repeat match goal with | H: match_states _ _ |- _ => inv H end. + do 2 econstructor; eauto. + econstructor; congruence. +Qed.*)Admitted. 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', + forall f tf res sp pc rs rs' ps ps', transl_function f = OK tf -> - regs_lessdef rs rs' -> - match_stackframes (Stackframe res f sp pc rs) - (Stackframe res tf sp pc rs'). + (forall x, rs !! x = rs' !! x) -> + (forall x, ps !! x = ps' !! x) -> + match_stackframes (Stackframe res f sp pc rs ps) + (Stackframe res tf sp pc rs' ps'). Inductive match_states: RTLBlock.state -> RTLPar.state -> Prop := | match_state: - forall sf f sp pc rs rs' m m' sf' tf + forall sf f sp pc rs rs' m sf' tf ps ps' (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') + (REG: forall x, rs !! x = rs' !! x) + (REG: forall x, ps !! x = ps' !! x), + match_states (State sf f sp pc rs ps m) + (State sf' tf sp pc rs' ps' 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'), + forall stack stack' v m + (STACKS: list_forall2 match_stackframes stack stack'), match_states (Returnstate stack v m) - (Returnstate stack' v' m') + (Returnstate stack' v m) | match_callstate: - forall stack stack' f tf args args' m m' + forall stack stack' f tf args 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'), + (STACKS: list_forall2 match_stackframes stack stack'), match_states (Callstate stack f args m) - (Callstate stack' tf args' m'). + (Callstate stack' tf args m). Section CORRECTNESS. @@ -121,7 +876,7 @@ Section CORRECTNESS. Lemma find_function_translated: forall ros rs rs' f, - regs_lessdef rs rs' -> + (forall x, rs !! x = rs' !! x) -> find_function ge ros rs = Some f -> exists tf, find_function tge ros rs' = Some tf /\ transl_fundef f = OK tf. @@ -134,7 +889,7 @@ Section CORRECTNESS. | [ H: Genv.find_funct _ Vundef = Some _ |- _] => solve [inv H] | _ => solve [exploit functions_translated; eauto] end. - unfold regs_lessdef; destruct ros; simplify; try rewrite <- H; + destruct ros; simplify; try rewrite <- H; [| rewrite symbols_preserved; destruct_match; try (apply function_ptr_translated); crush ]; intros; @@ -160,8 +915,8 @@ Section CORRECTNESS. 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. + forall (sp0 : Values.val) (op : Op.operation) (vl : list Values.val) m, + Op.eval_operation ge sp0 op vl m = Op.eval_operation tge sp0 op vl m. Proof using TRANSL. intros. destruct op; auto; unfold Op.eval_operation, Genv.symbol_address, Op.eval_addressing32; @@ -197,6 +952,16 @@ Section CORRECTNESS. Proof using. destruct or; crush. Qed. Hint Resolve lessdef_regmap_optget : rtlgp. + Lemma regmap_equiv_lessdef: + forall rs rs', + (forall x, rs !! x = rs' !! x) -> + regs_lessdef rs rs'. + Proof using. + intros; unfold regs_lessdef; intros. + rewrite H. apply Val.lessdef_refl. + Qed. + Hint Resolve regmap_equiv_lessdef : rtlgp. + Lemma int_lessdef: forall rs rs', regs_lessdef rs rs' -> @@ -227,8 +992,8 @@ Section CORRECTNESS. 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: find_function _ _ _ = Some _, H2: forall x, ?rs !! x = ?rs' !! x |- _ ] => + learn H; exploit find_function_translated; try apply H2; 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' |- _ ] => @@ -249,6 +1014,29 @@ Section CORRECTNESS. Hint Resolve set_reg_lessdef : rtlgp. Hint Resolve Op.eval_condition_lessdef : rtlgp. + Hint Constructors Events.eval_builtin_arg: barg. + + Lemma eval_builtin_arg_eq: + forall A ge a v1 m1 e1 e2 sp, + (forall x, e1 x = e2 x) -> + @Events.eval_builtin_arg A ge e1 sp m1 a v1 -> + Events.eval_builtin_arg ge e2 sp m1 a v1. +Proof. induction 2; try rewrite H; eauto with barg. Qed. + + Lemma eval_builtin_args_eq: + forall A ge e1 sp m1 e2 al vl1, + (forall x, e1 x = e2 x) -> + @Events.eval_builtin_args A ge e1 sp m1 al vl1 -> + Events.eval_builtin_args ge e2 sp m1 al vl1. + Proof. + induction 2. + - econstructor; split. + - exploit eval_builtin_arg_eq; eauto. intros. + destruct IHlist_forall2 as [| y]. constructor; eauto. + constructor. constructor; auto. + constructor; eauto. + Qed. + Lemma step_cf_instr_correct: forall cfi t s s', step_cf_instr ge s cfi t s' -> @@ -257,7 +1045,26 @@ Section CORRECTNESS. 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). + try solve [repeat (try erewrite match_states_list; eauto; econstructor; eauto with rtlgp)]. + { do 3 (try erewrite match_states_list by eauto; econstructor; eauto with rtlgp). + eapply eval_builtin_args_eq. eapply REG. + eapply Events.eval_builtin_args_preserved. eapply symbols_preserved. + eauto. + intros. + unfold regmap_setres. destruct res. + destruct (Pos.eq_dec x0 x); subst. + repeat rewrite Regmap.gss; auto. + repeat rewrite Regmap.gso; auto. + eapply REG. eapply REG. + } + { repeat (try erewrite match_states_list; eauto; econstructor; eauto with rtlgp). + unfold regmap_optget. destruct or. rewrite REG. constructor; eauto. + constructor; eauto. + } + { exploit IHstep_cf_instr; eauto. simplify. + repeat (try erewrite match_states_list; eauto; econstructor; eauto with rtlgp). + erewrite eval_predf_pr_equiv; eauto. + } Qed. Theorem transl_step_correct : @@ -269,20 +1076,65 @@ Section CORRECTNESS. 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. } + + { destruct bb; destruct x. + assert (bb_exit = bb_exit0). + { unfold schedule_oracle in *. simplify. + unfold check_control_flow_instr in *. + destruct_match; crush. + } + subst. + + exploit abstract_execution_correct; try eassumption. eapply ge_preserved_lem. + econstructor; eauto. + simplify. destruct x. inv H7. + + exploit step_cf_instr_correct; try eassumption. econstructor; eauto. + simplify. + + econstructor. econstructor. eapply Smallstep.plus_one. econstructor. + eauto. eauto. simplify. eauto. eauto. } + { unfold bind in *. inv TRANSL0. clear Learn. inv H0. destruct_match; crush. + inv H2. unfold transl_function in Heqr. destruct_match; crush. + inv Heqr. + repeat econstructor; eauto. + unfold bind in *. destruct_match; crush. } { 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.*) + { inv STACKS. inv H2. repeat econstructor; eauto. + intros. apply PTree_matches; eauto. } + Qed. + + Lemma transl_initial_states: + forall S, + RTLBlock.initial_state prog S -> + exists R, RTLPar.initial_state tprog R /\ match_states S R. + Proof. + induction 1. + exploit function_ptr_translated; eauto. intros [tf [A B]]. + econstructor; split. + econstructor. apply (Genv.init_mem_transf_partial TRANSL); eauto. + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved; eauto. + symmetry; eapply match_program_main; eauto. + eexact A. + rewrite <- H2. apply sig_transl_function; auto. + constructor. auto. constructor. + Qed. + + Lemma transl_final_states: + forall S R r, + match_states S R -> RTLBlock.final_state S r -> RTLPar.final_state R r. + Proof. + intros. inv H0. inv H. inv STACKS. constructor. + Qed. + + Theorem transf_program_correct: + Smallstep.forward_simulation (RTLBlock.semantics prog) (RTLPar.semantics tprog). + Proof. + eapply Smallstep.forward_simulation_plus. + apply senv_preserved. + eexact transl_initial_states. + eexact transl_final_states. + exact transl_step_correct. + Qed. End CORRECTNESS. diff --git a/src/hls/Sat.v b/src/hls/Sat.v index 9549947..b7596f6 100644 --- a/src/hls/Sat.v +++ b/src/hls/Sat.v @@ -1,38 +1,21 @@ -(** Homework Assignment 6#<br># +(** #<a href="http://www.cs.berkeley.edu/~adamc/itp/">#Interactive Computer Theorem Proving#</a><br># CS294-9, Fall 2006#<br># UC Berkeley *) -(** Submit your solution file for this assignment as an attachment - #<a href="mailto:adamc@cs.berkeley.edu?subject=ICTP HW6">#by e-mail#</a># with - the subject "ICTP HW6" by the start of class on October 12. - You should write your solutions entirely on your own, which includes not - consulting any solutions to these problems that may be posted on the web. - - #<a href="HW6.v">#Template source file#</a># - *) - Require Import Arith Bool List. +Require Import Coq.funind.Recdef. +Require Coq.MSets.MSetList. +Require Import Coq.Structures.OrderedTypeEx. +Require Import Coq.Structures.OrdersAlt. +Require Import Coq.Program.Wf. +Require Import Vericertlib. -(** This assignment involves building a certified boolean satisfiability solver - based on the DPLL algorithm. Your certified procedure will take as input a - boolean formula in conjunctive normal form (CNF) and either return a - satisfying assignment to the variables or a value signifying that the input - formula is unsatisfiable. Moreover, the procedure will be implemented with a - rich specification, so you'll know that the answer it gives is correct. By - the end of the assignment, you'll have extracted OCaml code that can be used - to solve some of the more modest classes of problems in the SATLIB archive. - - If you need to page in the relevant background material, try the Wikipedia - pages on - #<a href="http://en.wikipedia.org/wiki/Boolean_satisfiability_problem">#SAT#</a># - and - #<a href="http://en.wikipedia.org/wiki/DPLL_algorithm">#the DPLL - algorithm#</a>#. The implementation we'll develop here omits the pure literal - heuristic mentioned on the Wikipedia page but is otherwise identical. - *) +Module Nat_OT := Update_OT Nat_as_OT. +Module NSet := MSetList.Make Nat_OT. +#[local] Open Scope nat. (** * Problem Definition *) @@ -57,77 +40,22 @@ Definition satLit (l : lit) (a : asgn) := Fixpoint satClause (cl : clause) (a : asgn) {struct cl} : Prop := match cl with - | nil => False - | l :: cl' => satLit l a \/ satClause cl' a + | nil => False + | l :: cl' => satLit l a \/ satClause cl' a end. (** An assignment satisfies a clause if it satisfies at least one of its literals. - *) + *) Fixpoint satFormula (fm: formula) (a: asgn) {struct fm} : Prop := match fm with - | nil => True - | cl :: fm' => satClause cl a /\ satFormula fm' a + | nil => True + | cl :: fm' => satClause cl a /\ satFormula fm' a end. (** An assignment satisfies a formula if it satisfies all of its clauses. *) (** * Subroutines *) -(** This is the only section of this assignment where you need to provide your - own solutions. You will be implementing four crucial subroutines used by - DPLL. - - I've provided a number of useful definitions and lemmas which you should feel - free to take advantage of in your definitions. A few tips to keep in mind - while writing these strongly specified functions: - - You have a case-by-case choice of a "programming" approach, based around the - [refine] tactic; or a "proving" approach, where the "code" parts of your - definitions are constructed step by step with tactics. The former is often - harder to get started with, but it tends to be more maintainable. - - When you use [refine] with a [fix] expression, it's usually a good idea to - use the [clear] tactic to remove the recursive function name from the - context immediately afterward. This is because Coq won't check that you - call this function with strictly smaller arguments until the whole proof is - done, and it's a real downer to be told you had an invalid recursion - somewhere after you finally "finish" a proof. Instead, make all recursive - calls explicit in the [refine] argument and clear the function name - afterward. - - You'll probably end up with a lot of proof obligations to discharge, and you - definitely won't want to prove most of them manually. These tactics will - probably be your best friends here: [intuition], [firstorder], [eauto], - [simpl], [subst], .... You will probably want to follow your [refine] tactics - with semicolons and strings of semicolon-separated tactics. These strings - should probably start out with basic simplifiers like [intros], [simpl], and - [subst]. - - A word of warning about the [firstorder] tactic: When it works, it works - really well! However, this tactic has a way of running forever on - complicated enough goals. Be ready to cancel its use (e.g., press the - "Stop" button in Proof General) if it takes more than a few seconds. If - you do things the way I have, be prepared to mix and match all sorts of - different combinations of the automating tactics to get a proof script that - solves the problem quickly enough. - - The dependent type families that we use with rich specifications are all - defined in #<a href="http://coq.inria.fr/library/Coq.Init.Specif.html">#the - Specif module#</a># of the Coq standard library. One potential gotcha when - using them comes from the fact that they are defined inductively with - parameters; that is, some arguments to these type families are defined - before the colon in the [Inductive] command. Compared to general arguments - stemming from function types after that colon, usage of parameters is - restricted; they aren't allowed to vary in recursive occurrences of the - type being defined, for instance. Because of this, parameters are ignored - for the purposes of pattern-matching, while they must be passed when - actually constructing new values. For instance, one would pattern-match a - value of a [sig] type with a pattern like [exist x pf], while one would - construct a new value of the same type like [exist _ x pf]. The parameter - [P] is passed in the second case, and we use an underscore when the Coq - type-checker ought to be able to infer its value. When this inference isn't - possible, you may need to specify manually the predicate defining the [sig] - type you want. - - You can also consult the sizeable example at the end of this file, which ties - together the pieces you are supposed to write. - *) - (** You'll probably want to compare booleans for equality at some point. *) Definition bool_eq_dec : forall (x y : bool), {x = y} + {x <> y}. decide equality. @@ -135,10 +63,10 @@ Defined. (** A literal and its negation can't be true simultaneously. *) Lemma contradictory_assignment : forall s l cl a, - s <> fst l - -> satLit l a - -> satLit (s, snd l) a - -> satClause cl a. + s <> fst l + -> satLit l a + -> satLit (s, snd l) a + -> satClause cl a. intros. red in H0, H1. simpl in H1. @@ -146,79 +74,68 @@ Lemma contradictory_assignment : forall s l cl a, tauto. Qed. -Local Hint Resolve contradictory_assignment : core. +#[local] Hint Resolve contradictory_assignment : core. (** Augment an assignment with a new mapping. *) Definition upd (a : asgn) (l : lit) : asgn := fun v : var => if eq_nat_dec v (snd l) - then fst l - else a v. + then fst l + else a v. (** Some lemmas about [upd] *) Lemma satLit_upd_eq : forall l a, - satLit l (upd a l). + satLit l (upd a l). unfold satLit, upd; simpl; intros. destruct (eq_nat_dec (snd l) (snd l)); tauto. Qed. -Local Hint Resolve satLit_upd_eq : core. +#[local] Hint Resolve satLit_upd_eq : core. Lemma satLit_upd_neq : forall v l s a, - v <> snd l - -> satLit (s, v) (upd a l) - -> satLit (s, v) a. + v <> snd l + -> satLit (s, v) (upd a l) + -> satLit (s, v) a. unfold satLit, upd; simpl; intros. destruct (eq_nat_dec v (snd l)); tauto. Qed. -Local Hint Resolve satLit_upd_neq : core. +#[local] Hint Resolve satLit_upd_neq : core. Lemma satLit_upd_neq2 : forall v l s a, - v <> snd l - -> satLit (s, v) a - -> satLit (s, v) (upd a l). + v <> snd l + -> satLit (s, v) a + -> satLit (s, v) (upd a l). unfold satLit, upd; simpl; intros. destruct (eq_nat_dec v (snd l)); tauto. Qed. -Local Hint Resolve satLit_upd_neq2 : core. +#[local] Hint Resolve satLit_upd_neq2 : core. Lemma satLit_contra : forall s l a cl, - s <> fst l - -> satLit (s, snd l) (upd a l) - -> satClause cl a. + s <> fst l + -> satLit (s, snd l) (upd a l) + -> satClause cl a. unfold satLit, upd; simpl; intros. destruct (eq_nat_dec (snd l) (snd l)); intuition. assert False; intuition. Qed. -Local Hint Resolve satLit_contra : core. - -(** Here's the tactic that I used to discharge #<i>#all#</i># proof obligations - in my implementations of the four functions you will define. - It comes with no warranty, as different implementations may lead to - obligations that it can't solve, or obligations that it takes 42 years to - solve. - However, if you think enough like me, each of the four definitions you fill in - should read like: [[ -refine some_expression_with_holes; clear function_name; magic_solver. -]] leaving out the [clear] invocation for non-recursive function definitions. - *) +#[local] Hint Resolve satLit_contra : core. + Ltac magic_solver := simpl; intros; subst; intuition eauto; firstorder; - match goal with - | [ H1 : satLit ?l ?a, H2 : satClause ?cl ?a |- _ ] => - assert (satClause cl (upd a l)); firstorder - end. + match goal with + | [ H1 : satLit ?l ?a, H2 : satClause ?cl ?a |- _ ] => + assert (satClause cl (upd a l)); firstorder + end. -(** OK, here's your first challenge. Write this strongly-specified function to - update a clause to reflect the effect of making a particular literal true. - *) +(** Strongly-specified function to update a clause to reflect the effect of making a particular + literal true. *) Definition setClause : forall (cl : clause) (l : lit), - {cl' : clause | - forall a, satClause cl (upd a l) <-> satClause cl' a} - + {forall a, satLit l a -> satClause cl a}. + {cl' : clause | + forall a, satClause cl (upd a l) <-> satClause cl' a} + + {forall a, satLit l a -> satClause cl a}. refine (fix setClause (cl: clause) (l: lit) {struct cl} := match cl with | nil => inleft (exist _ nil _) @@ -247,20 +164,13 @@ Defined. (** For testing purposes, we define a weakly-specified function as a thin wrapper around [setClause]. - *) + *) Definition setClauseSimple (cl : clause) (l : lit) := match setClause cl l with - | inleft (exist _ cl' _) => Some cl' - | inright _ => None + | inleft (exist _ cl' _) => Some cl' + | inright _ => None end. -(** When your [setClause] implementation is done, you should be able to - uncomment these test cases and verify that each one yields the correct answer. - Be sure that your [setClause] definition ends in [Defined] and not [Qed], as - the former exposes the definition for use in computational reduction, while - the latter doesn't. - *) - (*Eval compute in setClauseSimple ((false, 1%nat) :: nil) (true, 1%nat).*) (*Eval compute in setClauseSimple nil (true, 0). Eval compute in setClauseSimple ((true, 0) :: nil) (true, 0). @@ -281,40 +191,38 @@ Arguments isNil [A]. (** Some more lemmas that I found helpful.... *) Lemma satLit_idem_lit : forall l a l', - satLit l a - -> satLit l' a - -> satLit l' (upd a l). + satLit l a + -> satLit l' a + -> satLit l' (upd a l). unfold satLit, upd; simpl; intros. destruct (eq_nat_dec (snd l') (snd l)); congruence. Qed. -Local Hint Resolve satLit_idem_lit : core. +#[local] Hint Resolve satLit_idem_lit : core. Lemma satLit_idem_clause : forall l a cl, - satLit l a - -> satClause cl a - -> satClause cl (upd a l). + satLit l a + -> satClause cl a + -> satClause cl (upd a l). induction cl; simpl; intuition. Qed. -Local Hint Resolve satLit_idem_clause : core. +#[local] Hint Resolve satLit_idem_clause : core. Lemma satLit_idem_formula : forall l a fm, - satLit l a - -> satFormula fm a - -> satFormula fm (upd a l). + satLit l a + -> satFormula fm a + -> satFormula fm (upd a l). induction fm; simpl; intuition. Qed. -Local Hint Resolve satLit_idem_formula : core. +#[local] Hint Resolve satLit_idem_formula : core. -(** Challenge 2: Write this function that updates an entire formula to reflect - setting a literal to true. - *) +(** Function that updates an entire formula to reflect setting a literal to true. *) Definition setFormula : forall (fm : formula) (l : lit), - {fm' : formula | - forall a, satFormula fm (upd a l) <-> satFormula fm' a} - + {forall a, satLit l a -> ~satFormula fm a}. + {fm' : formula | + forall a, satFormula fm (upd a l) <-> satFormula fm' a} + + {forall a, satLit l a -> ~satFormula fm a}. refine (fix setFormula (fm: formula) (l: lit) {struct fm} := match fm with | nil => inleft (exist _ nil _) @@ -330,43 +238,39 @@ Definition setFormula : forall (fm : formula) (l : lit), else inleft (exist _ (cl'' :: fm'') _) end end - end); clear setFormula; try solve [magic_solver]. + end); clear setFormula; magic_solver. Defined. -(** Here's some code for testing your implementation. *) - Definition setFormulaSimple (fm : formula) (l : lit) := match setFormula fm l with - | inleft (exist _ fm' _) => Some fm' - | inright _ => None + | inleft (exist _ fm' _) => Some fm' + | inright _ => None end. -(*Eval compute in setFormulaSimple (((true, 1%nat) :: nil) :: ((false, 1%nat) :: nil) :: nil) (true, 1%nat). +Eval compute in setFormulaSimple (((true, 1%nat) :: nil) :: ((false, 1%nat) :: nil) :: nil) (true, 1%nat). Eval compute in setFormulaSimple nil (true, 0). Eval compute in setFormulaSimple (((true, 0) :: nil) :: nil) (true, 0). Eval compute in setFormulaSimple (((false, 0) :: nil) :: nil) (true, 0). Eval compute in setFormulaSimple (((false, 1) :: nil) :: nil) (true, 0). Eval compute in setFormulaSimple (((false, 1) :: (true, 0) :: nil) :: nil) (true, 0). -Eval compute in setFormulaSimple (((false, 1) :: (false, 0) :: nil) :: nil) (true, 0).*) +Eval compute in setFormulaSimple (((false, 1) :: (false, 0) :: nil) :: nil) (true, 0). -Local Hint Extern 1 False => discriminate : core. +#[local] Hint Extern 1 False => discriminate : core. Local Hint Extern 1 False => - match goal with - | [ H : In _ (_ :: _) |- _ ] => inversion H; clear H; subst - end : core. +match goal with +| [ H : In _ (_ :: _) |- _ ] => inversion H; clear H; subst +end : core. -(** Challenge 3: Write this code that either finds a unit clause in a formula - or declares that there are none. - *) +(** Code that either finds a unit clause in a formula or declares that there are none. *) Definition findUnitClause : forall (fm: formula), - {l : lit | In (l :: nil) fm} - + {forall l, ~In (l :: nil) fm}. + {l : lit | In (l :: nil) fm} + + {forall l, ~In (l :: nil) fm}. refine (fix findUnitClause (fm: formula) {struct fm} := match fm with | nil => inright _ | (l :: nil) :: fm' => inleft (exist _ l _) - | cl :: fm' => + | _ :: fm' => match findUnitClause fm' with | inleft (exist _ l _) => inleft (exist _ l _) | inright H => inright _ @@ -375,33 +279,30 @@ Definition findUnitClause : forall (fm: formula), ); clear findUnitClause; magic_solver. Defined. -(** The literal in a unit clause must always be true in a satisfying - assignment. - *) +(** The literal in a unit clause must always be true in a satisfying assignment. *) Lemma unitClauseTrue : forall l a fm, - In (l :: nil) fm - -> satFormula fm a - -> satLit l a. + In (l :: nil) fm + -> satFormula fm a + -> satLit l a. induction fm; intuition. inversion H. inversion H; subst; simpl in H0; intuition. Qed. -Local Hint Resolve unitClauseTrue : core. +#[local] Hint Resolve unitClauseTrue : core. -(** Final challenge: Implement unit propagation. The return type of - [unitPropagate] signifies that three results are possible: +(** Unit propagation. The return type of [unitPropagate] signifies that three results are possible: - [None]: There are no unit clauses. - [Some (inleft _)]: There is a unit clause, and here is a formula reflecting setting its literal to true. - [Some (inright _)]: There is a unit clause, and propagating it reveals that the formula is unsatisfiable. - *) + *) Definition unitPropagate : forall (fm : formula), option (sigT (fun fm' : formula => - {l : lit | - (forall a, satFormula fm a -> satLit l a) - /\ forall a, satFormula fm (upd a l) <-> satFormula fm' a}) -+ {forall a, ~satFormula fm a}). + {l : lit | + (forall a, satFormula fm a -> satLit l a) + /\ forall a, satFormula fm (upd a l) <-> satFormula fm' a}) + + {forall a, ~satFormula fm a}). refine (fix unitPropagate (fm: formula) {struct fm} := match findUnitClause fm with | inright H => None @@ -418,9 +319,9 @@ Defined. Definition unitPropagateSimple (fm : formula) := match unitPropagate fm with - | None => None - | Some (inleft (existT _ fm' (exist _ l _))) => Some (Some (fm', l)) - | Some (inright _) => Some None + | None => None + | Some (inleft (existT _ fm' (exist _ l _))) => Some (Some (fm', l)) + | Some (inright _) => Some None end. (*Eval compute in unitPropagateSimple (((true, 1%nat) :: nil) :: ((false, 1%nat) :: nil) :: nil). @@ -434,23 +335,21 @@ Eval compute in unitPropagateSimple (((false, 0) :: (false, 1) :: nil) :: ((true (** * The SAT Solver *) -(** This section defines a DPLL SAT solver in terms of the subroutines you've - written. - *) +(** This section defines a DPLL SAT solver in terms of the subroutines. *) (** An arbitrary heuristic to choose the next variable to split on *) Definition chooseSplit (fm : formula) := match fm with - | ((l :: _) :: _) => l - | _ => (true, 0) + | ((l :: _) :: _) => l + | _ => (true, 0) end. Definition negate (l : lit) := (negb (fst l), snd l). -Local Hint Unfold satFormula : core. +#[local] Hint Unfold satFormula : core. Lemma satLit_dec : forall l a, - {satLit l a} + {satLit (negate l) a}. + {satLit l a} + {satLit (negate l) a}. destruct l. unfold satLit; simpl; intro. destruct b; destruct (a v); simpl; auto. @@ -461,12 +360,11 @@ Definition alist := list lit. Fixpoint interp_alist (al : alist) : asgn := match al with - | nil => fun _ => true - | l :: al' => upd (interp_alist al') l + | nil => fun _ => true + | l :: al' => upd (interp_alist al') l end. -(** Here's the final definition! This is not the way you should write proof - scripts. ;-) +(** Here's the final definition! This implementation isn't #<i>#quite#</i># what you would expect, since it takes an extra parameter expressing a search tree depth. Writing the function @@ -474,57 +372,57 @@ Fixpoint interp_alist (al : alist) : asgn := In practice, you can just seed the bound with one plus the number of variables in the input, but the function's return type still indicates a possibility for a "time-out" by returning [None]. - *) + *) Definition boundedSat: forall (bound : nat) (fm : formula), - option ({al : alist | satFormula fm (interp_alist al)} - + {forall a, ~satFormula fm a}). + option ({al : alist | satFormula fm (interp_alist al)} + + {forall a, ~satFormula fm a}). refine (fix boundedSat (bound : nat) (fm : formula) {struct bound} - : option ({al : alist | satFormula fm (interp_alist al)} - + {forall a, ~satFormula fm a}) := - match bound with - | O => None - | S bound' => - if isNil fm - then Some (inleft _ (exist _ nil _)) - else match unitPropagate fm with - | Some (inleft (existT _ fm' (exist _ l _))) => - match boundedSat bound' fm' with + : option ({al : alist | satFormula fm (interp_alist al)} + + {forall a, ~satFormula fm a}) := + match bound with + | O => None + | S bound' => + if isNil fm + then Some (inleft _ (exist _ nil _)) + else match unitPropagate fm with + | Some (inleft (existT _ fm' (exist _ l _))) => + match boundedSat bound' fm' with | None => None | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (l :: al) _)) | Some (inright _) => Some (inright _ _) - end - | Some (inright _) => Some (inright _ _) - | None => - let l := chooseSplit fm in + end + | Some (inright _) => Some (inright _ _) + | None => + let l := chooseSplit fm in match setFormula fm l with - | inleft (exist _ fm' _) => - match boundedSat bound' fm' with + | inleft (exist _ fm' _) => + match boundedSat bound' fm' with + | None => None + | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (l :: al) _)) + | Some (inright _) => + match setFormula fm (negate l) with + | inleft (exist _ fm' _) => + match boundedSat bound' fm' with | None => None - | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (l :: al) _)) - | Some (inright _) => - match setFormula fm (negate l) with - | inleft (exist _ fm' _) => - match boundedSat bound' fm' with - | None => None - | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (negate l :: al) _)) - | Some (inright _) => Some (inright _ _) - end - | inright _ => Some (inright _ _) - end + | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (negate l :: al) _)) + | Some (inright _) => Some (inright _ _) + end + | inright _ => Some (inright _ _) end - | inright _ => - match setFormula fm (negate l) with - | inleft (exist _ fm' _) => - match boundedSat bound' fm' with - | None => None - | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (negate l :: al) _)) - | Some (inright _) => Some (inright _ _) - end - | inright _ => Some (inright _ _) + end + | inright _ => + match setFormula fm (negate l) with + | inleft (exist _ fm' _) => + match boundedSat bound' fm' with + | None => None + | Some (inleft (exist _ al _)) => Some (inleft _ (exist _ (negate l :: al) _)) + | Some (inright _) => Some (inright _ _) end + | inright _ => Some (inright _ _) + end end - end - end); simpl; intros; subst; intuition; try generalize dependent (interp_alist al). + end + end); simpl; intros; subst; intuition; try generalize dependent (interp_alist al). firstorder. firstorder. firstorder. @@ -578,3 +476,186 @@ Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((true Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((true, 1) :: (false, 0) :: nil) :: nil). Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((false, 0) :: (false, 0) :: nil) :: ((true, 1) :: nil) :: nil). Eval compute in boundedSatSimple 100 (((false, 0) :: (true, 1) :: nil) :: ((false, 1) :: (true, 0) :: nil) :: nil).*) + +Definition lit_set_cl (cl: clause) := + fold_right NSet.add NSet.empty (map snd cl). + +Definition lit_set (fm: formula) := + fold_right NSet.union NSet.empty (map lit_set_cl fm). + +Compute NSet.cardinal (lit_set (((true, 1)::(true, 1)::(true, 1)::nil)::nil)). + +Definition sat_measure (fm: formula) := NSet.cardinal (lit_set fm). + +Lemma elim_clause : + forall (cl: clause) l, In l cl -> exists H, setClause cl l = inright H. +Proof. + induction cl; intros; simpl in *; try contradiction. + destruct (setClause cl l) eqn:?; [|econstructor; eauto]. + destruct s. inversion H; subst. clear H. + destruct (Nat.eq_dec (snd l) (snd l)); [| contradiction]. + destruct (bool_eq_dec (fst l) (fst l)); [| contradiction]. + econstructor. eauto. apply IHcl in H0. + inversion H0. rewrite H1 in Heqs. discriminate. +Qed. + +Lemma sat_measure_setClause' : + forall cl cl' l A, + setClause cl l = inleft (exist _ cl' A) -> + ~ In (snd l) (map snd cl'). +Proof. + induction cl; intros. + { simpl in *. inv H. unfold not in *. intros. inv H. } + { simpl in H. + repeat (destruct_match; crush; []). destruct_match. + repeat (destruct_match; crush; []). inv H. eapply IHcl; eauto. + inv H. unfold not. intros. inv H. contradiction. eapply IHcl; eauto. + } +Qed. + +Lemma sat_measure_setClause'' : + forall cl cl' l A, + setClause cl l = inleft (exist _ cl' A) -> + forall l', + l' <> snd l -> + In l' (map snd cl) -> + In l' (map snd cl'). +Proof. + induction cl; intros. + { inversion H1. } + { inversion H1. subst. simpl in H. + repeat (destruct_match; crush; []). inv H. simpl. + inv H1. eauto. right. eapply IHcl; eauto. + simpl in H. repeat (destruct_match; crush; []). destruct_match. + repeat (destruct_match; crush; []). inv H. eapply IHcl; eauto. + inv H1; crush. inv H. simplify. auto. + inv H. simpl. right. eapply IHcl; eauto. + } +Qed. + +Lemma sat_measure_setClause : + forall cl cl' l A, + In (snd l) (map snd cl) -> + setClause cl l = inleft (exist _ cl' A) -> + NSet.cardinal (lit_set_cl cl') < NSet.cardinal (lit_set_cl cl). +Proof. + intros. pose proof H0. apply sat_measure_setClause' in H0. + pose proof (sat_measure_setClause'' _ _ _ _ H1). admit. +Admitted. + +Definition InFm l (fm: formula) := exists cl, In cl fm /\ In l cl. + +Lemma sat_measure_setFormula : + forall fm fm' l A, + InFm l fm -> + setFormula fm l = inleft (exist _ fm' A) -> + sat_measure fm' < sat_measure fm. +Proof. Admitted. + +Lemma sat_measure_propagate_unit : + forall fm' fm H, + unitPropagate fm = Some (inleft (existT _ fm' H)) -> + sat_measure fm' < sat_measure fm. +Proof. + induction fm; crush. + repeat (destruct_match; crush; []). + destruct_match. + repeat (destruct_match; crush; []). + inv Heqs1. + unfold sat_measure. + Admitted. + +Program Fixpoint satSolve (fm: formula) { measure (sat_measure fm) }: + {al : alist | satFormula fm (interp_alist al)} + {forall a, ~satFormula fm a} := + if isNil fm + then inleft _ (exist _ nil _) + else match unitPropagate fm with + | Some (inleft (existT _ fm' (exist _ l _))) => + match satSolve fm' with + | inleft (exist _ al _) => inleft _ (exist _ (l :: al) _) + | inright _ => inright _ _ + end + | Some (inright _) => inright _ _ + | None => + let l := chooseSplit fm in + match setFormula fm l with + | inleft (exist _ fm' _) => + match satSolve fm' with + | inleft (exist _ al _) => inleft _ (exist _ (l :: al) _) + | inright _ => + match setFormula fm (negate l) with + | inleft (exist _ fm' _) => + match satSolve fm' with + | inleft (exist _ al _) => inleft _ (exist _ (negate l :: al) _) + | inright _ => inright _ _ + end + | inright _ => inright _ _ + end + end + | inright _ => + match setFormula fm (negate l) with + | inleft (exist _ fm' _) => + match satSolve fm' with + | inleft (exist _ al _) => inleft _ (exist _ (negate l :: al) _) + | inright _ => inright _ _ + end + | inright _ => inright _ _ + end + end + end. +Next Obligation. + eapply sat_measure_propagate_unit; eauto. Defined. +Next Obligation. + apply i; auto. Defined. +Next Obligation. + unfold not; intros; eapply wildcard'; apply i; eauto. Defined. +Next Obligation. + Admitted. +Next Obligation. + apply wildcard'0; auto. Defined. +Next Obligation. + Admitted. +Next Obligation. + apply wildcard'2; auto. Defined. +Next Obligation. + unfold not in *; intros. + destruct (satLit_dec (chooseSplit fm) a); + [assert (satFormula fm (upd a (chooseSplit fm))) + | assert (satFormula fm (upd a (negate (chooseSplit fm))))]; firstorder. + { eapply wildcard'1. apply wildcard'0; eauto. } + { eapply wildcard'. apply wildcard'2; eauto. } +Defined. +Next Obligation. + unfold not in *; intros. + destruct (satLit_dec (chooseSplit fm) a); + [assert (satFormula fm (upd a (chooseSplit fm))) + | assert (satFormula fm (upd a (negate (chooseSplit fm))))]; firstorder. + { eapply wildcard'1. eapply wildcard'0. eauto. } + { eapply wildcard'; eauto. } +Defined. +Next Obligation. + Admitted. +Next Obligation. + apply wildcard'1; auto. Defined. +Next Obligation. + unfold not in *; intros. + destruct (satLit_dec (chooseSplit fm) a); + [assert (satFormula fm (upd a (chooseSplit fm))) + | assert (satFormula fm (upd a (negate (chooseSplit fm))))]; firstorder. + { eapply wildcard'0; eauto. } + { eapply wildcard'; apply wildcard'1; eauto. } +Defined. +Next Obligation. + unfold not in *; intros. + destruct (satLit_dec (chooseSplit fm) a). + { eapply wildcard'0; eauto. } + { eapply wildcard'; eauto. } +Defined. + +Definition satSolveSimple (fm : formula) := + match satSolve fm with + | inleft (exist _ a _) => Some a + | inright _ => None + end. + +Eval compute in satSolveSimple nil. diff --git a/src/hls/Schedule.ml b/src/hls/Schedule.ml index 613236f..94225fa 100644 --- a/src/hls/Schedule.ml +++ b/src/hls/Schedule.ml @@ -26,6 +26,7 @@ open AST open Kildall open Op open RTLBlockInstr +open Predicate open RTLBlock open HTL open Verilog @@ -87,14 +88,25 @@ end)(struct let default = 0 end) +module DFGSimp = Graph.Persistent.Graph.Concrete(struct + type t = int * instr + let compare = compare + let equal = (=) + let hash = Hashtbl.hash + end) + +let convert dfg = + DFG.fold_vertex (fun v g -> DFGSimp.add_vertex g v) dfg DFGSimp.empty + |> DFG.fold_edges (fun v1 v2 g -> DFGSimp.add_edge (DFGSimp.add_edge g v1 v2) v2 v1) dfg + let reg r = sprintf "r%d" (P.to_int r) -let print_pred r = sprintf "p%d" (Nat.to_int r) +let print_pred r = sprintf "p%d" (P.to_int r) let print_instr = function | RBnop -> "" | RBload (_, _, _, _, r) -> sprintf "load(%s)" (reg r) | RBstore (_, _, _, _, r) -> sprintf "store(%s)" (reg r) - | RBsetpred (_, _, p) -> sprintf "setpred(%s)" (print_pred p) + | RBsetpred (_, _, _, p) -> sprintf "setpred(%s)" (print_pred p) | RBop (_, op, args, d) -> (match op, args with | Omove, _ -> "mov" @@ -203,6 +215,8 @@ module DFGDot = Graph.Graphviz.Dot(struct include DFG end) +module DFGDfs = Graph.Traverse.Dfs(DFG) + module IMap = Map.Make (struct type t = int @@ -341,7 +355,7 @@ let rec find_all_next_dst_read i dst i' 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' + | RBsetpred (_, _, rs, _) :: curr' -> check_dst rs curr' let drop i lst = let rec drop' i' lst' = @@ -400,10 +414,11 @@ let accumulate_WAW_mem_deps instrs dfg curri = 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'' + | Plit p'' -> P.to_int p = P.to_int (snd p'') | Pand (p1, p2) -> in_predicate p p1 || in_predicate p p2 | Por (p1, p2) -> in_predicate p p1 || in_predicate p p2 + | Ptrue -> false + | Pfalse -> false let get_predicate = function | RBop (p, _, _, _) -> p @@ -413,7 +428,7 @@ let get_predicate = function let rec next_setpred p i = function | [] -> None - | RBsetpred (_, _, p') :: rst -> + | RBsetpred (_, _, _, p') :: rst -> if in_predicate p' p then Some i else @@ -446,7 +461,7 @@ let accumulate_RAW_pred_deps instrs dfg curri = let accumulate_WAR_pred_deps instrs dfg curri = let i, curr = curri in match curr with - | RBsetpred (_, _, p) -> ( + | RBsetpred (_, _, _, p) -> ( match next_preduse p 0 (take i instrs |> List.rev) with | None -> dfg | Some d -> DFG.add_edge dfg (gen_vertex instrs (i - d - 1)) (gen_vertex instrs i) ) @@ -455,8 +470,8 @@ let accumulate_WAR_pred_deps instrs dfg curri = let accumulate_WAW_pred_deps instrs dfg curri = let i, curr = curri in match curr with - | RBsetpred (_, _, p) -> ( - match next_setpred (Pvar p) 0 (take i instrs |> List.rev) with + | RBsetpred (_, _, _, p) -> ( + match next_setpred (Plit (true, p)) 0 (take i instrs |> List.rev) with | None -> dfg | Some d -> DFG.add_edge dfg (gen_vertex instrs (i - d - 1)) (gen_vertex instrs i) ) | _ -> dfg @@ -499,18 +514,18 @@ let assigned_vars vars = function | RBop (_, _, _, dst) -> dst :: vars | RBload (_, _, _, _, dst) -> dst :: vars | RBstore (_, _, _, _, _) -> vars - | RBsetpred (_, _, _) -> vars + | RBsetpred (_, _, _, _) -> vars let get_pred = function | RBnop -> None | RBop (op, _, _, _) -> op | RBload (op, _, _, _, _) -> op | RBstore (op, _, _, _, _) -> op - | RBsetpred (_, _, _) -> None + | RBsetpred (_, _, _, _) -> None let independant_pred p p' = - match sat_pred_temp (Nat.of_int 100000) (Pand (p, p')) with - | Some None -> true + match sat_pred_simple (Pand (p, p')) with + | None -> true | _ -> false let check_dependent op1 op2 = @@ -720,22 +735,22 @@ let parse_soln (tree, bbtree) s = else (tree, bbtree)) let solve_constraints constr = - let oc = open_out "lpsolve.txt" in + let (fn, oc) = Filename.open_temp_file "vericert_" "_lp_solve" in fprintf oc "%s\n" (print_lp constr); close_out oc; - Str.split (Str.regexp_string "\n") (read_process "lp_solve lpsolve.txt") - |> drop 3 - |> List.fold_left parse_soln (IMap.empty, IMap.empty) + let res = Str.split (Str.regexp_string "\n") (read_process ("lp_solve " ^ fn)) + |> drop 3 + |> List.fold_left parse_soln (IMap.empty, IMap.empty) + in + Sys.remove fn; res let subgraph dfg l = let dfg' = List.fold_left (fun g v -> DFG.add_vertex g v) DFG.empty l in List.fold_left (fun g v -> List.fold_left (fun g' v' -> let edges = DFG.find_all_edges dfg v v' in - List.fold_left (fun g'' e -> - DFG.add_edge_e g'' e - ) g' edges + List.fold_left DFG.add_edge_e g' edges ) g l ) dfg' l @@ -755,6 +770,21 @@ let combine_bb_schedule schedule s = let i, st = s in IMap.update st (update_schedule i) schedule +(**let add_el dfg i l = + List.*) + +let check_in el = + List.exists (List.exists ((=) el)) + +let all_dfs dfg = + let roots = DFG.fold_vertex (fun v li -> + if DFG.in_degree dfg v = 0 then v :: li else li + ) dfg [] in + let dfg' = DFG.fold_edges (fun v1 v2 g -> DFG.add_edge g v2 v1) dfg dfg in + List.fold_left (fun a el -> + if check_in el a then a else + (DFGDfs.fold_component (fun v l -> v :: l) [] dfg' el) :: a) [] roots + let range s e = List.init (e - s) (fun i -> i) |> List.map (fun x -> x + s) @@ -773,23 +803,29 @@ let transf_rtlpar c c' schedule = let i_sched_tree = List.fold_left combine_bb_schedule IMap.empty i_sched in - (*let body = IMap.to_seq i_sched_tree |> List.of_seq |> List.map snd + let body = IMap.to_seq i_sched_tree |> List.of_seq |> List.map snd |> List.map (List.map (fun x -> (x, List.nth bb_body' x))) - in*) - let body2 = List.fold_left (fun x b -> + in + (*let body2 = List.fold_left (fun x b -> match IMap.find_opt b i_sched_tree with | Some i -> i :: x | None -> [] :: x ) [] (range (fst bb_st_e) (snd bb_st_e + 1)) |> List.map (List.map (fun x -> (x, List.nth bb_body' x))) |> List.rev - in + in*) (*let final_body = List.map (fun x -> subgraph dfg x |> order_instr) body in*) let final_body2 = List.map (fun x -> subgraph dfg x - |> (fun x -> TopoDFG.fold (fun i l -> snd i :: l) x []) - |> List.rev) body2 + |> (fun x -> + all_dfs x + |> List.map (subgraph x) + |> List.map (fun y -> + TopoDFG.fold (fun i l -> snd i :: l) y [] + |> List.rev))) body + (*|> (fun x -> TopoDFG.fold (fun i l -> snd i :: l) x []) + |> List.rev) body2*) in - { bb_body = List.map (fun x -> [x]) final_body2; + { bb_body = final_body2; bb_exit = ctrl_flow } in @@ -799,7 +835,7 @@ let schedule entry (c : RTLBlock.bb RTLBlockInstr.code) = let debug = true in let transf_graph (_, dfg, _) = dfg in let c' = PTree.map1 (fun x -> gather_bb_constraints false x |> transf_graph) 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 _ = if debug then PTree.map (fun r o -> printf "##### %d #####\n%a\n\n" (P.to_int r) print_dfg o) c' else PTree.empty in*) let cgraph = PTree.elements c' |> List.map (function (x, y) -> (P.to_int x, y)) |> List.fold_left (gather_cfg_constraints c) G.empty @@ -809,7 +845,7 @@ let schedule entry (c : RTLBlock.bb RTLBlockInstr.code) = close_out graph; let schedule' = solve_constraints cgraph 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';*) + (**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 c' schedule' let rec find_reachable_states c e = @@ -831,7 +867,6 @@ let schedule_fn (f : RTLBlock.coq_function) : RTLPar.coq_function = { 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_funct_units = f.fn_funct_units; + fn_code = scheduled (*List.fold_left (add_to_tree scheduled) PTree.empty reachable*); fn_entrypoint = f.fn_entrypoint } diff --git a/src/hls/Verilog.v b/src/hls/Verilog.v index 779b05c..3a2c81d 100644 --- a/src/hls/Verilog.v +++ b/src/hls/Verilog.v @@ -21,23 +21,24 @@ Set Implicit Arguments. Require Import Coq.Structures.OrderedTypeEx. Require Import Coq.FSets.FMapPositive. +Require Import Coq.Program.Basics. Require Import Coq.Arith.PeanoNat. Require Import Coq.ZArith.ZArith. Require Import Coq.Lists.List. +Require Import Coq.Program.Program. Require Import Coq.micromega.Lia. +Require compcert.common.Events. +Require Import compcert.lib.Integers. Require Import compcert.common.Errors. -Require Import compcert.common.Globalenvs. Require Import compcert.common.Smallstep. -Require Import compcert.lib.Integers. -Require compcert.common.Events. +Require Import compcert.common.Globalenvs. -Require Import vericert.common.Show. Require Import vericert.common.Vericertlib. -Require Import vericert.hls.Array. -Require Import vericert.hls.AssocMap. -Require Import vericert.hls.FunctionalUnits. +Require Import vericert.common.Show. Require Import vericert.hls.ValueInt. +Require Import vericert.hls.AssocMap. +Require Import vericert.hls.Array. Import ListNotations. @@ -81,6 +82,39 @@ Definition merge_arr (new : option arr) (old : option arr) : option arr := Definition merge_arrs (new : assocmap_arr) (old : assocmap_arr) : assocmap_arr := AssocMap.combine merge_arr new old. +Lemma merge_arr_empty': + forall l, + merge_arr (Some (arr_repeat None (length l))) (Some (make_array l)) = Some (make_array l). +Proof. + induction l; auto. + unfold merge_arr. + unfold combine, make_array. simplify. rewrite H0. + rewrite list_repeat_cons. simplify. + rewrite H0; auto. +Qed. + +Lemma merge_arr_empty: + forall v l, + v = Some (make_array l) -> + merge_arr (Some (arr_repeat None (length l))) v = v. +Proof. intros. rewrite H. apply merge_arr_empty'. Qed. + +Lemma merge_arr_empty2: + forall v l v', + v = Some v' -> + l = arr_length v' -> + merge_arr (Some (arr_repeat None l)) v = v. +Proof. + intros. subst. destruct v'. simplify. + generalize dependent arr_wf. generalize dependent arr_length. + induction arr_contents. + - simplify; subst; auto. + - unfold combine, make_array in *; simplify; subst. + rewrite list_repeat_cons; simplify. + specialize (IHarr_contents (Datatypes.length arr_contents) eq_refl). + inv IHarr_contents. rewrite H0. rewrite H0. auto. +Qed. + Definition arr_assocmap_lookup (a : assocmap_arr) (r : reg) (i : nat) : option value := match a ! r with | None => None @@ -195,9 +229,12 @@ Inductive stmnt : Type := | Vskip : stmnt | Vseq : stmnt -> stmnt -> stmnt | Vcond : expr -> stmnt -> stmnt -> stmnt -| Vcase : expr -> list (expr * stmnt) -> option stmnt -> stmnt +| Vcase : expr -> stmnt_expr_list -> option stmnt -> stmnt | Vblock : expr -> expr -> stmnt -| Vnonblock : expr -> expr -> stmnt. +| Vnonblock : expr -> expr -> stmnt +with stmnt_expr_list : Type := +| Stmntnil : stmnt_expr_list +| Stmntcons : expr -> stmnt -> stmnt_expr_list -> stmnt_expr_list. (*| Edges @@ -263,7 +300,6 @@ Record module : Type := mkmodule { mod_stk : reg; mod_stk_len : nat; mod_args : list reg; - mod_funct_units: funct_units; mod_body : list module_item; mod_entrypoint : node; }. @@ -405,7 +441,7 @@ Inductive expr_runp : fext -> assocmap -> assocmap_arr -> expr -> value -> Prop expr_runp fext reg stack fs vf -> valueToBool vc = false -> expr_runp fext reg stack (Vternary c ts fs) vf. -Hint Constructors expr_runp : verilog. +#[export] Hint Constructors expr_runp : verilog. Definition handle_opt {A : Type} (err : errmsg) (val : option A) : res A := @@ -464,19 +500,19 @@ Inductive stmnt_runp: fext -> reg_associations -> arr_associations -> expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) me mve -> mve <> ve -> stmnt_runp f asr0 asa0 (Vcase e cs def) asr1 asa1 -> - stmnt_runp f asr0 asa0 (Vcase e ((me, sc)::cs) def) asr1 asa1 + stmnt_runp f asr0 asa0 (Vcase e (Stmntcons me sc cs) def) asr1 asa1 | stmnt_runp_Vcase_match: forall e ve asr0 asa0 f asr1 asa1 me mve sc cs def, expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) e ve -> expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) me mve -> mve = ve -> stmnt_runp f asr0 asa0 sc asr1 asa1 -> - stmnt_runp f asr0 asa0 (Vcase e ((me, sc)::cs) def) asr1 asa1 + stmnt_runp f asr0 asa0 (Vcase e (Stmntcons me sc cs) def) asr1 asa1 | stmnt_runp_Vcase_default: forall asr0 asa0 asr1 asa1 f st e ve, expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) e ve -> stmnt_runp f asr0 asa0 st asr1 asa1 -> - stmnt_runp f asr0 asa0 (Vcase e nil (Some st)) asr1 asa1 + stmnt_runp f asr0 asa0 (Vcase e Stmntnil (Some st)) asr1 asa1 | stmnt_runp_Vblock_reg: forall lhs r rhs rhsval asr asa f, location_is f asr.(assoc_blocking) asa.(assoc_blocking) lhs (LocReg r) -> @@ -505,26 +541,35 @@ Inductive stmnt_runp: fext -> reg_associations -> arr_associations -> stmnt_runp f asr asa (Vnonblock lhs rhs) asr (nonblock_arr r i asa rhsval). -Hint Constructors stmnt_runp : verilog. +#[export] Hint Constructors stmnt_runp : verilog. Inductive mi_stepp : fext -> reg_associations -> arr_associations -> module_item -> reg_associations -> arr_associations -> Prop := | mi_stepp_Valways : forall f sr0 sa0 st sr1 sa1 c, stmnt_runp f sr0 sa0 st sr1 sa1 -> - mi_stepp f sr0 sa0 (Valways c st) sr1 sa1 -| mi_stepp_Valways_ff : - forall f sr0 sa0 st sr1 sa1 c, - stmnt_runp f sr0 sa0 st sr1 sa1 -> - mi_stepp f sr0 sa0 (Valways_ff c st) sr1 sa1 -| mi_stepp_Valways_comb : + mi_stepp f sr0 sa0 (Valways (Vposedge c) st) sr1 sa1 +| mi_stepp_Valways_ne : + forall f sr0 sa0 c st, + mi_stepp f sr0 sa0 (Valways (Vnegedge c) st) sr0 sa0 +| mi_stepp_Vdecl : + forall f sr0 sa0 d, + mi_stepp f sr0 sa0 (Vdeclaration d) sr0 sa0. +#[export] Hint Constructors mi_stepp : verilog. + +Inductive mi_stepp_negedge : fext -> reg_associations -> arr_associations -> + module_item -> reg_associations -> arr_associations -> Prop := +| mi_stepp_negedge_Valways : forall f sr0 sa0 st sr1 sa1 c, stmnt_runp f sr0 sa0 st sr1 sa1 -> - mi_stepp f sr0 sa0 (Valways_comb c st) sr1 sa1 -| mi_stepp_Vdecl : - forall f sr sa d, - mi_stepp f sr sa (Vdeclaration d) sr sa. -Hint Constructors mi_stepp : verilog. + mi_stepp_negedge f sr0 sa0 (Valways (Vnegedge c) st) sr1 sa1 +| mi_stepp_negedge_Valways_ne : + forall f sr0 sa0 c st, + mi_stepp_negedge f sr0 sa0 (Valways (Vposedge c) st) sr0 sa0 +| mi_stepp_negedge_Vdecl : + forall f sr0 sa0 d, + mi_stepp_negedge f sr0 sa0 (Vdeclaration d) sr0 sa0. +#[export] Hint Constructors mi_stepp : verilog. Inductive mis_stepp : fext -> reg_associations -> arr_associations -> list module_item -> reg_associations -> arr_associations -> Prop := @@ -536,7 +581,19 @@ Inductive mis_stepp : fext -> reg_associations -> arr_associations -> | mis_stepp_Nil : forall f sr sa, mis_stepp f sr sa nil sr sa. -Hint Constructors mis_stepp : verilog. +#[export] Hint Constructors mis_stepp : verilog. + +Inductive mis_stepp_negedge : fext -> reg_associations -> arr_associations -> + list module_item -> reg_associations -> arr_associations -> Prop := +| mis_stepp_negedge_Cons : + forall f mi mis sr0 sa0 sr1 sa1 sr2 sa2, + mi_stepp_negedge f sr0 sa0 mi sr1 sa1 -> + mis_stepp_negedge f sr1 sa1 mis sr2 sa2 -> + mis_stepp_negedge f sr0 sa0 (mi :: mis) sr2 sa2 +| mis_stepp_negedge_Nil : + forall f sr sa, + mis_stepp_negedge f sr sa nil sr sa. +#[export] Hint Constructors mis_stepp : verilog. Local Close Scope error_monad_scope. @@ -552,18 +609,24 @@ Definition empty_stack (m : module) : assocmap_arr := Inductive step : genv -> state -> Events.trace -> state -> Prop := | step_module : - forall asr asa asr' asa' basr1 nasr1 basa1 nasa1 f stval pstval m sf st g ist, + forall asr asa asr' asa' basr1 nasr1 basa1 nasa1 basr2 nasr2 + basa2 nasa2 f stval pstval m sf st g ist, asr!(m.(mod_reset)) = Some (ZToValue 0) -> asr!(m.(mod_finish)) = Some (ZToValue 0) -> asr!(m.(mod_st)) = Some ist -> valueToPos ist = st -> mis_stepp f (mkassociations asr empty_assocmap) (mkassociations asa (empty_stack m)) - m.(mod_body) + (mod_body m) (mkassociations basr1 nasr1) - (mkassociations basa1 nasa1)-> - asr' = merge_regs nasr1 basr1 -> - asa' = merge_arrs nasa1 basa1 -> + (mkassociations basa1 nasa1) -> + mis_stepp_negedge f (mkassociations (merge_regs nasr1 basr1) empty_assocmap) + (mkassociations (merge_arrs nasa1 basa1) (empty_stack m)) + (mod_body m) + (mkassociations basr2 nasr2) + (mkassociations basa2 nasa2) -> + asr' = merge_regs nasr2 basr2 -> + asa' = merge_arrs nasa2 basa2 -> asr'!(m.(mod_st)) = Some stval -> valueToPos stval = pstval -> step g (State sf m st asr asa) Events.E0 (State sf m pstval asr' asa') @@ -586,7 +649,7 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := mst = mod_st m -> step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) asa). -Hint Constructors step : verilog. +#[export] Hint Constructors step : verilog. Inductive initial_state (p: program): state -> Prop := | initial_state_intro: forall b m0 m, @@ -605,6 +668,18 @@ Definition semantics (m : program) := Smallstep.Semantics step (initial_state m) final_state (Globalenvs.Genv.globalenv m). +Fixpoint list_to_stmnt st := + match st with + | (e, s) :: r => Stmntcons e s (list_to_stmnt r) + | nil => Stmntnil + end. + +Fixpoint stmnt_to_list st := + match st with + | Stmntcons e s r => (e, s) :: stmnt_to_list r + | Stmntnil => nil + end. + Lemma expr_runp_determinate : forall f e asr asa v, expr_runp f asr asa e v -> @@ -632,7 +707,7 @@ Proof. learn (H1 _ H2) end; crush). Qed. -Hint Resolve expr_runp_determinate : verilog. +#[export] Hint Resolve expr_runp_determinate : verilog. Lemma location_is_determinate : forall f asr asa e l, @@ -665,8 +740,8 @@ Lemma stmnt_runp_determinate : | [ H : stmnt_runp _ _ _ (Vblock _ _) _ _ |- _ ] => invert H | [ H : stmnt_runp _ _ _ Vskip _ _ |- _ ] => invert H | [ H : stmnt_runp _ _ _ (Vcond _ _ _) _ _ |- _ ] => invert H - | [ H : stmnt_runp _ _ _ (Vcase _ (_ :: _) _) _ _ |- _ ] => invert H - | [ H : stmnt_runp _ _ _ (Vcase _ [] _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vcase _ (Stmntcons _ _ _) _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vcase _ Stmntnil _) _ _ |- _ ] => invert H | [ H1 : expr_runp _ ?asr ?asa ?e _, H2 : expr_runp _ ?asr ?asa ?e _ |- _ ] => @@ -681,7 +756,7 @@ Lemma stmnt_runp_determinate : learn (H1 _ _ H2) end; crush). Qed. -Hint Resolve stmnt_runp_determinate : verilog. +#[export] Hint Resolve stmnt_runp_determinate : verilog. Lemma mi_stepp_determinate : forall f asr0 asa0 m asr1 asa1, @@ -699,6 +774,22 @@ Proof. end; crush). Qed. +Lemma mi_stepp_negedge_determinate : + forall f asr0 asa0 m asr1 asa1, + mi_stepp_negedge f asr0 asa0 m asr1 asa1 -> + forall asr1' asa1', + mi_stepp_negedge f asr0 asa0 m asr1' asa1' -> + asr1' = asr1 /\ asa1' = asa1. +Proof. + intros. destruct m; invert H; invert H0; + + repeat (try match goal with + | [ H1 : stmnt_runp _ ?asr0 ?asa0 ?s _ _, + H2 : stmnt_runp _ ?asr0 ?asa0 ?s _ _ |- _ ] => + learn (stmnt_runp_determinate H1 H2) + end; crush). +Qed. + Lemma mis_stepp_determinate : forall f asr0 asa0 m asr1 asa1, mis_stepp f asr0 asa0 m asr1 asa1 -> @@ -722,17 +813,77 @@ Proof. end; crush). Qed. +Lemma mis_stepp_negedge_determinate : + forall f asr0 asa0 m asr1 asa1, + mis_stepp_negedge f asr0 asa0 m asr1 asa1 -> + forall asr1' asa1', + mis_stepp_negedge f asr0 asa0 m asr1' asa1' -> + asr1' = asr1 /\ asa1' = asa1. +Proof. + induction 1; intros; + + repeat (try match goal with + | [ H : mis_stepp_negedge _ _ _ [] _ _ |- _ ] => invert H + | [ H : mis_stepp_negedge _ _ _ ( _ :: _ ) _ _ |- _ ] => invert H + + | [ H1 : mi_stepp_negedge _ ?asr0 ?asa0 ?s _ _, + H2 : mi_stepp_negedge _ ?asr0 ?asa0 ?s _ _ |- _ ] => + learn (mi_stepp_negedge_determinate H1 H2) + + | [ H1 : forall asr1 asa1, mis_stepp_negedge _ ?asr0 ?asa0 ?m asr1 asa1 -> _, + H2 : mis_stepp_negedge _ ?asr0 ?asa0 ?m _ _ |- _ ] => + learn (H1 _ _ H2) + end; crush). +Qed. + Lemma semantics_determinate : forall (p: program), Smallstep.determinate (semantics p). Proof. intros. constructor; set (ge := Globalenvs.Genv.globalenv p); simplify. - invert H; invert H0; constructor. (* Traces are always empty *) - - invert H; invert H0; crush. - assert (f = f0) by (destruct f; destruct f0; auto); subst. - pose proof (mis_stepp_determinate H5 H15). + - invert H; invert H0; crush. assert (f = f0) by (destruct f; destruct f0; auto); subst. + pose proof (mis_stepp_determinate H5 H15). simplify. inv H0. inv H4. + pose proof (mis_stepp_negedge_determinate H6 H17). crush. - constructor. invert H; crush. - invert H; invert H0; unfold ge0, ge1 in *; crush. - red; simplify; intro; invert H0; invert H; crush. - invert H; invert H0; crush. Qed. + +Local Open Scope positive. + +Fixpoint max_reg_expr (e: expr) := + match e with + | Vlit _ => 1 + | Vvar r => r + | Vvari r e => Pos.max r (max_reg_expr e) + | Vrange r e1 e2 => Pos.max r (Pos.max (max_reg_expr e1) (max_reg_expr e2)) + | Vinputvar r => r + | Vbinop _ e1 e2 => Pos.max (max_reg_expr e1) (max_reg_expr e2) + | Vunop _ e => max_reg_expr e + | Vternary e1 e2 e3 => Pos.max (max_reg_expr e1) (Pos.max (max_reg_expr e2) (max_reg_expr e3)) + end. + +Fixpoint max_reg_stmnt (st: stmnt) := + match st with + | Vskip => 1 + | Vseq s1 s2 => Pos.max (max_reg_stmnt s1) (max_reg_stmnt s2) + | Vcond e s1 s2 => + Pos.max (max_reg_expr e) + (Pos.max (max_reg_stmnt s1) (max_reg_stmnt s2)) + | Vcase e stl None => Pos.max (max_reg_expr e) (max_reg_stmnt_expr_list stl) + | Vcase e stl (Some s) => + Pos.max (max_reg_stmnt s) + (Pos.max (max_reg_expr e) (max_reg_stmnt_expr_list stl)) + | Vblock e1 e2 => Pos.max (max_reg_expr e1) (max_reg_expr e2) + | Vnonblock e1 e2 => Pos.max (max_reg_expr e1) (max_reg_expr e2) + end +with max_reg_stmnt_expr_list (stl: stmnt_expr_list) := + match stl with + | Stmntnil => 1 + | Stmntcons e s stl' => + Pos.max (max_reg_expr e) + (Pos.max (max_reg_stmnt s) + (max_reg_stmnt_expr_list stl')) + end. diff --git a/src/hls/Veriloggen.v b/src/hls/Veriloggen.v index 6ea00e0..035e7a4 100644 --- a/src/hls/Veriloggen.v +++ b/src/hls/Veriloggen.v @@ -25,6 +25,7 @@ Require Import vericert.hls.AssocMap. Require Import vericert.hls.HTL. Require Import vericert.hls.ValueInt. Require Import vericert.hls.Verilog. +Require Import vericert.hls.FunctionalUnits. Definition transl_list_fun (a : node * Verilog.stmnt) := let (n, stmnt) := a in @@ -42,28 +43,61 @@ Definition arr_to_Vdeclarr_fun (a : reg * (option io * arr_decl)) := Definition arr_to_Vdeclarr arrdecl := map arr_to_Vdeclarr_fun arrdecl. +Definition inst_ram clk ram := + Valways (Vnegedge clk) + (Vcond (Vbinop Vne (Vvar (ram_u_en ram)) (Vvar (ram_en ram))) + (Vseq (Vcond (Vvar (ram_wr_en ram)) + (Vnonblock (Vvari (ram_mem ram) (Vvar (ram_addr ram))) + (Vvar (ram_d_in ram))) + (Vnonblock (Vvar (ram_d_out ram)) + (Vvari (ram_mem ram) (Vvar (ram_addr ram))))) + (Vnonblock (Vvar (ram_en ram)) (Vvar (ram_u_en ram)))) + Vskip). + Definition transl_module (m : HTL.module) : Verilog.module := - let case_el_ctrl := transl_list (PTree.elements m.(mod_controllogic)) in - let case_el_data := transl_list (PTree.elements m.(mod_datapath)) in - let body := - Valways (Vposedge m.(HTL.mod_clk)) (Vcond (Vbinop Veq (Vvar m.(HTL.mod_reset)) (Vlit (ZToValue 1))) - (Vnonblock (Vvar m.(HTL.mod_st)) (Vlit (posToValue m.(HTL.mod_entrypoint)))) - (Vcase (Vvar m.(HTL.mod_st)) case_el_ctrl (Some Vskip))) - :: Valways (Vposedge m.(HTL.mod_clk)) (Vcase (Vvar m.(HTL.mod_st)) case_el_data (Some Vskip)) - :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) - ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in - Verilog.mkmodule m.(HTL.mod_start) - m.(HTL.mod_reset) - m.(HTL.mod_clk) - m.(HTL.mod_finish) - m.(HTL.mod_return) - m.(HTL.mod_st) - m.(HTL.mod_stk) - m.(HTL.mod_stk_len) - m.(HTL.mod_params) - m.(HTL.mod_funct_units) - body - m.(HTL.mod_entrypoint). + let case_el_ctrl := list_to_stmnt (transl_list (PTree.elements m.(mod_controllogic))) in + let case_el_data := list_to_stmnt (transl_list (PTree.elements m.(mod_datapath))) in + match m.(HTL.mod_ram) with + | Some ram => + let body := + Valways (Vposedge m.(HTL.mod_clk)) (Vcond (Vbinop Veq (Vvar m.(HTL.mod_reset)) (Vlit (ZToValue 1))) + (Vnonblock (Vvar m.(HTL.mod_st)) (Vlit (posToValue m.(HTL.mod_entrypoint)))) + (Vcase (Vvar m.(HTL.mod_st)) case_el_ctrl (Some Vskip))) + :: Valways (Vposedge m.(HTL.mod_clk)) (Vcase (Vvar m.(HTL.mod_st)) case_el_data (Some Vskip)) + :: inst_ram m.(HTL.mod_clk) ram + :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) + ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in + Verilog.mkmodule m.(HTL.mod_start) + m.(HTL.mod_reset) + m.(HTL.mod_clk) + m.(HTL.mod_finish) + m.(HTL.mod_return) + m.(HTL.mod_st) + m.(HTL.mod_stk) + m.(HTL.mod_stk_len) + m.(HTL.mod_params) + body + m.(HTL.mod_entrypoint) + | None => + let body := + Valways (Vposedge m.(HTL.mod_clk)) (Vcond (Vbinop Veq (Vvar m.(HTL.mod_reset)) (Vlit (ZToValue 1))) + (Vnonblock (Vvar m.(HTL.mod_st)) (Vlit (posToValue m.(HTL.mod_entrypoint)))) + (Vcase (Vvar m.(HTL.mod_st)) case_el_ctrl (Some Vskip))) + :: Valways (Vposedge m.(HTL.mod_clk)) (Vcase (Vvar m.(HTL.mod_st)) case_el_data (Some Vskip)) + :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) + ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in + Verilog.mkmodule m.(HTL.mod_start) + m.(HTL.mod_reset) + m.(HTL.mod_clk) + m.(HTL.mod_finish) + m.(HTL.mod_return) + m.(HTL.mod_st) + m.(HTL.mod_stk) + m.(HTL.mod_stk_len) + m.(HTL.mod_params) + body + m.(HTL.mod_entrypoint) + end. Definition transl_fundef := transf_fundef transl_module. diff --git a/src/hls/Veriloggenproof.v b/src/hls/Veriloggenproof.v index 9abbd4b..d1494ec 100644 --- a/src/hls/Veriloggenproof.v +++ b/src/hls/Veriloggenproof.v @@ -115,7 +115,7 @@ Lemma Zle_relax : p < q <= r -> p <= q <= r. Proof. lia. Qed. -Hint Resolve Zle_relax : verilogproof. +#[local] Hint Resolve Zle_relax : verilogproof. Lemma transl_in : forall l p, @@ -178,7 +178,7 @@ Lemma transl_list_correct : stmnt_runp f {| assoc_blocking := asr; assoc_nonblocking := asrn |} {| assoc_blocking := asa; assoc_nonblocking := asan |} - (Vcase (Vvar ev) (transl_list l) (Some Vskip)) + (Vcase (Vvar ev) (list_to_stmnt (transl_list l)) (Some Vskip)) {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} {| assoc_blocking := asa'; assoc_nonblocking := asan' |}). Proof. @@ -202,7 +202,7 @@ Proof. eapply IHl. auto. inv NOREP. auto. eassumption. inv IN. inv H. contradiction. apply H. trivial. assumption. Qed. -Hint Resolve transl_list_correct : verilogproof. +#[local] Hint Resolve transl_list_correct : verilogproof. Lemma pc_wf : forall A m p v, @@ -223,7 +223,117 @@ Proof. - intros. constructor. - intros. simplify. econstructor. constructor. auto. Qed. -Hint Resolve mis_stepp_decl : verilogproof. +#[local] Hint Resolve mis_stepp_decl : verilogproof. + +Lemma mis_stepp_negedge_decl : + forall l asr asa f, + mis_stepp_negedge f asr asa (map Vdeclaration l) asr asa. +Proof. + induction l. + - intros. constructor. + - intros. simplify. econstructor. constructor. auto. +Qed. +#[local] Hint Resolve mis_stepp_negedge_decl : verilogproof. + +Lemma mod_entrypoint_equiv m : mod_entrypoint (transl_module m) = HTL.mod_entrypoint m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_st_equiv m : mod_st (transl_module m) = HTL.mod_st m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_stk_equiv m : mod_stk (transl_module m) = HTL.mod_stk m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_stk_len_equiv m : mod_stk_len (transl_module m) = HTL.mod_stk_len m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_finish_equiv m : mod_finish (transl_module m) = HTL.mod_finish m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_reset_equiv m : mod_reset (transl_module m) = HTL.mod_reset m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_clk_equiv m : mod_clk (transl_module m) = HTL.mod_clk m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_return_equiv m : mod_return (transl_module m) = HTL.mod_return m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma mod_params_equiv m : mod_args (transl_module m) = HTL.mod_params m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Lemma empty_stack_equiv m : empty_stack (transl_module m) = HTL.empty_stack m. +Proof. unfold transl_module; intros; destruct (HTL.mod_ram m) eqn:?; crush. Qed. + +Ltac rewrite_eq := rewrite mod_return_equiv + || rewrite mod_clk_equiv + || rewrite mod_reset_equiv + || rewrite mod_finish_equiv + || rewrite mod_stk_len_equiv + || rewrite mod_stk_equiv + || rewrite mod_st_equiv + || rewrite mod_entrypoint_equiv + || rewrite mod_params_equiv + || rewrite empty_stack_equiv. + +Lemma find_assocmap_get r i v : r ! i = Some v -> r # i = v. +Proof. + intros. unfold find_assocmap, AssocMapExt.get_default. rewrite H. auto. +Qed. + +Lemma ram_exec_match : + forall f asr asa asr' asa' r clk, + HTL.exec_ram asr asa (Some r) asr' asa' -> + mi_stepp_negedge f asr asa (inst_ram clk r) asr' asa'. +Proof. + inversion 1; subst; simplify. + { unfold inst_ram. econstructor. + eapply stmnt_runp_Vcond_false. + econstructor. econstructor. econstructor. auto. + econstructor. auto. + simplify. + unfold boolToValue, natToValue, valueToBool. + rewrite Int.eq_sym. rewrite H3. simplify. + auto. constructor. } + { unfold inst_ram. econstructor. econstructor. econstructor. + econstructor. econstructor. auto. + econstructor. auto. + simplify. + unfold boolToValue, natToValue, valueToBool. + pose proof H4 as X. apply find_assocmap_get in X. + rewrite X. rewrite Int.eq_sym. rewrite H1. auto. + econstructor. econstructor. econstructor. econstructor. + pose proof H5 as X. apply find_assocmap_get in X. + rewrite X. + unfold valueToBool. unfold ZToValue in *. + unfold Int.eq in H2. + unfold uvalueToZ. + assert (Int.unsigned wr_en =? 0 = false). + apply Z.eqb_neq. rewrite Int.unsigned_repr in H2 by (simplify; lia). + destruct (zeq (Int.unsigned wr_en) 0); crush. + rewrite H0. auto. + apply stmnt_runp_Vnonblock_arr. econstructor. econstructor. auto. + econstructor. econstructor. + apply find_assocmap_get in H9. rewrite H9. + apply find_assocmap_get in H6. rewrite H6. + repeat econstructor. apply find_assocmap_get; auto. + } + { econstructor. econstructor. econstructor. econstructor. auto. + econstructor. auto. + econstructor. + unfold boolToValue, natToValue, valueToBool. + apply find_assocmap_get in H3. rewrite H3. + rewrite Int.eq_sym. rewrite H1. auto. + econstructor. + eapply stmnt_runp_Vcond_false. econstructor. auto. + simplify. apply find_assocmap_get in H4. rewrite H4. + auto. + repeat (econstructor; auto). apply find_assocmap_get in H5. + rewrite H5. eassumption. + repeat econstructor. simplify. apply find_assocmap_get; auto. + } +Qed. + Section CORRECTNESS. @@ -238,7 +348,7 @@ Section CORRECTNESS. Lemma symbols_preserved: forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof. intros. eapply (Genv.find_symbol_match TRANSL). Qed. - Hint Resolve symbols_preserved : verilogproof. + #[local] Hint Resolve symbols_preserved : verilogproof. Lemma function_ptr_translated: forall (b: Values.block) (f: HTL.fundef), @@ -249,7 +359,7 @@ Section CORRECTNESS. intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto. intros (cu & tf & P & Q & R); exists tf; auto. Qed. - Hint Resolve function_ptr_translated : verilogproof. + #[local] Hint Resolve function_ptr_translated : verilogproof. Lemma functions_translated: forall (v: Values.val) (f: HTL.fundef), @@ -260,14 +370,20 @@ Section CORRECTNESS. intros. exploit (Genv.find_funct_match TRANSL); eauto. intros (cu & tf & P & Q & R); exists tf; auto. Qed. - Hint Resolve functions_translated : verilogproof. + #[local] Hint Resolve functions_translated : verilogproof. Lemma senv_preserved: Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof. intros. eapply (Genv.senv_match TRANSL). Qed. - Hint Resolve senv_preserved : verilogproof. + #[local] Hint Resolve senv_preserved : verilogproof. + + Ltac unfold_replace := + match goal with + | H: HTL.mod_ram _ = _ |- context[transl_module] => + unfold transl_module; rewrite H + end. Theorem transl_step_correct : forall (S1 : HTL.state) t S2, @@ -276,12 +392,14 @@ Section CORRECTNESS. match_states S1 R1 -> exists R2, Smallstep.plus step tge R1 t R2 /\ match_states S2 R2. Proof. - induction 1; intros R1 MSTATE; inv MSTATE. + induction 1; intros R1 MSTATE; inv MSTATE; destruct (HTL.mod_ram m) eqn:?. - econstructor; split. apply Smallstep.plus_one. econstructor. - assumption. assumption. eassumption. apply valueToPos_posToValue. + unfold_replace. assumption. unfold_replace. assumption. + unfold_replace. eassumption. apply valueToPos_posToValue. split. lia. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. split. lia. apply HP. eassumption. eassumption. + unfold_replace. econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. simpl. unfold find_assocmap. unfold AssocMapExt.get_default. rewrite H. trivial. @@ -303,7 +421,40 @@ Section CORRECTNESS. econstructor. econstructor. eapply transl_list_correct. - intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [_ HP]. auto. + intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [_ HP]. + auto. apply Maps.PTree.elements_keys_norepet. eassumption. + 2: { apply valueToPos_inj. apply unsigned_posToValue_le. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. + apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. + destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. trivial. + } + apply Maps.PTree.elements_correct. eassumption. eassumption. + econstructor. econstructor. + apply mis_stepp_decl. simplify. unfold_replace. simplify. + econstructor. econstructor. econstructor. econstructor. + econstructor. + apply ram_exec_match. eauto. + apply mis_stepp_negedge_decl. simplify. auto. auto. + rewrite_eq. eauto. auto. + rewrite valueToPos_posToValue. econstructor. auto. + simplify; lia. + - inv H7. econstructor; split. apply Smallstep.plus_one. econstructor. + unfold_replace. assumption. unfold_replace. assumption. + unfold_replace. eassumption. apply valueToPos_posToValue. + split. lia. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. + unfold_replace. + econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. + simpl. unfold find_assocmap. unfold AssocMapExt.get_default. + rewrite H. trivial. + + econstructor. simpl. auto. auto. + + eapply transl_list_correct. + intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. auto. apply Maps.PTree.elements_keys_norepet. eassumption. 2: { apply valueToPos_inj. apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. @@ -314,19 +465,44 @@ Section CORRECTNESS. } apply Maps.PTree.elements_correct. eassumption. eassumption. - apply mis_stepp_decl. trivial. trivial. simpl. eassumption. auto. - rewrite valueToPos_posToValue. constructor; assumption. lia. + econstructor. econstructor. - - econstructor; split. apply Smallstep.plus_one. apply step_finish. assumption. eassumption. + eapply transl_list_correct. + intros. split. lia. pose proof (HTL.mod_wf m) as HP. + destruct HP as [_ HP]; auto. + apply Maps.PTree.elements_keys_norepet. eassumption. + 2: { apply valueToPos_inj. apply unsigned_posToValue_le. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. + apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. + destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. trivial. + } + apply Maps.PTree.elements_correct. eassumption. eassumption. + + apply mis_stepp_decl. simplify. + unfold_replace. + repeat econstructor. apply mis_stepp_negedge_decl. trivial. trivial. + simpl. unfold_replace. eassumption. auto. simplify. + rewrite valueToPos_posToValue. constructor; eassumption. simplify; lia. + - econstructor; split. apply Smallstep.plus_one. apply step_finish. + rewrite_eq. assumption. + rewrite_eq. eassumption. + econstructor; auto. + - econstructor; split. apply Smallstep.plus_one. apply step_finish. + unfold transl_module. rewrite Heqo. simplify. + assumption. unfold_replace. eassumption. constructor; assumption. - econstructor; split. apply Smallstep.plus_one. constructor. - - constructor. constructor. + repeat rewrite_eq. constructor. constructor. + - econstructor; split. apply Smallstep.plus_one. constructor. + repeat rewrite_eq. constructor. constructor. - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. - - apply match_state. assumption. + repeat rewrite_eq. apply match_state. assumption. + - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. + repeat rewrite_eq. apply match_state. assumption. Qed. - Hint Resolve transl_step_correct : verilogproof. + #[local] Hint Resolve transl_step_correct : verilogproof. Lemma transl_initial_states : forall s1 : Smallstep.state (HTL.semantics prog), @@ -344,7 +520,7 @@ Section CORRECTNESS. inv B. eauto. constructor. Qed. - Hint Resolve transl_initial_states : verilogproof. + #[local] Hint Resolve transl_initial_states : verilogproof. Lemma transl_final_states : forall (s1 : Smallstep.state (HTL.semantics prog)) @@ -356,7 +532,7 @@ Section CORRECTNESS. Proof. intros. inv H0. inv H. inv H3. constructor. reflexivity. Qed. - Hint Resolve transl_final_states : verilogproof. + #[local] Hint Resolve transl_final_states : verilogproof. Theorem transf_program_correct: forward_simulation (HTL.semantics prog) (Verilog.semantics tprog). |