Repository: sifive/Kami Branch: master Commit: ffb77238f27b Files: 66 Total size: 1.9 MB Directory structure: gitextract_xcclyzzt/ ├── .gitignore ├── All.v ├── AllDefn.v ├── AllNotations.v ├── Compiler/ │ ├── Compiler.v │ ├── CompilerDoubleWrites.v │ ├── CompilerProps.v │ ├── CompilerSimple.v │ ├── CompilerSimpleProps.v │ ├── CompilerSimpleSem.v │ ├── Rtl.v │ ├── Test.v │ └── UnverifiedIncompleteCompiler.v ├── Extraction.v ├── GallinaModules/ │ ├── AuxLemmas.v │ ├── AuxTactics.v │ └── Relations.v ├── Guard.v ├── LICENSE ├── Lib/ │ ├── EclecticLib.v │ ├── Fold.v │ ├── HexNotation.v │ ├── HexNotationWord.v │ ├── NatStr.v │ ├── VectorFacts.v │ ├── Word.v │ └── WordProperties.v ├── LibStruct.v ├── Makefile ├── Notations.v ├── NotationsTest.v ├── PPlusProperties.v ├── PProperties.v ├── Properties.v ├── README.adoc ├── Rewrites/ │ ├── Notations_rewrites.v │ ├── ReflectionImpl.v │ ├── ReflectionOrig.v │ ├── ReflectionPre.v │ ├── ReflectionSoundTheorems1.v │ ├── ReflectionSoundTheorems2.v │ └── ReflectionSoundTopTheorems.v ├── SignatureMatch.v ├── Simulator/ │ ├── CoqSim/ │ │ ├── Eval.v │ │ ├── HaskellTypes.v │ │ ├── Misc.v │ │ ├── RegisterFile.v │ │ ├── Simulator.v │ │ └── TransparentProofs.v │ ├── NativeTest.v │ └── README.adoc ├── StateMonad.v ├── Syntax.v ├── SyntaxDoubleWrites.v ├── Tactics.v ├── Tutorial/ │ ├── ExtractEx.v │ ├── GallinaActionEx.v │ ├── PhoasEx.v │ ├── SyntaxEx.v │ └── TacticsEx.v ├── Utila.v ├── WfActionT.v ├── WfMod_Helper.v ├── _CoqProject ├── fixHaskell.sh └── kami.el ================================================ FILE CONTENTS ================================================ ================================================ FILE: .gitignore ================================================ *.cache Lib/.*.aux Lib/*.v.d *.v.d *.glob Lib/*.glob *.vo *.vok *.vos Lib/*.vo *.aux Target.hs ../Target.hs *.hi *.o Compiler/PrettyPrintVerilog Compiler/CompAction obj_dir top.sv *.vcd *.mem Makefile.coq.* Makefile.coq .coqdeps.d *~ *.md *.hs FixLits .*.swk .*.swl .*.swm .*.swn .*.swo .*.swp ================================================ FILE: All.v ================================================ Require Export Kami.AllNotations. (* N.b.: this module exports notations or things dependent on them *) Require Export Kami.Extraction. ================================================ FILE: AllDefn.v ================================================ Require Export Kami.Lib.Word Kami.Lib.HexNotationWord Kami.Lib.Fold Kami.Lib.EclecticLib Kami.Utila RecordUpdate.RecordSet. Require Export Kami.Lib.NatStr. Require Export Kami.Syntax Kami.Properties Kami.PProperties Kami.PPlusProperties Kami.Tactics. ================================================ FILE: AllNotations.v ================================================ Require Export Kami.AllDefn. Require Export Kami.Notations. Require Export Kami.LibStruct. Export Kami.Lib.Word.Notations. Export ListNotations. ================================================ FILE: Compiler/Compiler.v ================================================ Require Import Kami.StateMonad Kami.Syntax Kami.Properties Kami.PProperties Kami.PPlusProperties Kami.Notations Kami.Lib.EclecticLib. Import Word.Notations. Require Import ZArith. Set Implicit Arguments. Set Asymmetric Patterns. Section Compile. Variable ty: Kind -> Type. Variable regMapTy: Type. Inductive RegMapExpr: Type := | VarRegMap (v: regMapTy): RegMapExpr | UpdRegMap (r: string) (pred: Bool @# ty) (k: FullKind) (val: Expr ty k) (regMap: RegMapExpr): RegMapExpr | CompactRegMap (regMap: RegMapExpr): RegMapExpr. Inductive CompActionT: Kind -> Type := | CompCall (f: string) (argRetK: Kind * Kind) (pred: Bool @# ty) (arg: fst argRetK @# ty) lret (cont: fullType ty (SyntaxKind (snd argRetK)) -> CompActionT lret): CompActionT lret | CompLetExpr k (e: Expr ty k) lret (cont: fullType ty k -> CompActionT lret): CompActionT lret | CompNondet k lret (cont: fullType ty k -> CompActionT lret): CompActionT lret | CompSys (pred: Bool @# ty) (ls: list (SysT ty)) lret (cont: CompActionT lret): CompActionT lret | CompRead (r: string) (k: FullKind) (readMap: RegMapExpr) lret (cont: fullType ty k -> CompActionT lret): CompActionT lret | CompRet lret (e: lret @# ty) (newMap: RegMapExpr) : CompActionT lret | CompLetFull k (a: CompActionT k) lret (cont: fullType ty (SyntaxKind k) -> regMapTy -> CompActionT lret): CompActionT lret | CompAsyncRead (idxNum num : nat) (readPort dataArray writePort: string) (isWriteMask: bool) (idx : Bit (Nat.log2_up idxNum) @# ty) (pred : Bool @# ty) (k : Kind) (writeMap readMap : RegMapExpr) lret (cont : fullType ty (SyntaxKind (Array num k)) -> regMapTy -> CompActionT lret) : CompActionT lret | CompWrite (idxNum num : nat) (writePort dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# ty) (Data : Kind) (val : Array num Data @# ty) (mask : option (Array num Bool @# ty)) (pred : Bool @# ty) (writeMap readMap : RegMapExpr) lret (cont : regMapTy -> CompActionT lret) : CompActionT lret | CompSyncReadReq (idxNum num : nat) (readReq readReg dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# ty) (Data : Kind) (isAddr : bool) (pred : Bool @# ty) (writeMap readMap : RegMapExpr) lret (cont : regMapTy -> CompActionT lret) : CompActionT lret | CompSyncReadRes (idxNum num : nat) (readResp readReg dataArray writePort : string) (isWriteMask: bool) (Data : Kind) (isAddr : bool) (writeMap readMap : RegMapExpr) lret (cont : fullType ty (SyntaxKind (Array num Data)) -> regMapTy -> CompActionT lret) : CompActionT lret. Inductive EActionT (lretT : Kind) : Type := | EMCall (meth : string) s (e : Expr ty (SyntaxKind (fst s))) (cont : (fullType ty (SyntaxKind (snd s))) -> EActionT lretT) : EActionT lretT | ELetExpr (k : FullKind) (e : Expr ty k) (cont : fullType ty k -> EActionT lretT) : EActionT lretT | ELetAction (k : Kind) (a : EActionT k) (cont : fullType ty (SyntaxKind k) -> EActionT lretT) : EActionT lretT | EReadNondet (k : FullKind) (cont : fullType ty k -> EActionT lretT) : EActionT lretT | EReadReg (r : string) (k : FullKind) (cont : fullType ty k -> EActionT lretT) : EActionT lretT | EWriteReg (r : string) (k : FullKind) (e : Expr ty k) (cont : EActionT lretT) : EActionT lretT | EIfElse : Expr ty (SyntaxKind Bool) -> forall k, EActionT k -> EActionT k -> (fullType ty (SyntaxKind k) -> EActionT lretT) -> EActionT lretT | ESys (ls : list (SysT ty)) (cont : EActionT lretT) : EActionT lretT | EReturn (e : Expr ty (SyntaxKind lretT)) : EActionT lretT | EAsyncRead (idxNum num : nat) (readPort dataArray writePort : string) (isWriteMask: bool) (idx : Bit (Nat.log2_up idxNum) @# ty) (k : Kind) (cont : fullType ty (SyntaxKind (Array num k)) -> EActionT lretT) : EActionT lretT | EWrite (idxNum num : nat) (write dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# ty) (Data : Kind) (val : Array num Data @# ty) (mask : option (Array num Bool @# ty)) (cont : EActionT lretT) : EActionT lretT | ESyncReadReq (idxNum num : nat) (readReq readReg dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# ty) (Data : Kind) (isAddr : bool) (cont : EActionT lretT) : EActionT lretT | ESyncReadRes (idxNum num : nat) (readRes readReg dataArray writePort: string) (isWriteMask: bool) (Data : Kind) (isAddr : bool) (cont : fullType ty (SyntaxKind (Array num Data)) -> EActionT lretT) : EActionT lretT. Fixpoint Action_EAction (lretT : Kind) (a : ActionT ty lretT) : EActionT lretT := match a in ActionT _ _ with | MCall meth k argExpr cont => EMCall meth k argExpr (fun v => Action_EAction (cont v)) | Return x => EReturn x | LetExpr k' expr cont => ELetExpr expr (fun v => Action_EAction (cont v)) | ReadNondet k' cont => EReadNondet k' (fun ret => Action_EAction (cont ret)) | Sys ls cont => ESys ls (Action_EAction cont) | ReadReg r k' cont => EReadReg r k' (fun v => Action_EAction (cont v)) | WriteReg r k' expr cont => EWriteReg r expr (Action_EAction cont) | LetAction k' a' cont => ELetAction (Action_EAction a') (fun v => Action_EAction (cont v)) | IfElse pred' k' aT aF cont => EIfElse pred' (Action_EAction aT) (Action_EAction aF) (fun v => Action_EAction (cont v)) end. Section ReadMap. Variable readMap: regMapTy. Fixpoint compileAction k (a: ActionT ty k) (pred: Bool @# ty) (writeMap: RegMapExpr) {struct a}: CompActionT k := match a in ActionT _ _ with | MCall meth k argExpr cont => CompCall meth k pred argExpr (fun ret => @compileAction _ (cont ret) pred writeMap) | Return x => CompRet x writeMap | LetExpr k' expr cont => CompLetExpr expr (fun ret => @compileAction _ (cont ret) pred writeMap) | ReadNondet k' cont => CompNondet k' (fun ret => @compileAction _ (cont ret) pred writeMap) | Sys ls cont => CompSys pred ls (compileAction cont pred writeMap) | ReadReg r k' cont => @CompRead r k' (VarRegMap readMap) _ (fun v => @compileAction _ (cont v) pred writeMap) | WriteReg r k' expr cont => CompLetFull (CompRet ($$ WO)%kami_expr (UpdRegMap r pred expr writeMap)) (fun _ v => @compileAction _ cont pred (VarRegMap v)) | LetAction k' a' cont => CompLetFull (@compileAction k' a' pred writeMap) (fun retval writeMap' => @compileAction k (cont retval) pred (VarRegMap writeMap')) | IfElse pred' k' aT aF cont => CompLetExpr (pred && pred')%kami_expr (fun truePred => CompLetExpr (pred && !pred')%kami_expr (fun falsePred => CompLetFull (@compileAction k' aT (#truePred)%kami_expr writeMap) (fun valT writesT => CompLetFull (@compileAction k' aF (#falsePred)%kami_expr (VarRegMap writesT)) (fun valF writesF => CompLetExpr (IF pred' then #valT else #valF)%kami_expr (fun val => (@compileAction k (cont val) pred (VarRegMap writesF))) )))) end. Fixpoint EcompileAction k (a : EActionT k) (pred : Bool @# ty) (writeMap : RegMapExpr) {struct a} : CompActionT k := match a in EActionT _ with | EMCall meth k argExpr cont => CompCall meth k pred argExpr (fun ret => @EcompileAction _ (cont ret) pred writeMap) | EReturn x => CompRet x writeMap | ELetExpr k' expr cont => CompLetExpr expr (fun ret => @EcompileAction _ (cont ret) pred writeMap) | EReadNondet k' cont => CompNondet k' (fun ret => @EcompileAction _ (cont ret) pred writeMap) | ESys ls cont => CompSys pred ls (EcompileAction cont pred writeMap) | EReadReg r k' cont => @CompRead r k' (VarRegMap readMap) _ (fun v => @EcompileAction _ (cont v) pred writeMap) | EWriteReg r k' expr cont => CompLetFull (CompRet ($$ WO)%kami_expr (UpdRegMap r pred expr writeMap)) (fun _ v => @EcompileAction _ cont pred (VarRegMap v)) | ELetAction k' a' cont => CompLetFull (@EcompileAction k' a' pred writeMap) (fun retval writeMap' => @EcompileAction k (cont retval) pred (VarRegMap writeMap')) | EIfElse pred' k' aT aF cont => CompLetExpr (pred && pred')%kami_expr (fun truePred => CompLetExpr (pred && !pred')%kami_expr (fun falsePred => CompLetFull (@EcompileAction k' aT (#truePred)%kami_expr writeMap) (fun valT writesT => CompLetFull (@EcompileAction k' aF (#falsePred)%kami_expr (VarRegMap writesT)) (fun valF writesF => CompLetExpr (IF pred' then #valT else #valF)%kami_expr (fun val => (@EcompileAction k (cont val) pred (VarRegMap writesF))) )))) | EAsyncRead idxNum num readPort dataArray writePort isWriteMask idx k cont => CompAsyncRead idxNum readPort dataArray writePort isWriteMask idx pred writeMap (VarRegMap readMap) (fun array writeMap' => @EcompileAction _ (cont array) pred (VarRegMap writeMap')) | EWrite idxNum num writePort dataArray idx Data val mask cont => CompWrite idxNum writePort dataArray idx val mask pred writeMap (VarRegMap readMap) (fun writeMap' => @EcompileAction _ cont pred (VarRegMap writeMap')) | ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr cont => CompSyncReadReq idxNum num readReq readReg dataArray idx Data isAddr pred writeMap (VarRegMap readMap) (fun writeMap' => @EcompileAction _ cont pred (VarRegMap writeMap')) | ESyncReadRes idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr cont => CompSyncReadRes idxNum readResp readReg dataArray writePort isWriteMask isAddr writeMap (VarRegMap readMap) (fun array writeMap' => @EcompileAction _ (cont array) pred (VarRegMap writeMap')) end. Fixpoint inlineWriteFile k (rf : RegFileBase) (a : EActionT k) : EActionT k := match rf with | @Build_RegFileBase _isWrMask _num _dataArray _readers _write _idxNum _Data _init => match a with | EMCall g sign arg cont => match String.eqb _write g with | true => if _isWrMask then match Signature_dec sign (WriteRqMask (Nat.log2_up _idxNum) _num _Data, Void) with | left isEq => let inValue := (match isEq in _ = Y return Expr ty (SyntaxKind (fst Y)) with | eq_refl => arg end) in ELetExpr ($$ WO)%kami_expr (fun v => EWrite _idxNum _write _dataArray (inValue @% "addr")%kami_expr (inValue @% "data")%kami_expr (Some (inValue @% "mask")%kami_expr) (inlineWriteFile rf (match isEq in _ = Y return fullType ty (SyntaxKind (snd Y)) -> EActionT k with | eq_refl => cont end v))) | right _ => EMCall g sign arg (fun ret => inlineWriteFile rf (cont ret)) end else match Signature_dec sign (WriteRq (Nat.log2_up _idxNum) (Array _num _Data), Void) with | left isEq => let inValue := (match isEq in _ = Y return Expr ty (SyntaxKind (fst Y)) with | eq_refl => arg end) in ELetExpr ($$ WO)%kami_expr (fun v => EWrite _idxNum _write _dataArray (inValue @% "addr")%kami_expr (inValue @% "data")%kami_expr None (inlineWriteFile rf (match isEq in _ = Y return fullType ty (SyntaxKind (snd Y)) -> EActionT k with | eq_refl => cont end v))) | right _ => EMCall g sign arg (fun ret => inlineWriteFile rf (cont ret)) end | false => EMCall g sign arg (fun ret => inlineWriteFile rf (cont ret)) end | ELetExpr _ e cont => ELetExpr e (fun ret => inlineWriteFile rf (cont ret)) | ELetAction _ a cont => ELetAction (inlineWriteFile rf a) (fun ret => inlineWriteFile rf (cont ret)) | EReadNondet k c => EReadNondet k (fun ret => inlineWriteFile rf (c ret)) | EReadReg r k c => EReadReg r k (fun ret => inlineWriteFile rf (c ret)) | EWriteReg r k e a => EWriteReg r e (inlineWriteFile rf a) | EIfElse p _ aT aF c => EIfElse p (inlineWriteFile rf aT) (inlineWriteFile rf aF) (fun ret => inlineWriteFile rf (c ret)) | ESys ls c => ESys ls (inlineWriteFile rf c) | EReturn e => EReturn e | EAsyncRead idxNum num readPort dataArray writePort isWriteMask idx k cont => EAsyncRead idxNum readPort dataArray writePort isWriteMask idx (fun ret => inlineWriteFile rf (cont ret)) | EWrite idxNum num writePort dataArray idx Data val mask cont => EWrite idxNum writePort dataArray idx val mask (inlineWriteFile rf cont) | ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr cont => ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr (inlineWriteFile rf cont) | ESyncReadRes idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr cont => ESyncReadRes idxNum readResp readReg dataArray writePort isWriteMask isAddr (fun v => inlineWriteFile rf (cont v)) end end. Fixpoint inlineAsyncReadFile (read : string) (rf : RegFileBase) k (a : EActionT k) : EActionT k := match rf with | @Build_RegFileBase _isWrMask _num _dataArray _readers _write _idxNum _Data _init => match _readers with | Async reads => match (existsb (String.eqb read) reads) with | true => match a with | EMCall g sign arg cont => match String.eqb read g with | true => match Signature_dec sign (Bit (Nat.log2_up _idxNum), Array _num _Data) with | left isEq => let inValue := (match isEq in _ = Y return Expr ty (SyntaxKind (fst Y)) with | eq_refl => arg end) in EAsyncRead _idxNum read _dataArray _write _isWrMask inValue (fun array => inlineAsyncReadFile read rf (match isEq in _ = Y return fullType ty (SyntaxKind (snd Y)) -> EActionT k with | eq_refl => cont end array)) | right _ => EMCall g sign arg (fun ret => inlineAsyncReadFile read rf (cont ret)) end | false => EMCall g sign arg (fun ret => inlineAsyncReadFile read rf (cont ret)) end | ELetExpr _ e cont => ELetExpr e (fun ret => inlineAsyncReadFile read rf (cont ret)) | ELetAction _ a cont => ELetAction (inlineAsyncReadFile read rf a) (fun ret => inlineAsyncReadFile read rf (cont ret)) | EReadNondet k c => EReadNondet k (fun ret => inlineAsyncReadFile read rf (c ret)) | EReadReg r k c => EReadReg r k (fun ret => inlineAsyncReadFile read rf (c ret)) | EWriteReg r k e a => EWriteReg r e (inlineAsyncReadFile read rf a) | EIfElse p _ aT aF c => EIfElse p (inlineAsyncReadFile read rf aT) (inlineAsyncReadFile read rf aF) (fun ret => inlineAsyncReadFile read rf (c ret)) | ESys ls c => ESys ls (inlineAsyncReadFile read rf c) | EReturn e => EReturn e | EAsyncRead idxNum num readPort dataArray writePort isWriteMask idx k cont => EAsyncRead idxNum readPort dataArray writePort isWriteMask idx (fun ret => inlineAsyncReadFile read rf (cont ret)) | EWrite idxNum num writePort dataArray idx Data val mask cont => EWrite idxNum writePort dataArray idx val mask (inlineAsyncReadFile read rf cont) | ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr cont => ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr (inlineAsyncReadFile read rf cont) | ESyncReadRes idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr cont => ESyncReadRes idxNum readResp readReg dataArray writePort isWriteMask isAddr (fun v => inlineAsyncReadFile read rf (cont v)) end | false => a end | Sync _ _ => a end end. Lemma SyncRead_eq_dec (r r' : SyncRead) : {r = r'} + {r <> r'}. Proof. destruct (string_dec (readReqName r) (readReqName r')), (string_dec (readResName r) (readResName r')), (string_dec (readRegName r) (readRegName r')), r, r'; simpl in *; subst; auto; right; intro; inv H; auto. Qed. Definition SyncRead_eqb (r r' : SyncRead) : bool := (String.eqb (readReqName r) (readReqName r')) && (String.eqb (readResName r) (readResName r')) && (String.eqb (readRegName r) (readRegName r')). Lemma SyncRead_eqb_eq (r r' : SyncRead) : SyncRead_eqb r r' = true <-> r = r'. Proof. split; intros. - unfold SyncRead_eqb in H. repeat (apply andb_prop in H; dest; rewrite String.eqb_eq in *). destruct r, r'; simpl in *; subst; auto. - rewrite H. unfold SyncRead_eqb; repeat rewrite eqb_refl; auto. Qed. Fixpoint inlineSyncResFile (read : SyncRead) (rf : RegFileBase) k (a : EActionT k) : EActionT k := match rf with | @Build_RegFileBase _isWrMask _num _dataArray _readers _write _idxNum _Data _init => match read with | @Build_SyncRead _readReqName _readResName _readRegName => match _readers with | Async _ => a | Sync isAddr reads => match (existsb (SyncRead_eqb read) reads) with | true => match a with | EMCall g sign arg cont => match String.eqb _readResName g with | true => match Signature_dec sign (Void, Array _num _Data) with | left isEq => ESyncReadRes _idxNum _readResName _readRegName _dataArray _write _isWrMask isAddr (fun array => inlineSyncResFile read rf (match isEq in _ = Y return fullType ty (SyntaxKind (snd Y)) -> EActionT k with | eq_refl => cont end array)) | right _ => EMCall g sign arg (fun ret => inlineSyncResFile read rf (cont ret)) end | false => EMCall g sign arg (fun ret => inlineSyncResFile read rf (cont ret)) end | ELetExpr _ e cont => ELetExpr e (fun ret => inlineSyncResFile read rf (cont ret)) | ELetAction _ a cont => ELetAction (inlineSyncResFile read rf a) (fun ret => inlineSyncResFile read rf (cont ret)) | EReadNondet k c => EReadNondet k (fun ret => inlineSyncResFile read rf (c ret)) | EReadReg r k c => EReadReg r k (fun ret => inlineSyncResFile read rf (c ret)) | EWriteReg r k e a => EWriteReg r e (inlineSyncResFile read rf a) | EIfElse p _ aT aF c => EIfElse p (inlineSyncResFile read rf aT) (inlineSyncResFile read rf aF) (fun ret => inlineSyncResFile read rf (c ret)) | ESys ls c => ESys ls (inlineSyncResFile read rf c) | EReturn e => EReturn e | EAsyncRead idxNum num readPort dataArray writePort isWriteMask idx k cont => EAsyncRead idxNum readPort dataArray writePort isWriteMask idx (fun ret => inlineSyncResFile read rf (cont ret)) | EWrite idxNum num writePort dataArray idx Data val mask cont => EWrite idxNum writePort dataArray idx val mask (inlineSyncResFile read rf cont) | ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr cont => ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr (inlineSyncResFile read rf cont) | ESyncReadRes idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr cont => ESyncReadRes idxNum readResp readReg dataArray writePort isWriteMask isAddr (fun v => inlineSyncResFile read rf (cont v)) end | false => a end end end end. Fixpoint inlineSyncReqFile (read : SyncRead) (rf : RegFileBase) k (a : EActionT k) : EActionT k := match rf with | @Build_RegFileBase _isWrMask _num _dataArray _readers _write _idxNum _Data _init => match read with | @Build_SyncRead _readReqName _readResName _readRegName => match _readers with | Async _ => a | Sync isAddr reads => match (existsb (SyncRead_eqb read) reads) with | true => match a with | EMCall g sign arg cont => match String.eqb _readReqName g with | true => match Signature_dec sign (Bit (Nat.log2_up _idxNum), Void) with | left isEq => let inValue := (match isEq in _ = Y return Expr ty (SyntaxKind (fst Y)) with | eq_refl => arg end) in ELetExpr ($$ WO)%kami_expr (fun v => ESyncReadReq _idxNum _num _readReqName _readRegName _dataArray inValue _Data isAddr (inlineSyncReqFile read rf (match isEq in _ = Y return fullType ty (SyntaxKind (snd Y)) -> EActionT k with | eq_refl => cont end v))) | right _ => EMCall g sign arg (fun ret => inlineSyncReqFile read rf (cont ret)) end | false => EMCall g sign arg (fun ret => inlineSyncReqFile read rf (cont ret)) end | ELetExpr _ e cont => ELetExpr e (fun ret => inlineSyncReqFile read rf (cont ret)) | ELetAction _ a cont => ELetAction (inlineSyncReqFile read rf a) (fun ret => inlineSyncReqFile read rf (cont ret)) | EReadNondet k c => EReadNondet k (fun ret => inlineSyncReqFile read rf (c ret)) | EReadReg r k c => EReadReg r k (fun ret => inlineSyncReqFile read rf (c ret)) | EWriteReg r k e a => EWriteReg r e (inlineSyncReqFile read rf a) | EIfElse p _ aT aF c => EIfElse p (inlineSyncReqFile read rf aT) (inlineSyncReqFile read rf aF) (fun ret => inlineSyncReqFile read rf (c ret)) | ESys ls c => ESys ls (inlineSyncReqFile read rf c) | EReturn e => EReturn e | EAsyncRead idxNum num readPort dataArray writePort isWriteMask idx k cont => EAsyncRead idxNum readPort dataArray writePort isWriteMask idx (fun ret => inlineSyncReqFile read rf (cont ret)) | EWrite idxNum num writePort dataArray idx Data val mask cont => EWrite idxNum writePort dataArray idx val mask (inlineSyncReqFile read rf cont) | ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr cont => ESyncReadReq idxNum num readReq readReg dataArray idx Data isAddr (inlineSyncReqFile read rf cont) | ESyncReadRes idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr cont => ESyncReadRes idxNum readResp readReg dataArray writePort isWriteMask isAddr (fun v => inlineSyncReqFile read rf (cont v)) end | false => a end end end end. End ReadMap. Definition getRegFileWrite (rf : RegFileBase) : DefMethT := match rf with | @Build_RegFileBase isWrMask num dataArray _ write idxNum Data _ => writeRegFileFn isWrMask num dataArray write idxNum Data end. Definition getAsyncReads (rf : RegFileBase) (read : string) : DefMethT := (read, existT MethodT (Bit (Nat.log2_up (rfIdxNum rf)), Array (rfNum rf) (rfData rf)) (buildNumDataArray (rfNum rf) (rfDataArray rf) (rfIdxNum rf) (rfData rf))). Definition getSyncReq (rf : RegFileBase) (isAddr : bool) (read : SyncRead) : DefMethT := if isAddr then (readReqName read, existT MethodT (Bit (Nat.log2_up (rfIdxNum rf)), Void) (fun (ty : Kind -> Type) (idx : fullType ty (SyntaxKind (fst (Bit (Nat.log2_up (rfIdxNum rf)), Void)))) => (Write readRegName read : fst (Bit (Nat.log2_up (rfIdxNum rf)), Void) <- Var ty (SyntaxKind (fst (Bit (Nat.log2_up (rfIdxNum rf)), Void))) idx; Ret Const ty WO)%kami_action)) else (readReqName read, existT MethodT (Bit (Nat.log2_up (rfIdxNum rf)), Void) (fun (ty : Kind -> Type) (idx : fullType ty (SyntaxKind (fst (Bit (Nat.log2_up (rfIdxNum rf)), Void)))) => (LETA vals : Array (rfNum rf) (rfData rf) <- buildNumDataArray (rfNum rf) (rfDataArray rf) (rfIdxNum rf) (rfData rf) ty idx; Write readRegName read : Array (rfNum rf) (rfData rf) <- Var ty (SyntaxKind (Array (rfNum rf) (rfData rf))) vals; Ret Const ty WO)%kami_action)). Definition getSyncRes (rf : RegFileBase) (isAddr : bool) (read : SyncRead) : DefMethT := if isAddr then (readResName read, existT MethodT (Void, Array (rfNum rf) (rfData rf)) (fun (ty : Kind -> Type) (_ : fullType ty (SyntaxKind (fst (Void, Array (rfNum rf) (rfData rf))))) => (Read name : Bit (Nat.log2_up (rfIdxNum rf)) <- readRegName read; buildNumDataArray (rfNum rf) (rfDataArray rf) (rfIdxNum rf) (rfData rf) ty name)%kami_action)) else (readResName read, existT MethodT (Void, Array (rfNum rf) (rfData rf)) (fun (ty : Kind -> Type) (_ : fullType ty (SyntaxKind (fst (Void, Array (rfNum rf) (rfData rf))))) => (Read data : Array (rfNum rf) (rfData rf) <- readRegName read; Ret Var ty (SyntaxKind (Array (rfNum rf) (rfData rf))) data)%kami_action)). Definition inlineSingle_Flat_pos meths1 meths2 n := match nth_error meths1 n with | Some f => map (inlineSingle_Meth f) meths2 | None => meths2 end. Definition inlineSingle_pos k meths (a : ActionT ty k) n := match nth_error meths n with | Some f => inlineSingle a f | None => a end. Definition getEachRfMethod (rf : RegFileBase) : list DefMethT := (getRegFileWrite rf :: match (rfRead rf) with | Async read => map (getAsyncReads rf) read | Sync isAddr read => map (getSyncReq rf isAddr) read ++ map (getSyncRes rf isAddr) read end). Definition EgetRegFileMapMethods k (rf : RegFileBase) : list (EActionT k -> EActionT k) := (inlineWriteFile rf :: match (rfRead rf) with | Async read => map (fun x => @inlineAsyncReadFile x rf k) read | Sync isAddr read => map (fun x => @inlineSyncReqFile x rf k) read ++ map (fun x => @inlineSyncResFile x rf k) read end). Definition EeachRfMethodInliners k (lrf : list RegFileBase) : list (EActionT k -> EActionT k) := concat (map (fun rf => EgetRegFileMapMethods k rf) lrf). Definition eachRfMethodInliners k (lrf : list RegFileBase) : list (ActionT ty k -> ActionT ty k) := (concat (map (fun rf => (map (fun f a' => @inlineSingle ty k a' f) (getRegFileMethods rf))) lrf)). Definition apply_nth {A : Type} (lf : list (A -> A)) (a : A) (n : nat) := match nth_error lf n with | Some f => f a | None => a end. Definition preCompileRegFiles k (ea : EActionT k) (lrf : list RegFileBase) : EActionT k := fold_left (apply_nth (EeachRfMethodInliners k lrf)) (seq 0 (length (EeachRfMethodInliners k lrf))) ea. Definition compileActions (readMap : regMapTy) (acts: list (ActionT ty Void)) := fold_left (fun acc a => CompLetFull acc (fun _ writeMap => (CompLetFull (CompRet ($$ WO)%kami_expr (CompactRegMap (VarRegMap writeMap))) (fun _ v => @compileAction v _ a ($$ true)%kami_expr (VarRegMap v))))) acts (CompRet ($$ WO)%kami_expr (VarRegMap readMap)). Definition compileActionsRf (readMap : regMapTy) (acts : list (ActionT ty Void)) (lrf : list RegFileBase) := fold_left (fun acc a => CompLetFull acc (fun _ writeMap => (CompLetFull (CompRet ($$ WO)%kami_expr (CompactRegMap (VarRegMap writeMap))) (fun _ v => @EcompileAction v _ (preCompileRegFiles (Action_EAction a) lrf) ($$ true)%kami_expr (VarRegMap v))))) acts (CompRet ($$ WO)%kami_expr (VarRegMap readMap)). Definition compileRules (readMap : regMapTy) (rules: list RuleT) := compileActions readMap (map (fun a => snd a ty) rules). Definition compileRulesRf (readMap : regMapTy) (rules : list RuleT) (lrf : list RegFileBase) := compileActionsRf readMap (map (fun a => snd a ty) rules) lrf. End Compile. Section Semantics. Local Notation UpdRegT := RegsT. Local Notation UpdRegsT := (list UpdRegT). Local Notation RegMapType := (RegsT * UpdRegsT)%type. Section PriorityUpds. Variable o: RegsT. Inductive PriorityUpds: UpdRegsT -> RegsT -> Prop := | NoUpds: PriorityUpds nil o | ConsUpds (prevUpds: UpdRegsT) (prevRegs: RegsT) (prevCorrect: PriorityUpds prevUpds prevRegs) (u: UpdRegT) (curr: RegsT) (currRegsTCurr: getKindAttr o = getKindAttr curr) (Hcurr: forall s v, In (s, v) curr -> In (s, v) u \/ ((~ In s (map fst u)) /\ In (s, v) prevRegs)) fullU (HFullU: fullU = u :: prevUpds): PriorityUpds fullU curr. Lemma prevPrevRegsTrue prevUpds: forall prev, PriorityUpds prevUpds prev -> getKindAttr o = getKindAttr prev. Proof. induction 1; eauto. Qed. End PriorityUpds. Inductive SemRegMapExpr: (RegMapExpr type RegMapType) -> RegMapType -> Prop := | SemVarRegMap v: SemRegMapExpr (VarRegMap _ v) v | SemUpdRegMapTrue r (pred: Bool @# type) k val regMap (PredTrue: evalExpr pred = true) old upds (HSemRegMap: SemRegMapExpr regMap (old, upds)) upds' (HEqual : upds' = (hd nil upds ++ ((r, existT _ k (evalExpr val)) :: nil)) :: tl upds): SemRegMapExpr (@UpdRegMap _ _ r pred k val regMap) (old, upds') | SemUpdRegMapFalse r (pred: Bool @# type) k val regMap (PredTrue: evalExpr pred = false) old upds (HSemRegMap: SemRegMapExpr regMap (old, upds)): SemRegMapExpr (@UpdRegMap _ _ r pred k val regMap) (old, upds) | SemCompactRegMap old upds regMap (HSemRegMap: SemRegMapExpr regMap (old, upds)): SemRegMapExpr (@CompactRegMap _ _ regMap) (old, nil::upds). Definition WfRegMapExpr (regMapExpr : RegMapExpr type RegMapType) (regMap : RegMapType) := SemRegMapExpr regMapExpr regMap /\ let '(old, new) := regMap in forall u, In u new -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old). Inductive SemCompActionT: forall k, CompActionT type RegMapType k -> RegMapType -> MethsT -> type k -> Prop := | SemCompCallTrue (f: string) (argRetK: Kind * Kind) (pred: Bool @# type) (arg: fst argRetK @# type) lret (cont: fullType type (SyntaxKind (snd argRetK)) -> CompActionT _ _ lret) (ret: fullType type (SyntaxKind (snd argRetK))) regMap calls val newCalls (HNewCalls : newCalls = (f, existT _ argRetK (evalExpr arg, ret)) :: calls) (HSemCompActionT: SemCompActionT (cont ret) regMap calls val) (HPred : evalExpr pred = true): SemCompActionT (@CompCall _ _ f argRetK pred arg lret cont) regMap newCalls val | SemCompCallFalse (f: string) (argRetK: Kind * Kind) (pred: Bool @# type) (arg: fst argRetK @# type) lret (cont: fullType type (SyntaxKind (snd argRetK)) -> CompActionT _ _ lret) (ret: fullType type (SyntaxKind (snd argRetK))) regMap calls val (HSemCompActionT: SemCompActionT (cont ret) regMap calls val) (HPred : evalExpr pred = false): SemCompActionT (@CompCall _ _ f argRetK pred arg lret cont) regMap calls val | SemCompLetExpr k e lret cont regMap calls val (HSemCompActionT: SemCompActionT (cont (evalExpr e)) regMap calls val): SemCompActionT (@CompLetExpr _ _ k e lret cont) regMap calls val | SemCompNondet k lret cont ret regMap calls val (HSemCompActionT: SemCompActionT (cont ret) regMap calls val): SemCompActionT (@CompNondet _ _ k lret cont) regMap calls val | SemCompSys pred ls lret cont regMap calls val (HSemCompActionT: SemCompActionT cont regMap calls val): SemCompActionT (@CompSys _ _ pred ls lret cont) regMap calls val | SemCompRead r k readMap lret cont regMap calls val regVal updatedRegs readMapValOld readMapValUpds (HReadMap: SemRegMapExpr readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs: PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn: In (r, (existT _ k regVal)) updatedRegs) (HSemCompActionT: SemCompActionT (cont regVal) regMap calls val): SemCompActionT (@CompRead _ _ r k readMap lret cont) regMap calls val | SemCompRet lret e regMap regMapVal calls (HCallsNil : calls = nil) (HRegMapWf: WfRegMapExpr regMap regMapVal): SemCompActionT (@CompRet _ _ lret e regMap) regMapVal calls (evalExpr e) | SemCompLetFull k a lret cont regMap_a calls_a val_a (HSemCompActionT_a: SemCompActionT a regMap_a calls_a val_a) regMap_cont calls_cont val_cont newCalls (HNewCalls : newCalls = calls_a ++ calls_cont) (HSemCompActionT_cont: SemCompActionT (cont val_a regMap_a) regMap_cont calls_cont val_cont): SemCompActionT (@CompLetFull _ _ k a lret cont) regMap_cont newCalls val_cont | SemCompAsyncRead num (readPort dataArray writePort: string) isWriteMask idxNum (idx : Bit (Nat.log2_up idxNum) @# type) pred Data readMap lret updatedRegs readMapValOld readMapValUpds regVal writeMap writeMapTy regMap (HWriteMap: SemRegMapExpr writeMap writeMapTy) (HReadMap : SemRegMapExpr readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regVal)) updatedRegs) cont calls val contArray (HContArray : contArray = BuildArray (fun i : Fin.t num => ReadArray (Var type _ regVal) (CABit Add (Var type (SyntaxKind _) (evalExpr idx) :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil)))) (HSemCompActionT : SemCompActionT (cont (evalExpr contArray) writeMapTy) regMap calls val): SemCompActionT (@CompAsyncRead _ _ idxNum num readPort dataArray writePort isWriteMask idx pred Data writeMap readMap lret cont) regMap calls val | SemCompWriteSome num (writePort dataArray : string) idxNum (idx : Bit (Nat.log2_up idxNum) @# type) Data (array : Array num Data @# type) (optMask : option (Array num Bool @# type)) (writeMap readMap : RegMapExpr type RegMapType) lret mask (HMask : optMask = Some mask) updatedRegs readMapValOld readMapValUpds regVal (HReadMap : SemRegMapExpr readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regVal)) updatedRegs) regMapVal pred (HUpdate : WfRegMapExpr (UpdRegMap dataArray pred (fold_left (fun newArr i => ITE (ReadArrayConst mask i) (UpdateArray newArr (CABit Add (idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil)) (ReadArrayConst array i)) newArr ) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regVal)) writeMap) regMapVal) cont regMap_cont calls val (HSemCompActionT : SemCompActionT (cont regMapVal) regMap_cont calls val): SemCompActionT (@CompWrite _ _ idxNum num writePort dataArray idx Data array optMask pred writeMap readMap lret cont) regMap_cont calls val | SemCompWriteNone num (writePort dataArray : string) idxNum (idx : Bit (Nat.log2_up idxNum) @# type) Data (array : Array num Data @# type) (optMask : option (Array num Bool @# type)) (writeMap readMap : RegMapExpr type RegMapType) lret (HMask : optMask = None) updatedRegs readMapValOld readMapValUpds regVal (HReadMap : SemRegMapExpr readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regVal)) updatedRegs) regMapVal pred (HUpdate : WfRegMapExpr (UpdRegMap dataArray pred (fold_left (fun newArr i => (UpdateArray newArr (CABit Add (idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil)) (ReadArrayConst array i)) ) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regVal)) writeMap) regMapVal) cont regMap_cont calls val (HSemCompActionT : SemCompActionT (cont regMapVal) regMap_cont calls val): SemCompActionT (@CompWrite _ _ idxNum num writePort dataArray idx Data array optMask pred writeMap readMap lret cont) regMap_cont calls val | SemCompSyncReadReqTrue num idxNum readReqName readRegName dataArray (idx : Bit (Nat.log2_up idxNum) @# type) k (isAddr : bool) (writeMap : RegMapExpr type RegMapType) readMap lret cont regMapVal pred (HisAddr : isAddr = true) (HWriteMap : WfRegMapExpr (UpdRegMap readRegName pred (Var type (SyntaxKind _) (evalExpr idx)) writeMap) regMapVal) regMap_cont calls val (HSemCompActionT : SemCompActionT (cont regMapVal) regMap_cont calls val): SemCompActionT (@CompSyncReadReq _ _ idxNum num readReqName readRegName dataArray idx k isAddr pred writeMap readMap lret cont) regMap_cont calls val | SemCompSyncReadReqFalse num idxNum readReqName readRegName dataArray (idx : Bit (Nat.log2_up idxNum) @# type) Data (isAddr : bool) (writeMap : RegMapExpr type RegMapType) readMap lret cont regMapVal pred (HisAddr : isAddr = false) updatedRegs readMapValOld readMapValUpds regV (HReadMap : SemRegMapExpr readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HRegVal : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regV)) updatedRegs) (HWriteMap : WfRegMapExpr (UpdRegMap readRegName pred (BuildArray (fun i : Fin.t num => ReadArray (Var type _ regV) (CABit Add (Var type (SyntaxKind _) (evalExpr idx) :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil)))) writeMap) regMapVal) regMap_cont calls val (HSemCompActionT : SemCompActionT (cont regMapVal) regMap_cont calls val): SemCompActionT (@CompSyncReadReq _ _ idxNum num readReqName readRegName dataArray idx Data isAddr pred writeMap readMap lret cont) regMap_cont calls val | SemCompSyncReadResTrue num idxNum readRespName readRegName dataArray writePort isWriteMask Data isAddr writeMap readMap lret cont (HisAddr : isAddr = true) writeMapTy updatedRegs readMapValOld readMapValUpds regVal idx (HWriteMap: SemRegMapExpr writeMap writeMapTy) (HReadMap : SemRegMapExpr readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HRegVal1 : In (readRegName, existT _ (SyntaxKind (Bit (Nat.log2_up idxNum))) idx) updatedRegs) (HRegVal2 : In (dataArray, existT _ (SyntaxKind (Array idxNum Data)) regVal) updatedRegs) (contArray : Expr type (SyntaxKind (Array num Data))) (HContArray : contArray = BuildArray (fun i : Fin.t num => ReadArray (Var type _ regVal) (CABit Add (Var type (SyntaxKind _) idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil)))) regMap calls val (HSemCompActionT : SemCompActionT (cont (evalExpr contArray) writeMapTy) regMap calls val): SemCompActionT (@CompSyncReadRes _ _ idxNum num readRespName readRegName dataArray writePort isWriteMask Data isAddr writeMap readMap lret cont) regMap calls val | SemCompSyncReadResFalse num idxNum readRespName readRegName dataArray writePort isWriteMask Data isAddr writeMap writeMapTy readMap lret cont (HisAddr : isAddr = false) updatedRegs readMapValOld readMapValUpds regVal (HWriteMap: SemRegMapExpr writeMap writeMapTy) (HReadMap : SemRegMapExpr readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn1 : In (readRegName, (existT _ (SyntaxKind (Array num Data)) regVal)) updatedRegs) regMap calls val (HSemCompActionT : SemCompActionT (cont regVal writeMapTy) regMap calls val): SemCompActionT (@CompSyncReadRes _ _ idxNum num readRespName readRegName dataArray writePort isWriteMask Data isAddr writeMap readMap lret cont) regMap calls val. Variable (k : Kind) (a : CompActionT type RegMapType k) (regInits : list RegInitT). Section Loop. Variable f: RegsT -> CompActionT type RegMapType Void. Inductive SemCompTrace: RegsT -> list UpdRegsT -> list MethsT -> Prop := | SemCompTraceInit (oInit : RegsT) (lupds : list UpdRegsT) (lcalls : list MethsT) (HNoUpds : lupds = nil) (HNoCalls : lcalls = nil) (HInitRegs : Forall2 regInit oInit regInits) : SemCompTrace oInit lupds lcalls | SemCompTraceCont (o o' : RegsT) (lupds lupds' : list UpdRegsT) (upds : UpdRegsT) (lcalls lcalls' : list MethsT) (calls : MethsT) val (HOldTrace : SemCompTrace o lupds lcalls) (HSemAction : SemCompActionT (f o) (o, upds) calls val) (HNewUpds : lupds' = upds :: lupds) (HNewCalls : lcalls' = calls :: lcalls) (HPriorityUpds : PriorityUpds o upds o') : SemCompTrace o' lupds' lcalls'. End Loop. End Semantics. Section EActionT_Semantics. Variable o : RegsT. Inductive UpdOrMeth : Type := | UmUpd : RegT -> UpdOrMeth | UmMeth : MethT -> UpdOrMeth. Definition UpdOrMeths := list UpdOrMeth. Fixpoint UpdOrMeths_RegsT (uml : UpdOrMeths) : RegsT := match uml with | um :: uml' => match um with | UmUpd u => u :: (UpdOrMeths_RegsT uml') | UmMeth _ => (UpdOrMeths_RegsT uml') end | nil => nil end. Fixpoint UpdOrMeths_MethsT (uml : UpdOrMeths) : MethsT := match uml with | um :: uml' => match um with | UmUpd _ => (UpdOrMeths_MethsT uml') | UmMeth m => m :: (UpdOrMeths_MethsT uml') end | nil => nil end. Inductive ESemAction : forall k, EActionT type k -> UpdOrMeths -> type k -> Prop := | ESemCall (meth : string) (s : Kind * Kind) (marg : Expr type (SyntaxKind (fst s))) (mret : type (snd s)) (retK : Kind) (fret : type retK) (cont : type (snd s) -> EActionT type retK) (uml : UpdOrMeths) (auml : list UpdOrMeth) (HNewList : auml = (UmMeth (meth, existT SignT s (evalExpr marg, mret)) :: uml)) (HESemAction : ESemAction (cont mret) uml fret) : ESemAction (EMCall meth s marg cont) auml fret | ESemLetExpr (k : FullKind) (e : Expr type k) (retK : Kind) (fret : type retK) (cont : fullType type k -> EActionT type retK) (uml : UpdOrMeths) (HESemAction : ESemAction (cont (evalExpr e)) uml fret) : ESemAction (ELetExpr e cont) uml fret | ESemLetAction (k : Kind) (ea : EActionT type k) (v : type k) (retK : Kind) (fret : type retK) (cont : type k -> EActionT type retK) (newUml : list UpdOrMeth) (newUmlCont : list UpdOrMeth) (HDisjRegs : DisjKey (UpdOrMeths_RegsT newUml) (UpdOrMeths_RegsT newUmlCont)) (HESemAction : ESemAction ea newUml v) (HESemActionCont : ESemAction (cont v) newUmlCont fret) (uNewUml : UpdOrMeths) (HNewUml : uNewUml = newUml ++ newUmlCont) : ESemAction (ELetAction ea cont) uNewUml fret | ESemReadNondet (valueT : FullKind) (valueV : fullType type valueT) (retK : Kind) (fret : type retK) (cont : fullType type valueT -> EActionT type retK) (newUml : UpdOrMeths) (HESemAction : ESemAction (cont valueV) newUml fret): ESemAction (EReadNondet _ cont) newUml fret | ESemReadReg (r : string) (regT : FullKind) (regV : fullType type regT) (retK : Kind) (fret : type retK) (cont : fullType type regT -> EActionT type retK) (newUml : UpdOrMeths) (HRegVal : In (r, existT _ regT regV) o) (HESemAction : ESemAction (cont regV) newUml fret) : ESemAction (EReadReg r _ cont) newUml fret | ESemWriteReg (r : string) (k : FullKind) (e : Expr type k) (retK : Kind) (fret : type retK) (cont : EActionT type retK) (newUml : list UpdOrMeth) (anewUml : list UpdOrMeth) (HRegVal : In (r, k) (getKindAttr o)) (HDisjRegs : key_not_In r (UpdOrMeths_RegsT newUml)) (HANewUml : anewUml = (UmUpd (r, existT _ _ (evalExpr e))) :: newUml) (HESemAction : ESemAction cont newUml fret): ESemAction (EWriteReg r e cont) anewUml fret | ESemIfElseTrue (p : Expr type (SyntaxKind Bool)) (k1 : Kind) (ea ea' : EActionT type k1) (r1 : type k1) (k2 : Kind) (cont : type k1 -> EActionT type k2) (newUml1 newUml2 : list UpdOrMeth) (r2 : type k2) (HDisjRegs : DisjKey (UpdOrMeths_RegsT newUml1) (UpdOrMeths_RegsT newUml2)) (HTrue : evalExpr p = true) (HEAction : ESemAction ea newUml1 r1) (HESemAction : ESemAction (cont r1) newUml2 r2) (unewUml : UpdOrMeths) (HUNewUml : unewUml = newUml1 ++ newUml2) : ESemAction (EIfElse p ea ea' cont) unewUml r2 | ESemIfElseFalse (p : Expr type (SyntaxKind Bool)) (k1 : Kind) (ea ea' : EActionT type k1) (r1 : type k1) (k2 : Kind) (cont : type k1 -> EActionT type k2) (newUml1 newUml2 : list UpdOrMeth) (r2 : type k2) (HDisjRegs : DisjKey (UpdOrMeths_RegsT newUml1) (UpdOrMeths_RegsT newUml2)) (HFalse : evalExpr p = false) (HEAction : ESemAction ea' newUml1 r1) (HESemAction : ESemAction (cont r1) newUml2 r2) (unewUml : UpdOrMeths) (HUNewUml : unewUml = newUml1 ++ newUml2) : ESemAction (EIfElse p ea ea' cont) unewUml r2 | ESemSys (ls : list (SysT type)) (k : Kind) (cont : EActionT type k) (r : type k) (newUml : UpdOrMeths) (HESemAction : ESemAction cont newUml r) : ESemAction (ESys ls cont) newUml r | ESemReturn (k : Kind) (e : Expr type (SyntaxKind k)) (evale : fullType type (SyntaxKind k)) (HEvalE : evale = evalExpr e) (newUml : UpdOrMeths) (HNewUml : newUml = nil) : ESemAction (EReturn e) newUml evale | ESemAsyncRead (idxNum num : nat) (readPort dataArray : string) writePort isWriteMask (idx : Bit (Nat.log2_up idxNum) @# type) (Data : Kind) (retK : Kind) (fret : type retK) (newUml : UpdOrMeths) (regV : fullType type (SyntaxKind (Array idxNum Data))) (HRegVal : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regV)) o) (cont : type (Array num Data) -> EActionT type retK) (contArray : Expr type (SyntaxKind (Array num Data))) (HContArray : contArray = BuildArray (fun i : Fin.t num => ReadArray (Var type _ regV) (CABit Add (Var type (SyntaxKind _) (evalExpr idx) :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil)))) (HESemAction : ESemAction (cont (evalExpr contArray)) newUml fret): ESemAction (EAsyncRead idxNum num readPort dataArray writePort isWriteMask idx Data cont) newUml fret | ESemWriteSome (idxNum num : nat) (writePort dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# type) (Data : Kind) (array : Array num Data @# type) (optMask : option (Array num Bool @# type)) (retK : Kind) (fret : type retK) (cont : EActionT type retK) (newUml : UpdOrMeths) (anewUml : list UpdOrMeth) (regV : fullType type (SyntaxKind (Array idxNum Data))) (mask : Array num Bool @# type) (HRegVal : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regV)) o) (HMask : optMask = Some mask) (HANewUml : anewUml = (UmUpd (dataArray, existT _ _ (evalExpr (fold_left (fun newArr i => ITE (ReadArrayConst mask i) (UpdateArray newArr (CABit Add (idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil)) (ReadArrayConst array i)) newArr ) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))) :: newUml) (HDisjRegs : key_not_In dataArray (UpdOrMeths_RegsT newUml)) (HESemAction : ESemAction cont newUml fret) : ESemAction (EWrite idxNum writePort dataArray idx array optMask cont) anewUml fret | ESemWriteNone (idxNum num : nat) (writePort dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# type) (Data : Kind) (array : Array num Data @# type) (optMask : option (Array num Bool @# type)) (retK : Kind) (fret : type retK) (cont : EActionT type retK) (newUml : UpdOrMeths) (anewUml : list UpdOrMeth) (regV : fullType type (SyntaxKind (Array idxNum Data))) (HRegVal : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regV)) o) (HMask : optMask = None) (HANewUml : anewUml = (UmUpd (dataArray, existT _ _ (evalExpr (fold_left (fun newArr i => (UpdateArray newArr (CABit Add (idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil)) (ReadArrayConst array i)) ) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))) :: newUml) (HDisjRegs : key_not_In dataArray (UpdOrMeths_RegsT newUml)) (HESemAction : ESemAction cont newUml fret) : ESemAction (EWrite idxNum writePort dataArray idx array optMask cont) anewUml fret | ESemSyncReadReqTrue (idxNum num : nat) (readReqName readRegName dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# type) (Data : Kind) (isAddr : bool) (retK : Kind) (fret : type retK) (cont : EActionT type retK) (newUml : UpdOrMeths) (anewUml : list UpdOrMeth) (HisAddr : isAddr = true) (HRegVal : In (readRegName, (SyntaxKind (Bit (Nat.log2_up idxNum)))) (getKindAttr o)) (HDisjRegs : key_not_In readRegName (UpdOrMeths_RegsT newUml)) (HANewUml : anewUml = (UmUpd (readRegName, existT _ _ (evalExpr idx))) :: newUml) (HESemAction : ESemAction cont newUml fret): ESemAction (ESyncReadReq idxNum num readReqName readRegName dataArray idx Data isAddr cont) anewUml fret | ESemSyncReadReqFalse (idxNum num : nat) (readReqName readRegName dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# type) (Data : Kind) (isAddr : bool) (retK : Kind) (fret : type retK) (cont : EActionT type retK) (newUml : UpdOrMeths) (anewUml : list UpdOrMeth) (regV : fullType type (SyntaxKind (Array idxNum Data))) (HisAddr : isAddr = false) (HRegVal1 : In (readRegName, (SyntaxKind (Array num Data))) (getKindAttr o)) (HRegVal2 : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regV)) o) (HDisjRegs : key_not_In readRegName (UpdOrMeths_RegsT newUml)) (HANewUml : anewUml = (UmUpd (readRegName, existT _ _ (evalExpr (BuildArray (fun i : Fin.t num => ReadArray (Var type _ regV) (CABit Add (Var type (SyntaxKind _) (evalExpr idx) :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil))))))) :: newUml) (HESemAction : ESemAction cont newUml fret): ESemAction (ESyncReadReq idxNum num readReqName readRegName dataArray idx Data isAddr cont) anewUml fret | ESemSyncReadResTrue (idxNum num : nat) (readRespName readRegName dataArray : string) writePort isWriteMask (Data : Kind) (isAddr : bool) (retK : Kind) (fret : type retK) (regVal : fullType type (SyntaxKind (Array idxNum Data))) (idx : fullType type (SyntaxKind (Bit (Nat.log2_up idxNum)))) (cont : type (Array num Data) -> EActionT type retK) (HisAddr : isAddr = true) (HRegVal1 : In (readRegName, existT _ (SyntaxKind (Bit (Nat.log2_up idxNum))) idx) o) (HRegVal2 : In (dataArray, existT _ (SyntaxKind (Array idxNum Data)) regVal) o) (contArray : Expr type (SyntaxKind (Array num Data))) (HContArray : contArray = BuildArray (fun i : Fin.t num => ReadArray (Var type _ regVal) (CABit Add (Var type (SyntaxKind _) idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil)))) (newUml : UpdOrMeths) (HESemAction : ESemAction (cont (evalExpr contArray)) newUml fret): ESemAction (ESyncReadRes idxNum num readRespName readRegName dataArray writePort isWriteMask Data isAddr cont) newUml fret | ESemSyncReadResFalse (idxNum num : nat) (readRespName readRegName dataArray : string) writePort isWriteMask (Data : Kind) (isAddr : bool) (retK : Kind) (fret : type retK) (regVal : fullType type (SyntaxKind (Array num Data))) (cont : type (Array num Data) -> EActionT type retK) (HisAddr : isAddr = false) (HRegVal : In (readRegName, existT _ (SyntaxKind (Array num Data)) regVal) o) (newUml : UpdOrMeths) (HESemAction : ESemAction (cont regVal) newUml fret): ESemAction (ESyncReadRes idxNum num readRespName readRegName dataArray writePort isWriteMask Data isAddr cont) newUml fret. End EActionT_Semantics. ================================================ FILE: Compiler/CompilerDoubleWrites.v ================================================ Require Import Kami.SyntaxDoubleWrites Kami.Compiler.Compiler Kami.Compiler.CompilerProps Kami.Syntax Kami.Properties Kami.PProperties Kami.PPlusProperties Kami.Lib.EclecticLib Kami.Notations. Set Implicit Arguments. Set Asymmetric Patterns. Section DoubleWritesProof. Lemma NoDupAppSplit {A : Type} (l l' : list A) : NoDup (l++l') -> forall a, In a l -> ~ In a l'. Proof. induction l'. - intros. unfold not. intros. inversion H1. - intros. unfold not. intros. specialize (NoDup_remove _ _ _ H) as P0. destruct P0. inv H1. apply H3. rewrite in_app_iff. left. assumption. specialize (NoDup_remove _ _ _ H) as P0. destruct P0. eapply IHl'. assumption. apply H0. apply H4. Qed. Lemma getKindAttr_consistent (k : Kind) (a : ActionT type k) (o : RegsT): forall newRegs readRegs calls retl, SemActionDoubleWrites o a readRegs newRegs calls retl -> SubList (getKindAttr newRegs) (getKindAttr o). Proof. induction a; simpl in *; intros. - inv H0; EqDep_subst; eapply H; eauto. - inv H0; EqDep_subst; eapply H; eauto. - inv H0; EqDep_subst. rewrite map_app, SubList_app_l_iff; split. + eapply IHa; eauto. + eapply H; eauto. - inv H0; EqDep_subst; eapply H; eauto. - inv H0; EqDep_subst; eapply H; eauto. - inv H; EqDep_subst. repeat intro. simpl in *. destruct H; subst; auto. eapply IHa; eauto. - inv H0; EqDep_subst. + rewrite map_app, SubList_app_l_iff. split. * eapply IHa1; eauto. * eapply H; eauto. + rewrite map_app, SubList_app_l_iff. split. * eapply IHa2; eauto. * eapply H; eauto. - inv H; EqDep_subst. eapply IHa; eauto. - inv H; EqDep_subst. simpl in *. unfold SubList. intros. inversion H. Qed. Lemma CheckOnNewUpds (k : Kind) (a : ActionT type k) (o : RegsT): forall writeMap upds' calls retl upds old, SemRegMapExpr writeMap (old, upds) -> SemCompActionT (compileAction (o,nil) a (Const type true) writeMap) (old, upds') calls retl -> forall u, In u upds' -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old). Proof. induction a; intros; simpl in *; eauto. (* Meth Call *) - inv H1; EqDep_subst. * eapply H. apply H0. apply HSemCompActionT. assumption. * eapply H. apply H0. apply HSemCompActionT. assumption. (* Let Expr *) - inv H1; EqDep_subst. eapply H. apply H0. apply HSemCompActionT. assumption. (* Let Action *) - inv H1; EqDep_subst. destruct regMap_a. assert (old = r). { eapply SameOldAction. apply H0. apply HSemCompActionT_a. } rewrite <- H1 in HSemCompActionT_a. specialize (IHa _ _ _ _ _ _ H0 HSemCompActionT_a). assert (SemRegMapExpr (VarRegMap type (old, l)) (old,l)) as P0. { econstructor. } rewrite <- H1 in HSemCompActionT_cont. specialize (H _ _ _ _ _ _ _ P0 HSemCompActionT_cont). split. * apply H. assumption. * apply H. assumption. (* Non Det *) - inv H1; EqDep_subst. eapply H. apply H0. apply HSemCompActionT. apply H2. (* Read *) - inv H1; EqDep_subst. eapply H. apply H0. apply HSemCompActionT. apply H2. (* Write *) - inv H0; simpl in *; EqDep_subst. assert (val_a = evalExpr (Const type WO)) as P0. {rewrite (unique_word_0 val_a); auto. } subst. inversion HSemCompActionT_a; EqDep_subst. destruct regMap_a. assert (r0 = old). { - inv HRegMapWf. inv H0. EqDep_subst. * specialize (SemVarRegMap (r0, (hd nil upds0 ++ (r, existT (fullType type) k (evalExpr e)) :: nil) :: tl upds0)) as P0. eapply SameOldAction. apply P0. apply HSemCompActionT_cont. * discriminate. } assert (SemRegMapExpr (VarRegMap type (r0, l)) (r0, l)) as P1. { econstructor. } rewrite <- H0 in HSemCompActionT_cont. specialize (IHa _ _ _ _ _ _ P1 HSemCompActionT_cont). rewrite -> H0 in IHa. apply IHa. assumption. (* If-else *) - inv H1; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inversion HSemCompActionT_cont; simpl in *; EqDep_subst. inversion HSemCompActionT_cont0; simpl in *; EqDep_subst. remember (evalExpr e) as P0. destruct P0; simpl in *. * assert (forall b, (evalExpr (Var type (SyntaxKind Bool) b)) = evalExpr (Const type b)) as P4; auto. specialize (SemCompActionEquivBexpr _ _ _ _ _ (P4 true) HSemCompActionT_a) as P6. rewrite <- HeqP0 in *; simpl in HSemCompActionT. destruct regMap_a0. assert (r = old). { * specialize (SemVarRegMap (r, l)) as P0. eapply SameOldAction. apply P0. apply HSemCompActionT. } assert (SemRegMapExpr (VarRegMap type (r, l)) (r, l)) as P5. { econstructor. } rewrite <- H1 in HSemCompActionT. specialize (H _ _ _ _ _ _ _ P5 HSemCompActionT). rewrite -> H1 in H. apply H. assumption. * assert (forall b, (evalExpr (Var type (SyntaxKind Bool) b)) = evalExpr (Const type b)) as P4; auto. specialize (SemCompActionEquivBexpr _ _ _ _ _ (P4 true) HSemCompActionT_a0) as P6. destruct regMap_a0. assert (r = old). { * specialize (SemVarRegMap (r, l)) as P0. eapply SameOldAction. apply P0. apply HSemCompActionT. } assert (SemRegMapExpr (VarRegMap type (r, l)) (r, l)) as P5. { econstructor. } rewrite <- H1 in HSemCompActionT. specialize (H _ _ _ _ _ _ _ P5 HSemCompActionT). rewrite -> H1 in H. apply H. assumption. (* Sys *) - inv H0; EqDep_subst. eapply IHa. apply H. apply HSemCompActionT. assumption. (* Ret *) - inv H0; EqDep_subst. unfold WfRegMapExpr in HRegMapWf. destruct HRegMapWf. apply H2. assumption. Qed. Lemma getRegisterValue (k : FullKind) (o : RegsT): forall r, In (r, k) (getKindAttr o) -> exists v, In (r, existT (fullType type) k v) o. Proof. intros. simpl in *. rewrite in_map_iff in H. dest. inv H. destruct x; subst. destruct s0; subst. simpl in *. exists f; auto. Qed. Lemma FalseSemCompAction (k : Kind) (a : ActionT type k) (o oInit : RegsT) uInit (m : BaseModule): forall regMap regMapExpr (bexpr : Bool @# type) (WfRegMap : WfRegMapExpr regMapExpr regMap) (HPriorityUpds : PriorityUpds oInit uInit o) , getKindAttr o = getKindAttr (getRegisters m) -> getKindAttr oInit = getKindAttr (getRegisters m) -> WfActionT (getRegisters m) a -> evalExpr bexpr = false -> exists retl, SemCompActionT (compileAction (oInit,uInit) a bexpr regMapExpr) regMap nil retl. Proof. induction a; simpl in *; subst. - (* Meth Call *) intros. inversion H2; EqDep_subst. specialize (H6 (evalConstT (getDefaultConst (snd s)))). specialize (H (evalConstT (getDefaultConst (snd s))) _ _ _ WfRegMap HPriorityUpds H0 H1 H6 H3). destruct H. exists x. econstructor 2. eapply H. assumption. - (* Let expr *) intros. inversion H2; EqDep_subst. specialize (H6 (evalExpr e)). specialize (H (evalExpr e) _ _ _ WfRegMap HPriorityUpds H0 H1 H6 H3). destruct H. exists x. econstructor. assumption. - (* Let Action *) intros. inversion H2; EqDep_subst. specialize (IHa _ _ _ WfRegMap HPriorityUpds H0 H1 H7 H3). destruct IHa. assert (WfRegMapExpr (VarRegMap type regMap) regMap). { unfold WfRegMapExpr in *; split; eauto. constructor. destruct WfRegMap. assumption. } specialize (H9 x). specialize (H x _ _ _ H5 HPriorityUpds H0 H1 H9 H3). destruct H. exists x0. rewrite <- (app_nil_r (nil : MethsT)). econstructor; eauto. - (* Non Det *) intros. inversion H2; EqDep_subst. specialize (H6 (evalConstFullT (getDefaultConstFullKind k))). specialize (H (evalConstFullT (getDefaultConstFullKind k)) _ _ _ WfRegMap HPriorityUpds H0 H1 H6 H3). destruct H. exists x. econstructor. apply H. -(* Read *) intros. inversion H2; EqDep_subst. specialize (getRegisterValue); intros. change (fun x0 : FullKind => RegInitValT x0) with RegInitValT in H9. rewrite <- H0 in H9. specialize (H4 _ _ _ H9). destruct H4. specialize (H7 x). specialize (H x _ _ _ WfRegMap HPriorityUpds H0 H1 H7 H3). destruct H. exists x0. econstructor; eauto. constructor. -(* Write *) intros. assert (WfRegMapExpr (VarRegMap type regMap) regMap). { unfold WfRegMapExpr in *; split; eauto. constructor. destruct WfRegMap. assumption. } inversion H1; EqDep_subst. specialize (IHa _ _ _ H3 HPriorityUpds H H0 H7 H2). destruct IHa. exists x. simpl in *. rewrite <- (app_nil_r (nil : MethsT)). econstructor. econstructor. reflexivity. unfold WfRegMapExpr in *; dest; repeat split; eauto. destruct regMap. econstructor 3; eauto. reflexivity. assumption. -(* If-else *) intros. assert ((evalExpr (bexpr && !e)%kami_expr = evalExpr bexpr)) as P1. { simpl. rewrite -> H3. simpl. destruct (evalExpr e). simpl. reflexivity. reflexivity. } assert ((evalExpr (bexpr && e)%kami_expr = false)) as P2. { simpl. rewrite -> H3. simpl. reflexivity. } inversion H2; EqDep_subst. specialize (IHa1 _ _ _ WfRegMap HPriorityUpds H0 H1 H11 H3). destruct IHa1. assert (WfRegMapExpr (VarRegMap type regMap) regMap). { unfold WfRegMapExpr in *; split; eauto. constructor. destruct WfRegMap. assumption. } rewrite -> H3 in P1. specialize (IHa2 _ _ _ H5 HPriorityUpds H0 H1 H12 P2). remember (evalExpr e) as P0. destruct IHa2. destruct P0. * specialize (H8 x). specialize (H x _ _ _ H5 HPriorityUpds H0 H1 H8 P2). destruct H. exists x1. rewrite <- (app_nil_r (nil : MethsT)). do 3 econstructor. simpl in *. apply SemCompActionEquivBexpr with (bexpr1 := bexpr). simpl. rewrite -> H3. simpl. reflexivity. apply H4. reflexivity. rewrite <- (app_nil_r (nil : MethsT)). econstructor. apply SemCompActionEquivBexpr with (bexpr1 := (bexpr && e)%kami_expr). simpl. rewrite -> H3. simpl. reflexivity. apply H6. reflexivity. simpl. econstructor. simpl. rewrite <- HeqP0. apply SemCompActionEquivBexpr with (bexpr1 := (bexpr && e)%kami_expr). simpl. rewrite -> H3. simpl. reflexivity. apply H. * specialize (H8 x0). specialize (H x0 _ _ _ H5 HPriorityUpds H0 H1 H8 P2). destruct H. exists x1. rewrite <- (app_nil_r (nil : MethsT)). do 3 econstructor. simpl in *. apply SemCompActionEquivBexpr with (bexpr1 := bexpr). simpl. rewrite -> H3. simpl. reflexivity. apply H4. reflexivity. rewrite <- (app_nil_r (nil : MethsT)). econstructor. apply SemCompActionEquivBexpr with (bexpr1 := (bexpr && e)%kami_expr). simpl. rewrite -> H3. simpl. reflexivity. apply H6. reflexivity. simpl. econstructor. simpl. rewrite <- HeqP0. apply SemCompActionEquivBexpr with (bexpr1 := (bexpr && e)%kami_expr). simpl. rewrite -> H3. simpl. reflexivity. apply H. - (* Sys *) intros. inversion H1; EqDep_subst. specialize (IHa _ _ _ WfRegMap HPriorityUpds H H0 H5 H2). destruct IHa. exists x. econstructor. apply H3. - (* Ret *) intros. inversion H1; EqDep_subst. exists (evalExpr e). econstructor. reflexivity. assumption. Qed. Lemma EquivActionNoDupWritesNew (k : Kind) (a : ActionT type k) (o oInit: RegsT) uInit (m : BaseModule) (HoInitNoDups : NoDup (map fst oInit)) (HuInitNoDups : forall u, In u uInit -> NoDup (map fst u)) (HPriorityUpds : PriorityUpds oInit uInit o) (HOgetReg : getKindAttr o = getKindAttr (getRegisters m)) : forall newRegs readRegs calls retl, SemActionDoubleWrites o a readRegs newRegs calls retl -> NoDup (map fst newRegs) -> getKindAttr oInit = getKindAttr (getRegisters m) -> WfActionT (getRegisters m) a -> forall old writeMap upds (HConsistent: getKindAttr o = getKindAttr old) (HCheck : forall s, In s (map fst newRegs) -> ~ In s (map fst (hd nil upds))), SemRegMapExpr writeMap (old, upds) -> (forall u, In u upds -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old)) -> exists upds', (upds' = (old, match newRegs with |nil => upds |_ :: _ => (hd nil upds ++ newRegs) :: tl upds end)) /\ SemCompActionT (compileAction (oInit, uInit) a (Const type true) writeMap) upds' calls retl. Proof. induction a; subst; intros; simpl in *. - (* Meth Call *) inv H0; EqDep_subst. inv H3; EqDep_subst. specialize (H7 mret). specialize (H _ _ _ _ _ HSemAction H1 H2 H7 _ _ _ HConsistent HCheck H4 H5); dest. exists x. split. * assumption. * econstructor; eauto. - (* Let expr *) inv H0; EqDep_subst. inv H3; EqDep_subst. specialize (H7 (evalExpr e)). specialize (H _ _ _ _ _ HSemAction H1 H2 H7 _ _ _ HConsistent HCheck H4 H5); dest. exists x. split. * assumption. * econstructor; eauto. - (* Let Action *) inv H0; EqDep_subst. rewrite map_app, NoDup_app_iff in H1; dest. assert ( forall s, In s (map fst (newRegs0)) -> ~ In s (map fst (hd nil upds))) as P0. { intros. apply HCheck. rewrite map_app. apply in_or_app. left. assumption. } inv H3; EqDep_subst. specialize (H13 v). specialize (IHa _ _ _ _ HSemAction H0 H2 H11 _ _ _ HConsistent P0 H4 H5); dest. destruct x. assert (SemRegMapExpr (VarRegMap type (l, l0)) (l, l0)). apply SemVarRegMap. assert (forall u, In u l0 -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old) ) as P1. { split. inv H3; simpl in *; subst. destruct newRegs0; auto. simpl in *. apply H5. assumption. simpl in *. destruct H10; auto. subst. rewrite map_app. rewrite NoDup_app_iff; simpl in *; repeat split. * destruct upds; simpl in *. constructor. eapply H5. left. reflexivity. * assumption. * intros;subst. unfold not. intro. destruct H10. subst. eapply HCheck. left. reflexivity. assumption. eapply HCheck. right. rewrite map_app. eapply in_or_app. left. apply H10. assumption. * intros; subst. unfold not. intro. destruct H3; subst. eapply HCheck. left. reflexivity. assumption. eapply HCheck. right. rewrite map_app. eapply in_or_app. left. apply H3. assumption. * eapply H5. simpl in *. destruct upds. inversion H3. simpl in H6. simpl in *. right. assumption. * inv H3; subst. destruct newRegs0. apply H5. assumption. destruct upds. simpl in *. destruct H10; [|contradiction]; subst. specialize getKindAttr_consistent as P1. rewrite <- HConsistent. specialize (P1 _ a o (p :: newRegs0) readRegs0 calls0 v HSemAction). assumption. simpl in *. destruct H10; subst. rewrite map_app. rewrite SubList_app_l_iff; split; auto. apply H5. left. reflexivity. specialize getKindAttr_consistent as P1. rewrite <- HConsistent. specialize (P1 _ a o (p :: newRegs0) readRegs0 calls0 v HSemAction). assumption. apply H5. right. assumption. } inversion H3; subst; simpl in *. assert (forall s, In s (map fst (newRegsCont)) -> ~ In s (map fst (hd nil match newRegs0 with | nil => upds | _ :: _ => (hd nil upds ++ newRegs0) :: tl upds end))) as P2. { intros. simpl in *. destruct newRegs0. * unfold not; intros. eapply HCheck. simpl in *. apply H10. assumption. * unfold not. intros. eapply H7. apply H10. simpl in H12. rewrite map_app in H12. apply in_app_or in H12. destruct H12. + exfalso. eapply H7. apply H10. exfalso. eapply HCheck. rewrite map_app. apply in_or_app. right. apply H10. assumption. + assumption. } inversion H3; subst. simpl in *. specialize (H _ _ _ _ _ HSemActionCont H1 H2 H13 _ _ _ HConsistent P2 H9 P1). dest. exists x; split. * inversion H3; subst. destruct newRegs0. destruct newRegsCont; simpl in *; reflexivity. simpl in *. destruct newRegsCont. simpl in *. rewrite app_nil_r. reflexivity. rewrite app_comm_cons. rewrite app_assoc. reflexivity. * econstructor; eauto. - (* Non Det *) inv H0; EqDep_subst. inv H3; EqDep_subst. specialize (H7 valueV). specialize (H _ _ _ _ _ HSemAction H1 H2 H7 _ _ _ HConsistent HCheck H4 H5); dest. exists x. split. * assumption. * econstructor; eauto. - (* Read *) inv H0; EqDep_subst. inv H3; EqDep_subst. specialize (H8 regV). specialize (H _ _ _ _ _ HSemAction H1 H2 H8 _ _ _ HConsistent HCheck H4 H5); dest. exists x. split. * assumption. * econstructor; eauto. apply SemVarRegMap. - (* Write *) inv H; EqDep_subst. inv H0. inv H2; EqDep_subst. assert (SemRegMapExpr (VarRegMap type (old, (hd nil upds ++ (r, existT (fullType type) k (evalExpr e)) :: nil) :: tl upds)) (old, (hd nil upds ++ (r, existT (fullType type) k (evalExpr e)) :: nil) :: tl upds)) as P0. { econstructor; eauto. } assert ((forall u : RegsT, hd nil upds ++ (r, existT (fullType type) k (evalExpr e)) :: nil = u \/ In u (tl upds) -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old))) as P1. { intros. destruct H; subst. - repeat rewrite map_app; simpl. split. + rewrite NoDup_app_iff; simpl in *; repeat split. * clear - H4. destruct upds; simpl in *;[constructor|]. eapply H4. left; reflexivity. * constructor;[|constructor]. intro; inv H. * repeat intro. destruct H0; auto; subst. eapply HCheck. left; reflexivity. assumption. * intros; subst. destruct H; auto; subst. + simpl in *. apply SubList_app_l_iff. split. simpl in *. destruct upds; simpl in *; auto. repeat intro; simpl in *. contradiction. apply H4. left. reflexivity. rewrite <- HConsistent. unfold SubList. intros. simpl in *. destruct H; subst; auto. contradiction. - apply H4. simpl in *. destruct upds. inversion H. simpl in H. simpl in *. right. assumption. } assert (forall s, In s (map fst newRegs0) -> ~ In s (map fst (hd nil ((hd nil upds ++ (r, existT (fullType type) k (evalExpr e)) :: nil) :: tl upds)))) as P2. { repeat intro. simpl in *. rewrite map_app in H0. simpl in *. apply in_app_iff in H0. destruct H0. destruct upds; subst. inversion H0. simpl in *. eapply HCheck. right. apply H. assumption. simpl in *. destruct H0. subst. apply H6. assumption. assumption. } specialize (IHa _ _ _ _ HSemAction H7 H1 H8 _ _ _ HConsistent P2 P0 P1); dest; simpl in *. exists x; repeat split; auto. * destruct newRegs0. assumption. rewrite -> H. simpl in *. rewrite <- app_assoc. reflexivity. * simpl in *. rewrite <- (app_nil_l calls). econstructor; eauto. econstructor; eauto. unfold WfRegMapExpr; repeat split. ++ econstructor. simpl in *. reflexivity. apply H3. reflexivity. ++ destruct P1 with u. simpl in *. assumption. assumption. ++ simpl in *. destruct H2. subst. repeat intro. rewrite map_app in H; simpl in *. rewrite in_app_iff in H. destruct H. destruct upds. inv H. simpl in *. eapply H4. left. reflexivity. assumption. inv H. rewrite <- HConsistent. assumption. inv H2. destruct upds. simpl in *. inv H2. simpl in *. eapply H4; eauto. - (* if-else *) inv H0; EqDep_subst. inv H3; EqDep_subst. * rewrite map_app, NoDup_app_iff in H1; dest. assert (forall s : string, In s (map fst newRegs1) -> ~ In s (map fst (hd nil upds))) as P3. { intros. eapply HCheck. rewrite map_app. apply in_or_app. left. assumption. } specialize (IHa1 _ _ _ _ HAction H0 H2 H12 _ _ _ HConsistent P3 H4 H5); dest. destruct x. assert (SemRegMapExpr (VarRegMap type (l, l0)) (l, l0)). apply SemVarRegMap. assert (forall u, In u l0 -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old) ) as P4. { split. inv H7; simpl in *; subst. destruct newRegs1; auto. simpl in *. apply H5. assumption. simpl in *. destruct H11; auto. subst. rewrite map_app. rewrite NoDup_app_iff; simpl in *; repeat split. * destruct upds; simpl in *. constructor. eapply H5. left. reflexivity. * assumption. * intros;subst. unfold not. intro. destruct H11. subst. eapply HCheck. left. reflexivity. assumption. eapply HCheck. right. rewrite map_app. eapply in_or_app. left. apply H11. assumption. * intros; subst. unfold not. intro. destruct H7; subst. eapply HCheck. left. reflexivity. assumption. eapply HCheck. right. rewrite map_app. eapply in_or_app. left. apply H7. assumption. * eapply H5. simpl in *. destruct upds. inversion H7. simpl in H7. simpl in *. right. assumption. * inv H7; subst. destruct newRegs1. apply H5. assumption. destruct upds. simpl in *. destruct H11; [|contradiction]; subst. specialize getKindAttr_consistent as P0. rewrite <- HConsistent. specialize (P0 _ a1 o (p :: newRegs1) readRegs1 calls1 r1 HAction). assumption. simpl in *. destruct H11; subst. rewrite map_app. rewrite SubList_app_l_iff; split; auto. apply H5. left. reflexivity. specialize getKindAttr_consistent as P0. rewrite <- HConsistent. specialize (P0 _ a1 o (p :: newRegs1) readRegs1 calls1 r1 HAction). assumption. apply H5. right. assumption. } inversion H7; subst; simpl in *. assert (forall s, In s (map fst (newRegs2)) -> ~ In s (map fst (hd nil (match newRegs1 with | nil => upds | _ :: _ => (hd nil upds ++ newRegs1) :: tl upds end)))) as P5. { intros. simpl in *. destruct newRegs1. * unfold not; intros. eapply HCheck. simpl in *. apply H11. assumption. * unfold not. intros. eapply H6. apply H11. simpl in H14. rewrite map_app in H14. apply in_app_or in H14. destruct H14. + exfalso. eapply H6. apply H11. exfalso. eapply HCheck. rewrite map_app. apply in_or_app. right. apply H11. assumption. + assumption. } inversion H7; subst. simpl in *. specialize (H9 r1). specialize (H _ _ _ _ _ HSemAction H1 H2 H9 _ _ _ HConsistent P5 H10 P4). dest. exists x; split. ** destruct newRegs1. simpl in *. assumption. simpl in *. destruct newRegs2. simpl in *. rewrite app_nil_r. assumption. rewrite <- app_assoc in H. assumption. ** remember (evalExpr e) as P0. assert (forall bexpr, (evalExpr (Const type true && bexpr)%kami_expr = evalExpr bexpr)) as P1. { intro; simpl; auto. } assert (evalExpr e = evalExpr (Const type true)) as P2. { rewrite <- HeqP0. apply HTrue. } simpl. specialize (FalseSemCompAction) as P12. assert (evalExpr (!e)%kami_expr = false) as PF. { simpl; auto. simpl. rewrite -> P2. simpl; auto. } specialize (P1 (!e)%kami_expr). rewrite -> PF in P1. assert (WfRegMapExpr (VarRegMap type (old, match newRegs1 with | nil => upds | _ :: _ => (hd nil upds ++ newRegs1) :: tl upds end)) (old, match newRegs1 with | nil => upds | _ :: _ => (hd nil upds ++ newRegs1) :: tl upds end)). { unfold WfRegMapExpr in *; auto. } do 3 econstructor. apply SemCompActionEquivBexpr with (bexpr1 := (Const type true)). simpl in *. rewrite -> HeqP0 in HTrue. rewrite -> HTrue. reflexivity. apply H8. reflexivity. specialize (P12 _ a2 o oInit uInit _ _ _ _ H14 HPriorityUpds HOgetReg H2 H13 P1). destruct P12. rewrite <- (app_nil_l calls2). econstructor 8 with (regMap_a := (old, match newRegs1 with | nil => upds | _ :: _ => (hd nil upds ++ newRegs1) :: tl upds end)) (val_a := x0). eapply SemCompActionEquivBexpr with (bexpr1 := (Const type true && ! e)%kami_expr); eauto. reflexivity. simpl in *. econstructor. simpl in *. rewrite -> P2. apply H11. * rewrite map_app, NoDup_app_iff in H1; dest. assert (forall s : string, In s (map fst newRegs1) -> ~ In s (map fst (hd nil upds))) as P3. { intros. eapply HCheck. rewrite map_app. apply in_or_app. left. assumption. } assert (SemRegMapExpr (VarRegMap type (old, upds)) (old, upds)) as HF. { constructor. } inv H3; EqDep_subst. specialize (IHa2 _ _ _ _ HAction H0 H2 H16 _ _ _ HConsistent P3 HF H5); dest. destruct x. assert (SemRegMapExpr (VarRegMap type (l, l0)) (l, l0)). apply SemVarRegMap. assert (forall u, In u l0 -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old) ) as P4. { split. inv H3; simpl in *; subst. destruct newRegs1; auto. simpl in *. apply H5. assumption. simpl in *. destruct H10; auto. subst. rewrite map_app. rewrite NoDup_app_iff; simpl in *; repeat split. * destruct upds; simpl in *. constructor. eapply H5. left. reflexivity. * assumption. * intros;subst. unfold not. intro. destruct H10. subst. eapply HCheck. left. reflexivity. assumption. eapply HCheck. right. rewrite map_app. eapply in_or_app. left. apply H10. assumption. * intros; subst. unfold not. intro. destruct H3; subst. eapply HCheck. left. reflexivity. assumption. eapply HCheck. right. rewrite map_app. eapply in_or_app. left. apply H3. assumption. * eapply H5. simpl in *. destruct upds. inversion H3. simpl in H7. simpl in *. right. assumption. * inv H3; subst. destruct newRegs1. apply H5. assumption. destruct upds. simpl in *. destruct H10; [|contradiction]; subst. specialize getKindAttr_consistent as P0. rewrite <- HConsistent. specialize (P0 _ a2 o (p :: newRegs1) readRegs1 calls1 r1 HAction). assumption. simpl in *. destruct H10; subst. rewrite map_app. rewrite SubList_app_l_iff; split; auto. apply H5. left. reflexivity. specialize getKindAttr_consistent as P0. rewrite <- HConsistent. specialize (P0 _ a2 o (p :: newRegs1) readRegs1 calls1 r1 HAction). assumption. apply H5. right. assumption. } inversion H3; subst; simpl in *. assert (forall s, In s (map fst (newRegs2)) -> ~ In s (map fst (hd nil (match newRegs1 with | nil => upds | _ :: _ => (hd nil upds ++ newRegs1) :: tl upds end)))) as P5. { intros. simpl in *. destruct newRegs1. * unfold not; intros. eapply HCheck. simpl in *. apply H10. assumption. * unfold not. intros. eapply H7. apply H10. simpl in H11. rewrite map_app in H11. apply in_app_or in H11. destruct H11. + exfalso. eapply H7. apply H10. exfalso. eapply HCheck. rewrite map_app. apply in_or_app. right. apply H10. assumption. + assumption. } inversion H3; subst. simpl in *. specialize (H12 r1). specialize (H _ _ _ _ _ HSemAction H1 H2 H12 _ _ _ HConsistent P5 H9 P4). dest. exists x; split. ** destruct newRegs1. simpl in *. assumption. simpl in *. destruct newRegs2. simpl in *. rewrite app_nil_r. assumption. rewrite <- app_assoc in H. assumption. ** remember (evalExpr e) as P0. assert (forall bexpr, (evalExpr (Const type true && bexpr)%kami_expr = evalExpr bexpr)) as P1. { intro; simpl; auto. } assert (evalExpr (!e)%kami_expr = evalExpr (Const type true)) as P2. {simpl. rewrite -> HeqP0 in HFalse. rewrite -> HFalse. auto. } specialize (FalseSemCompAction) as P12. assert (evalExpr (!e)%kami_expr = true) as PF. { simpl; auto. } specialize (P1 (!e)%kami_expr). rewrite -> PF in P1. assert (WfRegMapExpr writeMap (old, upds)). { unfold WfRegMapExpr in *; auto. } rewrite <-(app_nil_l (calls1++calls2)). assert (evalExpr (Const type true && e)%kami_expr = false). { simpl. rewrite -> HFalse in HeqP0; auto. } specialize (P12 _ a1 o oInit uInit _ _ _ _ H11 HPriorityUpds HOgetReg H2 H15 H13). destruct P12. do 2 econstructor; econstructor 8 with (regMap_a := (old, upds)) (val_a := x0). eapply SemCompActionEquivBexpr with (bexpr1 := (Const type true && e)%kami_expr); eauto. reflexivity. simpl in *. econstructor 8 with (regMap_a := (old, match newRegs1 with | nil => upds | _ :: _ => (hd nil upds ++ newRegs1) :: tl upds end)) (val_a := r1) . simpl in *. apply SemCompActionEquivBexpr with (bexpr1 := (Const type true)). simpl in *. rewrite -> P2. reflexivity. apply H8. simpl in *. reflexivity. econstructor. simpl in *. rewrite -> HFalse in HeqP0. rewrite <- HeqP0. apply H10. - (* Sys *) inv H; EqDep_subst. inv H2; EqDep_subst. specialize (IHa _ _ _ _ HSemAction H0 H1 H6 _ _ _ HConsistent HCheck H3 H4); dest. exists x. split. * assumption. * econstructor; eauto. - (* Return *) inv H; EqDep_subst. inv H2; EqDep_subst. exists (old, upds). split. reflexivity. destruct upds. simpl in *. constructor. reflexivity. unfold WfRegMapExpr. split; auto. econstructor. reflexivity. unfold WfRegMapExpr. split; auto. Qed. End DoubleWritesProof. ================================================ FILE: Compiler/CompilerProps.v ================================================ Require Import Kami.StateMonad Kami.Syntax Kami.Properties Kami.PProperties Kami.PPlusProperties Kami.Lib.EclecticLib Kami.Notations Kami.Compiler.Compiler. Import Word.Notations. Require Import ZArith. Set Implicit Arguments. Set Asymmetric Patterns. Local Coercion BaseRegFile : RegFileBase >-> BaseModule. (* Section Defs *) Definition inline_Meths (l : list DefMethT) (xs : list nat) (meth : DefMethT) : DefMethT := let (name, sig_body) := meth in (name, let (sig, body) := sig_body in existT _ sig (fun ty arg => fold_left (inlineSingle_pos l) xs (body ty arg))). Definition inlineSingle_Meth_pos (l : list DefMethT) (meth : DefMethT) (n : nat) : DefMethT := match nth_error l n with | Some f => inlineSingle_Meth f meth | None => meth end. Definition inline_Rules (l : list DefMethT) (xs : list nat) (rule : RuleT) : RuleT := let (s, a) := rule in (s, fun ty => fold_left (inlineSingle_pos l) xs (a ty)). Definition listRfMethods (lrf : list RegFileBase) : (list DefMethT) := (concat (map (fun rf => getRegFileMethods rf) lrf)). Definition inlineRf_Rules_Flat (lrf : list RegFileBase) (l : list RuleT) := map (inline_Rules (listRfMethods lrf) (seq 0 (length (listRfMethods lrf)))) l. Definition inlineRf_Meths_Flat (lrf : list RegFileBase) (l : list DefMethT) := map (inline_Meths (listRfMethods lrf) (seq 0 (length (listRfMethods lrf)))) l. Definition flatInlineSingleRfNSC (m : BaseModule) (lrf : list RegFileBase) := BaseMod (getRegisters m ++ (concat (map (fun rf => getRegFileRegisters rf) lrf))) (inlineRf_Rules_Flat lrf (getRules m)) ((inlineRf_Meths_Flat lrf (getMethods m)) ++ (concat (map (fun rf => getRegFileMethods rf) lrf))). Definition inlineSingle_Rule_pos (meths : list DefMethT) n (rule : RuleT) := match nth_error meths n with | Some f => (inlineSingle_Rule f rule) | None => rule end. Definition inlineSingle_Meths_posmap (meths : list DefMethT) (currMap : DefMethT -> DefMethT) (n : nat) := match nth_error meths n with | Some f => (fun x => inlineSingle_Meth (currMap f) (currMap x)) | None => currMap end. Definition inlineAll_Rules_map (meths : list DefMethT) (rules : list RuleT) := map (fold_left (fun rle n => inlineSingle_Rule_pos meths n rle) (seq 0 (length meths))) rules. Fixpoint subseq_list {A : Type} (l : list A) (xs : list nat) := match xs with | n::xs' => match nth_error l n with | Some d => d :: (subseq_list l xs') | None => (subseq_list l xs') end | nil => nil end. Definition mergeSeparatedSingle (b : BaseModule) (lrf : list RegFileBase) : Mod := ConcatMod (Base b) (mergeSeparatedBaseFile lrf). (* End Defs *) (* begin misc properties *) Lemma WfBaseMod_inlineSingle_map ty (m : BaseModule) (HWfMod : WfBaseModule ty m) k (a : ActionT ty k) (n : nat): forall (lf : list DefMethT), SubList lf (getMethods m) -> WfActionT (getRegisters m) a -> WfActionT (getRegisters m) (apply_nth (map (fun f a' => @inlineSingle ty k a' f) lf) a n). Proof. intros. unfold apply_nth; remember (nth_error _ _) as err0; symmetry in Heqerr0; destruct err0; auto. apply nth_error_In in Heqerr0; rewrite in_map_iff in Heqerr0; dest. rewrite <- H1. apply WfBaseMod_inlineSingle; auto. Qed. Lemma WfBaseMod_inlineSome_map ty (m : BaseModule) (HWfMod : WfBaseModule ty m) xs: forall (lf : list DefMethT) k (a : ActionT ty k), SubList lf (getMethods m) -> WfActionT (getRegisters m) a -> WfActionT (getRegisters m) (fold_left (apply_nth (map (fun f a' => @inlineSingle ty k a' f) lf)) xs a). Proof. induction xs; simpl; intros; eauto. apply IHxs; auto. apply WfBaseMod_inlineSingle_map; assumption. Qed. Lemma subseq_list_app {A : Type} (l : list A) (xs1 xs2 : list nat): subseq_list l (xs1 ++ xs2) = subseq_list l xs1 ++ subseq_list l xs2. Proof. induction xs1; simpl; auto. remember (nth_error _ _) as err0; symmetry in Heqerr0; destruct err0; auto. rewrite <-app_comm_cons, IHxs1; reflexivity. Qed. Lemma subseq_list_shift {A : Type} (xs : list nat) : forall (l1 l2 : list A), (forall n, In n xs -> length l1 <= n) -> subseq_list (l1 ++ l2) xs = subseq_list l2 (map (fun x => x - (length l1)) xs). Proof. induction xs; simpl; auto; intros. remember (nth_error _ _ ) as err0. remember (nth_error l2 _ ) as err1. symmetry in Heqerr0, Heqerr1; destruct err0; rewrite nth_error_app2, Heqerr1 in Heqerr0; auto; rewrite Heqerr0; auto. apply f_equal; auto. Qed. Lemma subseq_list_all {A : Type} (l : list A) : subseq_list l (seq 0 (length l)) = l. Proof. induction l; auto. simpl; apply f_equal. rewrite <- IHl at 3. assert (a :: l = [a] ++ l) as P0; auto; rewrite P0. rewrite subseq_list_shift. - rewrite Reduce_seq; auto. - intros; rewrite in_seq in *; dest; auto. Qed. Lemma existsb_nexists_sync sync l : existsb (SyncRead_eqb sync) l = false <-> ~ In sync l. Proof. split; repeat intro. - assert (exists x, In x l /\ (SyncRead_eqb sync) x = true) as P0. { exists sync; split; auto. unfold SyncRead_eqb; repeat rewrite String.eqb_refl; auto. } rewrite <- existsb_exists in P0; rewrite P0 in *; discriminate. - remember (existsb _ _) as exb; symmetry in Heqexb; destruct exb; auto. exfalso; rewrite existsb_exists in Heqexb; dest. rewrite SyncRead_eqb_eq in *; subst; auto. Qed. (* end misc properties *) Lemma inline_Rules_eq_inlineSome (xs : list nat) : forall (meths : list DefMethT) (rules : list RuleT), fold_left (fun newRules n => inlineSingle_Rules_pos meths n newRules) xs rules = map (inline_Rules meths xs) rules. Proof. induction xs; unfold inline_Rules; simpl; intros. - induction rules; simpl; auto. apply f_equal2; auto. destruct a; apply f_equal. eexists. - rewrite IHxs. clear; induction rules; simpl. + unfold inlineSingle_Rules_pos; destruct nth_error; auto. + rewrite <- IHrules. unfold inlineSingle_Rules_pos. remember (nth_error meths a) as nth_err. destruct nth_err; simpl. * apply f_equal2; auto. unfold inlineSingle_pos, inline_Rules, inlineSingle_Rule; rewrite <- Heqnth_err; simpl. destruct a0; simpl. apply f_equal. eexists. * unfold inline_Rules; destruct a0. apply f_equal2; auto; apply f_equal. unfold inlineSingle_pos at 3; rewrite <- Heqnth_err. reflexivity. Qed. Corollary inlineAll_Rules_in (lm : list DefMethT) : forall lr, inlineAll_Rules lm lr = map (inline_Rules lm (seq 0 (length lm))) lr. Proof. unfold inlineAll_Rules; intros; rewrite inline_Rules_eq_inlineSome; reflexivity. Qed. Lemma inlineSingle_map meths: forall n, inlineSingle_Meths_pos meths n = map (inlineSingle_Meths_posmap meths (fun x => x) n) meths. Proof. intros. unfold inlineSingle_Meths_pos, inlineSingle_Meths_posmap; destruct nth_error;[|rewrite map_id]; auto. Qed. Lemma inlineSome_map xs : forall meths, fold_left inlineSingle_Meths_pos xs meths = map (fold_left (inlineSingle_Meths_posmap meths) xs (fun x => x)) meths. Proof. induction xs; simpl; intros;[rewrite map_id; reflexivity|]. rewrite inlineSingle_map. unfold inlineSingle_Meths_posmap at 1 3; destruct nth_error. - rewrite IHxs. rewrite map_map, forall_map; intros. repeat rewrite <- fold_left_rev_right. clear. revert x; induction (rev xs); simpl; auto; intros. unfold inlineSingle_Meths_posmap at 1 3. remember (nth_error _ _) as nth_err0. remember (nth_error meths a) as nth_err1. destruct nth_err0, nth_err1; auto. + symmetry in Heqnth_err1. apply (map_nth_error (fun x => inlineSingle_Meth d x)) in Heqnth_err1. rewrite Heqnth_err1 in Heqnth_err0; inv Heqnth_err0. rewrite IHl; simpl. apply f_equal2; auto. + exfalso. specialize (nth_error_map (fun x : DefMethT => inlineSingle_Meth d x) (fun x => False) a meths) as P0. rewrite <- Heqnth_err0, <- Heqnth_err1 in P0; rewrite P0; auto. + exfalso. specialize (nth_error_map (fun x : DefMethT => inlineSingle_Meth d x) (fun x => False) a meths) as P0. rewrite <- Heqnth_err0, <- Heqnth_err1 in P0; rewrite <- P0; auto. - rewrite map_id; apply IHxs. Qed. Lemma inlineAll_Rules_in' (lm : list DefMethT) : forall lr, inlineAll_Rules lm lr = inlineAll_Rules_map lm lr. Proof. unfold inlineAll_Rules, inlineAll_Rules_map. induction (seq 0 (length lm)); simpl; intros. - rewrite map_id; reflexivity. - rewrite IHl. clear; induction lr; simpl. + unfold inlineSingle_Rules_pos; destruct nth_error; simpl; auto. + unfold inlineSingle_Rules_pos, inlineSingle_Rule_pos at 3. remember (nth_error lm a) as nth_err. destruct nth_err; simpl; apply f_equal; rewrite <- IHlr; unfold inlineSingle_Rules_pos; rewrite <- Heqnth_err; reflexivity. Qed. Lemma NeverCall_inlineSingle_pos ty k (a : ActionT ty k) : forall (l : list DefMethT) (n : nat) (f : DefMethT) (HNeverCall : forall meth ty, In meth l -> forall arg, NeverCallActionT (projT2 (snd meth) ty arg)), nth_error l n = Some f -> NoCallActionT [f] (inlineSingle_pos l a n). Proof. unfold inlineSingle_pos; intros. remember (nth_error _ _) as nth_err0; symmetry in Heqnth_err0; destruct nth_err0; auto; inv H. apply NeverCall_inline; eauto using nth_error_In. Qed. Lemma NeverCall_inlineSingle_pos_persistent k ty (a : ActionT ty k) : forall (l ls : list DefMethT) (n : nat) (HNeverCall : forall meth ty, In meth l -> forall arg, NeverCallActionT (projT2 (snd meth) ty arg)), NoCallActionT ls a -> NoCallActionT ls (inlineSingle_pos l a n). Proof. unfold inlineSingle_pos; intros. destruct (nth_error _ _) eqn:err0; auto. apply NeverCall_inline_persistent; eauto using nth_error_In. Qed. Lemma NeverCall_inlineSome_pos_persistent xs: forall ty k (a : ActionT ty k) (l ls : list DefMethT) (HNeverCall : forall meth ty, In meth l -> forall arg, NeverCallActionT (projT2 (snd meth) ty arg)), NoCallActionT ls a -> NoCallActionT ls (fold_left (inlineSingle_pos l) xs a). Proof. induction xs; intros; simpl in *; auto. eapply IHxs; eauto using NeverCall_inlineSingle_pos_persistent. Qed. Lemma NeverCall_inlineSome_pos xs: forall ty k (a : ActionT ty k) (l : list DefMethT) (HNeverCall : forall meth ty, In meth l -> forall arg, NeverCallActionT (projT2 (snd meth) ty arg)), (forall f, In f (subseq_list l xs) -> NoCallActionT [f] (fold_left (inlineSingle_pos l) xs a)). Proof. induction xs; simpl; intros; auto;[contradiction|]. destruct (nth_error _ _) eqn:G; auto. inv H; auto. eapply NeverCall_inlineSome_pos_persistent; eauto using NeverCall_inlineSingle_pos. Qed. Lemma NeverCall_inlineSome_pos_full xs : forall ty k (a : ActionT ty k) (l : list DefMethT) (HNeverCall : forall meth ty, In meth l -> forall arg, NeverCallActionT (projT2 (snd meth) ty arg)), NoCallActionT (subseq_list l xs) (fold_left (inlineSingle_pos l) xs a). Proof. induction xs; eauto using NilNoCall; intros. simpl; unfold inlineSingle_pos at 2. destruct (nth_error _ _) eqn:G; eauto. assert (d::subseq_list l xs = [d] ++ subseq_list l xs) as TMP; auto; rewrite TMP; clear TMP. apply NoCallActionT_Stitch; auto. apply NeverCall_inlineSome_pos_persistent; auto. apply NeverCall_inline; eauto using nth_error_In. Qed. Lemma NoSelfCall_ignorable k (a : ActionT type k) : forall (l1 l2 : list DefMethT) (n : nat), n < length l1 -> NoCallActionT l1 a -> inlineSingle_pos (inlineAll_Meths (l1 ++ l2)) a n = a. Proof. unfold inlineSingle_pos; intros; remember (nth_error (inlineAll_Meths (l1 ++ l2)) n) as nth_err0; destruct nth_err0; auto. eapply NotCalled_NotInlined; eauto. symmetry in Heqnth_err0. apply (map_nth_error (fun x => (fst x, projT1 (snd x)))) in Heqnth_err0. rewrite <- SameKindAttrs_inlineAll_Meths, map_app, nth_error_app1 in Heqnth_err0. + apply (nth_error_In _ _ Heqnth_err0). + rewrite map_length; assumption. Qed. Lemma SemRegExprVals expr : forall o1 o2, SemRegMapExpr expr o1 -> SemRegMapExpr expr o2 -> o1 = o2. Proof. induction expr; intros; inv H; inv H0; EqDep_subst; auto; try congruence; specialize (IHexpr _ _ HSemRegMap HSemRegMap0); inv IHexpr; auto. Qed. Lemma UpdRegs_same_nil o : UpdRegs (nil::nil) o o. Proof. unfold UpdRegs. repeat split; auto. intros. right; unfold not; split; intros; dest; auto. destruct H0; subst; auto. Qed. Lemma PriorityUpds_Equiv old upds new (HNoDupOld : NoDup (map fst old)) (HNoDupUpds : forall u, In u upds -> NoDup (map fst u)) : PriorityUpds old upds new -> forall new', PriorityUpds old upds new' -> SubList new new'. Proof. induction 1; intros. - inv H. + apply SubList_refl. + discriminate. - subst. inv H0; inv HFullU. repeat intro. destruct x. specialize (Hcurr _ _ H0). specialize (getKindAttr_map_fst _ _ currRegsTCurr0) as P0. specialize (getKindAttr_map_fst _ _ currRegsTCurr) as P1. assert (In s (map fst new')). { rewrite <- P0, P1, in_map_iff. exists (s, s0); split; auto. } rewrite in_map_iff in H1; dest. destruct x; simpl in *; subst. specialize (Hcurr0 _ _ H2). specialize (HNoDupUpds _ (or_introl _ (eq_refl))) as P3. destruct Hcurr, Hcurr0; dest. + rewrite <-(KeyMatching3 _ _ _ P3 H3 H1 eq_refl). assumption. + exfalso; apply H3. rewrite in_map_iff. exists (s, s0); split; auto. + exfalso; apply H1. rewrite in_map_iff. exists (s, s2); split; auto. + assert (forall u, In u prevUpds0 -> NoDup (map fst u)) as P4; eauto. specialize (IHPriorityUpds P4 _ prevCorrect _ H5). rewrite (getKindAttr_map_fst _ _ (prevPrevRegsTrue prevCorrect)) in HNoDupOld. rewrite (KeyMatching3 _ _ _ HNoDupOld H4 IHPriorityUpds eq_refl) in *. assumption. Qed. Lemma PriorityUpdsCompact upds: forall old new, PriorityUpds old upds new -> PriorityUpds old (nil::upds) new. Proof. induction upds. - econstructor 2 with (u := nil) (prevUpds := nil); eauto; repeat constructor. inv H; eauto. - intros. econstructor 2 with (u := nil) (prevUpds := a :: upds); eauto. inv H; auto. Qed. Lemma CompactPriorityUpds upds: forall old, NoDup (map fst old) -> forall new, PriorityUpds old (nil::upds) new -> PriorityUpds old upds new. Proof. induction upds; intros. - enough (old = new). { subst; constructor. } inv H0; inv HFullU; inv prevCorrect;[|discriminate]; simpl in *. apply getKindAttr_map_fst in currRegsTCurr. assert (forall s v, In (s, v) new -> In (s, v) prevRegs). { intros. destruct (Hcurr _ _ H0);[contradiction|dest]; auto. } symmetry. apply KeyMatch; auto. rewrite currRegsTCurr in H; assumption. - inv H0; inv HFullU. enough ( new = prevRegs). { rewrite H0; auto. } apply getKindAttr_map_fst in currRegsTCurr. specialize (getKindAttr_map_fst _ _ (prevPrevRegsTrue prevCorrect)) as P0. rewrite currRegsTCurr in H. eapply KeyMatch; eauto. + rewrite <- currRegsTCurr; assumption. + intros. destruct (Hcurr _ _ H0);[contradiction| dest; auto]. Qed. Lemma CompactPriorityUpds_iff {old} (NoDupsOld : NoDup (map fst old)) upds new: PriorityUpds old (nil::upds) new <-> PriorityUpds old upds new. Proof. split; eauto using CompactPriorityUpds, PriorityUpdsCompact. Qed. Lemma inline_Meths_eq_inlineSome (xs : list nat) : forall (l l' : list DefMethT) (HDisjMeths : DisjKey l l'), fold_left (inlineSingle_Flat_pos l') xs l = map (inline_Meths l' xs) l. Proof. induction xs; simpl; intros. - unfold inline_Meths; induction l; simpl in *; auto. rewrite <-IHl. + destruct a, s0, x; simpl. reflexivity. + intro k; specialize (HDisjMeths k); simpl in *; firstorder fail. - rewrite IHxs. + unfold inlineSingle_Flat_pos. remember (nth_error l' a) as nth_err. destruct nth_err. * unfold inline_Meths at 2; simpl. unfold inlineSingle_pos at 2. rewrite <- Heqnth_err. induction l; simpl; auto. rewrite <- IHl. -- apply f_equal2; auto. unfold inline_Meths, inlineSingle_Meth. destruct a0, s0. remember (String.eqb _ _ ) as strd; symmetry in Heqstrd. destruct strd; auto; rewrite String.eqb_eq in *. exfalso. specialize (nth_error_In _ _ (eq_sym Heqnth_err)) as P0. destruct d; subst. apply (in_map fst) in P0. clear - HDisjMeths P0. destruct (HDisjMeths s0); auto; apply H; left; reflexivity. -- clear - HDisjMeths. intro k; specialize (HDisjMeths k); simpl in *; firstorder fail. * unfold inline_Meths at 2; simpl. unfold inlineSingle_pos at 2. rewrite <- Heqnth_err. fold (inline_Meths l' xs). reflexivity. + clear - HDisjMeths. intro k; specialize (HDisjMeths k). enough (map fst (inlineSingle_Flat_pos l' l a) = (map fst l)). { rewrite H; auto. } unfold inlineSingle_Flat_pos. destruct nth_error; auto. apply inline_preserves_keys_Meth. Qed. Lemma getFromEach_getMethods (rf : RegFileBase) : getMethods rf = getEachRfMethod rf. Proof. unfold getEachRfMethod; destruct rf; simpl. destruct rfRead; simpl; auto. unfold readSyncRegFile, getSyncReq, getSyncRes; simpl. destruct isAddr; auto. Qed. Lemma inlineSingle_Flat_pos_lengths : forall xs ls ls', length (fold_left (inlineSingle_Flat_pos ls') xs ls) = length ls. Proof. induction xs; simpl; auto; intros. rewrite IHxs. unfold inlineSingle_Flat_pos. destruct nth_error; auto. rewrite map_length. reflexivity. Qed. Lemma inlineAll_Meths_RegFile_fold_flat2 n : forall (l l' : list DefMethT) (HNeverCall : forall meth ty, In meth l' -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))) (Hlen : 0 < n - length l), fold_left inlineSingle_Meths_pos (seq (length l) (n - (length l))) (l ++ l') = fold_left (inlineSingle_Flat_pos l') (seq 0 (n - length l)) l ++ l'. Proof. intros; induction n. - simpl; auto. - assert (length l <= n) as TMP. { lia. } rewrite Nat.sub_succ_l in *; auto. + apply lt_n_Sm_le in Hlen. destruct (le_lt_or_eq _ _ Hlen). * repeat rewrite seq_eq. repeat rewrite fold_left_app; simpl. rewrite IHn; [rewrite <- le_plus_minus; [|lia]|]; auto. remember (nth_error l' (n - length l)) as nth_err. destruct nth_err. -- symmetry in Heqnth_err. assert (length l <= n) as P1. { lia. } rewrite <-(inlineSingle_Flat_pos_lengths (seq 0 (n - Datatypes.length l)) l l') in Heqnth_err, P1. erewrite inlineAll_Meths_RegFile_flat2; eauto. unfold inlineSingle_Flat_pos at 2. rewrite inlineSingle_Flat_pos_lengths in Heqnth_err. rewrite Heqnth_err. reflexivity. -- unfold inlineSingle_Meths_pos. remember (nth_error (fold_left (inlineSingle_Flat_pos l') (seq 0 (n - Datatypes.length l)) l ++ l') n) as nth_err2. destruct nth_err2. ++ exfalso. assert (nth_error (fold_left (inlineSingle_Flat_pos l') (seq 0 (n - Datatypes.length l)) l ++ l') n <> None) as P1. { rewrite <- Heqnth_err2; intro; discriminate. } rewrite nth_error_Some in P1. rewrite app_length, inlineSingle_Flat_pos_lengths in P1. symmetry in Heqnth_err. rewrite nth_error_None in Heqnth_err. lia. ++ unfold inlineSingle_Flat_pos. rewrite <- Heqnth_err; reflexivity. * rewrite <- H; simpl. assert (n = length l) as P0. { lia. } rewrite P0 in *; clear TMP. remember (nth_error l' (length l - length l)) as nth_err. destruct nth_err. -- symmetry in Heqnth_err. erewrite inlineAll_Meths_RegFile_flat2; eauto. unfold inlineSingle_Flat_pos. remember (nth_error l' 0) as nth_err2. destruct nth_err2. ++ rewrite Nat.sub_diag in Heqnth_err. rewrite Heqnth_err in *. inv Heqnth_err2. reflexivity. ++ rewrite Nat.sub_diag in Heqnth_err. rewrite Heqnth_err in *. inv Heqnth_err2. -- unfold inlineSingle_Meths_pos. remember (nth_error (l ++ l') (Datatypes.length l)) as nth_err2. destruct nth_err2. ++ exfalso. assert (nth_error (l ++ l') (length l) <> None). { rewrite <- Heqnth_err2; intro; inv H0. } rewrite nth_error_Some in H0. symmetry in Heqnth_err. rewrite nth_error_None in Heqnth_err. rewrite app_length in H0. rewrite Nat.sub_diag in Heqnth_err. lia. ++ unfold inlineSingle_Flat_pos. rewrite Nat.sub_diag in Heqnth_err. rewrite <- Heqnth_err. reflexivity. Qed. Lemma inlineAll_Meths_RegFile_fold_flat : forall (l l' : list DefMethT) (HNeverCall : forall meth ty, In meth l' -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))), fold_left inlineSingle_Meths_pos (seq 0 (length (l ++ l'))) (l ++ l') = fold_left (inlineSingle_Flat_pos l') (seq 0 (length l')) (fold_left inlineSingle_Meths_pos (seq 0 (length l)) l) ++ l'. Proof. intros. specialize (Nat.le_add_r (length l) (length l')) as P0. rewrite app_length, (seq_app' _ P0), fold_left_app, Nat.add_0_l. rewrite inlineAll_Meths_RegFile_fold_flat1; auto. destruct (zerop (length l')). - rewrite e; rewrite minus_plus; simpl. rewrite length_zero_iff_nil in e; rewrite e, app_nil_r; reflexivity. - assert (0 < (length l + length l') - length l). { rewrite minus_plus; assumption. } rewrite <- (inlineSome_Meths_pos_length l (seq 0 (Datatypes.length l))) at 1 2 3. rewrite <- (inlineSome_Meths_pos_length l (seq 0 (Datatypes.length l))) in H. rewrite inlineAll_Meths_RegFile_fold_flat2; auto. rewrite (inlineSome_Meths_pos_length l (seq 0 (Datatypes.length l))) in *. rewrite minus_plus. rewrite <- (inlineSome_Meths_pos_length l (seq 0 (Datatypes.length l)) ). reflexivity. Qed. Lemma inlineSingle_pos_NeverCall k ty (a : ActionT ty k) n: forall (l : list DefMethT) (ls : list DefMethT), (forall meth ty, In meth l -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))) -> (forall k, ~In k (map fst l) \/ ~In k (map fst ls)) -> NoCallActionT ls (inlineSingle_pos l a n) -> NoCallActionT ls a. Proof. unfold inlineSingle_pos; intros; remember (nth_error _ _) as nth_err0; symmetry in Heqnth_err0; destruct nth_err0; auto. apply nth_error_In in Heqnth_err0. eapply inline_NeverCall; eauto. apply (in_map fst) in Heqnth_err0. destruct (H0 (fst d)); auto. intro; apply H2; rewrite in_map_iff in *; dest; exists x; inv H3; split; auto. Qed. Lemma inlineSome_pos_NeverCall xs : forall k ty (a : ActionT ty k) (l : list DefMethT) (ls : list DefMethT), (forall meth ty, In meth l -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))) -> (forall k, ~In k (map fst l) \/ ~In k (map fst ls)) -> NoCallActionT ls (fold_left (inlineSingle_pos l) xs a) -> NoCallActionT ls a. Proof. induction xs; simpl; intros; auto. eapply inlineSingle_pos_NeverCall; eauto. Qed. Lemma NoCall_Meths_reduction xs : forall (l l' : list DefMethT) (HDisjKeys : DisjKey l l') (HNeverCall : forall meth ty, In meth l' -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))), (forall meth ty, In meth (fold_left (inlineSingle_Flat_pos l') xs l) -> (forall arg, NoCallActionT l (projT2 (snd meth) ty arg))) -> (forall meth ty, In meth l -> (forall arg, NoCallActionT l (projT2 (snd meth) ty arg))). Proof. intros. rewrite inline_Meths_eq_inlineSome in *; auto. destruct meth, s0; simpl in *. specialize (H _ ty (in_map (inline_Meths l' xs) _ _ H0) arg); unfold inline_Meths in *; simpl in *. eapply inlineSome_pos_NeverCall; eauto. apply DisjKey_Commutative in HDisjKeys; intro k; specialize (HDisjKeys k); assumption. Qed. Lemma NoCall_Rules_reduction : forall (l : list DefMethT) (lr : list RuleT) (ls : list DefMethT) (DisjKeys : forall k, ~In k (map fst l) \/ ~In k (map fst ls)) (HNeverCall : forall meth ty, In meth l -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))), (forall rule ty, In rule (inlineAll_Rules l lr) -> NoCallActionT ls (snd rule ty)) -> (forall rule ty, In rule lr -> NoCallActionT ls (snd rule ty)). Proof. intros; destruct rule; simpl in *. rewrite inlineAll_Rules_in in *. eapply inlineSome_pos_NeverCall; eauto. specialize (H _ ty (in_map (inline_Rules l _) _ _ H0)); unfold inline_Rules in *; simpl in *; apply H. Qed. Lemma SameKeys_inlineSome_Meths_map xs : forall (l l' : list DefMethT), (map fst (map (inline_Meths l' xs) l)) = map fst l. Proof. unfold inline_Meths; induction l; simpl; auto; intros. setoid_rewrite IHl; apply f_equal2; destruct a; auto. Qed. Lemma SameKindAttrs_inlineSome_Meths_map xs : forall (l l' : list DefMethT), (getKindAttr (map (inline_Meths l' xs) l)) = getKindAttr l. Proof. unfold inline_Meths; induction l; simpl; auto; intros. setoid_rewrite IHl; apply f_equal2; destruct a, s0; auto. Qed. Lemma inlineAll_NoCall_Meths_RegFile_fold_flat : forall (l l' : list DefMethT) (HNeverCall : forall meth ty, In meth l' -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))) (HDisjMeths : DisjKey l l') (HNoCall : forall meth ty, In meth l -> (forall arg, NoCallActionT l (projT2 (snd meth) ty arg))), inlineAll_Meths (l ++ l') = map (inline_Meths l' (seq 0 (length l'))) l ++ l' /\ (forall meth ty, In meth (map (inline_Meths l' (seq 0 (length l'))) l) -> (forall arg, NoCallActionT ((map (inline_Meths l' (seq 0 (length l'))) l)) (projT2 (snd meth) ty arg))). Proof. intros; split. - unfold inlineAll_Meths; rewrite inlineAll_Meths_RegFile_fold_flat; auto. erewrite (inlineSome_Meths_pos_NoCalls_ident); eauto; [| apply SubList_refl]. rewrite inline_Meths_eq_inlineSome; auto. - intros. rewrite in_map_iff in H; dest; subst; destruct x, s0. specialize (HNoCall _ ty H0 arg); simpl in *. eapply NeverCall_inlineSome_pos_persistent; auto. * specialize (SameKindAttrs_inlineSome_Meths_map (seq 0 (length l')) l l') as P0. eauto using SignatureReplace_NoCall. Qed. Lemma SameKeys_inlineSome_Rules_map xs : forall (l' : list DefMethT) (l : list RuleT), (map fst (map (inline_Rules l' xs) l)) = map fst l. Proof. unfold inline_Rules; induction l; simpl; auto; intros. setoid_rewrite IHl; apply f_equal2; destruct a; auto. Qed. Lemma inlineAll_NoCall_Rules_RegFile_fold_flat : forall (l l' : list DefMethT) (lr : list RuleT) (HNeverCall : forall meth ty, In meth l' -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))) (HDisjMeths : DisjKey l l') (HNoCall : forall rule ty, In rule lr -> NoCallActionT l (snd rule ty)), inlineAll_Rules (l ++ l') lr = map (inline_Rules l' (seq 0 (length l'))) lr /\ (forall rule ty, In rule (map (inline_Rules l' (seq 0 (length l'))) lr) -> NoCallActionT l (snd rule ty)). Proof. intros; split. - rewrite inlineAll_Rules_NoCalls; auto. unfold inlineAll_Rules at 2. erewrite inlineSome_Rules_pos_NoCalls_ident; eauto using SubList_refl. apply inlineAll_Rules_in. - intros; rewrite in_map_iff in *; dest; subst; destruct x; simpl in *. apply NeverCall_inlineSome_pos_persistent; auto. apply (HNoCall _ _ H0). Qed. Lemma inlineSingle_pos_app_l (l1 l2 : list DefMethT) ty k (a : ActionT ty k) : forall n, n < length l1 -> inlineSingle_pos (l1 ++ l2) a n = inlineSingle_pos l1 a n. Proof. intros; unfold inlineSingle_pos. remember (nth_error (l1 ++ l2) n) as nth_err0. destruct nth_err0; rewrite nth_error_app1 in Heqnth_err0; auto; rewrite <- Heqnth_err0; reflexivity. Qed. Lemma inlineSingle_pos_app_r (l1 l2 : list DefMethT) ty k (a : ActionT ty k) : forall n, length l1 <= n -> inlineSingle_pos (l1 ++ l2) a n = inlineSingle_pos l2 a (n - length l1). Proof. intros; unfold inlineSingle_pos. remember (nth_error (l1 ++ l2) n) as nth_err0. destruct nth_err0; rewrite nth_error_app2 in Heqnth_err0; auto; rewrite <- Heqnth_err0; reflexivity. Qed. Lemma inlineSome_pos_app_l (l1 l2 : list DefMethT) ty k (a : ActionT ty k) n : n <= length l1 -> fold_left (inlineSingle_pos (l1 ++ l2)) (seq 0 n) a = fold_left (inlineSingle_pos l1) (seq 0 n) a. Proof. induction n; auto; intros. rewrite seq_eq; repeat rewrite fold_left_app; simpl. rewrite inlineSingle_pos_app_l; [|lia]. rewrite IHn; auto; lia. Qed. Lemma inlineSome_pos_app_r (l1 l2 : list DefMethT) ty k (a : ActionT ty k) n : fold_left (inlineSingle_pos (l1 ++ l2)) (seq (length l1) n) a = fold_left (inlineSingle_pos l2) (seq 0 n) a. Proof. induction n; auto; intros. repeat rewrite seq_eq; repeat rewrite fold_left_app; simpl. rewrite inlineSingle_pos_app_r; [|lia]. rewrite IHn, minus_plus; reflexivity. Qed. Lemma inlineSome_pos_app (l1 l2 : list DefMethT) ty k (a : ActionT ty k) : forall n m, n = length l1 -> m = length l2 -> fold_left (inlineSingle_pos (l1 ++ l2)) (seq 0 (n + m)) a = fold_left (inlineSingle_pos l2) (seq 0 m) (fold_left (inlineSingle_pos l1) (seq 0 n) a). Proof. intros. assert (n <= length (l1 ++ l2)) as P0. { rewrite app_length; lia. } rewrite H, H0, <- app_length. rewrite (seq_app' _ P0), fold_left_app, app_length, H, minus_plus, plus_O_n. rewrite inlineSome_pos_app_r, inlineSome_pos_app_l; auto. Qed. Lemma SameKeys_inlineSingle_Flat meths1 meths2 n : map fst (inlineSingle_Flat_pos meths1 meths2 n) = map fst meths2. Proof. unfold inlineSingle_Flat_pos; destruct nth_error; auto. apply inline_preserves_keys_Meth. Qed. Lemma SameKeys_inlineSome_Flat xs : forall meths1 meths2, map fst (fold_left (inlineSingle_Flat_pos meths1) xs meths2) = map fst meths2. Proof. induction xs; simpl; auto; intros. rewrite IHxs, SameKeys_inlineSingle_Flat; reflexivity. Qed. Lemma SameKindAttrs_inlineSingle_Flat meths1 meths2 n : getKindAttr (inlineSingle_Flat_pos meths1 meths2 n) = getKindAttr meths2. Proof. unfold inlineSingle_Flat_pos; destruct nth_error; auto. apply inline_preserves_KindAttrs_Meth. Qed. Lemma SameKindAttrs_inlineSome_Flat xs : forall meths1 meths2, getKindAttr (fold_left (inlineSingle_Flat_pos meths1) xs meths2) = getKindAttr meths2. Proof. induction xs; simpl; auto; intros. rewrite IHxs, SameKindAttrs_inlineSingle_Flat; reflexivity. Qed. Lemma UpdOrMeths_RegsT_app (uml1 uml2 : UpdOrMeths) : UpdOrMeths_RegsT (uml1 ++ uml2) = UpdOrMeths_RegsT uml1 ++ UpdOrMeths_RegsT uml2. Proof. induction uml1; simpl; auto. destruct a; simpl; auto. rewrite IHuml1; reflexivity. Qed. Lemma UpdOrMeths_MethsT_app (uml1 uml2 : UpdOrMeths) : UpdOrMeths_MethsT (uml1 ++ uml2) = UpdOrMeths_MethsT uml1 ++ UpdOrMeths_MethsT uml2. Proof. induction uml1; simpl; auto. destruct a; simpl; auto. rewrite IHuml1; reflexivity. Qed. Lemma SemCompActionEEquivWMap (k : Kind) (ea : EActionT type k): forall o calls retl bexpr v' v expr1 expr2, SemRegMapExpr expr1 v -> SemRegMapExpr expr2 v -> SemCompActionT (EcompileAction o ea bexpr expr1) v' calls retl -> SemCompActionT (EcompileAction o ea bexpr expr2) v' calls retl. Proof. induction ea; intros; simpl in *; eauto. - inv H2; EqDep_subst; [econstructor 1 | econstructor 2]; eauto. - inv H2; EqDep_subst; econstructor; eauto. - inv H2; EqDep_subst; econstructor; eauto. - inv H2; EqDep_subst; econstructor; eauto. - inv H2; EqDep_subst; econstructor; eauto. - inv H1; simpl in *; EqDep_subst; rewrite unifyWO in *. inv HSemCompActionT_a; EqDep_subst. econstructor; eauto. inv HRegMapWf. repeat econstructor; auto. inv H1; EqDep_subst; [econstructor 2| econstructor 3]; eauto; erewrite SemRegExprVals; eauto. - inv H2; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; simpl in *; EqDep_subst. inv HSemCompActionT_cont0; simpl in *; EqDep_subst. repeat (econstructor; eauto). - inv H1; EqDep_subst; econstructor; eauto. - inv H1; EqDep_subst; econstructor; eauto. inv HRegMapWf; constructor; auto. erewrite SemRegExprVals; eauto. - inv H2; EqDep_subst; econstructor; eauto. rewrite (SemRegExprVals H0 HWriteMap); assumption. - inv H1; EqDep_subst;[econstructor 10 | econstructor 11]; eauto; inv HUpdate; inv H1; EqDep_subst; econstructor; eauto. + econstructor 2; eauto. erewrite SemRegExprVals; eauto. + econstructor 3; eauto. erewrite SemRegExprVals; eauto. + econstructor 2; eauto. erewrite SemRegExprVals; eauto. + econstructor 3; eauto. erewrite SemRegExprVals; eauto. - inv H1; EqDep_subst; inv HWriteMap; inv H1; EqDep_subst. + repeat (econstructor; eauto). erewrite SemRegExprVals; eauto. + do 2 (econstructor; eauto). econstructor 3; eauto. erewrite SemRegExprVals; eauto. + do 3 (econstructor; eauto). erewrite SemRegExprVals; eauto. + do 2 (econstructor; eauto). econstructor 3; eauto. erewrite SemRegExprVals; eauto. - inv H2; EqDep_subst;[econstructor 14 | econstructor 15]; eauto; rewrite (SemRegExprVals H0 HWriteMap); eauto. Qed. Lemma SemCompActionEEquivBexpr (k : Kind) (ea : EActionT type k): forall o calls retl expr1 v' (bexpr1 bexpr2 : Bool @# type), evalExpr bexpr1 = evalExpr bexpr2 -> SemCompActionT (EcompileAction o ea bexpr1 expr1) v' calls retl -> SemCompActionT (EcompileAction o ea bexpr2 expr1) v' calls retl. Proof. induction ea; intros; simpl in *; eauto. - inv H1; EqDep_subst; [econstructor 1| econstructor 2]; eauto. - inv H1; EqDep_subst; econstructor; eauto. - inv H1; EqDep_subst; econstructor; eauto. - inv H1; EqDep_subst; econstructor; eauto. - inv H1; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst. econstructor; eauto. rewrite (unifyWO val_a) in HSemCompActionT_a. inv HSemCompActionT_a; EqDep_subst. econstructor; eauto. inv HRegMapWf; destruct regMap_a. split; auto. destruct (bool_dec (evalExpr bexpr2) true). inv H0; EqDep_subst. + econstructor 2; eauto. + congruence. + inv H0; EqDep_subst. * congruence. * econstructor 3; eauto. - inv H1; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; simpl in *; EqDep_subst. do 3 econstructor. + eapply IHea1 with (bexpr1 := (Var type (SyntaxKind Bool) (evalExpr bexpr1 && evalExpr e))); eauto. simpl; rewrite H0; reflexivity. + reflexivity. + econstructor. * eapply IHea2 with (bexpr1 := (Var type (SyntaxKind Bool) (evalExpr (bexpr2 && ! e)%kami_expr))); eauto. simpl; rewrite <- H0; eauto. * reflexivity. * econstructor; simpl. eapply H; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H1; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. + unfold WfRegMapExpr in *; dest; split; auto. inv H0; EqDep_subst. * econstructor; rewrite H in *; eauto. * econstructor 3; rewrite H in *; eauto. + econstructor 11; eauto. unfold WfRegMapExpr in *; dest; split; auto. inv H0; EqDep_subst. * econstructor; rewrite H in *; eauto. * econstructor 3; rewrite H in *; eauto. - inv H0; EqDep_subst. econstructor; eauto. + unfold WfRegMapExpr in *; dest; split; auto. inv H0; EqDep_subst. * econstructor; rewrite H in *; eauto. * econstructor 3; rewrite H in *; eauto. + econstructor 13; eauto. unfold WfRegMapExpr in *; dest; split; auto. inv H0; EqDep_subst. * econstructor; rewrite H in *; eauto. * econstructor 3; rewrite H in *; eauto. - inv H1; EqDep_subst; [econstructor | econstructor 15]; eauto. Qed. Lemma SemCompActionEquivBexpr (k : Kind) (a : ActionT type k): forall o calls retl expr1 v' (bexpr1 bexpr2 : Bool @# type), evalExpr bexpr1 = evalExpr bexpr2 -> SemCompActionT (compileAction o a bexpr1 expr1) v' calls retl -> SemCompActionT (compileAction o a bexpr2 expr1) v' calls retl. Proof. induction a; intros; simpl in *; eauto. - inv H1; EqDep_subst; [econstructor 1| econstructor 2]; eauto. - inv H1; EqDep_subst; econstructor; eauto. - inv H1; EqDep_subst; econstructor; eauto. - inv H1; EqDep_subst; econstructor; eauto. - inv H1; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst. econstructor; eauto. rewrite (unifyWO val_a) in HSemCompActionT_a. inv HSemCompActionT_a; EqDep_subst. econstructor; eauto. inv HRegMapWf; destruct regMap_a. split; auto. destruct (bool_dec (evalExpr bexpr2) true). inv H0; EqDep_subst. + econstructor 2; eauto. + congruence. + inv H0; EqDep_subst. * congruence. * econstructor 3; eauto. - inv H1; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; simpl in *; EqDep_subst. do 3 econstructor. + eapply IHa1 with (bexpr1 := (Var type (SyntaxKind Bool) (evalExpr (bexpr2 && e)%kami_expr))); eauto. simpl; rewrite <- H0; eauto. + reflexivity. + econstructor. * eapply IHa2 with (bexpr1 := (Var type (SyntaxKind Bool) (evalExpr (bexpr2 && ! e)%kami_expr)));eauto. simpl; rewrite <-H0; eauto. * reflexivity. * econstructor; simpl. eapply H; eauto. - inv H0; EqDep_subst. econstructor; eauto. Qed. Lemma EpredFalse_UpdsNil k ea : forall (bexpr: Bool @# type) o u regMap1 regMap2 calls val (HNbexpr : evalExpr bexpr = false) rexpr (HRegMap : SemRegMapExpr rexpr regMap1), @SemCompActionT k (EcompileAction (o, u) ea bexpr rexpr) regMap2 calls val -> regMap1 = regMap2 /\ calls = nil. Proof. induction ea; intros. - inv H0; EqDep_subst;[congruence|eauto]. - inv H0; EqDep_subst; eauto. - inv H0; EqDep_subst; eauto. specialize (IHea _ _ _ _ _ _ _ HNbexpr _ HRegMap HSemCompActionT_a); dest. rewrite H0 in HRegMap. specialize (H _ _ _ _ _ _ _ _ HNbexpr _ (SemVarRegMap _) HSemCompActionT_cont); dest. split; subst; auto. - inv H0; EqDep_subst; eauto. - inv H0; EqDep_subst; eauto. - inv H; simpl in *; EqDep_subst; eauto. rewrite (unifyWO val_a) in HSemCompActionT_a. inv HSemCompActionT_a; EqDep_subst. inv HRegMapWf; inv H; EqDep_subst;[congruence|]. specialize (IHea _ _ _ _ _ _ _ HNbexpr _ (SemVarRegMap _) HSemCompActionT_cont); dest. rewrite (SemRegExprVals HRegMap HSemRegMap); auto. - inv H0; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; EqDep_subst. apply Eqdep.EqdepTheory.inj_pair2 in H4; subst; simpl in *. assert (forall (b : Expr type (SyntaxKind Bool)), (evalExpr (Var type (SyntaxKind Bool) (evalExpr bexpr && evalExpr b)) = false)). { intros; simpl; rewrite HNbexpr; auto. } specialize (IHea1 _ _ _ _ _ _ _ (H0 e) _ HRegMap HSemCompActionT_a); dest. specialize (IHea2 _ _ _ _ _ _ _ (H0 (!e)%kami_expr) _ (SemVarRegMap _) HSemCompActionT_a0); dest. specialize (H _ _ _ _ _ _ _ _ HNbexpr _ (SemVarRegMap _) HSemCompActionT); dest. subst; auto. - inv H; EqDep_subst; eauto. - inv H; EqDep_subst. inv HRegMapWf. rewrite (SemRegExprVals HRegMap H); auto. - inv H0; EqDep_subst; eauto; eapply H with (rexpr := VarRegMap type writeMapTy); eauto; assert (sth: regMap1 = writeMapTy) by (eapply SemRegExprVals; eauto); subst; econstructor. - inv H; EqDep_subst; eauto; unfold WfRegMapExpr in *; dest; inv H; EqDep_subst; [rewrite HNbexpr in *; discriminate| | rewrite HNbexpr in *; discriminate | ]; specialize (IHea _ _ _ _ _ _ _ HNbexpr _ (SemVarRegMap _) HSemCompActionT); dest; subst; rewrite (SemRegExprVals HSemRegMap HRegMap); split; auto. - inv H; EqDep_subst; eauto; unfold WfRegMapExpr in *; dest; inv H; EqDep_subst; [rewrite HNbexpr in *; discriminate| | rewrite HNbexpr in *; discriminate | ]; specialize (IHea _ _ _ _ _ _ _ HNbexpr _ (SemVarRegMap _) HSemCompActionT); dest; subst; rewrite (SemRegExprVals HSemRegMap HRegMap); split; auto. - inv H0; EqDep_subst; eauto; eapply H with (rexpr := VarRegMap type writeMapTy); eauto; unfold WfRegMapExpr in *; dest; assert (sth: regMap1 = writeMapTy) by (eapply SemRegExprVals; eauto); subst; econstructor. Qed. Lemma predFalse_UpdsNil k a: forall (bexpr: Bool @# type) o u regMap1 regMap2 calls val (HNbexpr : evalExpr bexpr = false) rexpr (HRegMap : SemRegMapExpr rexpr regMap1), @SemCompActionT k (compileAction (o, u) a bexpr rexpr) regMap2 calls val -> regMap1 = regMap2 /\ calls = nil. Proof. induction a; intros. - inv H0; EqDep_subst;[congruence|eauto]. - inv H0; EqDep_subst; eauto. - inv H0; EqDep_subst; eauto. specialize (IHa _ _ _ _ _ _ _ HNbexpr _ HRegMap HSemCompActionT_a); dest. rewrite H0 in HRegMap. specialize (H _ _ _ _ _ _ _ _ HNbexpr _ (SemVarRegMap _) HSemCompActionT_cont); dest. split; subst; auto. - inv H0; EqDep_subst; eauto. - inv H0; EqDep_subst; eauto. - inv H; simpl in *; EqDep_subst; eauto. rewrite (unifyWO val_a) in HSemCompActionT_a. inv HSemCompActionT_a; EqDep_subst. inv HRegMapWf; inv H; EqDep_subst;[congruence|]. specialize (IHa _ _ _ _ _ _ _ HNbexpr _ (SemVarRegMap _) HSemCompActionT_cont); dest. rewrite (SemRegExprVals HRegMap HSemRegMap); auto. - inv H0; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; EqDep_subst. apply Eqdep.EqdepTheory.inj_pair2 in H4; subst; simpl in *. assert (forall (b : Expr type (SyntaxKind Bool)), (evalExpr (Var type (SyntaxKind Bool) (evalExpr bexpr && evalExpr b)) = false)). { intros; simpl; rewrite HNbexpr; auto. } specialize (IHa1 _ _ _ _ _ _ _ (H0 e) _ HRegMap HSemCompActionT_a); dest. specialize (IHa2 _ _ _ _ _ _ _ (H0 (!e)%kami_expr) _ (SemVarRegMap _) HSemCompActionT_a0); dest. specialize (H _ _ _ _ _ _ _ _ HNbexpr _ (SemVarRegMap _) HSemCompActionT); dest. subst; auto. - inv H; EqDep_subst; eauto. - inv H; EqDep_subst. inv HRegMapWf. rewrite (SemRegExprVals HRegMap H); auto. Qed. Lemma ESameOldAction (k : Kind) (ea : EActionT type k) : forall oInit uInit writeMap old upds wOld wUpds calls retl bexpr (HSemRegMap : SemRegMapExpr writeMap (wOld, wUpds)), @SemCompActionT k (EcompileAction (oInit, uInit) ea bexpr writeMap) (old, upds) calls retl -> wOld = old. Proof. induction ea; intros; simpl in *. - inv H0; EqDep_subst; simpl in *; eapply H; eauto. - inv H0; EqDep_subst; simpl in *. eapply H; eauto. - inv H0; EqDep_subst; simpl in *. destruct regMap_a. specialize (H _ _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont); subst. specialize (IHea _ _ _ _ _ _ _ _ _ _ HSemRegMap HSemCompActionT_a); assumption. - inv H0; EqDep_subst; simpl in *. eapply H; eauto. - inv H0; EqDep_subst; simpl in *. eapply H; eauto. - inv H; simpl in *; EqDep_subst. rewrite (unifyWO val_a) in HSemCompActionT_a. inv HSemCompActionT_a; EqDep_subst. destruct regMap_a; unfold WfRegMapExpr in *; dest. inv H; EqDep_subst. + specialize (IHea _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont). specialize (SemRegExprVals HSemRegMap HSemRegMap0) as TMP; inv TMP. reflexivity. + specialize (IHea _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont). specialize (SemRegExprVals HSemRegMap HSemRegMap0) as TMP; inv TMP. reflexivity. - inv H0; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; simpl in *; EqDep_subst. destruct regMap_a, regMap_a0. specialize (H _ _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT). simpl in *. specialize (IHea1 _ _ _ _ _ _ _ _ _ _ HSemRegMap HSemCompActionT_a). specialize (IHea2 _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT_a0). subst; reflexivity. - inv H; EqDep_subst; simpl in *. eapply IHea; eauto. - inv H; EqDep_subst. unfold WfRegMapExpr in *; dest. specialize (SemRegExprVals H HSemRegMap) as TMP; inv TMP. reflexivity. - inv H0; EqDep_subst. eapply H with (writeMap := VarRegMap type writeMapTy); eauto; assert (sth: writeMapTy = (wOld, wUpds)) by (eapply SemRegExprVals; eauto); subst; econstructor. - inv H; EqDep_subst; unfold WfRegMapExpr in *; destruct regMapVal; dest; specialize (IHea _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT); subst; inv H; EqDep_subst; specialize (SemRegExprVals HSemRegMap HSemRegMap0) as TMP; inv TMP; reflexivity. - inv H; EqDep_subst; unfold WfRegMapExpr in *; destruct regMapVal; dest; specialize (IHea _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT); subst; inv H; EqDep_subst; specialize (SemRegExprVals HSemRegMap HSemRegMap0) as TMP; inv TMP; reflexivity. - inv H0; EqDep_subst; eapply H with (writeMap := VarRegMap type writeMapTy); eauto; assert (sth: writeMapTy = (wOld, wUpds)) by (eapply SemRegExprVals; eauto); subst; econstructor. Qed. Lemma EEquivActions k ea: forall writeMap o old upds oInit uInit (HoInitNoDups : NoDup (map fst oInit)) (HuInitNoDups : forall u, In u uInit -> NoDup (map fst u)) (HPriorityUpds : PriorityUpds oInit uInit o) (HConsistent : getKindAttr o = getKindAttr old) (WfMap : WfRegMapExpr writeMap (old, upds)), forall calls retl upds', @SemCompActionT k (EcompileAction (oInit, uInit) ea (Const type true) writeMap) upds' calls retl -> (forall u, In u (snd upds') -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old)) /\ exists uml, upds' = (old, match (UpdOrMeths_RegsT uml) with |nil => upds |_ :: _ => (hd nil upds ++ (UpdOrMeths_RegsT uml)) :: tl upds end) /\ calls = (UpdOrMeths_MethsT uml) /\ ESemAction o ea uml retl. Proof. induction ea; subst; intros; simpl in *. - inv H0; EqDep_subst;[|discriminate]. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists (UmMeth (meth, existT SignT s (evalExpr e, ret))::x); repeat split; simpl; subst; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x; repeat split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (IHea _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT_a); dest. assert (WfRegMapExpr (VarRegMap type regMap_a) regMap_a) as WfMap0. { unfold WfRegMapExpr; split;[econstructor|]. destruct regMap_a; inv H1; intros. apply (H0 _ H1). } rewrite H1 in *. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap0 _ _ _ HSemCompActionT_cont); dest. split; auto. exists (x++x0); rewrite UpdOrMeths_RegsT_app, UpdOrMeths_MethsT_app; repeat split; auto. + destruct (UpdOrMeths_RegsT x0); simpl in *; auto. * rewrite app_nil_r; assumption. * destruct (UpdOrMeths_RegsT x); simpl in *; auto. rewrite app_comm_cons, app_assoc; assumption. + subst; auto. + econstructor; eauto. rewrite H4 in H; simpl in *. clear - H. destruct (UpdOrMeths_RegsT x0), (UpdOrMeths_RegsT x); eauto using DisjKey_nil_r, DisjKey_nil_l; simpl in *. specialize (H _ (or_introl _ eq_refl)); simpl in *; dest. repeat rewrite map_app in H. intro k. destruct (In_dec string_dec k (map fst (p0::r0))); auto. right; intro. destruct (NoDup_app_Disj string_dec _ _ H k); auto. apply H2; rewrite in_app_iff; right; auto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x; repeat split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x. repeat split; simpl; auto. econstructor; eauto. inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. - inv H; simpl in *; EqDep_subst. rewrite (unifyWO val_a) in HSemCompActionT_a. inv HSemCompActionT_a; EqDep_subst. destruct HRegMapWf, WfMap, regMap_a. inv H;[|discriminate]; EqDep_subst. specialize (SemRegExprVals H1 HSemRegMap) as P0; inv P0. assert (WfRegMapExpr (VarRegMap type (r0, (hd nil upds0 ++ (r, existT (fullType type) k (evalExpr e)) :: nil) :: tl upds0)) (r0, (hd nil upds0 ++ (r, existT (fullType type) k (evalExpr e)) :: nil) :: tl upds0)) as WfMap0. { split; auto. constructor. } specialize (IHea _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap0 _ _ _ HSemCompActionT_cont); dest; simpl in *; split; auto. exists ((UmUpd (r, existT (fullType type) k (evalExpr e))):: x); repeat split; auto. + simpl; destruct (UpdOrMeths_RegsT x); simpl in *; auto. rewrite <- app_assoc in H3. rewrite <-app_comm_cons in H3. simpl in H3; auto. + simpl; econstructor; eauto. * rewrite H3 in H. destruct (UpdOrMeths_RegsT x); simpl in *; rewrite HConsistent; eapply H; simpl; eauto; repeat rewrite map_app, in_app_iff; [right | left]; simpl; auto. * repeat intro. rewrite H3 in H. destruct (UpdOrMeths_RegsT x); simpl in *; auto. destruct H7; subst; simpl in *; specialize (H _ (or_introl eq_refl)); dest; repeat rewrite map_app, NoDup_app_iff in H; simpl in *; dest. -- apply (H7 r); clear. rewrite in_app_iff; simpl; right; left; reflexivity. left; reflexivity. -- apply (H8 r); clear - H7. ++ rewrite in_app_iff; right; left; reflexivity. ++ right; rewrite in_map_iff; exists (r, v); split; auto. - inv H0; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; EqDep_subst. remember (evalExpr e) as P0. apply Eqdep.EqdepTheory.inj_pair2 in H4. rewrite H4 in *. clear H4; simpl in *. rewrite HeqP0 in HSemCompActionT_a, HSemCompActionT_a0. destruct P0; rewrite <- HeqP0 in *; simpl in *. + assert (forall b, (evalExpr (Var type (SyntaxKind Bool) b) = (evalExpr (Const type b)))) as Q0; auto. specialize (SemCompActionEEquivBexpr _ _ _ _ _ (Q0 false) HSemCompActionT_a0) as Q1. specialize (SemCompActionEEquivBexpr _ _ _ _ _ (Q0 true) HSemCompActionT_a) as Q2. specialize (IHea1 _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ Q2); dest. assert (evalExpr (Const type false) = false) as Q3; auto. destruct (EpredFalse_UpdsNil _ _ _ _ Q3 (SemVarRegMap regMap_a) Q1). assert (WfRegMapExpr (VarRegMap type regMap_a0) regMap_a0) as P7. { unfold WfRegMapExpr; split; [constructor|]. subst; eauto. } rewrite <- H4 in P7 at 2. rewrite H1 in P7. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent P7 _ _ _ HSemCompActionT); dest. split; auto. exists (x ++ x0); rewrite UpdOrMeths_RegsT_app, UpdOrMeths_MethsT_app; repeat split; auto. * destruct (UpdOrMeths_RegsT x0); simpl; auto. -- rewrite app_nil_r; auto. -- destruct (UpdOrMeths_RegsT x); simpl in *; auto. rewrite app_comm_cons, app_assoc; assumption. * subst; reflexivity. * econstructor; eauto. rewrite H6 in H; destruct (UpdOrMeths_RegsT x), (UpdOrMeths_RegsT x0); intro; simpl in *; auto. clear - H. specialize (H _ (or_introl _ (eq_refl))); dest. rewrite map_app in H. destruct (NoDup_app_Disj string_dec _ _ H k0); auto. left; intro; apply H1. rewrite map_app, in_app_iff; auto. + assert (forall b, (evalExpr (Var type (SyntaxKind Bool) b) = (evalExpr (Const type b)))) as Q0; auto. remember WfMap as WfMap0. inv WfMap0. assert (evalExpr (Var type (SyntaxKind Bool) false) = false) as Q1; auto. destruct (EpredFalse_UpdsNil _ _ _ _ Q1 H0 HSemCompActionT_a). assert (WfRegMapExpr (VarRegMap type regMap_a) (old, upds)) as WfMap0. { rewrite <- H2. clear - WfMap. unfold WfRegMapExpr in *; dest; repeat split;[constructor| |]; eapply H0; eauto. } specialize (SemCompActionEEquivBexpr _ _ _ _ _ (Q0 true) HSemCompActionT_a0) as Q2. specialize (IHea2 _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap0 _ _ _ Q2); dest. assert (WfRegMapExpr (VarRegMap type regMap_a0) regMap_a0) as P7. { unfold WfRegMapExpr; split; [constructor|]. subst; eauto. } rewrite H5 in P7 at 2. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent P7 _ _ _ HSemCompActionT); dest. split; auto. exists (x ++ x0); rewrite UpdOrMeths_RegsT_app, UpdOrMeths_MethsT_app; repeat split; auto. * destruct (UpdOrMeths_RegsT x0); simpl; auto. -- rewrite app_nil_r; auto. -- destruct (UpdOrMeths_RegsT x); simpl in *; auto. rewrite app_comm_cons, app_assoc; assumption. * subst; reflexivity. * econstructor 8; eauto. rewrite H8 in H; destruct (UpdOrMeths_RegsT x), (UpdOrMeths_RegsT x0); intro; simpl in *; auto. clear - H. specialize (H _ (or_introl _ (eq_refl))); dest. rewrite map_app in H. destruct (NoDup_app_Disj string_dec _ _ H k0); auto. left; intro; apply H1. rewrite map_app, in_app_iff; auto. - inv H; EqDep_subst. specialize (IHea _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x. repeat split; auto. econstructor; eauto. - inv H; EqDep_subst. inv WfMap; inv HRegMapWf. specialize (SemRegExprVals H H1) as TMP; subst; simpl in *. split; auto. exists nil. repeat split; auto. constructor; auto. - inv H0; EqDep_subst. apply (SemCompActionEEquivWMap _ _ _ (SemVarRegMap _) HWriteMap) in HSemCompActionT. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest. split; auto. exists x. repeat split; auto. econstructor; eauto. inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. - inv H; EqDep_subst; destruct regMapVal; simpl in *. + unfold WfRegMapExpr in *; dest. inv H; EqDep_subst; [|discriminate]. specialize (SemRegExprVals H1 HSemRegMap) as TMP; inv TMP. assert (WfRegMapExpr (VarRegMap type (r, (hd [] upds0 ++ [(dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (IF ReadArrayConst mask0 i then newArr @[ idx + Const type (natToWord (Nat.log2_up idxNum) (proj1_sig (to_nat i))) <- ReadArrayConst val i] else newArr)%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regVal))))]) :: tl upds0)) (r, (hd [] upds0 ++ [(dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (IF ReadArrayConst mask0 i then newArr @[ idx + Const type (natToWord (Nat.log2_up idxNum)(proj1_sig (to_nat i))) <- ReadArrayConst val i] else newArr)%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regVal))))]) :: tl upds0)) as P0. { unfold WfRegMapExpr in *; dest; split; auto; constructor. } specialize (IHea _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent P0 _ _ _ HSemCompActionT); dest; split; auto. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (IF ReadArrayConst mask0 i then newArr @[ idx + Const type (natToWord (Nat.log2_up idxNum)(proj1_sig (to_nat i))) <- ReadArrayConst val i] else newArr)%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regVal))))::x). repeat split; auto. * simpl in *. clear - H3. destruct (UpdOrMeths_RegsT x); auto. rewrite <- app_assoc in H3; simpl in *; assumption. * econstructor; eauto. -- inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. -- rewrite H3 in H. clear - H. destruct (UpdOrMeths_RegsT x); repeat intro; auto. specialize (H _ (or_introl eq_refl)). simpl in H; repeat rewrite map_app in H; simpl in *. rewrite NoDup_app_iff in H; dest; apply (H3 dataArray); destruct H0; subst; simpl; auto. ++ rewrite in_app_iff; right; simpl; left; auto. ++ rewrite in_app_iff; right; simpl; left; auto. ++ right; rewrite in_map_iff; exists (dataArray, v); auto. + unfold WfRegMapExpr in *; dest. inv H; EqDep_subst; [|discriminate]. specialize (SemRegExprVals H1 HSemRegMap) as TMP; inv TMP. assert (WfRegMapExpr (VarRegMap type (r, (hd [] upds0 ++ [(dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (newArr @[ idx + Const type (natToWord (Nat.log2_up idxNum) (proj1_sig (to_nat i))) <- ReadArrayConst val i])%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regVal))))]) :: tl upds0)) (r, (hd [] upds0 ++ [(dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (newArr @[ idx + Const type (natToWord (Nat.log2_up idxNum)(proj1_sig (to_nat i))) <- ReadArrayConst val i])%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regVal))))]) :: tl upds0)) as P0. { unfold WfRegMapExpr in *; dest; split; auto; constructor. } specialize (IHea _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent P0 _ _ _ HSemCompActionT); dest; split; auto. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (newArr @[ idx + Const type (natToWord (Nat.log2_up idxNum)(proj1_sig (to_nat i))) <- ReadArrayConst val i])%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regVal))))::x). repeat split; auto. * simpl in *. clear - H3. destruct (UpdOrMeths_RegsT x); auto. rewrite <- app_assoc in H3; simpl in *; assumption. * econstructor 13; eauto. -- inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. -- rewrite H3 in H. clear - H. destruct (UpdOrMeths_RegsT x); repeat intro; auto. specialize (H _ (or_introl eq_refl)). simpl in H; repeat rewrite map_app in H; simpl in *. rewrite NoDup_app_iff in H; dest; apply (H3 dataArray); destruct H0; subst; simpl; auto. ++ rewrite in_app_iff; right; simpl; left; auto. ++ rewrite in_app_iff; right; simpl; left; auto. ++ right; rewrite in_map_iff; exists (dataArray, v); auto. - inv H; EqDep_subst. + unfold WfRegMapExpr in *; dest. inv H; EqDep_subst; [|discriminate]. specialize (SemRegExprVals H1 HSemRegMap) as TMP; inv TMP. assert (WfRegMapExpr (VarRegMap type (old0, (hd [] upds0 ++ [(readReg, existT (fullType type) (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr (Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx))))]) :: tl upds0)) (old0, (hd [] upds0 ++ [(readReg, existT (fullType type) (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr (Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx))))]) :: tl upds0)) as P0. { unfold WfRegMapExpr in *; dest; split; auto; constructor. } specialize (IHea _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent P0 _ _ _ HSemCompActionT); dest; split; auto. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr (Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx))))::x). repeat split; auto. * simpl in *. clear - H3. destruct (UpdOrMeths_RegsT x); auto. rewrite <- app_assoc in H3; simpl in *; assumption. * econstructor; eauto. -- rewrite H3 in H. rewrite HConsistent. clear - H. simpl in *. destruct (UpdOrMeths_RegsT x); simpl in *; specialize (H _ (or_introl eq_refl)); dest; apply H0; repeat rewrite map_app, in_app_iff; [right| left; right]; left; auto. -- rewrite H3 in H. clear - H. simpl in *. destruct (UpdOrMeths_RegsT x); simpl in *; specialize (H _ (or_introl eq_refl)); dest; repeat intro; auto. repeat rewrite map_app in H; simpl in *. rewrite NoDup_app_iff in H; dest. apply (H3 readReg); destruct H1; subst; simpl; auto. ++ rewrite in_app_iff; right; simpl; left; auto. ++ rewrite in_app_iff; right; simpl; left; auto. ++ right; rewrite in_map_iff; exists (readReg, v); auto. + unfold WfRegMapExpr in *; dest. inv H; EqDep_subst; [|discriminate]. specialize (SemRegExprVals H1 HSemRegMap) as TMP; inv TMP. assert (WfRegMapExpr (VarRegMap type (old0, (hd [] upds0 ++ [(readReg, existT (fullType type) (SyntaxKind (Array num Data)) (evalExpr (BuildArray (fun i : Fin.t num => (Var type (SyntaxKind (Array idxNum Data)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx) + Const type (natToWord (Nat.log2_up idxNum)(proj1_sig (to_nat i)))])%kami_expr))))]) :: tl upds0)) (old0, (hd [] upds0 ++ [(readReg, existT (fullType type) (SyntaxKind (Array num Data)) (evalExpr (BuildArray (fun i : Fin.t num => (Var type (SyntaxKind (Array idxNum Data)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx) + Const type (natToWord (Nat.log2_up idxNum) (proj1_sig (to_nat i)))])%kami_expr))))]) :: tl upds0)) as P0. { unfold WfRegMapExpr in *; dest; split; auto; constructor. } specialize (IHea _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent P0 _ _ _ HSemCompActionT); dest; split; auto. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Array num Data)) (evalExpr (BuildArray (fun i : Fin.t num => (Var type (SyntaxKind (Array idxNum Data)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx) + Const type (natToWord (Nat.log2_up idxNum) (proj1_sig (to_nat i)))])%kami_expr))))::x). repeat split; auto. * simpl in *. clear - H3. destruct (UpdOrMeths_RegsT x); auto. rewrite <- app_assoc in H3; simpl in *; assumption. * econstructor 15; eauto. -- rewrite H3 in H. rewrite HConsistent. clear - H. simpl in *. destruct (UpdOrMeths_RegsT x); simpl in *; specialize (H _ (or_introl eq_refl)); dest; apply H0; repeat rewrite map_app, in_app_iff; [right| left; right]; left; auto. -- inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. -- rewrite H3 in H. clear - H. simpl in *. destruct (UpdOrMeths_RegsT x); simpl in *; specialize (H _ (or_introl eq_refl)); dest; repeat intro; auto. repeat rewrite map_app in H; simpl in *. rewrite NoDup_app_iff in H; dest. apply (H3 readReg); destruct H1; subst; simpl; auto. ++ rewrite in_app_iff; right; simpl; left; auto. ++ rewrite in_app_iff; right; simpl; left; auto. ++ right; rewrite in_map_iff; exists (readReg, v); auto. - inv H0; EqDep_subst. + apply (SemCompActionEEquivWMap _ _ _ (SemVarRegMap _) HWriteMap) in HSemCompActionT. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest. split; auto. exists x. repeat split; auto. econstructor; eauto. * inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. * inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. + apply (SemCompActionEEquivWMap _ _ _ (SemVarRegMap _) HWriteMap) in HSemCompActionT. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest. split; auto. exists x. repeat split; auto. econstructor 17; eauto. * inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. Qed. Lemma ESemAction_NoDup_Upds k (ea : EActionT type k) : forall o uml retl, ESemAction o ea uml retl -> NoDup (map fst (UpdOrMeths_RegsT uml)). Proof. induction ea; intros. - inv H0; EqDep_subst; simpl; eauto. - inv H0; EqDep_subst; simpl; eauto. - inv H0; EqDep_subst; simpl; eauto. rewrite UpdOrMeths_RegsT_app, map_app, NoDup_app_iff; repeat split; repeat intro; eauto. + specialize (HDisjRegs a); firstorder fail. + specialize (HDisjRegs a); firstorder fail. - inv H0; EqDep_subst; simpl; eauto. - inv H0; EqDep_subst; simpl; eauto. - inv H; EqDep_subst; simpl. constructor; eauto. intro; rewrite in_map_iff in H; dest; destruct x; subst; simpl in *. eapply HDisjRegs; eauto. - inv H0; EqDep_subst; rewrite UpdOrMeths_RegsT_app, map_app, NoDup_app_iff; repeat split; repeat intro; eauto; specialize (HDisjRegs a); tauto. - inv H; EqDep_subst; simpl; eauto. - inv H; EqDep_subst; simpl; constructor. - inv H0; EqDep_subst; simpl; eauto. - inv H; EqDep_subst; simpl; constructor; eauto; intro; rewrite in_map_iff in H; dest; destruct x; subst; simpl in *; eapply HDisjRegs; eauto. - inv H; EqDep_subst; simpl; constructor; eauto; intro; rewrite in_map_iff in H; dest; destruct x; subst; simpl in *; eapply HDisjRegs; eauto. - inv H0; EqDep_subst; eauto. Qed. Lemma ESemAction_SubList_Upds k (ea : EActionT type k) : forall o uml retl, ESemAction o ea uml retl -> SubList (getKindAttr (UpdOrMeths_RegsT uml)) (getKindAttr o). Proof. induction ea; intros. - inv H0; EqDep_subst; simpl; eauto. - inv H0; EqDep_subst; simpl; eauto. - inv H0; EqDep_subst; simpl; eauto. rewrite UpdOrMeths_RegsT_app, map_app, SubList_app_l_iff; split; eauto. - inv H0; EqDep_subst; simpl; eauto. - inv H0; EqDep_subst; simpl; eauto. - inv H; EqDep_subst; simpl. repeat intro; inv H; auto. eapply IHea; eauto. - inv H0; EqDep_subst; simpl; eauto; rewrite UpdOrMeths_RegsT_app, map_app, SubList_app_l_iff; split; eauto. - inv H; EqDep_subst; simpl; eauto. - inv H; EqDep_subst; simpl; repeat intro; contradiction. - inv H0; EqDep_subst; simpl; eauto. - inv H; EqDep_subst; simpl; eauto; repeat intro; inv H. + rewrite in_map_iff; exists (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) regV); split; auto. + eapply IHea; eauto. + rewrite in_map_iff; exists (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) regV); split; auto. + eapply IHea; eauto. - inv H; EqDep_subst; simpl; eauto; repeat intro; inv H; auto; eapply IHea; eauto. - inv H0; EqDep_subst; eauto. Qed. Lemma Extension_Compiles1 {k : Kind} (a : ActionT type k) : forall o calls retl expr v' bexpr, SemCompActionT (compileAction o a bexpr expr) v' calls retl -> SemCompActionT (EcompileAction o (Action_EAction a) bexpr expr) v' calls retl. Proof. induction a; simpl; intros; auto. - inv H0; EqDep_subst; [econstructor| econstructor 2]; eauto. - inv H0; EqDep_subst; econstructor; auto. - inv H0; EqDep_subst; econstructor; eauto. - inv H0; EqDep_subst; econstructor; eauto. - inv H0; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; simpl in *; EqDep_subst. repeat econstructor; eauto. - inv H; EqDep_subst; econstructor; eauto. Qed. Lemma Extension_Compiles2 {k : Kind} (a : ActionT type k) : forall o calls retl expr v' bexpr, SemCompActionT (EcompileAction o (Action_EAction a) bexpr expr) v' calls retl -> SemCompActionT (compileAction o a bexpr expr) v' calls retl. Proof. induction a; simpl; intros; auto. - inv H0; EqDep_subst; [econstructor| econstructor 2]; eauto. - inv H0; EqDep_subst; econstructor; auto. - inv H0; EqDep_subst; econstructor; eauto. - inv H0; EqDep_subst; econstructor; eauto. - inv H0; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; simpl in *; EqDep_subst. repeat econstructor; eauto. - inv H; EqDep_subst; econstructor; eauto. Qed. Corollary Extension_Compiles_iff {k : Kind} (a : ActionT type k) : forall o calls retl expr v' bexpr, SemCompActionT (EcompileAction o (Action_EAction a) bexpr expr) v' calls retl <-> SemCompActionT (compileAction o a bexpr expr) v' calls retl. Proof. split; intro; eauto using Extension_Compiles1, Extension_Compiles2. Qed. Lemma FalseSemCompAction_Ext k (a : ActionT type k) : forall writeMap o old upds oInit uInit (bexpr : Bool @# type) m (HPriorityUpds : PriorityUpds oInit uInit o) (HConsistent : getKindAttr o = getKindAttr old) (WfMap : WfRegMapExpr writeMap (old, upds)) (HRegConsist : getKindAttr o = getKindAttr (getRegisters m)) (HWf : WfActionT (getRegisters m) a) (HFalse : evalExpr bexpr = false), exists retl, @SemCompActionT k (compileAction (oInit, uInit) a bexpr writeMap) (old, upds) nil retl. Proof. induction a; simpl in *; intros. - inv HWf; EqDep_subst. specialize (H _ _ _ _ _ _ _ _ _ HPriorityUpds HConsistent WfMap HRegConsist (H2 (evalConstT (getDefaultConst (snd s)))) HFalse); dest. exists x. econstructor 2; eauto. - inv HWf; EqDep_subst. specialize (H _ _ _ _ _ _ _ _ _ HPriorityUpds HConsistent WfMap HRegConsist (H2 (evalExpr e)) HFalse); dest. exists x. econstructor; eauto. - inv HWf; EqDep_subst. specialize (IHa _ _ _ _ _ _ _ _ HPriorityUpds HConsistent WfMap HRegConsist H3 HFalse); dest. assert (WfRegMapExpr (VarRegMap type (old, upds)) (old, upds)) as P0. { unfold WfRegMapExpr in *; dest; split; auto. constructor. } specialize (H _ _ _ _ _ _ _ _ _ HPriorityUpds HConsistent P0 HRegConsist (H5 x) HFalse); dest. exists x0. econstructor; eauto. reflexivity. - inv HWf; EqDep_subst. specialize (H _ _ _ _ _ _ _ _ _ HPriorityUpds HConsistent WfMap HRegConsist (H2 (evalConstFullT (getDefaultConstFullKind k))) HFalse); dest. exists x. econstructor; eauto. - inv HWf; EqDep_subst. change (fun x0 : FullKind => RegInitValT x0) with RegInitValT in H5. rewrite <- HRegConsist in H5. rewrite in_map_iff in H5; dest; inv H0. destruct x, s0; simpl in *. specialize (H _ _ _ _ _ _ _ _ _ HPriorityUpds HConsistent WfMap HRegConsist (H3 f) HFalse); dest. exists x0. econstructor; eauto. constructor. - inv HWf; EqDep_subst. assert (WfRegMapExpr (VarRegMap type (old, upds)) (old, upds)) as P0. { unfold WfRegMapExpr in *; dest; split; auto; constructor. } specialize (IHa _ _ _ _ _ _ _ _ HPriorityUpds HConsistent P0 HRegConsist H2 HFalse); dest. exists x. econstructor; eauto. + econstructor; eauto. unfold WfRegMapExpr in *; dest; split; auto. * econstructor 3; auto. + reflexivity. - inv HWf; EqDep_subst. remember (evalExpr e) as e_val. assert (WfRegMapExpr (VarRegMap type (old, upds)) (old, upds)) as P0. { unfold WfRegMapExpr in *; dest; split; auto; constructor. } assert (evalExpr (bexpr && e)%kami_expr = false) as P1. { simpl; rewrite HFalse, andb_false_l; reflexivity. } assert (evalExpr (bexpr && !e)%kami_expr = false) as P2. { simpl; rewrite HFalse, andb_false_l; reflexivity. } specialize (IHa1 _ _ _ _ _ _ _ _ HPriorityUpds HConsistent WfMap HRegConsist H7 P1); dest. specialize (IHa2 _ _ _ _ _ _ _ _ HPriorityUpds HConsistent P0 HRegConsist H8 P2); dest. destruct e_val. + specialize (H _ _ _ _ _ _ _ _ _ HPriorityUpds HConsistent P0 HRegConsist (H4 x) HFalse); dest. exists x1. do 2 econstructor; eauto. econstructor; eauto using SemCompActionEquivBexpr; [reflexivity|]. econstructor; eauto using SemCompActionEquivBexpr; [reflexivity|]. econstructor; simpl; rewrite <- Heqe_val. assumption. + specialize (H _ _ _ _ _ _ _ _ _ HPriorityUpds HConsistent P0 HRegConsist (H4 x0) HFalse); dest. exists x1. do 2 econstructor; eauto. econstructor; eauto using SemCompActionEquivBexpr; [reflexivity|]. econstructor; eauto using SemCompActionEquivBexpr; [reflexivity|]. econstructor; simpl; rewrite <- Heqe_val. assumption. - inv HWf; EqDep_subst. specialize (IHa _ _ _ _ _ _ _ _ HPriorityUpds HConsistent WfMap HRegConsist H1 HFalse); dest. exists x. econstructor; eauto. - inv HWf; EqDep_subst. exists (evalExpr e). econstructor; eauto. Qed. Lemma ActionsEEquivWeak k a: forall writeMap o old upds oInit uInit m (HoInitNoDups : NoDup (map fst oInit)) (HuInitNoDups : forall u, In u uInit -> NoDup (map fst u)) (HPriorityUpds : PriorityUpds oInit uInit o) (HConsistent : getKindAttr o = getKindAttr old) (WfMap : WfRegMapExpr writeMap (old, upds)) (HRegConsist : getKindAttr o = getKindAttr (getRegisters m)) (HWf : WfActionT (getRegisters m) a), forall uml retl upds' calls, upds' = (old, match (UpdOrMeths_RegsT uml) with |nil => upds |_ :: _ => (hd nil upds ++ (UpdOrMeths_RegsT uml)) :: tl upds end) -> calls = (UpdOrMeths_MethsT uml) -> DisjKey (hd nil upds) (UpdOrMeths_RegsT uml) -> ESemAction o (Action_EAction a) uml retl -> @SemCompActionT k (EcompileAction (oInit, uInit) (Action_EAction a) (Const type true) writeMap) upds' calls retl. Proof. induction a; intros; subst; simpl in *. - inv H3; inv HWf; EqDep_subst; simpl. econstructor; eauto. - inv H3; inv HWf; EqDep_subst; simpl. econstructor; eauto. - specialize (ESemAction_NoDup_Upds H3) as P0; specialize (ESemAction_SubList_Upds H3) as P1. inv H3; inv HWf; EqDep_subst; rewrite UpdOrMeths_RegsT_app, UpdOrMeths_MethsT_app. econstructor; eauto. eapply IHa; eauto. + intro k0; specialize (H2 k0). rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff in H2. destruct H2; auto. + eapply H; eauto. * unfold WfRegMapExpr; repeat split; [constructor| |]; unfold WfRegMapExpr in *; dest; rewrite UpdOrMeths_RegsT_app in *; destruct (UpdOrMeths_RegsT newUml); simpl in *. -- apply (H3 _ H0). -- destruct H0; subst; [rewrite map_app|]; simpl. ++ rewrite NoDup_app_iff; repeat split; repeat intro; auto. ** destruct upds; [constructor| simpl; apply (H3 _ (or_introl eq_refl))]. ** rewrite map_app in P0; inv P0. rewrite in_app_iff in H6. rewrite NoDup_app_iff in H7; dest. constructor; [firstorder fail|]; auto. ** specialize (H2 a1); simpl in *; rewrite map_app, in_app_iff in H2. clear - H2 H0 H5. firstorder fail. ** specialize (H2 a1); simpl in *; rewrite map_app, in_app_iff in H2. clear - H2 H0 H5. firstorder fail. ++ apply H3; clear - H0; destruct upds; simpl in *; auto. -- apply (H3 _ H0). -- destruct H0; subst; [rewrite map_app|]; simpl. ++ rewrite SubList_app_l_iff; split; repeat intro. ** destruct upds; simpl in *; [contradiction| apply (H3 _ (or_introl eq_refl)); assumption]. ** rewrite HConsistent in P1; apply P1; simpl in *. rewrite map_app, in_app_iff. clear - H0; firstorder fail. ++ eapply H3; destruct upds; simpl in *; eauto. * clear. destruct (UpdOrMeths_RegsT newUml); simpl; auto. destruct (UpdOrMeths_RegsT newUmlCont); simpl; [rewrite app_nil_r| rewrite <-app_assoc]; auto. * destruct (UpdOrMeths_RegsT newUml); simpl; auto. -- intro k0; specialize (H2 k0). rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff in H2. clear - H2; firstorder fail. -- intro k0; specialize (H2 k0); specialize (HDisjRegs k0). clear - H2 HDisjRegs. rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff in *; firstorder fail. - inv H3; inv HWf; EqDep_subst; econstructor; eauto. - inv H3; inv HWf; EqDep_subst; econstructor; eauto. constructor. - inv H2; inv HWf; EqDep_subst. unfold WfRegMapExpr in *; dest. econstructor; eauto. + econstructor; eauto. unfold WfRegMapExpr; split; eauto. * econstructor; eauto. * simpl; intros. destruct H2; subst; split. -- rewrite map_app, NoDup_app_iff; repeat split; repeat intro; auto. ++ destruct upds; simpl; [constructor| apply (H0 _ (or_introl eq_refl))]. ++ simpl; constructor; [intro; contradiction| constructor]. ++ destruct H4; auto; subst. specialize (H1 r); simpl in *. clear - H1 H2; firstorder fail. ++ destruct H2; auto; subst. specialize (H1 r); simpl in *. clear - H1 H4; firstorder fail. -- rewrite map_app, SubList_app_l_iff; split; simpl. ++ repeat intro. destruct upds; [contradiction| apply (H0 _ (or_introl eq_refl))]; auto. ++ repeat intro; destruct H2;[subst |contradiction]. rewrite HConsistent in HRegVal; assumption. -- destruct upds; [contradiction| apply (H0 _ (or_intror H2))]. -- destruct upds; [contradiction| apply (H0 _ (or_intror H2))]. + reflexivity. + simpl; eapply IHa; eauto. * split; [constructor| intros]; split. -- inv H2; simpl in *; [rewrite map_app, NoDup_app_iff; repeat split; repeat intro|]. ++ destruct upds; [constructor| simpl; apply (H0 _ (or_introl eq_refl))]. ++ simpl; repeat constructor; auto. ++ specialize (H1 a0); clear - H1 H2 H4; firstorder fail. ++ specialize (H1 a0); clear - H1 H2 H4; firstorder fail. ++ destruct upds; [inv H4| apply (H0 _ (or_intror _ H4))]. -- inv H2; repeat intro; simpl in *. ++ rewrite map_app, in_app_iff in H2; simpl in H2. destruct H2; [ destruct upds; [contradiction|]| destruct H2; [|contradiction]]; subst. ** apply (H0 _ (or_introl _ (eq_refl))); assumption. ** rewrite HConsistent in HRegVal; assumption. ++ destruct upds; [contradiction| apply (H0 _ (or_intror _ H4)); assumption]. * simpl; destruct (UpdOrMeths_RegsT newUml); auto. rewrite <-app_assoc; reflexivity. * intro k0; simpl; rewrite map_app, in_app_iff. specialize (H1 k0); simpl in *. clear - H1 HDisjRegs. destruct H1; auto. destruct (string_dec r k0); subst. -- right; intro. rewrite in_map_iff in H0; dest; destruct x; subst; simpl in *. apply (HDisjRegs s0); assumption. -- left; intro; firstorder fail. - inv H3; inv HWf; EqDep_subst; do 2 econstructor;[econstructor|]. + assert (evalExpr (Const type true) = evalExpr (Var type (SyntaxKind Bool) (evalExpr (Const type true && e)%kami_expr))) as P0; auto. eapply SemCompActionEEquivBexpr; eauto. eapply IHa1 with (old := old) (o := o); auto. * apply WfMap. * apply HRegConsist. * assumption. * instantiate (1 := newUml1). intro; specialize (H2 k0); clear - H2; rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff in H2; firstorder fail. * apply HEAction. + rewrite UpdOrMeths_MethsT_app; reflexivity. + assert (evalExpr (Const type true && !e)%kami_expr = false) as P0. { simpl; rewrite HTrue; reflexivity. } assert (WfRegMapExpr (VarRegMap type (old, match UpdOrMeths_RegsT newUml1 with | [] => upds | _ :: _ => (hd [] upds ++ UpdOrMeths_RegsT newUml1) :: tl upds end)) (old, match UpdOrMeths_RegsT newUml1 with | [] => upds | _ :: _ => (hd [] upds ++ UpdOrMeths_RegsT newUml1) :: tl upds end)) as P1. { unfold WfRegMapExpr in *; dest; split; auto; [constructor|]. intros; split. - specialize (ESemAction_NoDup_Upds HEAction) as P1. rewrite UpdOrMeths_RegsT_app in H2. destruct (UpdOrMeths_RegsT newUml1). + apply H1; auto. + inv H3; [| destruct upds; [contradiction| apply H1; right; assumption]]. rewrite map_app, NoDup_app_iff; repeat split; auto. * destruct upds;[constructor| apply H1; left; reflexivity]. * repeat intro; specialize (H2 a); rewrite map_app, in_app_iff in H2;clear - H2 H3 H4; firstorder fail. * repeat intro; specialize (H2 a); rewrite map_app, in_app_iff in H2;clear - H2 H3 H4; firstorder fail. - specialize (ESemAction_SubList_Upds HEAction) as P1. destruct (UpdOrMeths_RegsT newUml1). + apply H1; auto. + inv H3; [|destruct upds; [contradiction| apply H1; right; assumption]]. repeat intro; rewrite map_app, in_app_iff in *; inv H3;[| rewrite HConsistent in *; auto]. destruct upds; [contradiction|]. apply (H1 r0 (in_eq _ _)); assumption. } specialize (FalseSemCompAction_Ext _ _ HPriorityUpds HConsistent P1 HRegConsist H13 P0) as P2; dest. rewrite <- Extension_Compiles_iff in H0. econstructor. * eapply SemCompActionEEquivBexpr with (bexpr1 := (Const type true && ! e)%kami_expr); eauto. * reflexivity. * rewrite UpdOrMeths_RegsT_app. econstructor; simpl; rewrite HTrue. eapply H; eauto. -- destruct (UpdOrMeths_RegsT newUml1); simpl; auto. destruct (UpdOrMeths_RegsT newUml2); [rewrite app_nil_r | rewrite app_comm_cons, app_assoc]; simpl; auto. -- rewrite UpdOrMeths_RegsT_app in *. destruct (UpdOrMeths_RegsT newUml1); simpl in *; auto. clear - H2 HDisjRegs. intro k; specialize (H2 k); specialize (HDisjRegs k); simpl in *; rewrite map_app, in_app_iff in *. firstorder fail. + assert (evalExpr (Const type true && e)%kami_expr = false) as P0. { simpl; rewrite HFalse; reflexivity. } specialize (FalseSemCompAction_Ext _ _ HPriorityUpds HConsistent WfMap HRegConsist H12 P0) as P2; dest. rewrite <- Extension_Compiles_iff in H0. econstructor 8; eauto. * eapply SemCompActionEEquivBexpr with (bexpr1 := (Const type true && e)%kami_expr); eauto. * reflexivity. * rewrite UpdOrMeths_RegsT_app, UpdOrMeths_MethsT_app. assert (WfRegMapExpr (VarRegMap type (old, upds)) (old, upds)) as P1. { unfold WfRegMapExpr in *; dest; split; auto; constructor. } econstructor; simpl. -- assert (evalExpr (Const type true) = evalExpr (Var type (SyntaxKind Bool) (negb (evalExpr e)))) as P2. { simpl; rewrite HFalse; auto. } apply (SemCompActionEEquivBexpr _ _ _ _ _ P2). eapply IHa2 with (o := o) (old := old) (upds := upds) (uml := newUml1); eauto. clear - H2; intro k; specialize (H2 k); rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff in H2. firstorder fail. -- reflexivity. -- econstructor; simpl; rewrite HFalse. eapply H with (upds := match UpdOrMeths_RegsT newUml1 with | [] => upds | _ :: _ => (hd [] upds ++ UpdOrMeths_RegsT newUml1) :: tl upds end); eauto. ++ rewrite UpdOrMeths_RegsT_app in *. specialize (ESemAction_NoDup_Upds HEAction) as P3. specialize (ESemAction_SubList_Upds HEAction) as P4. unfold WfRegMapExpr in *; dest; split; [constructor| intros; split]. ** destruct (UpdOrMeths_RegsT newUml1);[apply H6; assumption| inv H7; [| apply H6; destruct upds;[contradiction| right; assumption]]]. rewrite map_app, NoDup_app_iff; repeat split; repeat intro; auto. --- destruct upds; [constructor| apply H6; left; reflexivity]. --- clear - H2 H7 H8; specialize (H2 a); rewrite map_app, in_app_iff in H2. firstorder fail. --- clear - H2 H7 H8; specialize (H2 a); rewrite map_app, in_app_iff in H2. firstorder fail. ** destruct (UpdOrMeths_RegsT newUml1);[apply H6; assumption| inv H7; [| apply H6; destruct upds;[contradiction| right; assumption]]]. rewrite HConsistent in P4. repeat intro; rewrite map_app, in_app_iff in H7; inv H7. --- destruct upds; [contradiction|]. apply (H6 r0 (in_eq _ _)); assumption. --- apply P4; assumption. ++ rewrite UpdOrMeths_RegsT_app in *. destruct (UpdOrMeths_RegsT newUml1); simpl in *; auto. destruct (UpdOrMeths_RegsT newUml2); simpl in *; [rewrite app_nil_r| rewrite <-app_assoc, app_comm_cons; simpl];auto. ++ rewrite UpdOrMeths_RegsT_app in *. destruct (UpdOrMeths_RegsT newUml1); simpl in *; auto. clear - H2 HDisjRegs. intro k; specialize (H2 k); specialize (HDisjRegs k); simpl in *; rewrite map_app, in_app_iff in *. firstorder fail. - inv H2; inv HWf; EqDep_subst; econstructor; eauto. - inv H2; inv HWf; EqDep_subst; econstructor; eauto. Qed. Corollary ECompCongruence k (ea : EActionT type k) (a : ActionT type k) : forall writeMap o old upds oInit uInit m (HoInitNoDups : NoDup (map fst oInit)) (HuInitNoDups : forall u, In u uInit -> NoDup (map fst u)) (HPriorityUpds : PriorityUpds oInit uInit o) (HConsistent : getKindAttr o = getKindAttr old) (WfMap : WfRegMapExpr writeMap (old, upds)) (HRegConsist : getKindAttr o = getKindAttr (getRegisters m)) (HWf : WfActionT (getRegisters m) a), (forall uml retl, ESemAction o ea uml retl -> ESemAction o (Action_EAction a) uml retl) -> forall upds' calls retl, @SemCompActionT k (EcompileAction (oInit, uInit) ea (Const type true) writeMap) upds' calls retl -> @SemCompActionT k (EcompileAction (oInit, uInit) (Action_EAction a) (Const type true) writeMap) upds' calls retl. Proof. intros. apply (EEquivActions _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap) in H0; dest. specialize (H _ _ H3). eapply ActionsEEquivWeak; eauto. rewrite H1 in H0; simpl in *. destruct (UpdOrMeths_RegsT x); [intro; right; intro; contradiction|]. specialize (H0 _ (or_introl eq_refl)); dest; rewrite map_app, NoDup_app_iff in H0; dest. intro; specialize (H6 k0); specialize (H7 k0). destruct (in_dec string_dec k0 (map fst (hd [] upds))); auto. Qed. Lemma EquivActions k a: forall writeMap o old upds oInit uInit (HoInitNoDups : NoDup (map fst oInit)) (HuInitNoDups : forall u, In u uInit -> NoDup (map fst u)) (HPriorityUpds : PriorityUpds oInit uInit o) (HConsistent : getKindAttr o = getKindAttr old) (WfMap : WfRegMapExpr writeMap (old, upds)), forall calls retl upds', @SemCompActionT k (compileAction (oInit, uInit) a (Const type true) writeMap) upds' calls retl -> (forall u, In u (snd upds') -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old)) /\ exists newRegs readRegs, upds' = (old, match newRegs with |nil => upds |_ :: _ => (hd nil upds ++ newRegs) :: tl upds end) /\ SemAction o a readRegs newRegs calls retl. Proof. induction a; subst; intros; simpl in *. - inv H0; EqDep_subst;[|discriminate]. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x, x0; split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x, x0; split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (IHa _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT_a); dest. assert (WfRegMapExpr (VarRegMap type regMap_a) regMap_a) as WfMap0. { unfold WfRegMapExpr; split;[econstructor|]. destruct regMap_a; inv H1; intros. apply (H0 _ H1). } rewrite H1 in *. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap0 _ _ _ HSemCompActionT_cont); dest. split; auto. exists (x++x1), (x0++x2); split. + destruct x1; simpl in *; auto. * rewrite app_nil_r; assumption. * destruct x; simpl in *; auto. rewrite app_comm_cons, app_assoc; assumption. + econstructor; eauto. rewrite H3 in H; simpl in *. clear - H. destruct x, x1; eauto using DisjKey_nil_r, DisjKey_nil_l; simpl in *. specialize (H _ (or_introl _ eq_refl)); simpl in *; dest. repeat rewrite map_app in H. intro k. destruct (In_dec string_dec k (map fst (p0::x1))); auto. left; intro. destruct (NoDup_app_Disj string_dec _ _ H k); auto. apply H2; rewrite in_app_iff; right; auto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x, x0; split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x, ((r, existT _ k regVal) :: x0). split; auto. econstructor; eauto. inv HReadMap. apply (PriorityUpds_Equiv HoInitNoDups HuInitNoDups HUpdatedRegs HPriorityUpds); auto. - inv H; simpl in *; EqDep_subst. rewrite (unifyWO val_a) in HSemCompActionT_a. inv HSemCompActionT_a; EqDep_subst. destruct HRegMapWf, WfMap, regMap_a. inv H;[|discriminate]; EqDep_subst. specialize (SemRegExprVals H1 HSemRegMap) as P0; inv P0. assert (WfRegMapExpr (VarRegMap type (r0, (hd nil upds0 ++ (r, existT (fullType type) k (evalExpr e)) :: nil) :: tl upds0)) (r0, (hd nil upds0 ++ (r, existT (fullType type) k (evalExpr e)) :: nil) :: tl upds0)) as WfMap0. { split; auto. constructor. } specialize (IHa _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap0 _ _ _ HSemCompActionT_cont); dest; simpl in *; split; auto. exists ((r, existT (fullType type) k (evalExpr e)) :: nil ++ x), x0; split. + destruct x; simpl in *; auto. rewrite <- app_assoc in H3. rewrite <-app_comm_cons in H3. simpl in H3; auto. + rewrite H3 in H; simpl in *; destruct x; econstructor; eauto; simpl in *; specialize (H _ (or_introl _ eq_refl)); dest. * rewrite map_app, <-HConsistent in H6; simpl in *. apply (H6 (r, k)). rewrite in_app_iff; right; left; reflexivity. * repeat intro; inv H7. * rewrite map_app, <-HConsistent in H6; simpl in *. apply (H6 (r, k)). rewrite map_app; repeat rewrite in_app_iff; simpl; auto. * repeat intro. repeat rewrite map_app in H; simpl in *. destruct H7; subst; destruct (NoDup_app_Disj string_dec _ _ H r) as [P0|P0]; apply P0. -- rewrite in_app_iff; simpl; auto. -- simpl; auto. -- rewrite in_app_iff; simpl; auto. -- simpl; right; rewrite in_map_iff. exists (r, v); simpl; auto. - inv H0; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; EqDep_subst. remember (evalExpr e) as P0. apply Eqdep.EqdepTheory.inj_pair2 in H4. rewrite H4 in *. clear H4; simpl in *. destruct P0; rewrite <- HeqP0 in *; simpl in *. + assert (evalExpr (Var type (SyntaxKind Bool) true) = evalExpr (Const type true)) as P4; auto. assert (evalExpr (Var type (SyntaxKind Bool) false) = false) as P5; auto. specialize (SemCompActionEquivBexpr _ _ _ _ _ P4 HSemCompActionT_a) as P6. specialize (IHa1 _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ P6); dest. destruct (predFalse_UpdsNil _ _ _ _ P5 (SemVarRegMap regMap_a) HSemCompActionT_a0). assert (WfRegMapExpr (VarRegMap type regMap_a0) regMap_a0) as P7. { unfold WfRegMapExpr; split; [constructor|]. subst; eauto. } rewrite <- H3 in P7 at 2. rewrite H1 in P7. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent P7 _ _ _ HSemCompActionT); dest. split; auto. exists (x++x1), (x0++x2). destruct x; simpl; split; auto. * rewrite H4. econstructor; eauto. apply DisjKey_nil_l. * destruct x1; [rewrite app_nil_r|]; simpl in *; auto. rewrite <-app_assoc, <-app_comm_cons in H5; assumption. * rewrite H4; simpl. econstructor; eauto. rewrite H5 in H; simpl in *. clear - H. destruct x1; simpl in *; [apply DisjKey_nil_r|]. specialize (H _ (or_introl _ (eq_refl))); dest. rewrite map_app in H. intro. destruct (NoDup_app_Disj string_dec _ _ H k); auto. left; intro; apply H1. rewrite map_app, in_app_iff; auto. + assert (evalExpr (Var type (SyntaxKind Bool) true) = evalExpr (Const type true)) as P4; auto. assert (evalExpr (Var type (SyntaxKind Bool) false) = false) as P5; auto. specialize (SemCompActionEquivBexpr _ _ _ _ _ P4 HSemCompActionT_a0) as P6. remember WfMap as WfMap0. inv WfMap0. destruct (predFalse_UpdsNil _ _ _ _ P5 H0 HSemCompActionT_a). assert (WfRegMapExpr (VarRegMap type regMap_a) (old, upds)) as WfMap0. { rewrite <- H2. clear - WfMap. unfold WfRegMapExpr in *; dest; repeat split;[constructor| |]; eapply H0; eauto. } specialize (IHa2 _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap0 _ _ _ P6); dest. assert (WfRegMapExpr (VarRegMap type regMap_a0) regMap_a0) as P7. { unfold WfRegMapExpr; split; [constructor|]. subst; eauto. } rewrite H5 in P7 at 2. specialize (H _ _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent P7 _ _ _ HSemCompActionT); dest. split; auto. exists (x++x1), (x0++x2). destruct x; simpl; split; auto. * rewrite H3; simpl. econstructor 8; eauto. apply DisjKey_nil_l. * destruct x1;[rewrite app_nil_r|]; simpl in *; auto. rewrite <-app_assoc, <-app_comm_cons in H7; assumption. * rewrite H3; simpl. econstructor 8; eauto. rewrite H7 in H; simpl in *. clear - H. destruct x1; simpl in *; [apply DisjKey_nil_r|]. specialize (H _ (or_introl _ (eq_refl))); dest. rewrite map_app in H. intro. destruct (NoDup_app_Disj string_dec _ _ H k); auto. left; intro; apply H1. rewrite map_app, in_app_iff; auto. - inv H; EqDep_subst. specialize (IHa _ _ _ _ _ _ HoInitNoDups HuInitNoDups HPriorityUpds HConsistent WfMap _ _ _ HSemCompActionT); dest; split; auto. exists x, x0. split; auto. econstructor; eauto. - inv H; EqDep_subst. inv WfMap; inv HRegMapWf. specialize (SemRegExprVals H H1) as TMP; subst; simpl in *. split; auto. exists nil, nil. split; auto. constructor; auto. Qed. Lemma SameOldAction (k : Kind) (a : ActionT type k) : forall oInit uInit writeMap old upds wOld wUpds calls retl bexpr (HSemRegMap : SemRegMapExpr writeMap (wOld, wUpds)), @SemCompActionT k (compileAction (oInit, uInit) a bexpr writeMap) (old, upds) calls retl -> wOld = old. Proof. induction a; intros; simpl in *. - inv H0; EqDep_subst; simpl in *; eapply H; eauto. - inv H0; EqDep_subst; simpl in *. eapply H; eauto. - inv H0; EqDep_subst; simpl in *. destruct regMap_a. specialize (H _ _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont); subst. specialize (IHa _ _ _ _ _ _ _ _ _ _ HSemRegMap HSemCompActionT_a); assumption. - inv H0; EqDep_subst; simpl in *. eapply H; eauto. - inv H0; EqDep_subst; simpl in *. eapply H; eauto. - inv H; simpl in *; EqDep_subst. rewrite (unifyWO val_a) in HSemCompActionT_a. inv HSemCompActionT_a; EqDep_subst. destruct regMap_a; unfold WfRegMapExpr in *; dest. inv H; EqDep_subst. + specialize (IHa _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont). specialize (SemRegExprVals HSemRegMap HSemRegMap0) as TMP; inv TMP. reflexivity. + specialize (IHa _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont). specialize (SemRegExprVals HSemRegMap HSemRegMap0) as TMP; inv TMP. reflexivity. - inv H0; simpl in *; EqDep_subst. inv HSemCompActionT; simpl in *; EqDep_subst. inv HSemCompActionT0; simpl in *; EqDep_subst. inv HSemCompActionT_cont; EqDep_subst. inv HSemCompActionT_cont0; simpl in *; EqDep_subst. destruct regMap_a, regMap_a0. specialize (H _ _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT). simpl in *. specialize (IHa1 _ _ _ _ _ _ _ _ _ _ HSemRegMap HSemCompActionT_a). specialize (IHa2 _ _ _ _ _ _ _ _ _ _ (SemVarRegMap _) HSemCompActionT_a0). subst; reflexivity. - inv H; EqDep_subst; simpl in *. eapply IHa; eauto. - inv H; EqDep_subst. unfold WfRegMapExpr in *; dest. specialize (SemRegExprVals H HSemRegMap) as TMP; inv TMP. reflexivity. Qed. Lemma SameOldActions o la: forall old upds calls retl, @SemCompActionT Void (compileActions (o, nil) (rev la)) (old, upds) calls retl -> o = old. Proof. induction la; simpl in *; intros. rewrite (unifyWO retl) in H. inv H; EqDep_subst. inv HRegMapWf. inv H. reflexivity. - unfold compileActions in *; simpl in *. setoid_rewrite <- fold_left_rev_right in IHla. rewrite <- fold_left_rev_right in *. rewrite rev_app_distr, rev_involutive in *; simpl in *. rewrite (unifyWO retl) in H. inv H; simpl in *; EqDep_subst. rewrite (unifyWO WO) in HSemCompActionT_cont. inv HSemCompActionT_cont; simpl in *; EqDep_subst. rewrite (unifyWO val_a0) in HSemCompActionT_a0. inv HSemCompActionT_a0; EqDep_subst. destruct regMap_a. specialize (IHla _ _ _ _ HSemCompActionT_a); subst. destruct regMap_a0. inv HRegMapWf; inv H; inv HSemRegMap. apply (SameOldAction _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont0). Qed. Lemma SameOldLoop (m : BaseModule) o: forall rules old upds calls retl, @SemCompActionT Void (compileRules type (o, nil) (rev rules)) (old, upds) calls retl -> o = old. Proof. induction rules; simpl in *; intros. - rewrite (unifyWO retl) in H. inv H; EqDep_subst. inv HRegMapWf. inv H. reflexivity. - unfold compileRules, compileActions in *; simpl in *. setoid_rewrite <- fold_left_rev_right in IHrules. rewrite map_app, <- fold_left_rev_right, map_rev in *. simpl in *. rewrite rev_app_distr, rev_involutive in *; simpl in *. rewrite (unifyWO retl) in H. inv H; EqDep_subst. apply Eqdep.EqdepTheory.inj_pair2 in H4; subst; simpl in *. destruct regMap_a. specialize (IHrules _ _ _ _ HSemCompActionT_a); subst. rewrite (unifyWO WO) in HSemCompActionT_cont. inv HSemCompActionT_cont; simpl in *; EqDep_subst. rewrite (unifyWO val_a0) in HSemCompActionT_a0. inv HSemCompActionT_a0; simpl in *; EqDep_subst. destruct regMap_a; inv HRegMapWf; inv H; inv HSemRegMap. apply (SameOldAction _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont0). Qed. Lemma EquivLoop (m : BaseModule) o: forall rules upds calls retl ls (HoInitNoDups : NoDup (map fst o)) (HTrace : Trace m o ls) (HNoSelfCalls : NoSelfCallBaseModule m), SubList rules (getRules m) -> @SemCompActionT Void (compileRules type (o, nil) (rev rules)) (o, upds) calls retl -> (forall u, In u upds -> (NoDup (map fst u)) /\ SubList (getKindAttr u) (getKindAttr o)) /\ exists o' (ls' : list (list FullLabel)), PriorityUpds o upds o' /\ upds = (map getLabelUpds ls') /\ (map Rle (map fst rules)) = getLabelExecs (concat ls') /\ calls = concat (map getLabelCalls (rev ls')) /\ Trace m o' (ls' ++ ls). Proof. induction rules; simpl in *; intros. - rewrite (unifyWO retl) in H0. inv H0; EqDep_subst. unfold WfRegMapExpr in *; dest. inv H0; split; auto. exists o, nil; repeat split; auto. constructor. - unfold compileRules, compileActions in *; simpl in *. rewrite map_app in *. rewrite <- fold_left_rev_right in *. rewrite map_rev in *. simpl in *. rewrite rev_app_distr in H0. rewrite rev_involutive in *. simpl in *. rewrite (unifyWO retl) in H0. inv H0; simpl in *; EqDep_subst. destruct (SubList_cons H) as [TMP P0]; clear TMP. destruct regMap_a. rewrite (unifyWO WO) in HSemCompActionT_cont. inv HSemCompActionT_cont; simpl in *; EqDep_subst. rewrite (unifyWO val_a0) in HSemCompActionT_a0. inv HSemCompActionT_a0; simpl in *; EqDep_subst. destruct regMap_a. specialize HRegMapWf as HRegMapWf0. inv HRegMapWf; inv H0; inv HSemRegMap. specialize (SameOldAction _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont0) as TMP; subst. specialize (IHrules _ _ _ _ HoInitNoDups HTrace HNoSelfCalls P0 HSemCompActionT_a); dest. rewrite <-CompactPriorityUpds_iff in H2; auto. assert (forall u, In u (nil :: upds0) -> NoDup (map fst u)) as P1. { intros. destruct (H1 _ H8); auto. } assert (WfRegMapExpr (VarRegMap type (o, nil :: upds0)) (o, nil::upds0)) as P2. { clear - HRegMapWf0. unfold WfRegMapExpr in *; dest; split; auto. constructor. } specialize (EquivActions _ HoInitNoDups P1 H2 (eq_sym (prevPrevRegsTrue H2)) P2 HSemCompActionT_cont0) as TMP; dest. split; auto; simpl in *. assert (upds = (x1::upds0)) as P4. { inv H9. destruct x1; auto. } clear H9; subst. exists (doUpdRegs x1 x), (((x1, (Rle (fst a), calls_cont0))::nil)::x0). unfold getLabelCalls, getLabelUpds in *; simpl in *. rewrite app_nil_r. repeat split; auto. + econstructor 2 with (u := x1); auto. * rewrite CompactPriorityUpds_iff in H2; auto. apply H2. * specialize (H8 _ (or_introl eq_refl)); dest. rewrite (prevPrevRegsTrue H2). apply getKindAttr_doUpdRegs; eauto. -- rewrite <- (getKindAttr_map_fst _ _ (prevPrevRegsTrue H2)). assumption. -- intros. rewrite <- (prevPrevRegsTrue H2). apply H5. rewrite in_map_iff. exists (s, v); simpl; split; auto. * repeat intro. rewrite (getKindAttr_map_fst _ _ (prevPrevRegsTrue H2)) in HoInitNoDups. specialize (H8 _ (or_introl eq_refl)); dest. rewrite (prevPrevRegsTrue H2) in H8. specialize (doUpdRegs_UpdRegs _ (HoInitNoDups) _ H8) as P4. unfold UpdRegs in P4; dest. specialize (H11 _ _ H3); dest. destruct H11; dest. -- inv H11; auto. inv H13. -- right; split; auto. intro; apply H11. exists x1; split; simpl; auto. + apply f_equal; assumption. + repeat rewrite map_app; simpl. repeat rewrite concat_app; simpl. repeat rewrite app_nil_r. reflexivity. + destruct a; simpl in *. econstructor 2. * apply H7. * enough (Step m x ((x1, (Rle s, calls_cont0))::nil)) as P3. { apply P3. } econstructor. -- econstructor 2; eauto; specialize (Trace_sameRegs HTrace) as TMP; simpl in *. ++ rewrite <- TMP, (prevPrevRegsTrue H2); reflexivity. ++ apply H; left; simpl; reflexivity. ++ rewrite <- TMP, (prevPrevRegsTrue H2). apply SubList_map, (SemActionReadsSub H10). ++ specialize (H8 _ (or_introl eq_refl)); dest. rewrite <- TMP, (prevPrevRegsTrue H2). apply (SemActionUpdSub H10). ++ intros; inv H3. ++ intros; inv H3. ++ econstructor. rewrite <- TMP. apply (eq_sym (prevPrevRegsTrue H2)). -- unfold MatchingExecCalls_Base; intros. specialize (getNumExecs_nonneg f [(x1, (Rle s, calls_cont0))]) as P3. unfold getNumCalls; simpl. rewrite getNumFromCalls_app; simpl. erewrite NoSelfCallRule_Impl; eauto. ++ apply H; apply in_eq. ++ apply H10. * simpl. apply doUpdRegs_enuf; auto. -- apply getKindAttr_doUpdRegs; auto. ++ rewrite <-(getKindAttr_map_fst _ _ (prevPrevRegsTrue H2)); assumption. ++ intros. specialize (H8 _ (or_introl (eq_refl))); dest. rewrite <-(prevPrevRegsTrue H2). apply H8. rewrite in_map_iff. exists (s0, v); auto. * reflexivity. Qed. Corollary EquivLoop' {m : BaseModule} {o ls rules upds calls retl} (HTrace : Trace m o ls) (HRegsWf : NoDup (map fst (getRegisters m))) (HNoSelfCalls : NoSelfCallBaseModule m) (HValidSch : SubList rules (getRules m)): @SemCompActionT Void (compileRules type (o, nil) rules) (o, upds) calls retl -> (forall u, In u upds -> (NoDup (map fst u)) /\ SubList (getKindAttr u) (getKindAttr o)) /\ exists o' (ls' : list (list FullLabel)), PriorityUpds o upds o' /\ upds = (map getLabelUpds ls') /\ (map Rle (map fst (rev rules))) = getLabelExecs (concat ls') /\ calls = concat (map getLabelCalls (rev ls')) /\ Trace m o' (ls' ++ ls). Proof. specialize (Trace_NoDup HTrace HRegsWf) as HoInitNoDups. rewrite <- (rev_involutive rules) at 1. assert (SubList (rev rules) (getRules m)) as P0. { repeat intro; apply HValidSch; rewrite in_rev; assumption. } eapply EquivLoop; eauto. Qed. Lemma PriorityUpds_glue upds1 : forall o1 o1', (forall u, In u upds1 -> SubList (getKindAttr u) (getKindAttr o1)) -> PriorityUpds o1 upds1 o1' -> forall upds2 o2 o2', (forall u, In u upds2 -> SubList (getKindAttr u) (getKindAttr o2)) -> PriorityUpds o2 upds2 o2' -> DisjKey o1 o2 -> PriorityUpds (o1++o2) (upds1++upds2) (o1'++o2'). Proof. induction upds1. - simpl. induction upds2; intros. + inv H2; inv H0; [constructor 1 |discriminate| |discriminate]; discriminate. + inv H2; inv H0; inv HFullU;[|discriminate]. econstructor 2. * eapply IHupds2; eauto. intros; eapply H1. right; assumption. * repeat rewrite map_app; rewrite currRegsTCurr. reflexivity. * intros. rewrite in_app_iff in H0; destruct H0. -- right; split. ++ intro. specialize (H1 _ (or_introl eq_refl)). rewrite in_map_iff in H2; dest; subst. specialize (H1 _ (in_map (fun x => (fst x, projT1 (snd x))) _ _ H4)). destruct (H3 (fst x)). ** apply H2. rewrite in_map_iff. exists (fst x, v); split; auto. ** apply H2. apply (in_map fst) in H1; simpl in *. rewrite fst_getKindAttr in H1; assumption. ++ rewrite in_app_iff; left ; assumption. -- destruct (Hcurr _ _ H0); [left; apply H2|right; dest; split; auto]. rewrite in_app_iff; right; assumption. * reflexivity. - intros; simpl. inv H0; inv HFullU. econstructor 2 with (prevUpds := prevUpds ++ upds2) (u := u) (prevRegs := prevRegs ++ o2'). + eapply IHupds1; eauto. intros; apply (H _ (or_intror H0)). + repeat rewrite map_app; rewrite currRegsTCurr, (prevPrevRegsTrue H2). reflexivity. + intros; rewrite in_app_iff in H0. destruct H0. * specialize (Hcurr _ _ H0). destruct Hcurr; auto. dest; right; split; auto. rewrite in_app_iff; left; assumption. * right; split. -- intro. rewrite in_map_iff in H4; dest; subst. specialize (H _ (or_introl eq_refl) _ (in_map (fun x => (fst x, projT1 (snd x))) _ _ H5)). apply (in_map fst) in H0; simpl in *. apply (in_map fst) in H; rewrite fst_getKindAttr in H; simpl in *. destruct (H3 (fst x)); eauto. rewrite (getKindAttr_map_fst _ _ (prevPrevRegsTrue H2)) in H4; contradiction. -- rewrite in_app_iff; auto. + reflexivity. Qed. Lemma PriorityUpds_exist o (HNoDup : NoDup (map fst o)): forall upds (HUpdsCorrect : forall u, In u upds -> SubList (getKindAttr u) (getKindAttr o)) (HNoDupUpds : forall u, In u upds -> NoDup (map fst u)), exists o', PriorityUpds o upds o'. Proof. induction upds. - exists o. constructor. - intros. assert (forall u, In u upds -> SubList (getKindAttr u) (getKindAttr o)) as P0. { intros; apply HUpdsCorrect; simpl; eauto. } assert (forall u, In u upds -> NoDup (map fst u)) as P1. { intros; specialize (HNoDupUpds _ (or_intror H)); assumption. } specialize (IHupds P0 P1); dest. exists (doUpdRegs a x). rewrite (getKindAttr_map_fst _ _ (prevPrevRegsTrue H)) in HNoDup. rewrite (prevPrevRegsTrue H) in HUpdsCorrect. specialize (doUpdRegs_UpdRegs _ HNoDup _ (HUpdsCorrect _ (or_introl eq_refl))) as P2. unfold UpdRegs in P2; dest. econstructor; auto. + apply H. + rewrite (prevPrevRegsTrue H). assumption. + intros. specialize (H1 _ _ H2). destruct H1; dest. * destruct H1; subst; auto. contradiction. * right; split; auto. intro; apply H1. exists a; split; auto. left; reflexivity. Qed. Section ESemAction_meth_collector. Variable f : DefMethT. Variable o : RegsT. Inductive ESemAction_meth_collector : UpdOrMeths -> UpdOrMeths -> Prop := | NilUml : ESemAction_meth_collector nil nil | ConsUpd um uml uml' newUml newUml' upd (HUpd : um = UmUpd upd) (HDisjRegs : key_not_In (fst upd) (UpdOrMeths_RegsT newUml)) (HUmlCons : uml' = um :: uml) (HnewUmlCons : newUml' = um :: newUml) (HCollector : ESemAction_meth_collector uml newUml): ESemAction_meth_collector uml' newUml' | ConsCallsNStr um uml uml' newUml newUml' meth (HMeth : um = UmMeth meth) (HIgnore : fst meth <> fst f) (HUmlCons : uml' = um :: uml) (HnewUmlCons : newUml' = um :: newUml) (HCollector : ESemAction_meth_collector uml newUml): ESemAction_meth_collector uml' newUml' | ConsWrCallsNSgn um uml uml' newUml newUml' meth (HMeth : um = UmMeth meth) (HIgnore : projT1 (snd meth) <> projT1 (snd f)) (HUmlCons : uml' = um :: uml) (HnewUmlCons : newUml' = um :: newUml) (HCollector : ESemAction_meth_collector uml newUml): ESemAction_meth_collector uml' newUml' | ConsWrFCalls um fUml uml uml' newUml newUml' argV retV (HMeth : um = UmMeth (fst f, (existT _ (projT1 (snd f)) (argV, retV)))) (HESemAction : ESemAction o (Action_EAction (projT2 (snd f) type argV)) fUml retV) (HDisjRegs : DisjKey (UpdOrMeths_RegsT fUml) (UpdOrMeths_RegsT newUml)) (HUmlCons : uml' = um :: uml) (HnewUmlApp : newUml' = fUml ++ newUml) (HCollector : ESemAction_meth_collector uml newUml): ESemAction_meth_collector uml' newUml'. Lemma ESemActionMC_Upds_SubList (uml : UpdOrMeths) : forall newUml, ESemAction_meth_collector uml newUml -> SubList (UpdOrMeths_RegsT uml) (UpdOrMeths_RegsT newUml). Proof. induction uml; repeat intro. - inv H0. - simpl in H0. destruct a. + inv H; inv HUmlCons; simpl. inv H0; auto. right; eapply IHuml; eauto. + inv H; inv HUmlCons; simpl; auto. * eapply IHuml; eauto. * eapply IHuml; eauto. * rewrite UpdOrMeths_RegsT_app, in_app_iff; right. eapply IHuml; eauto. Qed. Lemma ESemAction_meth_collector_break (uml1 : UpdOrMeths) : forall uml2 newUml, ESemAction_meth_collector (uml1 ++ uml2) newUml -> exists newUml1 newUml2, newUml = newUml1 ++ newUml2 /\ DisjKey (UpdOrMeths_RegsT newUml1) (UpdOrMeths_RegsT newUml2) /\ ESemAction_meth_collector uml1 newUml1 /\ ESemAction_meth_collector uml2 newUml2. Proof. induction uml1; simpl; intros. - exists nil, newUml; simpl; repeat split; auto. + intro k; auto. + constructor. - inv H; inv HUmlCons; specialize (IHuml1 _ _ HCollector); dest. + exists (UmUpd upd :: x), x0; subst; repeat split; auto. * rewrite UpdOrMeths_RegsT_app in HDisjRegs. apply key_not_In_app in HDisjRegs; dest. intro k; simpl. destruct (string_dec (fst upd) k); subst. -- right; intro. rewrite in_map_iff in H4; dest. apply (H3 (snd x1)); destruct x1; simpl in *; rewrite <- H4; auto. -- destruct (H0 k); auto. left; intro; destruct H5; auto. * econstructor; auto. rewrite UpdOrMeths_RegsT_app in HDisjRegs. apply key_not_In_app in HDisjRegs; dest; auto. + exists (UmMeth meth :: x), x0; subst; repeat split; auto. econstructor 3; eauto. + exists (UmMeth meth :: x), x0; subst; repeat split; auto. econstructor 4; eauto. + exists (fUml ++ x), x0; subst; repeat split; eauto using app_assoc. * intro k; specialize (HDisjRegs k); specialize (H0 k). rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff in *. firstorder fail. * econstructor 5; auto. -- assumption. -- intro k; destruct (HDisjRegs k); auto. right; intro; apply H. rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff; auto. Qed. Lemma ESemAction_meth_collector_stitch (uml1 : UpdOrMeths) : forall uml2 newUml1 newUml2 (HDisjRegs : DisjKey (UpdOrMeths_RegsT newUml1) (UpdOrMeths_RegsT newUml2)), ESemAction_meth_collector uml1 newUml1 -> ESemAction_meth_collector uml2 newUml2 -> ESemAction_meth_collector (uml1 ++ uml2) (newUml1 ++ newUml2). Proof. induction uml1; simpl; intros. - inv H; simpl; auto; discriminate. - inv H; simpl; inv HUmlCons. + econstructor; auto. * specialize (HDisjRegs (fst upd)); simpl in *; destruct HDisjRegs; [exfalso; apply H; left; reflexivity|]. repeat intro. rewrite UpdOrMeths_RegsT_app, in_app_iff in H1. destruct H1. -- eapply HDisjRegs0; eauto. -- apply H; rewrite in_map_iff; exists (fst upd, v); split; auto. * eapply IHuml1; eauto. repeat intro; specialize (HDisjRegs k); simpl in *. clear - HDisjRegs. firstorder fail. + econstructor 3; auto. assumption. + econstructor 4; auto. assumption. + econstructor 5. * reflexivity. * apply HESemAction. * instantiate (1 := newUml ++ newUml2). intro k. specialize (HDisjRegs k); specialize (HDisjRegs0 k). clear - HDisjRegs HDisjRegs0. rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff in *. firstorder fail. * reflexivity. * rewrite app_assoc; reflexivity. * eapply IHuml1; eauto. intro k. specialize (HDisjRegs k). clear - HDisjRegs. rewrite UpdOrMeths_RegsT_app, map_app, in_app_iff in *. firstorder fail. Qed. End ESemAction_meth_collector. (* Section WriteInline. *) Hint Rewrite unifyWO : _word_zero. Lemma Extension_inlineWrites {k : Kind} (ea : EActionT type k) : forall o uml retv rf, ESemAction o ea uml retv -> forall newUml, ESemAction_meth_collector (getRegFileWrite rf) o uml newUml -> ESemAction o (inlineWriteFile rf ea) newUml retv. Proof. induction ea; simpl; intros; destruct rf. - inv H0; EqDep_subst. inv H1;[discriminate | | | ]; remember (String.eqb _ _) as strb; destruct strb; symmetry in Heqstrb; inv HUmlCons; try rewrite String.eqb_eq in Heqstrb; try rewrite String.eqb_neq in Heqstrb; subst; try (destruct rfIsWrMask, Signature_dec); subst; simpl in *; try congruence; EqDep_subst. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + autorewrite with _word_zero in *; inv HESemAction0; simpl in *; EqDep_subst. autorewrite with _word_zero in *; inv HESemAction1; simpl in *; EqDep_subst. do 2 econstructor; auto; rewrite (Eqdep.EqdepTheory.UIP_refl _ _ e0). -- apply HRegVal. -- instantiate (1 := (newUml ++ newUml0)). do 2 (apply f_equal2; auto; apply f_equal). clear. rewrite <- (rev_involutive (getFins rfNum)). repeat rewrite <- fold_left_rev_right; simpl. rewrite (rev_involutive). induction (rev (getFins rfNum)); simpl; auto. rewrite IHl; auto. -- repeat intro. specialize (HDisjRegs rfDataArray); simpl in *. rewrite UpdOrMeths_RegsT_app, in_app_iff in H0. destruct H0. ++ eapply HDisjRegs0; eauto. ++ destruct HDisjRegs; eauto. apply H1; rewrite in_map_iff; exists (rfDataArray, v); split; auto. -- autorewrite with _word_zero in *; inv HESemAction0; simpl in *; EqDep_subst. rewrite (unifyWO retV) in HESemAction; simpl in *. eapply H; simpl; eauto. + autorewrite with _word_zero in *; inv HESemAction0; simpl in *; EqDep_subst. autorewrite with _word_zero in *; inv HESemAction1; simpl in *; EqDep_subst. econstructor; auto; econstructor 13; auto; rewrite (Eqdep.EqdepTheory.UIP_refl _ _ e0). -- apply HRegVal. -- instantiate (1 := (newUml ++ newUml0)). do 2 (apply f_equal2; auto; apply f_equal). clear. rewrite <- (rev_involutive (getFins rfNum)). repeat rewrite <- fold_left_rev_right; simpl. rewrite (rev_involutive). induction (rev (getFins rfNum)); simpl; auto. rewrite IHl; auto. -- repeat intro. specialize (HDisjRegs rfDataArray); simpl in *. rewrite UpdOrMeths_RegsT_app, in_app_iff in H0. destruct H0. ++ eapply HDisjRegs0; eauto. ++ destruct HDisjRegs; eauto. apply H1; rewrite in_map_iff; exists (rfDataArray, v); split; auto. -- autorewrite with _word_zero in *; inv HESemAction0; simpl in *; EqDep_subst. rewrite (unifyWO retV) in HESemAction; simpl in *. eapply H; simpl; eauto. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst. + specialize (ESemAction_meth_collector_break _ _ H1) as TMP; dest. econstructor. * instantiate (1 := x0); instantiate (1 := x); auto. * eapply IHea; eauto. * eapply H; eauto. * assumption. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. -inv H; simpl in *; EqDep_subst. inv H0; [ | discriminate | discriminate | discriminate]. inv HUmlCons; econstructor; auto. + simpl in *; auto. + eapply IHea; eauto. - inv H0; simpl in *; EqDep_subst; specialize (ESemAction_meth_collector_break _ _ H1) as TMP; dest. + econstructor; eauto. + econstructor 8; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. inv H0; auto; discriminate. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst. + inv H0; inv HUmlCons. econstructor; eauto. + inv H0; inv HUmlCons. econstructor 13; eauto. - inv H; simpl in *; EqDep_subst. + inv H0; inv HUmlCons. econstructor; auto. * simpl in *; eauto. * eapply IHea; eauto. + inv H0; inv HUmlCons. econstructor 15; auto. * apply HRegVal2. * instantiate (1 := newUml1). simpl in *; eauto. * reflexivity. * eapply IHea; eauto. - inv H0; simpl in *; EqDep_subst. + econstructor; eauto. + econstructor 17; eauto. Qed. Lemma inlineWrites_Extension {k : Kind} (ea : EActionT type k): forall rf o newUml retv, ESemAction o (inlineWriteFile rf ea) newUml retv -> exists uml, ESemAction_meth_collector (getRegFileWrite rf) o uml newUml /\ ESemAction o ea uml retv. Proof. induction ea; simpl in *; intro rf; remember rf as rf'; destruct rf'; intros. - remember (String.eqb _ _) as strb; symmetry in Heqstrb. destruct strb; try rewrite String.eqb_eq in *; try rewrite String.eqb_neq in *; [destruct rfIsWrMask; destruct Signature_dec |]. + revert Heqrf'. inv H0; simpl in *; EqDep_subst. inv HESemAction; simpl in *; EqDep_subst. * specialize (H _ _ _ _ _ HESemAction0); dest; inv H9. intro. exists (UmMeth (meth, existT SignT (WriteRqMask (Nat.log2_up rfIdxNum) rfNum rfData, Void) (evalExpr e, WO))::x); split. -- econstructor 5; auto. ++ econstructor; eauto. econstructor; simpl; auto. ** rewrite in_map_iff. exists (rfDataArray, existT _ (SyntaxKind (Array rfIdxNum rfData)) regV); split; auto. ** instantiate (1 := nil); repeat intro; auto. ** econstructor; eauto. ++ intro; simpl. destruct (string_dec rfDataArray k). ** right; instantiate (1 := newUml0). intro; rewrite in_map_iff in H1; dest; destruct x0; simpl in *; subst. eapply HDisjRegs; eauto. ** left; intro; destruct H1; subst; eauto. ++ simpl. do 2 (apply f_equal2; auto; apply f_equal). clear. rewrite <- (rev_involutive (getFins rfNum)). repeat rewrite <- fold_left_rev_right; simpl. rewrite (rev_involutive). induction (rev (getFins rfNum)); simpl; auto. rewrite IHl; auto. ++ assumption. -- econstructor; eauto. * discriminate. + inv H0; simpl in *; EqDep_subst. * specialize (H _ _ _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x); split. -- econstructor 4; simpl; eauto. intro; destruct s; simpl in *; auto. -- econstructor; eauto. + revert Heqrf'. inv H0; EqDep_subst. inv HESemAction; simpl in *; EqDep_subst; [discriminate|]. * specialize (H _ _ _ _ _ HESemAction0); dest; inv H9. intro. exists (UmMeth (meth, existT SignT (WriteRq (Nat.log2_up rfIdxNum) (Array rfNum rfData), Void) (evalExpr e, WO))::x); split. -- econstructor 5; auto. ++ econstructor; eauto. econstructor; simpl; auto. ** rewrite in_map_iff. exists (rfDataArray, existT _ (SyntaxKind (Array rfIdxNum rfData)) regV); split; auto. ** instantiate (1 := nil); repeat intro; auto. ** econstructor; eauto. ++ intro; simpl. destruct (string_dec rfDataArray k). ** right; instantiate (1 := newUml0). intro; rewrite in_map_iff in H1; dest; destruct x0; simpl in *; subst. eapply HDisjRegs; eauto. ** left; intro; destruct H1; subst; eauto. ++ simpl. do 2 (apply f_equal2; auto; apply f_equal). clear. rewrite <- (rev_involutive (getFins rfNum)). repeat rewrite <- fold_left_rev_right; simpl. rewrite (rev_involutive). induction (rev (getFins rfNum)); simpl; auto. rewrite IHl; auto. ++ assumption. -- econstructor; eauto. + inv H0; simpl in *; EqDep_subst. * specialize (H _ _ _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x); split. -- econstructor 4; simpl; eauto. intro; destruct s; simpl in *; auto. -- econstructor; eauto. + inv H0; simpl in *; EqDep_subst. * specialize (H _ _ _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x); split. -- econstructor 3; simpl; eauto. intro; destruct s; simpl in *; auto. -- econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HESemActionCont); dest. specialize (IHea _ _ _ _ HESemAction); dest. exists (x0 ++ x); split; auto. apply ESemAction_meth_collector_stitch; auto. econstructor. + instantiate (1 := x); instantiate (1 := x0). intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P0. specialize (ESemActionMC_Upds_SubList H1) as P1. clear - P0 P1 HDisjRegs. destruct HDisjRegs;[left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. + apply H2. + assumption. + reflexivity. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. specialize (IHea _ _ _ _ HESemAction); dest. exists (UmUpd (r, existT (fullType type) k (evalExpr e))::x); split; auto. + econstructor; auto. * simpl; assumption. + econstructor; auto. repeat intro; eapply HDisjRegs. apply (ESemActionMC_Upds_SubList H _ H1). - inv H0; EqDep_subst. + specialize (IHea1 _ _ _ _ HEAction); dest. specialize (H _ _ _ _ _ HESemAction); dest. exists (x ++ x0); split; auto. * apply ESemAction_meth_collector_stitch; auto. * econstructor; auto. -- intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P0. specialize (ESemActionMC_Upds_SubList H0) as P1. clear - P0 P1 HDisjRegs. destruct HDisjRegs; [left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. -- apply H1. -- assumption. + specialize (IHea2 _ _ _ _ HEAction); dest. specialize (H _ _ _ _ _ HESemAction); dest. exists (x ++ x0); split; auto. * apply ESemAction_meth_collector_stitch; auto. * econstructor 8; auto. -- intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P0. specialize (ESemActionMC_Upds_SubList H0) as P1. clear - P0 P1 HDisjRegs. destruct HDisjRegs; [left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. -- apply H1. -- assumption. - inv H; EqDep_subst. specialize (IHea _ _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. exists nil; split; auto. + constructor. + econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. + specialize (IHea _ _ _ _ HESemAction); dest. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (IF ReadArrayConst mask0 i then newArr @[ idx + Const type (natToWord (Nat.log2_up idxNum) (proj1_sig (to_nat i))) <- ReadArrayConst val i] else newArr)%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))::x); split; auto. * econstructor; eauto; simpl. assumption. * econstructor; eauto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P0. apply (P0 _ H1). + specialize (IHea _ _ _ _ HESemAction); dest. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (newArr @[ idx + Const type (natToWord (Nat.log2_up idxNum) (proj1_sig (to_nat i))) <- ReadArrayConst val i])%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))::x); split; auto. * econstructor; eauto; simpl. assumption. * econstructor 13; eauto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P0. apply (P0 _ H1). - inv H; EqDep_subst. + specialize (IHea _ _ _ _ HESemAction); dest. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx)) :: x); split; auto. * econstructor; eauto. simpl; assumption. * econstructor; auto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P0. apply (P0 _ H1). + specialize (IHea _ _ _ _ HESemAction); dest. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Array num Data)) (evalExpr (BuildArray (fun i : Fin.t num => (Var type (SyntaxKind (Array idxNum Data)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx) + Const type (natToWord (Nat.log2_up idxNum) (proj1_sig (to_nat i)))])%kami_expr)))) :: x); split; auto. * econstructor; simpl in *; auto. -- assumption. * econstructor 15; auto. -- assumption. -- repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P0. apply (P0 _ H1). - inv H0; EqDep_subst. + specialize (H _ _ _ _ _ HESemAction); dest. exists x ; split; auto. econstructor; eauto. + specialize (H _ _ _ _ _ HESemAction); dest. exists x; split; auto. econstructor 17; eauto. Qed. Corollary inlineWrites_congruence {k : Kind} (ea1 ea2 : EActionT type k) : (forall o uml retv, ESemAction o ea1 uml retv -> ESemAction o ea2 uml retv) -> forall o newUml retv rf, ESemAction o (inlineWriteFile rf ea1) newUml retv -> ESemAction o (inlineWriteFile rf ea2) newUml retv. Proof. intros. specialize (inlineWrites_Extension _ _ H0) as TMP; dest. specialize (H _ _ _ H2). apply (Extension_inlineWrites _ H H1). Qed. Lemma WrInline_inlines {k : Kind} (a : ActionT type k) : forall rf o uml retv, ESemAction o (Action_EAction (inlineSingle a (getRegFileWrite rf))) uml retv -> ESemAction o (inlineWriteFile rf (Action_EAction a)) uml retv. Proof. induction a; intros; auto; simpl; destruct rf; subst; simpl in *. - destruct String.eqb, rfIsWrMask; [destruct Signature_dec | destruct Signature_dec | | ]; simpl in *. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemAction0; EqDep_subst. inv HESemAction; EqDep_subst. do 2 econstructor; auto. * apply HRegVal. * instantiate (1 := (newUml0 ++ newUmlCont)); simpl. do 2 (apply f_equal2; auto; apply f_equal). clear. rewrite <- (rev_involutive (getFins rfNum)). repeat rewrite <- fold_left_rev_right; simpl. rewrite (rev_involutive). induction (rev (getFins rfNum)); simpl; auto. rewrite IHl; auto. * repeat intro; simpl in *. rewrite UpdOrMeths_RegsT_app, in_app_iff in H0. specialize (HDisjRegs rfDataArray); simpl in *. destruct HDisjRegs; [apply H1; auto|]. specialize (HDisjRegs0 v0); destruct H0; auto. apply H1; rewrite in_map_iff. exists (rfDataArray, v0); split; auto. * inv HESemAction0; EqDep_subst; simpl; eauto. + inv H0; EqDep_subst. econstructor; eauto. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemAction0; EqDep_subst. inv HESemAction; EqDep_subst. econstructor; auto; econstructor 13; auto. * apply HRegVal. * instantiate (1 := (newUml0 ++ newUmlCont)); simpl. do 2 (apply f_equal2; auto; apply f_equal). clear. rewrite <- (rev_involutive (getFins rfNum)). repeat rewrite <- fold_left_rev_right; simpl. rewrite (rev_involutive). induction (rev (getFins rfNum)); simpl; auto. rewrite IHl; auto. * repeat intro; simpl in *. rewrite UpdOrMeths_RegsT_app, in_app_iff in H0. specialize (HDisjRegs rfDataArray); simpl in *. destruct HDisjRegs; [apply H1; auto|]. specialize (HDisjRegs0 v0); destruct H0; auto. apply H1; rewrite in_map_iff. exists (rfDataArray, v0); split; auto. * inv HESemAction0; EqDep_subst; simpl; eauto. + inv H0; EqDep_subst. econstructor; eauto. + inv H0; EqDep_subst. econstructor; eauto. + inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst; econstructor; eauto. - inv H0; EqDep_subst; econstructor; eauto. - inv H0; EqDep_subst; econstructor; eauto. - inv H0; EqDep_subst; econstructor; eauto. - inv H; EqDep_subst; econstructor; eauto. - inv H0; EqDep_subst. + econstructor; eauto. + econstructor 8; eauto. - inv H; EqDep_subst; econstructor; eauto. - inv H; EqDep_subst; econstructor; eauto. Qed. Lemma inline_WrInlines {k : Kind} (a : ActionT type k) rf : forall o uml retv, ESemAction o (inlineWriteFile rf (Action_EAction a)) uml retv -> ESemAction o (Action_EAction (inlineSingle a (getRegFileWrite rf))) uml retv. Proof. induction a; intros; auto; simpl; destruct rf; subst; simpl in *. - destruct String.eqb, rfIsWrMask; [destruct Signature_dec | destruct Signature_dec | | ]; simpl in *. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst; inv H9. econstructor; simpl; auto. * instantiate (1 := newUml). instantiate (1 := (UmUpd (rfDataArray, existT (fullType type) (SyntaxKind (Array rfIdxNum rfData)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array rfIdxNum rfData))) (i : Fin.t rfNum) => (IF ReadArrayConst (ReadStruct e (Fin.FS (Fin.FS Fin.F1))) i then newArr @[ ReadStruct e Fin.F1 + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i)))) <- ReadArrayConst (ReadStruct e (Fin.FS Fin.F1)) i] else newArr)%kami_expr) (getFins rfNum) (Var type (SyntaxKind (Array rfIdxNum rfData)) regV))))) :: nil); simpl in *. intro k; simpl. destruct (string_dec rfDataArray k); [right | left]; intro; auto; subst. -- rewrite in_map_iff in *; dest; destruct x; subst; eapply HDisjRegs; eauto. -- destruct H0; auto. * do 2 econstructor; auto. -- apply HRegVal. -- econstructor; auto. ++ rewrite in_map_iff. eexists; split; [| eapply HRegVal]; simpl; reflexivity. ++ instantiate (1 := nil); simpl; repeat intro; auto. ++ do 2 (apply f_equal2; auto; apply f_equal). clear. rewrite <- (rev_involutive (getFins rfNum)). repeat rewrite <- fold_left_rev_right; simpl. rewrite (rev_involutive). induction (rev (getFins rfNum)); simpl; auto. rewrite IHl; auto. ++ econstructor; eauto. * eapply H; eauto. * simpl; reflexivity. + inv H0; EqDep_subst. econstructor; eauto. + subst. inv H0; EqDep_subst. inv HESemAction; EqDep_subst; [discriminate |]. econstructor; simpl; auto. * instantiate (1 := newUml). instantiate (1 := (UmUpd (rfDataArray, existT (fullType type) (SyntaxKind (Array rfIdxNum rfData)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array rfIdxNum rfData))) (i : Fin.t rfNum) => (newArr @[ ReadStruct e Fin.F1 + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i)))) <- ReadArrayConst (ReadStruct e (Fin.FS Fin.F1)) i])%kami_expr) (getFins rfNum) (Var type (SyntaxKind (Array rfIdxNum rfData)) regV))))) :: nil); simpl in *. intro k; simpl. destruct (string_dec rfDataArray k); [right | left]; intro; auto; subst. -- rewrite in_map_iff in *; dest; destruct x; subst; eapply HDisjRegs; eauto. -- destruct H0; auto. * do 2 econstructor; auto. -- apply HRegVal. -- econstructor; auto. ++ rewrite in_map_iff. eexists; split; [| eapply HRegVal]; simpl; reflexivity. ++ instantiate (1 := nil); simpl; repeat intro; auto. ++ do 2 (apply f_equal2; auto; apply f_equal). clear. rewrite <- (rev_involutive (getFins rfNum)). repeat rewrite <- fold_left_rev_right; simpl. rewrite (rev_involutive). induction (rev (getFins rfNum)); simpl; auto. rewrite IHl; auto. ++ econstructor; eauto. * eapply H; eauto. * simpl; reflexivity. + inv H0; EqDep_subst. econstructor; eauto. + inv H0; EqDep_subst. econstructor; eauto. + inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. ++ econstructor; eauto. ++ econstructor 8; eauto. - inv H; EqDep_subst. econstructor; eauto. - inv H; EqDep_subst. econstructor; eauto. Qed. (* End WriteInline. *) (* Section AsyncReadInline. *) Lemma Extension_inlineAsyncRead {k : Kind} (ea : EActionT type k) : forall rf (read : string) (reads : list string) (HIsAsync : rfRead rf = Async reads) (HIn : In read reads) o uml retv, ESemAction o ea uml retv -> forall newUml, ESemAction_meth_collector (getAsyncReads rf read) o uml newUml -> ESemAction o (inlineAsyncReadFile read rf ea) newUml retv. Proof. destruct rf; simpl in *; destruct rfRead;[| intros; discriminate]. induction ea; simpl; intros; inv HIsAsync; remember (existsb _ _) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_exists in *; dest; try rewrite existsb_nexists_str in *; try rewrite String.eqb_eq in *; subst; try congruence. - inv H0; EqDep_subst. remember (String.eqb _ _) as strb; symmetry in Heqstrb; revert Heqstrb. inv H1;[discriminate | | | ]; intro; destruct strb; try rewrite String.eqb_eq in *; inv HUmlCons; try (destruct Signature_dec); subst; try (simpl in *; congruence); EqDep_subst. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + rewrite (Eqdep.EqdepTheory.UIP_refl _ _ e0) in *. inv HESemAction0; EqDep_subst. inv HESemAction1; EqDep_subst. econstructor; simpl in *; eauto. + rewrite eqb_refl in *; discriminate. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst. + specialize (ESemAction_meth_collector_break _ _ H1) as TMP; dest. econstructor. * instantiate (1 := x1); instantiate (1 := x0); auto. * eapply IHea; eauto. * eapply H; eauto. * assumption. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. -inv H; simpl in *; EqDep_subst. inv H0; [ | discriminate | discriminate | discriminate]. inv HUmlCons; econstructor; auto. + simpl in *; auto. + eapply IHea; eauto. - inv H0; simpl in *; EqDep_subst; specialize (ESemAction_meth_collector_break _ _ H1) as TMP; dest. + econstructor; eauto. + econstructor 8; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. inv H0; auto; discriminate. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst. + inv H0; inv HUmlCons. econstructor; eauto. + inv H0; inv HUmlCons. econstructor 13; eauto. - inv H; simpl in *; EqDep_subst. + inv H0; inv HUmlCons. econstructor; auto. * simpl in *; eauto. * eapply IHea; eauto. + inv H0; inv HUmlCons. econstructor 15; auto. * apply HRegVal2. * instantiate (1 := newUml1). simpl in *; eauto. * reflexivity. * eapply IHea; eauto. - inv H0; simpl in *; EqDep_subst. + econstructor; eauto. + econstructor 17; eauto. Qed. Lemma inlineAsyncRead_Extension {k : Kind} (ea : EActionT type k): forall rf (reads : list string)(HIsAsync : rfRead rf = Async reads) (read : string) (HIn : In read reads) o newUml retv, ESemAction o (inlineAsyncReadFile read rf ea) newUml retv -> exists uml, ESemAction_meth_collector (getAsyncReads rf read) o uml newUml /\ ESemAction o ea uml retv. Proof. induction ea; simpl in *; intros rf; remember rf as rf'; destruct rf'; intros; simpl in *; rewrite HIsAsync in *; remember (existsb _ _) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_exists in *; dest; try rewrite existsb_nexists_str in *; try rewrite String.eqb_eq in *; revert Heqrf' HIsAsync; subst; try congruence. - remember (String.eqb _ _) as strb; symmetry in Heqstrb; destruct strb; [destruct Signature_dec |]. + inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (UmMeth (x, existT SignT (Bit (Nat.log2_up rfIdxNum), Array rfNum rfData) (evalExpr e, (evalExpr (BuildArray (fun i : Fin.t rfNum => (Var type (SyntaxKind (Array rfIdxNum rfData)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up rfIdxNum))) (evalExpr e) + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i))))])%kami_expr)))))::x0); split. * econstructor 5; auto. -- do 2 (econstructor; eauto). -- repeat intro; auto. -- simpl; reflexivity. -- assumption. * rewrite String.eqb_eq in *; subst; econstructor; eauto. + inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x0); split. * econstructor 4; simpl; eauto. intro; destruct s; simpl in *; auto. * econstructor; eauto. + inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x0); split. * econstructor 3; simpl; eauto. intro; destruct s; simpl in *; subst; rewrite String.eqb_refl in *; discriminate. * econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists x0; split; auto. econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemActionCont); dest. specialize (IHea _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (x1 ++ x0); split; auto. apply ESemAction_meth_collector_stitch; auto. econstructor. + instantiate (1 := x0); instantiate (1 := x1). intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H2) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs;[left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x; split; auto. + apply H3. + assumption. + reflexivity. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists x0; split; auto. econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists x0; split; auto. econstructor; eauto. - inv H; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (UmUpd (r, existT (fullType type) k (evalExpr e))::x0); split; auto. + econstructor; auto. * simpl; assumption. + econstructor; auto. repeat intro; eapply HDisjRegs. apply (ESemActionMC_Upds_SubList H _ H2). - inv H0; EqDep_subst. + intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea1 _ _ P0 _ HIn _ _ _ HEAction); dest. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (x0 ++ x1); split; auto. * apply ESemAction_meth_collector_stitch; auto. * econstructor; auto. -- intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H0) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs; [left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x; split; auto. -- apply H2. -- assumption. + intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea2 _ _ P0 _ HIn _ _ _ HEAction); dest. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (x0 ++ x1); split; auto. * apply ESemAction_meth_collector_stitch; auto. * econstructor 8; auto. -- intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H0) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs; [left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x; split; auto. -- apply H2. -- assumption. - inv H; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ P0 _ HIn _ _ _ HESemAction); dest. exists x0; split; auto. econstructor; eauto. - inv H; EqDep_subst. exists nil; split; auto. + constructor. + econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists x0; split; auto. econstructor; eauto. - inv H; EqDep_subst. + intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (IF ReadArrayConst mask0 i then newArr @[ idx + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i)))) <- ReadArrayConst val i] else newArr)%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))::x0); split; auto. * econstructor; eauto; simpl. assumption. * econstructor; eauto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H2). + intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (newArr @[ idx + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i)))) <- ReadArrayConst val i])%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))::x0); split; auto. * econstructor; eauto; simpl. assumption. * econstructor 13; eauto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H2). - inv H; EqDep_subst. + intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx)) :: x0); split; auto. * econstructor; eauto. simpl; assumption. * econstructor; auto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H2). + intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ P0 _ HIn _ _ _ HESemAction); dest. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Array num Data)) (evalExpr (BuildArray (fun i : Fin.t num => (Var type (SyntaxKind (Array idxNum Data)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx) + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i))))])%kami_expr)))) :: x0); split; auto. * econstructor; eauto. simpl; assumption. * econstructor 15; auto. -- assumption. -- repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H2). - inv H0; EqDep_subst. + intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists x0 ; split; auto. econstructor; eauto. + intros. assert (Syntax.rfRead rf = Async reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ P0 _ HIn _ _ _ HESemAction); dest. exists x0 ; split; auto. econstructor 17; eauto. Qed. Corollary inlineAsyncRead_congruence {k : Kind} (ea1 ea2 : EActionT type k) : (forall o uml retv, ESemAction o ea1 uml retv -> ESemAction o ea2 uml retv) -> forall o newUml retv rf (read : string) (reads : list string) (HIsAsync : rfRead rf = Async reads) (HIn : In read reads), ESemAction o (inlineAsyncReadFile read rf ea1) newUml retv -> ESemAction o (inlineAsyncReadFile read rf ea2) newUml retv. Proof. intros. specialize (inlineAsyncRead_Extension _ _ HIsAsync _ HIn H0) as TMP; dest. specialize (H _ _ _ H2). apply (Extension_inlineAsyncRead HIsAsync HIn H H1). Qed. Lemma AsyncReadInline_inlines {k : Kind} (a : ActionT type k) : forall rf (reads : list string)(HIsAsync : rfRead rf = Async reads) (read : string) (HIn : In read reads) o uml retv, ESemAction o (Action_EAction (inlineSingle a (getAsyncReads rf read))) uml retv -> ESemAction o (inlineAsyncReadFile read rf (Action_EAction a)) uml retv. Proof. induction a; intros; auto; simpl; destruct rf; simpl in *; rewrite HIsAsync in *; remember (existsb _ _) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_exists in *; try rewrite existsb_nexists_str in *; dest; try rewrite String.eqb_eq in *; subst; try congruence. - remember (String.eqb _ _) as strb; symmetry in Heqstrb; destruct strb; [rewrite String.eqb_eq in *; destruct Signature_dec |rewrite String.eqb_neq in *]; simpl in *. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemAction0; EqDep_subst. inv HESemAction; EqDep_subst. econstructor; auto. * apply HRegVal. * eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; eauto. eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; auto. eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eapply H; simpl; eauto. - inv H0; EqDep_subst. econstructor; eauto. + eapply IHa; simpl; eauto. + eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eauto; eapply H; simpl; eauto. - inv H; EqDep_subst; econstructor; eauto; eapply IHa; simpl; eauto. - inv H0; EqDep_subst. + econstructor; eauto. * eapply IHa1; simpl; eauto. * eapply H; simpl; eauto. + econstructor 8; eauto. * eapply IHa2; simpl; eauto. * eapply H; simpl; eauto. - inv H; EqDep_subst; econstructor; eapply IHa; simpl; eauto. Qed. Lemma inline_AsyncReadInlines {k : Kind} (a : ActionT type k) rf : forall (reads : list string)(HIsAsync : rfRead rf = Async reads) (read : string) (HIn : In read reads) o uml retv, ESemAction o (inlineAsyncReadFile read rf (Action_EAction a)) uml retv -> ESemAction o (Action_EAction (inlineSingle a (getAsyncReads rf read))) uml retv. Proof. induction a; intros; auto; simpl; destruct rf; simpl in *; rewrite HIsAsync in *; remember (existsb _ _) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_exists in *; try rewrite existsb_nexists_str in *; dest; try rewrite String.eqb_eq in *; subst; try congruence. - remember (String.eqb _ _) as strb; symmetry in Heqstrb; destruct strb; [rewrite String.eqb_eq in *; destruct Signature_dec |rewrite String.eqb_neq in *]; simpl in *. + inv H0; EqDep_subst. econstructor; simpl; auto. * instantiate (1 := uml). instantiate (1 := nil); simpl in *. intro k; simpl; auto. * do 2 econstructor; auto. -- apply HRegVal. -- econstructor; auto. * eapply H; eauto. * simpl; reflexivity. + inv H0; EqDep_subst. econstructor; eauto. + subst. inv H0; EqDep_subst. econstructor; simpl; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. ++ econstructor; eauto. ++ econstructor 8; eauto. - inv H; EqDep_subst. econstructor; eauto. Qed. (* End AsyncReadInline. *) (* Section SyncReqInline. *) Lemma Extension_inlineSyncReq {k : Kind} (ea : EActionT type k) : forall rf (isAddr : bool) (read : SyncRead) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads) o uml retv, ESemAction o ea uml retv -> forall newUml, ESemAction_meth_collector (getSyncReq rf isAddr read) o uml newUml -> ESemAction o (inlineSyncReqFile read rf ea) newUml retv. Proof. destruct rf; simpl in *; destruct rfRead;[intros; discriminate|]. induction ea; simpl; intros; inv HIsSync; remember (existsb _ _ ) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_nexists_sync in *; try congruence; destruct read. - inv H0; EqDep_subst. inv H1;[discriminate | | | ]; remember (String.eqb _ _ ) as strb; symmetry in Heqstrb; destruct strb; try rewrite String.eqb_eq in *; try rewrite String.eqb_neq in *; inv HUmlCons; try (destruct Signature_dec); subst; unfold getSyncReq in *; destruct isAddr0; try (simpl in *; congruence); EqDep_subst. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + simpl in *. rewrite (Eqdep.EqdepTheory.UIP_refl _ _ e0) in *. autorewrite with _word_zero in *; inv HESemAction0; EqDep_subst. autorewrite with _word_zero in *; inv HESemAction1; EqDep_subst. do 2 (econstructor; simpl in *; eauto). * repeat intro. destruct (HDisjRegs readRegName); apply H2; simpl; auto. rewrite in_map_iff; eexists; split; eauto. reflexivity. * eapply H; eauto. rewrite (unifyWO retV) in *; assumption. + simpl in *. rewrite (Eqdep.EqdepTheory.UIP_refl _ _ e0) in *. autorewrite with _word_zero in *; inv HESemAction0; EqDep_subst. autorewrite with _word_zero in *; inv HESemAction1; EqDep_subst. autorewrite with _word_zero in *; inv HESemActionCont; EqDep_subst. inv HESemAction0; EqDep_subst. autorewrite with _word_zero in *; inv HESemAction1; EqDep_subst. econstructor; simpl in *; eauto. econstructor 15; simpl in *; eauto. * repeat intro. destruct (HDisjRegs readRegName); apply H2; simpl; auto. rewrite in_map_iff; eexists; split; eauto. reflexivity. * eapply H; eauto. rewrite (unifyWO retV) in *; assumption. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst. + specialize (ESemAction_meth_collector_break _ _ H1) as TMP; dest. econstructor. * instantiate (1 := x0); instantiate (1 := x); auto. * eapply IHea; eauto. * eapply H; eauto. * assumption. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. -inv H; simpl in *; EqDep_subst. inv H0; [ | discriminate | discriminate | discriminate]. inv HUmlCons; econstructor; auto. + simpl in *; auto. + eapply IHea; eauto. - inv H0; simpl in *; EqDep_subst; specialize (ESemAction_meth_collector_break _ _ H1) as TMP; dest. + econstructor; eauto. + econstructor 8; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. inv H0; auto; discriminate. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst. + inv H0; inv HUmlCons. econstructor; eauto. + inv H0; inv HUmlCons. econstructor 13; eauto. - inv H; simpl in *; EqDep_subst. + inv H0; inv HUmlCons. econstructor; auto. * simpl in *; eauto. * eapply IHea; eauto. + inv H0; inv HUmlCons. econstructor 15; auto. * apply HRegVal2. * instantiate (1 := newUml1). simpl in *; eauto. * reflexivity. * eapply IHea; eauto. - inv H0; simpl in *; EqDep_subst. + econstructor; eauto. + econstructor 17; eauto. Qed. Lemma inlineSyncReq_Extension {k : Kind} (ea : EActionT type k): forall rf (read : SyncRead) (isAddr : bool) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads) o newUml retv, ESemAction o (inlineSyncReqFile read rf ea) newUml retv -> exists uml, ESemAction_meth_collector (getSyncReq rf isAddr read) o uml newUml /\ ESemAction o ea uml retv. Proof. induction ea; simpl in *; intros rf read; remember rf as rf'; remember read as read'; destruct rf', read'; intros; simpl in *; rewrite HIsSync in *; remember (existsb _ _ ) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_nexists_sync in *; try congruence; revert Heqrf' Heqread' HIsSync. - remember (String.eqb _ _) as strb; symmetry in Heqstrb; destruct strb; [rewrite String.eqb_eq in *; subst; destruct Signature_dec |rewrite String.eqb_neq in *]. +inv H0; EqDep_subst. inv HESemAction; EqDep_subst; intros. * assert (Syntax.rfRead rf = Sync true reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction0); dest. exists (UmMeth (meth, existT SignT (Bit (Nat.log2_up rfIdxNum), Void) (evalExpr e, WO))::x); split. -- econstructor 5; auto. ++ econstructor; auto. ** instantiate (1 := nil); simpl; repeat intro; auto. ** econstructor; eauto. ++ instantiate (1 := newUml0). repeat intro; simpl. destruct (string_dec readRegName k); subst; [right | left]; intro. ** rewrite in_map_iff in H1; dest. destruct x0; simpl in *; subst. eapply HDisjRegs; eauto. ** destruct H1; congruence. ++ reflexivity. ++ assumption. -- econstructor; eauto. * assert (Syntax.rfRead rf = Sync false reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction0); dest. exists (UmMeth (meth, existT SignT (Bit (Nat.log2_up rfIdxNum), Void) (evalExpr e, WO))::x); split. -- econstructor 5; auto. ++ instantiate (1 := [UmUpd (readRegName, existT (fullType type) (SyntaxKind (Array rfNum rfData)) (evalExpr (Var type (SyntaxKind (Array rfNum rfData)) (evalExpr (BuildArray (fun i0 : Fin.t rfNum => (Var type (SyntaxKind (Array rfIdxNum rfData)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up rfIdxNum))) (evalExpr e) + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i0))))])%kami_expr))))))]); simpl; repeat intro; auto. econstructor; eauto. ** instantiate (2 := nil). intro; simpl; auto. ** do 2 (econstructor; eauto). ** econstructor; auto. --- instantiate (1 := nil); repeat intro; auto. --- econstructor; eauto. ** simpl; auto. ++ instantiate (1 := newUml0). repeat intro; simpl. destruct (string_dec readRegName k); subst; [right | left]; intro. ** rewrite in_map_iff in H1; dest. destruct x0; simpl in *; subst. eapply HDisjRegs; eauto. ** destruct H1; congruence. ++ reflexivity. ++ assumption. -- econstructor; eauto. + inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x); split. * econstructor 4; simpl; eauto. unfold getSyncReq; destruct isAddr; simpl; auto. * econstructor; eauto. + inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x); split. * econstructor 3; simpl; eauto. unfold getSyncReq; destruct isAddr; simpl; auto. * econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemActionCont); dest. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (x0 ++ x); split; auto. apply ESemAction_meth_collector_stitch; auto. econstructor. + instantiate (1 := x); instantiate (1 := x0). intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H1) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs;[left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. + apply H2. + assumption. + reflexivity. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (r, existT (fullType type) k (evalExpr e))::x); split; auto. + econstructor; auto. * simpl; assumption. + econstructor; auto. repeat intro; eapply HDisjRegs. apply (ESemActionMC_Upds_SubList H _ H1). - inv H0; EqDep_subst. + intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea1 _ _ _ _ P0 HIn _ _ _ HEAction); dest. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (x ++ x0); split; auto. * apply ESemAction_meth_collector_stitch; auto. * econstructor; auto. -- intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H0) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs; [left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. -- apply H1. -- assumption. + intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea2 _ _ _ _ P0 HIn _ _ _ HEAction); dest. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (x ++ x0); split; auto. * apply ESemAction_meth_collector_stitch; auto. * econstructor 8; auto. -- intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H0) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs; [left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. -- apply H1. -- assumption. - inv H; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. exists nil; split; auto. + constructor. + econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. + intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (IF ReadArrayConst mask0 i then newArr @[ idx + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i)))) <- ReadArrayConst val i] else newArr)%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))::x); split; auto. * econstructor; eauto; simpl. assumption. * econstructor; eauto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H1). + intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (newArr @[ idx + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i)))) <- ReadArrayConst val i])%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))::x); split; auto. * econstructor; eauto; simpl. assumption. * econstructor 13; eauto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H1). - inv H; EqDep_subst. + intros. assert (Syntax.rfRead rf = Sync isAddr0 reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx)) :: x); split; auto. * econstructor; eauto. simpl; assumption. * econstructor; auto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H1). + intros. assert (Syntax.rfRead rf = Sync isAddr0 reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Array num Data)) (evalExpr (BuildArray (fun i : Fin.t num => (Var type (SyntaxKind (Array idxNum Data)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx) + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i))))])%kami_expr)))) :: x); split; auto. * econstructor; eauto. simpl; assumption. * econstructor 15; auto. -- assumption. -- repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H1). - inv H0; EqDep_subst. + intros. assert (Syntax.rfRead rf = Sync isAddr0 reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x ; split; auto. econstructor; eauto. + intros. assert (Syntax.rfRead rf = Sync isAddr0 reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x ; split; auto. econstructor 17; eauto. Qed. Corollary inlineSyncReq_congruence {k : Kind} (ea1 ea2 : EActionT type k) : (forall o uml retv, ESemAction o ea1 uml retv -> ESemAction o ea2 uml retv) -> forall o newUml retv rf (read : SyncRead) (isAddr : bool) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads), ESemAction o (inlineSyncReqFile read rf ea1) newUml retv -> ESemAction o (inlineSyncReqFile read rf ea2) newUml retv. Proof. intros. specialize (inlineSyncReq_Extension _ _ _ HIsSync HIn H0) as TMP; dest. specialize (H _ _ _ H2). apply (Extension_inlineSyncReq _ _ HIsSync HIn H H1). Qed. Lemma SyncReqInline_inlines {k : Kind} (a : ActionT type k) : forall rf (read : SyncRead) (isAddr : bool) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads) o uml retv, ESemAction o (Action_EAction (inlineSingle a (getSyncReq rf isAddr read))) uml retv -> ESemAction o (inlineSyncReqFile read rf (Action_EAction a)) uml retv. Proof. induction a; simpl in *; intros rf read; remember rf as rf'; remember read as read'; destruct rf', read'; intros; simpl in *; rewrite HIsSync in *; remember (existsb _ _ ) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_nexists_sync in *; try congruence; revert Heqrf' Heqread' HIsSync. - simpl in *; intros; remember (String.eqb _ _) as strb; symmetry in Heqstrb. unfold getSyncReq in *; simpl in *; destruct isAddr, strb; [simpl in Heqstrb; rewrite Heqstrb in *; destruct Signature_dec |rewrite String.eqb_neq in * |simpl in Heqstrb; rewrite Heqstrb; destruct Signature_dec |simpl in Heqstrb; rewrite Heqstrb in *]; simpl in *. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemAction0; EqDep_subst. inv HESemAction; EqDep_subst. intros; do 2 (econstructor; auto). * instantiate (1 := newUmlCont). repeat intro. destruct (HDisjRegs readRegName); apply H1; simpl; auto. rewrite in_map_iff; exists (readRegName, v); split; auto. * reflexivity. * eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; eauto. eapply H; simpl; eauto. + rewrite <- eqb_neq in Heqstrb; rewrite Heqstrb. inv H0; EqDep_subst. econstructor; auto. eapply H; simpl; eauto. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemAction0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemActionCont0; EqDep_subst. inv HESemAction0; EqDep_subst. inv HESemAction; EqDep_subst. econstructor; eauto. econstructor 15; auto. * apply HRegVal. * instantiate (1 := newUmlCont). repeat intro. destruct (HDisjRegs readRegName); apply H1; simpl; auto. rewrite in_map_iff; exists (readRegName, v); split; auto. * reflexivity. * eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; auto. eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; auto. eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eapply H; simpl; eauto. - inv H0; EqDep_subst. econstructor; eauto. + eapply IHa; simpl; eauto. + eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eauto; eapply H; simpl; eauto. - inv H; EqDep_subst; econstructor; eauto; eapply IHa; simpl; eauto. - inv H0; EqDep_subst. + econstructor; eauto. * eapply IHa1; simpl; eauto. * eapply H; simpl; eauto. + econstructor 8; eauto. * eapply IHa2; simpl; eauto. * eapply H; simpl; eauto. - inv H; EqDep_subst; econstructor; eapply IHa; simpl; eauto. Qed. Lemma inline_SyncReqInlines {k : Kind} (a : ActionT type k) rf : forall (read : SyncRead) (isAddr : bool) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads) o uml retv, ESemAction o (inlineSyncReqFile read rf (Action_EAction a)) uml retv -> ESemAction o (Action_EAction (inlineSingle a (getSyncReq rf isAddr read))) uml retv. Proof. intros read isAddr; induction a; intros; auto; simpl; destruct rf; subst; simpl in *; rewrite HIsSync in *; unfold getSyncReq in *; destruct read; remember (existsb _ _ ) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_nexists_sync in *; try congruence. - simpl in *; intros; remember (String.eqb _ _) as strb; symmetry in Heqstrb. destruct isAddr, strb; simpl in *; rewrite Heqstrb; [destruct Signature_dec | | destruct Signature_dec | ]; simpl in *. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst; [ |discriminate]. * econstructor; auto. -- instantiate (1 := newUml). instantiate (1 := [UmUpd (readRegName, existT (fullType type) (SyntaxKind (Bit (Nat.log2_up rfIdxNum))) (evalExpr (Var type (SyntaxKind (Bit (Nat.log2_up rfIdxNum))) (evalExpr e))))]). intro; simpl. destruct (string_dec readRegName k); subst; [right |left ]; intro. ++ rewrite in_map_iff in H0; dest; destruct x; subst. eapply HDisjRegs; eauto. ++ destruct H0; auto. -- repeat econstructor; eauto. repeat intro; auto. -- eapply H; eauto. -- reflexivity. + inv H0; EqDep_subst. econstructor; simpl; eauto. + inv H0; EqDep_subst. econstructor; simpl; eauto. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst; [discriminate| ]. * econstructor; auto. -- instantiate (1 := newUml). instantiate (1 := [UmUpd (readRegName, existT (fullType type) (SyntaxKind (Array rfNum rfData)) (evalExpr (Var type (SyntaxKind (Array rfNum rfData)) (evalExpr (BuildArray (fun i0 : Fin.t rfNum => (Var type (SyntaxKind (Array rfIdxNum rfData)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up rfIdxNum))) (evalExpr e) + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i0))))])%kami_expr))))))]). intro; simpl. destruct (string_dec readRegName k); subst; [right |left ]; intro. ++ rewrite in_map_iff in H0; dest; destruct x; subst. eapply HDisjRegs; eauto. ++ destruct H0; auto. -- repeat econstructor; eauto. repeat intro; auto. -- eapply H; eauto. -- reflexivity. + inv H0; EqDep_subst. econstructor; simpl; eauto. + inv H0; EqDep_subst. econstructor; simpl; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. ++ econstructor; eauto. ++ econstructor 8; eauto. - inv H; EqDep_subst. econstructor; eauto. Qed. (* End SyncReqInline. *) (* Section SyncResInline. *) Lemma Extension_inlineSyncRes {k : Kind} (ea : EActionT type k) : forall rf (isAddr : bool) (read : SyncRead) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads) o uml retv, ESemAction o ea uml retv -> forall newUml, ESemAction_meth_collector (getSyncRes rf isAddr read) o uml newUml -> ESemAction o (inlineSyncResFile read rf ea) newUml retv. Proof. destruct rf; simpl in *; destruct rfRead;[intros; discriminate|]. induction ea; simpl; intros; inv HIsSync; remember (existsb _ _ ) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_nexists_sync in *; try congruence; destruct read. - inv H0; EqDep_subst. inv H1;[discriminate | | | ]; remember (String.eqb _ _ ) as strb; symmetry in Heqstrb; destruct strb; try rewrite String.eqb_eq in *; try rewrite String.eqb_neq in *; inv HUmlCons; try (destruct Signature_dec); subst; unfold getSyncReq in *; destruct isAddr0; try (simpl in *; congruence); EqDep_subst. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + rewrite (Eqdep.EqdepTheory.UIP_refl _ _ e0) in *. autorewrite with _word_zero in *; inv HESemAction0; EqDep_subst. autorewrite with _word_zero in *; inv HESemAction1; EqDep_subst. autorewrite with _word_zero in *; inv HESemAction0; EqDep_subst. econstructor; eauto. + rewrite (Eqdep.EqdepTheory.UIP_refl _ _ e0) in *. autorewrite with _word_zero in *; inv HESemAction0; EqDep_subst. autorewrite with _word_zero in *; inv HESemAction1; EqDep_subst. econstructor 17; simpl in *; eauto. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst. + specialize (ESemAction_meth_collector_break _ _ H1) as TMP; dest. econstructor. * instantiate (1 := x0); instantiate (1 := x); auto. * eapply IHea; eauto. * eapply H; eauto. * assumption. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. -inv H; simpl in *; EqDep_subst. inv H0; [ | discriminate | discriminate | discriminate]. inv HUmlCons; econstructor; auto. + simpl in *; auto. + eapply IHea; eauto. - inv H0; simpl in *; EqDep_subst; specialize (ESemAction_meth_collector_break _ _ H1) as TMP; dest. + econstructor; eauto. + econstructor 8; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst; econstructor; eauto. inv H0; auto; discriminate. - inv H0; simpl in *; EqDep_subst; econstructor; eauto. - inv H; simpl in *; EqDep_subst. + inv H0; inv HUmlCons. econstructor; eauto. + inv H0; inv HUmlCons. econstructor 13; eauto. - inv H; simpl in *; EqDep_subst. + inv H0; inv HUmlCons. econstructor; auto. * simpl in *; eauto. * eapply IHea; eauto. + inv H0; inv HUmlCons. econstructor 15; auto. * apply HRegVal2. * instantiate (1 := newUml1). simpl in *; eauto. * reflexivity. * eapply IHea; eauto. - inv H0; simpl in *; EqDep_subst. + econstructor; eauto. + econstructor 17; eauto. Qed. Lemma inlineSyncRes_Extension {k : Kind} (ea : EActionT type k): forall rf (read : SyncRead) (isAddr : bool) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads) o newUml retv, ESemAction o (inlineSyncResFile read rf ea) newUml retv -> exists uml, ESemAction_meth_collector (getSyncRes rf isAddr read) o uml newUml /\ ESemAction o ea uml retv. Proof. induction ea; simpl in *; intros rf read; remember rf as rf'; remember read as read'; destruct rf', read'; intros; simpl in *; rewrite HIsSync in *; remember (existsb _ _ ) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_nexists_sync in *; try congruence; revert Heqrf' Heqread' HIsSync. - remember (String.eqb _ _) as strb; symmetry in Heqstrb; destruct strb; [rewrite String.eqb_eq in *; subst; destruct Signature_dec |rewrite String.eqb_neq in *]. +inv H0; EqDep_subst; intros. * assert (Syntax.rfRead rf = Sync true reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT (Void, Array rfNum rfData) (WO, (evalExpr (BuildArray (fun i : Fin.t rfNum => (Var type (SyntaxKind (Array rfIdxNum rfData)) regVal @[ Var type (SyntaxKind (Bit (Nat.log2_up rfIdxNum))) idx + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i))))])%kami_expr)))))::x); split. -- econstructor 5; auto. ++ simpl; repeat econstructor; eauto. ++ intro; left; intro; auto. ++ simpl; reflexivity. ++ assumption. -- econstructor; eauto. rewrite (unifyWO (evalExpr e)); simpl; reflexivity. * assert (Syntax.rfRead rf = Sync false reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT (Void, Array rfNum rfData) (WO, regVal))::x); split. -- econstructor 5; auto. ++ simpl; repeat econstructor; eauto. ++ intro; left; intro; auto. ++ simpl; reflexivity. ++ assumption. -- econstructor; eauto. rewrite (unifyWO (evalExpr e)); simpl; reflexivity. + inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x); split. * econstructor 4; simpl; eauto. unfold getSyncRes; destruct isAddr; simpl; auto. * econstructor; eauto. + inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmMeth (meth, existT SignT s (evalExpr e, mret))::x); split. * econstructor 3; simpl; eauto. unfold getSyncRes; destruct isAddr; simpl; auto. * econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemActionCont); dest. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (x0 ++ x); split; auto. apply ESemAction_meth_collector_stitch; auto. econstructor. + instantiate (1 := x); instantiate (1 := x0). intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H1) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs;[left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. + apply H2. + assumption. + reflexivity. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (r, existT (fullType type) k (evalExpr e))::x); split; auto. + econstructor; auto. * simpl; assumption. + econstructor; auto. repeat intro; eapply HDisjRegs. apply (ESemActionMC_Upds_SubList H _ H1). - inv H0; EqDep_subst. + intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea1 _ _ _ _ P0 HIn _ _ _ HEAction); dest. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (x ++ x0); split; auto. * apply ESemAction_meth_collector_stitch; auto. * econstructor; auto. -- intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H0) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs; [left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. -- apply H1. -- assumption. + intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea2 _ _ _ _ P0 HIn _ _ _ HEAction); dest. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (x ++ x0); split; auto. * apply ESemAction_meth_collector_stitch; auto. * econstructor 8; auto. -- intro k0. specialize (HDisjRegs k0). specialize (ESemActionMC_Upds_SubList H) as P1. specialize (ESemActionMC_Upds_SubList H0) as P2. clear - P1 P2 HDisjRegs. destruct HDisjRegs; [left | right]; intro; apply H; rewrite in_map_iff in *; dest; exists x1; split; auto. -- apply H1. -- assumption. - inv H; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. exists nil; split; auto. + constructor. + econstructor; eauto. - inv H0; EqDep_subst. intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x; split; auto. econstructor; eauto. - inv H; EqDep_subst. + intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (IF ReadArrayConst mask0 i then newArr @[ idx + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i)))) <- ReadArrayConst val i] else newArr)%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))::x); split; auto. * econstructor; eauto; simpl. assumption. * econstructor; eauto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H1). + intros. assert (Syntax.rfRead rf = Sync isAddr reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (dataArray, existT (fullType type) (SyntaxKind (Array idxNum Data)) (evalExpr (fold_left (fun (newArr : Expr type (SyntaxKind (Array idxNum Data))) (i : Fin.t num) => (newArr @[ idx + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i)))) <- ReadArrayConst val i])%kami_expr) (getFins num) (Var type (SyntaxKind (Array idxNum Data)) regV))))::x); split; auto. * econstructor; eauto; simpl. assumption. * econstructor 13; eauto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H1). - inv H; EqDep_subst. + intros. assert (Syntax.rfRead rf = Sync isAddr0 reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx)) :: x); split; auto. * econstructor; eauto. simpl; assumption. * econstructor; auto. repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H1). + intros. assert (Syntax.rfRead rf = Sync isAddr0 reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (IHea _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists (UmUpd (readReg, existT (fullType type) (SyntaxKind (Array num Data)) (evalExpr (BuildArray (fun i : Fin.t num => (Var type (SyntaxKind (Array idxNum Data)) regV @[ Var type (SyntaxKind (Bit (Nat.log2_up idxNum))) (evalExpr idx) + Const type (ZToWord _ (Z.of_nat (proj1_sig (Fin.to_nat i))))])%kami_expr)))) :: x); split; auto. * econstructor; eauto. simpl; assumption. * econstructor 15; auto. -- assumption. -- repeat intro. eapply HDisjRegs. specialize (ESemActionMC_Upds_SubList H) as P1. apply (P1 _ H1). - inv H0; EqDep_subst. + intros. assert (Syntax.rfRead rf = Sync isAddr0 reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x ; split; auto. econstructor; eauto. + intros. assert (Syntax.rfRead rf = Sync isAddr0 reads) as P0. { rewrite <- Heqrf'; reflexivity. } rewrite <- Heqrf' in *. specialize (H _ _ _ _ _ P0 HIn _ _ _ HESemAction); dest. exists x ; split; auto. econstructor 17; eauto. Qed. Corollary inlineSyncRes_congruence {k : Kind} (ea1 ea2 : EActionT type k) : (forall o uml retv, ESemAction o ea1 uml retv -> ESemAction o ea2 uml retv) -> forall o newUml retv rf (read : SyncRead) (isAddr : bool) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads), ESemAction o (inlineSyncResFile read rf ea1) newUml retv -> ESemAction o (inlineSyncResFile read rf ea2) newUml retv. Proof. intros. specialize (inlineSyncRes_Extension _ _ _ HIsSync HIn H0) as TMP; dest. specialize (H _ _ _ H2). apply (Extension_inlineSyncRes _ _ HIsSync HIn H H1). Qed. Lemma SyncResInline_inlines {k : Kind} (a : ActionT type k) : forall rf (read : SyncRead) (isAddr : bool) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads) o uml retv, ESemAction o (Action_EAction (inlineSingle a (getSyncRes rf isAddr read))) uml retv -> ESemAction o (inlineSyncResFile read rf (Action_EAction a)) uml retv. Proof. induction a; simpl in *; intros rf read; remember rf as rf'; remember read as read'; destruct rf', read'; intros; simpl in *; rewrite HIsSync in *; remember (existsb _ _ ) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_nexists_sync in *; try congruence; revert Heqrf' Heqread' HIsSync. - simpl in *; intros; remember (String.eqb _ _) as strb; symmetry in Heqstrb. unfold getSyncReq in *; simpl in *; destruct isAddr, strb; simpl in *; rewrite Heqstrb; [destruct Signature_dec | |destruct Signature_dec | ]. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemAction0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemAction0; EqDep_subst. econstructor; eauto. eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; eauto. eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; auto. eapply H; simpl; eauto. + inv H0; EqDep_subst. inv HESemAction; EqDep_subst. inv HESemAction0; EqDep_subst. inv HESemAction; EqDep_subst. econstructor 17; eauto. eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; auto. eapply H; simpl; eauto. + inv H0; EqDep_subst. econstructor; auto. eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eapply H; simpl; eauto. - inv H0; EqDep_subst. econstructor; eauto. + eapply IHa; simpl; eauto. + eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eapply H; simpl; eauto. - inv H0; EqDep_subst; econstructor; eauto; eapply H; simpl; eauto. - inv H; EqDep_subst; econstructor; eauto; eapply IHa; simpl; eauto. - inv H0; EqDep_subst. + econstructor; eauto. * eapply IHa1; simpl; eauto. * eapply H; simpl; eauto. + econstructor 8; eauto. * eapply IHa2; simpl; eauto. * eapply H; simpl; eauto. - inv H; EqDep_subst; econstructor; eapply IHa; simpl; eauto. Qed. Lemma inline_SyncResInlines {k : Kind} (a : ActionT type k) rf : forall (read : SyncRead) (isAddr : bool) (reads : list SyncRead) (HIsSync : rfRead rf = Sync isAddr reads) (HIn : In read reads) o uml retv, ESemAction o (inlineSyncResFile read rf (Action_EAction a)) uml retv -> ESemAction o (Action_EAction (inlineSingle a (getSyncRes rf isAddr read))) uml retv. Proof. intros read isAddr; induction a; intros; auto; simpl; destruct rf; subst; simpl in *; rewrite HIsSync in *; unfold getSyncReq in *; destruct read; remember (existsb _ _ ) as exb; symmetry in Heqexb; destruct exb; try rewrite existsb_nexists_sync in *; try congruence. - simpl in *; intros; remember (String.eqb _ _) as strb; symmetry in Heqstrb. destruct isAddr, strb; simpl in *; rewrite Heqstrb; [destruct Signature_dec | | destruct Signature_dec | ]; simpl in *. + inv H0; EqDep_subst; [ |discriminate]. * econstructor; auto. -- instantiate (2 := nil). intro; auto. -- repeat econstructor; eauto. -- eapply H; eauto. -- reflexivity. + inv H0; EqDep_subst. econstructor; simpl; eauto. + inv H0; EqDep_subst. econstructor; simpl; eauto. + inv H0; EqDep_subst; [discriminate| ]. * econstructor; auto. -- instantiate (2 := nil). intro; auto. -- repeat econstructor; eauto. -- eapply H; eauto. -- reflexivity. + inv H0; EqDep_subst. econstructor; simpl; eauto. + inv H0; EqDep_subst. econstructor; simpl; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. econstructor; eauto. - inv H; EqDep_subst. econstructor; eauto. - inv H0; EqDep_subst. ++ econstructor; eauto. ++ econstructor 8; eauto. - inv H; EqDep_subst. econstructor; eauto. Qed. (* End SyncResInline. *) Lemma inlineEach_inlineSingle_pos (lrf : list RegFileBase): forall k ty (a : ActionT ty k) n, inlineSingle_pos (listRfMethods lrf) a n = apply_nth (eachRfMethodInliners ty k lrf) a n. Proof. induction lrf; simpl; intros. unfold listRfMethods, eachRfMethodInliners; simpl. unfold inlineSingle_pos, apply_nth. remember (nth_error _ _) as err0; remember (nth_error (nil : list (_ -> _)) _ ) as err1. symmetry in Heqerr0, Heqerr1. destruct err0; [apply nth_error_In in Heqerr0; inv Heqerr0|]. destruct err1; [apply nth_error_In in Heqerr1; inv Heqerr1| reflexivity]. unfold listRfMethods, eachRfMethodInliners, inlineSingle_pos, apply_nth in *; simpl. destruct (le_lt_dec (length (getRegFileMethods a)) n). - repeat rewrite nth_error_app2; try rewrite map_length; auto. - repeat rewrite nth_error_app1; try rewrite map_length; auto. remember (nth_error _ _) as err0; remember (nth_error (map _ _) _) as err1. symmetry in Heqerr0, Heqerr1. destruct err0. + eapply (map_nth_error (fun f a' => inlineSingle a' f (k:=k))) in Heqerr0. rewrite Heqerr1 in Heqerr0; rewrite Heqerr0; reflexivity. + rewrite (nth_error_map_None_iff (fun f a' => @inlineSingle ty k a' f)) in Heqerr0. setoid_rewrite Heqerr0 in Heqerr1; rewrite <- Heqerr1; reflexivity. Qed. Lemma inlineEach_inlineSome_pos xs : forall (lrf : list RegFileBase) k ty (a : ActionT ty k), fold_left (inlineSingle_pos (listRfMethods lrf)) xs a = fold_left (apply_nth (eachRfMethodInliners ty k lrf)) xs a. Proof. induction xs; simpl; auto; intros. rewrite inlineEach_inlineSingle_pos, IHxs; reflexivity. Qed. Lemma EgetRegFileMapMethods_getRegFileMethods_len k ty (rf : RegFileBase) : length (EgetRegFileMapMethods ty k rf) = length (getRegFileMethods rf). Proof. unfold EgetRegFileMapMethods, getRegFileMethods. destruct rf, rfRead; simpl. - induction reads; simpl; auto. rewrite <- IHreads. do 2 apply f_equal. do 2 rewrite map_length; reflexivity. - apply f_equal. destruct isAddr; simpl; repeat rewrite app_length; repeat rewrite map_length; reflexivity. Qed. Lemma inlineEach_SingleRf_inlineEeach (rf : RegFileBase) : forall n k (a : ActionT type k), (forall o uml retV, ESemAction o (Action_EAction (apply_nth (map (fun f a' => @inlineSingle type k a' f) (getRegFileMethods rf)) a n)) uml retV -> ESemAction o (apply_nth (EgetRegFileMapMethods type k rf) (Action_EAction a) n) uml retV). Proof. unfold getRegFileMethods, EgetRegFileMapMethods; destruct rf, rfRead; simpl. - unfold apply_nth in *; destruct n; simpl in *; intros. + eapply WrInline_inlines; auto. + unfold readRegFile in H. remember (nth_error _ _) as err0. remember (nth_error (map (fun x => _) reads) n) as err1. symmetry in Heqerr0, Heqerr1. destruct err1. * rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. -- rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H2; dest. rewrite <- H4 in H3. eapply AsyncReadInline_inlines; simpl; eauto using nth_error_In. rewrite H0 in H2; inv H2; simpl; assumption. -- exfalso. repeat rewrite <- nth_error_map_None_iff in Heqerr0. rewrite H0 in Heqerr0; inv Heqerr0. * rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr1; discriminate. - unfold apply_nth in *; destruct n; simpl in *; intros. + eapply WrInline_inlines; auto. + unfold readSyncRegFile in H. remember (nth_error _ _) as err0. remember (nth_error ((map _ _ ) ++ (map _ _ )) _) as err1. symmetry in Heqerr0, Heqerr1. destruct (le_lt_dec (length reads) n), isAddr. * rewrite nth_error_app2 in Heqerr1; rewrite map_length in *;[| assumption]. rewrite map_app in Heqerr0. rewrite nth_error_app2 in Heqerr0; repeat rewrite map_length in *; [| assumption]. destruct err1. -- rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. ++ rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H2; dest. rewrite <- H4 in H3. eapply SyncResInline_inlines; simpl; eauto using nth_error_In. rewrite H0 in H2; inv H2; simpl; assumption. ++ exfalso. repeat rewrite <- nth_error_map_None_iff in Heqerr0. rewrite H0 in Heqerr0; inv Heqerr0. -- rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr1; discriminate. * rewrite nth_error_app2 in Heqerr1; rewrite map_length in *;[| assumption]. rewrite map_app in Heqerr0. rewrite nth_error_app2 in Heqerr0; repeat rewrite map_length in *; [| assumption]. destruct err1. -- rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. ++ rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H2; dest. rewrite <- H4 in H3. eapply SyncResInline_inlines; simpl; eauto using nth_error_In. rewrite H0 in H2; inv H2; simpl; assumption. ++ exfalso. repeat rewrite <- nth_error_map_None_iff in Heqerr0. rewrite H0 in Heqerr0; inv Heqerr0. -- rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr1; discriminate. * rewrite nth_error_app1 in Heqerr1;[| rewrite map_length in *; assumption]. rewrite map_app in Heqerr0. rewrite nth_error_app1 in Heqerr0; repeat rewrite map_length in *; [| assumption]. destruct err1. -- rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. ++ rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H2; dest. rewrite <- H4 in H3. eapply SyncReqInline_inlines; simpl; eauto using nth_error_In. rewrite H0 in H2; inv H2; simpl; assumption. ++ exfalso. repeat rewrite <- nth_error_map_None_iff in Heqerr0. rewrite H0 in Heqerr0; inv Heqerr0. -- rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr1; discriminate. * rewrite nth_error_app1 in Heqerr1;[| rewrite map_length in *; assumption]. rewrite map_app in Heqerr0. rewrite nth_error_app1 in Heqerr0; repeat rewrite map_length in *; [| assumption]. destruct err1. -- rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. ++ rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H2; dest. rewrite <- H4 in H3. eapply SyncReqInline_inlines; simpl; eauto using nth_error_In. rewrite H0 in H2; inv H2; simpl; assumption. ++ exfalso. repeat rewrite <- nth_error_map_None_iff in Heqerr0. rewrite H0 in Heqerr0; inv Heqerr0. -- rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr1; discriminate. Qed. Lemma inlineEeach_SingleRf_inlineEach (rf : RegFileBase) : forall n k (a : ActionT type k), (forall o uml retV, ESemAction o (apply_nth (EgetRegFileMapMethods type k rf) (Action_EAction a) n) uml retV -> ESemAction o (Action_EAction (apply_nth (map (fun f a' => @inlineSingle type k a' f) (getRegFileMethods rf)) a n)) uml retV). Proof. unfold getRegFileMethods, EgetRegFileMapMethods; destruct rf, rfRead; simpl. - unfold apply_nth in *; destruct n; simpl in *; intros. + specialize (inline_WrInlines _ _ H); auto. + unfold readRegFile. remember (nth_error _ _) as err0. remember (nth_error (map _ (map _ reads)) n) as err1. symmetry in Heqerr0, Heqerr1. destruct err1. * rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. -- rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite <- H4. rewrite <- H3 in H. assert (rfRead {| rfIsWrMask := rfIsWrMask; rfNum := rfNum; rfDataArray := rfDataArray; rfRead := Async reads; rfWrite := rfWrite; rfIdxNum := rfIdxNum; rfData := rfData; rfInit := rfInit |} = Async reads) as P0. { auto. } specialize (inline_AsyncReadInlines _ _ P0 _ (nth_error_In _ _ H2) H) as P1. unfold getAsyncReads in P1; simpl in *. rewrite H0 in H2; inv H2; assumption. -- exfalso. repeat rewrite <- nth_error_map_None_iff in Heqerr0. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr0; inv Heqerr0. * rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite <- nth_error_map_None_iff in Heqerr1. rewrite nth_error_map_iff in Heqerr0; dest. rewrite H0 in Heqerr1; discriminate. - unfold apply_nth in *; destruct n; simpl in *; intros. + specialize (inline_WrInlines _ _ H); auto. + unfold readSyncRegFile. remember (nth_error _ _) as err0. remember (nth_error (map _ (if isAddr then _ else _ )) _) as err1. symmetry in Heqerr0, Heqerr1. destruct (le_lt_dec (length reads) n), isAddr; rewrite map_app in *. * rewrite nth_error_app2 in Heqerr1; repeat rewrite map_length in *;[| assumption]. rewrite nth_error_app2 in Heqerr0; repeat rewrite map_length in *; [| assumption]. destruct err1. -- rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. ++ rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite <- H4. rewrite <- H3 in H. assert (rfRead {| rfIsWrMask := rfIsWrMask; rfNum := rfNum; rfDataArray := rfDataArray; rfRead := Sync true reads; rfWrite := rfWrite; rfIdxNum := rfIdxNum; rfData := rfData; rfInit := rfInit |} = Sync true reads) as P0. { auto. } specialize (inline_SyncResInlines _ _ _ P0 (nth_error_In _ _ H2) H) as P1. simpl in *. rewrite H0 in H2; inv H2; simpl; assumption. ++ exfalso. rewrite <- nth_error_map_None_iff in Heqerr0. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr0; inv Heqerr0. -- rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite <- nth_error_map_None_iff in Heqerr1. rewrite H0 in Heqerr1; discriminate. * rewrite nth_error_app2 in Heqerr1; repeat rewrite map_length in *;[| assumption]. rewrite nth_error_app2 in Heqerr0; rewrite map_length in *; [| assumption]. destruct err1. -- rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. ++ rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite <- H4. rewrite <- H3 in H. assert (rfRead {| rfIsWrMask := rfIsWrMask; rfNum := rfNum; rfDataArray := rfDataArray; rfRead := Sync false reads; rfWrite := rfWrite; rfIdxNum := rfIdxNum; rfData := rfData; rfInit := rfInit |} = Sync false reads) as P0. { auto. } specialize (inline_SyncResInlines _ _ _ P0 (nth_error_In _ _ H2) H) as P1. rewrite H0 in H2; inv H2; simpl; assumption. ++ exfalso. repeat rewrite <- nth_error_map_None_iff in Heqerr0. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr0; inv Heqerr0. -- rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite <- nth_error_map_None_iff in Heqerr1; dest. rewrite H0 in Heqerr1; discriminate. * rewrite nth_error_app1 in Heqerr1;[| repeat rewrite map_length in *; assumption]. rewrite nth_error_app1 in Heqerr0; repeat rewrite map_length in *; [| assumption]. destruct err1. -- rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. ++ rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite <- H4. rewrite <- H3 in H. assert (rfRead {| rfIsWrMask := rfIsWrMask; rfNum := rfNum; rfDataArray := rfDataArray; rfRead := Sync true reads; rfWrite := rfWrite; rfIdxNum := rfIdxNum; rfData := rfData; rfInit := rfInit |} = Sync true reads) as P0. { auto. } specialize (inline_SyncReqInlines _ _ _ P0 (nth_error_In _ _ H2) H) as P1. rewrite H0 in H2; inv H2; simpl; assumption. ++ exfalso. rewrite <- nth_error_map_None_iff in Heqerr0. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr0; inv Heqerr0. -- rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite <- nth_error_map_None_iff in Heqerr1. rewrite H0 in Heqerr1; discriminate. * rewrite nth_error_app1 in Heqerr1;[| repeat rewrite map_length in *; assumption]. rewrite nth_error_app1 in Heqerr0; repeat rewrite map_length in *; [| assumption]. destruct err1. -- rewrite nth_error_map_iff in Heqerr1; dest. rewrite <- H1. destruct err0. ++ rewrite nth_error_map_iff in Heqerr0; dest. rewrite nth_error_map_iff in H0; dest. rewrite <- H4. rewrite <- H3 in H. assert (rfRead {| rfIsWrMask := rfIsWrMask; rfNum := rfNum; rfDataArray := rfDataArray; rfRead := Sync false reads; rfWrite := rfWrite; rfIdxNum := rfIdxNum; rfData := rfData; rfInit := rfInit |} = Sync false reads) as P0. { auto. } specialize (inline_SyncReqInlines _ _ _ P0 (nth_error_In _ _ H2) H) as P1. rewrite H0 in H2; inv H2; simpl; assumption. ++ exfalso. rewrite <- nth_error_map_None_iff in Heqerr0. rewrite nth_error_map_iff in H0; dest. rewrite H0 in Heqerr0; inv Heqerr0. -- rewrite <- nth_error_map_None_iff in Heqerr1. destruct err0;[|assumption]. exfalso. rewrite nth_error_map_iff in Heqerr0; dest. rewrite <- nth_error_map_None_iff in Heqerr1; dest. rewrite H0 in Heqerr1; discriminate. Qed. Lemma inlineEach_Singlelist_inlineEeach (lrf : list RegFileBase): forall n k (a : ActionT type k), (forall o uml retV, ESemAction o (Action_EAction (apply_nth (eachRfMethodInliners _ k lrf) a n)) uml retV -> ESemAction o (apply_nth (EeachRfMethodInliners _ k lrf) (Action_EAction a) n) uml retV). Proof. induction lrf; intros. - unfold eachRfMethodInliners, EeachRfMethodInliners in *; simpl in *. unfold apply_nth in *. rewrite nth_error_nil_None; rewrite nth_error_nil_None in H. assumption. - unfold eachRfMethodInliners, EeachRfMethodInliners in *. destruct (le_lt_dec (length (getRegFileMethods a)) n). + unfold apply_nth in *; simpl in *. rewrite nth_error_app2 in H; try rewrite map_length in *; auto. rewrite app_comm_cons; rewrite nth_error_app2. * fold (EgetRegFileMapMethods type k a). rewrite EgetRegFileMapMethods_getRegFileMethods_len. apply IHlrf; auto. * erewrite <-EgetRegFileMapMethods_getRegFileMethods_len in l; eauto. + unfold apply_nth in *; simpl in *. rewrite nth_error_app1 in H; try rewrite map_length in *; auto. rewrite app_comm_cons; rewrite nth_error_app1. * eapply inlineEach_SingleRf_inlineEeach. assumption. * erewrite <-EgetRegFileMapMethods_getRegFileMethods_len in l; eauto. Qed. Lemma inlineEeach_Singlelist_inlineEach (lrf : list RegFileBase): forall n k (a : ActionT type k), (forall o uml retV, ESemAction o (apply_nth (EeachRfMethodInliners _ k lrf) (Action_EAction a) n) uml retV ->ESemAction o (Action_EAction (apply_nth (eachRfMethodInliners _ k lrf) a n)) uml retV). Proof. induction lrf; intros. - unfold eachRfMethodInliners, EeachRfMethodInliners in *; simpl in *. unfold apply_nth in *. rewrite nth_error_nil_None; rewrite nth_error_nil_None in H. assumption. - unfold eachRfMethodInliners, EeachRfMethodInliners in *. destruct (le_lt_dec (length (getRegFileMethods a)) n). + unfold apply_nth in *; simpl in *. rewrite nth_error_app2; try rewrite map_length in *; auto. rewrite app_comm_cons, nth_error_app2 in H. * fold (EgetRegFileMapMethods type k a) in H. rewrite EgetRegFileMapMethods_getRegFileMethods_len in H. apply IHlrf; auto. * erewrite <- EgetRegFileMapMethods_getRegFileMethods_len in l; eauto. + unfold apply_nth in *; simpl in *. rewrite nth_error_app1; try rewrite map_length in *; auto. rewrite app_comm_cons, nth_error_app1 in H. * eapply inlineEeach_SingleRf_inlineEach. assumption. * erewrite <-EgetRegFileMapMethods_getRegFileMethods_len in l; eauto. Qed. Lemma inlineEeach_Single_Congruence (rf : RegFileBase) : forall n k (ea1 ea2 : EActionT type k), (forall o uml retV, ESemAction o ea1 uml retV -> ESemAction o ea2 uml retV) -> (forall o uml retV, ESemAction o (apply_nth (EgetRegFileMapMethods type k rf) ea1 n) uml retV -> ESemAction o (apply_nth (EgetRegFileMapMethods type k rf) ea2 n) uml retV). Proof. unfold EgetRegFileMapMethods; destruct rf, rfRead; simpl. - unfold apply_nth in *; destruct n; simpl in *; intros. + eapply inlineWrites_congruence; eauto. + remember (nth_error _ _) as err0. symmetry in Heqerr0; destruct err0; eauto. rewrite nth_error_map_iff in Heqerr0; dest. rewrite <- H2 in *. eapply inlineAsyncRead_congruence; simpl; eauto using nth_error_In. - unfold apply_nth in *; destruct n; simpl in *; intros. + eapply inlineWrites_congruence; eauto. + remember (nth_error _ _) as err0. symmetry in Heqerr0. destruct (le_lt_dec (length reads) n). * rewrite nth_error_app2 in Heqerr0; rewrite map_length in *; [| assumption]. destruct err0; eauto. rewrite nth_error_map_iff in Heqerr0; dest. rewrite <- H2 in *. eapply inlineSyncRes_congruence; simpl in *; eauto using nth_error_In. * rewrite nth_error_app1 in Heqerr0;[| rewrite map_length; assumption]. destruct err0; eauto. rewrite nth_error_map_iff in Heqerr0; dest. rewrite <- H2 in *. eapply inlineSyncReq_congruence; simpl in *; eauto using nth_error_In. Qed. Lemma inlineEeach_SingleList_Congruence (lrf : list RegFileBase) : forall n k (ea1 ea2 : EActionT type k), (forall o uml retV, ESemAction o ea1 uml retV -> ESemAction o ea2 uml retV) -> (forall o uml retV, ESemAction o (apply_nth (EeachRfMethodInliners type k lrf) ea1 n) uml retV -> ESemAction o (apply_nth (EeachRfMethodInliners type k lrf) ea2 n) uml retV). Proof. induction lrf; unfold EeachRfMethodInliners; simpl; intros. - unfold apply_nth in *. rewrite nth_error_nil_None in *; auto. - unfold apply_nth in *; rewrite app_comm_cons in *. destruct (le_lt_dec (length (EgetRegFileMapMethods type k a)) n). + rewrite nth_error_app2 in *; eauto. + rewrite nth_error_app1 in *; eauto. eapply inlineEeach_Single_Congruence; eauto. Qed. Lemma inlineEeach_Some_Congruence xs : forall (lrf : list RegFileBase) k (ea1 ea2 : EActionT type k), (forall o uml retV, ESemAction o ea1 uml retV -> ESemAction o ea2 uml retV) -> (forall o uml retV, ESemAction o (fold_left (apply_nth (EeachRfMethodInliners type k lrf)) xs ea1) uml retV -> ESemAction o (fold_left (apply_nth (EeachRfMethodInliners type k lrf)) xs ea2) uml retV). Proof. induction xs; simpl; eauto; intros. eapply IHxs. - eapply inlineEeach_SingleList_Congruence; eauto. - assumption. Qed. Lemma inlineEach_Somelist_inlineEeach (lrf : list RegFileBase) xs : forall k (a : ActionT type k), (forall o uml retV, ESemAction o (Action_EAction (fold_left (apply_nth (eachRfMethodInliners _ k lrf)) xs a)) uml retV -> ESemAction o (fold_left (apply_nth (EeachRfMethodInliners _ k lrf)) xs (Action_EAction a)) uml retV). Proof. induction xs; simpl in *; auto; intros. eapply inlineEeach_Some_Congruence. - eapply inlineEach_Singlelist_inlineEeach. - eapply IHxs; assumption. Qed. Lemma inlineEeach_Somelist_inlineEach (lrf : list RegFileBase) xs : forall k (a : ActionT type k), (forall o uml retV, ESemAction o (fold_left (apply_nth (EeachRfMethodInliners _ k lrf)) xs (Action_EAction a)) uml retV -> ESemAction o (Action_EAction (fold_left (apply_nth (eachRfMethodInliners _ k lrf)) xs a)) uml retV). Proof. induction xs; simpl in *; auto; intros. eapply inlineEeach_Some_Congruence in H. - eapply IHxs; apply H. - eapply inlineEeach_Singlelist_inlineEach. Qed. Lemma ESameOldLoop o: forall rules old upds calls retl lrf, @SemCompActionT Void (compileRulesRf type (o, nil) (rev rules) lrf) (old, upds) calls retl -> o = old. Proof. induction rules; simpl in *; intros. - rewrite (unifyWO retl) in H. inv H; EqDep_subst. inv HRegMapWf. inv H. reflexivity. - unfold compileRulesRf, compileActionsRf in *; simpl in *. setoid_rewrite <- fold_left_rev_right in IHrules. rewrite map_app, <- fold_left_rev_right, map_rev in *. simpl in *. rewrite rev_app_distr, rev_involutive in *; simpl in *. rewrite (unifyWO retl) in H. inv H; EqDep_subst. apply Eqdep.EqdepTheory.inj_pair2 in H4; subst; simpl in *. destruct regMap_a. specialize (IHrules _ _ _ _ _ HSemCompActionT_a); subst. rewrite (unifyWO WO) in HSemCompActionT_cont. inv HSemCompActionT_cont; simpl in *; EqDep_subst. rewrite (unifyWO val_a0) in HSemCompActionT_a0. inv HSemCompActionT_a0; simpl in *; EqDep_subst. destruct regMap_a; inv HRegMapWf; inv H; inv HSemRegMap. apply (ESameOldAction _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont0). Qed. Lemma CompileRules_Congruence rules (b : BaseModule) (lrf : list RegFileBase) : let m := inlineAll_All_mod (mergeSeparatedSingle b lrf) in forall o upds calls retl (HConsist : getKindAttr o = getKindAttr (getRegisters m)) (HSubList1 : SubList (listRfMethods lrf) (getMethods m)) (HSubList2 : SubList rules (getRules b)) (HWfMod : WfMod type (mergeSeparatedSingle b lrf)), SemCompActionT (compileRulesRf type (o, []) (rev rules) lrf) (o, upds) calls retl -> SemCompActionT (compileRules type (o, []) (map (inline_Rules (getAllMethods (mergeSeparatedBaseFile lrf)) (seq 0 (Datatypes.length (getAllMethods (mergeSeparatedBaseFile lrf))))) (rev rules))) (o, upds) calls retl. Proof. unfold compileRulesRf, compileRules, compileActionsRf, compileActions. setoid_rewrite <-fold_left_rev_right at 2 3; repeat setoid_rewrite <-map_rev; repeat rewrite rev_involutive. induction rules; simpl; intros; auto. rewrite (unifyWO retl) in H3; inv H3; simpl in *; EqDep_subst. rewrite (unifyWO WO) in HSemCompActionT_cont; inv HSemCompActionT_cont; simpl in *; EqDep_subst. destruct regMap_a, regMap_a0. rewrite (unifyWO val_a0) in HSemCompActionT_a0; inv HSemCompActionT_a0; simpl in *; EqDep_subst. specialize (ESameOldAction _ _ _ _ (SemVarRegMap _) HSemCompActionT_cont0) as TMP; subst. unfold WfRegMapExpr in *; dest. inv H3; inv HSemRegMap. rewrite <- (app_nil_l calls_cont0). assert (SubList rules (getRules b)) as P0. { repeat intro; apply H1; right; assumption. } repeat (econstructor; eauto); try (apply H4; auto); destruct a; simpl. unfold preCompileRegFiles in *; simpl in *. assert (allMeths_merge_listRf : forall lrf', getAllMethods (mergeSeparatedBaseFile lrf') = listRfMethods lrf'). { clear. induction lrf'; simpl; unfold listRfMethods; simpl; eauto. rewrite IHlrf'; reflexivity. } rewrite allMeths_merge_listRf, inlineEach_inlineSome_pos, <- Extension_Compiles_iff. assert (NoDup (map fst o)) as P1. { unfold mergeSeparatedSingle in H2; inv H2. rewrite (getKindAttr_map_fst _ _ H), map_app, NoDup_app_iff; repeat split. - inv HWf1; unfold WfBaseModule in HWfBaseModule; dest; assumption. - clear - HWf2. induction lrf; simpl in *; [constructor|]. inv HWf2; inv HWf1; unfold WfBaseModule in *; dest. rewrite map_app, NoDup_app_iff; repeat split; auto. + repeat intro. specialize (HDisjRegs a0); clear - HDisjRegs H4 H5; inv HDisjRegs; contradiction. + repeat intro. specialize (HDisjRegs a0); clear - HDisjRegs H4 H5; inv HDisjRegs; contradiction. - repeat intro. specialize (HDisjRegs a0); clear - HDisjRegs H2 H3; inv HDisjRegs; contradiction. - repeat intro. specialize (HDisjRegs a0); clear - HDisjRegs H2 H3; inv HDisjRegs; contradiction. } specialize (PriorityUpds_exist _ P1 ([]::upds0) (ltac:(eapply H4; eauto)) (ltac:(eapply H4; eauto))) as TMP; dest. eapply ECompCongruence with (old := o) (o := x); auto. - intros; eapply H4; eauto. - symmetry; eapply prevPrevRegsTrue; eauto. - unfold WfRegMapExpr; split. + econstructor. + assumption. - instantiate (1 := inlineAll_All_mod (mergeSeparatedSingle b lrf)); simpl. rewrite <- (prevPrevRegsTrue H3); assumption. - unfold WfBaseModule in H2; dest. unfold eachRfMethodInliners. rewrite <- map_map, <- concat_map. apply WfBaseMod_inlineSome_map; auto. + specialize (flatten_inline_everything_Wf (Build_ModWf H2)) as P2. unfold flatten_inline_everything in P2; rewrite WfMod_createHide in P2; dest; simpl in *; inv H6; assumption. +unfold mergeSeparatedSingle in H2; inv H2; inv HWf1. unfold WfBaseModule in *; dest. specialize (H2 _ (H1 _ (or_introl eq_refl))); simpl in H2. eapply WfExpand; eauto. unfold inlineAll_All_mod; simpl; apply SubList_app_r, SubList_refl. - apply inlineEeach_Somelist_inlineEach. - rewrite (unifyWO retl); simpl. assert (forall lrf, length (listRfMethods lrf) = length (EeachRfMethodInliners type Void lrf)). { clear. unfold listRfMethods, EeachRfMethodInliners. repeat rewrite <- flat_map_concat_map. induction lrf; auto. unfold getRegFileMethods; destruct a; simpl. repeat rewrite app_length; rewrite <- IHlrf; clear. apply f_equal; apply f_equal2; auto. destruct rfRead. - unfold readRegFile. repeat rewrite map_length; reflexivity. - unfold readSyncRegFile; destruct isAddr; repeat rewrite app_length; repeat rewrite map_length; reflexivity. } setoid_rewrite H5. assumption. Qed. Lemma EEquivLoop (b : BaseModule) (lrf : list RegFileBase) o : let m := inlineAll_All_mod (mergeSeparatedSingle b lrf) in forall rules upds calls retl ls (HWfMod : WfMod type (mergeSeparatedSingle b lrf)) (HTrace : Trace m o ls) (HNoSelfCalls : NoSelfCallBaseModule m) (HNoSelfCallsBase : NoSelfCallBaseModule b), SubList rules (getRules b) -> @SemCompActionT Void (compileRulesRf type (o, nil) rules lrf) (o, upds) calls retl -> (forall u, In u upds -> (NoDup (map fst u)) /\ SubList (getKindAttr u) (getKindAttr o)) /\ exists o' (ls' : list (list FullLabel)), PriorityUpds o upds o' /\ upds = (map getLabelUpds ls') /\ (map Rle (map fst (rev rules))) = getLabelExecs (concat ls') /\ calls = concat (map getLabelCalls (rev ls')) /\ Trace m o' (ls' ++ ls). Proof. intros. specialize (mergeFile_noCalls lrf) as P0. assert ( forall (meth : DefMethT) (ty : Kind -> Type), In meth (getAllMethods (mergeSeparatedBaseFile lrf)) -> forall arg : ty (fst (projT1 (snd meth))), NeverCallActionT (projT2 (snd meth) ty arg)). { revert P0; clear. induction lrf; simpl; intros; [contradiction|]. rewrite in_app_iff in H; inv H. - specialize (RegFileBase_noCalls a) as P1. inv P1; inv HNCBaseModule; eauto. - inv P0. eapply IHlrf; eauto. } assert ( map fst (rev rules) = map fst (rev (map (inline_Rules (getAllMethods (mergeSeparatedBaseFile lrf)) (seq 0 (Datatypes.length (getAllMethods (mergeSeparatedBaseFile lrf))))) rules))) as P2. { rewrite <- map_rev. rewrite SameKeys_inlineSome_Rules_map; reflexivity. } rewrite P2. eapply EquivLoop'; eauto; simpl. - rewrite map_app, NoDup_app_iff; repeat split; auto; inv HWfMod. + inv HWf1; inv HWfBaseModule; dest; assumption. + clear - HWf2; induction lrf; simpl; [constructor| inv HWf2]. rewrite map_app, NoDup_app_iff; repeat split; eauto. * inv HWf1; inv HWfBaseModule; dest; assumption. * repeat intro; specialize (HDisjRegs a0); clear - HDisjRegs H H0; inv HDisjRegs; contradiction. * repeat intro; specialize (HDisjRegs a0); clear - HDisjRegs H H0; inv HDisjRegs; contradiction. + repeat intro; specialize (HDisjRegs a); clear - HDisjRegs H2 H3; inv HDisjRegs; contradiction. + repeat intro; specialize (HDisjRegs a); clear - HDisjRegs H2 H3; inv HDisjRegs; contradiction. - unfold inlineAll_All_mod, inlineAll_All, inlineAll_Meths; simpl. rewrite inlineAll_Meths_RegFile_fold_flat, inlineAll_Rules_NoCalls, inlineAll_Rules_in; eauto; simpl in *. rewrite getAllRules_mergeBaseFile, app_nil_r. inv HNoSelfCallsBase; unfold NoSelfCallMethsBaseModule, NoSelfCallRulesBaseModule in *. apply SubList_map. erewrite inlineSome_Meths_pos_NoCalls_ident'; eauto using SubList_refl. unfold inlineAll_Rules. erewrite inlineSome_Rules_pos_NoCalls_ident'; eauto. rewrite SameKindAttrs_inlineSome_Flat; apply SubList_refl. - setoid_rewrite <- (rev_involutive rules). eapply CompileRules_Congruence. + apply (Trace_sameRegs HTrace). + simpl; unfold inlineAll_Meths. rewrite inlineAll_Meths_RegFile_fold_flat; simpl. * repeat intro; rewrite in_app_iff; right. clear - H2. unfold listRfMethods in *; simpl in *. induction lrf; simpl in *; auto. rewrite in_app_iff in *; inv H2; auto. * assumption. + repeat intro. rewrite <-in_rev in H2; apply H; assumption. + assumption. + rewrite rev_involutive. apply H0. Qed. Lemma inlineSingle_pos_NoCall_persistent xs: forall ty k (a : ActionT ty k) (l l' : list DefMethT), (forall f, In f l' -> (forall v, NeverCallActionT (projT2 (snd f) ty v))) -> NoCallActionT l a -> NoCallActionT l (fold_left (inlineSingle_pos l') xs a). Proof. induction xs; simpl; auto; intros. eapply IHxs; eauto; unfold inlineSingle_pos; destruct (nth_error _ _) eqn:G; auto. apply NeverCall_inline_persistent; eauto using nth_error_In. Qed. Lemma inlineFlat_persistent xs : forall (l l' l'': list DefMethT), (forall meth ty, In meth l -> (forall v, NeverCallActionT (projT2 (snd meth) ty v))) -> (forall meth ty, In meth l' -> (forall v, NoCallActionT l'' (projT2 (snd meth) ty v))) -> (forall meth ty, In meth (fold_left (inlineSingle_Flat_pos l) xs l') -> (forall v, NoCallActionT l'' (projT2 (snd meth) ty v))). Proof. induction xs; simpl; auto; intros. eapply IHxs with (l := l) (l' := (inlineSingle_Flat_pos l l' a)); auto; intros. unfold inlineSingle_Flat_pos in H2; destruct (nth_error _ _) eqn:G; auto. rewrite in_map_iff in H2; dest; destruct x, s0, d; subst; simpl in *. destruct (String.eqb s0 s); simpl in *. - specialize (H0 _ ty0 H3 v0); assumption. - apply NeverCall_inline_persistent; eauto using nth_error_In. specialize (H0 _ ty0 H3 v0); assumption. Qed. Lemma inlineFlat_ident' xs : forall (l l' : list DefMethT), (forall meth ty, In meth l' -> (forall v, NeverCallActionT (projT2 (snd meth) ty v))) -> (forall meth ty, In meth (map (inline_Meths l' xs) l) -> (forall v, NoCallActionT (subseq_list l' xs) (projT2 (snd meth) ty v))). Proof. intros; rewrite in_map_iff in H0; dest; subst. unfold inline_Meths in *; destruct x, s0; simpl in *. apply NeverCall_inlineSome_pos_full; eauto. Qed. Lemma NoSelfCall_BaseModule_extension (b : BaseModule) (lrf : list RegFileBase) : forall (HDisjKeys : DisjKey (getMethods b) (getAllMethods (mergeSeparatedBaseFile lrf))), NoSelfCallBaseModule b -> (NoSelfCallBaseModule (inlineAll_All_mod (mergeSeparatedSingle b lrf))). Proof. specialize (NeverCallMod_NeverCalls (mergeFile_noCalls lrf)) as TMP; dest. unfold inlineAll_All_mod, inlineAll_All, inlineAll_Meths, NoSelfCallBaseModule, NoSelfCallRulesBaseModule, NoSelfCallMethsBaseModule; simpl; repeat intro; dest; split; intros; rewrite getAllRules_mergeBaseFile in *. - rewrite inlineAll_Meths_RegFile_fold_flat, app_nil_r in *; eauto. erewrite inlineSome_Meths_pos_NoCalls_ident' in *; eauto using SubList_refl. rewrite inlineAll_Rules_NoCalls in H3. unfold inlineAll_Rules at 2 in H3; erewrite inlineSome_Rules_pos_NoCalls_ident' in H3; eauto. + unfold inlineAll_Rules in H3; rewrite inline_Rules_eq_inlineSome, in_map_iff in H3; dest; subst; destruct x; simpl. apply NoCallActionT_Stitch. * eapply SignatureReplace_NoCall with (ls := (getMethods b)); eauto using SameKindAttrs_inlineSome_Flat. apply inlineSingle_pos_NoCall_persistent; eauto. apply (H1 _ ty H4). * eapply SignatureReplace_NoCall;[apply f_equal, (subseq_list_all (getAllMethods (mergeSeparatedBaseFile lrf)))|]. apply NeverCall_inlineSome_pos_full; auto. + rewrite SameKindAttrs_inlineSome_Flat; apply SubList_refl. - rewrite inlineAll_Meths_RegFile_fold_flat in *; auto. erewrite inlineSome_Meths_pos_NoCalls_ident' in *; eauto using SubList_refl. rewrite in_app_iff in H3; inv H3. + apply NoCallActionT_Stitch. * eapply SignatureReplace_NoCall with (ls := (getMethods b)); eauto using SameKindAttrs_inlineSome_Flat. eapply inlineFlat_persistent; intros; eauto. * rewrite inline_Meths_eq_inlineSome in H4; auto. rewrite <- (subseq_list_all (getAllMethods (_ _))). eapply inlineFlat_ident'; eauto. + apply NeverCall_NoCalls; eauto. Qed. Lemma EEquivLoop' (b : BaseModule) (lrf : list RegFileBase) o : let m := inlineAll_All_mod (mergeSeparatedSingle b lrf) in forall rules upds calls retl ls (HWfMod : WfMod type (mergeSeparatedSingle b lrf)) (HTrace : Trace m o ls) (HNoSelfCallsBase : NoSelfCallBaseModule b), SubList rules (getRules b) -> @SemCompActionT Void (compileRulesRf type (o, nil) rules lrf) (o, upds) calls retl -> (forall u, In u upds -> (NoDup (map fst u)) /\ SubList (getKindAttr u) (getKindAttr o)) /\ exists o' (ls' : list (list FullLabel)), PriorityUpds o upds o' /\ upds = (map getLabelUpds ls') /\ (map Rle (map fst (rev rules))) = getLabelExecs (concat ls') /\ calls = concat (map getLabelCalls (rev ls')) /\ Trace m o' (ls' ++ ls). Proof. intros; eapply EEquivLoop; eauto. inv HWfMod; apply NoSelfCall_BaseModule_extension; auto. Qed. Lemma PriorityUpds_Equiv' : forall old upds new, NoDup (map fst old) -> (forall u, In u upds -> NoDup (map fst u)) -> PriorityUpds old upds new -> (forall new', PriorityUpds old upds new' -> new = new'). Proof. intros. specialize (PriorityUpds_Equiv H H0 H1 H2) as P0. assert (map fst old = map fst new) as P1. { do 2 rewrite <- fst_getKindAttr. setoid_rewrite <- (prevPrevRegsTrue H1); reflexivity. } assert (map fst old = map fst new') as P2. { do 2 rewrite <- fst_getKindAttr. setoid_rewrite <- (prevPrevRegsTrue H2); reflexivity. } rewrite P1 in H, P2. apply KeyPair_Equiv; assumption. Qed. Lemma CompTraceEquiv (b : BaseModule) (lrf : list RegFileBase) o : let m := inlineAll_All_mod (mergeSeparatedSingle b lrf) in let regInits := (getRegisters b) ++ (concat (map getRegFileRegisters lrf)) in forall rules lupds lcalls (HWfMod : WfMod type (mergeSeparatedSingle b lrf)) (HNoSelfCallsBase : NoSelfCallBaseModule b), SubList rules (getRules b) -> SemCompTrace regInits (fun s => compileRulesRf type (s, nil) rules lrf) o lupds lcalls -> (forall upds u, In upds lupds -> In u upds -> (NoDup (map fst u)) /\ SubList (getKindAttr u) (getKindAttr o)) /\ exists (lss : list (list (list FullLabel))), Forall2 (fun x y => x = (map getLabelUpds y)) lupds lss /\ (forall x, In x lss -> (map Rle (map fst (rev rules))) = getLabelExecs (concat x)) /\ Forall2 (fun x y => x = concat (map getLabelCalls (rev y))) lcalls lss /\ Trace m o (concat lss). Proof. induction 4; split; subst; intros; dest; auto. - inv H0. - exists nil; repeat split; auto. + intros; exfalso. inv H0. + econstructor; eauto. unfold regInits in *; simpl in *. enough (getAllRegisters (mergeSeparatedBaseFile lrf) = concat (map getRegFileRegisters lrf)). { rewrite H0; assumption. } clear; induction lrf; simpl; auto. rewrite IHlrf; reflexivity. - rewrite <-(rev_involutive rules) in HSemAction. specialize (ESameOldLoop _ _ _ HSemAction) as TMP; subst. rewrite rev_involutive in HSemAction. inv H1; rewrite <- (prevPrevRegsTrue HPriorityUpds); eauto. eapply EEquivLoop' with (calls := calls) (retl := val); eauto. - rewrite <-(rev_involutive rules) in HSemAction. specialize (ESameOldLoop _ _ _ HSemAction) as TMP; subst. rewrite rev_involutive in HSemAction. specialize (EEquivLoop' HWfMod H5 HNoSelfCallsBase H HSemAction) as TMP2; dest. unfold m; exists (x1 :: x); repeat split; auto. + intros; inv H12; eauto. + simpl; enough (o' = x0). { subst; assumption. } eapply PriorityUpds_Equiv'; eauto. * apply Trace_sameRegs in H5. apply WfNoDups in HWfMod; dest. unfold m in H4; simpl in *. rewrite <- fst_getKindAttr; setoid_rewrite H5. rewrite <- fst_getKindAttr in H12; assumption. * intros; eapply H6; assumption. Qed. ================================================ FILE: Compiler/CompilerSimple.v ================================================ Require Import Kami.Syntax Kami.Compiler.Compiler. Require Import Kami.Notations. Section Simple. Variable ty : Kind -> Type. Variable regMapTy : Type. Inductive RmeSimple := | VarRME (v : regMapTy) : RmeSimple | UpdRegRME (r : string)(pred : Bool @# ty)(k : FullKind)(val : Expr ty k)(regMap : RmeSimple) : RmeSimple | WriteRME (idxNum num : nat) (writePort dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# ty) (Data : Kind) (val : Array num Data @# ty) (mask : option (Array num Bool @# ty)) (pred : Bool @# ty) (writeMap readMap : RmeSimple) (arr : Array idxNum Data @# ty) : RmeSimple | ReadReqRME (idxNum num : nat) (readReq readReg dataArray : string) (idx : Bit (Nat.log2_up idxNum) @# ty) (Data : Kind) (isAddr : bool) (pred : Bool @# ty) (writeMap readMap : RmeSimple) (arr : Array idxNum Data @# ty) : RmeSimple | ReadRespRME (idxNum num : nat) (readResp readReg dataArray writePort : string) (isWriteMask: bool) (Data : Kind) (isAddr : bool) (writeMap readMap : RmeSimple) : RmeSimple | AsyncReadRME (idxNum num : nat) (readPort dataArray writePort : string) (isWriteMask: bool) (idx : Bit (Nat.log2_up idxNum) @# ty) (pred : Bool @# ty) (k : Kind)(writeMap readMap : RmeSimple) : RmeSimple | CompactRME (regMap: RmeSimple): RmeSimple. Fixpoint RmeSimple_of_RME(x : RegMapExpr ty regMapTy) : RmeSimple := match x with | VarRegMap v => VarRME v | UpdRegMap r pred k val regMap => UpdRegRME r pred val (RmeSimple_of_RME regMap) | CompactRegMap x' => CompactRME (RmeSimple_of_RME x') end. Inductive CompActionSimple : Kind -> Type := | CompCall_simple (f : string)(argRetK : Kind * Kind)(pred : Bool @# ty)(arg : fst argRetK @# ty) lret (cont : fullType ty (SyntaxKind (snd argRetK)) -> CompActionSimple lret) : CompActionSimple lret | CompLetExpr_simple k (e : Expr ty k) lret (cont : fullType ty k -> CompActionSimple lret) : CompActionSimple lret | CompNondet_simple k lret (cont : fullType ty k -> CompActionSimple lret) : CompActionSimple lret | CompSys_simple (pred: Bool @# ty) (ls: list (SysT ty)) lret (cont: CompActionSimple lret): CompActionSimple lret | CompReadReg_simple (r: string) (k: FullKind) (readMap : RmeSimple) lret (cont: fullType ty k -> CompActionSimple lret): CompActionSimple lret | CompRet_simple lret (e: lret @# ty) (newMap: RmeSimple) : CompActionSimple lret | CompLetFull_simple k (a: CompActionSimple k) lret (cont: fullType ty (SyntaxKind k) -> regMapTy -> CompActionSimple lret): CompActionSimple lret | CompWrite_simple (idxNum : nat) (Data : Kind) (writePort dataArray : string) (readMap : RmeSimple) lret (cont : ty (Array idxNum Data) -> CompActionSimple lret) : CompActionSimple lret | CompSyncReadReq_simple (idxNum num : nat) (Data : Kind) (readReq readReg dataArray : string) (isAddr : bool) (readMap : RmeSimple) lret (cont : ty (Array idxNum Data) -> CompActionSimple lret) : CompActionSimple lret | CompSyncReadRes_simple (idxNum num : nat) (readResp readReg dataArray writePort : string) (isWriteMask: bool) (Data : Kind) (isAddr : bool) (readMap : RmeSimple) lret (cont : fullType ty (SyntaxKind (Array num Data)) -> CompActionSimple lret) : CompActionSimple lret | CompAsyncRead_simple (idxNum num : nat) (readPort dataArray writePort : string) (isWriteMask: bool) (idx : Bit (Nat.log2_up idxNum) @# ty) (pred : Bool @# ty) (k : Kind) (readMap : RmeSimple) lret (cont : fullType ty (SyntaxKind (Array num k)) -> CompActionSimple lret) : CompActionSimple lret. Fixpoint CompActionSimple_of_CA{k}(a : CompActionT ty regMapTy k) : CompActionSimple k := match a with | CompCall f argRetK pred arg lret cont => CompCall_simple f argRetK pred arg (fun x => CompActionSimple_of_CA (cont x)) | CompLetExpr k e lret cont => CompLetExpr_simple e (fun x => CompActionSimple_of_CA (cont x)) | CompNondet k lret cont => CompNondet_simple k (fun x => CompActionSimple_of_CA (cont x)) | CompSys pred ls lret cont => CompSys_simple pred ls (CompActionSimple_of_CA cont) | CompRead r k readMap lret cont => CompReadReg_simple r k (RmeSimple_of_RME readMap) (fun x => CompActionSimple_of_CA (cont x)) | CompRet lret e newMap => CompRet_simple e (RmeSimple_of_RME newMap) | CompLetFull k a lret cont => CompLetFull_simple (CompActionSimple_of_CA a) (fun x y => CompActionSimple_of_CA (cont x y)) | CompWrite idxNum num writePort dataArray idx Data val mask pred writeMap readMap lret cont => @CompWrite_simple idxNum Data writePort dataArray (RmeSimple_of_RME readMap) lret (fun arr => CompLetFull_simple (CompRet_simple (($$ WO)%kami_expr : Void @# ty) (@WriteRME idxNum num writePort dataArray idx Data val mask pred (RmeSimple_of_RME writeMap) (RmeSimple_of_RME readMap) (#arr)%kami_expr)) (fun _ y => CompActionSimple_of_CA (cont y))) | CompSyncReadReq idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap lret cont => @CompSyncReadReq_simple idxNum num Data readReq readReg dataArray isAddr (RmeSimple_of_RME readMap) lret (fun x => CompLetFull_simple (CompRet_simple (($$ WO)%kami_expr : Void @# ty) (@ReadReqRME idxNum num readReq readReg dataArray idx Data isAddr pred (RmeSimple_of_RME writeMap) (RmeSimple_of_RME readMap) (#x)%kami_expr)) (fun _ y => CompActionSimple_of_CA (cont y))) | CompSyncReadRes idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr writeMap readMap lret cont => CompSyncReadRes_simple idxNum readResp readReg dataArray writePort isWriteMask isAddr (RmeSimple_of_RME readMap) (fun x => CompLetFull_simple (CompRet_simple (($$WO)%kami_expr) (@ReadRespRME idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr (RmeSimple_of_RME writeMap) (RmeSimple_of_RME readMap))) (fun _ y => CompActionSimple_of_CA (cont x y))) | CompAsyncRead idxNum num readPort dataArray writePort isWriteMask idx pred k writeMap readMap lret cont => CompAsyncRead_simple idxNum readPort dataArray writePort isWriteMask idx pred (RmeSimple_of_RME readMap) (fun x => CompLetFull_simple (CompRet_simple (($$ WO)%kami_expr : Void @# ty) (AsyncReadRME idxNum num readPort dataArray writePort isWriteMask idx pred k (RmeSimple_of_RME writeMap) (RmeSimple_of_RME readMap))) (fun _ y => CompActionSimple_of_CA (cont x y))) end. Definition CAS_RulesRf(readMap : regMapTy) (rules : list RuleT) (lrf : list RegFileBase) := CompActionSimple_of_CA (compileRulesRf ty readMap rules lrf). End Simple. ================================================ FILE: Compiler/CompilerSimpleProps.v ================================================ Require Import Kami.Syntax Kami.PPlusProperties. Require Import Kami.Notations. Require Import Kami.Compiler.CompilerSimpleSem. Require Import Kami.Compiler.CompilerSimple. Require Import Kami.Compiler.CompilerProps. Require Import Kami.Compiler.Compiler. Lemma RME_Simple_RME_Equiv map: forall old upds, Sem_RmeSimple (RmeSimple_of_RME map) (old, upds) -> SemRegMapExpr map (old, upds). Proof. induction map; intros; try (inv H; EqDep_subst). - econstructor 1; eauto. - econstructor 2; eauto. - econstructor 3; eauto. - econstructor 4; eauto. Qed. Lemma CA_Simple_CA_Equiv {k : Kind} (ca : CompActionT type (RegsT * list RegsT) k) : forall regMap calls val, SemCompActionSimple (CompActionSimple_of_CA ca) regMap calls val -> SemCompActionT ca regMap calls val. Proof. induction ca; intros; try ((inv H0 || inv H); EqDep_subst). - econstructor 1; eauto. - econstructor 2; eauto. - econstructor 3; eauto. - econstructor 4; eauto. - econstructor 5; eauto. - econstructor 6; eauto using RME_Simple_RME_Equiv. - econstructor 7; eauto. destruct regMap; inv HRegMapWf; econstructor; eauto using RME_Simple_RME_Equiv. - econstructor 8; eauto. - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *. inv HSemCompActionSimple_a; simpl in *; EqDep_subst. inv HRegMapWf; inv H0; EqDep_subst. econstructor 9; eauto using RME_Simple_RME_Equiv. - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *. inv HSemCompActionSimple_a; EqDep_subst. destruct regMap_a; inv HRegMapWf; inv H0; EqDep_subst. + inv HUpdate; EqDep_subst. econstructor 10; eauto using RME_Simple_RME_Equiv. * econstructor; eauto. econstructor; eauto using RME_Simple_RME_Equiv. * econstructor 10; eauto using RME_Simple_RME_Equiv. econstructor; eauto. eapply SemUpdRegMapFalse; eauto using RME_Simple_RME_Equiv. + econstructor 11; eauto using RME_Simple_RME_Equiv. econstructor; eauto using RME_Simple_RME_Equiv. - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *. inv HSemCompActionSimple_a; EqDep_subst. destruct regMap_a; inv HRegMapWf; inv H0; EqDep_subst;[|discriminate]. econstructor 12; eauto. econstructor; eauto using RME_Simple_RME_Equiv. - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *. inv HSemCompActionSimple_a; EqDep_subst. destruct regMap_a; inv HRegMapWf; inv H0; EqDep_subst;[discriminate|]. econstructor 13; eauto using RME_Simple_RME_Equiv. econstructor; eauto using RME_Simple_RME_Equiv. - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *. inv HSemCompActionSimple_a; simpl in *; EqDep_subst. inv HRegMapWf; destruct regMap_a. inv H0. econstructor 14; eauto using RME_Simple_RME_Equiv. - inv HSemCompActionSimple; simpl in *; EqDep_subst; rewrite unifyWO in *. inv HSemCompActionSimple_a; simpl in *; EqDep_subst. inv HRegMapWf; destruct regMap_a. econstructor 15; eauto using RME_Simple_RME_Equiv. inv H0. apply RME_Simple_RME_Equiv; auto. Qed. Lemma CA_Simple_Trace_CA_Trace_Equiv (ca : RegsT -> CompActionT type (RegsT * list RegsT) Void) : forall regInits o lupds lcalls, SemCompActionSimple_Trace regInits (fun s => CompActionSimple_of_CA (ca s)) o lupds lcalls -> SemCompTrace regInits ca o lupds lcalls. Proof. induction 1;[econstructor 1 | econstructor 2]; eauto using CA_Simple_CA_Equiv. Qed. Lemma CompActionSimpleTraceEquiv (b : BaseModule) (lrf : list RegFileBase) o : let m := inlineAll_All_mod (mergeSeparatedSingle b lrf) in let regInits := (getRegisters b) ++ (concat (map getRegFileRegisters lrf)) in forall rules lupds lcalls (HWfMod : WfMod type (mergeSeparatedSingle b lrf)) (HNoSelfCallsBase : NoSelfCallBaseModule b), SubList rules (getRules b) -> SemCompActionSimple_Trace regInits (fun s => CompActionSimple_of_CA (compileRulesRf type (s, nil) rules lrf)) o lupds lcalls -> (forall upds u, In upds lupds -> In u upds -> (NoDup (map fst u)) /\ SubList (getKindAttr u) (getKindAttr o)) /\ exists (lss : list (list (list FullLabel))), Forall2 (fun x y => x = (map getLabelUpds y)) lupds lss /\ (forall x, In x lss -> (map Rle (map fst (rev rules))) = getLabelExecs (concat x)) /\ Forall2 (fun x y => x = concat (map getLabelCalls (rev y))) lcalls lss /\ Trace m o (concat lss). Proof. intros; eapply CompTraceEquiv; eauto using CA_Simple_Trace_CA_Trace_Equiv. Qed. ================================================ FILE: Compiler/CompilerSimpleSem.v ================================================ Require Import Kami.All Kami.Compiler.Compiler. Require Import Kami.Notations. Require Import Kami.Compiler.CompilerSimple. Section SemSimple. Local Notation UpdRegT := RegsT. Local Notation UpdRegsT := (list UpdRegT). Local Notation RegMapType := (RegsT * UpdRegsT)%type. Inductive Sem_RmeSimple: (RmeSimple type RegMapType) -> RegMapType -> Prop := | SemVarRME v: Sem_RmeSimple (VarRME _ v) v | SemUpdRegRMETrue r (pred: Bool @# type) k val regMap (HPredTrue: evalExpr pred = true) old upds (HSem_RmeSimple : Sem_RmeSimple regMap (old, upds)) upds' (HEqual : upds' = (hd nil upds ++ ((r, existT _ k (evalExpr val)) :: nil)) :: tl upds): Sem_RmeSimple (@UpdRegRME _ _ r pred k val regMap) (old, upds') | SemUpdRegRMEFalse r (pred: Bool @# type) k val regMap (HPredFalse: evalExpr pred = false) old upds (HSem_RmeSimple: Sem_RmeSimple regMap (old, upds)): Sem_RmeSimple (@UpdRegRME _ _ r pred k val regMap) (old, upds) | SemWriteRMESome idxNum num writePort dataArray idx Data val optMask mask pred writeMap readMap arr old upds (HMask : optMask = Some mask) (HUpdate : Sem_RmeSimple (UpdRegRME dataArray pred (fold_left (fun newArr i => ITE (ReadArrayConst mask i) (UpdateArray newArr (CABit Add (idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil)) (ReadArrayConst val i)) newArr ) (getFins num) arr) writeMap) (old, upds)): Sem_RmeSimple (@WriteRME _ _ idxNum num writePort dataArray idx Data val optMask pred writeMap readMap arr) (old, upds) | SemWriteRMENone idxNum num writePort dataArray idx Data val optMask pred writeMap readMap arr old upds (HMask : optMask = None) (HUpdate : Sem_RmeSimple (UpdRegRME dataArray pred (fold_left (fun newArr i => (UpdateArray newArr (CABit Add (idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil)) (ReadArrayConst val i)) ) (getFins num) arr) writeMap) (old, upds)): Sem_RmeSimple (@WriteRME _ _ idxNum num writePort dataArray idx Data val optMask pred writeMap readMap arr) (old, upds) | SemReadReqRMETrue idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap arr old upds (HisAddr : isAddr = true) (HWriteMap : Sem_RmeSimple (UpdRegRME readReg pred (Var type (SyntaxKind _) (evalExpr idx)) writeMap) (old, upds)): Sem_RmeSimple (@ReadReqRME _ _ idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap arr) (old, upds) | SemReadReqRMEFalse idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap arr old upds (HisAddr : isAddr = false) (HWriteMap : Sem_RmeSimple (UpdRegRME readReg pred (BuildArray (fun i : Fin.t num => ReadArray arr (CABit Add (Var type (SyntaxKind _) (evalExpr idx) :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil)))) writeMap) (old, upds)): Sem_RmeSimple (@ReadReqRME _ _ idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap arr) (old, upds) | SemReadRespRME idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr writeMap readMap old upds (HWriteMap : Sem_RmeSimple writeMap (old, upds)): Sem_RmeSimple (@ReadRespRME _ _ idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr writeMap readMap) (old, upds) | SemAsyncReadRME (idxNum num : nat) (readPort dataArray : string) writePort isWriteMask (idx : Bit (Nat.log2_up idxNum) @# type) (pred : Bool @# type) (k : Kind) (writeMap readMap : RmeSimple type RegMapType) old upds (HNoOp : Sem_RmeSimple writeMap (old, upds)): Sem_RmeSimple (@AsyncReadRME _ _ idxNum num readPort dataArray writePort isWriteMask idx pred k writeMap readMap) (old, upds) | SemCompactRME old upds regMap (HSemRegMap: Sem_RmeSimple regMap (old, upds)): Sem_RmeSimple (@CompactRME _ _ regMap) (old, nil::upds). Definition WfRmeSimple (regMapExpr : RmeSimple type RegMapType) (regMap : RegMapType) := Sem_RmeSimple regMapExpr regMap /\ let '(old, new) := regMap in forall u, In u new -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old). Inductive SemCompActionSimple: forall k, CompActionSimple type RegMapType k -> RegMapType -> MethsT -> type k -> Prop := | SemCompCall_simple_True (f: string) (argRetK: Kind * Kind) (pred: Bool @# type) (arg: fst argRetK @# type) lret (cont: fullType type (SyntaxKind (snd argRetK)) -> CompActionSimple _ _ lret) (ret: fullType type (SyntaxKind (snd argRetK))) regMap calls val newCalls (HNewCalls : newCalls = (f, existT _ argRetK (evalExpr arg, ret)) :: calls) (HSemCompActionSimple: SemCompActionSimple (cont ret) regMap calls val) (HPred : evalExpr pred = true): SemCompActionSimple (@CompCall_simple _ _ f argRetK pred arg lret cont) regMap newCalls val | SemCompCall_simple_False (f: string) (argRetK: Kind * Kind) (pred: Bool @# type) (arg: fst argRetK @# type) lret (cont: fullType type (SyntaxKind (snd argRetK)) -> CompActionSimple _ _ lret) (ret: fullType type (SyntaxKind (snd argRetK))) regMap calls val (HSemCompActionSimple: SemCompActionSimple (cont ret) regMap calls val) (HPred : evalExpr pred = false): SemCompActionSimple (@CompCall_simple _ _ f argRetK pred arg lret cont) regMap calls val | SemCompLetExpr_simple k e lret cont regMap calls val (HSemCompActionSimple: SemCompActionSimple (cont (evalExpr e)) regMap calls val): SemCompActionSimple (@CompLetExpr_simple _ _ k e lret cont) regMap calls val | SemCompNondet_simple k lret cont ret regMap calls val (HSemCompActionSimple: SemCompActionSimple (cont ret) regMap calls val): SemCompActionSimple (@CompNondet_simple _ _ k lret cont) regMap calls val | SemCompSys_simple pred ls lret cont regMap calls val (HSemCompActionSimple: SemCompActionSimple cont regMap calls val): SemCompActionSimple (@CompSys_simple _ _ pred ls lret cont) regMap calls val | SemCompReadReg_simple r k readMap lret cont regMap calls val regVal updatedRegs readMapValOld readMapValUpds (HReadMap: Sem_RmeSimple readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs: PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn: In (r, (existT _ k regVal)) updatedRegs) (HSemCompActionT: SemCompActionSimple (cont regVal) regMap calls val): SemCompActionSimple (@CompReadReg_simple _ _ r k readMap lret cont) regMap calls val | SemCompRet_simple lret e regMap regMapVal calls (HCallsNil : calls = nil) (HRegMapWf: WfRmeSimple regMap regMapVal): SemCompActionSimple (@CompRet_simple _ _ lret e regMap) regMapVal calls (evalExpr e) | SemCompLetFull_simple k a lret cont regMap_a calls_a val_a (HSemCompActionSimple_a: SemCompActionSimple a regMap_a calls_a val_a) regMap_cont calls_cont val_cont newCalls (HNewCalls : newCalls = calls_a ++ calls_cont) (HSemCompActionSimple_cont: SemCompActionSimple (cont val_a regMap_a) regMap_cont calls_cont val_cont): SemCompActionSimple (@CompLetFull_simple _ _ k a lret cont) regMap_cont newCalls val_cont | SemCompAsyncReadRmeSimple num (readPort dataArray : string) writePort isWriteMask idxNum (idx : Bit (Nat.log2_up idxNum) @# type) pred Data readMap lret updatedRegs readMapValOld readMapValUpds regVal regMap (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regVal)) updatedRegs) cont calls val contArray (HContArray : contArray = BuildArray (fun i : Fin.t num => ReadArray (Var type _ regVal) (CABit Add (Var type (SyntaxKind _) (evalExpr idx) :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil)))) (HSemCompActionSimple : SemCompActionSimple (cont (evalExpr contArray)) regMap calls val): SemCompActionSimple (@CompAsyncRead_simple _ _ idxNum num readPort dataArray writePort isWriteMask idx pred Data readMap lret cont) regMap calls val | SemCompWrite_simple (writePort dataArray : string) idxNum Data (readMap : RmeSimple type RegMapType) lret updatedRegs readMapValOld readMapValUpds regVal (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regVal)) updatedRegs) cont regMap_cont calls val (HSemCompActionSimple : SemCompActionSimple (cont regVal) regMap_cont calls val): SemCompActionSimple (@CompWrite_simple _ _ idxNum Data writePort dataArray readMap lret cont) regMap_cont calls val | SemCompSyncReadReq_simple_True num idxNum readReq readReg dataArray k (isAddr : bool) readMap lret cont regMapVal (HisAddr : isAddr = true) regMap_cont calls val (HSemCompActionSimple : SemCompActionSimple (cont regMapVal) regMap_cont calls val): SemCompActionSimple (@CompSyncReadReq_simple _ _ idxNum num k readReq readReg dataArray isAddr readMap lret cont) regMap_cont calls val | SemCompSyncReadReq_simple_False num idxNum readReq readReg dataArray (idx : Bit (Nat.log2_up idxNum) @# type) Data (isAddr : bool) (writeMap : RegMapExpr type RegMapType) readMap lret cont (HisAddr : isAddr = false) updatedRegs readMapValOld readMapValUpds regV (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HRegVal : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regV)) updatedRegs) regMap_cont calls val (HSemCompActionSimple : SemCompActionSimple (cont regV) regMap_cont calls val): SemCompActionSimple (@CompSyncReadReq_simple _ _ idxNum num Data readReq readReg dataArray isAddr readMap lret cont) regMap_cont calls val | SemCompSyncReadRes_simple_True num idxNum readResp readRegName dataArray writePort isWriteMask Data isAddr readMap lret cont (HisAddr : isAddr = true) updatedRegs readMapValOld readMapValUpds regVal idx (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HRegVal1 : In (readRegName, existT _ (SyntaxKind (Bit (Nat.log2_up idxNum))) idx) updatedRegs) (HRegVal2 : In (dataArray, existT _ (SyntaxKind (Array idxNum Data)) regVal) updatedRegs) (contArray : Expr type (SyntaxKind (Array num Data))) (HContArray : contArray = BuildArray (fun i : Fin.t num => ReadArray (Var type _ regVal) (CABit Add (Var type (SyntaxKind _) idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil)))) regMap calls val (HSemCompActionSimple : SemCompActionSimple (cont (evalExpr contArray)) regMap calls val): SemCompActionSimple (@CompSyncReadRes_simple _ _ idxNum num readResp readRegName dataArray writePort isWriteMask Data isAddr readMap lret cont) regMap calls val | SemCompSyncReadRes_simple_False num idxNum readResp readRegName dataArray writePort isWriteMask Data isAddr readMap lret cont (HisAddr : isAddr = false) updatedRegs readMapValOld readMapValUpds regVal (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds)) (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs) (HIn1 : In (readRegName, (existT _ (SyntaxKind (Array num Data)) regVal)) updatedRegs) regMap calls val (HSemCompActionSimple : SemCompActionSimple (cont regVal) regMap calls val): SemCompActionSimple (@CompSyncReadRes_simple _ _ idxNum num readResp readRegName dataArray writePort isWriteMask Data isAddr readMap lret cont) regMap calls val. Variable (k : Kind) (a : CompActionSimple type RegMapType k) (regInits : list RegInitT). Section Loop. Variable f: RegsT -> CompActionSimple type RegMapType Void. Inductive SemCompActionSimple_Trace: RegsT -> list UpdRegsT -> list MethsT -> Prop := | SemCompActionSimple_TraceInit (oInit : RegsT) (lupds : list UpdRegsT) (lcalls : list MethsT) (HNoUpds : lupds = nil) (HNoCalls : lcalls = nil) (HInitRegs : Forall2 regInit oInit regInits) : SemCompActionSimple_Trace oInit lupds lcalls | SemCompActionSimple_TraceCont (o o' : RegsT) (lupds lupds' : list UpdRegsT) (upds : UpdRegsT) (lcalls lcalls' : list MethsT) (calls : MethsT) val (HOldTrace : SemCompActionSimple_Trace o lupds lcalls) (HSemAction : SemCompActionSimple (f o) (o, upds) calls val) (HNewUpds : lupds' = upds :: lupds) (HNewCalls : lcalls' = calls :: lcalls) (HPriorityUpds : PriorityUpds o upds o') : SemCompActionSimple_Trace o' lupds' lcalls'. End Loop. End SemSimple. ================================================ FILE: Compiler/Rtl.v ================================================ Require Import Kami.Syntax String. Set Implicit Arguments. Set Asymmetric Patterns. Definition VarType := (string * option nat)%type. Definition rtl_ty := (fun (_ : Kind) => VarType). Definition RtlExpr := (Expr rtl_ty). Definition RtlSysT := (SysT rtl_ty). Definition RtlExpr' k := (RtlExpr (SyntaxKind k)). Record RtlModule := { hiddenWires: list VarType; regFiles: list RegFileBase; inputs: list (VarType * Kind); outputs: list (VarType * Kind); regInits: list (VarType * sigT RegInitValT); regWrites: list (VarType * sigT RtlExpr); wires: list (VarType * sigT RtlExpr); sys: list (RtlExpr (SyntaxKind Bool) * list RtlSysT) }. ================================================ FILE: Compiler/Test.v ================================================ Require Import Kami.Extraction. Require Import BinNat. Import FinFun.Fin2Restrict. Require Import Kami.AllNotations. Class toString (X : Type) := { to_string : X -> string }. Instance toString_prod{X Y}`{toString X, toString Y} : toString (X * Y) := {| to_string := fun '(x,y) => (to_string x ++ "_" ++ to_string y)%string |}. Instance toString_sigma{X}{Y : X -> Type}`{toString X}`{forall x, toString (Y x)} : toString {x : X & Y x} := {| to_string := fun '(existT x y) => (to_string x ++ "_" ++ to_string y)%string |}. Definition cart_prod{X Y}(xs : list X)(ys : list Y) : list (X * Y) := List.concat (map (fun x => map (pair x) ys) xs). Inductive FileType := | AsyncF | SyncIsAddr | SyncNotIsAddr. Inductive OverlapType := | Over (* write ----- read ----- *) | Under (* write ----- read ----- *) | Disjoint (* write ----- read ----- *) . Inductive MaskType := | IsWrMask | NotIsWrMask. Inductive Schedule := | WriteFirst | WriteSecond | WriteThird. Definition FileTuple := (FileType * Schedule * OverlapType * MaskType)%type. Definition async_file_varieties : list FileTuple := cart_prod (cart_prod (cart_prod [AsyncF] [WriteFirst; WriteSecond]) [Over; Under; Disjoint]) [IsWrMask; NotIsWrMask]. Definition syncIsAddr_file_varieties : list FileTuple := cart_prod (cart_prod (cart_prod [SyncIsAddr] [WriteFirst; WriteSecond; WriteThird]) [Over; Under; Disjoint]) [IsWrMask; NotIsWrMask]. Definition syncNotIsAddr_file_varieties : list FileTuple := cart_prod (cart_prod (cart_prod [SyncNotIsAddr] [WriteFirst; WriteSecond; WriteThird]) [Over; Under; Disjoint]) [IsWrMask; NotIsWrMask]. Definition dep_cart_prod{X}{Y : X -> Type}(xs : list X)(ys : forall x, list (Y x)) : list ({x : X & Y x}) := concat (map (fun x => map (fun y => existT Y x y) (ys x)) xs). Section Params. Definition num := 5. Definition idxNum := 20. Definition Xlen := 32. Definition Data := Bit Xlen. Definition Counter := Bit 2. Definition init_val : word Xlen := Xlen 'h"e". (* mask = {true; false; false; false; true} *) Definition mask_func1 : Fin.t num -> bool := fun (i : Fin.t num) => match i with | F1 _ => true | FS _ (F1 _) => false | FS _ (FS _ (F1 _)) => false | FS _ (FS _ (FS _ (F1 _))) => false | _ => true end. Definition mask_func2 : Fin.t num -> bool := fun i => negb (mask_func1 i). Definition mask1 : ConstT (Array num Bool) := ConstArray mask_func1. Definition mask2 : ConstT (Array num Bool) := ConstArray mask_func2. Definition write_index := 4. Definition read_under_index := 2. Definition read_over_index := 6. Definition read_disjoint_index := 12. Definition write_val_1 : word Xlen := Xlen 'h"1e". Definition write_val_2 : word Xlen := Xlen 'h"3e". (* reality check lemmas *) (* good read/write indices*) Lemma read_under_bounds : read_under_index < write_index < read_under_index + num. Proof. cbv delta; try split; lia. Qed. Lemma read_over_bounds : read_over_index < write_index + num < read_over_index + num. Proof. cbv delta; try split; lia. Qed. Lemma read_disjoint_bounds : write_index + num < read_disjoint_index /\ read_disjoint_index + num < idxNum. Proof. cbv delta; try split; lia. Qed. (*good masks*) Lemma mask1_under_true : exists (i : Fin.t num), mask_func1 i = true /\ f2n i < num - (write_index - read_under_index). Proof. exists F1; simpl; auto. Qed. Lemma mask1_under_false : exists (i : Fin.t num), mask_func1 i = false /\ f2n i < num - (write_index - read_under_index). Proof. exists (FS F1); simpl; auto. Qed. Lemma mask1_over_true : exists (i : Fin.t num), mask_func1 i = true /\ f2n i > (read_over_index - write_index). Proof. exists (FS (FS (FS (FS F1)))); unfold f2n; simpl; auto. Qed. Lemma mask1_over_false : exists (i : Fin.t num), mask_func1 i = false /\ f2n i > (read_over_index - write_index). Proof. exists (FS (FS (FS F1))); unfold f2n; simpl; auto. Qed. Lemma mask2_under_true : exists (i : Fin.t num), mask_func2 i = true /\ f2n i < num - (write_index - read_under_index). Proof. exists (FS F1); simpl; auto. Qed. Lemma mask2_under_false : exists (i : Fin.t num), mask_func2 i = false /\ f2n i < num - (write_index - read_under_index). Proof. exists F1; simpl; auto. Qed. Lemma mask2_over_true : exists (i : Fin.t num), mask_func2 i = true /\ f2n i > (read_over_index - write_index). Proof. exists (FS (FS (FS F1))); unfold f2n; simpl; auto. Qed. Lemma mask2_over_false : exists (i : Fin.t num), mask_func2 i = false /\ f2n i > (read_over_index - write_index). Proof. exists (FS (FS (FS (FS F1)))); unfold f2n; simpl; auto. Qed. (* good values *) Lemma init_write1_neq : weqb init_val write_val_1 = false. Proof. auto. Qed. Lemma init_write2_neq : weqb init_val write_val_2 = false. Proof. auto. Qed. Lemma write1_write2_neq : weqb write_val_1 write_val_2 = false. Proof. auto. Qed. End Params. Section Files. Instance toString_FileType : toString FileType := {| to_string := fun x => match x with | AsyncF => "async" | SyncIsAddr => "syncIsAddr" | SyncNotIsAddr => "syncNotIsAddr" end |}. Instance toString_OverlapType : toString OverlapType := {| to_string := fun x => match x with | Over => "over" | Under => "under" | Disjoint => "disjoint" end |}. Instance toString_MaskType : toString MaskType := {| to_string := fun x => match x with | IsWrMask => "isWrMask" | NotIsWrMask => "notIsWrMask" end |}. Instance toString_Schedule : toString Schedule := {| to_string := fun x => match x with | WriteFirst => "writeFirst" | WriteSecond => "writeSecond" | WriteThird => "writeThird" end |}. Definition dataArray_name : FileTuple -> string := fun tup => ("dataArray_" ++ to_string tup)%string. Definition read_name : FileTuple -> string := fun tup => ("read_" ++ to_string tup)%string. Definition readReq_name : FileTuple -> string := fun tup => ("readReq_" ++ to_string tup)%string. Definition readRes_name : FileTuple -> string := fun tup => ("readRes_" ++ to_string tup)%string. Definition readReg_name : FileTuple -> string := fun tup => ("readReg_" ++ to_string tup)%string. Definition write_name : FileTuple -> string := fun tup => ("write_" ++ to_string tup)%string. Definition make_RFB(tup : FileTuple) : RegFileBase := let '(ft,sch,ot,mt) := tup in {| rfIsWrMask := match mt with | IsWrMask => true | NotIsWrMask => false end; rfNum := num; rfDataArray := dataArray_name tup; rfRead := match ft with | AsyncF => Async [read_name tup] | SyncIsAddr => Sync true [ {| readReqName := readReq_name tup; readResName := readRes_name tup; readRegName := readReg_name tup |} ] | SyncNotIsAddr => Sync false [ {| readReqName := readReq_name tup; readResName := readRes_name tup; readRegName := readReg_name tup |} ] end; rfWrite := write_name tup; rfIdxNum := idxNum; rfData := Data; rfInit := RFNonFile idxNum (Some (ConstBit init_val)) |}. End Files. Section Rules. Local Open Scope kami_expr. Local Open Scope kami_action. Variable tup : FileTuple. Definition all_init : ConstT (Array num Data) := ConstArray (fun _ => init_val). Definition expected_read_under(val : word Xlen) : ConstT (Array num Data) := ConstArray (fun i => if f2n i if f2n i bool) : ConstT (Array num Data) := ConstArray (fun i => if f2n i bool) : ConstT (Array num Data) := ConstArray (fun i => match Compare_dec.le_lt_dec (num - (read_over_index - write_index)) (f2n i) with | left _ => init_val | right pf => if mf (read_over_Fin_to_write_Fin i pf) then mask_val else if nmf (read_over_Fin_to_write_Fin i pf) then non_mask_val else init_val end). Definition expected_read_ot_mt(write_val old_val : word Xlen)(wmf omf : Fin.t num -> bool)(ot : OverlapType)(mt : MaskType) := match ot,mt with | Over,IsWrMask => expected_read_over_masked write_val old_val wmf omf | Over,NotIsWrMask => expected_read_over write_val | Under,IsWrMask => expected_read_under_masked write_val old_val wmf omf | Under,NotIsWrMask => expected_read_under write_val | Disjoint,_ => all_init end. Definition expected_read_val_first_cycle : ConstT (Array num Data) := let '(p,ot,mt) := tup in match p with | (AsyncF,WriteFirst) => expected_read_ot_mt write_val_1 init_val mask_func1 mask_func2 ot mt | (AsyncF,_) => all_init | _ => getDefaultConst (Array num Data) end. Definition expected_read_val_second_cycle : ConstT (Array num Data) := let '(p,ot,mt) := tup in match p with | (AsyncF, WriteFirst) => expected_read_ot_mt write_val_2 write_val_1 mask_func2 mask_func1 ot mt | (AsyncF, _) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt | (SyncIsAddr, WriteFirst) => expected_read_ot_mt write_val_2 write_val_1 mask_func2 mask_func1 ot mt | (SyncIsAddr, WriteSecond) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt | (SyncIsAddr, WriteThird) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt | (SyncNotIsAddr, WriteFirst) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt | (SyncNotIsAddr, WriteSecond) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt | (SyncNotIsAddr, WriteThird) => all_init end. Definition make_write : RuleT := let '(ft,sch,ot,mt) := tup in match mt with | IsWrMask => (("rule_" ++ write_name tup)%string, fun ty : (Kind -> Type) => Read c : Counter <- "counter"; LET write_val <- ITE (#c == $1) $$write_val_2 $$write_val_1; LET mask <- ITE (#c == $1) $$mask2 $$mask1; Call (write_name tup)(@createWriteRqMask ty idxNum num Data ($write_index) (BuildArray (fun _ => #write_val)) #mask : _); Retv ) | NotIsWrMask => (("rule_" ++ write_name tup)%string, fun ty : (Kind -> Type) => Read c : Counter <- "counter"; LET write_val <- ITE (#c == $1) $$write_val_2 $$write_val_1; Call (write_name tup)(@createWriteRq ty idxNum num Data ($write_index) (BuildArray (fun _ => #write_val)) : _); Retv ) end. Definition print_comparison{ty k}(val exp_val : Expr ty (SyntaxKind k)) : ActionT ty Void := System ( [DispString _ "Read Value: "; DispHex val; DispString _ "\n"; DispString _ "Expected Value: "; DispHex exp_val; DispString _ "\n" ] ); Read curr_passing : Bool <- "passing"; Write "passing" <- #curr_passing && (val == exp_val); If (val == exp_val) then (System [DispString _ "Passed.\n\n"]; Retv) else (System [DispString _ "FAILED FAILED FAILED FAILED FAILED FAILED FAILED FAILED\n\n"]; Retv); Retv. Definition print_read{ty}(read_idx : Expr ty (SyntaxKind (Bit (Nat.log2_up idxNum)))) : list (SysT ty) := [DispString _ "Read Index: "; DispHex read_idx; DispString _ "\n\n" ]. Definition make_read : RuleT := let '(ft,sch,ot,mt) := tup in let read_index := match ot with | Over => read_over_index | Under => read_under_index | Disjoint => read_disjoint_index end in (("rule_" ++ read_name tup)%string, fun (ty : Kind -> Type) => Call val : Array num Data <- (read_name tup)($read_index : Bit (Nat.log2_up idxNum)); Read c : Counter <- "counter"; LET exp_val : Array num Data <- ITE (#c == $1) $$expected_read_val_second_cycle $$expected_read_val_first_cycle; System ([DispString _ ("rule_" ++ read_name tup ++ ":\n")%string] ++ print_read ($read_index))%list; LETA _ : _ <- (print_comparison #val #exp_val); Retv ). Definition make_readReq : RuleT := let '(ft,sch,ot,mt) := tup in let read_index := match ot with | Over => read_over_index | Under => read_under_index | Disjoint => read_disjoint_index end in (("rule_" ++ readReq_name tup)%string, fun ty => Call (readReq_name tup)($read_index : Bit (Nat.log2_up idxNum)); System ([DispString _ ("rule_" ++ readReq_name tup ++ ":\n")%string] ++ print_read ($read_index))%list; Retv ). Definition make_readResp : RuleT := (("rule_" ++ readRes_name tup)%string, fun (ty : Kind -> Type) => Call val : Array num Data <- (readRes_name tup)(); Read c : Counter <- "counter"; LET exp_val : Array num Data <- ITE (#c == $1) $$expected_read_val_second_cycle $$expected_read_val_first_cycle; System [DispString _ ("rule_" ++ readRes_name tup ++ ":\n")%string]; If (#c == $1) then (print_comparison #val #exp_val); Retv ). Definition make_rules : list RuleT := let '(p,ot,mt) := tup in match p with | (AsyncF, WriteFirst) => [make_write; make_read] | (AsyncF, _) => [make_read; make_write] | (SyncIsAddr, WriteFirst) => [make_write; make_readResp; make_readReq] | (SyncIsAddr, WriteSecond) => [make_readResp; make_write; make_readReq] | (SyncIsAddr, WriteThird) => [make_readResp; make_readReq; make_write] | (SyncNotIsAddr, WriteFirst) => [make_write; make_readResp; make_readReq] | (SyncNotIsAddr, WriteSecond) => [make_readResp; make_write; make_readReq] | (SyncNotIsAddr, WriteThird) => [make_readResp; make_readReq; make_write] end. End Rules. Section TestMod. Local Open Scope kami_expr. Local Open Scope kami_action. Definition all_async_rules : list RuleT := concat (map make_rules async_file_varieties). Definition all_syncIsAddr_rules : list RuleT := concat (map make_rules syncIsAddr_file_varieties). Definition all_syncNotIsAddr_rules : list RuleT := concat (map make_rules syncNotIsAddr_file_varieties). (* registers *) (* write then read *) Definition write_reg_WR : RuleT := ("write_reg_WR", fun ty : (Kind -> Type) => Read c : Counter <- "counter"; LET new_val : Data <- ITE (#c == $1) $$write_val_2 $$write_val_1; System ([DispString _ ("write_reg_WR: ")%string; DispHex #new_val; DispString _ "\n\n"]); Write "reg_WR" <- #new_val; Retv ). Definition read_reg_WR : RuleT := ("read_reg_WR", fun ty : (Kind -> Type) => Read c : Counter <- "counter"; Read val : Data <- "reg_WR"; LET exp_val : Data <- ITE (#c == $1) $$write_val_2 $$write_val_1; System [DispString _ "read_reg_WR:\n"]; LETA _ : _ <- print_comparison #val #exp_val; Retv ). (* read then write *) Definition read_reg_RW : RuleT := ("read_reg_RW", fun ty : (Kind -> Type) => Read c : Counter <- "counter"; Read val : Data <- "reg_RW"; LET exp_val : Data <- ITE (#c == $1) $$write_val_1 $$init_val; System [DispString _ "read_reg_RW:\n"]; LETA _ : _ <- print_comparison #val #exp_val; Retv ). Definition write_reg_RW : RuleT := ("write_reg_RW", fun ty : (Kind -> Type) => Read c : Counter <- "counter"; LET new_val : Data <- ITE (#c == $1) $$write_val_2 $$write_val_1; System ([DispString _ "write_reg_RW: "; DispHex #new_val; DispString _ "\n\n"]); Write "reg_RW" <- #new_val; Retv ). Definition reg_3_rule_1 : RuleT := ("reg_3_write_1", fun ty : (Kind -> Type) => Write "reg_3" <- $$write_val_1; Read val : Data <- "reg_3"; System [DispString _ "reg_3_write_1:\n"]; LETA _ : _ <- print_comparison #val $$init_val; Retv ). Definition reg_3_rule_2 : RuleT := ("reg_3_write_2", fun ty : (Kind -> Type) => Write "reg_3" <- $$write_val_2; Read val : Data <- "reg_3"; System [DispString _ "reg_3_write_2:\n"]; LETA _ : _ <- print_comparison #val $$write_val_1; Retv ). Definition reg_3_rule_3 : RuleT := ("reg_3_init", fun ty : (Kind -> Type) => Write "reg_3" <- $$init_val; Read val : Data <- "reg_3"; System [DispString _ "reg_3_init:\n"]; LETA _ : _ <- print_comparison #val $$write_val_2; Retv ). (* counter rule*) Definition counter : RuleT := ("counter", fun ty : (Kind -> Type) => Read c : Counter <- "counter"; System [DispString _ "End of cycle "; DispHex #c; DispString _ "\n"]; Write "counter" <- #c + $1; If(#c == $1) then (Read passed : Bool <- "passing"; If (#passed) then (System [DispString _ "Test Suite Passed.\n"; Finish _]; Retv) else (System [DispString _ "Test Suite Failed.\n"; Finish _]; Retv); Retv); Retv). Definition all_reg_rules := [write_reg_WR; read_reg_WR; read_reg_RW; write_reg_RW; reg_3_rule_1; reg_3_rule_2; reg_3_rule_3]. Definition testRegBaseMod := BaseMod [ ("reg_WR", (existT _ (SyntaxKind _) (Some (SyntaxConst init_val)))); ("reg_RW", (existT _ (SyntaxKind _) (Some (SyntaxConst init_val)))); ("reg_3", (existT _ (SyntaxKind _) (Some (SyntaxConst init_val)))); ("counter", (existT _ (SyntaxKind (Counter)) (Some (SyntaxConst (getDefaultConst _))))); ("passing", (existT _ (SyntaxKind Bool) (Some (SyntaxConst (ConstBool true))))) ] (all_reg_rules ++ [counter]) []. Definition testAsyncBaseMod := BaseMod [ ("counter", (existT _ (SyntaxKind (Counter)) (Some (SyntaxConst (getDefaultConst _))))); ("passing", (existT _ (SyntaxKind Bool) (Some (SyntaxConst (ConstBool true))))) ] (all_async_rules ++ [counter]) []. Definition testSyncIsAddrBaseMod := BaseMod [ ("counter", (existT _ (SyntaxKind (Counter)) (Some (SyntaxConst (getDefaultConst _))))); ("passing", (existT _ (SyntaxKind Bool) (Some (SyntaxConst (ConstBool true))))) ] (all_syncIsAddr_rules ++ [counter]) []. Definition testSyncNotIsAddrBaseMod := BaseMod [ ("counter", (existT _ (SyntaxKind (Counter)) (Some (SyntaxConst (getDefaultConst _))))); ("passing", (existT _ (SyntaxKind Bool) (Some (SyntaxConst (ConstBool true))))) ] (all_syncNotIsAddr_rules ++ [counter]) []. Definition testAsyncRFs := map make_RFB async_file_varieties. Definition testSyncIsAddrRFs := map make_RFB syncIsAddr_file_varieties. Definition testSyncNotIsAddrRFs := map make_RFB syncNotIsAddr_file_varieties. Definition mkTestMod(bm : BaseModule)(rfs : list RegFileBase) := let md := (fold_right ConcatMod bm (map (fun m => Base (BaseRegFile m)) rfs)) in createHideMod md (map fst (getAllMethods md)). Definition testReg := mkTestMod testRegBaseMod []. Definition testAsync := mkTestMod testAsyncBaseMod testAsyncRFs. Definition testSyncIsAddr := mkTestMod testSyncIsAddrBaseMod testSyncIsAddrRFs. Definition testSyncNotIsAddr := mkTestMod testSyncNotIsAddrBaseMod testSyncNotIsAddrRFs. End TestMod. ================================================ FILE: Compiler/UnverifiedIncompleteCompiler.v ================================================ Require Import Kami.Syntax Kami.Notations RecordUpdate.RecordSet Kami.Compiler.Rtl Kami.StateMonad. Set Implicit Arguments. Set Asymmetric Patterns. Local Notation NoneVal := (None: option nat). Local Open Scope string. Definition getRegActionRead a s := (a ++ "#" ++ s ++ "#_read", NoneVal). Definition getRegActionWrite a s := (a ++ "#" ++ s ++ "#_tempwrite", NoneVal). Definition getRegActionEn a s := (a ++ "#" ++ s ++ "#_en", NoneVal). Definition getMethRet f := (f ++ "#_return", NoneVal). Definition getMethArg f := (f ++ "#_argument", NoneVal). Definition getMethEn f := (f ++ "#_enable", NoneVal). Definition getActionGuard r := (r ++ "#_guard", NoneVal). Local Close Scope string. Definition RtlReadWire k s := @Var rtl_ty (SyntaxKind k) s. Definition RtlReadReg k s := @Var rtl_ty (SyntaxKind k) (s, None). Arguments RtlReadWire: clear implicits. Section Compile. Variable name: string. Fixpoint convertExprToRtl k (e: RtlExpr (SyntaxKind k)) := e. Definition getRtlDisp (d: RtlSysT) := d. Local Notation inc ns := (S ns). Record RtlExprs := { tempWires : list (string * option nat * sigT RtlExpr') ; regsWrite : string -> forall k, option (RtlExpr' Bool * RtlExpr' k) ; methCalls : string -> forall k, option (RtlExpr' Bool * RtlExpr' k) ; systCalls : list (RtlExpr' Bool * list RtlSysT) ; guard : option (RtlExpr' Bool) }. Definition defRtlExprs := {| tempWires := nil ; regsWrite := fun _ k => None ; methCalls := fun _ k => None ; systCalls := nil ; guard := None |}. Local Open Scope kami_expr. Definition combineRtlExprPreds k p (e1: option (_ * RtlExpr k)) e2 := match e1, e2 with | None, None => None | None, Some (x, v) => Some ((UniBool Neg p) && x, v) | Some (x, v), None => Some (p && x, v) | Some (x1, v1), Some (x2, v2) => Some (ITE p x1 x2, ITE (p && x1) v1 v2) end. Definition combineRtlExpr k (e1: option (_ * RtlExpr k)) e2 := match e1, e2 with | None, None => None | None, Some (x, v) => Some (x, v) | Some (x, v), None => Some (x, v) | Some (x1, v1), Some (x2, v2) => Some (x1 || x2, ITE x1 v1 v2) end. Definition combineRtlExprsPreds p e1 e2 := {| tempWires := tempWires e1 ++ tempWires e2 ; regsWrite := fun s k => combineRtlExprPreds p (regsWrite e1 s k) (regsWrite e2 s k) ; methCalls := fun s k => combineRtlExprPreds p (methCalls e1 s k) (methCalls e2 s k) ; systCalls := map (fun x => (p && fst x, snd x)) (systCalls e1) ++ map (fun x => ((UniBool Neg p) && fst x, snd x)) (systCalls e2) ; guard := match guard e1, guard e2 with | None, None => None | Some x, None => Some (x || (UniBool Neg p)) | None, Some x => Some (x || p) | Some x1, Some x2 => Some (ITE p x1 x2) end |}. Definition combineRtlExprs e1 e2 := {| tempWires := tempWires e1 ++ tempWires e2 ; regsWrite := fun s k => combineRtlExpr (regsWrite e1 s k) (regsWrite e2 s k) ; methCalls := fun s k => combineRtlExpr (methCalls e1 s k) (methCalls e2 s k) ; systCalls := systCalls e1 ++ systCalls e2 ; guard := match guard e1, guard e2 with | None, None => None | Some x, None => Some x | None, Some x => Some x | Some x1, Some x2 => Some (x1 && x2) end |}. Global Instance etaX_RtlExprs : Settable _ := settable! Build_RtlExprs . Local Notation add proj rec val := (rec <| proj ::== (cons val) |>). Definition getTemp num := (name, Some num : option nat). Fixpoint convertActionToRtl k (a: ActionT rtl_ty k) (retVar: nat) : State nat RtlExprs := match a in ActionT _ _ with | MCall meth argRetK argExpr cont => (do curr <- get ; do _ <- put (inc curr) ; do final <- convertActionToRtl (cont (getTemp curr)) retVar ; ret (final<| tempWires := (name, Some curr, existT _ _ (RtlReadWire (snd argRetK) (getMethRet meth))) :: tempWires final |> <| methCalls := fun s k' => match string_dec meth s with | left _ => match Kind_dec (fst argRetK) k' with | left pf_k => Some (RtlReadWire Bool (getActionGuard name), match pf_k in _ = Y return _ Y with | eq_refl => convertExprToRtl argExpr end) | _ => methCalls final s k' end | _ => methCalls final s k' end |>)) | Return x => ret (add tempWires defRtlExprs (name, Some retVar, existT _ k (convertExprToRtl x))) | LetExpr k' expr cont => match k' return Expr rtl_ty k' -> (fullType rtl_ty k' -> ActionT rtl_ty k) -> State nat RtlExprs with | SyntaxKind k => fun expr cont => (do curr <- get ; do _ <- put (inc curr) ; do final <- convertActionToRtl (cont (getTemp curr)) retVar ; ret (add tempWires final (name, Some curr, existT _ k (convertExprToRtl expr)))) | _ => fun _ _ => ret defRtlExprs end expr cont | LetAction k' a' cont => (do curr <- get ; do _ <- put (inc curr) ; do final1 <- convertActionToRtl a' curr ; do final2 <- convertActionToRtl (cont (getTemp curr)) retVar ; ret (combineRtlExprs final1 final2)) | ReadNondet k' cont => match k' return (fullType rtl_ty k' -> ActionT rtl_ty k) -> State nat RtlExprs with | SyntaxKind k => fun cont => (do curr <- get ; do _ <- put (inc curr) ; do final <- convertActionToRtl (cont (getTemp curr)) retVar ; ret (add tempWires final (name, Some curr, existT _ k (Const _ (getDefaultConst k))))) | _ => fun _ => ret defRtlExprs end cont | ReadReg r k' cont => match k' return (fullType rtl_ty k' -> ActionT rtl_ty k) -> State nat RtlExprs with | SyntaxKind k => fun cont => (do curr <- get ; do _ <- put (inc curr) ; do final <- convertActionToRtl (cont (getTemp curr)) retVar ; ret (add tempWires final (name, Some curr, existT _ _ (RtlReadWire k (getRegActionRead name r))))) | _ => fun _ => ret defRtlExprs end cont | WriteReg r k' expr cont => match k' return Expr rtl_ty k' -> State nat RtlExprs with | SyntaxKind k => fun expr => (do final <- convertActionToRtl cont retVar ; ret (final<| regsWrite := fun s k'' => match string_dec r s with | left _ => match Kind_dec k k'' with | left pf_k => Some (RtlReadWire Bool (getActionGuard name), match pf_k in _ = Y return _ Y with | eq_refl => convertExprToRtl expr end) | _ => regsWrite final s k'' end | _ => regsWrite final s k'' end |>)) | _ => fun _ => ret defRtlExprs end expr | Sys ls cont => (do final <- convertActionToRtl cont retVar ; ret (add systCalls final (RtlReadWire Bool (getActionGuard name), map getRtlDisp ls))) | IfElse pred ktf t f cont => (do init <- get ; let predWire := RtlReadWire Bool (name, Some init) in do _ <- put (inc init) ; do currT <- get ; do _ <- put (inc currT) ; do finalT <- convertActionToRtl t currT ; do currF <- get ; do _ <- put (inc currF) ; do finalF <- convertActionToRtl f currF ; do curr <- get ; do _ <- put (inc curr) ; do final <- convertActionToRtl (cont (getTemp curr)) retVar ; let combTF := combineRtlExprsPreds predWire finalT finalF in let combCont := combineRtlExprs combTF final in let addCurr := add tempWires combCont (name, Some curr, existT _ _ (ITE predWire (RtlReadWire ktf (name, Some currT)) (RtlReadWire ktf (name, Some currF)))) in ret (add tempWires addCurr (name, Some init, existT _ Bool (convertExprToRtl pred)))) end. End Compile. Section PerRule. Variable rule: Attribute (Action Void). Local Definition calls := getCallsWithSignPerRule rule. Record RuleOutput := { ruleTemps: list (string * option nat * sigT RtlExpr') ; ruleSysCs: list (RtlExpr' Bool * list RtlSysT) }. Definition getRtlExprsForRule := fst (run (convertActionToRtl (fst rule) (snd rule rtl_ty) 0) 1). Definition getTempWiresForRule (regs: list (Attribute Kind)) := let '(Build_RtlExprs tw rw mc sc g) := getRtlExprsForRule in {| ruleTemps := (getActionGuard (fst rule), existT _ Bool match g with | Some g' => g' | None => Const _ true end) :: tw ++ (map (fun sk => let '(s, k) := sk in (getRegActionEn (fst rule) s, existT _ Bool match rw s k with | Some (pred, val) => pred | None => Const _ false end)) regs) ++ (map (fun sk => let '(s, k) := sk in (getRegActionWrite (fst rule) s, existT _ k match rw s k with | Some (pred, val) => val | None => Const _ (getDefaultConst k) end)) regs) ++ (map (fun sk => let '(s, (argK, retK)) := sk in (getMethEn s, existT _ Bool match mc s argK with | Some (pred, val) => pred | None => Const _ false end)) calls) ++ (map (fun sk => let '(s, (argK, retK)) := sk in (getMethArg s, existT _ argK match mc s argK with | Some (pred, val) => val | None => Const _ (getDefaultConst argK) end)) calls) ; ruleSysCs := map (fun v => let '(pred, val) := v in (pred, val)%kami_expr) sc |}. End PerRule. Section AllRules. Variable rules: list (Attribute (Action Void)). Variable regs: list (Attribute Kind). Definition combineRules := fold_left (fun acc rule => {| ruleTemps := ruleTemps acc ++ ruleTemps (getTempWiresForRule rule regs) ; ruleSysCs := ruleSysCs acc ++ ruleSysCs (getTempWiresForRule rule regs) |}) rules {| ruleTemps := nil ; ruleSysCs := nil |}. End AllRules. Section ThreadRules. Variable rules: list (Attribute (Action Void)). Variable regs: list (Attribute Kind). Definition getRuleWrite rule (x: Attribute Kind) := existT RtlExpr' (snd x) (ITE (RtlReadWire Bool (getRegActionEn rule (fst x))) (RtlReadWire (snd x) (getRegActionWrite rule (fst x))) (RtlReadWire (snd x) (getRegActionRead rule (fst x)))). Definition threadTogether curr next : list (string * option nat * sigT RtlExpr') := map (fun x => (getRegActionRead next (fst x), getRuleWrite curr x)) regs. Fixpoint threadAllTemps (order: list string) {struct order} := match order with | x :: xs => match xs with | y :: ys => threadTogether x y | nil => nil end ++ threadAllTemps xs | _ => nil end. Definition finalWrite (order: list string) := map (fun x => (fst x, getRuleWrite (last order ""%string) x)) regs. Definition initialRead (order: list string) := map (fun x => (getRegActionRead (hd ""%string order) (fst x), existT RtlExpr' _ (RtlReadReg (snd x) (fst x)))) regs. Definition allWires order := ({| ruleTemps := threadAllTemps order ++ initialRead order ++ ruleTemps (combineRules rules regs) ; ruleSysCs := ruleSysCs (combineRules rules regs) |}, finalWrite order). End ThreadRules. Definition getRegInit (y: sigT RegInitValT): {x: Kind & option (ConstT x)} := existT _ _ match projT2 y with | None => None | Some y' => Some match y' in ConstFullT k return ConstT match k with | SyntaxKind k' => k' | _ => Void end with | SyntaxConst k c => c | _ => WO end end. (* tagged database entry definitions *) Fixpoint tag' val T (xs : list T) := match xs with | nil => nil | y :: ys => (val, y) :: tag' (S val) ys end. Definition tag := @tag' 0. Section order. Variable rules: list RuleT. Variable order: list string. Definition callingRule m := find (fun calls => getBool (In_dec string_dec m (snd calls))) (map (fun x => (fst x, map fst (getCallsWithSignPerRule x))) rules). Definition getPosCallingRule m := match callingRule m with | Some (x, _) => match find (fun z => getBool (string_dec x (snd z))) (tag order) with | Some (pos, _) => Some pos | None => None end | None => None end. Definition isBeforeCall m1 m2 := match getPosCallingRule m1, getPosCallingRule m2 with | Some x, Some y => getBool (Compare_dec.lt_dec x y) | _, _ => false end. End order. Definition convertRtl (e : {x : Kind & RtlExpr' x}) : {x : FullKind & RtlExpr x} := match e with | existT x val => existT _ (SyntaxKind x) val end. Definition rtlModCreate (bm: list string * (list RegFileBase * BaseModule)) (order: list string) := let '(hides, (rfs, m)) := bm in let rules := getRules m in let regs := map (fun x => let '(a, b) := x in (a, match b with | SyntaxKind k => k | _ => Bit 0 end)) (getKindAttr (getRegisters m)) in let calls := getCallsWithSignPerMod m in let '(Build_RuleOutput temps syss, regWr) := allWires rules regs order in let ins := map (fun x => (getMethRet (fst x), (snd (snd x)))) calls in let outs := map (fun x => (getMethArg (fst x), (fst (snd x)))) calls ++ map (fun x => (getMethEn (fst x), Bool)) calls in {| hiddenWires := map (fun x => getMethArg x) hides ++ map (fun x => getMethEn x) hides ++ map (fun x => getMethRet x) hides ; regFiles := rfs ; inputs := ins ; outputs := outs; regInits := map (fun '(x,y) => (x, None, y)) (getRegisters m) ; regWrites := map (fun '(x,y) => (x, None, convertRtl y)) regWr ; wires := map (fun '(x,y,z) => (x, y, convertRtl z)) temps ; sys := syss |}. Definition getRtl (bm: (list string * (list RegFileBase * BaseModule))) := rtlModCreate bm (map fst (getRules (snd (snd bm)))). Definition getRtlSafe (module : Mod) : RtlModule := getRtl (separateModRemove module). Definition rtlGet m := getRtl (getHidden m, (fst (separateBaseMod m), inlineAll_All_mod (mergeSeparatedBaseMod (snd (separateBaseMod m))))). Definition makeRtl (m: ModWfOrd rtl_ty) := rtlGet m. ================================================ FILE: Extraction.v ================================================ Require Export List String Ascii BinInt BinNat. Require Export Kami.Syntax Kami.Compiler.CompilerSimple Kami.Compiler.Compiler Kami.Compiler.Rtl Kami.LibStruct Kami.Compiler.UnverifiedIncompleteCompiler. Require Import Kami.Notations. Require Coq.extraction.Extraction. Require Export ExtrHaskellBasic ExtrHaskellNatInt ExtrHaskellString ExtrHaskellZInteger. Extraction Language Haskell. Set Extraction Optimize. Set Extraction KeepSingleton. Unset Extraction AutoInline. Extract Inductive sigT => "(,)" ["(,)"]. Extract Inductive Fin.t => "CustomExtract.EFin" ["CustomExtract.fin0" "CustomExtract.finS"] "CustomExtract.finRec". Extract Inductive N => "Prelude.Integer" ["0" "(\x -> x)"] "(\fn0 fnpos x -> if x Prelude.== 0 then fn0 () else fnpos x)". Extract Inlined Constant fst => "Prelude.fst". Extract Inlined Constant snd => "Prelude.snd". Extract Inlined Constant projT1 => "Prelude.fst". Extract Inlined Constant projT2 => "Prelude.snd". Extract Inlined Constant map => "Prelude.map". Extract Inlined Constant List.concat => "Prelude.concat". Extract Inlined Constant String.concat => "Data.List.intercalate". Extract Inlined Constant mod2 => "Prelude.odd". Extract Constant nat_cast => "(\_ _ x -> x)". Extract Inlined Constant length => "Prelude.length". Extract Inlined Constant Datatypes.length => "Prelude.length". Extract Constant Nat.div2 => "(`Prelude.div` 2)". Extract Constant Nat.log2 => "(\x -> Prelude.floor (Prelude.logBase 2 (Prelude.fromIntegral x)))". Extract Constant Nat.log2_up => "(\x -> Prelude.ceiling (Prelude.logBase 2 (Prelude.fromIntegral x)))". Extract Constant List.fold_left => "(\f bs a -> Data.List.foldl' f a bs)". Extract Constant natToWord => "(\sz n -> Prelude.toInteger n)". Extract Constant wordToNat => "(\_ -> Prelude.fromIntegral)". Extract Constant sumSizes => "(\n f -> Prelude.sum (Prelude.map (\i -> f (n Prelude.-1,i)) [0..(n Prelude.-1)]))". Extract Constant nth_Fin => "(\xs (_,i) -> xs Prelude.!! i)". Extract Constant nth_Fin_map2 => "(\_ _ _ x -> x)". Extract Constant getFins => "(\n -> Prelude.map ((,) (n Prelude.- 1)) [0..(n Prelude.- 1)])". Extract Constant Fin.to_nat => "(\_ (_,i) -> i)". Extract Constant Fin.cast => "(\_ x _ -> x)". Extract Constant Fin.of_nat_lt => "(\i n -> (n Prelude.- 1,i))". Extract Constant Fin_eq_dec => "(\_ x y -> x Prelude.== y)". Extract Inlined Constant getBool => "Prelude.id". Extract Inlined Constant String.append => "(Prelude.++)". Extract Constant ZToWord => "(\n x -> Prelude.mod x (2 Prelude.^ n))". Extract Inlined Constant NToWord => "(\_ x -> x)". Extract Constant wones => "(\n -> 2 Prelude.^ n Prelude.- 1)". Extract Constant wadd => "(\_ x y -> x Prelude.+ y)". Extract Constant wsub => "(\_ x y -> x Prelude.- y)". Extract Constant wor => "(\_ x y -> x Data.Bits..|. y)". Extract Constant wand => "(\_ x y -> x Data.Bits..&. y)". Extract Constant wxor => "(\_ -> Data.Bits.xor)". Extract Constant wnot => "(\_ -> Data.Bits.complement)". Extract Constant wuxor => "(\_ x -> Prelude.odd (Data.Bits.popCount x))". Extract Constant wmul => "(\_ x y -> x Prelude.* y)". Extract Constant wdiv => "(\_ -> Prelude.div)". Extract Constant wmod => "(\_ -> Prelude.mod)". Extract Constant wslu => "(\_ x n -> Data.Bits.shiftL x (Prelude.fromIntegral n))". Extract Constant wsru => "(\_ x n -> Data.Bits.shiftR x (Prelude.fromIntegral n))". Extract Constant weqb => "(\_ -> (Prelude.==))". Extract Constant wuand => "(\n x -> x Prelude.== 2 Prelude.^ n)". Extract Constant wuor => "(\_ x -> Prelude.not (x Prelude.== 0))". Extract Constant wltu => "(\_ -> (Prelude.<))". Extract Constant truncMsb => "(\msb _ x -> Data.Bits.shiftR x msb)". Extract Inlined Constant Z.pow => "(Prelude.^)". Extract Inlined Constant Z.of_nat => "Prelude.toInteger". Extract Inlined Constant Z.ltb => "(Prelude.<)". Extract Inlined Constant Z.opp => "Prelude.negate". Extract Inlined Constant Z.div => "Prelude.div". Extract Inlined Constant Z.modulo => "Prelude.mod". Extract Inlined Constant N.succ_pos => "(\x -> x Prelude.+ 1)". Extract Inlined Constant N.add => "(Prelude.+)". Extract Inlined Constant N.sub => "(Prelude.-)". Extract Inlined Constant N.mul => "(Prelude.*)". Extract Inlined Constant N.eqb => "(Prelude.==)". Extract Inlined Constant N.ltb => "(Prelude.<)". Extract Inlined Constant N.of_nat => "Prelude.toInteger". Section Ty. Variable ty: Kind -> Type. Local Open Scope kami_expr. Definition predPack k (pred: Bool @# ty) (val: k @# ty) := (IF pred then pack val else $0). Definition orKind k (ls: list (Bit (size k) @# ty)) := unpack k (Kor ls). Definition predPackOr k (ls: list ((Bool @# ty) * (k @# ty))) := ((@Kor _ Bool) (map fst ls), orKind k (map (fun '(p, v) => predPack p v) ls)). Definition createWriteRq ty (idxNum num: nat) (k: Kind) (idx: Bit (Nat.log2_up idxNum) @# ty) (val: Array num k @# ty): WriteRq (Nat.log2_up idxNum) (Array num k) @# ty := STRUCT { "addr" ::= idx ; "data" ::= val }. Definition createWriteRqMask ty (idxNum num: nat) (k: Kind) (idx: Bit (Nat.log2_up idxNum) @# ty) (val: Array num k @# ty) (mask: Array num Bool @# ty): WriteRqMask (Nat.log2_up idxNum) num k @# ty := STRUCT { "addr" ::= idx ; "data" ::= val ; "mask" ::= mask }. Definition pointwiseIntersectionNoMask (idxNum num: nat) (k: Kind) (readPred: Bool @# ty) (readAddr: Bit (Nat.log2_up idxNum) @# ty) (writePred: Bool @# ty) (writeRq: WriteRq (Nat.log2_up idxNum) (Array num k) @# ty) : Array num (Maybe k) @# ty := BuildArray (fun i => let readAddr_i := readAddr + $(proj1_sig (Fin.to_nat i)) in STRUCT { "valid" ::= (readPred && writePred && (writeRq @% "addr" <= readAddr_i) && (readAddr_i < writeRq @% "addr" + $num)); "data" ::= (writeRq @% "data")@[readAddr - writeRq @% "addr" + $(proj1_sig (Fin.to_nat i))] } : Maybe k @# ty). Definition pointwiseIntersectionMask (idxNum num: nat) (k: Kind) (readPred: Bool @# ty) (readAddr: Bit (Nat.log2_up idxNum) @# ty) (writePred: Bool @# ty) (writeRq: WriteRqMask (Nat.log2_up idxNum) num k @# ty) : Array num (Maybe k) @# ty := BuildArray (fun i => let readAddr_i := readAddr + $(proj1_sig (Fin.to_nat i)) in STRUCT { "valid" ::= (readPred && writePred && ((writeRq @% "mask")@[readAddr - writeRq @% "addr" + $(proj1_sig (Fin.to_nat i))]) && (writeRq @% "addr" <= readAddr_i) && (readAddr_i < writeRq @% "addr" + $num)); "data" ::= (writeRq @% "data")@[readAddr - writeRq @% "addr" + $(proj1_sig (Fin.to_nat i))] } : Maybe k @# ty). Definition pointwiseIntersection (idxNum num: nat) (k: Kind) (isMask: bool) (readPred: Bool @# ty) (readAddr: Bit (Nat.log2_up idxNum) @# ty) (writePred: Bool @# ty) (writeRq: if isMask then WriteRqMask (Nat.log2_up idxNum) num k @# ty else WriteRq (Nat.log2_up idxNum) (Array num k) @# ty) : Array num (Maybe k) @# ty := match isMask return (if isMask then WriteRqMask (Nat.log2_up idxNum) num k @# ty else WriteRq (Nat.log2_up idxNum) (Array num k) @# ty) -> Array num (Maybe k) @# ty with | true => fun writeRq => pointwiseIntersectionMask idxNum readPred readAddr writePred writeRq | false => fun writeRq => pointwiseIntersectionNoMask idxNum readPred readAddr writePred writeRq end writeRq. Definition pointwiseBypass (num: nat) (k: Kind) (bypass: Array num (Maybe k) @# ty) (resp: Array num k @# ty) : Array num k @# ty := BuildArray (fun i => (IF (ReadArrayConst bypass i) @% "valid" then (ReadArrayConst bypass i) @% "data" else ReadArrayConst resp i)). Local Close Scope kami_expr. End Ty. ================================================ FILE: GallinaModules/AuxLemmas.v ================================================ Require Import Kami.All. Require Import Kami.GallinaModules.Relations. Definition doUpdReg (u : RegsT) (r : RegT) : RegT := match findReg (fst r) u with | Some y => (fst r, y) | None => r end. Fixpoint oneUpdRegs (r : RegT) (o : RegsT) : RegsT := match o with | nil => nil | x :: o' => (if String.eqb (fst x) (fst r) then r else x) :: (oneUpdRegs r o') end. Definition oneUpdReg (r1 r2 : RegT) : RegT := if String.eqb (fst r2) (fst r1) then r1 else r2. Lemma InGetKindAttr: forall {name} {o: RegsT} {k} {v} (H: In (name, existT (fullType type) (SyntaxKind k) v) o), In (name, SyntaxKind k) (getKindAttr o). Proof. intros; rewrite in_map_iff; eexists; split; eauto; simpl; reflexivity. Qed. Lemma doUpdRegs_nil: forall r, doUpdRegs [] r = r. Proof. intros. induction r; auto. simpl. rewrite IHr. auto. Qed. Lemma in_app_fst: forall {A} {B} {a: A} {l l': list (A * B)}, ~ In a (map fst l) -> In a (map fst (l ++ l')) -> In a (map fst l'). Proof. intros. induction l, l'; simpl in *; auto; intuition. Qed. Lemma inImpInFst: forall {A B: Type} (a: A) (b: B) (l: list (A * B)), In (a,b) l -> In a (map fst l). Proof. intros; rewrite in_map_iff; exists (a, b); auto. Qed. Lemma noDupSame: forall (o_s: RegsT), List.NoDup (map fst o_s) -> forall name k rv_1 rv_2, In (name, existT (fullType type) (SyntaxKind k) rv_1) o_s -> In (name, existT (fullType type) (SyntaxKind k) rv_2) o_s -> rv_1 = rv_2. Proof. induction o_s; intros; simpl in *; intuition; subst. - apply inversionPairExistT in H0; inv H0; EqDep_subst; reflexivity. - exfalso. inv H; apply H3; apply (in_map fst) in H0; auto. - exfalso. inv H; apply H3; apply (in_map fst) in H2; auto. - inv H; eapply IHo_s; eauto. Qed. Lemma SubList_Strengthen: forall A (l1 l2: list A) (a: A), SubList l1 (a::l2) -> ~ In a l1 -> SubList l1 l2. Proof. intros. unfold SubList in *. intros. specialize (H x H1). inversion H; subst; solve [intuition]. Qed. Lemma getKindAttrEqImpFstEq: forall (r1 r2: RegsT), (* Possibly replace *) getKindAttr r1 = getKindAttr r2 -> map fst r1 = map fst r2. Proof. apply getKindAttr_fst. Qed. Lemma inGetKindAttrImpInMapFstRegs: forall (r: RegsT) a k, In (a, k) (getKindAttr r) -> In a (map fst r). Proof. intros. erewrite <- fst_getKindAttr, in_map_iff; exists (a, k); eauto. Qed. Lemma inFstGetKindAttrIffInFst: forall (r: RegsT) a, In a (map fst (getKindAttr r)) <-> In a (map fst r). Proof. intros; split; intros; [rewrite <- fst_getKindAttr | rewrite fst_getKindAttr]; assumption. Qed. Lemma stripIrrelevantUpd: forall (name: string) (regs: RegsT) (upds: list RegT) v, ~ In name (map fst regs) -> doUpdRegs ((name, v) :: upds) regs = doUpdRegs upds regs. intros. induction regs; simpl; auto; simpl in H. erewrite IHregs; intuition. induction upds; simpl; auto; f_equal; case_eq (fst a =? name); auto; intro; intuition; epose (String.eqb_eq (fst a) name); destruct i; specialize (H3 H2); intuition. Qed. Lemma NoDupMapFstGetKindAttr: forall (r: RegsT), NoDup (map fst r) <-> NoDup (map fst (getKindAttr r)). Proof. intros; split; intro; [rewrite fst_getKindAttr| rewrite <- fst_getKindAttr]; assumption. Qed. Lemma inversionSemAction' k o a reads news calls retC (evalA: @SemAction o k a reads news calls retC): match a with | MCall m s e c => exists mret pcalls, SemAction o (c mret) reads news pcalls retC /\ calls = (m, (existT _ _ (evalExpr e, mret))) :: pcalls | LetExpr _ e cont => SemAction o (cont (evalExpr e)) reads news calls retC | LetAction _ a cont => exists reads1 news1 calls1 reads2 news2 calls2 r1, DisjKey news1 news2 /\ SemAction o a reads1 news1 calls1 r1 /\ SemAction o (cont r1) reads2 news2 calls2 retC /\ reads = reads1 ++ reads2 /\ news = news1 ++ news2 /\ calls = calls1 ++ calls2 | ReadNondet k c => exists rv, SemAction o (c rv) reads news calls retC | ReadReg r k c => exists rv reads2, In (r, existT _ k rv) o /\ SemAction o (c rv) reads2 news calls retC /\ reads = (r, existT _ k rv) :: reads2 | WriteReg r k e a => exists pnews, In (r, k) (getKindAttr o) /\ key_not_In r pnews /\ SemAction o a reads pnews calls retC /\ news = (r, (existT _ _ (evalExpr e))) :: pnews | IfElse p _ aT aF c => match evalExpr p with | true => exists r1, r1 = retC /\ SemAction o (LetAction aT c) reads news calls r1 | false => exists r1, r1 = retC /\ SemAction o (LetAction aF c) reads news calls retC end | Sys _ c => SemAction o c reads news calls retC | Return e => retC = evalExpr e /\ news = nil /\ calls = nil /\ reads = nil end. Proof. destruct evalA; eauto; repeat eexists; eauto; destruct (evalExpr p); try discriminate; eexists; split; econstructor; eauto. Qed. Lemma SemActionExpand o o' {k} {a : ActionT type k} {reads upds calls ret}: forall (HSubList : SubList o o') (HSemAction : SemAction o a reads upds calls ret), SemAction o' a reads upds calls ret. Proof. revert reads upds calls ret. induction a; intros; try (apply inversionSemAction in HSemAction); dest; subst. 7 : { destruct (evalExpr e) eqn:G; dest; [econstructor 7 | econstructor 8]; eauto. } all : econstructor; eauto. rewrite in_map_iff in H; dest. specialize (HSubList _ H2). rewrite in_map_iff. exists x0; split; auto. Qed. Lemma SubList_chain {B C : Type} (l1 : list (B * C)): forall (l2 l3 : list (B * C)) (HNoDup : NoDup (map fst l2)) (HSubList1 : SubList l1 l2) (HSubList2 : SubList l3 l2) (HKeysMatch : map fst l1 = map fst l3), l1 = l3. Proof. induction l1; intros. - destruct l3; inv HKeysMatch; auto. - destruct a; simpl in *. destruct l3; inversion HKeysMatch. destruct p; simpl in *; subst. rewrite (NoDup_map_fst HNoDup (HSubList1 _ (in_eq _ _)) (HSubList2 _ (in_eq _ _))) in *. erewrite IHl1; eauto; eapply SubList_cons; eauto. Qed. Lemma app_cons : (forall (A : Type) (a : A) (l : list A), a :: l = [a] ++ l). Proof. auto. Qed. Lemma NoDup_app_Disj_iff {B : Type} (eqDec : forall a1 a2 : B, {a1 = a2} + {a1 <> a2}): forall (l1 l2 : list B), NoDup (l1 ++ l2) <-> NoDup l1 /\ NoDup l2 /\ (forall a : B, ~In a l1 \/ ~In a l2). Proof. red; repeat split; intros; dest. rewrite NoDup_app_iff in H; dest; auto. rewrite NoDup_app_iff in H; dest; auto. apply NoDup_app_Disj; auto. rewrite NoDup_app_iff; repeat split; auto; intros. destruct (in_dec eqDec a l2); eauto. destruct (H1 a); eauto. destruct (in_dec eqDec a l1); eauto. destruct (H1 a); eauto. Qed. Corollary NoDup_app_DisjKey {B : Type} : forall (l1 l2 : list (string * B)), NoDup (map fst (l1 ++ l2)) <-> NoDup (map fst l1) /\ NoDup (map fst l2) /\ DisjKey l1 l2. Proof. intros; rewrite map_app, NoDup_app_Disj_iff; unfold DisjKey;[reflexivity|apply string_dec]. Qed. Lemma DisjKey_app_split_r {B C : Type} : forall (l1 l2 l3 : list (B * C)), DisjKey l1 (l2 ++ l3) <-> DisjKey l1 l2 /\ DisjKey l1 l3. Proof. split; intros. - split; intro k; specialize (H k); rewrite map_app, in_app_iff, DeM1 in H; destruct H; dest; auto. - dest; intro. destruct (H k); destruct (H0 k); rewrite map_app, in_app_iff, DeM1; auto. Qed. Corollary DisjKey_app_split_l {B C : Type} : forall (l1 l2 l3 : list (B * C)), DisjKey (l1 ++ l2) l3 <-> DisjKey l1 l3 /\ DisjKey l2 l3. Proof. split; intros. - apply DisjKey_Commutative in H; rewrite DisjKey_app_split_r in H; dest; eauto using DisjKey_Commutative. - apply DisjKey_Commutative; rewrite DisjKey_app_split_r; dest; eauto using DisjKey_Commutative. Qed. Lemma NoDup_singleton_map {B C : Type}: forall (a : B) (f : B -> C), NoDup (map f [a]) <-> True. Proof. intros; repeat constructor; auto. Qed. Lemma DisjKey_singletons {B : Type} : forall (a b : string * B), DisjKey [a] [b] <-> fst a <> fst b. Proof. unfold DisjKey; split; repeat intro; simpl in *. - rewrite H0 in H; destruct (H (fst b)); auto. - destruct (string_dec k (fst b)); subst. + left; intro G; destruct G; auto. + right; intro G; destruct G; auto. Qed. Lemma DisjKey_singleton_l {B : Type} : forall (a : string * B) (l : list (string * B)), DisjKey [a] l <-> key_not_In (fst a) l. Proof. unfold DisjKey, key_not_In; split; simpl; repeat intro. - apply (in_map fst) in H0; simpl in *. specialize (H (fst a)); destruct H; auto. - destruct (string_dec k (fst a)); subst. + right; intro. rewrite in_map_iff in H0; dest; destruct x; simpl in *; subst. specialize (H b); contradiction. + left; intro; destruct H0; auto. Qed. Corollary DisjKey_singleton_r {B : Type} : forall (a : string * B) (l : list (string * B)), DisjKey l [a] <-> key_not_In (fst a) l. Proof. split; intro. - apply DisjKey_Commutative in H; rewrite DisjKey_singleton_l in H; assumption. - apply DisjKey_Commutative; rewrite DisjKey_singleton_l; assumption. Qed. Lemma key_not_In_cons {B C : Type} : forall (a : B) (b : B * C) (l : list (B * C)), key_not_In a (b :: l) <-> a <> fst b /\ key_not_In a l. Proof. split; intros; rewrite app_cons in *; [rewrite key_not_In_app_iff in H| rewrite key_not_In_app_iff]; dest; split; auto. - intro; destruct b; simpl in *; subst; eapply H; simpl; auto. - repeat intro; destruct b; simpl in *; subst; destruct H1; auto. apply inversionPair in H1; dest; subst; apply H; reflexivity. Qed. Lemma DisjKey_cons_l {B C : Type} (Heq_dec : forall (a b : B), {a = b} + {a <> b}): forall (b : B * C) (l1 l2 : list (B * C)), DisjKey (b :: l1) l2 <-> key_not_In (fst b) l2 /\ DisjKey l1 l2. Proof. repeat split; intros; dest. - specialize (H (fst b)); destruct H; rewrite key_not_In_fst; simpl in *; auto. - rewrite app_cons in H. rewrite DisjKey_app_split_l in H; dest; auto. - rewrite app_cons, DisjKey_app_split_l; split; auto. repeat intro. rewrite key_not_In_fst in H. destruct (Heq_dec k (fst b)); subst; simpl; auto. left; intro; destruct H1; auto. Qed. Corollary DisjKey_cons_l_str {B : Type} : forall (b : string * B) (l1 l2 : list (string * B)), DisjKey (b :: l1) l2 <-> key_not_In (fst b) l2 /\ DisjKey l1 l2. Proof. intros; apply (DisjKey_cons_l string_dec). Qed. Corollary DisjKey_cons_r_str {B : Type} : forall (b : string * B) (l1 l2 : list (string * B)), DisjKey l1 (b :: l2) <-> key_not_In (fst b) l1 /\ DisjKey l1 l2. Proof. split; intros; [ apply DisjKey_Commutative in H; rewrite DisjKey_cons_l_str in H | apply DisjKey_Commutative; rewrite DisjKey_cons_l_str] ; dest; split; auto; apply DisjKey_Commutative; assumption. Qed. Lemma map_nil {B C : Type} {f : B -> C}: map f nil = nil. Proof. auto. Qed. Lemma doUpdRegs_app_r o : forall u o', doUpdRegs u (o ++ o') = (doUpdRegs u o) ++ (doUpdRegs u o'). Proof. induction o; intros; simpl; auto. case_eq (findReg (fst a) u); intros; subst; f_equal; rewrite IHo; auto. Qed. Lemma findReg_Some_app u : forall s u' x, findReg s (u ++ u') = Some x -> findReg s u = Some x \/ findReg s u' = Some x. Proof. induction u; simpl; intros; auto. destruct String.eqb eqn:G; auto. Qed. Lemma findReg_Some_app_ordered u : forall s u' x y, findReg s (u ++ u') = Some x -> findReg s u = Some y -> x = y. Proof. induction u; simpl; intros;[discriminate|]. destruct String.eqb. - rewrite H in H0; inv H0; reflexivity. - eapply IHu; eauto. Qed. Lemma doUpdRegs_l_reduce o : forall u u', DisjKey u o -> doUpdRegs (u ++ u') o = doUpdRegs u' o. Proof. induction o; simpl; auto; intros. destruct (findReg (fst a) (u ++ u')) eqn:G, (findReg (fst a) u') eqn:G0. - apply findReg_Some_app in G. destruct G. + exfalso. apply findRegs_Some', (in_map fst) in H0. specialize (H (fst a)). destruct H; simpl in *; auto. + rewrite H0 in G0; inv G0; f_equal; apply IHo. intro k; specialize (H k); simpl in H; destruct H; auto. - exfalso. apply findReg_Some_app in G. destruct G;[apply findRegs_Some', (in_map fst) in H0| rewrite H0 in G0; discriminate]. specialize (H (fst a)). destruct H; simpl in *; auto. - exfalso. rewrite <- findRegs_None, map_app, in_app_iff, DeM1 in G; dest. apply findRegs_Some', (in_map fst) in G0; auto. - rewrite IHo; auto. intro k; specialize (H k); simpl in *; destruct H; auto. Qed. Lemma doUpdRegs_r_reduce o : forall u u', DisjKey u' o -> doUpdRegs (u ++ u') o = doUpdRegs u o. Proof. induction o; simpl; auto; intros. destruct (findReg (fst a) (u ++ u')) eqn:G, (findReg (fst a) u) eqn:G0. - apply findReg_Some_app in G. destruct G. + rewrite H0 in G0; inv G0; f_equal; apply IHo. intro k; specialize (H k); simpl in H; destruct H; auto. + exfalso. apply findRegs_Some', (in_map fst) in H0. specialize (H (fst a)). destruct H; simpl in *; auto. - exfalso. apply findReg_Some_app in G. destruct G;[rewrite H0 in G0; discriminate| apply findRegs_Some', (in_map fst) in H0]. specialize (H (fst a)). destruct H; simpl in *; auto. - exfalso. rewrite <- findRegs_None, map_app, in_app_iff, DeM1 in G; dest. apply findRegs_Some', (in_map fst) in G0; auto. - rewrite IHo; auto. intro k; specialize (H k); simpl in *; destruct H; auto. Qed. Lemma doUpdRegs_DisjKey o : forall u, DisjKey u o -> doUpdRegs u o = o. Proof. induction o; simpl; auto; intros. destruct (findReg (fst a) u) eqn:G. - exfalso; apply findRegs_Some' in G. apply (in_map fst) in G; destruct (H (fst a)); auto. apply H0; simpl; auto. - rewrite IHo; auto. intro k; destruct (H k); simpl in *; auto. Qed. Lemma doUpdRegs_app_l o : forall u u', doUpdRegs (u ++ u') o = doUpdRegs u (doUpdRegs u' o). Proof. induction o; simpl; auto; intros. destruct (findReg (fst a) (u ++ u')) eqn:G, (findReg (fst a) u') eqn:G0, (findReg (fst a) u) eqn:G1 ; simpl; try (rewrite G1). - f_equal; auto. rewrite (findReg_Some_app_ordered _ _ _ G G1); reflexivity. - apply findReg_Some_app in G; destruct G as [G|G]; rewrite G in *;[discriminate|inv G0]. f_equal; eauto. - apply findReg_Some_app in G; destruct G as [G|G]; rewrite G in *;[inv G1|discriminate]. f_equal; eauto. - apply findReg_Some_app in G; rewrite G0, G1 in G; destruct G; discriminate. - rewrite <- findRegs_None, map_app, in_app_iff, DeM1 in G. apply findRegs_Some', (in_map fst) in G0; dest; contradiction. - rewrite <- findRegs_None, map_app, in_app_iff, DeM1 in G. apply findRegs_Some', (in_map fst) in G0; dest; contradiction. - rewrite <- findRegs_None, map_app, in_app_iff, DeM1 in G. apply findRegs_Some', (in_map fst) in G1; dest; contradiction. - f_equal; eauto. Qed. Lemma doUpdRegs_cons_l o : forall r u, doUpdRegs (r::u) o = doUpdRegs [r] (doUpdRegs u o). Proof. intros; rewrite app_cons; apply doUpdRegs_app_l. Qed. Lemma doUpdReg_preserves_getKindAttr : forall u o, NoDup (map fst o) -> SubList (getKindAttr u) (getKindAttr o) -> getKindAttr (doUpdRegs u o) = getKindAttr o. Proof. symmetry; erewrite getKindAttr_doUpdRegs; eauto; intros. apply H0; rewrite in_map_iff; eexists; split; eauto. simpl; reflexivity. Qed. Lemma doUpdRegs_preserves_keys o : forall u, map fst (doUpdRegs u o) = map fst o. Proof. induction o; simpl; auto; intros. destruct findReg; rewrite IHo; reflexivity. Qed. Lemma DisjKey_rewrite_l {B C : Type} : forall (l1 l2 l3: list (B * C)), map fst l1 = map fst l2 -> DisjKey l1 l3 <-> DisjKey l2 l3. Proof. intros; split; unfold DisjKey; repeat intro; rewrite H in *; auto. Qed. Lemma doUpdRegs_key_not_In a l1 : key_not_In (fst a) l1 -> doUpdRegs [a] l1 = l1. Proof. intro. rewrite <- DisjKey_singleton_l in H. apply doUpdRegs_DisjKey; assumption. Qed. Lemma doUpdRegs_keys_neq a b : fst a <> fst b -> doUpdRegs [a] [b] = [b]. Proof. rewrite <- DisjKey_singletons; intros. apply doUpdRegs_DisjKey; assumption. Qed. Lemma in_cons_iff {B : Type} {a b : B} {l : list B}: In a (b :: l) <-> b = a \/ In a l. Proof. split; intros; simpl in *; auto. Qed. Lemma nIn_app_iff {B : Type} (Heq_dec : forall (a b : B), {a = b} + {a <> b}) : forall (a : B) (l1 l2 : list B), ~In a (l1 ++ l2) <-> ~In a l1 /\ ~In a l2. Proof. split; intros; rewrite in_app_iff, DeM1 in *; auto. Qed. Lemma SubList_nil_r {B : Type} : forall (l : list B), SubList l nil -> l = nil. Proof. repeat intro; induction l; auto. exfalso; specialize (H _ (in_eq _ _)); auto. Qed. Lemma SubList_filter {B : Type} : forall (a : B) (l1 l2 : list B), SubList l1 l2 -> ~In a l2 -> ~In a l1. Proof. repeat intro; eauto. Qed. Lemma DisjKey_filter {B C : Type} : forall (l1 l2 l3 l4 : list (B * C)), SubList (map fst l3) (map fst l1) -> SubList (map fst l4) (map fst l2) -> DisjKey l1 l2 -> DisjKey l3 l4. Proof. repeat intro; firstorder fail. Qed. Lemma DisjKey_filter_r {B C : Type} : forall (l1 l2 l3 : list (B * C)), SubList (map fst l3) (map fst l2) -> DisjKey l1 l2 -> DisjKey l1 l3. Proof. repeat intros; firstorder fail. Qed. Lemma DisjKey_filter_l {B C : Type} : forall (l1 l2 l3 : list (B * C)), SubList (map fst l3) (map fst l2) -> DisjKey l2 l1 -> DisjKey l3 l1. Proof. repeat intros; firstorder fail. Qed. Lemma doUpdRegs_cons_r' : forall (u o : RegsT) (r : RegT), doUpdRegs u (r :: o) = doUpdReg u r :: doUpdRegs u o. Proof. intros; simpl; auto. Qed. Lemma oneUpdRegs_doUpdRegs : forall (o : RegsT) (r : RegT), doUpdRegs [r] o = oneUpdRegs r o. Proof. induction o; intros; auto. simpl; destruct String.eqb eqn:G; f_equal; eauto. rewrite String.eqb_eq in G; rewrite G; destruct r; reflexivity. Qed. Lemma doUpdRegs_cons_l' : forall (u o : RegsT) (r : RegT), doUpdRegs (r :: u) o = oneUpdRegs r (doUpdRegs u o). Proof. intros. rewrite <- oneUpdRegs_doUpdRegs, doUpdRegs_cons_l; reflexivity. Qed. Lemma doUpdReg_oneUpdReg : forall (r1 r2 : RegT), oneUpdReg r1 r2 = doUpdReg [r1] r2. Proof. intros; unfold oneUpdReg, doUpdReg, findReg. destruct String.eqb eqn:G; auto. rewrite String.eqb_eq in G; rewrite G; destruct r1; reflexivity. Qed. Lemma oneUpdRegs_cons : forall (o : RegsT) (r1 r2 : RegT), oneUpdRegs r1 (r2 :: o) = oneUpdReg r1 r2 :: oneUpdRegs r1 o. Proof. intros; rewrite <- oneUpdRegs_doUpdRegs, doUpdRegs_cons_r', <- doUpdReg_oneUpdReg. f_equal; apply oneUpdRegs_doUpdRegs. Qed. Lemma oneUpdRegs_app : forall (o1 o2 : RegsT) (r : RegT), oneUpdRegs r (o1 ++ o2) = oneUpdRegs r o1 ++ oneUpdRegs r o2. Proof. intros; repeat rewrite <- oneUpdRegs_doUpdRegs; rewrite doUpdRegs_app_r; reflexivity. Qed. Lemma doUpdReg_doUpdRegs : forall (u : RegsT) (r : RegT), doUpdRegs u [r] = [doUpdReg u r]. Proof. auto. Qed. Lemma doUpdReg_app : forall (u1 u2 : RegsT) (r : RegT), doUpdReg (u1 ++ u2) r = doUpdReg u1 (doUpdReg u2 r). Proof. intros. enough ([doUpdReg (u1 ++ u2) r] = [doUpdReg u1 (doUpdReg u2 r)]) as P. { inv P; reflexivity. } repeat rewrite <- doUpdReg_doUpdRegs; rewrite doUpdRegs_app_l; reflexivity. Qed. Lemma doUpdReg_cons : forall (u : RegsT) (r1 r2 : RegT), doUpdReg (r1 :: u) r2 = oneUpdReg r1 (doUpdReg u r2). Proof. intros. enough ([doUpdReg (r1 :: u) r2] = [oneUpdReg r1 (doUpdReg u r2)]) as P. { inv P; reflexivity. } rewrite <- doUpdReg_doUpdRegs, doUpdRegs_cons_l, doUpdReg_doUpdRegs, oneUpdRegs_doUpdRegs. reflexivity. Qed. Lemma doUpdReg_notIn : forall (u : RegsT) (r : RegT), ~ In (fst r) (map fst u) -> doUpdReg u r = r. Proof. induction u; intros; auto. unfold doUpdReg; destruct findReg eqn:G; auto. exfalso; apply findRegs_Some', (in_map fst) in G; apply H; assumption. Qed. Corollary doUpdReg_nil : forall (r : RegT), doUpdReg nil r = r. Proof. eauto using in_nil, doUpdReg_notIn. Qed. Lemma oneUpdRegs_notIn : forall (u : RegsT) (r : RegT), ~ In (fst r) (map fst u) -> oneUpdRegs r u = u. Proof. induction u; intros; auto. simpl; destruct String.eqb eqn:G. - rewrite String.eqb_eq in G; simpl in H; subst. exfalso; apply H; auto. - f_equal; apply IHu; intro; apply H; simpl; auto. Qed. Lemma DisjKey_rewrite_r {B C : Type}: forall (l1 l2 l3 : list (B * C)), map fst l1 = map fst l2 -> DisjKey l3 l1 <-> DisjKey l3 l2. Proof. split; intros; apply DisjKey_Commutative. - rewrite DisjKey_rewrite_l; [apply (DisjKey_Commutative H0)| apply eq_sym, H]. - rewrite DisjKey_rewrite_l; [apply (DisjKey_Commutative H0)| apply H]. Qed. Lemma BreakGKAEvar1 {B C : Type} {P : C -> Type} (l1 : list (B * {x : C & P x})) x l2 : forall a b l3 p, l1 = (a, (existT _ b p)) :: l3 -> (a, b) = x -> getKindAttr l3 = l2 -> getKindAttr l1 = x :: l2. Proof. intros; subst; simpl; f_equal. Qed. Lemma BreakGKAEvar2 {B C : Type} {f : B -> C} l1 l2 l3 : forall l4 l5, l1 = l4 ++ l5 -> map f l4 = l2 -> map f l5 = l3 -> map f l1 = l2 ++ l3. Proof. intros; subst; rewrite map_app; reflexivity. Qed. Lemma doUpdReg_preserves_keys : forall (u : RegsT) (r : RegT), fst (doUpdReg u r) = fst r. Proof. induction u; intros; eauto using doUpdReg_nil. unfold doUpdReg; simpl; destruct String.eqb; auto; apply IHu. Qed. Lemma SubList_cons_l_iff {B : Type}: forall (a : B) (l1 l2 : list B), SubList (a :: l1) l2 <-> In a l2 /\ SubList l1 l2. Proof. split; intros; rewrite app_cons, SubList_app_l_iff in *; split; try firstorder fail. repeat intro; inv H0; dest; auto. inv H1. Qed. Lemma SubList_nil_l {B : Type} : forall (l : list B), SubList nil l. Proof. repeat intro; inv H. Qed. Lemma gatherAction_invar {B: Type} {k_in k_out} (f : B -> ActionT type k_in) myReg (cont : ActionT type k_out): ActionWb myReg cont -> (forall (b : B), ActionWb myReg (f b)) -> forall (l : list B), ActionWb myReg (gatherActions (map f l) (fun val => cont)). Proof. induction l; simpl; intros; auto. unfold ActionWb; intros. apply inversionSemAction' in H3; dest; subst. specialize (H0 _ _ _ _ _ _ H1 H2 H4). specialize (IHl _ _ _ _ _ H1 H2 H5); dest. rewrite <- H10 in H13. specialize (SubList_chain H1 H6 H0 (getKindAttr_fst _ _ (eq_sym H13))) as P; subst. split. - eexists; repeat split; eauto. + rewrite SubList_app_l_iff; split; auto. + econstructor; eauto. - rewrite map_app, SubList_app_l_iff; split; auto. Qed. Lemma ActionWbExpand : forall k (a : ActionT type k) myRegs1 myRegs2, SubList myRegs1 myRegs2 -> ActionWb myRegs1 a -> ActionWb myRegs2 a. Proof. unfold ActionWb; intros. specialize (H0 _ _ _ _ _ H1 (SubList_transitive H H2) H3); dest. rewrite SubList_map_iff in H2; dest. assert (SubList x x0). { rewrite <- H8, <- H6 in H. repeat intro. specialize (H0 _ H9). specialize (in_map fst _ _ H9) as P. apply (SubList_map fst) in H; repeat rewrite fst_getKindAttr in H. specialize (H _ P). rewrite in_map_iff in H; dest. specialize (H2 _ H10). rewrite (KeyMatching3 _ _ _ H1 H0 H2 (eq_sym H)). assumption. } split. - exists x0; repeat split; auto. + apply (SubList_transitive H5 H9). + eapply SemActionExpand; [apply H9| assumption]. - apply (SubList_transitive H4 H). Qed. Lemma RetvWb : ActionWb nil Retv%kami_action. Proof. unfold ActionWb; intros. apply inversionSemAction' in H1; dest; subst. split; [eexists; repeat split; auto; try instantiate (1 := nil) |]; eauto using SubList_nil_l. constructor; auto. Qed. Lemma SemActionSub : forall o k (a : ActionT type k) reads upds calls ret, SemAction o a reads upds calls ret -> SubList reads o /\ SubList (getKindAttr upds) (getKindAttr o). Proof. intros; eauto using SemActionReadsSub, SemActionUpdSub. Qed. Lemma doUpdRegs_idemp o : NoDup (map fst o) -> doUpdRegs o o = o. Proof. induction o; auto; intros. inv H; destruct a; simpl. rewrite String.eqb_refl, doUpdRegs_cons_l, doUpdRegs_key_not_In, IHo; auto. rewrite IHo; auto. repeat intro; apply H2. rewrite in_map_iff. exists (s, v); auto. Qed. Lemma doUpdRegs_idemp' o o' : o = o' -> NoDup (map fst o) -> doUpdRegs o o' = o'. Proof. intros; subst; apply doUpdRegs_idemp; auto. Qed. Require Import RelationClasses. Section Effect_trans. Variable k : Kind. Variable R1 R2: RegsT -> RegsT -> Prop. Lemma Effectless_trans (a1 a2 a3 : ActionT type k): EffectlessRelation R1 a1 a2 -> EffectlessRelation R2 a2 a3 -> EffectlessRelation (fun o1 o2 => exists o3, R1 o1 o3 /\ R2 o3 o2) a1 a3. Proof. unfold EffectlessRelation; intros; dest. specialize (H _ _ H1 _ _ _ _ H2); dest; subst; repeat split. eapply H0; eauto. Qed. Lemma Effectful_trans (a1 a2 a3 : ActionT type k): EffectfulRelation R1 a1 a2 -> EffectfulRelation R2 a2 a3 -> EffectfulRelation (fun o1 o2 => exists o3, R1 o1 o3 /\ R2 o3 o2) a1 a3. Proof. unfold EffectfulRelation; intros; dest. specialize (H _ _ H1 _ _ _ _ H2); dest; subst. specialize (H0 _ _ H3 _ _ _ _ H); dest. exists x2, x3; split; auto. exists (doUpdRegs x1 x); split; auto. Qed. End Effect_trans. Section Effect_refl. Variable k : Kind. Definition EffectlessAction (a : ActionT type k) := forall o reads upds calls retVal, SemAction o a reads upds calls retVal -> upds = nil /\ calls = nil. Lemma Effectful_refl (a : ActionT type k): EffectfulRelation (fun o1 o2 => o1 = o2) a a. Proof. unfold EffectfulRelation; intros; dest. exists reads_i, upds_i; subst; split; auto. Qed. Lemma Effectless_refl (a : ActionT type k): EffectlessAction a -> EffectlessRelation (fun o1 o2 => o1 = o2) a a. Proof. unfold EffectlessRelation; intros. specialize (H _ _ _ _ _ H1); dest; subst. repeat split. exists reads_i; assumption. Qed. End Effect_refl. ================================================ FILE: GallinaModules/AuxTactics.v ================================================ Require Import Kami.All. Require Import Kami.GallinaModules.AuxLemmas. Require Import Kami.GallinaModules.Relations. (* subst, but also rewrites with arbitrary equalities *) Ltac mySubst := progress first [subst | match goal with | [H : _ = _ |- _] => try rewrite H in *; clear H; subst end]. Ltac find_if_inside := match goal with | [H : ?X = _ |- context[if ?X then _ else _]] => rewrite H | [ |- context[if ?X then _ else _]] => let G := fresh "G" in has_evar X ; destruct X eqn: G end. (* clear out trivially true statements *) Ltac clean_useless_hyp := match goal with | [ H : ?a = ?a |- _] => clear H | [ H : True |- _] => clear H | [ H : SubList nil _ |- _] => clear H | [ H : key_not_In _ nil |- _] => clear H | [ H : DisjKey _ nil |- _] => clear H | [ H : DisjKey nil _ |- _] => clear H | [ H : NoDup nil |- _] => clear H | [ H : NoDup (_ :: nil) |- _] => clear H | [ H : ~In _ nil |- _] => clear H | [ H1 : ?P, H2 : ?P |- _] => clear H1 end. (* Transforms hypotheses and goals into a form suitable for the solvers *) Ltac my_simplifier := match goal with | [ H1 : ?a = ?b, H2 : ?a = ?c |- _] => rewrite H1 in H2 | [ H : context [map _ nil] |- _] => rewrite map_nil in H | [ H : context [map ?f (?l1 ++ ?l2)] |- _] => rewrite (map_app f l1 l2) in H | [ H : context [map ?f (?l1 :: ?l2)] |- _] => rewrite (map_cons f l1 l2) in H | [ H : context [?a ++ nil] |- _] => rewrite (app_nil_r a) in H | [ H : context [nil ++ ?a] |- _] => rewrite (app_nil_l a) in H | [ H : _ \/ _ |- _] => destruct H | [ H : _ /\ _ |- _] => destruct H | [ H : SubList _ nil |- _] => apply SubList_nil_r in H | [ H : (_, _) = (_, _) |- _] => apply inversionPair in H; destruct H as [? ?] | [ H : existT ?a ?b ?c1 = existT ?a ?b ?c2 |- _] => apply Eqdep.EqdepTheory.inj_pair2 in H | [ H : existT ?a ?b1 ?c1 = existT ?a ?b2 ?c2 |- _] => apply inversionExistT in H; destruct H as [? ?] | [ H1 : In (?a, ?b) ?c, H2 : ~In ?a (map fst ?c) |- _] => apply (in_map fst) in H1; contradiction | [ H : forall _, (~In _ (map fst ?l1)) \/ (~In _ (map fst ?l2)) |- _] => fold (DisjKey l1 l2) in H | [ |- context [map _ nil]] => rewrite map_nil | [ |- context [map ?f (?l1 ++ ?l2)]] => rewrite (map_app f l1 l2) | [ |- context [map _ (?l1 :: ?l2)]] => rewrite map_cons | [ |- context [In _ (_ :: _)]] => rewrite in_cons_iff | [ |- context [In _ (_ ++ _)]] => rewrite in_app_iff | [ |- context [map fst (doUpdRegs _ _)]] => rewrite doUpdRegs_preserves_keys | [ |- context [fst (doUpdReg _ _ )]] => rewrite doUpdReg_preserves_keys | [ |- context [doUpdRegs nil _]] => rewrite doUpdRegs_nil | [ |- context [doUpdReg nil _]] => rewrite doUpdReg_nil | [ |- ( _ , _ ) = ( _ , _ )] => f_equal | [ |- (map (fun x => (fst x, projT1 (snd x))) _) = _ :: _] => eapply BreakGKAEvar1 | [ |- (map (fun x => (fst x, projT1 (snd x))) _) = _ ++ _] => eapply BreakGKAEvar2 | [ H : SubList (_ :: _) _ |- _] => rewrite SubList_cons_l_iff in H | [ H : SubList (_ ++ _) _ |- _] => rewrite SubList_app_l_iff in H end. Ltac decompose_In H := repeat (rewrite in_cons_iff in H || rewrite in_app_iff in H). Ltac aggressive_key_finder2 := (match goal with | [ H1 : SubList (map fst _) (map fst _) |- _] => revert H1 ; aggressive_key_finder2 | [ H1 : SubList (map (fun x => (fst x, projT1 (snd x))) _) (map (fun y => (fst y, projT1 (snd y))) _) |- _] => apply (SubList_map fst) in H1 ; repeat rewrite fst_getKindAttr in H1 ; revert H1 ; aggressive_key_finder2 | [ H1 : SemAction _ _ _ _ _ _ |- _] => apply SemActionSub in H1 ; destruct H1 as [? ?] ; aggressive_key_finder2 | [ H1 : SubList _ _ |- _] => apply (SubList_map fst) in H1 ; revert H1 ; aggressive_key_finder2 | _ => idtac end) ; intros. (* Aggressively attempts to find getKindAttr connections, probably should be more aggressive *) Ltac aggressive_gka_finder l1 := match goal with | [ H1 : SubList l1 _ |- _] => apply (SubList_map (fun x => (fst x, projT1 (snd x)))) in H1 | [ H1 : SemAction _ _ l1 _ _ _ |- _] => apply SemActionReadsSub in H1 | [ H1 : SemAction _ _ _ l1 _ _ |- _] => apply SemActionUpdSub in H1 end. (* Aggressively attempts to find getKindAttr connections, probably should be more aggressive *) Ltac aggressive_gka_finder2 := (match goal with | [ H1 : SubList (map (fun x => (fst x, projT1 (snd x))) _) (map (fun y => (fst y, projT1 (snd y))) _) |- _] => revert H1 ; aggressive_gka_finder2 | [ H1 : SubList _ _ |- _] => apply (SubList_map (fun x => (fst x, projT1 (snd x)))) in H1 ; revert H1 ; aggressive_gka_finder2 | [ H1 : SemAction _ _ _ _ _ _ |- _] => apply SemActionSub in H1 ; destruct H1 as [? ?] ; aggressive_gka_finder2 | [ H1 : SemAction _ _ _ _ _ _ |- _] => apply SemActionSub in H1 ; destruct H1 as [? ?] ; aggressive_gka_finder2 | _ => idtac end) ; intros. (* Searches for hypotheses that can be transormed into SubList statements *) Ltac aggressive_sublist_finder2 := (match goal with | [ H : SubList _ _ |- _] => revert H ; aggressive_sublist_finder2 | [ H : SemAction _ _ _ _ _ _ |- _] => apply SemActionSub in H ; destruct H ; aggressive_sublist_finder2 | _ => idtac end) ; intros. (* Attempts to solve statements about simplified SubLists *) Ltac sublist_sol := (match goal with | [ |- SubList _ (map (fun y => (fst y, projT1 (snd y))) ?b)] => aggressive_gka_finder2 | [ |- SubList ?a ?b] => aggressive_sublist_finder2 end) ; let v := fresh "v" in let HIn := fresh "H" in intros v HIn ; repeat my_simplifier ; repeat (match goal with | [HSubList : SubList ?c ?d |- _] => (specialize (HSubList v) || clear HSubList) end) ; tauto. (* Attempts to solve key Disjointness goals by aggressively finding all logical connections between every type of key *) Ltac solve_keys := let TMP1 := fresh "H" in let TMP2 := fresh "H" in let v := fresh "k" in (match goal with | [ |- ~ In ?k (map fst ?l1)] => specialize (SubList_refl (map fst l1)) as TMP1 ; aggressive_key_finder2 ; repeat (match goal with | [H : SubList (map fst _) (map fst _) |- _] => specialize (H k) | [H : DisjKey _ _ |- _] => specialize (H k) end) ; repeat rewrite key_not_In_fst in * | [ |- DisjKey ?l1 ?l2] => specialize (SubList_refl (map fst l1)) as TMP1 ; specialize (SubList_refl (map fst l2)) as TMP2 ; aggressive_key_finder2 ; intro v ; repeat (match goal with | [H : SubList (map fst _) (map fst _) |- _] => specialize (H v) | [H : DisjKey _ _ |- _] => specialize (H v) end) end); repeat rewrite key_not_In_fst in * ; tauto. (* Breaks SubList goal into multiple, generic goals recognizable by the solver *) Ltac normalize_sublist_l := match goal with | [ |- In _ _] => my_simplifier | [ |- SubList (_ :: _) _] => rewrite SubList_cons_l_iff; split | [ |- SubList (_ ++ _) _] => rewrite SubList_app_l_iff; split end. (* slightly problematic, unifies variables under a specific condition asserts should attempt to solve using the solver instead of just leaving it for later *) Ltac resolve_sublist := let HNoDup := fresh "HNoDup" in let HSubList2 := fresh "HSubList" in match goal with | [Heq : (map (fun x => (fst x, _)) ?o1) = (map (fun y => (fst y, _)) ?o2), HSubList1 : SubList ?o1 ?o3 |- _] => assert (NoDup (map fst o3)) as HNoDup ;[ | assert (SubList o2 o3) as HSubList2 ; [clear HNoDup | specialize (SubList_chain HNoDup HSubList1 HSubList2 (getKindAttr_fst _ _ Heq)) as ? ; subst ; clear Heq HNoDup HSubList1 HSubList2] ] | [Heq : (map fst ?o1) = (map fst ?o2), HSubList1 : SubList ?o1 ?o3 |- _] => assert (NoDup (map fst o3)) as HNoDup ;[clear HNoDup | assert (SubList o2 o3) as HSubList2 ; [ | specialize (SubList_chain HNoDup HSubList1 HSubList2 Heq) as ? ; subst ; clear Heq HNoDup HSubList1 HSubList2] ] end. (* slightly problematic, unifies variables under a specific condition asserts should attempt to solve using the solver instead of just leaving it for later *) Ltac resolve_sublist2 := match goal with | [ Heq:map (fun x => (fst x, _)) ?o1 = map (fun y => (fst y, _)) ?o2, HSubList1 : SubList ?o1 ?o3, HNoDup:NoDup (map fst ?o3) |- _ ] => let HSubList2 := fresh "H" in assert (HSubList2 : SubList o2 o3) ;[ sublist_sol | specialize (SubList_chain HNoDup HSubList1 HSubList2 (getKindAttr_fst _ _ Heq)) as ? ; clear HSubList2] ; mySubst end. (* solves specific Effectful/Effectless relation conditions *) Ltac resolve_rel := let HupdsNil := fresh "HupdsNil" in let HcallsNil := fresh "HcallsNil" in let reads_s := fresh "reads_s" in let HSemAction_s := fresh "HSemAction_s" in let upds_s := fresh "upds_s" in let HdoUpdRegsR := fresh "HdoUpdRegsR" in match goal with | [HSemAction : SemAction ?o_i ?a_i _ _ _ _, HERelation : EffectlessRelation ?R ?a_i _, HoRelation : ?R ?o_i _ |- _] => specialize (HERelation _ _ HoRelation _ _ _ _ HSemAction) as [HupdsNil [HcallsNil [reads_s HSemAction_s]]] ; clear HSemAction | [HSemAction : SemAction ?o_i1 (?a_i _) _ _ _ _, HERelation : forall _, EffectlessRelation ?R (?a_i _) _, HoRelation : ?R ?o_i2 ?o_j |- _] => specialize (HERelation _ _ _ HoRelation _ _ _ _ HSemAction) as [HupdsNil [HcallsNil [reads_s HSemAction_s]]] ; clear HSemAction | [HSemAction : SemAction ?o_i1 ?a_i _ _ _ _, HERelation : EffectfulRelation ?R ?a_i _, HoRelation : ?R ?o_i2 ?o_j |- _] => specialize (HERelation _ _ HoRelation _ _ _ _ HSemAction) as [reads_s [upds_s [HSemAction_s HdoUpdRegsR]]] ; clear HSemAction | [HSemAction : SemAction ?o_i1 (?a_i _) _ _ _ _, HERelation : forall _, EffectfulRelation ?R (?a_i _) _, HoRelation : ?R ?o_i2 ?o_j |- _] => specialize (HERelation _ _ _ HoRelation _ _ _ _ HSemAction) as [reads_s [upds_s [HSemAction_s HdoUpdRegsR]]] ; clear HSemAction end. (* Despite the name, likely not aggressive enough. Should replace SemAction*Sub with SemActionReadsUpdSub and just match every SemAction *) Ltac aggressive_key_finder l1 := match goal with | [ H1 : SubList l1 _ |- _] => apply (SubList_map fst) in H1 | [ H1 : SubList (map (fun x => (fst x, projT1 (snd x))) l1) (map (fun y => (fst y, projT1 (snd y))) _) |- _] => apply (SubList_map fst) in H1 ; repeat rewrite fst_getKindAttr in H1 | [ H1 : SemAction _ _ l1 _ _ _ |- _] => apply SemActionReadsSub in H1 | [ H1 : SemAction _ _ _ l1 _ _ |- _] => apply SemActionUpdSub in H1 end. (* Transforms doUpdRegs statements into a version recognizable by the reducer *) Ltac doUpdRegs_simpl := match goal with | [ |- context [doUpdRegs ?a (?b ++ ?c)]] => rewrite (doUpdRegs_app_r b a c) | [ |- context [doUpdRegs ?a (?b :: ?c)]] => rewrite (doUpdRegs_cons_r' a c b) | [ |- context [doUpdRegs (?a ++ ?b) ?c]] => rewrite (doUpdRegs_app_l c a b) | [ |- context [doUpdRegs (?a :: ?b) ?c]] => rewrite (doUpdRegs_cons_l' b c a) | [ |- context [doUpdReg (?a ++ ?b) ?c]] => rewrite (doUpdReg_app a b c) | [ |- context [doUpdReg (?a :: ?b) ?c]] => rewrite (doUpdReg_cons b a c) | [H : context [doUpdRegs ?a (?b ++ ?c)] |- _] => rewrite doUpdRegs_app_r in H | [H : context [doUpdRegs ?a (?b :: ?c)] |- _] => rewrite doUpdRegs_cons_r' in H | [H : context [doUpdRegs (?a ++ ?b) ?c] |- _] => rewrite doUpdRegs_app_l in H | [H : context [doUpdRegs (?a :: ?b) ?c] |- _] => rewrite doUpdRegs_cons_l' in H | [H : context [doUpdReg (?a ++ ?b) ?c] |- _] => rewrite doUpdReg_app in H | [H : context [doUpdReg (?a_ :: ?b) ?c] |- _] => rewrite doUpdReg_cons in H end. (* Simply breaks apart a goal *) Ltac goal_split := match goal with | [ |- ex _] => eexists | [ |- _ /\ _] => split end. (* Attempts to reduce statements about the getKindAttr of doUpdRegs *) Ltac gka_doUpdReg_red := match goal with | [ |- context [getKindAttr (doUpdRegs ?u ?o)]] => let TMP1 := fresh "H" in let TMP2 := fresh "H" in assert (NoDup (map fst o)) as TMP1 ; [repeat rewrite doUpdRegs_preserves_keys (*a bit weak *) ; auto | assert (SubList (getKindAttr u) (getKindAttr o)) as TMP2 ;[ repeat (aggressive_gka_finder u) ; auto | rewrite (doUpdReg_preserves_getKindAttr _ _ TMP1 TMP2) ; clear TMP1 TMP2]] end. (* Makes a best guess for a solution and unifies Evars potentially dangerous. *) Ltac my_risky_solver := match goal with | [ |- _ :: _ = _ :: _ ] => f_equal | [ |- _ ++ _ = _ ++ _ ] => f_equal | [ H : ?a = ?b |- _] => discriminate | [ |- map _ ?x = nil] => is_evar x; apply map_nil end. (* Reduces simple goals, but may make things more difficult by changing forms to something harder to solve *) Ltac my_risky_simplifier := match goal with | [ |- context [_ ++ nil]] => rewrite app_nil_r | [ |- context [nil ++ _]] => rewrite app_nil_l end. (* A bit of a patch, trying to fulfill obligations down the line that are not alway obvious *) Ltac sublist_iff := match goal with | [ H : SubList ?l (map (fun x => (fst x, projT1 (snd x))) _) |- _] => (match l with | (map (fun y => (fst y, projT1 (snd y))) _) => revert H; sublist_iff | _ => rewrite SubList_map_iff in H; dest; sublist_iff end) | _ => intros end. Ltac extract_gatherActions' subRegs := match goal with | [ H : SemAction ?o (gatherActions (map ?f ?l) (fun _ : _ => ?s)) _ _ _ _ |- _] => assert (ActionWb subRegs s /\ (forall t', ActionWb subRegs (f t'))) end. (* consumes the main body of a SemAction *) Ltac main_body := match goal with | [H: SemAction _ (Return _) _ _ _ _ |- _] => apply inversionSemAction' in H ; destruct H as [? [? [? ?]]] | [H: SemAction _ (MCall _ _ _ _) _ _ _ _ |- _] => apply inversionSemAction' in H ; destruct H as [? [? [? ?]]] | [H: SemAction _ (LetAction _ _) _ _ _ _ |- _] => apply inversionSemAction' in H ; destruct H as [? [? [? [? [? [? [? [? [? [? [? [? ?]]]]]]]]]]]] | [H: SemAction _ (ReadReg _ _ _) _ _ _ _ |- _] => let TMP := fresh "H" in apply inversionSemAction' in H ; destruct H as [? [? [TMP [? ?]]]]; decompose_In TMP | [H: SemAction _ (WriteReg _ _ _) _ _ _ _ |- _] => apply inversionSemAction' in H ; destruct H as [? [? [? [? ?]]]] | [H: SemAction _ (IfElse _ _ _ _) _ _ _ _ |- _] => apply inversionSemAction' in H; let TMP := fresh "H" in destruct evalExpr eqn:TMP in H ; destruct H as [? [? ?]] | [H: SemAction _ (LetExpr _ _) _ _ _ _ |- _] => apply inversionSemAction' in H | [H: SemAction _ (ReadNondet _ _) _ _ _ _ |- _] => apply inversionSemAction' in H ; destruct H as [? ?] | [H: SemAction _ (Sys _ _) _ _ _ _ |- _] => apply inversionSemAction' in H | [H: SemAction _ (gatherActions (map _ ?l) _) _ _ _ _ |- _] => idtac (* TODO : put gatherActions workflow here *) end. Ltac risky_unify := match goal with | [ |- ?a = _] => has_evar a; reflexivity | [ |- _ = ?a] => has_evar a; reflexivity end. Ltac resolve_In := let TMP := fresh "H" in match goal with | [ HNoDup : NoDup (map fst ?o), H1 : In (?s, ?a) ?o, H2 : In (?s, ?b) ?o |- _] => specialize (NoDup_map_fst HNoDup H1 H2) as TMP; EqDep_subst; clear H1 end. Ltac extract_in_map := (match goal with | [H : In _ (map _ _) |- _] => let TMP := fresh "H" in specialize H as TMP ; rewrite in_map_iff in TMP ; revert H TMP ; extract_in_map | [H : SubList _ (map _ _) |- _] => let TMP := fresh "H" in specialize H as TMP ; rewrite SubList_map_iff in TMP ; revert H TMP ; extract_in_map | _ => idtac end) ; intros ; dest. Ltac extract_in_map' := (match goal with | [H : In _ (map _ _) |- _] => let TMP := fresh "H" in specialize H as TMP ; rewrite in_map_iff in TMP ; let x1 := fresh "x" in let x2 := fresh "x" in let x3 := fresh "x" in let Hfeq := fresh "H" in let HIn := fresh "H" in destruct TMP as [[x1 [x2 x3]] [Hfeq HIn]] ; revert H x1 Hfeq HIn ; extract_in_map' | [H : SubList _ (map _ _) |- _] => let TMP := fresh "H" in specialize H as TMP ; rewrite SubList_map_iff in TMP ; revert H TMP ; extract_in_map' | _ => idtac end) ; intros ; dest ; simpl in * ; repeat my_simplifier; subst. Ltac dangerous_solver := match goal with | [ H : ?a = ?b |- ?c = ?b] => has_evar c ; apply H end. Ltac right_subst := match goal with | [ H1 : ?b = ?a, H2 : ?c = ?a |- _] => rewrite <- H1 in H2 end. Ltac normalize_key_hyps1 := match goal with | [ H : context [map fst (_ ++ _)] |- _] => rewrite map_app in H | [ H : forall _, (~In _ (map fst ?l1)) \/ (~In _ (map fst ?l2)) |- _] => fold (DisjKey l1 l2) in H | [ H : NoDup (_ ++ _) |- _] => rewrite (NoDup_app_Disj_iff string_dec) in H; destruct H as [? [? ?]] | [ H : DisjKey (_ ++ _) _ |- _] => rewrite DisjKey_app_split_l in H; destruct H as [? ?] | [ H : DisjKey _ (_ ++ _) |- _] => rewrite DisjKey_app_split_r in H; destruct H as [? ?] | [ H : ~In _ (_ ++ _) |- _] => rewrite (nIn_app_iff string_dec) in H; destruct H as [? ?] | [ H : DisjKey (_ :: _) _ |- _] => rewrite DisjKey_cons_l_str in H; destruct H as [? ?] | [ H : DisjKey _ (_ :: _) |- _] => rewrite DisjKey_cons_r_str in H; destruct H as [? ?] end. Ltac normalize_key_hyps2 := match goal with | [ H : context [map fst (_ :: _)] |- _] => rewrite map_cons in H | [ H : context [map fst nil] |- _] => rewrite map_nil in H | [ H : NoDup (_ :: _) |- _] => rewrite NoDup_cons_iff in H; destruct H as [? ?] | [ H : key_not_In _ (_ :: _) |- _] => rewrite key_not_In_cons in H; destruct H as [? ?] | [ H : ~In _ (_ :: _) |- _] => rewrite not_in_cons in H; destruct H as [? ?] end. Ltac normalize_key_hyps := repeat normalize_key_hyps1; repeat normalize_key_hyps2; cbn [fst] in *; repeat clean_useless_hyp. Ltac my_simpl_solver := match goal with | [ H : ?P |- ?P] => apply H | [ |- DisjKey nil _] => apply DisjKey_nil_l | [ |- DisjKey _ nil] => apply DisjKey_nil_r | [ |- ?a = ?a] => reflexivity | [ |- True] => apply I | [ |- NoDup nil] => constructor | [ |- ~In _ nil] => intro; my_simpl_solver | [ H : False |- _] => exfalso; apply H | [ H : ?a <> ?a |- _] => exfalso; apply H; reflexivity | [ H : In _ nil |- _] => inversion H | [ |- SubList nil _ ] => apply SubList_nil_l | [ |- SubList ?a ?a] => apply SubList_refl | [ |- ?a = ?b] => is_evar a; reflexivity | [ |- ?a = ?b] => is_evar b; reflexivity | [ H: ?a = ?b |- _] => discriminate | [H1 : ?a = ?b, H2 : ?a <> ?b |- _] => exfalso; apply H2; rewrite H1; reflexivity | [H1 : ?a = ?b, H2 : ?b <> ?a |- _] => exfalso; apply H2; rewrite H1; reflexivity | [|- nil = ?l1 ++ ?l2] => symmetry; apply (app_eq_nil l1 l2); split | [|- ?l1 ++ ?l2 = nil] => apply (app_eq_nil l1 l2); split | [H1 : key_not_In ?s ?l, H2 : In (?s, _) ?l |- _] => exfalso; specialize (H1 _ H2); contradiction | [H1 : key_not_In ?s ?l |- ~In ?s (map fst ?l)] => rewrite <- key_not_In_fst; apply H1 | [H1 : key_not_In ?s ?l, H2 : In ?s (map fst ?l) |- _] => exfalso; rewrite key_not_In_fst in H1; contradiction | [H1 : ?a <> ?b |- ?b <> ?a] => apply (not_eq_sym H1) end. Ltac or_unify := match goal with | [ |- In _ _ ] => repeat my_simplifier; my_simpl_solver | [ |- ?a = ?b] => repeat my_simplifier; my_simpl_solver | [ |- ?a \/ ?b] => left; or_unify | [ |- ?a \/ ?b] => right; or_unify end. Ltac normalize_key_concl1 := match goal with | [|- context [map fst (_ ++ _)]] => rewrite map_app | [|- forall _, (~In _ (map fst ?l1)) \/ (~In _ (map fst ?l2))] => fold (DisjKey l1 l2) | [ |- NoDup (_ ++ _)] => rewrite (NoDup_app_Disj_iff string_dec); repeat split | [ |- DisjKey (_ ++ _) _] => rewrite DisjKey_app_split_l; split | [ |- DisjKey _ (_ ++ _)] => rewrite DisjKey_app_split_r; split | [ |- ~In _ (_ ++ _)] => rewrite (nIn_app_iff string_dec); split | [ |- DisjKey (_ :: _) _] => rewrite DisjKey_cons_l_str; split | [ |- DisjKey _ (_ :: _)] => rewrite DisjKey_cons_r_str; split end. Ltac normalize_key_concl2 := match goal with | [ |- context [map fst (_ :: _)]] => rewrite map_cons | [ |- context [map fst nil]] => rewrite map_nil | [ |- NoDup (_ :: _)] => rewrite NoDup_cons_iff; split | [ |- key_not_In _ (_ :: _)] => rewrite key_not_In_cons; split | [ |- ~In _ (_ :: _)] => rewrite not_in_cons; split | [ |- key_not_In _ ?l] => match l with | _ => has_evar l; idtac | _ => rewrite key_not_In_fst end | [ |- ~In _ (_ :: _)] => rewrite not_in_cons; split | [ |- ~In _ (_ ++ _)] => rewrite (nIn_app_iff string_dec); split end. Ltac normalize_key_concl := repeat normalize_key_concl1; repeat normalize_key_concl2; cbn [fst]; repeat (my_simpl_solver || solve_keys). Ltac normal_solver := repeat my_simplifier ; repeat my_simpl_solver ; repeat or_unify ; repeat find_if_inside ; repeat normalize_key_concl ; repeat sublist_sol ; repeat solve_keys. Ltac normal_solver2 := repeat my_simplifier ; repeat my_simpl_solver ; repeat resolve_In ; repeat or_unify ; repeat risky_unify ; repeat resolve_sublist2 ; repeat find_if_inside ; repeat normalize_key_concl ; repeat normalize_sublist_l ; repeat sublist_sol ; repeat solve_keys. Ltac resolve_wb := let HNoDup := fresh "H" in let HSubList := fresh "H" in match goal with | [HSemAction1 :SemAction ?o1 ?a_i _ _ _ _, HActionWb : ActionWb ?myR ?a_i |- _] => assert (NoDup (map fst o1)) as HNoDup ;[repeat normalize_key_concl | assert (SubList myR (getKindAttr o1)) as HSubList ;[clear HNoDup HSemAction1 ; repeat normalize_sublist_l ; sublist_sol | specialize (HActionWb _ _ _ _ _ HNoDup HSubList HSemAction1) as [[? [? [? [? ?]]]] ?] ; try resolve_sublist2 ; clear HSemAction1 HNoDup HSubList]] | [HSemAction1 : SemAction ?o1 (?a_i _) _ _ _ _, HActionWb : forall _, ActionWb ?myR (?a_i _) |- _] => assert (NoDup (map fst o1)) as HNoDup ;[repeat normalize_key_concl | assert (SubList myR (getKindAttr o1)) as HSubList ;[clear HNoDup HSemAction1 ; repeat normalize_sublist_l ; sublist_sol | specialize (HActionWb _ _ _ _ _ _ HNoDup HSubList HSemAction1) as [[? [? [? [? ?]]]] ?] ; try resolve_sublist2 ; clear HSemAction1 HNoDup HSubList]] end. Ltac hyp_consumer := repeat mySubst; normalize_key_hyps; repeat (repeat main_body ; repeat mySubst ; repeat (my_simplifier; repeat my_simpl_solver; repeat clean_useless_hyp) ; repeat mySubst ; repeat normalize_key_hyps ; repeat (my_simplifier; repeat my_simpl_solver; repeat clean_useless_hyp) ; repeat (resolve_wb; repeat my_simpl_solver; repeat clean_useless_hyp) ; repeat resolve_rel ; repeat mySubst ; repeat (my_simplifier ; repeat my_simpl_solver; repeat clean_useless_hyp)) ; repeat my_simpl_solver ; cbn [fst] in *. Ltac goal_body := match goal with | [ |- SemAction _ (Return _) _ _ _ _ ] => econstructor 10 | [ |- SemAction _ (MCall _ _ _ _) _ _ _ _] => econstructor 1 | [ |- SemAction _ (LetAction _ _) _ _ _ _] => econstructor 3 | [ |- SemAction _ (ReadReg _ _ _) _ _ _ _] => econstructor 5 | [ |- SemAction _ (WriteReg _ _ _) _ _ _ _] => econstructor 6 | [ |- SemAction _ (IfElse _ _ _ _) _ _ _ _] => eapply SemAction_if_split ;[ find_if_inside| | | | ] | [ |- SemAction _ (LetExpr _ _) _ _ _ _] => econstructor 2 | [ |- SemAction _ (ReadNondet _ _) _ _ _ _] => econstructor 4 | [ |- SemAction _ (Sys _ _) _ _ _ _] => econstructor 9 | [ H : SemAction ?o ?a _ _ _ _ |- SemAction ?o ?a _ _ _ _] => apply H | [ H : SemAction ?o1 ?a _ _ _ _ |- SemAction ?o2 ?a _ _ _ _] => eapply SemActionExpand;[| apply H; sublist_sol] end. Ltac doUpdRegs_red1 := match goal with | [ |- context [ doUpdRegs nil _]] => rewrite doUpdRegs_nil | [ |- context [ doUpdReg nil _]] => rewrite doUpdReg_nil | |- context [ oneUpdRegs ?r ?o ] => let TMP := fresh "H" in assert (TMP : ~ In (fst r) (map fst o)); [ repeat match goal with | |- context [ map fst (doUpdRegs _ _) ] => rewrite doUpdRegs_preserves_keys end; (solve_keys || my_simpl_solver) | rewrite (oneUpdRegs_notIn _ _ TMP); clear TMP ] | |- context [ doUpdReg ?u ?r ] => let TMP := fresh "H" in assert (TMP : ~ In (fst r) (map fst u)); [ repeat match goal with | |- context [ map fst (doUpdRegs _ _) ] => rewrite doUpdRegs_preserves_keys end; (solve_keys || my_simpl_solver) | rewrite (doUpdReg_notIn _ _ TMP); clear TMP ]; cbn[fst] end. Ltac doUpdRegs_red2 := match goal with | |- context [oneUpdReg _ _ ] => cbv [oneUpdReg fst] | [|- context [?a =? ?a]] => rewrite eqb_refl | H : fst ?r1 = fst ?r2 |- context [fst ?r1 =? fst ?r2] => rewrite (proj2 (String.eqb_eq (fst r1) (fst r2)) H) | H : fst ?r2 = fst ?r1 |- context [fst ?r1 =? fst ?r2] => apply eq_sym in H; rewrite (proj2 (String.eqb_eq (fst r1) (fst r2)) H) | H : fst ?r1 <> fst ?r2 |- context [fst ?r1 =? fst ?r2] => rewrite (proj2 (String.eqb_neq (fst r1) (fst r2)) H) | H : fst ?r2 <> fst ?r1 |- context [fst ?r1 =? fst ?r2] => apply not_eq_sym in H; rewrite (proj2 (String.eqb_neq (fst r1) (fst r2)) H) | H : ?a = ?b |- context [?a =? ?b] => rewrite (proj2 (String.eqb_eq a b) H) | H : ?b = ?a |- context [?a =? ?b] => apply eq_sym in H; rewrite (proj2 (String.eqb_eq a b) H) | H : ?a <> ?b |- context [?a =? ?b] => rewrite (proj2 (String.eqb_neq a b) H) | H : ?b <> ?a |- context [?a =? ?b] => apply not_eq_sym in H; rewrite (proj2 (String.eqb_neq a b) H) end. Ltac doUpdRegs_red3 := match goal with | |- context [doUpdReg _ _ ] => cbv [doUpdReg findReg fst] | [|- context [?a =? ?a]] => rewrite eqb_refl | H : fst ?r1 = fst ?r2 |- context [fst ?r1 =? fst ?r2] => rewrite (proj2 (String.eqb_eq (fst r1) (fst r2)) H) | H : fst ?r2 = fst ?r1 |- context [fst ?r1 =? fst ?r2] => apply eq_sym in H; rewrite (proj2 (String.eqb_eq (fst r1) (fst r2)) H) | H : fst ?r1 <> fst ?r2 |- context [fst ?r1 =? fst ?r2] => rewrite (proj2 (String.eqb_neq (fst r1) (fst r2)) H) | H : fst ?r2 <> fst ?r1 |- context [fst ?r1 =? fst ?r2] => apply not_eq_sym in H; rewrite (proj2 (String.eqb_neq (fst r1) (fst r2)) H) | H : ?a = ?b |- context [?a =? ?b] => rewrite (proj2 (String.eqb_eq a b) H) | H : ?b = ?a |- context [?a =? ?b] => apply eq_sym in H; rewrite (proj2 (String.eqb_eq a b) H) | H : ?a <> ?b |- context [?a =? ?b] => rewrite (proj2 (String.eqb_neq a b) H) | H : ?b <> ?a |- context [?a =? ?b] => apply not_eq_sym in H; rewrite (proj2 (String.eqb_neq a b) H) end. Ltac doUpdRegs_red := repeat ( match goal with | _ => doUpdRegs_red1 | _ => doUpdRegs_red2 | _ => doUpdRegs_red3 end). Ltac extractGKAs := let var := fresh "x" in let vfst := fresh "x" in let vsnd := fresh "x" in let p1 := fresh "x" in let p2 := fresh "x" in let Heq := fresh "H" in let HIn := fresh "H" in let Heq1 := fresh "H" in let Heq2 := fresh "H" in match goal with | [HNoDup : NoDup (map fst ?o), H1 : In (?a, ?b) (map (fun x => (fst x, projT1 (snd x))) ?o) |- _] => rewrite in_map_iff in H1; destruct H1 as [var [Heq HIn]]; destruct var as [vfst vsnd]; destruct vsnd as [p1 p2]; cbn [fst snd projT1] in Heq; apply inversionPair in Heq; inversion_clear Heq as [Heq1 Heq2]; subst; repeat resolve_In end. Ltac goal_consumer1 := repeat (repeat goal_split ; repeat goal_body ; repeat normal_solver) ; repeat (repeat doUpdRegs_simpl ; doUpdRegs_red ; repeat normal_solver). Ltac SubList_gka_deconstruct := let x := fresh "x" in let Heq1 := fresh "H" in let Heq2 := fresh "H" in match goal with | [H : SubList _ (map (fun x => (fst x, projT1 (snd x))) ?o) |- _] => apply SubList_map_iff in H; destruct H as [x [Heq1 Heq2]]; mySubst end. Ltac goal_consumer2 := repeat SubList_gka_deconstruct; repeat extractGKAs; repeat goal_split ; repeat goal_body ; repeat normal_solver2 ; repeat my_risky_solver ; repeat normal_solver2. ================================================ FILE: GallinaModules/Relations.v ================================================ Require Import Kami.All. Definition EffectfulRelation {k: Kind} (R: RegsT -> RegsT -> Prop) (a_i a_s: ActionT type k): Prop := forall o_i o_s, R o_i o_s -> forall calls reads_i upds_i retval, SemAction o_i a_i reads_i upds_i calls retval -> exists reads_s upds_s, (SemAction o_s a_s reads_s upds_s calls retval) /\ R (doUpdRegs upds_i o_i) (doUpdRegs upds_s o_s). Definition EffectlessRelation {k: Kind} (R: RegsT -> RegsT -> Prop) (a_i a_s: ActionT type k): Prop := forall o_i o_s, R o_i o_s -> forall reads_i upds calls retval, SemAction o_i a_i reads_i upds calls retval -> (upds = [] /\ calls = [] /\ exists reads_s, (SemAction o_s a_s reads_s [] [] retval)). Definition ActionWb {k} myRegs (act: ActionT type k): Prop := forall o reads upds calls ret, NoDup (map fst o) -> SubList myRegs (getKindAttr o) -> SemAction o act reads upds calls ret -> ((exists o', SubList o' o /\ SubList reads o' /\ getKindAttr o' = myRegs /\ SemAction o' act reads upds calls ret ) /\ SubList (getKindAttr upds) myRegs). ================================================ FILE: Guard.v ================================================ Require Import Kami.Syntax Kami.Notations. Set Asymmetric Patterns. Set Implicit Arguments. Section ty. Variable ty: Kind -> Type. Definition boolTy (k: Kind) := bool. Fixpoint goodDfExpr k (e: Expr boolTy k) {struct e}: bool. refine match e with | Var k v => match k return fullType boolTy k -> bool with | SyntaxKind k' => fun v => v | _ => fun _ => true end v | Const k c => true | UniBool op e => @goodDfExpr _ e | CABool op es => forallb (@goodDfExpr _) es | UniBit n1 n2 op e => @goodDfExpr _ e | CABit n op es => forallb (@goodDfExpr _) es | BinBit n1 n2 n3 op e1 e2 => (@goodDfExpr _ e1) && (@goodDfExpr _ e2) | BinBitBool n1 n2 op e1 e2 => (@goodDfExpr _ e1) && (@goodDfExpr _ e2) | ITE k p e1 e2 => (@goodDfExpr _ p) && (@goodDfExpr _ e1) && (@goodDfExpr _ e2) | Eq k e1 e2 => (@goodDfExpr _ e1) && (@goodDfExpr _ e2) | ReadStruct n m k e i => (@goodDfExpr _ e) | ReadArray n m k e i => (@goodDfExpr _ e) && (@goodDfExpr _ i) | ReadArrayConst n k e i => (@goodDfExpr _ e) | BuildArray n k fv => forallb (fun i => @goodDfExpr _ (fv i)) (getFins n) | BuildStruct n fk fs fv => forallb (fun i => @goodDfExpr _ (fv i)) (getFins n) | Kor k es => forallb(@goodDfExpr _ ) es | ToNative _ e => goodDfExpr _ e | FromNative _ e => goodDfExpr _ e end. Defined. Fixpoint goodDfAction lret (a: ActionT boolTy lret) := match a with | MCall name sig arg cont => goodDfAction (cont true) | LetExpr k e cont => match k return Expr boolTy k -> (fullType boolTy k -> ActionT boolTy lret) -> bool with | SyntaxKind k' => fun e cont => goodDfAction (cont (goodDfExpr e)) | _ => fun e cont => false end e cont | LetAction k a cont => goodDfAction a && (goodDfAction (cont true)) | ReadNondet k cont => match k return (fullType boolTy k -> ActionT boolTy lret) -> bool with | SyntaxKind k' => fun cont => goodDfAction (cont false) | _ => fun cont => false end cont | ReadReg name k cont => match k return (fullType boolTy k -> ActionT boolTy lret) -> bool with | SyntaxKind k' => fun cont => goodDfAction (cont true) | _ => fun cont => false end cont | WriteReg name k e cont => goodDfAction cont | IfElse p k a1 a2 cont => goodDfExpr p && goodDfAction a1 && goodDfAction a2 && goodDfAction (cont true) | Sys _ cont => goodDfAction cont | Return e => (* goodDfExpr e *) true end. Local Open Scope kami_expr. Local Open Scope kami_action. Section aggressive. Variable isAgg: bool. Fixpoint getGuard lret (a: ActionT ty lret): ActionT ty Bool := match a with | MCall name sig arg cont => Call gmeth: Bool <- (name ++ ".guard")(arg: _) ; LET dummy <- Const _ (getDefaultConst _); LETA grest <- getGuard (cont dummy); Ret (#gmeth && #grest) | LetExpr k e cont => LetExpr e (fun x => getGuard (cont x)) | LetAction k a cont => LETA ga <- getGuard a; LET dummy <- Const _ (getDefaultConst _); LETA grest <- getGuard (cont dummy); Ret (#ga && #grest) | ReadNondet k cont => ReadNondet k (fun x => getGuard (cont x)) | ReadReg name k cont => ReadReg name k (fun x => getGuard (cont x)) | WriteReg name k e cont => getGuard cont | IfElse p k a1 a2 cont => LETA g1 <- getGuard a1; LETA g2 <- getGuard a2; LET dummy <- Const _ (getDefaultConst _); LETA grest <- getGuard (cont dummy); Ret (if isAgg then (IF p then #g1 else #g2) && #grest else #g1 && #g2 && #grest) | Sys _ cont => getGuard cont | Return e => Ret ($$ true) end. Definition addGuardGen lret (a: ActionT ty lret) := LETA g <- getGuard a; If #g then a else Ret ($$ (getDefaultConst lret)) as sth; Ret #sth. End aggressive. End ty. Definition addGuardMeth (f: DefMethT) := (fst f, existT MethodT (projT1 (snd f)) (fun ty x => addGuardGen (goodDfAction (projT2 (snd f) boolTy true)) (projT2 (snd f) ty x))). Definition MethodGuardT (sig: Signature) := forall ty : Kind -> Type, (ty (fst sig) -> ActionT ty (snd sig)) * (ty (fst sig) -> ActionT ty Bool). Definition DefMethGuardT := Attribute (sigT MethodGuardT). Definition addGuardRule (ra: Attribute (Action Void)) := (fst ra, fun ty => addGuardGen (goodDfAction (snd ra boolTy)) (snd ra ty)). Definition addGuardMethWithGuard (f: DefMethGuardT): (DefMethT * DefMethT) := (addGuardMeth (fst f, existT MethodT (projT1 (snd f)) (fun ty => fst (projT2 (snd f) ty))), addGuardMeth ((fst f ++ ".guard")%string, existT MethodT (fst (projT1 (snd f)), Bool) (fun ty => snd (projT2 (snd f) ty)))). (* IGNORE THE REST *) (* Section ty. *) (* Variable ty: Kind -> Type. *) (* Definition optTy := (fun k => option (ty k)). *) (* Definition liftSome A B (f: A -> B) (e: option A) := match e with *) (* | Some x => Some (f x) *) (* | None => None *) (* end. *) (* Fixpoint liftSomes A (ls: list (option A)) := *) (* match ls with *) (* | Some x :: xs => liftSome (cons x) (liftSomes xs) *) (* | None :: xs => None *) (* | nil => Some nil *) (* end. *) (* Definition liftSome2 A B C (f: A -> B -> C) (e1: option A) (e2: option B) *) (* := match e1, e2 with *) (* | Some x, Some y => Some (f x y) *) (* | _, _ => None *) (* end. *) (* Definition liftSome3 A B C D (f: A -> B -> C -> D) (e1: option A) (e2: option B) (e3: option C) *) (* := match e1, e2, e3 with *) (* | Some x, Some y, Some z => Some (f x y z) *) (* | _, _, _ => None *) (* end. *) (* Fixpoint exprForGuard k (e: Expr optTy k) {struct e}: option (Expr ty k). *) (* refine *) (* match e with *) (* | Var k v => match k return fullType optTy k -> option (Expr ty k) with *) (* | SyntaxKind k' => fun v => match v with *) (* | None => None *) (* | Some x => Some (Var _ (SyntaxKind k') x) *) (* end *) (* | NativeKind t c => fun v => Some (Var ty (NativeKind c) v) *) (* end v *) (* | Const k c => Some (Const _ c) *) (* | UniBool op e => liftSome (UniBool op) (@exprForGuard _ e) *) (* | CABool op es => liftSome (CABool op) (liftSomes (map (@exprForGuard _) es)) *) (* | UniBit n1 n2 op e => liftSome (UniBit op) (@exprForGuard _ e) *) (* | CABit n op es => liftSome (CABit op) (liftSomes (map (@exprForGuard _) es)) *) (* | BinBit n1 n2 n3 op e1 e2 => liftSome2 (BinBit op) (@exprForGuard _ e1) *) (* (@exprForGuard _ e2) *) (* | BinBitBool n1 n2 op e1 e2 => liftSome2 (BinBitBool op) (@exprForGuard _ e1) *) (* (@exprForGuard _ e2) *) (* | ITE k p e1 e2 => liftSome3 (@ITE _ k) (@exprForGuard _ p) *) (* (@exprForGuard _ e1) (@exprForGuard _ e2) *) (* | Eq k e1 e2 => liftSome2 (@Eq _ k) (@exprForGuard _ e1) (@exprForGuard _ e2) *) (* | ReadStruct n fk fs e i => liftSome (fun e => ReadStruct e i) (@exprForGuard _ e) *) (* | ReadArray n m k e i => liftSome2 (@ReadArray ty n m k) *) (* (@exprForGuard _ e) (@exprForGuard _ i) *) (* | ReadArrayConst n k e i => liftSome (fun e => @ReadArrayConst ty n k e i) *) (* (@exprForGuard _ e) *) (* | BuildArray n k fv => _ *) (* | BuildStruct n fk fs fv => _ *) (* end. *) (* - refine (match _ with *) (* | None => None *) (* | Some fv' => Some (BuildStruct fk fs fv') *) (* end). *) (* pose proof (fun i => @exprForGuard _ (fv i)) as sth. *) (* induction n. *) (* + exact (Some (fun i => Fin.case0 (fun i => Expr ty (SyntaxKind (fk i))) i)). *) (* + refine (match sth Fin.F1, IHn (fun i => fk (Fin.FS i)) *) (* (fun i => fs (Fin.FS i)) *) (* (fun i => fv (Fin.FS i)) *) (* (fun i => sth (Fin.FS i))with *) (* | Some x, Some y => Some (fun i => fin_case *) (* i *) (* (fun i => Expr ty (SyntaxKind (fk i))) x y) *) (* | _, _ => None *) (* end). *) (* - refine (match _ with *) (* | None => None *) (* | Some fv' => Some (BuildArray fv') *) (* end). *) (* pose proof (fun i => @exprForGuard _ (fv i)) as sth. *) (* induction n. *) (* + exact (Some (fun i => Fin.case0 (fun i => Expr ty (SyntaxKind k)) i)). *) (* + refine (match sth Fin.F1, IHn (fun i => fv (Fin.FS i)) (fun i => sth (Fin.FS i)) with *) (* | Some x, Some y => Some (fun i => fin_case *) (* i *) (* (fun i => Expr ty (SyntaxKind k)) x y) *) (* | _, _ => None *) (* end). *) (* Defined. *) (* End ty. *) ================================================ FILE: LICENSE ================================================ Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright 2019 SiFive, Inc. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. ================================================ FILE: Lib/EclecticLib.v ================================================ Require Import String Coq.Lists.List Omega Fin Eqdep Bool Coq.ZArith.Zdiv Lia. Require Import Coq.Arith.Even. Require Import Coq.Arith.Div2. Require Import Coq.NArith.NArith. Require Import Arith_base. Require Import Arith Coq.ZArith.Znat Psatz. Import ListNotations. Set Implicit Arguments. Set Asymmetric Patterns. Section NubBy. Variable A : Type. Variable f: A -> A -> bool. Definition nubBy (ls: list A) := fold_right (fun x acc => if existsb (f x) acc then acc else x :: acc) nil ls. End NubBy. Section Tree. Inductive Tree (A: Type): Type := | Leaf (_: list A) | Node (_: list (Tree A)). Fixpoint flattenTree A (t: Tree A): list A := match t with | Leaf xs => xs | Node xs => (fix fold xs := match xs with | nil => nil | x :: xs => flattenTree x ++ fold xs end) xs end. End Tree. Fixpoint string_rev (ls: string) := match ls with | EmptyString => EmptyString | String x xs => append (string_rev xs) (String x EmptyString) end. (* Definition in_decb{X}(eqb : X -> X -> bool) : X -> list X -> bool := fun x => existsb (eqb x). Lemma in_decb_In{X} : forall eqb : X -> X -> bool, (forall x y, eqb x y = true <-> x = y) -> forall x xs, in_decb eqb x xs = true <-> In x xs. Proof. intros; unfold in_decb; rewrite existsb_exists. split. intros [y [Hy1 Hy2]]. rewrite H in Hy2; congruence. intro. exists x; split; [auto | rewrite H; auto]. Qed. *) Fixpoint Fin_t_foldr (A : Type) (n : nat) (init : A) := match n return forall (f : Fin.t n -> A -> A), A with | 0 => fun _ => init | S m => fun f => f Fin.F1 (Fin_t_foldr m init (fun i => f (Fin.FS i))) end. Section nth_Fin. Variable A: Type. Fixpoint nth_Fin (ls: list A): Fin.t (length ls) -> A := match ls return Fin.t (length ls) -> A with | nil => fun pf => Fin.case0 _ pf | x :: xs => fun i => match i in Fin.t n return n = length (x :: xs) -> A with | Fin.F1 _ => fun _ => x | Fin.FS _ y => fun pf => nth_Fin xs match eq_add_S _ _ pf in _ = Y return Fin.t Y with | eq_refl => y end end eq_refl end. Definition nth_Fin' (ls: list A) n (pf: n = length ls) (i: Fin.t n): A := nth_Fin ls (Fin.cast i pf). Fixpoint nth_Fin'' (ls: list A) n (pf: n <= length ls) {struct ls} : Fin.t n -> A. Proof. refine( match ls return (n <= length ls) -> Fin.t n -> A with | nil => fun pf i => Fin.case0 _ (Fin.cast i _) | x :: xs => fun pf i => match i in Fin.t m return m <= length (x :: xs) -> A with | Fin.F1 _ => fun _ => x | Fin.FS _ z => fun pf => nth_Fin'' xs _ _ z end _ end _). all: cbn in *; abstract omega. Defined. Lemma nth_Fin'_nth : forall n d (i: Fin.t n) (xs: list A) (len_eq: n = length xs), let i' := proj1_sig (Fin.to_nat i) in nth_Fin' xs len_eq i = nth i' xs d. Proof. induction n; cbn; intros *; try easy. destruct xs; cbn in *; try easy. inversion len_eq. destruct i eqn:?; cbn; auto. destruct (Fin.to_nat _) eqn:?; cbn. assert (n0 = n); subst. { inversion len_eq; subst; auto. } specialize (IHn d t xs (f_equal pred len_eq)). rewrite Heqs in IHn; cbn in IHn; auto. Qed. Lemma nth_Fin_nth : forall d (xs: list A) (i: Fin.t (length xs)), let i' := proj1_sig (Fin.to_nat i) in nth_Fin xs i = nth i' xs d. Proof. cbn; intros. rewrite <- (nth_Fin'_nth _ _ _ eq_refl). unfold nth_Fin'; f_equal. clear; induction i; cbn; auto. rewrite <- IHi; auto. Qed. End nth_Fin. Definition fin_case n x : forall (P : Fin.t (S n) -> Type), P Fin.F1 -> (forall y, P (Fin.FS y)) -> P x := match x in Fin.t n0 return forall P, match n0 return (Fin.t n0 -> (Fin.t n0 -> Type) -> Type) with | 0 => fun _ _ => False | S m => fun x P => P Fin.F1 -> (forall x0, P (Fin.FS x0)) -> P x end x P with | Fin.F1 _ => fun _ H1 _ => H1 | Fin.FS _ _ => fun _ _ HS => HS _ end. Ltac fin_dep_destruct v := pattern v; apply fin_case; clear v; intros. Lemma Fin_cast_lemma : forall m n i (p q : m = n), Fin.cast i p = Fin.cast i q. Proof. intros. rewrite (UIP_nat _ _ p q); reflexivity. Defined. Lemma fin_to_nat_cast : forall n (i: Fin.t n) m (Heq: n = m), proj1_sig (Fin.to_nat (Fin.cast i Heq)) = proj1_sig (Fin.to_nat i). Proof. induction n; cbn; intros *; try easy. destruct m; try easy. assert (n = m) by auto. destruct i eqn:?; cbn; auto. assert (n0 = n) by (subst; auto); subst. specialize (IHn t m eq_refl). destruct (Fin.to_nat t) eqn:?; cbn in *. rewrite <- (Fin_cast_lemma _ eq_refl). destruct (Fin.to_nat (Fin.cast t eq_refl)) eqn:?; cbn in *; auto. Qed. Definition UIP(X : Type) := forall (x y : X)(p q : x = y), p = q. Definition discrete(X : Type) := forall (x y : X), {x = y} + {x <> y}. Theorem hedberg : forall X, discrete X -> UIP X. Proof. intros X Xdisc x y. assert ( lemma : forall proof : x = y, match Xdisc x x, Xdisc x y with | left r, left s => proof = eq_trans (eq_sym r) s | _, _ => False end ). { destruct proof. destruct (Xdisc x x) as [pr | f]. destruct pr; auto. elim f; reflexivity. } intros p q. assert (p_given_by_dec := lemma p). assert (q_given_by_dec := lemma q). destruct (Xdisc x x). destruct (Xdisc x y). apply (eq_trans p_given_by_dec (eq_sym q_given_by_dec)). contradiction. contradiction. Defined. Definition map_length_red := (fun (A B : Type) (f : A -> B) (l : list A) => list_ind (fun l0 : list A => Datatypes.length (map f l0) = Datatypes.length l0) eq_refl (fun (a : A) (l0 : list A) (IHl : Datatypes.length (map f l0) = Datatypes.length l0) => f_equal_nat nat S (Datatypes.length (map f l0)) (Datatypes.length l0) IHl) l) : forall (A B : Type) (f : A -> B) (l : list A), Datatypes.length (map f l) = Datatypes.length l. Section nth_Fin_map2. Variable A B: Type. Variable g: A -> B. Variable f: B -> Type. Fixpoint nth_Fin_map2 (ls: list A): forall (p : Fin.t (length (map g ls))) (val: f (g (nth_Fin ls (Fin.cast p (map_length_red g ls))))), f (nth_Fin (map g ls) p). refine match ls return forall (p : Fin.t (length (map g ls))) (val: f (g (nth_Fin ls (Fin.cast p (map_length_red g ls))))), f (nth_Fin (map g ls) p) with | nil => fun i _ => Fin.case0 (fun j => f (nth_Fin (map g nil) j)) i | x :: xs => fun p => _ end. fin_dep_destruct p. + exact val. + apply (nth_Fin_map2 xs y). match goal with | |- f (g (nth_Fin xs (Fin.cast y ?P))) => rewrite (hedberg eq_nat_dec P (f_equal Init.Nat.pred (map_length_red g (x :: xs)))) end. exact val. Defined. End nth_Fin_map2. Section Fin. Fixpoint Fin_forallb{n} : (Fin.t n -> bool) -> bool := match n return (Fin.t n -> bool) -> bool with | 0 => fun _ => true | S m => fun p => p Fin.F1 && Fin_forallb (fun i => p (Fin.FS i)) end. Lemma Fin_forallb_correct{n} : forall p : Fin.t n -> bool, Fin_forallb p = true <-> forall i, p i = true. Proof. induction n; intros; split; intros. apply (Fin.case0 (fun i => p i = true)). reflexivity. simpl in H. fin_dep_destruct i. destruct (p F1); [auto|discriminate]. apply (IHn (fun j => p (FS j))). destruct (p F1); [auto|discriminate]. simpl. apply andb_true_intro; split. apply H. apply IHn. intro; apply H. Qed. Definition Fin_cast : forall m n, Fin.t m -> m = n -> Fin.t n := fun m n i pf => match pf in _ = y return Fin.t y with | eq_refl => i end. End Fin. Lemma inversionPair A B (a1 a2: A) (b1 b2: B): (a1, b1) = (a2, b2) -> a1 = a2 /\ b1 = b2. Proof. intros H. inversion H. subst; auto. Qed. Lemma inversionExistT A (P: A -> Type) (x1 x2: A) (y1: P x1) (y2: P x2): existT P x1 y1 = existT P x2 y2 -> exists pf: x1 = x2, match pf in _ = Y return _ Y with | eq_refl => y1 end = y2. Proof. intros H. pose proof (EqdepFacts.eq_sigT_fst H) as sth. exists sth. subst. apply Eqdep.EqdepTheory.inj_pair2 in H; subst. auto. Qed. Lemma inversionPairExistT A B (f: B -> Type) (a1 a2: A) (b1 b2: B) (f1: f b1) (f2: f b2): (a1, existT f b1 f1) = (a2, existT f b2 f2) -> a1 = a2 /\ existT f b1 f1 = existT f b2 f2. Proof. intros. inversion H. repeat split; auto. Qed. Lemma InSingleton_impl A (x y: A): In x [y] -> x = y. Proof. intros; simpl in *. destruct H; auto; tauto. Qed. Definition fromOption (A : Type) (mx : option A) (default : A) : A := match mx with | Some x => x | _ => default end. Definition strings_in (xs : list string) (x : string) : bool := existsb (String.eqb x) xs. Definition strings_any_in (xs : list string) : list string -> bool := existsb (strings_in xs). Definition strings_all_in (xs : list string) : list string -> bool := forallb (strings_in xs). Definition emptyb (A : Type) (xs : list A) : bool := match xs with | nil => true | _ => false end. Definition list_max : nat -> list (option nat) -> nat := fold_right (fun x acc => fromOption (option_map (Nat.max acc) x) acc). Ltac existT_destruct dec := match goal with | H: existT _ _ _ = existT _ _ _ |- _ => apply EqdepFacts.eq_sigT_eq_dep in H; apply (Eqdep_dec.eq_dep_eq_dec dec) in H; subst end. Fixpoint Fin_eq_dec n a {struct a}: forall (b: Fin.t n), {a = b} + {a <> b}. Proof. refine match a in Fin.t n return forall b: Fin.t n, {a = b} + {a <> b} with | Fin.F1 _ => fun b => match b with | Fin.F1 _ => left eq_refl | _ => right _ end | Fin.FS _ x => fun b => match b in Fin.t (S m) return forall x: Fin.t m, (forall y: Fin.t m, {x = y} + {x <> y}) -> {Fin.FS x = b} + {Fin.FS x <> b} with | Fin.F1 _ => fun _ _ => right _ | Fin.FS _ y => fun _ f => match f y with | left eq1 => left (f_equal Fin.FS eq1) | right neq => right _ end end x (Fin_eq_dec _ x) end; intro; clear Fin_eq_dec; try (abstract discriminate). abstract (injection H; intros; existT_destruct Nat.eq_dec; tauto). Defined. Section fold_left_right. Variable A B: Type. Variable f: A -> B -> A. Variable f_comm: forall x i j, f (f x i) j = f (f x j) i. Lemma fold_left_right_comm ls: forall init, fold_left f ls init = fold_right (fun x acc => f acc x) init ls. Proof. induction ls; simpl; auto; intros. rewrite <- IHls; simpl. clear IHls. generalize init; clear init. induction ls; simpl; auto; intros. rewrite <- IHls. rewrite f_comm. auto. Qed. End fold_left_right. Section fold_left_map. Variable A B C: Type. Variable f: A -> B -> A. Variable g: C -> B. Lemma fold_left_dist_map ls: forall init, fold_left f (map g ls) init = fold_left (fun acc x => f acc (g x)) ls init. Proof. induction ls; simpl; auto. Qed. End fold_left_map. Lemma seq_eq sz: forall n, seq n (S sz) = seq n sz ++ [n + sz]. Proof. induction sz; simpl; auto; intros; repeat f_equal. - rewrite Nat.add_0_r; auto. - specialize (IHsz (S n)). assert (sth: S n + sz = n + S sz) by omega. rewrite <- sth. rewrite <- IHsz. auto. Qed. Section map_fold_eq. Variable A: Type. Variable f: A -> A. Fixpoint zeroToN n := match n with | 0 => nil | S m => zeroToN m ++ m :: nil end. Lemma zeroToN_upto n: zeroToN n = seq 0 n. Proof. induction n; simpl; auto. rewrite IHn. pose proof (seq_eq n 0) as sth. simpl in sth. auto. Qed. Fixpoint transform_nth_left ls i := match ls with | nil => nil | x :: xs => match i with | 0 => f x :: xs | S m => x :: transform_nth_left xs m end end. Lemma transform_nth_left_length' ls: forall i, length (transform_nth_left ls i) = length ls. Proof. induction ls; simpl; auto; intros. destruct i; simpl; auto; intros. Qed. Lemma transform_nth_left_length ns: forall ls, length (fold_left transform_nth_left ns ls) = length ls. Proof. induction ns; simpl; auto; intros. rewrite IHns. apply transform_nth_left_length'. Qed. Lemma transform_nth_tail a ls: forall i, transform_nth_left (a :: ls) (S i) = a :: transform_nth_left ls i. Proof. induction ls; destruct i; simpl; auto. Qed. Lemma zeroToSN n: zeroToN n ++ [n] = 0 :: map S (zeroToN n). Proof. induction n; simpl; auto. rewrite map_app. rewrite app_comm_cons. rewrite <- IHn. auto. Qed. Lemma map_fold_left_eq' ls: map f ls = fold_left transform_nth_left (zeroToN (length ls)) ls. Proof. induction ls; simpl; auto. rewrite IHls. rewrite zeroToSN; simpl. rewrite fold_left_dist_map. clear IHls. remember (f a) as x. remember (zeroToN (length ls)) as ys. clear Heqx a Heqys. generalize ls x; clear x ls. induction ys; simpl; auto. Qed. Lemma map_fold_left_eq ls: map f ls = fold_left transform_nth_left (seq 0 (length ls)) ls. Proof. rewrite <- zeroToN_upto. apply map_fold_left_eq'. Qed. End map_fold_eq. Section map_fold_eq_gen. Variable A: Type. Variable f: A -> nat -> A. Fixpoint transform_nth_left_gen ls i := match ls with | nil => nil | x :: xs => match i with | 0 => f x i :: xs | S m => x :: transform_nth_left_gen xs m end end. End map_fold_eq_gen. Section map_fold_eq'. Variable A: Type. Variable f: A -> A. Fixpoint transform_nth_right i ls := match ls with | nil => nil | x :: xs => match i with | 0 => f x :: xs | S m => x :: transform_nth_right m xs end end. Lemma transform_left_right_eq x: forall y, transform_nth_left f x y = transform_nth_right y x. Proof. induction x; destruct y; simpl; auto; intros. f_equal; auto. Qed. Lemma transform_nth_left_comm ls: forall i j, transform_nth_left f (transform_nth_left f ls i) j = transform_nth_left f (transform_nth_left f ls j) i. Proof. induction ls; destruct i, j; simpl; auto; intros; f_equal. auto. Qed. Lemma transform_nth_right_comm ls: forall i j, transform_nth_right j (transform_nth_right i ls) = transform_nth_right i (transform_nth_right j ls). Proof. intros. rewrite <- ?transform_left_right_eq. apply transform_nth_left_comm. Qed. Lemma map_fold_right_eq' ls: map f ls = fold_right transform_nth_right ls (zeroToN (length ls)). Proof. rewrite <- fold_left_right_comm by apply transform_nth_right_comm. rewrite map_fold_left_eq'. remember (zeroToN (length ls)) as xs. clear Heqxs. generalize ls; clear ls. induction xs; simpl; auto; intros. rewrite IHxs. rewrite transform_left_right_eq. auto. Qed. Lemma map_fold_right_eq ls: map f ls = fold_right transform_nth_right ls (seq 0 (length ls)). Proof. rewrite <- zeroToN_upto. eapply map_fold_right_eq'. Qed. End map_fold_eq'. Lemma nth_error_nth A : forall (xs: list A) n d v, nth_error xs n = Some v -> nth n xs d = v. Proof. induction xs; cbn; intros; destruct n; cbn in *; try easy; auto. inversion H; auto. Qed. Lemma nth_error_not_None A : forall n (xs: list A), nth_error xs n <> None -> exists x, nth_error xs n = Some x. Proof. induction n; destruct xs; cbn; try easy; eauto. Qed. Fixpoint getFins n := match n return list (Fin.t n) with | 0 => nil | S m => Fin.F1 :: map Fin.FS (getFins m) end. Fixpoint getFinsBound m n: list (Fin.t n) := match m return (list (Fin.t n)) with | 0 => nil | S k => match n with | 0 => nil | S n' => Fin.F1 :: map Fin.FS (getFinsBound k n') end end. Definition mapOrFins n (x: Fin.t n) := fold_left (fun a b => x = b \/ a) (getFins n) False. Lemma getFins_length : forall n, length (getFins n) = n. Proof. induction n; cbn; auto. rewrite map_length; auto. Qed. Lemma getFins_all : forall n (i: Fin.t n), In i (getFins n). Proof. induction i; cbn; auto using in_map. Qed. Lemma getFins_nth_error : forall n (i: Fin.t n), let i' := proj1_sig (Fin.to_nat i) in nth_error (getFins n) i' = Some i. Proof. induction i; cbn in *; auto. destruct (Fin.to_nat i); cbn in *. apply map_nth_error; auto. Qed. Lemma getFins_nth : forall n d (i: Fin.t n), let i' := proj1_sig (Fin.to_nat i) in nth i' (getFins n) d = i. Proof. intros. apply nth_error_nth. apply getFins_nth_error. Qed. Section Arr. Variable A: Type. Variable def: A. Definition list_arr n (arr : Fin.t n -> A):= map arr (getFins n). Lemma list_arr_correct : forall n (arr : Fin.t n -> A)(i: nat), match lt_dec i n with | left pf => arr (Fin.of_nat_lt pf) | right _ => def end = nth_default def (list_arr arr) i. Proof. intros; destruct lt_dec; unfold list_arr, nth_default; destruct nth_error eqn:G; auto. - erewrite map_nth_error in G; inversion G; subst. + reflexivity. + assert (i = proj1_sig (to_nat (of_nat_lt l))) as P0. { rewrite to_nat_of_nat; simpl; reflexivity. } specialize (getFins_nth_error (of_nat_lt l)) as P1. cbv zeta in P1. rewrite <- P0 in P1. assumption. - exfalso. rewrite nth_error_None, map_length, getFins_length in G; lia. - exfalso. assert (nth_error (map arr (getFins n)) i <> None). { congruence. } rewrite nth_error_Some, map_length, getFins_length in H; contradiction. Qed. Lemma list_arr_correct_simple : forall n (arr : Fin.t n -> A) i, nth_error (list_arr arr) (proj1_sig (Fin.to_nat i)) = Some (arr i). Proof. intros. unfold list_arr; apply map_nth_error. apply getFins_nth_error. Qed. Fixpoint snoc (a : A) (ls : list A) := match ls with | nil => a::nil | x :: ls' => x :: (snoc a ls') end. Fixpoint rotateList (n : nat) (ls : list A) := match n with | O => ls | S m => rotateList m (match ls with | nil => nil | x :: ls => snoc x ls end) end. Lemma snoc_rapp (a : A) (ls : list A) : snoc a ls = ls ++ [a]. Proof. induction ls; simpl; auto. rewrite IHls; reflexivity. Qed. Lemma snoc_rev_cons (a : A) (ls : list A) : snoc a ls = rev (cons a (rev ls)). Proof. simpl; rewrite rev_involutive, snoc_rapp; reflexivity. Qed. End Arr. Lemma fold_left_or_init: forall A (f: A -> Prop) ls (P: Prop), P -> fold_left (fun a b => f b \/ a) ls P. Proof. induction ls; simpl; intros; auto. Qed. Lemma fold_left_or_impl: forall A (f: A -> Prop) ls (g: A -> Prop) (P Q: Prop), (P -> Q) -> (forall a, f a -> g a) -> fold_left (fun a b => f b \/ a) ls P -> fold_left (fun a b => g b \/ a) ls Q. Proof. induction ls; simpl; intros; auto. eapply IHls with (P := f a \/ P) (Q := g a \/ Q); try tauto. specialize (H0 a). tauto. Qed. Lemma fold_left_map A B C (f: A -> B) (g: C -> B -> C) ls: forall init, fold_left g (map f ls) init = fold_left (fun c a => g c (f a)) ls init. Proof. induction ls; simpl; auto. Qed. Lemma mapOrFins_true n: forall (x: Fin.t n), mapOrFins x. Proof. induction x; unfold mapOrFins in *; simpl; intros. - apply fold_left_or_init; auto. - rewrite fold_left_map. eapply (@fold_left_or_impl _ (fun b => x = b) (getFins n) _ False (Fin.FS x = Fin.F1 \/ False)); try tauto; congruence. Qed. Lemma list_split A B C (f: A -> C) (g: B -> C): forall l l1 l2, map f l = map g l1 ++ map g l2 -> exists l1' l2', l = l1' ++ l2' /\ map f l1' = map g l1 /\ map f l2' = map g l2. Proof. induction l; simpl; auto; intros. - apply eq_sym in H. apply app_eq_nil in H; destruct H as [s1 s2]. apply map_eq_nil in s1. apply map_eq_nil in s2. subst. exists nil, nil; simpl; auto. - destruct l1; simpl in *. + destruct l2; simpl in *. * discriminate. * inversion H; subst; clear H. specialize (IHl nil l2 H2). destruct IHl as [l1' [l2' [s1 [s2 s3]]]]. simpl in *. apply map_eq_nil in s2; subst; simpl in *. exists nil, (a :: l2'); simpl; auto. + inversion H; subst; clear H. specialize (IHl _ _ H2). destruct IHl as [l1' [l2' [s1 [s2 s3]]]]. exists (a :: l1'), l2'; simpl; repeat split; auto. * f_equal; auto. * f_equal; auto. Qed. Lemma nth_error_len A B i: forall (la: list A) (lb: list B) a, nth_error la i = None -> nth_error lb i = Some a -> length la = length lb -> False. Proof. induction i; destruct la; destruct lb; simpl; auto; intros; try congruence. inversion H. eapply IHi; eauto. Qed. (* fold_right *) Section list. Variable A: Type. Variable fn: A -> bool. Fixpoint remove_fn (ls: list A) := match ls with | nil => nil | x :: xs => if fn x then remove_fn xs else x :: remove_fn xs end. Definition SubList (l1 l2: list A) := forall x, In x l1 -> In x l2. Lemma SubList_app_l (l1 l2 ls: list A): SubList (l1 ++ l2) ls -> SubList l1 ls /\ SubList l2 ls. Proof. firstorder. Qed. Lemma SubList_app_r (ls l1 l2: list A): SubList ls l1 -> SubList ls (l1 ++ l2). Proof. firstorder. Qed. Lemma SubList_transitive (l1 l2 l3: list A): SubList l1 l2 -> SubList l2 l3 -> SubList l1 l3. Proof. firstorder. Qed. Lemma SubList_cons a (l ls: list A): SubList (a :: l) ls -> In a ls /\ SubList l ls. Proof. firstorder. Qed. Definition SameList (l1 l2: list A) := SubList l1 l2 /\ SubList l2 l1. Definition DisjList (l1 l2: list A) := forall x, ~ In x l1 \/ ~ In x l2. Lemma remove_fn_sublist (ls: list A): SubList (remove_fn ls) ls. Proof. induction ls; unfold SubList; simpl; auto; intros. destruct (fn a); simpl in *; auto. destruct H; auto. Qed. Variable decA: forall x y: A, {x = y} + {x <> y}. Fixpoint subtract_list l1 l2 := match l2 with | nil => l1 | x :: xs => subtract_list (remove decA x l1) xs end. Lemma subtract_list_nil_l (l: list A): subtract_list l [] = l. Proof. reflexivity. Qed. Lemma subtract_list_nil_r (l: list A): subtract_list [] l = []. Proof. induction l; auto. Qed. End list. Lemma SubList_map A B (f: A -> B) l1 l2: SubList l1 l2 -> SubList (map f l1) (map f l2). Proof. unfold SubList; intros. rewrite in_map_iff in *. repeat match goal with | H: exists x, _ |- _ => destruct H | H: _ /\ _ |- _ => destruct H end; subst. apply H in H1. firstorder fail. Qed. Lemma SubList_map2 A B C (f: A -> C) (g: B -> C) l1 l2 l3: SubList (map f l1) (map g l2) -> SubList l2 l3 -> SubList (map f l1) (map g l3). Proof. intros. unfold SubList in *; intros. specialize (H x H1). rewrite in_map_iff in H, H1. repeat match goal with | H: exists x, _ |- _ => destruct H | H: _ /\ _ |- _ => destruct H end; subst. specialize (H0 x1 H3). rewrite in_map_iff. exists x1; auto. Qed. Section Filter. Variable A: Type. Variable f g: A -> bool. Lemma filter_complement_same (ls: list A): SameList (filter f ls ++ filter (fun x => negb (f x)) ls) ls. Proof. induction ls; unfold SameList in *; simpl; auto; intros. - unfold SubList; auto. - destruct IHls. split; destruct (f a); unfold SubList in *. + firstorder fail. + intros. rewrite in_app_iff in H1; simpl in *. clear - H H1. firstorder. + firstorder fail. + intros. specialize (H0 x). rewrite in_app_iff in *; simpl in *. clear - H0 H1. firstorder fail. Qed. Variable B: Type. Variable h: A -> B. Lemma filter_complement_map_same (ls: list A): SameList (map h (filter f ls) ++ map h (filter (fun x => negb (f x)) ls)) (map h ls). Proof. induction ls; unfold SameList in *; simpl; auto; intros. - unfold SubList; auto. - destruct IHls. split; destruct (f a); unfold SubList in *. + firstorder fail. + intros. rewrite in_app_iff in H1; simpl in *. clear - H H1. firstorder. + firstorder fail. + intros. specialize (H0 x). rewrite in_app_iff in *; simpl in *. clear - H0 H1. firstorder fail. Qed. Variable gImpF: forall a, g a = true -> f a = true. Lemma SubList_strengthen_filter (l ls: list A): SubList l (filter g ls) -> SubList l (filter f ls). Proof. unfold SubList; intros. specialize (H _ H0). rewrite filter_In in *. destruct H. apply gImpF in H1. auto. Qed. End Filter. Definition getBool A B (x: {A} + {B}) : bool := match x with | left _ => true | right _ => false end. Section SubList_filter. Variable A B: Type. Variable f: A -> B. Variable Bdec: forall b1 b2: B, {b1 = b2} + {b1 <> b2}. Lemma SubList_filter_map: forall l1 l2 l3, SubList l1 l2 -> SubList (map f l1) l3 -> SubList l1 (filter (fun x => getBool (in_dec Bdec (f x) l3)) l2). Proof. unfold SubList; intros. rewrite filter_In. specialize (H _ H1). split; [auto | ]. unfold getBool. destruct (in_dec Bdec (f x) l3); [auto | ]. apply in_map with (f := f) in H1. specialize (H0 (f x) H1). tauto. Qed. Lemma SubList_filter_Disj: forall l1 l2 l3 l4, SubList l1 l2 -> SubList (map f l1) l3 -> DisjList l3 l4 -> SubList l1 (filter (fun x => negb (getBool (in_dec Bdec (f x) l4))) l2). Proof. unfold SubList; intros. rewrite filter_In. specialize (H _ H2). split; [auto | ]. unfold getBool. destruct (in_dec Bdec (f x) l4); [|auto]. apply in_map with (f := f) in H2. specialize (H0 (f x) H2). firstorder fail. Qed. End SubList_filter. Lemma filter_false: forall A (l: list A), filter (fun _ => false) l = nil. Proof. induction l; simpl; auto. Qed. Section filter_app. Variable A: Type. Variable f: A -> bool. Lemma filter_app: forall l1 l2, filter f (l1 ++ l2) = filter f l1 ++ filter f l2. Proof. induction l1; simpl; auto; intros. destruct (f a); simpl; f_equal; firstorder fail. Qed. End filter_app. Lemma In_nil A l: (forall a: A, ~ In a l) -> l = nil. Proof. induction l; auto; intros. exfalso. simpl in H. specialize (H a). assert (a <> a /\ ~ In a l) by firstorder. firstorder. Qed. Section filterSmaller. Variable A: Type. Variable g: A -> bool. Lemma filter_smaller: forall l l1, filter g l = l1 ++ l -> l1 = nil. Proof. induction l; simpl; intros. - rewrite app_nil_r in *; subst; auto. - destruct (g a), l1; simpl in *; auto. + inversion H; subst; clear H. specialize (IHl (l1 ++ [a0])). rewrite <- app_assoc in IHl. specialize (IHl H2). apply app_eq_nil in IHl. destruct IHl. discriminate. + specialize (IHl ((a0 :: l1) ++ [a])). rewrite <- app_assoc in IHl. specialize (IHl H). apply app_eq_nil in IHl. destruct IHl. discriminate. Qed. Variable h: A -> bool. Variable hKeepsMore: forall a, g a = true -> h a = true. Lemma filter_strengthen_same l: filter g l = l -> filter h l = l. Proof. induction l; simpl; auto; intros. specialize (@hKeepsMore a). destruct (g a), (h a); inversion H. - specialize (IHl H1). congruence. - specialize (@hKeepsMore eq_refl); discriminate. - assert (sth: filter g l = [a] ++ l) by (apply H). apply filter_smaller in sth. discriminate. - assert (sth: filter g l = [a] ++ l) by (apply H). apply filter_smaller in sth. discriminate. Qed. End filterSmaller. Section filter_nil. Variable A: Type. Variable f: A -> bool. Lemma filter_nil1: forall l, filter f l = nil -> forall a, In a l -> f a = false. Proof. induction l. - simpl; auto; intros; try tauto. - intros. simpl in *. case_eq (f a); intros. + rewrite H1 in *; simpl in *; discriminate. + destruct H0; [subst; auto | ]. rewrite H1 in *; simpl in *. eapply IHl; eauto. Qed. Lemma filter_nil2: forall l, (forall a, In a l -> f a = false) -> filter f l = nil. Proof. induction l; auto. intros. simpl. assert (sth: forall a, In a l -> f a = false) by firstorder. specialize (IHl sth). case_eq (f a); intros; auto. specialize (H a (or_introl eq_refl)); auto. rewrite H in *; discriminate. Qed. End filter_nil. Definition key_not_In A B key (ls: list (A * B)) := forall v, ~ In (key, v) ls. Section DisjKey. Variable A B: Type. Section l1_l2. Variable Adec: forall a1 a2: A, {a1 = a2} + {a1 <> a2}. Variable l1 l2: list (A * B). Definition DisjKey := forall k, ~ In k (map fst l1) \/ ~ In k (map fst l2). Definition DisjKeyWeak := forall k, In k (map fst l1) -> In k (map fst l2) -> False. Lemma Demorgans (P Q: A -> Prop) (Pdec: forall a, {P a} + {~ P a}) (Qdec: forall a, {Q a} + {~ Q a}): (forall a, ~ P a \/ ~ Q a) <-> (forall a, P a -> Q a -> False). Proof. split; intros; firstorder fail. Qed. Lemma DisjKeyWeak_same: DisjKey <-> DisjKeyWeak. Proof. unfold DisjKeyWeak. apply Demorgans; intros; apply (in_dec Adec); auto. Qed. End l1_l2. Lemma NoDup_DisjKey l1: forall l2, NoDup (map fst l1) -> NoDup (map fst l2) -> DisjKey l1 l2 -> NoDup (map fst (l1 ++ l2)). Proof. induction l1; simpl; auto; intros. inversion H; subst; clear H. unfold DisjKey in H1; simpl in H1. assert (sth: forall k, ~ In k (map fst l1) \/ ~ In k (map fst l2)) by (clear - H1; firstorder fail). specialize (IHl1 _ H5 H0 sth). constructor; auto. assert (~ In (fst a) (map fst l2)) by (clear - H1; firstorder fail). rewrite map_app; rewrite in_app_iff. tauto. Qed. Lemma DisjKey_nil_r: forall l, DisjKey l nil. Proof. unfold DisjKey; simpl; intros. tauto. Qed. Lemma DisjKey_nil_l: forall l, DisjKey nil l. Proof. unfold DisjKey; simpl; intros. tauto. Qed. End DisjKey. Section FilterMap. Variable A B C: Type. Variable Adec: forall a1 a2: A, {a1 = a2} + {a1 <> a2}. Variable f: B -> C. Lemma filter_In_map_same l: filter (fun x => getBool (in_dec Adec (fst x) (map fst l))) (map (fun x => (fst x, f (snd x))) l) = map (fun x => (fst x, f (snd x))) l. Proof. induction l; simpl; auto. destruct (Adec (fst a) (fst a)); simpl; [f_equal |exfalso; tauto]. match goal with | H: filter ?g ?l = ?l |- filter ?h ?l = ?l => apply (filter_strengthen_same g h); auto end. intros. destruct (Adec (fst a) (fst a0)); auto. destruct (in_dec Adec (fst a0) (map fst l)); auto. Qed. Lemma filter_DisjKeys l1: forall l2, DisjKey l1 l2 -> filter (fun x : A * C => getBool (in_dec Adec (fst x) (map fst l1))) (map (fun x : A * B => (fst x, f (snd x))) l2) = nil. Proof. induction l2; intros; auto. assert (sth: DisjKey l1 l2). { unfold DisjKey; intros. specialize (H k). destruct H; firstorder fail. } specialize (IHl2 sth). simpl. rewrite IHl2. destruct (in_dec Adec (fst a) (map fst l1)); simpl; auto. rewrite DisjKeyWeak_same in H; auto. unfold DisjKeyWeak in *. specialize (H (fst a) i (or_introl eq_refl)). tauto. Qed. Lemma filter_DisjKeys_negb l1: forall l2, DisjKey l1 l2 -> filter (fun x : A * C => negb (getBool (in_dec Adec (fst x) (map fst l1)))) (map (fun x : A * B => (fst x, f (snd x))) l2) = (map (fun x => (fst x, f (snd x))) l2). Proof. induction l2; intros; auto. assert (sth: DisjKey l1 l2). { unfold DisjKey, key_not_In in *; intros. specialize (H k). destruct H; firstorder fail. } specialize (IHl2 sth). simpl. rewrite IHl2. destruct (in_dec Adec (fst a) (map fst l1)); simpl; auto. rewrite DisjKeyWeak_same in H; auto. unfold DisjKeyWeak in *. specialize (H _ i (or_introl eq_refl)). tauto. Qed. Lemma filter_negb l1: filter (fun x : A * C => negb (getBool (in_dec Adec (fst x) (map fst l1)))) (map (fun x : A * B => (fst x, f (snd x))) l1) = nil. Proof. induction l1; simpl; intros; auto. destruct (Adec (fst a) (fst a)); [simpl | exfalso; tauto]. pose proof (filter_nil1 _ _ IHl1) as sth. simpl in sth. apply filter_nil2; intros. destruct (Adec (fst a) (fst a0)); auto. destruct (in_dec Adec (fst a0) (map fst l1)); auto. exfalso. rewrite in_map_iff in *. destruct H as [? [? ?]]. assert (exists x, fst x = fst a0 /\ In x l1). exists x; split; auto. destruct x, a0; auto; simpl in *. inversion H; auto. tauto. Qed. Lemma filter_In_map_prod (l1: list (A * B)): forall l2, DisjKey l1 l2 -> filter (fun x => getBool (in_dec Adec (fst x) (map fst l1))) (map (fun x => (fst x, f (snd x))) (l1 ++ l2)) = map (fun x => (fst x, f (snd x))) l1. Proof. intros. rewrite map_app, filter_app. rewrite filter_DisjKeys with (l2 := l2); auto. rewrite app_nil_r. apply filter_In_map_same. Qed. End FilterMap. Section FilterMap2. Variable A B: Type. Variable f: A -> B. Variable g: B -> bool. Lemma filter_map_simple ls: filter g (map f ls) = map f (filter (fun x => g (f x)) ls). Proof. induction ls; simpl; auto. case_eq (g (f a)); intros; simpl; f_equal; auto. Qed. End FilterMap2. Lemma SubList_filter A (l1 l2: list A) (g: A -> bool): SubList l1 l2 -> SubList (filter g l1) (filter g l2). Proof. unfold SameList, SubList; simpl; intros. intros; rewrite filter_In in *. destruct H0; split; auto. Qed. Lemma SameList_filter A (l1 l2: list A) (g: A -> bool): SameList l1 l2 -> SameList (filter g l1) (filter g l2). Proof. unfold SameList, SubList; simpl; intros. destruct H; split; intros; rewrite filter_In in *; destruct H1; split; auto. Qed. Fixpoint mapProp A (P: A -> Prop) ls := match ls with | nil => True | x :: xs => P x /\ mapProp P xs end. Fixpoint mapProp2 A B (P: A -> B -> Prop) (ls: list (A * B)) := match ls with | nil => True | (x, y) :: ps => P x y /\ mapProp2 P ps end. Fixpoint mapProp_len A B (P: A -> B -> Prop) (la: list A) (lb: list B) := match la, lb with | (x :: xs), (y :: ys) => P x y /\ mapProp_len P xs ys | _, _ => True end. Lemma mapProp_len_conj A B (P Q: A -> B -> Prop): forall (la: list A) (lb: list B), mapProp_len (fun a b => P a b /\ Q a b) la lb <-> mapProp_len P la lb /\ mapProp_len Q la lb. Proof. induction la; destruct lb; simpl; auto; try tauto; intros. split; intros; firstorder fail. Qed. Section zip. Variable A B: Type. Lemma fst_combine (la: list A): forall (lb: list B), length la = length lb -> map fst (combine la lb) = la. Proof. induction la; simpl; intros; auto. destruct lb; simpl in *; try congruence. inversion H. specialize (IHla _ H1). f_equal; auto. Qed. Lemma snd_combine (la: list A): forall (lb: list B), length la = length lb -> map snd (combine la lb) = lb. Proof. induction la; simpl; intros; auto. - destruct lb; simpl in *; try congruence. - destruct lb; simpl in *; try congruence. inversion H. specialize (IHla _ H1). f_equal; auto. Qed. End zip. Lemma mapProp2_len_same A B (P: A -> B -> Prop) la: forall lb, length la = length lb -> mapProp_len P la lb <-> mapProp2 P (combine la lb). Proof. induction la; simpl; intros; try tauto. destruct lb; try tauto. inversion H. specialize (IHla _ H1). split; intros; destruct H0; firstorder fail. Qed. Definition nthProp A (P: A -> Prop) la := forall i, match nth_error la i with | Some a => P a | _ => True end. Definition nthProp2 A B (P: A -> B -> Prop) la lb := forall i, match nth_error la i, nth_error lb i with | Some a, Some b => P a b | _, _ => True end. Lemma mapProp_nthProp A (P: A -> Prop) ls: mapProp P ls <-> nthProp P ls. Proof. unfold nthProp. induction ls; simpl; auto; split; intros; auto. - destruct i; simpl; auto. - destruct i; simpl; try tauto. pose proof ((proj1 IHls) (proj2 H)). apply H0; auto. - destruct IHls. pose proof (H 0); simpl in *. split; auto. assert (sth: forall i, match nth_error (a :: ls) (S i) with | Some a => P a | None => True end) by (intros; eapply (H (S i)); eauto). simpl in sth. eapply H1; eauto. Qed. Lemma mapProp2_nthProp A B (P: A -> B -> Prop) ls: mapProp2 P ls <-> forall i, match nth_error ls i with | Some (a, b) => P a b | _ => True end. Proof. induction ls; simpl; auto; split; intros; auto. - destruct i; simpl; auto. - destruct a; destruct i; simpl; try tauto. pose proof ((proj1 IHls) (proj2 H)). apply H0; auto. - destruct a, IHls. pose proof (H 0); simpl in *. split; auto. assert (sth: forall i, match nth_error ((a, b) :: ls) (S i) with | Some (a, b) => P a b | None => True end) by (intros; eapply (H (S i)); eauto). simpl in sth. eapply H1; eauto. Qed. Lemma mapProp_len_nthProp2 A B (P: A -> B -> Prop) la lb: length la = length lb -> mapProp_len P la lb <-> nthProp2 P la lb. Proof. unfold nthProp2. intros. apply mapProp2_len_same with (P := P) in H. rewrite H; clear H. generalize lb; clear lb. induction la; destruct lb; simpl; split; auto; intros; try destruct i; simpl; auto. - destruct (nth_error la i); simpl; auto. - tauto. - apply IHla; tauto. - pose proof (H 0); simpl in *. split; auto. assert (sth: forall i, match nth_error (a :: la) (S i) with | Some a => match nth_error (b :: lb) (S i) with | Some b => P a b | None => True end | None => True end) by (intros; eapply (H (S i)); eauto). simpl in sth. eapply IHla; eauto. Qed. Lemma prod_dec A B (Adec: forall a1 a2: A, {a1 = a2} + {a1 <> a2}) (Bdec: forall b1 b2: B, {b1 = b2} + {b1 <> b2}): forall x y: (A * B), {x = y} + {x <> y}. Proof. decide equality. Defined. Lemma DisjKey_Commutative A B (l1 l2: list (A * B)): DisjKey l1 l2 -> DisjKey l2 l1. Proof. unfold DisjKey, key_not_In; intros. firstorder fail. Qed. Section filter. Variable A: Type. Variable g: A -> bool. Lemma filter_length_le: forall ls, length (filter g ls) <= length ls. Proof. induction ls; simpl; intros; auto. destruct (g a); simpl; try omega. Qed. Lemma filter_length_same: forall ls, length (filter g ls) = length ls -> filter g ls = ls. Proof. induction ls; simpl; intros; auto. destruct (g a); f_equal. - apply IHls; auto. - pose proof (filter_length_le ls). Omega.omega. Qed. Lemma map_filter B (f: A -> B): forall ls, map f (filter g ls) = map f ls -> filter g ls = ls. Proof. intros. pose proof (map_length f (filter g ls)) as sth1. pose proof (map_length f ls) as sth2. rewrite H in *. rewrite sth1 in sth2. apply filter_length_same; auto. Qed. Lemma filter_true_list: forall ls (true_list: forall a, In a ls -> g a = true), filter g ls = ls. Proof. induction ls; simpl; auto; intros. case_eq (g a); intros. - f_equal. apply IHls; auto. - specialize (true_list a). clear - true_list H; firstorder congruence. Qed. Lemma filter_false_list: forall ls (false_list: forall a, In a ls -> g a = false), filter g ls = []. Proof. induction ls; simpl; auto; intros. case_eq (g a); intros. - specialize (false_list a). clear - false_list H; firstorder congruence. - apply IHls; auto. Qed. End filter. Lemma filter_in_dec_map A: forall (ls: list (string * A)), filter (fun x => id (getBool (in_dec string_dec (fst x) (map fst ls)))) ls = ls. Proof. intros. eapply filter_true_list; intros. pose proof (in_map fst _ _ H) as sth. destruct (in_dec string_dec (fst a) (map fst ls)); simpl; auto. Qed. Lemma filter_not_in_dec_map A: forall (l1 l2: list (string * A)), DisjKey l1 l2 -> filter (fun x => id (getBool (in_dec string_dec (fst x) (map fst l1)))) l2 = []. Proof. intros. eapply filter_false_list; intros. pose proof (in_map fst _ _ H0) as sth. destruct (in_dec string_dec (fst a) (map fst l1)); simpl; auto. firstorder fail. Qed. Lemma filter_negb_in_dec_map A: forall (ls: list (string * A)), filter (fun x => negb (getBool (in_dec string_dec (fst x) (map fst ls)))) ls = []. Proof. intros. eapply filter_false_list; intros. pose proof (in_map fst _ _ H) as sth. destruct (in_dec string_dec (fst a) (map fst ls)); simpl; auto. firstorder fail. Qed. Lemma filter_negb_not_in_dec_map A: forall (l1 l2: list (string * A)), DisjKey l1 l2 -> filter (fun x => negb (getBool (in_dec string_dec (fst x) (map fst l1)))) l2 = l2. Proof. intros. eapply filter_true_list; intros. pose proof (in_map fst _ _ H0) as sth. destruct (in_dec string_dec (fst a) (map fst l1)); simpl; auto. firstorder fail. Qed. Section DisjKey_filter. Variable A B: Type. Variable decA: forall (a1 a2: A), {a1 = a2} + {a1 <> a2}. Lemma DisjKey_filter: forall (l1 l2: list (A * B)), DisjKey l1 l2 <-> filter (fun x => (getBool (in_dec decA (fst x) (map fst l1)))) l2 = []. Proof. intros. split; intros. - eapply filter_false_list; intros. pose proof (in_map fst _ _ H0) as sth. destruct (in_dec decA (fst a) (map fst l1)); simpl; auto. firstorder fail. - pose proof (filter_nil1 _ _ H) as sth. rewrite DisjKeyWeak_same by auto. unfold DisjKeyWeak; intros. rewrite in_map_iff in *. destruct H0 as [x1 [sth1 in1]]. destruct H1 as [x2 [sth2 in2]]. subst. specialize (sth _ in2); simpl in *. destruct (in_dec decA (fst x2) (map fst l1)); [discriminate|]. clear sth. erewrite in_map_iff in n. firstorder auto. Qed. End DisjKey_filter. Lemma SameList_map A B (f: A -> B): forall l1 l2, SameList l1 l2 -> SameList (map f l1) (map f l2). Proof. unfold SameList, SubList in *; intros. setoid_rewrite in_map_iff; split; intros; destruct H; subst; firstorder fail. Qed. Lemma SameList_map_map A B C (f: A -> B) (g: B -> C): forall l1 l2, SameList (map f l1) (map f l2) -> SameList (map (fun x => g (f x)) l1) (map (fun x => g (f x)) l2). Proof. intros. apply SameList_map with (f := g) in H. rewrite ?map_map in H. auto. Qed. Lemma filter_contra A B (f: A -> B) (g h: B -> bool): forall ls, (forall a, g (f a) = true -> h (f a) = false -> ~ In (f a) (map f ls)) -> (forall a, h (f a) = true -> g (f a) = false -> ~ In (f a) (map f ls)) -> filter (fun x => g (f x)) ls = filter (fun x => h (f x)) ls. Proof. induction ls; simpl; auto; intros. assert (filter (fun x => g (f x)) ls = filter (fun x => h (f x)) ls) by (firstorder first). specialize (H a); specialize (H0 a). case_eq (g (f a)); case_eq (h (f a)); intros. - f_equal; auto. - rewrite H2, H3 in *. firstorder fail. - rewrite H2, H3 in *. firstorder fail. - auto. Qed. Lemma filter_map_app_sameKey A B (f: A -> B) (Bdec: forall b1 b2: B, {b1 = b2} + {b1 <> b2}): forall ls l1 l2, (forall x, ~ In x l1 \/ ~ In x l2) -> map f ls = l1 ++ l2 -> ls = (filter (fun x => getBool (in_dec Bdec (f x) l1)) ls) ++ filter (fun x => getBool (in_dec Bdec (f x) l2)) ls. Proof. induction ls; simpl; auto; intros. destruct l1. - simpl in *; destruct l2; simpl in *. + discriminate. + inversion H0; subst; clear H0. destruct (Bdec (f a) (f a)); [simpl| exfalso; tauto]. rewrite filter_false; simpl. f_equal. rewrite filter_true_list; auto; intros. destruct (Bdec (f a) (f a0)); auto. destruct (in_dec Bdec (f a0) (map f ls)); auto; simpl. apply (in_map f) in H0. tauto. - inversion H0; subst; clear H0. destruct (in_dec Bdec (f a) l2); [assert (~ In (f a) l2) by (specialize (H (f a)); firstorder fail); exfalso; tauto|]. unfold getBool at 4. unfold getBool at 1. destruct (in_dec Bdec (f a) (f a :: l1)); [| exfalso; simpl in *; tauto]. assert (sth: forall A (a: A) l1 l2, (a :: l1) ++ l2 = a :: l1 ++ l2) by auto. rewrite sth. f_equal; clear sth. assert (sth: forall x, ~ In x l1 \/ ~ In x l2) by (clear - H; firstorder fail). specialize (IHls _ _ sth H3). rewrite IHls at 1. f_equal. destruct (in_dec Bdec (f a) l1). + eapply filter_contra with (f := f) (g := fun x => getBool (in_dec Bdec x l1)) (h := fun x => getBool (in_dec Bdec x (f a :: l1))); auto; intros; intro; simpl in *. * destruct (Bdec (f a) (f a0)); try discriminate. destruct (in_dec Bdec (f a0) l1); discriminate. * rewrite H3 in H2. rewrite in_app_iff in *. destruct (in_dec Bdec (f a0) l1); simpl in *; destruct (Bdec (f a) (f a0)); simpl in *; firstorder congruence. + eapply filter_contra with (f := f) (g := fun x => getBool (in_dec Bdec x l1)) (h := fun x => getBool (in_dec Bdec x (f a :: l1))); auto; intros; intro; simpl in *. * destruct (Bdec (f a) (f a0)); try discriminate. destruct (in_dec Bdec (f a0) l1); discriminate. * rewrite H3 in H2. rewrite in_app_iff in *. destruct (in_dec Bdec (f a0) l1); simpl in *; destruct (Bdec (f a) (f a0)); simpl in *; firstorder congruence. Qed. Lemma nth_error_map A B (f: A -> B) (P: B -> Prop) i: forall ls, match nth_error (map f ls) i with | Some b => P b | None => True end <-> match nth_error ls i with | Some a => P (f a) | None => True end. Proof. induction i; destruct ls; simpl; auto; intros; tauto. Qed. Lemma length_combine_cond A B: forall l1 l2, length l1 = length l2 -> length (@combine A B l1 l2) = length l1. Proof. induction l1; destruct l2; simpl; auto. Qed. Lemma nth_error_combine A B C (f: (A * B) -> C) (P: C -> Prop) i: forall l1 l2, length l1 = length l2 -> (match nth_error (map f (combine l1 l2)) i with | Some c => P c | None => True end <-> match nth_error l1 i, nth_error l2 i with | Some a, Some b => P (f (a,b)) | _, _ => True end). Proof. induction i; destruct l1, l2; simpl; intros; try tauto. - congruence. - inversion H. apply IHi; auto. Qed. Definition zip4 {A B C D} (l1 : list A) (l2 : list B) (l3 : list C) (l4 : list D) := List.combine (List.combine l1 l2) (List.combine l3 l4). Lemma nthProp2_cons A B (P: A -> B -> Prop): forall la lb a b, nthProp2 P (a :: la) (b :: lb) <-> (nthProp2 P la lb /\ P a b). Proof. intros. unfold nthProp2. split; intros. - split; intros. + specialize (H (S i)). simpl in *; auto. + specialize (H 0); simpl in *; auto. - destruct i; simpl in *; destruct H; auto. eapply H; eauto. Qed. Lemma combine_length A B n: forall (l1: list A) (l2: list B), length l1 = n -> length l2 = n -> length (List.combine l1 l2) = n. Proof. induction n; simpl; intros; auto. - rewrite length_zero_iff_nil in *; subst; auto. - destruct l1, l2; simpl in *; try discriminate. specialize (IHn l1 l2 ltac:(Omega.omega) ltac:(Omega.omega)). Omega.omega. Qed. Lemma zip4_length A B C D n: forall (l1: list A) (l2: list B) (l3: list C) (l4: list D), length l1 = n -> length l2 = n -> length l3 = n -> length l4 = n -> length (zip4 l1 l2 l3 l4) = n. Proof. unfold zip4; intros. assert (length (List.combine l1 l2) = n) by (eapply combine_length; eauto). assert (length (List.combine l3 l4) = n) by (eapply combine_length; eauto). eapply combine_length; eauto. Qed. (* Lemma length_upto t: *) (* forall b, *) (* (t > b \/ t = 0)%nat -> *) (* length (b upto t) = (t - b)%nat. *) (* Proof. *) (* induction t; simpl; auto; intros. *) (* destruct (Nat.eq_dec b t); simpl; subst. *) (* - destruct t; auto. *) (* rewrite seq_length. *) (* auto. *) (* - specialize (IHt b ltac:(Omega.omega)). *) (* rewrite seq_length. *) (* destruct b; auto. *) (* Qed. *) Lemma nth_combine A B n: forall (l1: list A) (l2: list B) a b, length l1 = n -> length l2 = n -> forall i, (i < n)%nat -> nth i (List.combine l1 l2) (a,b) = (nth i l1 a, nth i l2 b). Proof. induction n; simpl; auto; intros. - Omega.omega. - destruct l1, l2; simpl in *; try discriminate. destruct i; simpl in *; auto. specialize (IHn l1 l2 a b ltac:(Omega.omega) ltac:(Omega.omega) i ltac:(Omega.omega)); auto. Qed. Lemma nth_zip4 A B C D n: forall (l1: list A) (l2: list B) (l3: list C) (l4: list D) a b c d, length l1 = n -> length l2 = n -> length l3 = n -> length l4 = n -> forall i, (i < n)%nat -> nth i (zip4 l1 l2 l3 l4) ((a, b), (c, d)) = ((nth i l1 a, nth i l2 b), (nth i l3 c, nth i l4 d)). Proof. unfold zip4; intros. assert (length (List.combine l1 l2) = n) by (eapply combine_length; eauto). assert (length (List.combine l3 l4) = n) by (eapply combine_length; eauto). repeat erewrite nth_combine; eauto. Qed. Lemma length_minus1_nth A ls: forall (a b: A), nth (length ls) (ls ++ a :: nil) b = a. Proof. induction ls; simpl; auto. Qed. Lemma upto_0_n_length n: 0 <> n -> length (seq 0 n) <> 0. Proof. rewrite seq_length. intros; congruence. Qed. Lemma nth_0_upto_n_0 n: nth 0 (seq 0 n) 0 = 0. Proof. induction n; simpl; auto. Qed. Lemma nth_0_upto_n n: forall i, (i < n)%nat -> nth i (seq 0 n) 0 = i. Proof. intros. rewrite seq_nth; auto. Qed. Lemma log2_up_pow2 n: (n <= Nat.pow 2 (Nat.log2_up n))%nat. Proof. destruct n; simpl; auto. pose proof (Nat.log2_log2_up_spec (S n) ltac:(Omega.omega)). Omega.omega. Qed. Lemma append_remove_prefix a: forall b c, (a ++ b)%string = (a ++ c)%string <-> b = c. Proof. induction a; simpl; intros; auto. - reflexivity. - split; intros; subst; auto. inversion H. eapply IHa; eauto. Qed. Lemma append_nil a: (a ++ "")%string = a. Proof. induction a; simpl; auto; intros. rewrite IHa. auto. Qed. Lemma append_assoc a: forall b c, (a ++ (b ++ c))%string = ((a ++ b) ++ c)%string. Proof. induction a; simpl; auto; intros. f_equal; auto. Qed. Lemma append_cons a b: (String a b)%string = (String a EmptyString ++ b)%string. Proof. auto. Qed. Lemma append_eq_nil: forall a b, (a ++ b)%string = EmptyString <-> a = EmptyString /\ b = EmptyString. Proof. induction a; destruct b; simpl; split; intros; auto. - destruct H; congruence. - congruence. - destruct H; congruence. - congruence. - destruct H; congruence. Qed. Lemma append_cons_suffix: forall b c a, (b ++ String a "")%string = (c ++ String a "")%string <-> b = c. Proof. induction b; destruct c; simpl; split; intros; auto. - inversion H; subst. apply eq_sym in H2. rewrite append_eq_nil in H2. destruct H2. congruence. - congruence. - inversion H; subst. apply append_eq_nil in H2. destruct H2; congruence. - congruence. - inversion H; subst. f_equal. eapply IHb; eauto. - inversion H; subst. auto. Qed. Lemma append_remove_suffix a: forall b c, (b ++ a)%string = (c ++ a)%string <-> b = c. Proof. induction a; simpl; intros; auto; split; intros; subst; auto. - rewrite ?append_nil in H. auto. - rewrite append_cons in H. rewrite ?append_assoc in H. rewrite IHa in H. rewrite append_cons_suffix in H. auto. Qed. Lemma string_rev_append : forall s1 s2, (string_rev (s1 ++ s2) = string_rev s2 ++ string_rev s1)%string. Proof. induction s1; intros *; cbn; auto using append_nil. rewrite IHs1; auto using append_assoc. Qed. Lemma key_not_In_fst A B (ls: list (A*B)): forall k, key_not_In k ls <-> ~ In k (map fst ls). Proof. induction ls; simpl; auto; split; intros; try tauto. - unfold key_not_In in *; simpl; intros; auto. - intro. unfold key_not_In in H; simpl in *. assert (sth: key_not_In k ls) by (firstorder fail). pose proof (proj1 (IHls _) sth) as sth2. destruct H0; [subst|tauto]. specialize (H (snd a)). destruct a; simpl in *. firstorder fail. - unfold key_not_In in *; simpl; intros; auto. intro. destruct a; simpl in *. destruct H0. + inversion H0; subst; clear H0. firstorder fail. + apply (in_map fst) in H0; simpl in *. firstorder fail. Qed. Lemma InFilterPair A B (dec: forall a1 a2, {a1 = a2} + {a1 <> a2}): forall (ls: list (A * B)), forall x, In x ls <-> In x (filter (fun t => getBool (dec (fst x) (fst t))) ls). Proof. induction ls; simpl; split; auto; intros. - destruct H; [subst|]; auto. + destruct (dec (fst x) (fst x)) ; simpl in *; tauto. + apply IHls in H. destruct (dec (fst x) (fst a)) ; simpl in *; auto. - destruct (dec (fst x) (fst a)) ; simpl in *. + destruct H; auto. apply IHls in H; auto. + eapply IHls in H; eauto. Qed. Lemma InFilter A (dec: forall a1 a2, {a1 = a2} + {a1 <> a2}): forall (ls: list A), forall x, In x ls <-> In x (filter (fun t => getBool (dec x t)) ls). Proof. induction ls; simpl; split; auto; intros. - destruct H; [subst|]; auto. + destruct (dec x x) ; simpl in *; tauto. + apply IHls in H. destruct (dec x a) ; simpl in *; auto. - destruct (dec x a) ; simpl in *. + destruct H; auto. + eapply IHls in H; eauto. Qed. Lemma InSingleton A (x: A): In x [x]. Proof. simpl; auto. Qed. (* Useful Ltacs *) Ltac EqDep_subst := repeat match goal with |[H : existT ?a ?b ?c1 = existT ?a ?b ?c2 |- _] => apply Eqdep.EqdepTheory.inj_pair2 in H; subst end. Ltac inv H := inversion H; subst; clear H. Ltac dest := repeat (match goal with | H: _ /\ _ |- _ => destruct H | H: exists _, _ |- _ => destruct H end). Section NoDup. Variable A: Type. Variable decA: forall a1 a2: A, {a1 = a2} + {a1 <> a2}. Fixpoint NoDup_fn (ls: list A) := match ls with | nil => true | x :: xs => andb (negb (getBool (in_dec decA x xs))) (NoDup_fn xs) end. Lemma NoDup_dec l: NoDup l <-> NoDup_fn l = true. Proof. intros. induction l; simpl; split; auto; intros; try solve [econstructor; eauto]. - inv H. rewrite IHl in *. destruct (in_dec decA a l); simpl; auto. - rewrite andb_true_iff in *; dest. rewrite negb_true_iff in *. rewrite <- IHl in *. econstructor; eauto. destruct (in_dec decA a l); simpl; auto; discriminate. Qed. End NoDup. Section Forall. Variables (A B C: Type). Variable P: A -> Prop. Variable P2: A -> B -> Prop. Lemma Forall2_length : forall xs ys, Forall2 P2 xs ys -> length xs = length ys. Proof. induction 1; cbn; auto. Qed. Lemma Forall_map : forall (f: B -> A) xs, Forall P (map f xs) <-> Forall (fun x => P (f x)) xs. Proof. split; induction xs; cbn; intros * Hall; constructor; inv Hall; auto. Qed. Lemma Forall_combine : forall xs ys, length xs = length ys -> Forall (fun p => let '(x, y) := p in P2 x y) (List.combine xs ys) <-> Forall2 (fun x y => P2 x y) xs ys. Proof. induction xs; destruct ys; cbn in *; try easy; intros Hlen; inv Hlen. split; intros Hall; constructor; inv Hall; auto; apply IHxs; auto. Qed. Lemma Forall2_nth_error : forall xs ys, Forall2 P2 xs ys -> forall n x y, (n < length xs)%nat -> nth_error xs n = Some x -> nth_error ys n = Some y -> P2 x y. Proof. induction 1; cbn; intros * Hn Hx Hy; [omega |]. destruct n; cbn in *; [inv Hx; inv Hy; auto |]. eapply IHForall2; eauto; omega. Qed. Lemma Forall2_nth : forall xs ys d d', Forall2 P2 xs ys -> forall n, (n < length xs)%nat -> P2 (nth n xs d) (nth n ys d'). Proof. induction 1; cbn; intros * Hn; [omega |]. destruct n; auto. apply IHForall2; omega. Qed. End Forall. Section Stringb. Lemma strip_pref : forall pre x y, ((pre ++ x) =? (pre ++ y) = (x =? y))%string. Proof. induction pre; intros. auto. simpl. rewrite Ascii.eqb_refl. apply IHpre. Qed. End Stringb. Section Silly. (*used to avoid ill-typed term error messages*) Lemma silly_lemma_true : forall {Y} (b : bool) f g pf, b = true -> match b as b' return b = b' -> Y with | true => f | false => g end eq_refl = f pf. Proof. intros. destruct b. rewrite (hedberg bool_dec eq_refl pf); reflexivity. discriminate. Qed. Lemma silly_lemma_false : forall {Y} (b : bool) f g pf, b = false -> match b as b' return b = b' -> Y with | true => f | false => g end eq_refl = g pf. Proof. intros. destruct b. discriminate. rewrite (hedberg bool_dec eq_refl pf); reflexivity. Qed. End Silly. Lemma boundProof sz w: w mod 2^sz = w -> w < 2^sz. Proof. intros sth0. simpl. pose proof (Nat.mod_upper_bound w (2 ^ sz) (@Nat.pow_nonzero 2 sz ltac:(intro; discriminate))) as sth. rewrite sth0 in sth. auto. Qed. Lemma Z_lt_div': forall (a b c : Z), (c > 0)%Z -> (a/c < b/c)%Z -> (a < b)%Z. Proof. intros. destruct (Z_ge_lt_dec a b); auto. apply (Z_div_ge _ _ _ H) in g. exfalso; lia. Qed. Lemma Z_lt_div2: forall (a b c : Z), (c > 0)%Z -> (a < b)%Z -> (b mod c = 0)%Z -> (a/c < b/c)%Z. Proof. intros. pose proof (Z.div_le_mono a b c ltac:(lia) ltac:(lia)) as sth. apply Z_le_lt_eq_dec in sth. destruct sth; auto. pose proof (Z.mod_eq b c ltac:(lia)) as sth2. assert (sth3: (b = c * (b / c))%Z) by lia. rewrite sth3 in H0. assert (sth4: (c * (a/c) = c * (b/c))%Z) by nia. rewrite <- sth4 in *. pose proof (Z_mult_div_ge a c H). lia. Qed. Lemma Z_pow_2_gt_0: forall n, (n >= 0)%Z -> (2 ^ n > 0)%Z. Proof. intros. apply Z.lt_gt, Z.pow_pos_nonneg;[lia|]. lia. Qed. Lemma Z_of_nat_pow_2_gt_0: forall n, (2 ^ (Z.of_nat n) > 0)%Z. Proof. intros. apply Z.lt_gt, Z.pow_pos_nonneg;[lia|]. apply Nat2Z.is_nonneg. Qed. Lemma Zpow_1_0 : forall b, (Z.pow 2 b = 1)%Z -> b = 0%Z. Proof. repeat intro. destruct (Z_lt_le_dec 0 b). - specialize (Z.pow_gt_1 2 b) as TMP; destruct TMP; try lia. - rewrite Z.le_lteq in l; destruct l; try lia. exfalso. rewrite (Z.pow_neg_r 2 _ H0) in H; lia. Qed. Lemma pow2_of_nat (n : nat) : (2 ^ Z.of_nat n)%Z = Z.of_nat (2 ^ n)%nat. Proof. induction n. + simpl. auto. + rewrite Nat2Z.inj_succ. simpl. rewrite Z.pow_succ_r; try lia. Qed. Lemma Zpow_of_nat : forall n, Z.of_nat (2 ^ n) = (2 ^ Z.of_nat n)%Z. Proof. induction n; auto. rewrite Nat2Z.inj_succ, <- Z.add_1_l. rewrite Z.pow_add_r; try lia. rewrite <-IHn. rewrite Nat.pow_succ_r', Nat2Z.inj_mul; auto. Qed. Lemma Zpow_1_le (a b : Z) : (1 <= a)%Z -> (0 <= b)%Z -> (1 <= a ^b)%Z. Proof. intros. apply Zle_lt_or_eq in H. destruct H. - specialize (Z.pow_gt_lin_r _ _ H H0) as P0. lia. - rewrite <- H. rewrite Z.pow_1_l. lia. auto. Qed. Lemma Zpow_mul_le (a b : Z) : (0 <= a)%Z -> (0 <= b)%Z -> (2 ^ a <= 2 ^ b * 2 ^ a)%Z. Proof. intros. rewrite <-(Z.mul_1_l (2^a)) at 1. assert (1 <= 2)%Z. { lia. } specialize (Zpow_1_le H1 H0). intros. apply Zmult_lt_0_le_compat_r. apply Z.pow_pos_nonneg. lia. auto. auto. Qed. Lemma Zpow_add_sub (a b : Z) : (0 <= a)%Z -> (0 <= b)%Z -> (2 ^ (a + b) = (2 ^ a * 2 ^ b - 2 ^ b) + 2 ^ b)%Z. Proof. intros. rewrite Z.pow_add_r; lia. Qed. Lemma Zmul_sub (a b c : Z) : (0 <= b)%Z -> (0 <= c)%Z -> (0 <= a < 2 ^ b)%Z -> (a * 2 ^ c <= (2 ^ b * (2 ^ c) - 1 * (2 ^ c)))%Z. Proof. intros. rewrite <-Z.mul_sub_distr_r. apply Z.mul_le_mono_nonneg_r. apply Z.pow_nonneg; lia. lia. Qed. Lemma Zpow_lt_add (a b c : Z) : (0 <= c)%Z -> (0 <= b)%Z -> (0 <= a < 2 ^ c)%Z -> (0 <= a < 2 ^ (b + c))%Z. Proof. intros. split. destruct H1. auto. rewrite Z.pow_add_r; auto. assert (1 <= 2)%Z. { lia. } specialize (Zpow_1_le H2 H0) as P0. destruct H1. specialize (Zpow_mul_le H H0) as P1. lia. Qed. Lemma Zmul_add_0_lt (a a' b c : Z) : (0 <= a)%Z -> (0 <= b)%Z -> (0 <= c)%Z -> (0 <= a')%Z -> (0 <= a < 2 ^ b)%Z -> (0 <= a' < 2 ^ c)%Z -> (0 <= a' < 2 ^ (b + c))%Z -> (0 <= (a * 2 ^ c + a') < 2 ^ (b + c))%Z. Proof. intros. split. apply Z.add_nonneg_nonneg; auto. specialize (Z.pow_nonneg 2 (c)) as P0. assert (0 <= 2)%Z; [lia|]. specialize (P0 H6). apply Z.mul_nonneg_nonneg; auto. specialize(Zpow_lt_add H1 H0 H4); intros. specialize(Zmul_sub H0 H1 H3); intros. rewrite Z.mul_1_l in H7. specialize (Zmul_sub H0 H1 H3); intros. specialize (Zpow_add_sub H0 H1); intros. rewrite H9. lia. Qed. Lemma Nat_mod_factor a b c: b <> 0 -> c <> 0 -> (a mod (b * c)) mod b = a mod b. Proof. intros. pose proof (Nat.mod_mul_r a _ _ H H0). rewrite H1. rewrite Nat.add_mod_idemp_l by auto. rewrite Nat.add_mod by auto. assert (sth: b * ((a/b) mod c) = (a/b) mod c * b) by (apply Nat.mul_comm). rewrite sth. rewrite Nat.mod_mul by auto. rewrite Nat.add_0_r. rewrite Nat.mod_mod by auto. auto. Qed. Lemma Nat_mod_factor' a b c d: b <> 0 -> c <> 0 -> d = b * c -> (a mod d) mod b = a mod b. Proof. pose proof (@Nat_mod_factor a b c). intros. subst. eapply H; eauto. Qed. Lemma mod_sub a b c: c > 0 -> a >= b * c -> (a - b * c) mod c = a mod c. Proof. intros. assert (sth: a - b * c + b * c = a) by lia. rewrite <- sth at 2. rewrite Nat.mod_add by lia. auto. Qed. Fixpoint mod2 (n : nat) : bool := match n with | 0 => false | 1 => true | S (S n') => mod2 n' end. Ltac rethink := match goal with | [ H : ?f ?n = _ |- ?f ?m = _ ] => replace m with n; simpl; auto end. Theorem mod2_S_double : forall n, mod2 (S (2 * n)) = true. induction n; simpl; intuition; rethink. Qed. Theorem mod2_double : forall n, mod2 (2 * n) = false. induction n; simpl; intuition; rewrite <- plus_n_Sm; rethink. Qed. Theorem div2_double : forall n, Nat.div2 (2 * n) = n. Proof. induction n; simpl; intuition; rewrite <- plus_n_Sm; f_equal; rethink. Qed. Theorem div2_S_double : forall n, Nat.div2 (S (2 * n)) = n. induction n; simpl; intuition; f_equal; rethink. Qed. Fixpoint Npow2 (n : nat) : N := match n with | O => 1 | S n' => 2 * Npow2 n' end%N. Theorem untimes2 : forall n, n + (n + 0) = 2 * n. auto. Qed. Section strong. Variable P : nat -> Prop. Hypothesis PH : forall n, (forall m, m < n -> P m) -> P n. Lemma strong' : forall n m, m <= n -> P m. induction n; simpl; intuition; apply PH; intuition. elimtype False; omega. Qed. Theorem strong : forall n, P n. intros; eapply strong'; eauto. Qed. End strong. Theorem div2_odd : forall n, mod2 n = true -> n = S (2 * Nat.div2 n). induction n as [n] using strong; simpl; intuition. destruct n as [|n]; simpl in *; intuition. discriminate. destruct n as [|n]; simpl in *; intuition. do 2 f_equal. replace (Nat.div2 n + S (Nat.div2 n + 0)) with (S (Nat.div2 n + (Nat.div2 n + 0))); auto. Qed. Theorem div2_even : forall n, mod2 n = false -> n = 2 * Nat.div2 n. induction n as [n] using strong; simpl; intuition. destruct n as [|n]; simpl in *; intuition. destruct n as [|n]; simpl in *; intuition. discriminate. f_equal. replace (Nat.div2 n + S (Nat.div2 n + 0)) with (S (Nat.div2 n + (Nat.div2 n + 0))); auto. Qed. Theorem drop_mod2 : forall n k, 2 * k <= n -> mod2 (n - 2 * k) = mod2 n. induction n as [n] using strong; intros. do 2 (destruct n; simpl in *; repeat rewrite untimes2 in *; intuition). destruct k; simpl in *; intuition. destruct k; simpl; intuition. rewrite <- plus_n_Sm. repeat rewrite untimes2 in *. simpl; auto. apply H; omega. Qed. Theorem div2_minus_2 : forall n k, 2 * k <= n -> Nat.div2 (n - 2 * k) = Nat.div2 n - k. induction n as [n] using strong; intros. do 2 (destruct n; simpl in *; intuition; repeat rewrite untimes2 in *). destruct k; simpl in *; intuition. destruct k; simpl in *; intuition. rewrite <- plus_n_Sm. apply H; omega. Qed. Theorem div2_bound : forall k n, 2 * k <= n -> k <= Nat.div2 n. intros ? n H; case_eq (mod2 n); intro Heq. rewrite (div2_odd _ Heq) in H. omega. rewrite (div2_even _ Heq) in H. omega. Qed. Lemma two_times_div2_bound: forall n, 2 * Nat.div2 n <= n. Proof. eapply strong. intros n IH. destruct n. - constructor. - destruct n. + simpl. constructor. constructor. + simpl (Nat.div2 (S (S n))). specialize (IH n). omega. Qed. Lemma div2_compat_lt_l: forall a b, b < 2 * a -> Nat.div2 b < a. Proof. induction a; intros. - omega. - destruct b. + simpl. omega. + destruct b. * simpl. omega. * simpl. apply lt_n_S. apply IHa. omega. Qed. (* otherwise b is made implicit, while a isn't, which is weird *) Arguments div2_compat_lt_l {_} {_} _. Lemma pow2_add_mul: forall a b, Nat.pow 2 (a + b) = (Nat.pow 2 a) * (Nat.pow 2 b). Proof. induction a; destruct b; firstorder; simpl. repeat rewrite Nat.add_0_r. rewrite Nat.mul_1_r; auto. repeat rewrite Nat.add_0_r. rewrite IHa. simpl. repeat rewrite Nat.add_0_r. rewrite Nat.mul_add_distr_r; auto. Qed. Lemma mult_pow2_bound: forall a b x y, x < Nat.pow 2 a -> y < Nat.pow 2 b -> x * y < Nat.pow 2 (a + b). Proof. intros. rewrite pow2_add_mul. apply Nat.mul_lt_mono_nonneg; omega. Qed. Lemma mult_pow2_bound_ex: forall a c x y, x < Nat.pow 2 a -> y < Nat.pow 2 (c - a) -> c >= a -> x * y < Nat.pow 2 c. Proof. intros. replace c with (a + (c - a)) by omega. apply mult_pow2_bound; auto. Qed. Lemma lt_mul_mono' : forall c a b, a < b -> a < b * (S c). Proof. induction c; intros. rewrite Nat.mul_1_r; auto. rewrite Nat.mul_succ_r. apply lt_plus_trans. apply IHc; auto. Qed. Lemma lt_mul_mono : forall a b c, c <> 0 -> a < b -> a < b * c. Proof. intros. replace c with (S (c - 1)) by omega. apply lt_mul_mono'; auto. Qed. Lemma zero_lt_pow2 : forall sz, 0 < Nat.pow 2 sz. Proof. induction sz; simpl; omega. Qed. Lemma one_lt_pow2: forall n, 1 < Nat.pow 2 (S n). Proof. intros. induction n. simpl; omega. remember (S n); simpl. omega. Qed. Lemma one_le_pow2 : forall sz, 1 <= Nat.pow 2 sz. Proof. intros. pose proof (zero_lt_pow2 sz). omega. Qed. Lemma pow2_ne_zero: forall n, Nat.pow 2 n <> 0. Proof. intros. pose proof (zero_lt_pow2 n). omega. Qed. Lemma mul2_add : forall n, n * 2 = n + n. Proof. induction n; firstorder. Qed. Lemma pow2_le_S : forall sz, (Nat.pow 2 sz) + 1 <= Nat.pow 2 (sz + 1). Proof. induction sz; simpl; auto. repeat rewrite Nat.add_0_r. rewrite pow2_add_mul. repeat rewrite mul2_add. pose proof (zero_lt_pow2 sz). omega. Qed. Lemma pow2_bound_mono: forall a b x, x < Nat.pow 2 a -> a <= b -> x < Nat.pow 2 b. Proof. intros. replace b with (a + (b - a)) by omega. rewrite pow2_add_mul. apply lt_mul_mono; auto. pose proof (zero_lt_pow2 (b - a)). omega. Qed. Lemma pow2_inc : forall n m, 0 < n -> n < m -> Nat.pow 2 n < Nat.pow 2 m. Proof. intros. generalize dependent n; intros. induction m; simpl. intros. inversion H0. unfold lt in H0. rewrite Nat.add_0_r. inversion H0. apply Nat.lt_add_pos_r. apply zero_lt_pow2. apply Nat.lt_trans with (Nat.pow 2 m). apply IHm. exact H2. apply Nat.lt_add_pos_r. apply zero_lt_pow2. Qed. Lemma pow2_S: forall x, Nat.pow 2 (S x) = 2 * Nat.pow 2 x. Proof. intros. reflexivity. Qed. Lemma mod2_S_S : forall n, mod2 (S (S n)) = mod2 n. Proof. intros. destruct n; auto; destruct n; auto. Qed. Lemma mod2_S_not : forall n, mod2 (S n) = if (mod2 n) then false else true. Proof. intros. induction n; auto. rewrite mod2_S_S. destruct (mod2 n); replace (mod2 (S n)); auto. Qed. Lemma mod2_S_eq : forall n k, mod2 n = mod2 k -> mod2 (S n) = mod2 (S k). Proof. intros. do 2 rewrite mod2_S_not. rewrite H. auto. Qed. Theorem drop_mod2_add : forall n k, mod2 (n + 2 * k) = mod2 n. Proof. intros. induction n. simpl. rewrite Nat.add_0_r. replace (k + k) with (2 * k) by omega. apply mod2_double. replace (S n + 2 * k) with (S (n + 2 * k)) by omega. apply mod2_S_eq; auto. Qed. Lemma mod2sub: forall a b, b <= a -> mod2 (a - b) = xorb (mod2 a) (mod2 b). Proof. intros. remember (a - b) as c. revert dependent b. revert a. revert c. change (forall c, (fun c => forall a b, b <= a -> c = a - b -> mod2 c = xorb (mod2 a) (mod2 b)) c). apply strong. intros c IH a b AB N. destruct c. - assert (a=b) by omega. subst. rewrite Bool.xorb_nilpotent. reflexivity. - destruct c. + assert (a = S b) by omega. subst a. simpl (mod2 1). rewrite mod2_S_not. destruct (mod2 b); reflexivity. + destruct a; [omega|]. destruct a; [omega|]. simpl. apply IH; omega. Qed. Theorem mod2_pow2_twice: forall n, mod2 (Nat.pow 2 n + (Nat.pow 2 n + 0)) = false. Proof. intros. replace (Nat.pow 2 n + (Nat.pow 2 n + 0)) with (2 * Nat.pow 2 n) by omega. apply mod2_double. Qed. Theorem div2_plus_2 : forall n k, Nat.div2 (n + 2 * k) = Nat.div2 n + k. Proof. induction n; intros. simpl. rewrite Nat.add_0_r. replace (k + k) with (2 * k) by omega. apply div2_double. replace (S n + 2 * k) with (S (n + 2 * k)) by omega. destruct (Even.even_or_odd n). - rewrite <- even_div2. rewrite <- even_div2 by auto. apply IHn. apply Even.even_even_plus; auto. apply Even.even_mult_l; repeat constructor. - rewrite <- odd_div2. rewrite <- odd_div2 by auto. rewrite IHn. omega. apply Even.odd_plus_l; auto. apply Even.even_mult_l; repeat constructor. Qed. Lemma pred_add: forall n, n <> 0 -> pred n + 1 = n. Proof. intros; rewrite pred_of_minus; omega. Qed. Lemma pow2_zero: forall sz, (Nat.pow 2 sz > 0)%nat. Proof. induction sz; simpl; auto; omega. Qed. Section omega_compat. Ltac omega ::= lia. Theorem Npow2_nat : forall n, nat_of_N (Npow2 n) = Nat.pow 2 n. induction n as [|n IHn]; simpl; intuition. rewrite <- IHn; clear IHn. case_eq (Npow2 n); intuition. Qed. End omega_compat. Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus N_of_nat_of_N nat_of_N_of_nat nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N. Theorem nat_of_N_eq : forall n m, nat_of_N n = nat_of_N m -> n = m. intros ? ? H; apply (f_equal N_of_nat) in H; autorewrite with N in *; assumption. Qed. Theorem pow2_N : forall n, Npow2 n = N.of_nat (Nat.pow 2 n). Proof. intro n. apply nat_of_N_eq. rewrite Nat2N.id. apply Npow2_nat. Qed. Lemma Z_of_N_Npow2: forall n, Z.of_N (Npow2 n) = (2 ^ Z.of_nat n)%Z. Proof. intros. rewrite pow2_N. rewrite nat_N_Z. rewrite Zpow_of_nat. reflexivity. Qed. Lemma pow2_S_z: forall n, Z.of_nat (Nat.pow 2 (S n)) = (2 * Z.of_nat (Nat.pow 2 n))%Z. Proof. intros. replace (2 * Z.of_nat (Nat.pow 2 n))%Z with (Z.of_nat (Nat.pow 2 n) + Z.of_nat (Nat.pow 2 n))%Z by omega. simpl. repeat rewrite Nat2Z.inj_add. lia. Qed. Lemma pow2_le: forall n m, (n <= m)%nat -> (Nat.pow 2 n <= Nat.pow 2 m)%nat. Proof. intros. assert (exists s, n + s = m) by (exists (m - n); omega). destruct H0; subst. rewrite pow2_add_mul. pose proof (pow2_zero x). replace (Nat.pow 2 n) with (Nat.pow 2 n * 1) at 1 by omega. apply mult_le_compat_l. omega. Qed. Lemma Zabs_of_nat: forall n, Z.abs (Z.of_nat n) = Z.of_nat n. Proof. unfold Z.of_nat; intros. destruct n; auto. Qed. Lemma Npow2_not_zero: forall n, Npow2 n <> 0%N. Proof. induction n; simpl; intros; [discriminate|]. destruct (Npow2 n); auto. discriminate. Qed. Lemma Npow2_S: forall n, Npow2 (S n) = (Npow2 n + Npow2 n)%N. Proof. simpl; intros. destruct (Npow2 n); auto. rewrite <-Pos.add_diag. reflexivity. Qed. Lemma Npow2_pos: forall a, (0 < Npow2 a)%N. Proof. intros. destruct (Npow2 a) eqn: E. - exfalso. apply (Npow2_not_zero a). assumption. - constructor. Qed. Lemma minus_minus: forall a b c, c <= b <= a -> a - (b - c) = a - b + c. Proof. intros. omega. Qed. Lemma even_odd_destruct: forall n, (exists a, n = 2 * a) \/ (exists a, n = 2 * a + 1). Proof. induction n. - left. exists 0. reflexivity. - destruct IHn as [[a E] | [a E]]. + right. exists a. omega. + left. exists (S a). omega. Qed. Lemma mul_div_undo: forall i c, c <> 0 -> c * i / c = i. Proof. intros. pose proof (Nat.div_mul_cancel_l i 1 c) as P. rewrite Nat.div_1_r in P. rewrite Nat.mul_1_r in P. apply P; auto. Qed. Lemma mod_add_r: forall a b, b <> 0 -> (a + b) mod b = a mod b. Proof. intros. rewrite <- Nat.add_mod_idemp_r by omega. rewrite Nat.mod_same by omega. rewrite Nat.add_0_r. reflexivity. Qed. Lemma mod2_cases: forall (n: nat), n mod 2 = 0 \/ n mod 2 = 1. Proof. intros. assert (n mod 2 < 2). { apply Nat.mod_upper_bound. congruence. } omega. Qed. Lemma div_mul_undo: forall a b, b <> 0 -> a mod b = 0 -> a / b * b = a. Proof. intros. pose proof Nat.div_mul_cancel_l as A. specialize (A a 1 b). replace (b * 1) with b in A by omega. rewrite Nat.div_1_r in A. rewrite mult_comm. rewrite <- Nat.divide_div_mul_exact; try assumption. - apply A; congruence. - apply Nat.mod_divide; assumption. Qed. Lemma Smod2_1: forall k, S k mod 2 = 1 -> k mod 2 = 0. Proof. intros k C. change (S k) with (1 + k) in C. rewrite Nat.add_mod in C by congruence. pose proof (Nat.mod_upper_bound k 2). assert (k mod 2 = 0 \/ k mod 2 = 1) as E by omega. destruct E as [E | E]; [assumption|]. rewrite E in C. simpl in C. discriminate. Qed. Lemma mod_0_r: forall (m: nat), m mod 0 = 0. Proof. intros. reflexivity. Qed. Lemma sub_mod_0: forall (a b m: nat), a mod m = 0 -> b mod m = 0 -> (a - b) mod m = 0. Proof. intros. assert (m = 0 \/ m <> 0) as C by omega. destruct C as [C | C]. - subst. apply mod_0_r. - assert (a - b = 0 \/ b < a) as D by omega. destruct D as [D | D]. + rewrite D. apply Nat.mod_0_l. assumption. + apply Nat2Z.inj. simpl. rewrite Zdiv.mod_Zmod by assumption. rewrite Nat2Z.inj_sub by omega. rewrite Zdiv.Zminus_mod. rewrite <-! Zdiv.mod_Zmod by assumption. rewrite H. rewrite H0. apply Z.mod_0_l. omega. Qed. Lemma mul_div_exact: forall (a b: nat), b <> 0 -> a mod b = 0 -> b * (a / b) = a. Proof. intros. edestruct Nat.div_exact as [_ P]; [eassumption|]. specialize (P H0). symmetry. exact P. Qed. Lemma Z_add_sub_distr : forall a b c, ((a - (b + c)) = a - b - c)%Z. Proof. intros. lia. Qed. Lemma Zpow_successor : forall x (y : nat), (0 <= x < 2 ^ (Z.of_nat y))%Z -> (0 <= x < 2 ^ Z.of_nat(y + 1))%Z. Proof. intros. inversion H. split. * auto. * rewrite Nat2Z.inj_add. rewrite Z.add_comm. apply Zpow_lt_add. lia. lia. lia. Qed. Lemma Zpow_successor_itself : forall (y : nat), (0 <= 2 ^ (Z.of_nat y) < 2 ^ Z.of_nat(y + 1))%Z. Proof. intros. split. * rewrite (Z.pow_nonneg 2 (Z.of_nat y)). lia. lia. * apply Z.pow_lt_mono_r. lia. lia. lia. Qed. Lemma pow2_gt_1 n : (n > 0)%nat -> (2 ^ n > 1)%nat. Proof. induction n. + lia. + intros ?. apply one_lt_pow2. Qed. Lemma nat_mul_cancel_l : forall a b c, c <> 0 -> c * a = c * b -> a = b. Proof. induction a; intros. - rewrite <- mult_n_O in H0. apply eq_sym, mult_is_O in H0. destruct H0; subst; tauto. - induction b. + exfalso; rewrite <- mult_n_O in H0. destruct (mult_is_O _ _ H0); lia. + repeat rewrite Nat.mul_succ_r in H0. rewrite Nat.add_cancel_r in H0. rewrite (IHa _ _ H H0); reflexivity. Qed. Lemma Zdiv_div (n m : Z) : (0 < m)%Z -> (0 <= n)%Z -> Z.to_nat (n / m) = (Z.to_nat n /Z.to_nat m). Proof. intros. rewrite <- (Z2Nat.id n) at 1; auto. rewrite <- (Z2Nat.id m) at 1; [|lia]. rewrite <- div_Zdiv. - rewrite Nat2Z.id; reflexivity. - rewrite <- Z2Nat.inj_0; intro. rewrite Z2Nat.inj_iff in H1; subst; lia. Qed. Lemma Zmod_mod' (n m : Z) : (0 < m)%Z -> (0 <= n)%Z -> (Z.to_nat (n mod m) = (Z.to_nat n) mod (Z.to_nat m)). Proof. intros. rewrite <- (Z2Nat.id n) at 1; auto. rewrite <- (Z2Nat.id m) at 1; [|lia]. rewrite <- mod_Zmod. - rewrite Nat2Z.id; reflexivity. - rewrite <- Z2Nat.inj_0; intro. rewrite Z2Nat.inj_iff in H1; subst; lia. Qed. Lemma pow_divide : forall sz1 sz2, (2 ^ Z.of_nat sz1 | 2 ^ Z.of_nat (sz1 + sz2))%Z /\ (2 ^ Z.of_nat sz2 | 2 ^ Z.of_nat (sz1 + sz2))%Z. Proof. split; erewrite Nat2Z.inj_add, Z.pow_add_r; try apply Nat2Z.is_nonneg; eexists; [rewrite Z.mul_comm|]; reflexivity. Qed. Lemma diag : forall n, n - n = 0. Proof. intros. lia. Qed. Lemma Natlt_0 : forall n, n <= 0 <-> n = 0. Proof. induction n; intros; try lia. Qed. Lemma equal_expWidth_sigWidth: forall s, 2^s + 4 > s + 2. Proof. induction s; simpl; auto. rewrite Nat.add_0_r. pose proof (pow2_zero s). Omega.omega. Qed. Lemma one_lt_pow2' : forall n, n > 0 -> 1 < 2 ^ n. Proof. intros; specialize (pow2_gt_1 H); auto. Qed. Lemma lt_minus' : forall a b c : nat, b <= a -> b < c -> a < c -> a - b < c. Proof. intros. lia. Qed. Lemma if_same A (x: A) (p: bool): (if p then x else x) = x. Proof. destruct p; auto. Qed. Lemma mod_factor a b c: b <> 0 -> c <> 0 -> (a mod (b * c)) mod b = a mod b. Proof. intros. pose proof (Nat.mod_mul_r a _ _ H H0). rewrite H1. rewrite Nat.add_mod_idemp_l by auto. rewrite Nat.add_mod by auto. assert (sth: b * ((a/b) mod c) = (a/b) mod c * b) by (apply Nat.mul_comm). rewrite sth. rewrite Nat.mod_mul by auto. rewrite Nat.add_0_r. rewrite Nat.mod_mod by auto. auto. Qed. Lemma mod_factor' a b c d: b <> 0 -> c <> 0 -> d = b * c -> (a mod d) mod b = a mod b. Proof. pose proof (@mod_factor a b c). intros. subst. eapply H; eauto. Qed. Lemma if_bool_2 A (x y: A) (p1 p2: bool): p1 = p2 -> (if p1 then x else y) = (if p2 then x else y). Proof. intros sth. rewrite sth. auto. Qed. Lemma mod_cancel_l: forall a b x n, n <> 0 -> a mod n = b mod n -> (x + a) mod n = (x + b) mod n. Proof. intros. rewrite <- Nat.add_mod_idemp_r; auto. rewrite H0. rewrite Nat.add_mod_idemp_r; auto. Qed. Lemma pow2_1_iff_0 n: 2 ^ n = 1 <-> n = 0. Proof. induction n; split; intro; try lia. simpl. reflexivity. destruct IHn. pose proof (one_lt_pow2 n) as sth1. rewrite H in sth1. apply False_ind. inversion sth1. inversion H3. Qed. Lemma pow2_lt_S n: n > 0 -> 2 ^ n + 1 < 2 ^ (n + 1). Proof. pose proof (pow2_le_S n) as sth. apply Nat.lt_eq_cases in sth. destruct sth; auto. intro sth. apply False_ind. apply Nat.add_sub_eq_l in H. pose proof (pow2_1_iff_0 n) as sth1. replace (2 ^ n) with (2 ^ n * 1) in H by lia. rewrite pow2_add_mul in H. rewrite <- Nat.mul_sub_distr_l in H. simpl in H. destruct sth1 as [sth2 sth3]. rewrite sth2 in sth; lia. Qed. Lemma pow2_lt_2 n: 1 < n -> 2 < 2 ^ n. Proof. intro sth. induction n. inversion sth. simpl. assert (sth1: n = 1 \/ n > 1) by lia. destruct sth1. rewrite H. simpl. auto. simpl. apply Nat.lt_lt_add_l. rewrite Nat.add_0_r. lia. Qed. Lemma pow2_lt_pow2_S n : 2 ^ n < 2 ^ (n + 1). Proof. rewrite Nat.add_1_r. simpl. assert (0 < 2 ^ n) by apply zero_lt_pow2. lia. Qed. Lemma Natlog2_up_pow2 : forall a, Nat.log2_up (2 ^ a) = a. Proof. intros; apply Nat.log2_up_pow2; lia. Qed. Lemma log2_of_nat n : Z.log2 (Z.of_nat n) = Z.of_nat (Nat.log2 n). Proof. induction n; auto. destruct (Nat.log2_spec_alt (S n) (ltac:(lia))) as [m [P0 P1]]. apply (Z.log2_unique' (Z.of_nat (S n)) (Z.of_nat (Nat.log2 (S n))) (Z.of_nat m)). - apply Zle_0_nat. - destruct P1; split; [apply Zle_0_nat|]. rewrite <- Zpow_of_nat. apply (inj_lt _ _ H0). - rewrite <- Zpow_of_nat, <- Nat2Z.inj_add. apply (inj_eq _ _ P0). Qed. Lemma Log2_up_of_nat n : Z.of_nat (Nat.log2_up n) = Z.log2_up (Z.of_nat n). Proof. induction n. - unfold Z.log2_up; simpl; reflexivity. - unfold Nat.log2_up, Z.log2_up. destruct Nat.compare eqn:G, Z.compare eqn:G0; auto. + exfalso. apply Nat.compare_eq in G. rewrite Z.compare_lt_iff in G0. apply inj_eq in G; lia. + exfalso. rewrite Nat.compare_lt_iff in G. apply Z.compare_eq in G0. rewrite <- (Z2Nat.id 1%Z) in G0; lia. + repeat rewrite Nat2Z.inj_succ. rewrite Nat.pred_succ, Z.pred_succ, log2_of_nat; reflexivity. + exfalso. rewrite Nat.compare_lt_iff in G. rewrite Z.compare_gt_iff in G0. apply inj_lt in G. lia. + exfalso. rewrite Nat.compare_gt_iff in G. rewrite Z.compare_lt_iff in G0. apply inj_lt in G. lia. Qed. Lemma firstn_nil_iff {A : Type} n (l : list A) : firstn n l = [] <-> n = 0 \/ l = nil. Proof. red; split; intros. - destruct n; destruct l; auto. exfalso. inv H. - destruct H; subst; auto. destruct n; auto. Qed. Lemma rotateLength {A : Type} n : forall (l : list A), length (rotateList n l) = length l. Proof. induction n; auto; intros. simpl; rewrite IHn. destruct l; auto. rewrite snoc_rapp, app_length; simpl; lia. Qed. Lemma hd_firstn {A : Type} (l : list A): forall n, n <> 0 -> hd_error (firstn n l) = hd_error l. Proof. induction l; intros. - rewrite firstn_nil; reflexivity. - simpl; destruct n; simpl; auto. exfalso; apply H; reflexivity. Qed. Lemma hdRotateList {A : Type} n: forall (l : list A), n < length l -> hd_error (rotateList n l) = nth_error l n. Proof. induction n; intros; destruct l; auto. - exfalso; simpl in H; lia. - simpl; rewrite IHn, snoc_rapp. + rewrite nth_error_app1; auto. apply lt_S_n; assumption. + rewrite snoc_rapp, app_length; simpl in *; lia. Qed. Lemma firstn_app' {A : Type} (l1 : list A): forall n l2, n <= length l1 -> firstn n (l1 ++ l2) = firstn n l1. Proof. induction l1; intros. - rewrite firstn_nil. simpl in H. assert (n = 0) by lia; rewrite H0, firstn_O; reflexivity. - destruct n; simpl; auto. rewrite IHl1; auto. simpl in H; lia. Qed. Lemma tail_cut_rotate {A : Type} : forall (l : list A), firstn ((length l) - 1) (rotateList 1 l) = tl l. Proof. destruct l; simpl; auto. rewrite Nat.sub_0_r, snoc_rapp, firstn_app'; try lia. induction l; simpl; auto. rewrite IHl; reflexivity. Qed. Lemma rotateList_nil {A : Type} n: @rotateList A n [] = []. Proof. induction n; simpl; auto. Qed. Lemma rotateList_add {A : Type} m: forall (l : list A) n, rotateList (n + m) l = rotateList n (rotateList m l). Proof. induction m; auto; intros. - rewrite Nat.add_0_r; reflexivity. - rewrite <- plus_n_Sm; simpl. rewrite IHm; reflexivity. Qed. Lemma cutList_rotList_1 {A : Type} (l : list A) : forall n, n <= length l -> firstn n (rotateList 1 (firstn (S n) l)) = firstn n (rotateList 1 l). Proof. destruct l; intros. - repeat rewrite firstn_nil; reflexivity. - simpl; repeat rewrite snoc_rapp. destruct (le_lt_or_eq _ _ H). + simpl in H0. apply lt_n_Sm_le in H0. repeat rewrite firstn_app'; auto. * rewrite firstn_all2; auto. apply firstn_le_length. * rewrite firstn_length_le; auto. + repeat rewrite firstn_all2; auto; try rewrite app_length; simpl in *; lia. Qed. Lemma nth_error_nil_None' : forall {A : Type} (n : nat), nth_error (nil : list A) n = None. Proof. intros; rewrite nth_error_None; simpl; lia. Qed. Lemma snoc_cutList {A : Type} (l : list A) : forall n a, nth_error l n = Some a -> firstn (n + 1) l = snoc a (firstn n l). Proof. induction l; simpl; intros. - exfalso. rewrite nth_error_nil_None' in H; discriminate. - destruct n; simpl in *. + inv H; reflexivity. + erewrite IHl; auto. Qed. Lemma nth_error_rotate {A : Type} m : forall n (l : list A), (m + n) < length l -> nth_error (rotateList n l) m = nth_error l (m + n). Proof. induction n; intros. - rewrite Nat.add_0_r; auto. - destruct l. + rewrite rotateList_nil. repeat rewrite nth_error_nil_None'; reflexivity. + cbn [rotateList]. rewrite IHn. * rewrite <- plus_n_Sm, snoc_rapp, nth_error_app1; auto. simpl in *; lia. * rewrite snoc_rapp, app_length; simpl in *; lia. Qed. Lemma nth_error_rotate' {A : Type} m : forall n (l : list A), m < length l -> nth_error (rotateList n l) m = nth_error l ((m + n) mod (length l)). Proof. induction n; intros. - rewrite Nat.add_0_r, Nat.mod_small; auto. - destruct l. + rewrite rotateList_nil. repeat rewrite nth_error_nil_None'; reflexivity. + cbn [rotateList]. rewrite IHn. * rewrite <- plus_n_Sm, snoc_rapp. destruct (Nat.eq_dec (S (m + n) mod Datatypes.length (a :: l)) 0). -- rewrite e. rewrite Nat.mod_divide in e; [|simpl; auto]. destruct e. assert (m + n = x * S (length l) - 1) as P0. { simpl in H0; lia. } assert (forall n m, 0 < n -> (n * S m - 1) mod S m = m) as P1. { clear. induction n; intros; try lia. rewrite Nat.mul_succ_l. destruct (zerop n). - subst; rewrite Nat.mul_0_l, Nat.add_0_l, Nat.mod_small; lia. - rewrite Nat.add_comm, <- Nat.add_sub_assoc, Nat.add_comm, mod_add_r; try lia. apply IHn; assumption. } rewrite P0, app_length, Nat.add_1_r, nth_error_app2. ++ rewrite P1, Nat.sub_diag; simpl; auto. destruct (zerop x); auto. exfalso; subst; lia. ++ rewrite P1; auto. destruct (zerop x); auto. exfalso; subst; lia. -- specialize (Nat.mod_upper_bound (m + n) (S (length l)) ltac:(lia)) as P0. apply lt_n_Sm_le in P0. destruct (le_lt_or_eq _ _ P0) as [P1 | P1]. ++ rewrite app_length, Nat.add_1_r, nth_error_app1; auto. rewrite <- (Nat.add_1_l (m + n)), <- (Nat.add_mod_idemp_r 1 _); [|simpl; lia]. rewrite (Nat.mod_small (1 + _)), (Nat.add_1_l ((m + n) mod _)); [simpl; auto|]. cbn [length]; lia. ++ exfalso. apply n0; cbn[length]. rewrite <- Nat.add_1_l, <- Nat.add_mod_idemp_r, P1, Nat.add_1_l, Nat.mod_same; auto. * rewrite snoc_rapp, app_length; simpl in *; lia. Qed. Lemma nth_error_eq {A : Type} : forall (l1 l2 : list A), (forall m, nth_error l1 m = nth_error l2 m) -> l1 = l2. Proof. induction l1; intros. - destruct l2; auto. exfalso. specialize (H 0); simpl in *; discriminate. - destruct l2. + exfalso. specialize (H 0); simpl in *; discriminate. + specialize (H 0) as P0; inv P0. erewrite IHl1; auto. intros; specialize (H (S m)); simpl in *; assumption. Qed. Lemma nth_error_eq_iff {A : Type} : forall (l1 l2 : list A), (forall m, nth_error l1 m = nth_error l2 m) <-> l1 = l2. Proof. red; split; intros; subst; eauto using nth_error_eq. Qed. Lemma nth_error_cutList {A : Type} m: forall n (l : list A), n < m -> nth_error (firstn m l) n = nth_error l n. Proof. induction m; intros; try lia. destruct l, n; simpl; auto. apply IHm; lia. Qed. Lemma Fineqb_refl {m} (n : t m) : Fin.eqb n n = true. Proof. rewrite Fin.eqb_eq; reflexivity. Qed. Lemma Nat_mod_congr a b c : c <> 0 -> a < b -> a mod c = b mod c -> Nat.divide c (b - a). Proof. intros. repeat (rewrite Nat.mod_eq in H1; auto). exists (b / c - a / c). rewrite Nat.mul_sub_distr_r, Nat.mul_comm. rewrite (Nat.mul_comm _ c). rewrite <- (Nat.add_cancel_r _ _ (c * (b / c))), (Nat.add_comm (b - _) (c * (b / c))), le_plus_minus_r in H1. - rewrite <- H1 at 1. rewrite <- (Nat.add_cancel_r _ _ a), Nat.sub_add; try lia. assert (c * (a / c) <= c * (b / c)). { apply Nat.mul_le_mono_l. apply Nat.div_le_mono; lia. } assert (c * (a / c) <= a). { apply Nat.mul_div_le; assumption. } lia. - apply Nat.mul_div_le; assumption. Qed. Lemma seq_nth_error_Some size m n : n < size <-> nth_error (seq m size) n = Some (m + n). Proof. red; split. - induction size; intros; [lia|]. apply lt_n_Sm_le in H. rewrite seq_eq. destruct (le_lt_or_eq _ _ H). + rewrite nth_error_app1; auto. rewrite seq_length; assumption. + rewrite nth_error_app2; subst. * rewrite seq_length, diag. reflexivity. * rewrite seq_length; assumption. - intros. assert (nth_error (seq m size) n <> None) as P. { intro P; rewrite P in H; discriminate. } rewrite nth_error_Some, seq_length in P. assumption. Qed. Lemma seq_nth_error_None size m n : size <= n <-> nth_error (seq m size) n = None. Proof. rewrite nth_error_None, seq_length; reflexivity. Qed. Lemma Zlor_bounds sz m n : (0 <= m < 2 ^ sz -> 0 <= n < 2 ^ sz -> 0 <= Z.lor m n < 2 ^ sz)%Z. Proof. intros; split; dest. - rewrite Z.lor_nonneg; auto. - destruct (Zle_lt_or_eq _ _ H), (Zle_lt_or_eq _ _ H0). + rewrite Z.log2_lt_pow2 in *; auto. * rewrite Z.log2_lor; auto. apply Z.max_lub_lt; auto. * specialize ((proj2 (Z.lor_nonneg m n)) (conj H H0)) as P. destruct (Zle_lt_or_eq _ _ P); auto. exfalso. symmetry in H5. rewrite Z.lor_eq_0_iff in H5; lia. + rewrite <- H4, Z.lor_0_r; assumption. + rewrite <- H3, Z.lor_0_l; assumption. + rewrite <- H3, Z.lor_0_l; assumption. Qed. Lemma list_arr_length {A : Type} n : forall (arr : t n -> A), n = length (list_arr arr). Proof. unfold list_arr; intros. rewrite map_length, getFins_length; reflexivity. Qed. Lemma firstn_map {A B: Type} (l : list A) (f : A -> B): forall n, firstn n (map f l) = map f (firstn n l). Proof. induction l; intros. - repeat rewrite firstn_nil; reflexivity. - destruct n; simpl; auto. rewrite IHl; reflexivity. Qed. Lemma skipn_map {A B: Type} (l : list A) (f : A -> B): forall n, skipn n (map f l) = map f (skipn n l). Proof. induction l; intros. - repeat rewrite skipn_nil; reflexivity. - destruct n; simpl; auto. Qed. Lemma firstn_seq_le n : forall m size, n <= size -> firstn n (seq m size) = seq m n. Proof. induction n; intros. - rewrite firstn_O; reflexivity. - destruct size;[lia|]. simpl; rewrite IHn; auto; lia. Qed. Lemma skipn_seq_le n : forall m size, n <= size -> skipn n (seq m size) = seq (m + n) (size - n). Proof. induction n; intros. - rewrite Nat.add_0_r, Nat.sub_0_r; reflexivity. - destruct size;[lia|]. simpl; rewrite IHn; try lia. rewrite Nat.add_succ_comm; reflexivity. Qed. Corollary firstn_seq_le2 n : forall m size, size <= n -> firstn n (seq m size) = seq m size. Proof. intros; rewrite firstn_all2; auto. rewrite seq_length; assumption. Qed. Corollary skipn_seq_le2 n : forall m size, size <= n -> skipn n (seq m size) = nil. Proof. intros; rewrite skipn_all2; auto. rewrite seq_length; assumption. Qed. Lemma tl_map {A B : Type} (l : list A) (f : A -> B) : tl (map f l) = map f (tl l). Proof. destruct l; auto. Qed. Lemma tl_seq n: forall m, tl (seq m n) = (seq (S m) (n - 1)). Proof. destruct n; intros; auto. simpl; rewrite Nat.sub_0_r; reflexivity. Qed. Lemma seq_extract1 n: n <> 0 -> forall m, seq m n = m :: seq (S m) (n - 1). Proof. destruct n; intros. - contradiction. - simpl; rewrite Nat.sub_0_r; reflexivity. Qed. Lemma Z_mod_congr (a b c : Z): (0 < c)%Z -> (a mod c = b mod c)%Z -> Z.divide c (b - a). Proof. intros. do 2 (rewrite Z.mod_eq in H0; auto); try lia. exists (b / c - a / c)%Z. lia. Qed. Lemma rotateList_periodic {A : Type} n: forall (l : list A), rotateList n l = rotateList (n mod (length l)) l. Proof. intros. rewrite <-nth_error_eq_iff; intros. destruct (le_lt_dec (length l) m). - repeat rewrite (proj2 (nth_error_None _ _)); auto; rewrite rotateLength; assumption. - rewrite (nth_error_rotate' n l l0), (nth_error_rotate' (n mod (length l)) l l0), Nat.add_mod_idemp_r; auto; lia. Qed. Lemma emptyb_true {A : Type} (l : list A) : emptyb l = true <-> l = nil. Proof. red; split; destruct l; intros; auto; discriminate. Qed. Lemma emptyb_false {A : Type} (l : list A) : emptyb l = false <-> exists x, In x l. Proof. red; split; destruct l; intros; auto; try discriminate. - exists a; left; reflexivity. - dest; inv H. Qed. Lemma emptyb_true_len {A : Type} (l : list A) : emptyb l = true <-> length l = 0. Proof. rewrite length_zero_iff_nil; apply emptyb_true. Qed. Lemma emptyb_false_len {A : Type} (l : list A) : emptyb l = false <-> 0 < length l. Proof. rewrite emptyb_false; red; split; intros; dest. - destruct l; [inv H| simpl; lia]. - destruct l; [simpl in H; lia| exists a; left; reflexivity]. Qed. Lemma hd_error_Some {A : Type} (l : list A) (a : A) : hd_error l = Some a <-> l = a :: tl l. Proof. red; split; intros. - destruct l; inv H; reflexivity. - rewrite H; reflexivity. Qed. Lemma hd_error_None {A : Type} (l : list A) : hd_error l = None <-> l = nil. Proof. red; split; intros. - destruct l; auto; discriminate. - destruct l; auto; discriminate. Qed. Lemma Fin_eqb_neq {n : nat} (p q : Fin.t n): Fin.eqb p q = false <-> p <> q. Proof. red; split; repeat intro. - rewrite <- Fin.eqb_eq in H0; rewrite H0 in H; discriminate. - destruct Fin.eqb eqn:G; auto. exfalso. rewrite Fin.eqb_eq in G; contradiction. Qed. Section FifoProps. Variable size : nat. Local Notation lgSize := (Nat.log2_up size). Variable A : Type. Variable implArray : Fin.t size -> A. Variable enqP1 deqP1 : Z. Variable enqP1Bnd : (0 <= enqP1 < 2 ^ Z.of_nat (lgSize + 1))%Z. Variable deqP1Bnd : (0 <= deqP1 < 2 ^ Z.of_nat (lgSize + 1))%Z. Local Notation enq := (enqP1 mod (2 ^ (Z.of_nat lgSize)))%Z. Local Notation deq := (deqP1 mod (2 ^ (Z.of_nat lgSize)))%Z. Local Notation cutLen := ((enqP1 - deqP1) mod (2 ^ (Z.of_nat (lgSize + 1))))%Z. Definition convertToList {n} (kamiArray : Fin.t n -> A) := @list_arr A n kamiArray. Local Notation specList := (firstn (Z.to_nat cutLen) (rotateList (Z.to_nat deq) (convertToList implArray))). Variable inBounds : (cutLen <= Z.of_nat size)%Z. Variable sizePow2 : Nat.pow 2 lgSize = size. Lemma cutLen_0_iff : cutLen = 0%Z <-> enqP1 = deqP1. Proof. red; split; intro. - apply Znumtheory.Zmod_divide_minus in H; try lia. rewrite Z.sub_0_r in H; unfold Z.divide in H; destruct H as [x P]. rewrite <- Zpow_of_nat, Nat.pow_add_r, sizePow2, Nat2Z.inj_mul in *; simpl in *. destruct (Z_dec 0 x) as [[P0 | P0] | P0]; try lia. * apply Zlt_le_succ in P0; simpl in P0; try lia. apply (Z.mul_le_mono_nonneg_r _ _ (Z.of_nat size * 2)) in P0; lia. * apply Z.gt_lt in P0. rewrite Z.lt_le_pred in P0; simpl in P0. apply (Z.mul_le_mono_nonneg_r _ _ (Z.of_nat size * 2)) in P0; lia. - rewrite H, Z.sub_diag, Zmod_0_l; reflexivity. Qed. Lemma sizeNeq0 : size <> 0. Proof. intro P; rewrite P in *. simpl in sizePow2; discriminate. Qed. Lemma deq_lt_size : ((Z.to_nat deq) < size). Proof. specialize sizeNeq0 as P. apply inj_eq in sizePow2. rewrite Zpow_of_nat in sizePow2. rewrite sizePow2, Zmod_mod', Nat2Z.id; try lia. apply Nat.mod_upper_bound; assumption. Qed. Lemma enq_lt_size : ((Z.to_nat enq) < size). Proof. specialize sizeNeq0 as P. apply inj_eq in sizePow2. rewrite Zpow_of_nat in sizePow2. rewrite sizePow2, Zmod_mod', Nat2Z.id; try lia. apply Nat.mod_upper_bound; assumption. Qed. Lemma hdCorrect : enqP1 <> deqP1 -> hd_error specList = Some (implArray (Fin.of_nat_lt deq_lt_size)). Proof. intros. rewrite hd_firstn. - rewrite hdRotateList. + unfold convertToList. rewrite <- list_arr_correct_simple, to_nat_of_nat; reflexivity. + unfold convertToList, list_arr. rewrite map_length, getFins_length. apply deq_lt_size. - intro P; apply H. rewrite <- cutLen_0_iff. assert (0 = Z.to_nat 0) as TMP by lia; rewrite TMP in P at 2; clear TMP. apply Z2Nat.inj in P; try lia. apply Z.mod_pos_bound; lia. Qed. Lemma hdEmpty : enqP1 = deqP1 -> hd_error specList = None. Proof. intros. rewrite H, Z.sub_diag, firstn_O; reflexivity. Qed. Lemma tailCorrect : tl specList = firstn (Z.to_nat ((enqP1 - deqP1) mod 2 ^ Z.of_nat (lgSize + 1)) - 1) (rotateList (Z.to_nat (deq + 1)) (convertToList implArray)). Proof. destruct (Z.eq_dec enqP1 deqP1). - rewrite e, Z.sub_diag, Zmod_0_l; simpl; reflexivity. - unfold convertToList. rewrite <- tail_cut_rotate, firstn_length_le; [|rewrite rotateLength, <- list_arr_length]; try lia. assert ((Z.to_nat ((enqP1 - deqP1) mod 2 ^ Z.of_nat (lgSize + 1))) = S (Z.to_nat ((enqP1 - deqP1) mod 2 ^ Z.of_nat (lgSize + 1)) - 1)) as TMP. { rewrite <- (Nat.add_1_r (Z.to_nat _ - _)), Nat.sub_add; auto. specialize (Nat.le_0_l (Z.to_nat ((enqP1 - deqP1) mod 2 ^ Z.of_nat (lgSize + 1)))) as P. destruct (le_lt_or_eq _ _ P); try lia. exfalso. apply n; rewrite <-cutLen_0_iff. assert (0 = Z.to_nat 0) as TMP by lia; rewrite TMP in H at 1; clear TMP. apply Z2Nat.inj in H; try lia. apply Z.mod_pos_bound; lia. } rewrite TMP at 2; clear TMP. rewrite cutList_rotList_1, Z2Nat.inj_add, (Nat.add_comm (Z.to_nat deq)), rotateList_add; try lia; auto. + specialize sizeNeq0 as P. apply Z.mod_pos_bound. rewrite <- Zpow_of_nat, sizePow2; lia. + rewrite rotateLength, <- list_arr_length; lia. Qed. Lemma cutLen_succ : cutLen <> Z.of_nat size -> ((enqP1 + 1 - deqP1) mod 2 ^ Z.of_nat (lgSize + 1) = cutLen + 1)%Z. Proof. intros. assert (cutLen < Z.of_nat size)%Z as P by lia. specialize sizeNeq0 as P0. destruct (Z_lt_le_dec (Z.of_nat size) 1); try lia. assert (0 <= (enqP1 - deqP1) mod 2 ^ Z.of_nat (lgSize + 1) + 1 < 2 ^ Z.of_nat (lgSize + 1))%Z as P1. { specialize (Z.mod_pos_bound (enqP1 - deqP1) (2 ^ Z.of_nat (lgSize + 1)) ltac:(lia)) as P1. split; try lia. destruct P1. rewrite Nat2Z.inj_add, Z.pow_add_r, Z.pow_1_r, <- Zpow_of_nat, sizePow2 in *; try lia. } rewrite <- (Z.mod_small _ _ P1), Zplus_mod_idemp_l. f_equal; lia. Qed. Lemma cutLen_pred : enqP1 <> deqP1 -> ((enqP1 - (deqP1 + 1)) mod 2 ^ Z.of_nat (lgSize + 1) = cutLen - 1)%Z. Proof. intros. rewrite Z.sub_add_distr. assert (0 <= (enqP1 - deqP1) mod 2 ^ Z.of_nat (lgSize + 1) - 1 < 2 ^ Z.of_nat (lgSize + 1))%Z as P. { destruct (Z.eq_dec cutLen 0). - exfalso; rewrite cutLen_0_iff in e; contradiction. - specialize (Z.mod_pos_bound (enqP1 - deqP1) (2 ^ Z.of_nat (lgSize + 1)) ltac:(lia)) as P. destruct P; split; lia. } rewrite <- (Z.mod_small _ _ P), Zminus_mod_idemp_l; reflexivity. Qed. Lemma listSnoc (val : A) : cutLen <> Z.of_nat size -> snoc val specList = firstn (Z.to_nat ((enqP1 + 1 - deqP1) mod 2 ^ Z.of_nat (lgSize + 1))) (rotateList (Z.to_nat deq) (convertToList (fun i => if (Fin.eqb i (Fin.of_nat_lt enq_lt_size)) then val else implArray i))). Proof. intros HNotFull. rewrite cutLen_succ, Z2Nat.inj_add; auto; try lia; [| unfold cutLen in *; apply Z.mod_pos_bound; try lia]. erewrite snoc_cutList with (a := val). - f_equal. rewrite <- nth_error_eq_iff; intros. destruct (le_lt_dec (Z.to_nat cutLen) m). + destruct nth_error eqn:G. * exfalso. assert (nth_error specList m <> None) as G0. { intro G0; rewrite G0 in G; discriminate. } rewrite nth_error_Some, firstn_length_le in G0; [lia|]. unfold convertToList. rewrite rotateLength, <- list_arr_length; lia. * destruct (nth_error (firstn _ (rotateList (Z.to_nat deq) (convertToList (fun i => _))))) eqn: G0; auto. exfalso. assert (nth_error (firstn (Z.to_nat cutLen) (rotateList (Z.to_nat deq) (convertToList (fun i : t size => if Fin.eqb i (of_nat_lt enq_lt_size) then val else implArray i)))) m <> None) as G1. { intro G1; rewrite G1 in G0; discriminate. } rewrite nth_error_Some, firstn_length_le in G1; [lia|]. unfold convertToList. rewrite rotateLength, <- list_arr_length, <- Nat2Z.id, <- Z2Nat.inj_le; try lia. unfold cutLen. apply Z.mod_pos_bound; lia. + repeat rewrite nth_error_cutList; auto. assert (length (convertToList implArray) = size) as P. { unfold convertToList. rewrite <- list_arr_length; reflexivity. } assert (length (convertToList (fun i : t size => if Fin.eqb i (of_nat_lt enq_lt_size) then val else implArray i)) = size) as P0. { unfold convertToList. rewrite <- list_arr_length; reflexivity. } repeat rewrite nth_error_rotate'; [rewrite P0, P |rewrite P0 | rewrite P]; try lia. specialize (Nat.mod_upper_bound (m + (Z.to_nat deq)) _ sizeNeq0) as P1. assert (proj1_sig (to_nat (of_nat_lt P1)) = (m + (Z.to_nat deq)) mod size) as P2. { rewrite to_nat_of_nat; reflexivity. } rewrite <- P2. unfold convertToList. repeat rewrite list_arr_correct_simple. f_equal. destruct Fin.eqb eqn:G; auto. exfalso. rewrite Fin.eqb_eq in G. assert (proj1_sig (to_nat (of_nat_lt P1)) = proj1_sig (to_nat (of_nat_lt enq_lt_size))). { rewrite G; auto. } repeat rewrite to_nat_of_nat in H; simpl in H. rewrite <- (Nat2Z.id m), <- Z2Nat.inj_add in H; try lia; [|apply Z.mod_pos_bound; rewrite pow2_of_nat, sizePow2; lia]. rewrite <- (Nat2Z.id size) in H at 2. assert (0 <= deq)%Z as P3. { apply Z.mod_pos_bound. rewrite pow2_of_nat, sizePow2; lia. } rewrite <- Zmod_mod', pow2_of_nat, sizePow2 in H; try lia. rewrite Zplus_mod_idemp_r in H. apply Z2Nat.inj in H; try (apply Z.mod_pos_bound; lia). apply Z_mod_congr in H; try lia. destruct H as [x P4]. destruct (Z_lt_le_dec 0 x). * assert (cutLen < Z.of_nat size)%Z as P5 by lia. apply Zlt_le_succ in l0; simpl in l0. apply (Z.mul_le_mono_nonneg_r _ _ (Z.of_nat size) ltac:(lia)) in l0. rewrite <- P4 in l0. assert (Z.of_nat m + Z.of_nat size <= enqP1 - deqP1)%Z as P6 by lia. rewrite Z.mod_small in P5; lia. * destruct (Zle_lt_or_eq _ _ l0). -- clear P P0 G. assert (cutLen < Z.of_nat size)%Z as P5 by lia. rewrite Z.lt_le_pred in H; simpl in H. specialize H as H'. apply (Z.mul_le_mono_nonneg_r _ _ (Z.of_nat size) ltac:(lia)) in H. rewrite <- P4 in H. rewrite pow2_of_nat, Nat.pow_add_r, sizePow2, Nat.pow_1_r, Nat2Z.inj_mul in *. rewrite <- (Z_mod_plus_full _ 1 _), Z.mod_small in inBounds; try lia. rewrite <- (Z_mod_plus_full _ 1 _), Z.mod_small in l; try lia. rewrite <- (Z_mod_plus_full _ 1 _), Z.mod_small in P5; try lia. assert (enqP1 - deqP1 - (Z.of_nat m) < - (Z.of_nat size))%Z as P6 by lia. assert ((- 2) * Z.of_nat size < enqP1 - deqP1 - (Z.of_nat m))%Z as P7 by lia. destruct (Zle_lt_or_eq _ _ H'); try lia. rewrite Z.lt_le_pred in H0; simpl in H0. destruct (Zle_lt_or_eq _ _ H0); try lia. rewrite (Z.mul_lt_mono_pos_r (Z.of_nat size)) in H1; lia. -- rewrite H in P4. assert (enqP1 - deqP1 = Z.of_nat m)%Z as P5 by lia. rewrite P5, Z.mod_small in l; try lia. - assert (length (convertToList (fun i : t size => if Fin.eqb i (of_nat_lt enq_lt_size) then val else implArray i)) = size) as P. { unfold convertToList, list_arr. rewrite map_length, getFins_length; reflexivity. } specialize sizeNeq0 as P1. rewrite nth_error_rotate'; rewrite P; try lia. unfold convertToList. assert (proj1_sig (to_nat (of_nat_lt enq_lt_size)) = Z.to_nat enq) as P0. { rewrite to_nat_of_nat; reflexivity. } assert ((Z.to_nat cutLen + Z.to_nat deq) mod size = Z.to_nat enq) as P2. { destruct (Z_lt_le_dec (enqP1 - deqP1) 0). - rewrite <- (Z_mod_plus_full _ 1 _), Z.mod_small; try lia. assert (0 <= deq)%Z as P2. { apply Z.mod_pos_bound. rewrite pow2_of_nat, sizePow2; lia. } rewrite <- Z2Nat.inj_add; try lia. rewrite <- (Nat2Z.id size) at 3. rewrite <- Zmod_mod'; try lia. repeat rewrite pow2_of_nat. rewrite Nat.pow_add_r, Nat2Z.inj_mul, sizePow2, Z.add_mod_idemp_r, Nat.pow_1_r; try lia. assert (enqP1 - deqP1 + 1 * (Z.of_nat size * Z.of_nat 2) + deqP1 = enqP1 + (2 * Z.of_nat size))%Z as TMP by lia; rewrite TMP; clear TMP. rewrite Z_mod_plus_full; reflexivity. - rewrite Z.mod_small; try lia. rewrite Z2Nat.inj_sub; try lia. repeat rewrite pow2_of_nat. rewrite sizePow2, Zmod_mod', Nat2Z.id, Nat.add_mod_idemp_r; try lia. rewrite <- (Z2Nat.id enqP1) at 2; try lia. rewrite <- mod_Zmod, Nat2Z.id; try lia. rewrite <- Z2Nat.inj_sub, <- Z2Nat.inj_add, Z.sub_add; lia. } rewrite P2. rewrite <- P0 at 1. rewrite list_arr_correct_simple, Fineqb_refl; reflexivity. Qed. End FifoProps. Lemma app_emptyb {A : Type} (l1 l2 : list A) : emptyb (l1 ++ l2) = emptyb l1 && emptyb l2. Proof. destruct l1, l2; simpl; auto. Qed. ================================================ FILE: Lib/Fold.v ================================================ Require Import Recdef List Omega Div2. Import ListNotations. Set Implicit Arguments. Set Asymmetric Patterns. Local Ltac name_term n t H := assert (H: exists n', n' = t); try (exists t; reflexivity); destruct H as [n H]. Section UnApp. Context {A: Type}. Fixpoint unapp (n:nat)(m:list A) : list A * list A:= match n with | 0 => ([], m) | S n => match m with | nil => ([], []) | x::xs => let (m1, m2) := unapp n xs in (x::m1, m2) end end. Lemma unapp_wont_expand: forall n (m m1 m2: list A), unapp n m = (m1, m2) -> length m1 <= length m /\ length m2 <= length m. Proof. induction n as [| n]; intros * UA. - simpl in UA. injection UA; intros M1 M2. subst m1 m2. auto with arith. - destruct m. + simpl in UA. injection UA; intros M1 M2. subst m1 m2. auto with arith. + simpl in UA. name_term ua' (unapp n m) UA'. rewrite <- UA' in UA. destruct ua' as [m1' m2']. injection UA; intros M1 M2; subst m1 m2; clear UA. symmetry in UA'. apply IHn in UA'. simpl. omega. Qed. Lemma unapp_app: forall n (m m1 m2: list A), (m1, m2) = unapp n m -> m1 ++ m2 = m. Proof. intros n m. revert n. induction m as [| x xs]; intros * UA. - destruct n as [| n']; simpl in UA; injection UA; intros M1 M2; subst m1 m2; clear UA; simpl; auto with arith. - destruct n as [| n']; simpl in UA. + injection UA; intros M1 M2; subst m1 m2; clear UA. reflexivity. + name_term ua' (unapp n' xs) UA'. rewrite <- UA' in UA. destruct ua' as [m1' m2']. injection UA; intros M1 M2; subst m1 m2; clear UA. simpl. apply IHxs in UA'. subst xs. reflexivity. Qed. Lemma unapp_reduce_m1: forall n (m m1 m2: list A), unapp n m = (m1, m2) -> n < length m -> length m1 < length m. Proof. intros n m. revert n. induction m as [| x xs]; intros * UA NltM. - simpl in NltM. inversion NltM. - destruct n as [| n]. + unfold unapp in UA. injection UA; intros M1 M2; subst m1 m2; clear UA. simpl. auto with arith. + simpl in UA. simpl in NltM. apply lt_S_n in NltM. name_term ua' (unapp n xs) UA'. rewrite <- UA' in UA. destruct ua' as [m1' m2']. injection UA; intros M1 M2; subst m1 m2; clear UA. symmetry in UA'. apply IHxs in UA'; auto. simpl. omega. Qed. Lemma unapp_reduce_m2: forall n (m m1 m2: list A), unapp n m = (m1, m2)-> n > 0 -> length m > 0 -> length m2 < length m. Proof. intros * UA Ngt0 Mgt0. cut (length m1 > 0). { intro H. symmetry in UA. apply unapp_app in UA. subst m. rewrite app_length in *. omega. } destruct n as [| n']; destruct m as [| x xs]. - inversion Ngt0. - inversion Ngt0. - simpl in Mgt0. inversion Mgt0. - simpl in UA. name_term ua' (unapp n' xs) UA'. rewrite <- UA' in UA. destruct ua' as [m1' m2']. injection UA; intros M1 M2; subst m1 m2; clear UA. simpl. auto with arith. Qed. Definition unapp_half(m: list A) := let n := length m in let n2 := div2 n in let n1 := n - n2 in unapp n1 m. Lemma unapp_half_app: forall m m1 m2, (m1, m2) = unapp_half m -> m1 ++ m2 = m. Proof. induction m as [| x xs]; intros * SP. inversion SP; auto. unfold unapp_half in SP. apply unapp_app in SP. auto. Qed. Lemma div2_SS: forall n, div2 (S (S n)) > 0. Proof. induction n; simpl; auto with arith. Qed. Lemma unapp_half_nonnil_reduces: forall m m1 m2, unapp_half m = (m1,m2) -> length m > S 0 -> length m1 < length m /\ length m2 < length m. Proof. intros * SP MgtO. unfold unapp_half in SP. name_term k (length m) LEN. rewrite <- LEN in *. name_term n (k - div2 k) N1. rewrite <- N1 in SP. assert (DK: div2 k < k) by (apply lt_div2; auto with arith). name_term d (div2 k) D. rewrite <- D in *. destruct m as [| x1 xs]. simpl in LEN. subst k. inversion DK. destruct xs as [| x2 xs]. simpl in LEN. subst k. inversion MgtO. inversion H0. assert (DgtO: d > 0) by (subst k d; apply div2_SS). assert (NltM: n < length (x1::x2::xs)) by (simpl in *; omega). subst k. split. - apply unapp_reduce_m1 with (n:=n) (m2:=m2); auto. - assert (n > 0) by omega. assert (length (x1::x2::xs) > 0) by (simpl; omega). apply unapp_reduce_m2 with (n:=n) (m1:=m1); auto. Qed. End UnApp. Lemma unapp_map A B (f: A -> B): forall n (m m1 m2: list A), (m1, m2) = unapp n m -> (map f m1, map f m2) = unapp n (map f m). Proof. intros n m. revert n. induction m as [| x xs]; intros * UA. - destruct n as [| n']; simpl in UA; injection UA; intros M1 M2; subst m1 m2; clear UA; simpl; auto with arith. - destruct n as [| n']; simpl in UA. + injection UA; intros M1 M2; subst m1 m2; clear UA. reflexivity. + name_term ua' (unapp n' xs) UA'. rewrite <- UA' in UA. destruct ua' as [m1' m2']. injection UA; intros M1 M2; subst m1 m2; clear UA. simpl. apply IHxs in UA'. rewrite <- UA'. reflexivity. Qed. Lemma unapp_half_map A B (f: A -> B): forall m m1 m2, (m1, m2) = unapp_half m -> (map f m1, map f m2) = unapp_half (map f m). Proof. intros. eapply unapp_map with (f := f) in H. unfold unapp_half. rewrite map_length. auto. Qed. Section Folds. Variable A: Type. Variable f: A -> A -> A. Variable fComm: forall a b, f a b = f b a. Variable fAssoc: forall a b c, f (f a b) c = f a (f b c). Variable unit: A. Variable fUnit: forall x, f unit x = x. Lemma fold_right_inclusion: forall m1 m2 seed, fold_right f seed (m1 ++ m2) = fold_right f (fold_right f seed m2) m1. Proof. intro m1. induction m1 as [| x xs]; intros. - reflexivity. - cut (fold_right f seed (xs ++ m2) = fold_right f (fold_right f seed m2) xs). intro C; simpl. now rewrite C. apply IHxs. Qed. (* h := fold_tree *) (* odot := f *) Function fold_tree (ls: list A) {measure length ls} := match ls with | nil => unit | [x] => f x unit | [x;y] => f x y | _ => let (m1, m2) := unapp_half ls in f (fold_tree m1) (fold_tree m2) end. Proof. - abstract (intros; unfold unapp_half in teq2; symmetry in teq2; name_term len_x_n_l0 (length (x::y::a::l1)) LEN; rewrite <- LEN in *; simpl in LEN; assert (L0: len_x_n_l0 > 0) by omega; apply lt_div2 in L0; assert (len_x_n_l0 - div2 len_x_n_l0 > 0) by omega; symmetry in teq2; apply unapp_reduce_m2 in teq2; auto; simpl in teq2; [rewrite <- LEN in *; apply teq2| simpl; auto with arith]). - abstract (intros; unfold unapp_half in teq2; apply unapp_reduce_m1 in teq2; [apply teq2| clear teq2; name_term len_x_n_l0 (length (x::y::a::l1)) LEN; rewrite <- LEN in *; simpl in LEN; assert (L0: len_x_n_l0 > 0) by omega; apply lt_div2 in L0; assert (L1: len_x_n_l0 > 1) by omega; rewrite LEN at 2; simpl; omega]). Defined. Lemma f_comm1 a b c: f a (f b c) = f b (f a c). Proof. rewrite <- fAssoc. rewrite <- fAssoc. assert (sth:f a b = f b a) by apply fComm; rewrite sth; rewrite <- sth. auto. Qed. Lemma f_comm2 a b c: f a (f b c) = f (f a b) c. Proof. rewrite <- fAssoc. reflexivity. Qed. Lemma fold_right_f_assoc: forall i m1 seed, f i (fold_right f seed m1) = fold_right f (f i seed) m1. Proof. intros i m1. assert (exists k, length m1 <= k) as [k K] by (exists (length m1); auto). revert i m1 K. induction k as [| k]; intros * K *. - assert (A1: length m1 = 0) by omega. apply length_zero_iff_nil in A1. subst m1. reflexivity. - destruct m1 as [| y ys]. + reflexivity. + simpl in K. apply le_S_n in K. simpl. rewrite <- IHk; auto. apply f_comm1. Qed. Lemma fold_right_slideout: forall m seed, fold_right f seed m = f (fold_right f unit m) seed. Proof. induction m as [| x xs]; intros. - now simpl. - simpl. rewrite IHxs. destruct xs. apply f_comm2. apply f_comm2. Qed. Lemma fold_right_homomorphism: forall m1 m2, fold_right f unit (m1 ++ m2) = f (fold_right f unit m1) (fold_right f unit m2). Proof. intros *. name_term lhs (f (fold_right f unit m1) (fold_right f unit m2)) LHS. rewrite <- LHS. rewrite fold_right_inclusion. rewrite fold_right_slideout. now subst lhs. Qed. Lemma fold_right_homomorphism_unapp: forall m m1 m2, (m1, m2) = unapp_half m -> fold_right f unit m = f (fold_right f unit m1) (fold_right f unit m2). Proof. intros. apply unapp_half_app in H. rewrite <- H. eapply fold_right_homomorphism. Qed. Theorem fold_right_fold_tree: forall m, fold_right f unit m = fold_tree m. Proof. intro m. assert (exists k, length m <= k) as [k K] by (exists (length m); auto). revert m K. induction k as [| k]; intros * K. - assert (A1: length m = 0) by omega. apply length_zero_iff_nil in A1. now subst m. - destruct m as [| x1 xs]. now simpl. destruct xs as [| x2 xs]. now simpl. rewrite fold_tree_equation. name_term tpl (unapp_half (x1::x2::xs)) Tpl; rewrite <- Tpl; destruct tpl as [m1 m2]. simpl in K. assert (K': S (length xs) <= k) by (rewrite le_S_n; auto); clear K; rename K' into K. assert (length m1 <= length (x2::xs) /\ length m2 <= length (x2::xs)) as [A1 A2]. { symmetry in Tpl. apply unapp_half_nonnil_reduces in Tpl; auto. 2: simpl; omega. simpl in *. omega. } simpl in A1, A2. assert (A3: length m1 <= k) by omega; clear A1. assert (A4: length m2 <= k) by omega; clear A2. rewrite <- (IHk m1 A3); rewrite <- (IHk m2 A4). rewrite fold_right_homomorphism_unapp with (m:=(x1::x2::xs)) (m1 := m1) (m2 := m2); destruct xs; auto. unfold unapp_half in Tpl; simpl in *. inversion Tpl; clear Tpl; subst. simpl. rewrite (fComm x1 unit), (fComm x2 unit). rewrite ?fUnit. auto. Qed. Theorem fold_left_fold_right: forall m seed, fold_left f m seed = fold_right f seed m. Proof. induction m; simpl; auto; intros. rewrite IHm. rewrite fold_right_f_assoc. rewrite fComm. auto. Qed. Theorem fold_left_fold_tree: forall m, fold_left f m unit = fold_tree m. Proof. intros. rewrite fold_left_fold_right. apply fold_right_fold_tree. Qed. End Folds. Section FoldWhich. Variable A: Type. Variable decA: forall a b: A, {a = b} + {a <> b}. Variable which: A -> A -> bool. Variable whichRefl: forall a, which a a = true. Variable whichSym: forall x y, x = y \/ which x y = negb (which y x). Variable whichTrans: forall a b c, which a b = which b c -> which a c = which a b. Definition pick x y := if which x y then x else y. Local Lemma pickComm: forall a b, pick a b = pick b a. Proof. unfold pick; intros. specialize (whichSym a b). destruct whichSym; subst; auto. rewrite H. destruct (which b a); auto. Qed. Local Lemma pickAssoc: forall a b c, pick (pick a b) c = pick a (pick b c). Proof. unfold pick; intros. case_eq (which b c); case_eq (which a b); intros; auto. - erewrite whichTrans; eauto. rewrite H; auto. - rewrite H0; auto. - rewrite H0. erewrite whichTrans; eauto. rewrite H; auto. Qed. Variable unit: A. Variable whichUnit: forall x, x <> unit -> which unit x = false. Local Lemma pickUnit: forall x, pick unit x = x. Proof. unfold pick; intros. destruct (decA unit x); subst. destruct (which x x); auto. assert (sth: x <> unit) by (intro; subst; tauto). specialize (whichUnit sth). rewrite whichUnit; auto. Qed. Local Lemma pickUnit_both: forall x y, pick x y = unit -> x = unit /\ y = unit. Proof. intros. unfold pick in *. case_eq (which x y); intros sth; rewrite sth in *; subst. - split; auto. destruct (decA y unit); auto. specialize (whichUnit n). congruence. - split; auto. specialize (whichSym x unit). destruct whichSym; auto. rewrite H in sth. rewrite Bool.negb_false_iff in sth. rewrite sth in *; simpl in *. destruct (decA x unit); auto. specialize (whichUnit n). congruence. Qed. Lemma fold_right_unit ls: fold_right pick unit ls = unit -> forall x, In x ls -> x = unit. Proof. induction ls; simpl; auto; intros. - tauto. - destruct H0; subst. apply pickUnit_both in H. destruct H as [s1 s2]; subst; auto. apply pickUnit_both in H. destruct H as [s3 s4]. eapply IHls; eauto. Qed. Theorem which1_fold_right: forall ls, forall i, i < length ls -> which (fold_right pick unit ls) (nth i ls unit) = true. Proof. induction ls; simpl; auto; intros. - Omega.omega. - unfold pick in *. remember (fold_right (fun x y => if which x y then x else y) unit ls) as sth. destruct i; simpl in *. + case_eq (which a sth); intros sth2. * subst; eapply whichRefl; eauto. * destruct (decA sth a); simpl in *. -- subst; rewrite whichRefl; auto. -- specialize (whichSym sth a). destruct whichSym; [tauto|]. rewrite H0 in *. rewrite Bool.negb_true_iff. auto. + case_eq (which a sth); intros sth2. * specialize (IHls i ltac:(Omega.omega)). rewrite <- IHls in sth2. pose proof (@whichTrans _ _ _ sth2). congruence. * specialize (IHls i ltac:(Omega.omega)). auto. Qed. Theorem which1_fold_tree: forall ls, forall i, i < length ls -> which (fold_tree pick unit ls) (nth i ls unit) = true. Proof. intros. rewrite <- fold_right_fold_tree; auto; intros. - eapply which1_fold_right; eauto. - apply pickComm. - apply pickAssoc. - apply pickUnit. Qed. Theorem which1_fold_left: forall ls, forall i, i < length ls -> which (fold_left pick ls unit) (nth i ls unit) = true. Proof. intros. rewrite fold_left_fold_right; auto; intros. - eapply which1_fold_right; eauto. - apply pickComm. - apply pickAssoc. Qed. Theorem which2_fold_right: forall ls, fold_right pick unit ls <> unit -> exists n, n < length ls /\ nth n ls unit = fold_right pick unit ls. Proof. induction ls; simpl; auto; intros. - tauto. - destruct (decA (fold_right pick unit ls) unit); simpl in *. + rewrite e in *. rewrite pickComm in *. rewrite pickUnit in *; subst. exists 0; repeat split; auto; try Omega.omega; intros. + specialize (IHls n). destruct IHls as [j [jLen cond1]]. subst. rewrite <- cond1 in *. unfold pick in *. case_eq (which a (nth j ls unit)); intros sth; rewrite sth in *; subst. * exists 0; repeat split; auto; try Omega.omega; intros. * exists (S j); repeat split; auto; try Omega.omega; intros. Qed. Theorem which2_fold_tree: forall ls, fold_tree pick unit ls <> unit -> exists n, n < length ls /\ nth n ls unit = fold_tree pick unit ls. Proof. intros. rewrite <- fold_right_fold_tree in *; auto; intros. - eapply which2_fold_right; eauto; auto. - apply pickComm. - apply pickAssoc. - apply pickUnit. - apply pickComm. - apply pickAssoc. - apply pickUnit. Qed. Theorem which2_fold_left: forall ls, fold_left pick ls unit <> unit -> exists n, n < length ls /\ nth n ls unit = fold_left pick ls unit. Proof. intros. rewrite fold_left_fold_right in *; auto; intros. - eapply which2_fold_right; eauto; auto. - apply pickComm. - apply pickAssoc. - apply pickComm. - apply pickAssoc. Qed. Theorem whichNonUnit_fold_right: forall ls val, val = fold_right pick unit ls -> val <> unit -> exists n, n < length ls /\ nth n ls unit = val /\ forall i, i < length ls -> i <> n -> which val (nth i ls unit) = true. Proof. induction ls; simpl; auto; intros. - tauto. - destruct (decA (fold_right pick unit ls) unit); simpl in *. + rewrite e in *. rewrite pickComm in *. rewrite pickUnit in *; subst. exists 0; repeat split; auto; try Omega.omega; intros. destruct i; auto. pose proof (fold_right_unit _ e) as sth. specialize (sth (nth i ls unit) (nth_In (n := i) ls unit ltac:(Omega.omega))). rewrite sth. specialize (whichSym a unit). destruct whichSym as [whichSym0 | whichSym0]; auto. rewrite whichSym0. rewrite Bool.negb_true_iff. auto. + specialize (IHls _ eq_refl n). destruct IHls as [j [jLen [cond1 cond2]]]. subst. rewrite <- cond1 in *. unfold pick in *. case_eq (which a (nth j ls unit)); intros sth; rewrite sth in *; subst. * exists 0; repeat split; auto; try Omega.omega; intros. destruct i; auto. destruct (Nat.eq_dec i j); subst; [auto|]. specialize (cond2 i ltac:(Omega.omega) n0). rewrite <- cond2 in sth. pose proof (whichTrans sth). congruence. * exists (S j); repeat split; auto; try Omega.omega; intros. destruct i; auto. -- specialize (whichSym (nth j ls unit) a). destruct whichSym as [whichSym0 | whichSym0]; auto. ++ rewrite whichSym0 in *. eapply whichRefl; eauto. ++ rewrite whichSym0. rewrite Bool.negb_true_iff; auto. -- eapply cond2; eauto; Omega.omega. Qed. Theorem whichNonUnit_fold_left: forall ls val, val = fold_left pick ls unit -> val <> unit -> exists n, n < length ls /\ nth n ls unit = val /\ forall i, i < length ls -> i <> n -> which val (nth i ls unit) = true. Proof. intros. rewrite fold_left_fold_right in H; auto; intros. - eapply whichNonUnit_fold_right; eauto. - apply pickComm. - apply pickAssoc. Qed. Theorem whichNonUnit_fold_tree: forall ls val, val = fold_tree pick unit ls -> val <> unit -> exists n, n < length ls /\ nth n ls unit = val /\ forall i, i < length ls -> i <> n -> which val (nth i ls unit) = true. Proof. intros. rewrite <- fold_right_fold_tree in H; auto; intros. - eapply whichNonUnit_fold_right; eauto. - apply pickComm. - apply pickAssoc. - apply pickUnit. Qed. End FoldWhich. ================================================ FILE: Lib/HexNotation.v ================================================ (* Adapted from http://poleiro.info/posts/2013-04-03-parse-errors-as-type-errors.html, https://github.com/arthuraa/poleiro/blob/master/theories/ForceOption.v to produce N instead of nat *) Require Export Coq.Strings.String. Require Import Coq.Strings.Ascii. Require Import Coq.NArith.NArith. Local Open Scope char_scope. Local Open Scope N_scope. Definition hexDigitToN (c : ascii) : option N := match c with | "0" => Some 0 | "1" => Some 1 | "2" => Some 2 | "3" => Some 3 | "4" => Some 4 | "5" => Some 5 | "6" => Some 6 | "7" => Some 7 | "8" => Some 8 | "9" => Some 9 | "a" | "A" => Some 10 | "b" | "B" => Some 11 | "c" | "C" => Some 12 | "d" | "D" => Some 13 | "e" | "E" => Some 14 | "f" | "F" => Some 15 | _ => None end. Local Open Scope string_scope. Fixpoint readHexNAux (s : string) (acc : N) : option N := match s with | "" => Some acc | String c s' => match hexDigitToN c with | Some n => readHexNAux s' (16 * acc + n) | None => None end end. Definition readHexN (s : string) : option N := readHexNAux s 0. Goal readHexN "ff" = Some 255. Proof. reflexivity. Qed. Definition forceOption A Err (o : option A) (err : Err) : match o with | Some _ => A | None => Err end := match o with | Some a => a | None => err end. Inductive parseError := ParseError. Definition hex (s : string) := forceOption N parseError (readHexN s) ParseError. Goal hex"ff" = 255. Proof. reflexivity. Qed. Goal hex"a0f" = 2575. Proof. reflexivity. Qed. Goal hex"1O" = ParseError. Proof. reflexivity. Qed. Goal hex"ff34c8e3" = 4281649379. Proof. reflexivity. Qed. Local Close Scope string_scope. Local Close Scope N_scope. Definition binDigitToNat (c : ascii) : option nat := match c with | "0" => Some 0 | "1" => Some 1 | _ => None end. Open Scope string_scope. Fixpoint readBinAux (s : string) (acc : nat) : option nat := match s with | "" => Some acc | String c s' => match binDigitToNat c with | Some n => readBinAux s' (2 * acc + n) | None => None end end. Definition readBinNat (s : string) : option nat := readBinAux s 0. Goal readBinNat "01" = Some 1. Proof. reflexivity. Qed. Definition bin (s : string) := @forceOption nat parseError (readBinNat s) ParseError. ================================================ FILE: Lib/HexNotationWord.v ================================================ Require Export Kami.Lib.Word. Require Export Kami.Lib.HexNotation. Open Scope word_scope. Notation "'Ox' a" := (NToWord _ (hex a)) (at level 50). Notation "sz ''h' a" := (NToWord sz (hex a)) (at level 50). Goal 8'h"a" = ZToWord 8 (wordVal _ (NToWord 4 10)). Proof. reflexivity. Qed. Goal Ox"41" = ZToWord 7 65. Proof. reflexivity. Qed. Notation "sz ''b' a" := (ZToWord sz (Z.of_nat (bin a))) (at level 50). Notation "''b' a" := (ZToWord _ (Z.of_nat (bin a))) (at level 50). Goal 'b"00001010" = ZToWord 8 (wordVal _ (NToWord 4 10)). Proof. reflexivity. Qed. Goal 'b"1000001" = ZToWord 7 65. Proof. reflexivity. Qed. ================================================ FILE: Lib/NatStr.v ================================================ Require Import Kami.Syntax. Section nat_string. Unset Implicit Arguments. (* Accepts two arguments: radix and ns; and returns: ns[0] + radix * ns[1] + radix^2 * ns[2] + ... radix^n * ns[n] Ex: nat_decomp_nat 2 [1; 0; 1; 1] = 13. *) Local Fixpoint nat_decomp_nat (radix : nat) (ns : list nat) : nat := match ns with | [] => 0 | m :: ms => (radix * nat_decomp_nat radix ms) + m end. Local Fixpoint nat_decomp_prod (x : nat) (ns : list nat) : list nat := match ns with | [] => [] | m :: ms => x * m :: nat_decomp_prod x ms end. (* 0 = Nat.div x y ==> x < y ==> x = x mod y *) Lemma div0_mod : forall x y : nat, y <> 0 -> 0 = Nat.div x y -> x = x mod y. Proof. exact (fun x y H H0 => eq_sym (Nat.mod_small x y (proj1 (Nat.div_small_iff x y H) (eq_sym H0)))). Qed. Local Definition nat_decomp (radix : nat) (* radix minus 2 *) (n : nat) : {ms : list nat | Forall (fun m => m < (S (S radix))) ms /\ n = nat_decomp_nat (S (S radix)) ms} := Fix_F (fun n => {ms : list nat | Forall (fun m => m < (S (S radix))) ms /\ n = nat_decomp_nat (S (S radix)) ms}) (fun n (F : forall r, r < n -> {ms : list nat | Forall (fun m => m < (S (S radix))) ms /\ r = nat_decomp_nat (S (S radix)) ms}) => nat_rec (fun q => q = Nat.div n (S (S radix)) -> {ms : list nat | Forall (fun m => m < (S (S radix))) ms /\ n = nat_decomp_nat (S (S radix)) ms}) (fun H : 0 = Nat.div n (S (S radix)) => let H0 : n = nat_decomp_nat (S (S radix)) [n mod (S (S radix))] := ltac:( lazy [nat_decomp_nat list_rec list_rect]; rewrite (Nat.mul_0_r (S (S radix))); rewrite (Nat.add_0_l _); apply (div0_mod n (S (S radix)) (Nat.neq_succ_0 (S radix)) H)) in exist (fun ms => Forall (fun m => m < (S (S radix))) ms /\ n = nat_decomp_nat (S (S radix)) ms) [n mod (S (S radix))] (conj (Forall_cons (n mod (S (S radix))) (Nat.mod_upper_bound n (S (S radix)) (Nat.neq_succ_0 (S radix))) (Forall_nil (fun m => m < S (S radix)))) H0)) (fun q _ (H : S q = Nat.div n (S (S radix))) => let (ms, H0) := F (S q) (eq_ind_r (fun x => x < n) (Nat.div_lt n (S (S radix)) (or_ind (fun H0 : 0 < n => H0) (fun H0 : 0 = n => False_ind (0 < n) (let H2 : Nat.div n (S (S radix)) = 0 := eq_ind 0 (fun x => Nat.div x (S (S radix)) = 0) (Nat.div_0_l (S (S radix)) (Nat.neq_succ_0 (S radix))) n H0 in let H1 : S q = 0 := eq_ind_r (fun x => x = 0) H2 H in Nat.neq_succ_0 q H1)) ((proj1 (Nat.lt_eq_cases 0 n)) (Nat.le_0_l n))) (le_n_S 1 (S radix) (le_n_S 0 radix (Nat.le_0_l radix)))) H) in let xs := n mod (S (S radix)) :: ms in let H1 : n = nat_decomp_nat (S (S radix)) xs := ltac:( unfold xs; lazy [nat_decomp_nat list_rec list_rect]; fold (nat_decomp_nat (S (S radix))); rewrite <- (proj2 H0); rewrite H; rewrite <- (Nat.div_mod n (S (S radix)) (Nat.neq_succ_0 (S radix))); reflexivity) in let H2 : Forall (fun m => m < S (S radix)) xs := Forall_cons (n mod S (S radix)) (Nat.mod_upper_bound n (S (S radix)) (Nat.neq_succ_0 (S radix))) (proj1 H0) in exist _ xs (conj H2 H1)) (Nat.div n (S (S radix))) eq_refl)%nat (lt_wf n). (* Every function that has an inverse is injective. *) Local Theorem inv_inj : forall (A B : Type) (f : A -> B) (g : B -> A), (forall x : A, g (f x) = x) -> (forall x y : A, f x = f y -> x = y). Proof. intros A b f g Hg x y Hxy. rewrite <- (Hg x). rewrite <- (Hg y). rewrite Hxy. reflexivity. Qed. Local Theorem nat_decomp_inj (radix : nat) (* radix minus 2 *) : forall n m : nat, proj1_sig (nat_decomp radix n) = proj1_sig (nat_decomp radix m) -> n = m. Proof. exact (inv_inj _ _ (fun x => proj1_sig (nat_decomp radix x)) (nat_decomp_nat (S (S radix))) (fun x => eq_sym (proj2 (proj2_sig (nat_decomp radix x))))). Qed. Local Open Scope char_scope. Local Fixpoint nat_decomp_chars (radix : nat) (* radix minus 2 *) (encoding : forall n, n < S (S radix) -> ascii) (ns : list nat) : Forall (fun n => n < S (S radix)) ns -> list ascii := match ns with | [] => fun _ => [] | m :: ms => fun H : Forall (fun n => n < S (S radix)) (m :: ms) => nat_decomp_chars radix encoding ms (Forall_inv_tail H) ++ [encoding m (Forall_inv H)] end. Local Theorem nat_decomp_chars_inj (radix : nat) (encoding : forall n, n < S (S radix) -> ascii) (encoding_inj : forall n m (Hn : n < S (S radix)) (Hm : m < S (S radix)), encoding n Hn = encoding m Hm -> n = m) : forall (ns : list nat) (ms : list nat) (Hns : Forall (fun n => n < S (S radix)) ns) (Hms : Forall (fun m => m < S (S radix)) ms), nat_decomp_chars radix encoding ns Hns = nat_decomp_chars radix encoding ms Hms -> ns = ms. Proof. exact (list_ind (fun ns => forall (ms : list nat) (Hns : Forall (fun n => n < S (S radix)) ns) (Hms : Forall (fun m => m < S (S radix)) ms), nat_decomp_chars radix encoding ns Hns = nat_decomp_chars radix encoding ms Hms -> ns = ms) (list_ind (fun ms => forall (Hns : Forall (fun n => n < S (S radix)) []) (Hms : Forall (fun m => m < S (S radix)) ms), nat_decomp_chars radix encoding [] Hns = nat_decomp_chars radix encoding ms Hms -> [] = ms) (fun _ _ _ => ltac:(reflexivity)) (fun _ _ _ _ _ H => False_ind _ (app_cons_not_nil _ _ _ H))) (fun n ns F => list_ind (fun ms => forall (Hns : Forall (fun n => n < S (S radix)) (n :: ns)) (Hms : Forall (fun m => m < S (S radix)) ms), nat_decomp_chars radix encoding (n :: ns) Hns = nat_decomp_chars radix encoding ms Hms -> (n :: ns) = ms) (fun _ _ H => False_ind _ (app_cons_not_nil _ _ _ (eq_sym H))) (fun m ms G Hns Hms H => let H0 : ns = ms := F ms (Forall_inv_tail Hns) (Forall_inv_tail Hms) (proj1 (app_inj_tail (nat_decomp_chars radix encoding ns (Forall_inv_tail Hns)) (nat_decomp_chars radix encoding ms (Forall_inv_tail Hms)) (encoding n (Forall_inv Hns)) (encoding m (Forall_inv Hms)) H)) in sumbool_ind (fun _ => _) (fun H1 : n = m => ltac:(rewrite H0; rewrite H1; reflexivity) : (n :: ns) = (m :: ms)) (fun H1 : n <> m => let H2 : encoding n (Forall_inv Hns) = encoding m (Forall_inv Hms) := proj2 (app_inj_tail (nat_decomp_chars radix encoding ns (Forall_inv_tail Hns)) (nat_decomp_chars radix encoding ms (Forall_inv_tail Hms)) (encoding n (Forall_inv Hns)) (encoding m (Forall_inv Hms)) H) in False_ind _ (H1 (encoding_inj n m (Forall_inv Hns) (Forall_inv Hms) H2))) (Nat.eq_dec n m)))). Qed. Local Definition nat_chars (radix : nat) (encoding : forall n, n < S (S radix) -> ascii) (n : nat) : list ascii := nat_decomp_chars radix encoding (proj1_sig (nat_decomp radix n)) (proj1 (proj2_sig (nat_decomp radix n))). Local Theorem nat_chars_inj (radix : nat) (encoding : forall n, n < S (S radix) -> ascii) (encoding_inj : forall n m (Hn : n < S (S radix)) (Hm : m < S (S radix)), encoding n Hn = encoding m Hm -> n = m) : forall n m : nat, nat_chars radix encoding n = nat_chars radix encoding m -> n = m. Proof. intros n m H. assert ((proj1_sig (nat_decomp radix n)) = (proj1_sig (nat_decomp radix m))). apply (nat_decomp_chars_inj radix encoding encoding_inj (proj1_sig (nat_decomp radix n)) (proj1_sig (nat_decomp radix m)) (proj1 (proj2_sig (nat_decomp radix n))) (proj1 (proj2_sig (nat_decomp radix m))) H). apply (nat_decomp_inj radix n m H0). Qed. Local Definition nat_string (radix : nat) (encoding : forall n, n < S (S radix) -> ascii) (n : nat) : string := string_of_list_ascii (nat_chars radix encoding n). Local Lemma string_of_list_ascii_inj : forall xs ys : list ascii, string_of_list_ascii xs = string_of_list_ascii ys -> xs = ys. Proof. exact (inv_inj _ _ string_of_list_ascii list_ascii_of_string list_ascii_of_string_of_list_ascii). Qed. Local Theorem nat_string_inj (radix : nat) (encoding : forall n, n < S (S radix) -> ascii) (encoding_inj : forall n m (Hn : n < S (S radix)) (Hm : m < S (S radix)), encoding n Hn = encoding m Hm -> n = m) : forall n m : nat, nat_string radix encoding n = nat_string radix encoding m -> n = m. Proof. intros n m H. assert (nat_chars radix encoding n = nat_chars radix encoding m). apply (string_of_list_ascii_inj _ _ H). assert ((proj1_sig (nat_decomp radix n)) = (proj1_sig (nat_decomp radix m))). apply (nat_decomp_chars_inj radix encoding encoding_inj (proj1_sig (nat_decomp radix n)) (proj1_sig (nat_decomp radix m)) (proj1 (proj2_sig (nat_decomp radix n))) (proj1 (proj2_sig (nat_decomp radix m))) H0). apply (nat_decomp_inj radix n m H1). Qed. Local Ltac notIn H (* In x xs *) := repeat (destruct H; repeat (discriminate; assumption)). Local Ltac encoding_NoDup xs := lazymatch xs with | nil => exact (NoDup_nil ascii) | (cons ?X ?XS)%list => exact (NoDup_cons X (fun H : In X XS => ltac:(notIn H)) (ltac:(encoding_NoDup XS))) end. Local Definition decode (encoding : list ascii) (n : nat) : ascii := List.nth n encoding " ". Local Definition decode_safe (encoding : list ascii) (n : nat) (_ : n < List.length encoding) := decode encoding n. Local Ltac digit_encoding_inj encoding := exact (proj1 (NoDup_nth encoding " ") ltac:(encoding_NoDup encoding) : forall n m : nat, n < List.length encoding -> m < List.length encoding -> decode encoding n = decode encoding m -> n = m). Local Ltac encoding_inj radix encoding (* radix = encoding - 2 *) := exact (nat_string_inj radix (decode_safe encoding) (ltac:(digit_encoding_inj encoding))). Local Definition binary_encoding_list : list ascii := ["0"; "1"]. Definition natToBinStr : nat -> string := nat_string 0 (decode_safe binary_encoding_list). Definition natToBinStr_inj : forall n m, natToBinStr n = natToBinStr m -> n = m := ltac:(encoding_inj 0 ["0"; "1"]%list). Local Definition decimal_encoding_list : list ascii := ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"]. Definition natToDecStr : nat -> string := nat_string 8 (decode_safe decimal_encoding_list). Definition natToDecStr_inj : forall n m, natToDecStr n = natToDecStr m -> n = m := ltac:(encoding_inj 8 ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"]%list). Local Definition hex_encoding_list : list ascii := ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "A"; "B"; "C"; "D"; "E"; "F"]. Definition natToHexStr : nat -> string := nat_string 14 (decode_safe hex_encoding_list). Definition natToHexStr_inj : forall n m, natToHexStr n = natToHexStr m -> n = m := ltac:(encoding_inj 14 ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "A"; "B"; "C"; "D"; "E"; "F"]%list). Local Close Scope char_scope. Local Open Scope string_scope. (* Goal (natToHexStr 179 = "B3"). Proof. reflexivity. Qed. *) Goal (natToDecStr 179 = "179"). Proof. reflexivity. Qed. Goal (natToBinStr 179 = "10110011"). Proof. reflexivity. Qed. Local Close Scope string_scope. Local Close Scope list. Set Implicit Arguments. End nat_string. ================================================ FILE: Lib/VectorFacts.v ================================================ Require Coq.Vectors.Vector. Import Vectors.VectorDef.VectorNotations. Set Implicit Arguments. Set Asymmetric Patterns. Definition Vector_caseS' {A'} (Q : nat -> Type) (P : forall {n} (v : Vector.t A' (S n)), Q n -> Type) (H : forall h {n} t q, @P n (h :: t) q) {n} (v: Vector.t A' (S n)) (q : Q n) : P v q. Proof. specialize (fun h t => H h _ t q). change n with (pred (S n)) in H, q |- *. set (Sn := S n) in *. pose (fun Sn (v : Vector.t A' Sn) (q : Q (pred Sn)) => match Sn return Vector.t A' Sn -> Q (pred Sn) -> Type with | S n' => P n' | 0 => fun _ _ => True end v q) as P'. change (match Sn return Type with | 0 => True | _ => P' Sn v q end). change (forall h (t : match Sn with | S n' => Vector.t A' n' | 0 => Vector.t A' Sn end), P' Sn (match Sn return match Sn with | S n' => Vector.t A' n' | 0 => Vector.t A' Sn end -> Vector.t A' Sn with | S _ => fun t => h :: t | 0 => fun t => t end t) q) in H. clearbody P'; clear P. clearbody Sn. destruct v as [|h ? t]. { constructor. } { apply H. } Defined. Definition Vector_nth_map' A (f: A -> Type) (n: nat): forall v (p: Fin.t n), f (Vector.nth v p) -> Vector.nth (Vector.map f v) p. Proof. induction p. - apply (Vector.caseS (fun n1 v1 => f (Vector.nth v1 Fin.F1) -> Vector.nth (Vector.map f v1) Fin.F1) (fun h n1 t => fun x => x) v). - apply (Vector.caseS (fun n1 v1 => forall p4, (forall v2, f (Vector.nth v2 p4) -> Vector.nth (Vector.map f v2) p4) -> f (Vector.nth v1 (Fin.FS p4)) -> Vector.nth (Vector.map f v1) (Fin.FS p4)) (fun h n1 t p4 IHp2 => fun X => IHp2 t X) v p IHp ). Defined. Definition Vector_nth_map A (f: A -> Type) n (v: Vector.t A n) p (m: f (Vector.nth v p)): Vector.nth (Vector.map f v) p := @Vector_nth_map' _ f n v p m. Definition Vector_nth_map2_l' A B (g: A -> B) (f: B -> Type) n (v: Vector.t A n) (p: Fin.t n): (forall p: Fin.t n, Vector.nth (Vector.map (fun x => f (g x)) v) p) -> f (Vector.nth (Vector.map g v) p) := Fin.t_rect (fun n0 p3 => forall v0, (forall p, Vector.nth (Vector.map (fun x => f (g x)) v0) p) -> f (Vector.nth (Vector.map g v0) p3)) (fun n0 v0 => Vector.caseS (fun n1 v1 => (forall p, Vector.nth (Vector.map (fun x => f (g x)) v1) p) -> f (Vector.nth (Vector.map g v1) Fin.F1)) (fun h n1 t => fun x => x Fin.F1) v0) (fun n0 p3 IHp1 v0 => Vector.caseS (fun n1 v1 => forall p4, (forall v2, (forall p, Vector.nth (Vector.map (fun x => f (g x)) v2) p) -> f (Vector.nth (Vector.map g v2) p4)) -> (forall p, Vector.nth (Vector.map (fun x => f (g x)) v1) p) -> f (Vector.nth (Vector.map g v1) (Fin.FS p4))) (fun h n1 t p4 IHp2 => fun X => (IHp2 t (fun (p: Fin.t n1) => (X (Fin.FS p)))) ) v0 p3 IHp1) n p v. Definition Vector_nth_map2_l A B (g: A -> B) (f: B -> Type) n (v: Vector.t A n) (m: forall p: Fin.t n, Vector.nth (Vector.map (fun x => f (g x)) v) p) (p: Fin.t n): f (Vector.nth (Vector.map g v) p) := @Vector_nth_map2_l' _ _ g f n v p m. Definition Vector_nth_map2_r' A B (g: A -> B) (f: B -> Type) n (v: Vector.t A n) (p: Fin.t n): f (g (Vector.nth v p)) -> f (Vector.nth (Vector.map g v) p). Proof. induction p. - apply (Vector.caseS (fun n1 v1 => f (g (Vector.nth v1 Fin.F1)) -> f (Vector.nth (Vector.map g v1) Fin.F1)) (fun h n1 t => fun x => x) v). - apply (Vector.caseS (fun n1 v1 => forall p4, (forall v2, f (g (Vector.nth v2 p4)) -> f (Vector.nth (Vector.map g v2) p4)) -> f (g (Vector.nth v1 (Fin.FS p4))) -> f (Vector.nth (Vector.map g v1) (Fin.FS p4))) (fun h n1 t p4 IHp2 => fun X => IHp2 t X) v p IHp ). Defined. Definition Vector_nth_map2_r A B (g: A -> B) (f: B -> Type) n (v: Vector.t A n) (p: Fin.t n) (m: f (g (Vector.nth v p))): f (Vector.nth (Vector.map g v) p) := @Vector_nth_map2_r' _ _ g f n v p m. Section find. Variable A: Type. Variable f: A -> bool. Fixpoint Vector_find' n (v: Vector.t A n): match n with | 0 => unit | S m => Fin.t (S m) end := match v in Vector.t _ n0 return match n0 with | 0 => unit | S m0 => Fin.t (S m0) end with | Vector.nil => tt | Vector.cons h n1 t => if f h then Fin.F1 else match n1 as n0 return (Vector.t _ n0 -> Fin.t (S n0)) with | 0 => fun _ => Fin.F1 | S n2 => fun t0 => Fin.FS (Vector_find' t0) end t end. Definition Vector_find n (v: Vector.t A (S n)): Fin.t (S n) := Vector_find' v. Fixpoint Vector_find_opt n (v: Vector.t A n): option (Fin.t n) := match v in Vector.t _ n0 return option (Fin.t n0) with | Vector.nil => None | Vector.cons h n1 t => if f h then Some Fin.F1 else match n1 as n0 return (Vector.t _ n0 -> option (Fin.t (S n0))) with | 0 => fun _ => None | S n2 => fun t0 => match Vector_find_opt t0 with | None => None | Some i => Some (Fin.FS i) end end t end. End find. ================================================ FILE: Lib/Word.v ================================================ Require Import Coq.ZArith.BinIntDef Coq.ZArith.BinInt Coq.ZArith.Zdiv Psatz. Definition minimize_eq_proof{A: Type}(eq_dec: forall (x y: A), {x = y} + {x <> y}){x y: A} (pf: x = y): x = y := match eq_dec x y with | left p => p | right n => match n pf: False with end end. Section Word. Section fixedWidth. Variable width : nat. Declare Scope word_scope. Local Notation wrap_value n := (Z.modulo n (Z.pow 2 (Z.of_nat width))). (* Word is a record with two fields wordVal and wordBound *) Record word := mk {wordVal : Z ; wordBound : wrap_value wordVal = wordVal}. Delimit Scope word_scope with word. Bind Scope word_scope with word. Open Scope word_scope. Definition ZToWord (n : Z) : word := mk (wrap_value n) (minimize_eq_proof Z.eq_dec (Zdiv.Zmod_mod n _)). Definition boolToZ b : Z := match b with | false => 0 | true => 1 end. Definition NToWord (n : N) := ZToWord (Z.of_N n). Definition boolToWord b := ZToWord (boolToZ b). Definition natToWord (n : nat) := ZToWord (Z.of_nat n). Definition wones := ZToWord ((2 ^ (Z.of_nat width))%Z - 1). End fixedWidth. Section implicitWidth. Context {width : nat}. Definition wordToNat (w : word width) := Z.to_nat (wordVal width w). Definition wadd x y := ZToWord width (Z.add (wordVal width x) (wordVal width y)). Definition wsub x y := ZToWord width (Z.sub (wordVal width x) (wordVal width y)). Definition wor x y := ZToWord width (Z.lor (wordVal width x) (wordVal width y)). Definition wand x y := ZToWord width (Z.land (wordVal width x) (wordVal width y)). Definition wxor x y := ZToWord width (Z.lxor (wordVal width x) (wordVal width y)). Definition wneg x := ZToWord width (Z.sub (Z.pow 2 (Z.of_nat width)) (wordVal width x)). Definition wnot x := ZToWord width (Z.sub (wordVal width (wneg x)) 1). Definition wuand x := Z.eqb (wordVal width (wones width)) (wordVal width x). Definition wuor x := negb (Z.eqb (wordVal width (ZToWord width 0)) (wordVal width x)). Fixpoint pos_uxor (p : positive) : bool := match p with | xH => true | xI p' => negb (pos_uxor p') | xO p' => (pos_uxor p') end. Definition un_xor (z : Z) : bool := match z with | Z0 => false | Zpos p => pos_uxor p | Zneg p => pos_uxor p end. Definition wuxor x := un_xor (wordVal width x). Definition wmul x y := ZToWord width (Z.mul (wordVal width x) (wordVal width y)). Definition wdiv x y := ZToWord width (Z.div (wordVal width x) (wordVal width y)). Definition wmod x y := ZToWord width (Z.modulo (wordVal width x) (wordVal width y)). Definition wslu x y := ZToWord width (Z.mul (wordVal width x) (Z.pow 2 (wordVal width y))). Definition wsru x y := ZToWord width (Z.div (wordVal width x) (Z.pow 2 (wordVal width y))). Definition weqb x y := Z.eqb (wordVal width x) (wordVal width y). Definition wltu x y := Z.ltb (wordVal width x) (wordVal width y). End implicitWidth. Definition truncLsb {lsb outSz} (w : @word outSz) : @word lsb := ZToWord lsb (wordVal outSz w). Definition truncMsb {msb outSz} (w : @word outSz) : @word msb := ZToWord msb (Z.div (wordVal outSz w) (Z.pow 2 (Z.of_nat (Nat.sub outSz msb)))). Definition wconcat {msb lsb outSz} (w1 : @word msb) (w2 : @word lsb) : @word outSz := ZToWord outSz (Z.add (Z.mul (wordVal msb w1) (Z.pow 2 (Z.of_nat lsb))) (wordVal lsb w2)). Definition wcombine {msb lsb} (w1 : @word msb) (w2 : @word lsb) : @word (msb + lsb) := @wconcat msb lsb (msb + lsb) w1 w2. Definition get_msb {sz} (w : @word sz) : @word 1 := (@truncMsb 1 sz w). Definition get_lsb {sz} (w : @word sz) : @word 1 := (@truncLsb 1 sz w). Definition wnon_neg {sz} (w : @word sz) : bool := (Z.ltb (wordVal _ w) (Z.pow 2 (Z.of_nat (sz - 1)))). Definition twosComplement {sz} (w: @word sz) : @word sz := ZToWord _ (Z.sub (Z.pow 2 (Z.of_nat sz)) (wordVal _ w)). Definition wordToSignedZ {sz} (w: @word sz) : Z := if Z.ltb (wordVal _ w) (Z.pow 2 (Z.of_nat (sz - 1))) then wordVal _ w else Z.opp (wordVal _ (twosComplement w)). Definition signZ (n: Z) := match n with | Z0 => false | Z.pos _ => false | Z.neg _ => true end. Definition signedZToWord {sz} (n: Z) : @word sz := if signZ n then twosComplement (ZToWord _ (Z.opp n)) else ZToWord _ n. Definition wsra {sz1 sz2: nat} (w1: @word sz1) (w2 : @word sz2) : @word sz1 := @signedZToWord sz1 (Z.div (if wnon_neg w1 then wordVal _ w1 else wordToSignedZ w1) (Z.pow 2 (wordVal _ w2))). Definition whd sz (w : word (S sz)) := @truncMsb 1 _ w. Definition wtail sz (w : word (S sz)) := @truncLsb sz _ w. Definition wsplitl (sz1 sz2 : nat) (w : @word (sz1 + sz2)) : @word sz1 := ZToWord _ (wordVal _ w / (Z.pow 2 (Z.of_nat sz2)))%Z. Definition wsplitr (sz1 sz2 : nat) (w : @word (sz1 + sz2)) : @word sz2 := ZToWord _ ((wordVal _ w) mod (Z.pow 2 (Z.of_nat sz2)))%Z. Fixpoint nat_cast (P : nat -> Type) {n m} : n = m -> P n -> P m. refine match n, m return n = m -> P n -> P m with | O, O => fun _ => id | S n, S m => fun pf => @nat_cast (fun n => P (S n)) n m (f_equal pred pf) | _, _ => fun pf => match _ pf : False with end end; clear; abstract congruence. Defined. Definition wmsb sz (w : word sz) (b : bool) := if (sz =? 0)%nat then b else (0 x = y. Proof. intros. destruct x as [x px]. destruct y as [y py]. intros. simpl in *; subst; auto. apply f_equal, Eqdep_dec.UIP_dec. eapply Z.eq_dec. Qed. Lemma weqb_true: forall {sz} (a b: word sz), weqb a b = true -> a = b. Proof. intros. unfold weqb in H. rewrite Z.eqb_eq in H. apply eq_wordVal. assumption. Qed. Lemma weqb_false: forall {sz} (a b: word sz), weqb a b = false -> a <> b. Proof. intros. unfold weqb in H. rewrite Z.eqb_neq in H. congruence. Qed. Definition weq {sz} (x y: word sz): {x = y} + {x <> y} := match weqb x y as sth return weqb x y = sth -> {x = y} + {x <> y} with | true => fun s => left (weqb_true _ _ s) | false => fun s => right (weqb_false _ _ s) end eq_refl. End Word. Module Notations. Declare Scope word_scope. Notation "^~" := wneg : word_scope. Notation "l ^* r" := (@wmul _ l r) (at level 40, left associativity) : word_scope. Notation "l ^/ r" := (@wdiv _ l r) (at level 50, left associativity) : word_scope. Notation "l ^+ r" := (@wadd _ l r) (at level 50, left associativity) : word_scope. Notation "l ^- r" := (@wsub _ l r) (at level 50, left associativity) : word_scope. Notation "l ^% r" := (@wmod _ l r) (at level 50, left associativity) : word_scope. Notation "l ^| r" := (@wor _ l r) (at level 50, left associativity) : word_scope. Notation "l ^& r" := (@wand _ l r) (at level 40, left associativity) : word_scope. Notation "$ n" := (@natToWord _ n) (at level 0, no associativity): word_scope. (* Notation "$ m" := (@ZToWord _ m) (at level 0, no associativity): word_scope. *) Notation "WO~0" := (ZToWord 1 0) : word_scope. Notation "WO~1" := (ZToWord 1 1) : word_scope. Notation WO := (ZToWord 0 0). Delimit Scope word_scope with word. End Notations. Notation wzero sz := (ZToWord sz 0). Export Notations. Export ZArith. (* Compute (@wnot 2 (ZToWord 2 2)). *) (* Compute (@wneg 2 (ZToWord 2 3)). *) (* Compute (wsra (ZToWord 4 15) (ZToWord 1 1)). *) (* Compute (wsra (ZToWord 4 12) (ZToWord 3 3)). *) (* Compute (wsra (ZToWord 2 1) (ZToWord 3 5)). *) (* Compute (wsra (ZToWord 5 9) (ZToWord 4 3)). *) (* Compute (@wconcat 2 2 4 (ZToWord 2 2) (ZToWord 2 3)). *) (* Compute (@truncLsb 2 4 (@wconcat 2 2 4 (ZToWord 2 2) (ZToWord 2 3))).*) ================================================ FILE: Lib/WordProperties.v ================================================ Require Import Coq.ZArith.BinIntDef Coq.ZArith.BinInt Coq.ZArith.Zdiv Eqdep. Require Import Kami.Lib.Word. Require Import Kami.Lib.EclecticLib. Require Import Lia. Require Import Omega. Require Import Coq.Arith.Even. Require Import Coq.Arith.Div2. Require Import Coq.NArith.NArith. Require Import Arith_base. Require Import Arith Coq.ZArith.Znat Psatz. Lemma nat_cast_eq_rect: forall (P : nat -> Type), forall (n m : nat) (e: n = m) (pn: P n), nat_cast P e pn = eq_rect n P pn m e. Proof. destruct e. revert dependent P; induction n; simpl; intros. - reflexivity. - rewrite IHn. reflexivity. Qed. Lemma nat_cast_same: forall (P: nat -> Type) (s: nat) (n: P s), nat_cast P eq_refl n = n. Proof. intros. rewrite nat_cast_eq_rect. reflexivity. Qed. Fixpoint countLeadingZerosWord ni no: word ni -> word no := match ni return word ni -> word no with | 0 => fun _ => (ZToWord _ 0) | S m => fun e => if (weq (@truncMsb 1 (m+1) (nat_cast (fun n => word n) (eq_sym (Nat.add_1_r m)) e)) (ZToWord 1 0)) then (wadd (ZToWord _ 1) (@countLeadingZerosWord m no (@truncLsb m (m+1) (nat_cast (fun n => word n) (eq_sym (Nat.add_1_r m)) e)))) else (ZToWord _ 0) end. Lemma neq_wordVal sz w1 w2: w1 <> w2 -> wordVal sz w1 <> wordVal _ w2. Proof. intros. intro. apply eq_wordVal in H0. contradiction. Qed. Ltac discharge_pow_nonzero := (apply Z.pow_nonzero; unfold not; intros; discriminate). Hint Rewrite Z.lor_spec Z.lxor_spec Z.testbit_0_l : Z_bitwise_no_hyps. Ltac rewrite_bitwise := repeat (autorewrite with Z_bitwise_no_hyps). Ltac bitblast := repeat f_equal; eapply Z.bits_inj_iff; unfold Z.eqf; intros; rewrite_bitwise. Lemma boundProofZ (sz : nat) (w : Z): (w mod (2^ Z.of_nat sz))%Z = w -> (0 <= w < (2^ Z.of_nat sz))%Z. Proof. intros sth0. assert (forall sz', 0 < (2 ^ Z.of_nat sz'))%Z. { induction sz'. simpl. lia. rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. rewrite Z.pow_add_r. lia. lia. lia. } specialize (Z.mod_pos_bound w _ (H sz)) as TMP; destruct TMP. rewrite sth0 in *; split; assumption. Qed. Ltac discharge_gt_0 := (destruct wordVal; lia; lia). Tactic Notation "unique" "pose" "proof" constr(defn) "as" ident(H) := let T := type of defn in match goal with | [ H : T |- _ ] => fail 1 | _ => pose proof defn as H end. Ltac arithmetizeWord := repeat match goal with | w: word _ |- _ => destruct w end; unfold wordVal, wordBound in *; repeat match goal with | H: ?w1 <> ?w2 |- _ => match type of w1 with | word ?sz => apply neq_wordVal in H end; simpl in H | |- ?w1 = ?w2 => match type of w1 with | word ?sz => apply eq_wordVal end; simpl | H: (?w mod (2^(Z.of_nat ?sz)))%Z = ?w |- _ => let sth := fresh in unique pose proof (boundProofZ sz _ H) as sth | H: ?w1 = ?w2 |- _ => match type of w1 with | word ?sz => let H1 := fresh in let H2 := fresh in unique pose proof (f_equal (@wordVal sz) H) as H1 end; cbn [Z.modulo Z.pow_pos] in * end. Lemma word0_neq: forall w : word 1, w <> (ZToWord 1 0) -> w = (ZToWord 1 1). Proof. intros. arithmetizeWord. unfold Z.modulo in *; simpl in *. unfold Z.pow_pos in *; simpl in *. lia. Qed. Lemma wor_wzero : forall sz w, wor (ZToWord sz 0) w = w. Proof. intros. arithmetizeWord. assumption. Qed. Lemma wzero_wor: forall sz w, wor w (ZToWord sz 0) = w. Proof. intros. arithmetizeWord. rewrite Z.lor_0_r. assumption. Qed. Lemma unique_word_0 : forall a : word 0, a = ZToWord 0 0. Proof. intros. arithmetizeWord. simpl in *. unfold Z.modulo in *; simpl in *. lia. Qed. Lemma wzero_wplus: forall sz w, wadd (ZToWord sz 0) w = w. Proof. intros. arithmetizeWord. assumption. Qed. Lemma wplus_wzero : forall sz w, wadd w (ZToWord sz 0) = w. Proof. intros. arithmetizeWord. rewrite Zmod_0_l. rewrite Z.add_0_r. assumption. Qed. Lemma wor_idemp : forall (n : nat) (x0 : word n), wor x0 x0 = x0. Proof. intros. induction x0. unfold wor. arithmetizeWord. rewrite Z.lor_diag. auto. Qed. Lemma truncMsbLtTrue : forall (n x : nat) (w1 w2 : word n), (wordVal _ (@truncMsb x _ w1) < wordVal _ (@truncMsb x _ w2))%Z -> wltu w1 w2 = true. Proof. intros. arithmetizeWord. simpl in *. unfold wltu. destruct (zerop (n - x)). simpl in *. rewrite e in *; simpl in *. repeat rewrite Z.div_1_r in *. rewrite Nat.sub_0_le in e. specialize (Z.pow_le_mono_r_iff 2 (Z.of_nat n) (Z.of_nat x)) as P0. assert (1 < 2)%Z as TMP1; [lia|]. specialize (Nat2Z.is_nonneg x) as TMP2. rewrite Nat2Z.inj_le in e. destruct P0; auto. specialize (H2 e). rewrite Z.ltb_lt. do 2 (rewrite Zmod_small in H); try lia. assert (2^(Z.of_nat (n - x)) > 0)%Z as P1. { apply Z.lt_gt, Z.pow_pos_nonneg;[lia|]. apply Nat2Z.is_nonneg. } assert (Z.of_nat n = Z.of_nat x + Z.of_nat (n - x))%Z. { rewrite <- Nat2Z.inj_add. apply inj_eq. apply le_plus_minus. apply Z.gt_lt in P1. lia. } specialize (Z.pow_nonneg 2 (Z.of_nat (n - x))); intros. assert (0 <= 2)%Z. { lia. } specialize (H3 H4). assert (2 ^ (Z.of_nat n) = ((2 ^ (Z.of_nat x)) * (2 ^ Z.of_nat (n- x))))%Z. { rewrite <- Z.pow_add_r. rewrite <- H2. reflexivity. lia. lia. } assert (0 <= wordVal0 / 2 ^ Z.of_nat (n - x) < 2 ^ Z.of_nat x)%Z. { rewrite H5 in H1. destruct H1. apply Zdiv_lt_upper_bound in H6. split. apply Z.div_pos. auto. lia. auto. apply Z.pow_pos_nonneg. lia. lia. } assert (0 <= wordVal / 2 ^ Z.of_nat (n - x) < 2 ^ Z.of_nat x)%Z. { rewrite H5 in H0. destruct H0. apply Zdiv_lt_upper_bound in H7. split. apply Z.div_pos. auto. lia. auto. apply Z.pow_pos_nonneg. lia. lia. } apply Z.mod_small in H6. rewrite H6 in H. apply Z.mod_small in H7. rewrite H7 in H. rewrite Z.ltb_lt. apply(Z_lt_div' _ _ P1 H). Qed. Lemma truncMsbLtFalse : forall (n x : nat) (w1 w2 : word n), (wordVal _ (@truncMsb x _ w1) < wordVal _ (@truncMsb x _ w2))%Z -> wltu w2 w1 = false. Proof. intros. specialize (truncMsbLtTrue _ _ _ _ H). intros. unfold wltu in *. rewrite Z.ltb_lt in *. rewrite Z.ltb_nlt. lia. Qed. Theorem wplus_unit : forall sz (x : word sz), wadd (ZToWord sz 0) x = x. Proof. intros. arithmetizeWord. lia. Qed. Lemma boundProofZIff : forall (sz : nat) (w : Z), (w mod 2 ^ Z.of_nat sz)%Z = w <-> (0 <= w < 2 ^ Z.of_nat sz)%Z. Proof. split; intros. - apply boundProofZ; auto. - apply Z.mod_small; auto. Qed. Lemma wones_wzero : forall sz, (sz > 0) -> wones sz <> ZToWord sz 0. Proof. repeat intro. eapply (f_equal (wordVal _)) in H0. arithmetizeWord. simpl in *. assert (2 ^ Z.of_nat sz > 1)%Z. { pose proof (Z.pow_gt_1 2 (Z.of_nat sz)). lia. } rewrite 2 Z.mod_small in H0; lia. Qed. Lemma wordToZ_ZToWord: forall (sz : nat) (w : Z), (0 <= w < Z.pow 2 (Z.of_nat sz))%Z -> wordVal _ (ZToWord sz w) = w. Proof. intros. arithmetizeWord. simpl in *. apply Z.mod_small. auto. Qed. Lemma wordToNat_natToWord : forall (sz : nat) (w : nat), (w < 2 ^ sz)%nat -> wordToNat (natToWord sz w) = w. Proof. intros. unfold wordToNat. unfold natToWord. arithmetizeWord. simpl. rewrite Z.mod_small. rewrite Nat2Z.id. auto. split; try lia. rewrite pow2_of_nat. apply Nat2Z.inj_lt. auto. Qed. Lemma truncLsb_concat : forall sz1 sz2 (w1 : word sz1) (w2 : word sz2), @truncLsb sz2 (sz1 + sz2) (wconcat w1 w2) = w2. Proof. repeat intro. arithmetizeWord. specialize (@Zpow_lt_add wordVal (Z.of_nat sz1) (Z.of_nat sz2) (Zle_0_nat sz2) (Zle_0_nat sz1) H); intros. assert (0 <= wordVal0)%Z. { lia. } assert (0 <= wordVal)%Z. { lia. } specialize (@Zmul_add_0_lt wordVal0 wordVal (Z.of_nat sz1) (Z.of_nat sz2) H2 (Zle_0_nat sz1) (Zle_0_nat sz2) H3 H0 H H1); intros. specialize (Zmod_small _ _ H4); intros. rewrite Nat2Z.inj_add. rewrite H5. rewrite <- Zplus_mod_idemp_l. rewrite Z_mod_mult. simpl; auto. Qed. Lemma truncMsb_concat : forall sz1 sz2 (w1 : word sz1) (w2 : word sz2), @truncMsb sz1 (sz1 + sz2) (wconcat w1 w2) = w1. Proof. repeat intro. arithmetizeWord. specialize (@Zpow_lt_add wordVal0 (Z.of_nat sz2) (Z.of_nat sz1) (Zle_0_nat sz1) (Zle_0_nat sz2) H0); intros. assert (0 <= wordVal0)%Z. { lia. } assert (0 <= wordVal)%Z. { lia. } specialize (@Zpow_lt_add wordVal (Z.of_nat sz1) (Z.of_nat sz2) (Zle_0_nat sz2) (Zle_0_nat sz1) H); intros. specialize (@Zmul_add_0_lt wordVal0 wordVal (Z.of_nat sz1) (Z.of_nat sz2) H2 (Zle_0_nat sz1) (Zle_0_nat sz2) H3 H0 H H4); intros. specialize (Zmod_small _ _ H5); intros. rewrite Nat2Z.inj_add. rewrite H6. rewrite Z.add_comm. rewrite minus_plus. rewrite Z_div_plus. rewrite <- wordBound. rewrite Zmod_div. simpl; auto. lia. Qed. Lemma word1_neq (w: word 1): w <> (ZToWord 1 0) -> w <> (ZToWord 1 1) -> False. Proof. intros. apply word0_neq in H. contradiction. Qed. Lemma truncLsb_fits_ZToWord n sz: (0 <= n < Z.pow 2 (Z.of_nat sz))%Z -> (@truncLsb sz (sz+1) (ZToWord (sz + 1) n) = ZToWord sz n). Proof. intro. unfold truncLsb. simpl. rewrite Zmod_small; auto. destruct H. split; auto. rewrite Nat2Z.inj_add. rewrite Z.pow_add_r. rewrite Z.pow_1_r; lia. lia. lia. Qed. Theorem concat_split : forall sz1 sz2 (w : word (sz1 + sz2)), @wconcat _ _ _ (@truncMsb sz1 (sz1 + sz2) w) (@truncLsb sz2 (sz1 + sz2) w) = w. Proof. intros. arithmetizeWord. erewrite minus_plus, Z.add_comm, Z.mul_comm, <- Z.rem_mul_r. - erewrite <- Z.pow_add_r, <- Nat2Z.inj_add, Nat.add_comm; try apply Nat2Z.is_nonneg. repeat rewrite wordBound; auto. - intro. specialize (Z_of_nat_pow_2_gt_0 sz2) as P0; lia. - specialize (Z_of_nat_pow_2_gt_0 sz1) as P0; lia. Qed. Import Word.Notations. Open Scope word_scope. Hint Rewrite Zplus_mod_idemp_r Z_mod_plus_full Zplus_mod_idemp_l: distributeMod. Hint Rewrite Zminus_mod_idemp_r Zminus_mod_idemp_l: distributeMod. Hint Rewrite Z_mod_mult Zmult_mod_idemp_r Zmult_mod_idemp_l Zmult_mod_distr_l Zmult_mod_distr_r: distributeMod. Hint Rewrite <- Zplus_mod Zminus_mod Zmult_mod: distributeMod. Lemma wminus_plus_distr: forall {sz} (x y z: word sz), x ^- (y ^+ z) = x ^- y ^- z. Proof. intros. arithmetizeWord; autorewrite with distributeMod. f_equal. lia. Qed. Lemma wminus_def : forall sz (x y : word sz), x ^- y = x ^+ ^~ y. Proof. intros. arithmetizeWord. autorewrite with distributeMod. rewrite <- Zplus_mod_idemp_r. rewrite <- (Zminus_mod_idemp_l (2 ^ Z.of_nat sz) wordVal _). rewrite Z_mod_same_full. simpl in *. autorewrite with distributeMod. f_equal. Qed. Lemma wneg_wnot: forall sz (w : word sz), wnot w = wneg w ^- (ZToWord _ 1). Proof. intros. arithmetizeWord. autorewrite with distributeMod. f_equal. Qed. Lemma wplus_assoc : forall sz (x y z : word sz), x ^+ (y ^+ z) = x ^+ y ^+ z. Proof. intros. arithmetizeWord; autorewrite with distributeMod. f_equal. lia. Qed. Lemma wplus_comm : forall sz (x y : word sz), x ^+ y = y ^+ x. Proof. intros. arithmetizeWord; autorewrite with distributeMod. f_equal. lia. Qed. Lemma wminus_diag : (forall sz (x : word sz), x ^- x = ZToWord sz 0). Proof. intros. arithmetizeWord; f_equal; lia. Qed. Lemma wminus_wplus_undo : forall sz (a b : word sz), a ^- b ^+ b = a. Proof. intros. arithmetizeWord. rewrite Zplus_mod_idemp_l, Z.mod_small; lia. Qed. Lemma move_wplus_wminus : (forall sz (x y z : word sz), x ^+ y = z -> x = z ^- y). Proof. intros. arithmetizeWord. simpl in *; subst. autorewrite with distributeMod. assert (wordVal1 + wordVal0 - wordVal0 = wordVal1)%Z by lia. rewrite H3. lia. Qed. Lemma word_cancel_l sz (a b c: word sz): a = b -> c ^+ a = c ^+ b. Proof. intros. arithmetizeWord; autorewrite with distributeMod. inversion H; subst. f_equal. Qed. Lemma word_cancel_r sz (a b c: word sz): a = b -> a ^+ c = b ^+ c. Proof. intros. arithmetizeWord; autorewrite with distributeMod. simpl in *. inversion H; subst. f_equal. Qed. Lemma word_cancel_m sz (a b c a' b': word sz): a ^+ a' = b ^+ b'-> a ^+ c ^+ a' = b ^+ c ^+ b'. Proof. intros. assert (sth: a ^+ c ^+ a' = a ^+ a'^+ c ). rewrite <- wplus_assoc. rewrite wplus_comm with (y := a'). rewrite wplus_assoc. reflexivity. rewrite sth. rewrite H. rewrite <- wplus_assoc. rewrite wplus_comm with (x := b'). rewrite wplus_assoc. reflexivity. Qed. Lemma wconcat_1_0 : (@wconcat 1 0 1 (ZToWord 1 1) (ZToWord 0 0)) = (ZToWord 1 1). Proof. arithmetizeWord. lia. Qed. Lemma wconcat_w_0 : forall sz (w : word sz), (@wconcat sz 0 sz w (ZToWord 0 0)) = w. Proof. intros. arithmetizeWord. rewrite Zmod_0_l. rewrite <- Zred_factor0. rewrite Z.add_0_r. auto. Qed. Lemma wconcat_0_sz1_w : forall sz (w : word sz), (@wconcat 1 sz (sz+1) (ZToWord 1 0) w) = (ZToWord (sz+1) (wordVal _ w)). Proof. intros. arithmetizeWord. f_equal. Qed. Lemma eq_word {sz} {x y : word sz} : x = y -> wordVal _ x = wordVal _ y. Proof. intros. destruct x as [x px]. destruct y as [y py]. simpl in *; subst; auto. inversion H; auto. Qed. Lemma getWordVal : forall n x, (0 <= x < (2 ^ (Z.of_nat n)))%Z -> wordVal n (ZToWord n x) = x. Proof. intros. arithmetizeWord. simpl. apply Zmod_small; auto. Qed. Lemma concat_shiftl_plus_n n x: (0 <= x < 2 ^ (Z.of_nat n))%Z -> (@wconcat 1 n (n+1) (ZToWord 1 1) (ZToWord n x)) = (ZToWord (n + 1) (2 ^ (Z.of_nat n))) ^+ ZToWord (n + 1) x. Proof. intros. apply eq_wordVal. apply eq_word. unfold wconcat. unfold wadd. f_equal. assert (wordVal 1 (ZToWord 1 1) = 1)%Z. { simpl. apply Z.mod_1_l. rewrite Z.pow_pos_fold. rewrite Z.pow_1_r. lia. } rewrite H0. repeat (rewrite getWordVal). lia. apply Zpow_successor; auto. apply Zpow_successor_itself. auto. Qed. Lemma concat_wplus sz (w1 w2: word sz): forall sz' (w': word sz'), (0 <= (wordVal _ w1) + (wordVal _ w2) < 2 ^ Z.of_nat sz)%Z -> wconcat w' (w1 ^+ w2) = @wconcat sz' sz (sz'+sz) w' w1 ^+ wconcat (ZToWord sz' 0) w2. Proof. intros. arithmetizeWord. rewrite (Zmod_small (wordVal1 + wordVal0) _). rewrite <- Zplus_assoc_reverse. rewrite (Zplus_mod (wordVal * 2 ^ Z.of_nat sz + wordVal1) wordVal0 _). lia. auto. Qed. Lemma wminus_inv : forall sz (x : word sz), x ^+ ^~ x = ZToWord sz 0. Proof. intros. arithmetizeWord; autorewrite with distributeMod. rewrite Zplus_mod. rewrite Zminus_mod. rewrite Z_mod_same_full, Z.sub_0_l, Zplus_mod_idemp_r, Z.add_opp_r, Zminus_mod_idemp_r. rewrite (Zmod_small _ _ H); rewrite Z.sub_diag; reflexivity. Qed. Lemma wminus_cancel : forall sz (x y : word sz), (wordVal _ x + wordVal _ y < 2 ^ Z.of_nat sz)%Z -> x ^+ y ^- y = x. Proof. intros. arithmetizeWord. simpl in *. rewrite Z.mod_small; try lia. rewrite Z.mod_small; try lia. split. rewrite Z.mod_small. lia. split; lia. rewrite Z.mod_small; lia. Qed. Lemma wadd_wzero_1: forall sz (w: word sz), w ^+ (ZToWord _ 0) = w. Proof. intros. arithmetizeWord; autorewrite with distributeMod. rewrite Z.add_0_r. auto. Qed. Lemma move_wadd_wminus sz (a b c: word sz): a ^+ b = c <-> a = c ^- b. Proof. split; intro. + rewrite <- H. rewrite wminus_def. rewrite <- wplus_assoc. rewrite wminus_inv. rewrite wadd_wzero_1. reflexivity. + rewrite H. rewrite wminus_def. rewrite <- wplus_assoc. rewrite wplus_comm with (x:= ^~ b). rewrite wminus_inv. rewrite wadd_wzero_1. reflexivity. Qed. Lemma wneg_idempotent: forall {sz} (w: word sz), ^~ (^~ w) = w. Proof. intros. arithmetizeWord; autorewrite with distributeMod. rewrite <- Zminus_mod_idemp_l. rewrite Z_mod_same_full. rewrite Z.sub_0_l. rewrite Z.opp_sub_distr. rewrite Z.add_opp_l. rewrite <- Zminus_mod_idemp_r. rewrite Z_mod_same_full. rewrite Z.sub_0_r. auto. Qed. Lemma ZToWord_plus : forall sz n m, ZToWord sz (n + m) = ZToWord _ n ^+ ZToWord _ m. Proof. intros. arithmetizeWord; autorewrite with distributeMod. f_equal. Qed. (* The ring of size-0 words is the trivial ring, with 0 = 1 *) Lemma ws_zero_trivial (w : word 0) : w = ZToWord 0 1. Proof. arithmetizeWord. cbn in *. rewrite Z.mod_1_r in wordBound. auto. Qed. Lemma wone_wmul : forall sz w, wmul (ZToWord sz 1) w = w. Proof. intros. case (zerop sz) as [H_wz | H_wpos]. + subst. rewrite ws_zero_trivial. auto. + arithmetizeWord. repeat rewrite Z.mod_small; try lia; split; intuition; apply Z2Nat.inj_lt; try lia; simpl; rewrite <- Zpow_of_nat; rewrite Nat2Z.id; apply pow2_gt_1; auto. Qed. Lemma wmul_comm : forall sz (x y : word sz), x ^* y = y ^* x. Proof. intros. arithmetizeWord; autorewrite with distributeMod. f_equal. lia. Qed. Lemma split_concat : forall sz1 sz2 (w : word (sz1 + sz2)), wconcat (wsplitl sz1 sz2 w) (wsplitr sz1 sz2 w) = w. Proof. intros. unfold wconcat. unfold wsplitl. unfold wsplitr. specialize Z_of_nat_pow_2_gt_0 with sz2 as Hp. simpl. arithmetizeWord. rewrite Zmod_mod. specialize Z.mod_small with (wordVal / 2 ^ Z.of_nat sz2)%Z (2 ^ Z.of_nat sz1)%Z as Hs. rewrite Hs. specialize Z_div_mod_eq with wordVal (2 ^ Z.of_nat sz2)%Z as Hmod. rewrite Z.mul_comm in Hmod. rewrite <- Hmod. rewrite Z.mod_small; try lia. auto. split; try apply Z.div_pos; intuition. apply Z.div_lt_upper_bound; intuition. rewrite <- Z.pow_add_r; try lia. rewrite <- Nat2Z.inj_add. rewrite Nat.add_comm. lia. Qed. (* Moved from FpuProperties.v *) Lemma wordToNat_split2 : forall sz1 sz2 (w : word (sz1 + sz2)), wordToNat (@truncMsb sz2 _ w) = wordToNat w / (2 ^ sz1). Proof. intros. unfold natToWord, truncMsb, wordToNat. arithmetizeWord. simpl. rewrite Nat.add_sub, Z.mod_small. - rewrite Zdiv_div; try lia. + rewrite pow2_of_nat, Nat2Z.id; reflexivity. + apply (Z.gt_lt _ _ (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _)))). - split. + apply Z.div_pos; try lia. apply (Z.gt_lt _ _ (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _)))). + rewrite (Zdiv_unique (2 ^ Z.of_nat (sz1 + sz2)) (2 ^ Z.of_nat (sz1)) (2 ^ Z.of_nat (sz2)) 0%Z). * apply Z_lt_div2; try lia. -- apply (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _))). -- apply Znumtheory.Zdivide_mod, pow_divide. * split; try lia. apply (Z.gt_lt _ _ (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _)))). * rewrite Nat2Z.inj_add, Z.pow_add_r; lia. Qed. Lemma split2_combine : forall sz1 sz2 (w : word sz1) (z : word sz2), @truncMsb sz2 (sz1 + sz2) (wconcat z w) = z. Proof. intros. arithmetizeWord. rewrite Nat.add_sub, (Zmod_small _ (2 ^ Z.of_nat (_ + _))). - rewrite <- (Zdiv_unique _ _ wordVal wordVal0); lia. - split. + apply Z.add_nonneg_nonneg; [apply Z.mul_nonneg_nonneg|]; lia. + apply (Z.lt_le_trans _ ((2 ^ Z.of_nat sz1) * (wordVal + 1)) _ ); [| rewrite Nat2Z.inj_add, Z.pow_add_r]; try lia. apply Z.mul_le_mono_nonneg_l; lia. Qed. Lemma countLeadingZerosWord_le_len : forall no ni, ni < 2 ^ no -> forall w : word ni, @wleu _ (countLeadingZerosWord _ no w) (natToWord no ni) = true. Proof. unfold wleu; setoid_rewrite Z.leb_le. induction ni; intros; [simpl; lia|]. cbv [countLeadingZerosWord]. destruct (weq _ _). - fold (countLeadingZerosWord ni no (truncLsb (nat_cast (fun n : nat => word n) (eq_sym (Nat.add_1_r ni)) w))). unfold natToWord. rewrite <- (Nat.add_1_l ni) at 3; rewrite Nat2Z.inj_add, ZToWord_plus. simpl; repeat rewrite Zplus_mod_idemp_r; repeat rewrite Zplus_mod_idemp_l. repeat rewrite Z.mod_small. + apply Zplus_le_compat_l. apply (Z.le_trans _ (wordVal no (natToWord no ni)) _). * apply IHni; lia. * simpl; rewrite Z.mod_small; [lia|]. split; [apply Nat2Z.is_nonneg|]. rewrite <- Zpow_of_nat; apply inj_lt; lia. + split; try lia. specialize (inj_lt _ _ H) as P0. rewrite Zpow_of_nat, <- Nat.add_1_l, Nat2Z.inj_add in P0; lia. + assert (forall no w, (0 <= wordVal no w < 2 ^ Z.of_nat no)%Z) as P0. { clear; intros. arithmetizeWord; assumption. } split. * apply Z.add_nonneg_nonneg; [lia | apply P0]. * apply (Z.le_lt_trans _ (Z.of_nat (S ni)) _). -- rewrite <- (Nat.add_1_l ni) at 2. rewrite Nat2Z.inj_add, <- Z.add_le_mono_l. assert (Z.of_nat ni = wordVal no (natToWord no ni)) as P1. { simpl; symmetry. apply Z.mod_small; split; try lia. rewrite <- Zpow_of_nat. apply inj_lt; lia. } rewrite P1; apply IHni; lia. -- rewrite <- Zpow_of_nat. apply inj_lt; assumption. - arithmetizeWord. cbv [natToWord ZToWord]. repeat rewrite (Zmod_small);[ |split |split ]; try lia. + rewrite <- Zpow_of_nat. apply inj_lt; assumption. + apply (Z.gt_lt _ _ (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _)))). Qed. Lemma wneg_wplus_distr : forall sz (w1 w2 : word sz), ^~ (w1 ^+ w2) = ^~ w1 ^+ ^~ w2. Proof. intros. arithmetizeWord. rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l. assert ((2 ^ Z.of_nat sz - wordVal0 + (2 ^ Z.of_nat sz - wordVal)) = (2 * 2 ^ Z.of_nat sz - (wordVal0 + wordVal)))%Z as P0. { lia. } rewrite P0. destruct (Z_lt_le_dec (wordVal0 + wordVal) (2 ^ Z.of_nat sz)). - rewrite (Zmod_small (_ + _) _); try lia. rewrite Zminus_mod, Z_mod_same_full, Z.sub_0_l. rewrite Zminus_mod, (Znumtheory.Zdivide_mod (2*_)); auto. exists 2%Z; reflexivity. - rewrite (Zmod_eq_full (_ + _) _), <- (Zdiv_unique (wordVal0 + wordVal) (2 ^ Z.of_nat sz) 1 ((wordVal0 + wordVal) - 2 ^ Z.of_nat sz)); try lia. f_equal; lia. Qed. Lemma wordToNat_split1 : forall sz1 sz2 (w : word (sz1 + sz2)), wordToNat (@truncLsb sz1 _ w) = (wordToNat w) mod (2 ^ sz1). Proof. intros. unfold wordToNat. arithmetizeWord. simpl. rewrite Zmod_mod'; try lia. - rewrite <- Zpow_of_nat, Nat2Z.id; reflexivity. - apply (Z.gt_lt _ _ (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _)))). Qed. Lemma wordToNat_wplus : forall sz (w1 w2 : word sz), wordToNat (w1 ^+ w2) = (wordToNat w1 + wordToNat w2) mod (2 ^ sz). Proof. intros. unfold wordToNat. arithmetizeWord. simpl. rewrite Zmod_mod'; try lia. rewrite <- Zpow_of_nat, Nat2Z.id, Z2Nat.inj_add; lia. Qed. Lemma wordToNat_wnot : forall sz (a : word sz), wordToNat (wnot a) = 2 ^ sz - wordToNat a - 1. Proof. intros. unfold wordToNat. arithmetizeWord. simpl. rewrite Zminus_mod_idemp_l. rewrite (Z.mod_small); try lia. repeat rewrite Z2Nat.inj_sub; try lia. repeat f_equal; try lia. rewrite <- Zpow_of_nat, Nat2Z.id; reflexivity. Qed. Lemma countLeadingZerosWord_lt_len no ni : ni < 2 ^ no -> forall w : word ni, w <> wzero ni -> (wltu (countLeadingZerosWord _ no w) (natToWord no ni) = true). Proof. unfold wltu. setoid_rewrite <- Zlt_is_lt_bool. induction ni; intros. - exfalso; apply H0. apply unique_word_0. - cbv [countLeadingZerosWord]. destruct (weq _ _). + fold (countLeadingZerosWord ni no (truncLsb (nat_cast (fun n : nat => word n) (eq_sym (Nat.add_1_r ni)) w))). unfold natToWord. rewrite <- (Nat.add_1_l ni) at 3; rewrite Nat2Z.inj_add, ZToWord_plus. simpl; repeat rewrite Zplus_mod_idemp_r; repeat rewrite Zplus_mod_idemp_l. repeat rewrite Z.mod_small. * apply Zplus_lt_compat_l. apply (Z.lt_le_trans _ (wordVal no (natToWord no ni)) _). -- apply IHni; try lia. rewrite Nat.add_1_r. intro. specialize (concat_split 1 ni w) as P0. unfold truncMsb in *. simpl in *. rewrite Nat.add_1_r, Nat.sub_succ, Nat.sub_0_r in e. rewrite Nat.sub_0_r in P0. simpl in e. rewrite nat_cast_same in e, H1; rewrite e, H1 in P0. apply H0; rewrite <- P0. arithmetizeWord. repeat rewrite Z.mod_small; simpl in *; try split; try lia; try apply (Z.gt_lt _ _ (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _)))). -- arithmetizeWord; simpl. simpl; rewrite Z.mod_small; [lia| split; try lia]. rewrite <- Zpow_of_nat; apply inj_lt; lia. * split; try lia. specialize (inj_lt _ _ H) as P0. rewrite Zpow_of_nat, <- Nat.add_1_l, Nat2Z.inj_add in P0; lia. * assert (forall no w, (0 <= wordVal no w < 2 ^ Z.of_nat no)%Z) as P0. { clear; intros. arithmetizeWord; assumption. } split. -- apply Z.add_nonneg_nonneg; [lia | apply P0]. -- apply (Z.lt_trans _ (Z.of_nat (S ni)) _). ++ rewrite <- (Nat.add_1_l ni) at 2. rewrite Nat2Z.inj_add, <- Z.add_lt_mono_l. assert (Z.of_nat ni = wordVal no (natToWord no ni)) as P1. { simpl; symmetry. apply Z.mod_small; split; try lia. rewrite <- Zpow_of_nat. apply inj_lt; lia. } rewrite P1; apply IHni; try lia. rewrite Nat.add_1_r. intro. specialize (concat_split 1 ni w) as P2. unfold truncMsb in *. simpl in *. rewrite Nat.add_1_r, Nat.sub_succ, Nat.sub_0_r in e. rewrite Nat.sub_0_r in P2. simpl in e. rewrite nat_cast_same in e, H1; rewrite e, H1 in P2. apply H0; rewrite <- P2. arithmetizeWord. repeat rewrite Z.mod_small; simpl in *; try split; try lia; apply (Z.gt_lt _ _ (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _)))). ++ rewrite <- Zpow_of_nat. apply inj_lt; assumption. + arithmetizeWord. cbv [natToWord ZToWord]. repeat rewrite (Zmod_small);[ |split |split ]; try lia. * rewrite <- Zpow_of_nat. apply inj_lt; assumption. * apply (Z.gt_lt _ _ (Z_pow_2_gt_0 (Z.le_ge _ _ (Nat2Z.is_nonneg _)))). Qed. Lemma combine_shiftl_plus_n n x : x < 2 ^ n -> wconcat (natToWord 1 1) (natToWord n x) = natToWord (n + 1) (2 ^ n) ^+ natToWord (n + 1) x. Proof. intros. arithmetizeWord. destruct (2 ^ Z.of_nat n)%Z eqn:G; try(specialize (Z_of_nat_pow_2_gt_0 n) as P0; lia). rewrite (Z.mod_small _ (Z.pos _)). - rewrite Zplus_mod_idemp_l, Zplus_mod_idemp_r. f_equal. rewrite <- G, pow2_of_nat; reflexivity. - rewrite <- G; split. + apply Nat2Z.is_nonneg. + rewrite pow2_of_nat. apply inj_lt; assumption. Qed. Lemma combine_wplus sz (w1 w2 : word sz) : wordToNat w1 + wordToNat w2 < 2 ^ sz -> forall sz' (w' : word sz'), @wconcat _ _ (sz + sz') w' (w1 ^+ w2) = wconcat w' w1 ^+ wconcat (natToWord sz' 0) w2. Proof. unfold wordToNat; intros. arithmetizeWord. rewrite Zplus_mod_idemp_l, Zplus_mod_idemp_r, (Z.mod_small (wordVal1 + _) _), Z.add_assoc; try split; try lia. rewrite <- Z2Nat.inj_add in H; try lia. rewrite Z2Nat.inj_lt, <- Zpow_of_nat, Nat2Z.id; lia. Qed. Lemma pow2_wneg sz : wneg (natToWord (S sz) (2 ^ sz)) = natToWord (S sz) (2 ^ sz). Proof. arithmetizeWord. rewrite Zminus_mod_idemp_r. f_equal. rewrite Z.pow_pos_fold, Zpos_P_of_succ_nat, <- Nat2Z.inj_succ, <- Nat.add_1_l, Nat2Z.inj_add, Z.pow_add_r; try lia. repeat rewrite <- Zpow_of_nat. rewrite Nat.pow_1_r; lia. Qed. Lemma wmsb_true_split2_wones sz (w : word (sz + 1)) b : wmsb _ w b = true -> wones _ = @truncMsb 1 _ w. Proof. unfold wmsb. assert (sth : sz + 1 <> 0) by lia. apply Nat.eqb_neq in sth. rewrite sth. unfold wordToNat. intros. apply Nat.ltb_lt in H. arithmetizeWord. destruct H0. rewrite Z2Nat.inj_lt, <- Zpow_of_nat, Nat2Z.id in H1; try lia. rewrite Nat.div_str_pos_iff in H;[|specialize (pow2_zero (sz + 1 - 1))]; try lia. rewrite Nat.add_comm, minus_plus in H. rewrite Nat.add_comm, minus_plus, Z.mod_small; try rewrite Z.pow_pos_fold; try lia. rewrite Z.mod_small. - apply (Zdiv_unique _ _ _ (wordVal - 2 ^ Z.of_nat sz)); try split; rewrite pow2_of_nat, <- (Z2Nat.id wordVal); try lia. rewrite <- Nat2Z.inj_sub, <- Nat2Z.inj_lt; try lia. rewrite Nat.pow_add_r in H1. simpl in H1; lia. - assert (Z.pow_pos 2 1 <> 0)%Z as P0. { try rewrite Z.pow_pos_fold. lia. } assert ((wordVal / 2 ^ Z.of_nat sz)/(Z.pow_pos 2 1) = 0)%Z as P1. { replace (Z.pow_pos 2 1) with 2%Z; auto. rewrite Zdiv_Zdiv; try lia. - replace 2%Z with (2 ^ 1)%Z at 2; try lia. rewrite <- Z.pow_add_r; try lia. rewrite <- (Z2Nat.id 1); try lia. rewrite <- (Z2Nat.id wordVal); try lia. rewrite <- (Z2Nat.id 0); try lia. rewrite <- Nat2Z.inj_add, pow2_of_nat, <- div_Zdiv. + rewrite Nat2Z.inj_iff. replace (Z.to_nat 1) with 1; auto. replace (Z.to_nat 0) with 0; auto. rewrite Nat.div_small_iff; auto. specialize (pow2_zero (sz + 1)) as TMP; lia. + specialize (pow2_zero (sz + (Z.to_nat 1))) as TMP; lia. - apply Z.pow_nonneg; lia. } destruct (Z.div_small_iff (wordVal / 2 ^ Z.of_nat sz) _ P0) as [P2 P3]; clear P3. destruct (P2 P1); auto. exfalso; try rewrite Z.pow_pos_fold in *; lia. Qed. Lemma neq0_wneq0 sz (n : word sz) : wordToNat n <> 0 <-> n <> natToWord sz 0. Proof. unfold wordToNat, natToWord. split; repeat intro. + simpl in *. rewrite H0 in H. simpl in H. auto. + apply H. arithmetizeWord. rewrite Z.mod_small; try lia; try (rewrite <- Z2Nat.inj_iff; try lia; rewrite H0; auto). Qed. Lemma wmsb_1_natToWord sz n default : 2 ^ sz <= n < 2 * 2 ^ sz -> wmsb _ (natToWord (S sz) n) default = true. Proof. intros. unfold wmsb. destruct (Nat.eqb _ _) eqn:G. - exfalso. rewrite Nat.eqb_eq in G; discriminate. - rewrite Nat.ltb_lt. rewrite Nat.div_str_pos_iff. + unfold wordToNat, natToWord; simpl. rewrite Z.pow_pos_fold, Zpos_P_of_succ_nat, <- Nat2Z.inj_succ, <- (Nat.add_1_l sz), Nat2Z.inj_add, Z.pow_add_r; try lia. destruct H. rewrite <- minus_n_O, Z.mod_small. * rewrite Nat2Z.id; assumption. * split; [apply Nat2Z.is_nonneg|]. repeat rewrite <- Zpow_of_nat. rewrite <- Nat2Z.inj_mul. apply inj_lt. assumption. + intro. specialize (pow2_zero (S sz - 1)); lia. Qed. Unset Implicit Arguments. Lemma natToWord_wordToNat sz (w : word sz) : natToWord sz (wordToNat w) = w. Proof. unfold natToWord, wordToNat. rewrite Z2Nat.id; arithmetizeWord; intuition. Qed. Set Implicit Arguments. Lemma wzero_wones : forall sz, sz >= 1 -> natToWord sz 0 <> wones _. Proof. intros. unfold natToWord. simpl. apply weqb_false. unfold weqb. apply Z.eqb_neq. simpl. rewrite Z.mod_0_l, Z.mod_small; try split; try lia. rewrite <- Zpow_of_nat. assert (sth : (1 < Z.of_nat (2 ^ sz))%Z). { replace 1%Z with (Z.of_nat 1); auto. apply Nat2Z.inj_lt. apply one_lt_pow2'. lia. } lia. assert (sth : (1 <= Z.of_nat (2 ^ sz))%Z). { replace 1%Z with (Z.of_nat 1); auto. apply Nat2Z.inj_le. apply one_le_pow2. } rewrite <- Zpow_of_nat. lia. apply Z.pow_nonzero; lia. Qed. Lemma combine_wones_WO : forall (sz : nat) (w : word sz), w <> wzero sz -> @truncMsb 1 (sz + 1) (wconcat (natToWord 1 0) (wones sz) ^+ wconcat (natToWord 1 0) w) = natToWord 1 1. Proof. intros. arithmetizeWord. simpl. assert (Z.pow_pos 2 1 = 2)%Z by auto; rewrite !H1; simpl; clear H1. assert (1 mod 2 = 1)%Z by auto; rewrite H1. rewrite Nat.add_sub. rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, (Zmod_small (_ - 1) _); [|lia]. rewrite (Zmod_small (_ + wordVal)). - assert (0 <= wordVal - 1 < 2 ^ Z.of_nat sz)%Z as P0. { split; [|lia]. apply Zlt_0_le_0_pred. destruct H0; destruct (Zle_lt_or_eq _ _ H0); auto. exfalso; apply H. rewrite <- H3, Zmod_0_l; reflexivity. } erewrite <- (Z.div_unique_pos _ _ 1 _ P0); [assumption|lia]. - rewrite Nat2Z.inj_add, Z.pow_add_r; simpl; try rewrite Z.pow_pos_fold; lia. Qed. Lemma wones_pow2_minus_one : forall sz, wordToNat (wones sz) = 2 ^ sz - 1. Proof. intros. unfold wordToNat. arithmetizeWord. simpl. rewrite Z.mod_small; try split; try lia. rewrite Z2Nat.inj_sub; try lia. rewrite <- Zpow_of_nat, Nat2Z.id; auto. assert (H : (1 <= 2 ^ Z.of_nat sz)%Z) by (apply Zpow_1_le; lia). lia. Qed. Lemma split1_combine_wplus : forall sz1 sz2 (w11 w21 : word sz1) (w12 w22 : word sz2), @truncLsb sz1 (sz1 + sz2) (wconcat w12 w11 ^+ wconcat w22 w21) = w11 ^+ w21. Proof. intros. unfold truncLsb. arithmetizeWord. rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Nat2Z.inj_add, Z.pow_add_r, <- Znumtheory.Zmod_div_mod; try lia. - assert ((wordVal0 * 2 ^ Z.of_nat sz1 + wordVal2 + (wordVal * 2 ^ Z.of_nat sz1 + wordVal1)) = (wordVal2 + wordVal1 + ((wordVal0 + wordVal) * 2 ^ Z.of_nat sz1)))%Z as P0 by lia. rewrite P0, Z_mod_plus_full. reflexivity. - apply Z.mul_pos_pos; try lia. - rewrite Z.mul_comm; eexists; reflexivity. Qed. Lemma wordToNat_combine : forall sz1 (w1 : word sz1) sz2 (w2 : word sz2) outSz, outSz = sz1 + sz2 -> wordToNat (@wconcat _ _ outSz w2 w1) = wordToNat w1 + 2 ^ sz1 * wordToNat w2. Proof. intros. unfold wordToNat. arithmetizeWord; simpl. rewrite H, Zmod_small. - rewrite Z2Nat.inj_add, Z2Nat.inj_mul, pow2_of_nat, Nat2Z.id ; try lia. apply Z.mul_nonneg_nonneg; lia. - split. + apply Z.add_nonneg_nonneg; [|lia]. apply Z.mul_nonneg_nonneg; lia. + rewrite Nat2Z.inj_add, Z.pow_add_r; try lia. apply (Z.lt_le_trans _ ( 2 ^ Z.of_nat sz1 * (wordVal + 1)) _);[lia|]. rewrite <- Z.mul_le_mono_pos_l; lia. Qed. Lemma wordToNat_natToWord_idempotent' : forall sz n , n < 2 ^ sz -> wordToNat (natToWord sz n) = n. Proof. intros. unfold wordToNat, natToWord. simpl. rewrite <- Zpow_of_nat. rewrite <- mod_Zmod. rewrite Nat2Z.id. rewrite Nat.mod_small; auto. apply Nat.pow_nonzero; auto. Qed. Lemma wones_natToWord : forall sz, wones sz = natToWord sz (2 ^ sz - 1). Proof. intros. unfold natToWord, wones. arithmetizeWord. rewrite Nat2Z.inj_sub, Zpow_of_nat. auto. apply one_le_pow2. Qed. Lemma natToWord_plus : forall sz n m, natToWord sz (n + m) = natToWord sz n ^+ natToWord sz m. Proof. intros. unfold natToWord. arithmetizeWord. rewrite Nat2Z.inj_add, Zplus_mod. auto. Qed. Lemma natToWord_pow2_add : forall sz n, natToWord sz (n + 2 ^ sz) = natToWord sz n. Proof. intros. unfold natToWord. arithmetizeWord. rewrite Nat2Z.inj_add. rewrite Zpow_of_nat. rewrite Zplus_mod, Z_mod_same_full, Z.add_0_r. rewrite Zmod_mod. auto. Qed. Lemma split2_zero : forall sz1 sz2, @truncMsb sz2 (sz1 + sz2) (natToWord (sz1 + sz2) 0) = natToWord sz2 0. Proof. intros. unfold natToWord. simpl. arithmetizeWord. rewrite !Z.mod_0_l; auto; apply Z.pow_nonzero; lia. Qed. Lemma wordToNat_bound : forall sz (w : word sz), wordToNat w < 2 ^ sz. Proof. intros. unfold wordToNat. arithmetizeWord. apply Nat2Z.inj_lt. rewrite Z2Nat.id, Zpow_of_nat; intuition. Qed. Lemma wminus_minus : forall sz (a b : word sz), (wltu b a = true) -> wordToNat (a ^- b) = wordToNat a - wordToNat b. Proof. intros. unfold wordToNat, wltu in *. arithmetizeWord. simpl in *. rewrite Z.mod_small. rewrite Z2Nat.inj_sub; intuition. apply Z.ltb_lt in H. lia. Qed. Lemma Nat2Z_ZToWord : forall sz (n : nat), ZToWord sz (Z.of_nat n) = natToWord _ n. Proof. intros; auto. Qed. Lemma mod_sub' : forall a b, b <> 0 -> a < b * 2 -> a >= b -> a mod b = a - b. Proof. intros. rewrite <- (@mod_sub _ 1 _); try lia. rewrite Nat.mod_small; lia. Qed. Lemma wordVal_pos : forall sz (w : word sz), (0 <= wordVal _ w)%Z. Proof. intros. arithmetizeWord. lia. Qed. Lemma wordToNat_lt1 sz (a b : word sz) : wltu a b = true -> wordToNat a < wordToNat b. Proof. unfold wltu, wordToNat. intros. arithmetizeWord. simpl in *. apply Z.ltb_lt in H. apply Z2Nat.inj_lt; lia. Qed. Lemma wordToNat_natToWord_eqn sz n : wordToNat (natToWord sz n) = n mod (2 ^ sz). Proof. unfold wordToNat, natToWord. simpl. rewrite <- Zpow_of_nat. rewrite <- mod_Zmod. rewrite Nat2Z.id. auto. apply Nat.pow_nonzero; auto. Qed. Lemma move_wplus_wminus' sz (a b c : word sz) : a ^+ b = c <-> a = c ^- b. Proof. apply move_wadd_wminus. Qed. Lemma wltu_wordToNat sz (w w' : word sz) : wltu w w' = (wordToNat w wconcat (natToWord 1 0) (natToWord n x) = natToWord (n + 1) x. Proof. intros. unfold natToWord. simpl. arithmetizeWord. simpl. assert (H' : (Z.of_nat x < 2 ^ Z.of_nat n)%Z). { rewrite <- Zpow_of_nat. apply Nat2Z.inj_lt. auto. } assert (sth : (Z.of_nat x mod 2 ^ Z.of_nat n = Z.of_nat x)%Z). { apply Z.mod_small; lia. } rewrite sth. auto. Qed. Lemma split1_combine sz1 sz2 (w : word sz1) (z : word sz2) : @truncLsb sz1 (sz1 + sz2) (wconcat z w) = w. Proof. rewrite plus_comm. rewrite truncLsb_concat. auto. Qed. Lemma split1_fits_natToWord n sz: n < 2 ^ sz -> (@truncLsb sz _ (natToWord (sz + 1) n) = natToWord sz n). Proof. intro. rewrite <- combine_natToWord_wzero; auto. rewrite split1_combine; auto. Qed. Unset Implicit Arguments. Lemma getBool_weq sz (w1 w2: word sz): getBool (weq w1 w2) = true -> w1 = w2. Proof. intros. destruct (weq w1 w2); [auto | discriminate]. Qed. Lemma wor_comm width (x y : word width) : wor x y = wor y x. Proof. arithmetizeWord. rewrite Z.lor_comm; reflexivity. Qed. Lemma wor_assoc n (x y z : word n): wor x (wor y z) = wor (wor x y) z. Proof. arithmetizeWord. - rewrite (Zmod_small _ _ (Zlor_bounds _ H0 H)), (Zmod_small _ _ (Zlor_bounds _ H1 H0)), Z.lor_assoc; reflexivity. Qed. Lemma wltu_lt {n} (w1 w2 : word n): wltu w1 w2 = true <-> wordToNat w1 < wordToNat w2. Proof. rewrite wltu_wordToNat, Nat.ltb_lt; split; intro; auto. Qed. Lemma wltu_ge {n} (w1 w2 : word n): wltu w1 w2 = false <-> wordToNat w2 <= wordToNat w1. Proof. rewrite wltu_wordToNat, Nat.ltb_ge; split; intro; auto. Qed. ================================================ FILE: LibStruct.v ================================================ Require Import Kami.Syntax Kami.Notations. (* TODO: move to KamiStdLib? *) Definition extractArbitraryRange ty sz (inst: Bit sz ## ty) (range: nat * nat): Bit (fst range + 1 - snd range) ## ty := (LETE i <- inst ; RetE (ConstExtract (snd range) (fst range + 1 - snd range) (sz - 1 - fst range) (ZeroExtendTruncLsb _ #i)))%kami_expr. (* Useful Struct: TODO: move notation versions to StdLibKami*) Definition Maybe k := STRUCT_TYPE { "valid" :: Bool; "data" :: k }. Definition Pair (A B: Kind) := STRUCT_TYPE { "fst" :: A; "snd" :: B }. Definition Invalid {ty: Kind -> Type} {k} := (STRUCT { "valid" ::= $$ false ; "data" ::= $$ (getDefaultConst k) })%kami_expr. Local Open Scope kami_action. Local Open Scope kami_expr. Definition nullStruct: Kind := (Struct (fun i => @Fin.case0 _ i) (fun i => @Fin.case0 _ i)). Fixpoint BuildStructActionCont (ty: Kind -> Type) k n: forall (kinds : Fin.t n -> Kind) (names : Fin.t n -> string) (acts : forall i, ActionT ty (kinds i)) (cont: (forall i, Expr ty (SyntaxKind (kinds i))) -> ActionT ty k), ActionT ty k := match n return forall (kinds : Fin.t n -> Kind) (names : Fin.t n -> string) (acts : forall i, ActionT ty (kinds i)) (cont : (forall i, Expr ty (SyntaxKind (kinds i))) -> ActionT ty k), ActionT ty k with | 0 => fun kinds names acts cont => cont (fun i => @Fin.case0 (fun _ => Expr ty (SyntaxKind (kinds i))) i) | S m => fun kinds names acts cont => LETA next <- acts Fin.F1; @BuildStructActionCont ty k m (fun i => kinds (Fin.FS i)) (fun i => names (Fin.FS i)) (fun i => acts (Fin.FS i)) (fun exps => cont (fun i => match i in Fin.t (S m) return forall (ks: Fin.t (S m) -> Kind), ty (ks Fin.F1) -> (forall i: Fin.t m, Expr ty (SyntaxKind (ks (Fin.FS i)))) -> Expr ty (SyntaxKind (ks i)) with | Fin.F1 _ => fun ks next exps => #next | Fin.FS _ j => fun ks next exps => exps j end kinds next exps)) end. Definition BuildStructAction ty n (kinds: Fin.t n -> Kind) (names: Fin.t n -> string) (acts: forall i, ActionT ty (kinds i)) := BuildStructActionCont kinds names acts (fun x => Return (BuildStruct kinds names x)). Lemma WfConcatActionT_BuildStructActionCont: forall m k n kinds names acts cont, (forall (i:Fin.t n), WfConcatActionT (acts i) m) -> (forall x, WfConcatActionT (cont x) m) -> @WfConcatActionT type k (@BuildStructActionCont type k n kinds names acts cont) m. Proof. induction n; simpl; intros; auto. econstructor; [|intros; eapply IHn]; eauto. Qed. ================================================ FILE: Makefile ================================================ VS:=$(shell find . -type f -name '*.v') .PHONY: coq clean force coq: Makefile.coq.all $(VS) $(MAKE) -f Makefile.coq.all Makefile.coq.all: force $(COQBIN)coq_makefile -f _CoqProject $(VS) -o Makefile.coq.all force: clean:: Makefile.coq.all $(MAKE) -f Makefile.coq.all clean rm -rf *.v.d *.glob *.vo *~ *.hi *.o rm -f Makefile.coq.all Makefile.coq.all.conf ================================================ FILE: Notations.v ================================================ Require Import Kami.Syntax Kami.Lib.EclecticLib Kami.Tactics. Require Import Kami.Lib.NatStr. Require Import RecordUpdate.RecordSet. Require Import Program.Wf. Require Import Wf_nat. Require Import BinNums. Definition AddIndexToName name idx := (name ++ "_" ++ natToHexStr idx)%string. Definition AddIndicesToNames name idxs := List.map (fun x => AddIndexToName name x) idxs. (* Notation for normal mods *) Inductive ModuleElt: Type := | MERegister (_ : RegInitT) | MERule (_ : Attribute (Action Void)) | MEMeth (_ : DefMethT). Fixpoint makeModule' (xs: list ModuleElt) := match xs with | e :: es => let '(iregs, irules, imeths) := makeModule' es in match e with | MERegister mreg => (mreg :: iregs, irules, imeths) | MERule mrule => (iregs, mrule :: irules, imeths) | MEMeth mmeth => (iregs, irules, mmeth :: imeths) end | nil => (nil, nil, nil) end. Fixpoint makeModule_regs (xs: list ModuleElt) := match xs with | e :: es => let iregs := makeModule_regs es in match e with | MERegister mreg => mreg :: iregs | MERule mrule => iregs | MEMeth mmeth => iregs end | nil => nil end. Fixpoint makeModule_rules (xs: list ModuleElt) := match xs with | e :: es => let irules := makeModule_rules es in match e with | MERegister mreg => irules | MERule mrule => mrule :: irules | MEMeth mmeth => irules end | nil => nil end. Fixpoint makeModule_meths (xs: list ModuleElt) := match xs with | e :: es => let imeths := makeModule_meths es in match e with | MERegister mreg => imeths | MERule mrule => imeths | MEMeth mmeth => mmeth :: imeths end | nil => nil end. Definition makeModule (im : list ModuleElt) := BaseMod (makeModule_regs im) (makeModule_rules im) (makeModule_meths im). Definition makeConst k (c: ConstT k): ConstFullT (SyntaxKind k) := SyntaxConst c. Fixpoint getOrder (xs: list ModuleElt) := match xs with | e :: es => let names := getOrder es in match e with | MERegister _ => names | MERule mrule => fst mrule :: names | MEMeth mmeth => fst mmeth :: names end | nil => nil end. (* Definition getOrder (im : Tree ModuleElt) := getOrder' (flattenTree im). *) (** Notations for Struct **) Declare Scope kami_expr_scope. Delimit Scope kami_expr_scope with kami_expr. Declare Scope kami_struct_scope. Notation "name :: ty" := (name%string, ty) (only parsing) : kami_struct_scope. Delimit Scope kami_struct_scope with kami_struct. (** Notations for expressions *) Notation "k @# ty" := (Expr ty (SyntaxKind k)) (no associativity, at level 98, only parsing). Notation "# v" := (Var ltac:(assumption) (SyntaxKind _) v) (no associativity, at level 0, only parsing) : kami_expr_scope. Notation "$ n" := (Const _ (natToWord _ n)) (no associativity, at level 0): kami_expr_scope. Notation "$$ e" := (Const ltac:(assumption) e) (at level 8, only parsing) : kami_expr_scope. Notation "! v" := (UniBool Neg v) (at level 35): kami_expr_scope. Notation "e1 && e2" := (CABool And (e1 :: e2 :: nil)) : kami_expr_scope. Notation "e1 || e2" := ((@Kor _ Bool) (e1 :: e2 :: nil)) : kami_expr_scope. Notation "e1 ^^ e2" := (CABool Xor (e1 :: e2 :: nil)) (at level 50): kami_expr_scope. Notation "~ x" := (UniBit (Inv _) x) : kami_expr_scope. Notation "a $[ i : j ]":= ltac:(let aTy := type of a in match aTy with | Expr _ (SyntaxKind ?bv) => let bvSimpl := eval compute in bv in match bvSimpl with | Bit ?w => let middle := eval simpl in (i + 1 - j)%nat in let top := eval simpl in (w - 1 - i)%nat in exact (ConstExtract j middle top a) end end) (at level 100, i at level 99, only parsing) : kami_expr_scope. Notation "a $#[ i : j ]":= ltac:(let aTy := type of a in match aTy with | Expr _ (SyntaxKind ?bv) => let bvSimpl := eval compute in bv in match bvSimpl with | Bit ?w => let middle := eval simpl in (i + 1 - j)%nat in let top := eval simpl in (w - 1 - i)%nat in exact (ConstExtract j middle top (@castBits _ w (j + middle + top) ltac:(abstract (lia || nia)) a)) end end) (at level 100, i at level 99, only parsing) : kami_expr_scope. Notation "e1 + e2" := (CABit (Add) (e1 :: e2 :: nil)) : kami_expr_scope. Notation "e1 * e2" := (CABit (Mul) (e1 :: e2 :: nil)) : kami_expr_scope. Notation "e1 .& e2" := (CABit (Band) (e1 :: e2 :: nil)) (at level 201) : kami_expr_scope. Notation "e1 .| e2" := (Kor (e1 :: e2 :: nil)) (at level 201) : kami_expr_scope. Notation "e1 .^ e2" := (CABit (Bxor) (e1 :: e2 :: nil)) (at level 201) : kami_expr_scope. Infix "-" := (BinBit (Sub _)) : kami_expr_scope. Infix "/" := (BinBit (Div _)) : kami_expr_scope. Infix "%%" := (BinBit (Rem _)) (at level 100): kami_expr_scope. Infix "<<" := (BinBit (Sll _ _)) (at level 100) : kami_expr_scope. Infix ">>" := (BinBit (Srl _ _)) (at level 100) : kami_expr_scope. Infix ">>>" := (BinBit (Sra _ _)) (at level 100) : kami_expr_scope. Notation "{< a , .. , b >}" := ((BinBit (Concat _ _)) a .. (BinBit (Concat _ _) b (@Const _ (Bit 0) WO)) ..) (at level 100, a at level 99): kami_expr_scope. Notation "{< a , .. , b >}" := (wcombine b .. (wcombine a WO) ..) (at level 100, a at level 99): word_scope. Infix "<" := (BinBitBool (LessThan _)) : kami_expr_scope. Notation "x > y" := (BinBitBool (LessThan _) y x) : kami_expr_scope. Notation "x >= y" := (UniBool Neg (BinBitBool (LessThan _) x y)) : kami_expr_scope. Notation "x <= y" := (UniBool Neg (BinBitBool (LessThan _) y x)) : kami_expr_scope. Infix "s y" := (Slt _ y x) (at level 70, y at next level): kami_expr_scope. Notation "x >=s y" := (UniBool Neg (Slt _ x y)) (at level 100) : kami_expr_scope. Notation "x <=s y" := (UniBool Neg (Slt _ y x)) (at level 100): kami_expr_scope. Infix "==" := Eq (at level 39, no associativity) : kami_expr_scope. Notation "x != y" := (UniBool Neg (Eq x y)) (at level 39, no associativity) : kami_expr_scope. Notation "v @[ idx ] " := (ReadArray v idx) (at level 38) : kami_expr_scope. Notation "v '@[' idx <- val ] " := (UpdateArray v idx val) (at level 38) : kami_expr_scope. Notation "s @% f" := ltac:(struct_get_field_ltac s%kami_expr f%string) (at level 38, only parsing): kami_expr_scope. Declare Scope kami_struct_init_scope. Notation "name ::= value" := (existT (fun a : Attribute Kind => Expr _ (SyntaxKind (snd a))) (name%string, _) value) (at level 50) : kami_struct_init_scope. Delimit Scope kami_struct_init_scope with struct_init. Notation "'STRUCT' { s1 ; .. ; sN }" := (getStructVal (cons s1%struct_init .. (cons sN%struct_init nil) ..)) : kami_expr_scope. Declare Scope kami_switch_init_scope. Notation "name ::= value" := (name, value) (only parsing): kami_switch_init_scope. Delimit Scope kami_switch_init_scope with switch_init. Notation "s '@%[' f <- v ]" := ltac:(struct_set_field_ltac s f v) (at level 38, only parsing): kami_expr_scope. Notation "'IF' e1 'then' e2 'else' e3" := (ITE e1 e2 e3) : kami_expr_scope. Notation "nkind <[ def ]>" := (@NativeKind nkind def) (at level 100): kami_expr_scope. (* One hot switches *) Notation "'Switch' val 'Retn' retK 'With' { s1 ; .. ; sN }" := (unpack retK (Kor (cons (IF val == fst s1%switch_init then pack (snd s1%switch_init) else $0)%kami_expr .. (cons (IF val == fst sN%switch_init then pack (snd sN%switch_init)else $0)%kami_expr nil) ..))): kami_expr_scope. Notation "'Switch' val 'Of' inK 'Retn' retK 'With' { s1 ; .. ; sN }" := (unpack retK (Kor (cons (IF val == ((fst s1%switch_init): inK @# _) then pack (snd s1%switch_init) else $0)%kami_expr .. (cons (IF val == ((fst sN%switch_init): inK @# _) then pack (snd sN%switch_init)else $0)%kami_expr nil) ..))): kami_expr_scope. (* Notations for Let Expressions *) Notation "'LETE' name <- expr ; cont " := (LetE expr%kami_expr (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_expr_scope. Notation "'LETE' name : t <- expr ; cont " := (LetE (k' := t) expr%kami_expr (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_expr_scope. Notation "'RetE' expr" := (NormExpr expr%kami_expr) (at level 13) : kami_expr_scope. Notation "'LETC' name <- v ; c " := (LETE name <- RetE v ; c)%kami_expr (at level 13, right associativity, name at level 99) : kami_expr_scope. Notation "'LETC' name : t <- v ; c " := (LETE name : t <- RetE v ; c)%kami_expr (at level 13, right associativity, name at level 99) : kami_expr_scope. Notation "'SystemE' ls ; c " := (SysE ls c)%kami_expr (at level 13, right associativity, ls at level 99): kami_expr_scope. Notation "'IfE' cexpr 'then' tact 'else' fact 'as' name ; cont " := (IfElseE cexpr%kami_expr tact fact (fun name => cont)) (at level 14, right associativity) : kami_expr_scope. Notation "'IfE' cexpr 'then' tact 'else' fact ; cont " := (IfElseE cexpr%kami_expr tact fact (fun _ => cont)) (at level 14, right associativity) : kami_expr_scope. Notation "'IfE' cexpr 'then' tact ; cont" := (IfElseE cexpr%kami_expr tact (RetE (Const _ Default))%kami_expr (fun _ => cont)) (at level 14, right associativity) : kami_expr_scope. Notation "k ## ty" := (LetExprSyntax ty k) (no associativity, at level 98, only parsing). (** Notations for action *) Declare Scope kami_action_scope. Notation "'Call' meth ( a : argT ) ; cont " := (MCall meth%string (argT, Void) a%kami_expr (fun _ => cont)) (at level 13, right associativity, meth at level 0, a at level 99) : kami_action_scope. Notation "'Call' name : retT <- meth ( a : argT ) ; cont " := (MCall meth%string (argT, retT) a%kami_expr (fun name => cont)) (at level 13, right associativity, name at level 0, meth at level 0, a at level 99) : kami_action_scope. Notation "'Call' meth () ; cont " := (MCall meth%string (Void, Void) (Const _ Default) (fun _ => cont)) (at level 13, right associativity, meth at level 0) : kami_action_scope. Notation "'Call' name : retT <- meth () ; cont " := (MCall meth%string (Void, retT) (Const _ Default) (fun name => cont)) (at level 13, right associativity, name at level 0, meth at level 0) : kami_action_scope. Notation "'LETN' name : fullkind <- expr ; cont " := (LetExpr (k := fullkind) expr%kami_expr (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'LET' name <- expr ; cont " := (LetExpr expr%kami_expr (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'LET' name : t <- expr ; cont " := (LetExpr (k := SyntaxKind t) expr%kami_expr (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'LETA' name <- act ; cont " := (LetAction act (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'LETA' name : t <- act ; cont " := (LetAction (k := t) act (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'NondetN' name : fullkind ; cont" := (ReadNondet fullkind (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'Nondet' name : kind ; cont" := (ReadNondet (SyntaxKind kind) (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'ReadN' name : fullkind <- reg ; cont " := (ReadReg reg fullkind (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'Read' name <- reg ; cont" := (ReadReg reg _ (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'Read' name : kind <- reg ; cont " := (ReadReg reg (SyntaxKind kind) (fun name => cont)) (at level 13, right associativity, name at level 99) : kami_action_scope. Notation "'WriteN' reg : fullkind <- expr ; cont " := (@WriteReg _ _ reg fullkind expr%kami_expr cont) (at level 13, right associativity, reg at level 99) : kami_action_scope. Notation "'Write' reg <- expr ; cont " := (WriteReg reg expr%kami_expr cont) (at level 13, right associativity, reg at level 99) : kami_action_scope. Notation "'Write' reg : kind <- expr ; cont " := (@WriteReg _ _ reg (SyntaxKind kind) expr%kami_expr cont) (at level 13, right associativity, reg at level 99) : kami_action_scope. Notation "'If' cexpr 'then' tact 'else' fact 'as' name ; cont " := (IfElse cexpr%kami_expr tact fact (fun name => cont)) (at level 14, right associativity) : kami_action_scope. Notation "'If' cexpr 'then' tact 'else' fact ; cont " := (IfElse cexpr%kami_expr tact fact (fun _ => cont)) (at level 14, right associativity) : kami_action_scope. Notation "'If' cexpr 'then' tact ; cont" := (IfElse cexpr%kami_expr tact (Return (Const _ Default)) (fun _ => cont)) (at level 14, right associativity) : kami_action_scope. Notation "'System' sysexpr ; cont " := (Sys sysexpr%kami_expr cont) (at level 13, right associativity) : kami_action_scope. Notation "'Ret' expr" := (Return expr%kami_expr)%kami_expr (at level 13) : kami_action_scope. Notation "'Retv'" := (Return (Const _ (k := Void) Default)) : kami_action_scope. Delimit Scope kami_action_scope with kami_action. Notation "'ReadRf' val : k <- meth ( addr : idxT ) ; cont" := (MCall meth (idxT, Array 1 k) addr (fun raw => LetExpr (ReadArrayConst (@Var _ (SyntaxKind (Array 1 k)) raw) Fin.F1) (fun val => cont)))%kami_action (at level 13, right associativity, meth at level 0, addr at level 99, val at level 0): kami_action_scope. Notation "'ReadReqRf' meth ( addr : idxT ) ; cont" := (MCall meth (idxT, Void) addr (fun _ => cont))%kami_action (at level 13, right associativity, meth at level 0, addr at level 99): kami_action_scope. Notation "'ReadResRf' val : k <- meth () ; cont" := (MCall meth (Void, Array 1 k) (@Const _ Void (getDefaultConst Void)) (fun raw => LetExpr (ReadArrayConst (@Var _ (SyntaxKind (Array 1 k)) raw) Fin.F1) (fun val => cont)))%kami_action (at level 13, right associativity, meth at level 0, val at level 0): kami_action_scope. Notation "'WriteRf' meth ( addr : lgIdxNum ; data : k ) ; cont" := (MCall meth (WriteRq lgIdxNum (Array 1 k), Void) (STRUCT { "addr" ::= addr ; "data" ::= BuildArray (fun _ => data) })%kami_expr (fun _ => cont))%kami_action (at level 13, right associativity, meth at level 0, addr at level 99, data at level 99): kami_action_scope. (* Complex List Actions *) Fixpoint gatherActions (ty: Kind -> Type) k_in (acts: list (ActionT ty k_in)) k_out (cont: list (Expr ty (SyntaxKind k_in)) -> ActionT ty k_out): ActionT ty k_out := match acts with | nil => cont nil | x :: xs => (LetAction x (fun val => gatherActions xs (fun vals => cont ((Var ltac:(assumption) (SyntaxKind _) val) :: vals)))) end. Definition readNames (ty: Kind -> Type) k names := map (fun r => (ReadReg r (SyntaxKind k) (fun tmp => (Return (Var ltac:(assumption) (SyntaxKind _) tmp))))) names. Definition callNames (ty: Kind -> Type) k names := map (fun r => (MCall r (Void, k) (Const _ Default) (fun tmp => (Return (Var ltac:(assumption) (SyntaxKind _) tmp))))) names. Definition writeNames (ty: Kind -> Type) k namesVals := map (fun r => (@WriteReg _ _ (fst r) (SyntaxKind k) (snd r) (Return (Const ty (ZToWord 0 0))))) namesVals. (* Complex list action notations *) Notation "'GatherActions' actionList 'as' val ; cont" := (gatherActions actionList (fun val => cont)) (at level 13, right associativity, val at level 99) : kami_action_scope. Notation "'ReadToList' names 'of' k 'as' val ; cont" := (gatherActions (readNames _ k names) (fun val => cont)) (at level 13, right associativity, val at level 99) : kami_action_scope. Notation "'CallToList' names 'of' k 'as' val ; cont" := (gatherActions (callNames _ k names) (fun val => cont)) (at level 13, right associativity, val at level 99): kami_action_scope. Declare Scope kami_init_scope. Notation "'WriteToList' names 'of' k 'using' vals ; cont" := (gatherActions (@writeNames _ k (List.combine names vals)) (fun _ => cont)) (at level 13, right associativity, vals at level 99) : kami_action_scope. Delimit Scope kami_init_scope with kami_init. Notation "'ARRAY' { x1 ; .. ; xn }" := (BuildArray (nth_Fin (cons x1%kami_init .. (cons xn%kami_init nil) ..))) : kami_expr_scope. Declare Scope kami_struct_initial_scope. Notation "name ::= value" := (existT (fun a : Attribute Kind => ConstT (snd a)) (name%string, _) value) (at level 50) : kami_struct_initial_scope. Delimit Scope kami_struct_initial_scope with struct_initial. Declare Scope kami_scope. Delimit Scope kami_scope with kami. Notation "'RegisterN' name : type <- init" := (((MERegister (name%string, existT RegInitValT type (Some ((NativeConst init)%kami_init)%word))) :: nil)) (at level 13, name at level 99) : kami_scope. Notation "'RegisterNDef' name : type <- init" := ((MERegister (name%string, existT RegInitValT (@NativeKind type init)%kami_init (Some ((NativeConst init)%kami_init))) :: nil)) (at level 13, name at level 99) : kami_scope. Notation "'Register' name : type <- init" := (((MERegister (name%string, existT RegInitValT (SyntaxKind type) (Some (makeConst ((init)%kami_init)%word)))) :: nil)) (at level 13, name at level 99) : kami_scope. Notation "'RegisterU' name : type" := (((MERegister (name%string, existT RegInitValT (SyntaxKind type) None)) :: nil)) (at level 13, name at level 99) : kami_scope. Notation "'Method' name () : retT := c" := (((MEMeth (name%string, existT MethodT (Void, retT) (fun ty (_: ty Void) => c%kami_action : ActionT ty retT))) :: nil)) (at level 13, name at level 9) : kami_scope. Notation "'Method' name ( param : dom ) : retT := c" := (((MEMeth (name%string, existT MethodT (dom, retT) (fun ty (param : ty dom) => c%kami_action : ActionT ty retT))) :: nil)) (at level 13, name at level 9, param at level 99) : kami_scope. Notation "'Rule' name := c" := (((MERule (name%string, fun ty => (c)%kami_action : ActionT ty Void)) :: nil)) (at level 13) : kami_scope. Notation "'MODULE' { m1 'with' .. 'with' mN }" := (makeModule ((app m1%kami .. (app mN%kami nil) ..))) (only parsing). Notation "'MODULE_WF' { m1 'with' .. 'with' mN }" := {| baseModuleWf := {| baseModule := (makeModule ((app m1%kami .. (app mN%kami nil) ..))) ; wfBaseModule := ltac:(discharge_wf) |} ; baseModuleOrd := getOrder ((app m1%kami .. (app mN%kami nil) ..)) |} (only parsing). Notation "'MOD_WF' { m1 'with' .. 'with' mN }" := {| modWf := {| module := Base (makeModule ((app m1%kami .. (app mN%kami nil) ..))) ; wfMod := ltac:(discharge_wf) |} ; modOrd := getOrder ((app m1%kami .. (app mN%kami nil) ..)) |} (only parsing). Notation "'MODULE_WF_new' { m1 'with' .. 'with' mN }" := {| baseModuleWf_new := {| baseModule_new := (makeModule ((app m1%kami .. (app mN%kami nil) ..))) ; wfBaseModule_new := ltac:(discharge_wf_new) |} ; baseModuleOrd_new := getOrder ((app m1%kami .. (app mN%kami nil) ..)) |} (only parsing). Notation "'MOD_WF_new' { m1 'with' .. 'with' mN }" := {| modWf_new := {| module_new := Base (makeModule ((app m1%kami .. (app mN%kami nil) ..))) ; wfMod_new := ltac:(discharge_wf_new) |} ; modOrd_new := getOrder ((app m1%kami .. (app mN%kami nil) ..)) |} (only parsing). (* Notation "'RegisterVec' name 'using' nums : type <- init" := *) (* (MERegAry ( *) (* map (fun idx => *) (* (AddIndexToName name idx, existT RegInitValT (SyntaxKind type) (Some (makeConst (init)%kami_init))) *) (* ) nums *) (* )) *) (* (at level 13, name at level 9, nums at level 9) : kami_scope. *) (* Gallina Record Notations *) Notation "x <| proj := v |>" := (set proj (constructor v) x) (at level 12, left associativity). Notation "x <| proj ::== f |>" := (set proj f x) (at level 12, f at next level, left associativity). Notation "'STRUCT_TYPE' { s1 ; .. ; sN }" := (getStruct (cons s1%kami_struct .. (cons sN%kami_struct nil) ..)). Notation "'ARRAY_CONST' { x1 ; .. ; xn }" := (ConstArray (nth_Fin' (cons (x1%kami_init)%word .. (cons (xn%kami_init)%word nil) ..) eq_refl)). Notation "'STRUCT_CONST' { s1 ; .. ; sN }" := (getStructConst (cons (s1%struct_initial)%word .. (cons (sN%struct_initial)%word nil) ..)). Notation "i #: n" := (ltac:(let y := eval cbv in (@Fin.of_nat_lt (i)%nat (n)%nat ltac:(cbv; lia)) in exact y)) (at level 10, only parsing). Notation "'Valid' x" := (STRUCT { "valid" ::= $$ true ; "data" ::= x })%kami_expr (at level 100, only parsing) : kami_expr_scope. Notation "'InvData' x" := (STRUCT { "valid" ::= $$ false ; "data" ::= x })%kami_expr (at level 100, only parsing) : kami_expr_scope. Section mod_test. Variable a: string. Local Notation "^ x" := (a ++ "." ++ x)%string (at level 0). Local Example test : ModWf type := MOD_WF{ (concat [Register (^"x") : Bool <- true; Register (^"z") : Bool <- false]) with Register (^"y") : Bool <- false with Rule (^"r1") := ( Read y: Bool <- ^"y"; Write (^"x"): Bool <- #y; Retv) }. Local Example test1 : ModWf type := MODULE_WF{ (concat [Register (^"x") : Bool <- true; Register (^"w"): Bool <- true; Register (^"t"): Bit 0 <- WO]) with Register (^"y") : Bool <- false with Rule (^"r1") := ( Read y: Bool <- ^"y"; Write (^"x"): Bool <- #y; Retv ) }. Local Example test_new : ModWf_new type := MOD_WF_new { (concat [Register (^"x") : Bool <- true; Register (^"z") : Bool <- false]) with Register (^"y") : Bool <- false with Rule (^"r1") := ( Read y: Bool <- ^"y"; Write (^"x"): Bool <- #y; Retv ) }. Local Example test1_new : BaseModuleWf_new type := MODULE_WF_new{ (concat [Register (^"x") : Bool <- true; Register (^"w"): Bool <- true; Register (^"t"): Bit 0 <- WO]) with Register (^"y") : Bool <- false with Rule (^"r1") := ( Read y: Bool <- ^"y"; Write (^"x"): Bool <- #y; Retv ) }. End mod_test. Definition Registers := (map MERegister). Definition Rules := (map MERule). Definition Methods := (map MEMeth). ================================================ FILE: NotationsTest.v ================================================ Require Import Kami.Syntax Kami.Notations Kami.Tactics. Section mod_test. Variable a: string. Local Notation "^ x" := (a ++ "." ++ x)%string (at level 0). Local Example test : ModWf type := MOD_WF{ Register (^"x") : Bool <- true with Register (^"y") : Bool <- false with Rule (^"r1") := ( Read y: Bool <- ^"y"; Write (^"x"): Bool <- #y; Retv ) }. Local Example test1 : ModWf type := MODULE_WF{ Register (^"x") : Bool <- true with Register (^"y") : Bool <- false with Rule (^"r1") := ( Read y: Bool <- ^"y"; Write (^"x"): Bool <- #y; Retv ) }. End mod_test. Local Example test_normaldisj: DisjKey (map (fun x => (x, 1)) ("a" :: "b" :: "c" :: nil))%string (map (fun x => (x, 2)) ("d" :: "e" :: nil))%string. Proof. simpl. discharge_DisjKey. Qed. Local Example test_prefix_disj a: DisjKey (map (fun x => ((a ++ x)%string, 1)) ("ab" :: "be" :: "cs" :: nil))%string (map (fun x => ((a ++ x)%string, 2)) ("de" :: "et" :: nil))%string. Proof. simpl. discharge_DisjKey. Qed. Local Example test_suffix_disj a: DisjKey (map (fun x => ((x ++ a)%string, 1)) ("ab" :: "be" :: "cs" :: nil))%string (map (fun x => ((x ++ a)%string, 2)) ("de" :: "et" :: nil))%string. Proof. simpl. discharge_DisjKey. Qed. (* Testing the Notations *) Local Example testSwitch ty (val: Bit 5 @# ty) (a b: Bool @# ty) : Bool @# ty := (Switch val Retn Bool With { $$ (natToWord 5 5) ::= $$ true ; $$ (natToWord 5 6) ::= $$ false })%kami_expr. Local Example testSwitch2 ty (val: Bit 5 @# ty) (a b: Bool @# ty) : Bool @# ty := (Switch val Of Bit 5 Retn Bool With { $$ (natToWord 5 5) ::= $$ true ; $$ (natToWord 5 6) ::= $$ false })%kami_expr. Local Example test2 a b := (ConcatMod (test a) (test b))%kami. Section unittests. Open Scope kami_expr. Local Notation "X ==> Y" := (evalExpr X = Y) (at level 75). Let test_struct := STRUCT { "field0" ::= Const type false; "field1" ::= Const type (natToWord 4 2); "field2" ::= Const type (natToWord 5 3)}%kami_expr%struct_init. Section struct_get_field_default_unittests. Let test0 : test_struct @% "field0" ==> false := eq_refl false. Let test1 : test_struct @% "field1" ==> natToWord 4 2 := eq_refl (natToWord 4 2). Let test2 : test_struct @% "field2" ==> natToWord 5 3 := eq_refl (natToWord 5 3). End struct_get_field_default_unittests. Section struct_set_field_unittests. Let test_0 : (test_struct @%["field0" <- (Const type true)]) @% "field0" ==> true := eq_refl true. Let test_1 : (test_struct @%["field1" <- (Const type (natToWord 4 5))]) @% "field1" ==> natToWord 4 5 := eq_refl (natToWord 4 5). Let test_2 : (test_struct @%["field2" <- (Const type (natToWord 5 5))]) @% "field2" ==> natToWord 5 5 := eq_refl (natToWord 5 5). End struct_set_field_unittests. Close Scope kami_expr. End unittests. Local Definition testConcat ty (w1: Bit 10 @# ty) (w2: Bit 2 @# ty) (w3: Bit 5 @# ty) := {< w1, w2, w3 >}%kami_expr. Local Definition testArrayAccess ty (v: Array 4 (Bit 10) @# ty) (idx : Bit 2 @# ty) := (v @[ idx <- v @[ idx ]])%kami_expr. Local Definition testConstNat ty (w1 w2: Bit 10 @# ty): Bit 10 @# ty := (w1 + w2 + $4 + $6)%kami_expr. Local Definition testExtract ty n n1 n2 (pf1: n > n1) (pf2: n1 > n2) (a: Bit n @# ty) := (a $#[n1 : n2])%kami_expr. Local Definition testStruct := (STRUCT_TYPE { "hello" :: Bit 10 ; "a" :: Bit 3 ; "b" :: Bit 5 ; "test" :: Bool }). Local Definition testStructVal {ty}: testStruct @# ty := (STRUCT { "hello" ::= $ 4 ; "a" ::= $ 23 ; "b" ::= $ 5 ; "test" ::= $$ true })%kami_expr. Local Open Scope kami_action. Local Open Scope kami_expr. Local Definition testFieldAccess (ty: Kind -> Type): ActionT ty (Bit 10) := (LET val: testStruct <- testStructVal; Ret (#val @% "hello"))%kami_action. Local Close Scope kami_expr. Local Close Scope kami_action. Local Definition testFieldUpd (ty: Kind -> Type) := ((testStructVal (ty := ty)) @%[ "hello" <- Const ty (natToWord 10 23) ])%kami_expr. Local Open Scope kami_expr. Local Open Scope kami_action. Local Definition rftest1 ty : ActionT ty Void := ReadRf val : Bool <- "test" ($0: Bit 1); System [DispHex #val]; Retv. Local Definition rftest2 ty : ActionT ty Void := ReadReqRf "test" ($0: Bit 1); Retv. Local Definition rftest3 ty : ActionT ty Void := ReadResRf val : Bool <- "test" (); System [DispHex #val]; Retv. Local Definition rftest4 ty : ActionT ty Void := WriteRf "test" ($1 : 1 ; $$ true : Bool); Retv. Local Close Scope kami_action. Local Close Scope kami_expr. ================================================ FILE: PPlusProperties.v ================================================ Require Import Kami.Syntax. Require Import Kami.Properties Kami.PProperties. Import ListNotations. Require Import Coq.Sorting.Permutation. Require Import Coq.Sorting.PermutEq. Require Import RelationClasses Setoid Morphisms. Require Import ZArith Kami.Lib.EclecticLib. Local Notation PPT_execs := (fun x => fst (snd x)). Local Notation PPT_calls := (fun x => snd (snd x)). Local Open Scope Z_scope. (*TODO move somewhere else*) Lemma existsb_nexists_str str l : existsb (String.eqb str) l = false <-> ~ In str l. Proof. split; repeat intro. - assert (exists x, In x l /\ (String.eqb str) x = true) as P0. { exists str; split; auto. apply String.eqb_refl. } rewrite <- existsb_exists in P0; rewrite P0 in *; discriminate. - remember (existsb _ _) as exb; symmetry in Heqexb; destruct exb; auto. exfalso; rewrite existsb_exists in Heqexb; dest. rewrite String.eqb_eq in *; subst; auto. Qed. Section NeverCallAction. Variable ty : Kind -> Type. Inductive NeverCallActionT: forall k, ActionT ty k -> Prop := | NeverCallMCall meth s e lretT c: False -> @NeverCallActionT lretT (MCall meth s e c) | NeverCallLetExpr k (e: Expr ty k) lretT c: (forall v, NeverCallActionT (c v)) -> @NeverCallActionT lretT (LetExpr e c) | NeverCallLetAction k (a: ActionT ty k) lretT c: NeverCallActionT a -> (forall v, NeverCallActionT (c v)) -> @NeverCallActionT lretT (LetAction a c) | NeverCallReadNondet k lretT c: (forall v, NeverCallActionT (c v)) -> @NeverCallActionT lretT (ReadNondet k c) | NeverCallReadReg r k lretT c: (forall v, NeverCallActionT (c v)) -> @NeverCallActionT lretT (ReadReg r k c) | NeverCallWriteReg r k (e: Expr ty k) lretT c: NeverCallActionT c -> @NeverCallActionT lretT (WriteReg r e c) | NeverCallIfElse p k (atrue: ActionT ty k) afalse lretT c: (forall v, NeverCallActionT (c v)) -> NeverCallActionT atrue -> NeverCallActionT afalse -> @NeverCallActionT lretT (IfElse p atrue afalse c) | NeverCallSys ls lretT c: NeverCallActionT c -> @NeverCallActionT lretT (Sys ls c) | NeverCallReturn lretT e: @NeverCallActionT lretT (Return e). End NeverCallAction. Section NeverCallBaseModule. Variable m : BaseModule. Definition NeverCallBaseModule := (forall rule ty, In rule (getRules m) -> NeverCallActionT (snd rule ty)) /\ (forall meth ty, In meth (getMethods m) -> forall v, NeverCallActionT (projT2 (snd meth) ty v)). End NeverCallBaseModule. Inductive NeverCallMod: Mod -> Prop := | BaseNeverCall m (HNCBaseModule: NeverCallBaseModule m): NeverCallMod (Base m) | HideMethNeverCall m s (HNCModule: NeverCallMod m): NeverCallMod (HideMeth m s) | ConcatModNeverCall m1 m2 (HNCModule1: NeverCallMod m1) (HNCModule2: NeverCallMod m2) : NeverCallMod (ConcatMod m1 m2). (* Proves that the number of method calls returned by [getNumCalls] is always greater than or equal to 0. *) Lemma num_method_calls_positive : forall (method : MethT) (labels : list FullLabel), 0 <= getNumCalls method labels. Proof fun method => list_ind _ (ltac:(discriminate) : 0 <= getNumCalls method []) (fun (label : FullLabel) (labels : list FullLabel) (H : 0 <= getNumFromCalls method (concat (map PPT_calls labels))) => list_ind _ H (fun (method0 : MethT) (methods : MethsT) (H0 : 0 <= getNumFromCalls method (methods ++ concat (map PPT_calls labels))) => sumbool_ind (fun methods_eq => 0 <= if methods_eq then 1 + getNumFromCalls method (methods ++ concat (map PPT_calls labels)) else getNumFromCalls method (methods ++ concat (map PPT_calls labels))) (fun _ => Z.add_nonneg_nonneg 1 _ (Zle_0_pos 1) H0) (fun _ => H0) (MethT_dec method method0)) (snd (snd label))). (* Proves that the number of method executions counted by [getNumExecs] is always greater than or equal to 0. *) Lemma num_method_execs_positive : forall (method : MethT) (labels : list FullLabel), 0 <= getNumExecs method labels. Proof. induction labels; unfold getNumExecs in *; simpl; try lia. destruct a; simpl; auto. destruct p; simpl; auto. destruct r0; simpl; auto. destruct (MethT_dec method f); simpl; auto; subst. destruct (getNumFromExecs f (map PPT_execs labels)); simpl; auto; try lia. Defined. Local Close Scope Z_scope. Section PPlusTraceInclusion. Definition getListFullLabel_diff_flat f (t : (RegsT *((list RuleOrMeth)*MethsT))) : Z:= (getNumFromExecs f (PPT_execs t) - getNumFromCalls f (PPT_calls t))%Z. Definition WeakInclusion_flat (t1 t2 : (RegsT *((list RuleOrMeth) * MethsT))) := (forall (f : MethT), (getListFullLabel_diff_flat f t1 = getListFullLabel_diff_flat f t2)%Z) /\ ((exists rle, In (Rle rle) (PPT_execs t2)) -> (exists rle, In (Rle rle) (PPT_execs t1))). Inductive WeakInclusions_flat : list (RegsT * ((list RuleOrMeth) * MethsT)) -> list (RegsT *((list RuleOrMeth) * MethsT)) -> Prop := |WIf_Nil : WeakInclusions_flat nil nil |WIf_Cons : forall (lt1 lt2 : list (RegsT *((list RuleOrMeth) * MethsT))) (t1 t2 : RegsT *((list RuleOrMeth) * MethsT)), WeakInclusions_flat lt1 lt2 -> WeakInclusion_flat t1 t2 -> WeakInclusions_flat (t1::lt1) (t2::lt2). Definition PPlusTraceList (m : BaseModule)(lt : list (RegsT * ((list RuleOrMeth) * MethsT))) := (exists (o : RegsT), PPlusTrace m o lt). Definition PPlusTraceInclusion (m m' : BaseModule) := forall (o : RegsT)(tl : list (RegsT *((list RuleOrMeth) * MethsT))), PPlusTrace m o tl -> exists (tl' : list (RegsT * ((list RuleOrMeth) * MethsT))), PPlusTraceList m' tl' /\ WeakInclusions_flat tl tl'. Definition StrongPPlusTraceInclusion (m m' : BaseModule) := forall (o : RegsT)(tl : list (RegsT *((list RuleOrMeth) * MethsT))), PPlusTrace m o tl -> exists (tl' : list (RegsT * ((list RuleOrMeth) * MethsT))), PPlusTrace m' o tl' /\ WeakInclusions_flat tl tl'. End PPlusTraceInclusion. Section BaseModule. Variable m: BaseModule. Variable o: RegsT. Definition getLabelUpds (ls: list FullLabel) := concat (map (fun x => fst x) ls). Definition getLabelExecs (ls: list FullLabel) := map (fun x => fst (snd x)) ls. Definition getLabelCalls (ls: list FullLabel) := concat (map (fun x => (snd (snd x))) ls). Lemma getLabelCalls_perm_rewrite l l' : l [=] l' -> getLabelCalls l [=] getLabelCalls l'. Proof. induction 1. - reflexivity. - unfold getLabelCalls; simpl; fold (getLabelCalls l); fold (getLabelCalls l'). rewrite IHPermutation; reflexivity. - unfold getLabelCalls; simpl; fold (getLabelCalls l). repeat rewrite app_assoc. apply Permutation_app_tail, Permutation_app_comm. - rewrite IHPermutation1, IHPermutation2. reflexivity. Qed. Global Instance getLabelCalls_perm_rewrite' : Proper (@Permutation (FullLabel) ==> @Permutation (MethT)) (@getLabelCalls) | 10. Proof. repeat red; intro; eauto using getLabelCalls_perm_rewrite. Qed. Lemma getLabelExecs_perm_rewrite l l' : l [=] l' -> getLabelExecs l [=] getLabelExecs l'. Proof. induction 1; auto. - unfold getLabelExecs in *; simpl. apply perm_skip; assumption. - unfold getLabelExecs in *; simpl. apply perm_swap. - rewrite IHPermutation1, IHPermutation2; reflexivity. Qed. Lemma getLabelUpds_perm_rewrite l l' : l [=] l' -> getLabelUpds l [=] getLabelUpds l'. Proof. induction 1; auto; unfold getLabelUpds in *; simpl in *. - apply Permutation_app_head; assumption. - repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. - rewrite IHPermutation1, IHPermutation2; reflexivity. Qed. Global Instance getLabelExecs_perm_rewrite' : Proper (@Permutation (FullLabel) ==> @Permutation (RuleOrMeth)) (@getLabelExecs) | 10. Proof. repeat red; intro; eauto using getLabelExecs_perm_rewrite. Qed. Global Instance getLabelUpds_perm_rewrite' : Proper (@Permutation (FullLabel) ==> @Permutation (string * {x : FullKind & fullType type x})) (@getLabelUpds) | 10. Proof. repeat red; intro; eauto using getLabelUpds_perm_rewrite. Qed. Lemma InCall_getLabelCalls f l: InCall f l -> In f (getLabelCalls l). Proof. induction l; unfold InCall,getLabelCalls in *; intros; simpl; dest; auto. destruct H; subst;apply in_app_iff; [left; assumption|right; apply IHl]. exists x; auto. Qed. Lemma getLabelCalls_InCall f l: In f (getLabelCalls l) -> InCall f l. Proof. induction l; unfold InCall, getLabelCalls in *; intros; simpl in *;[contradiction|]. rewrite in_app_iff in H; destruct H;[exists a; auto|specialize (IHl H);dest]. exists x; auto. Qed. Corollary InCall_getLabelCalls_iff f l: InCall f l <-> In f (getLabelCalls l). Proof. split; intro; eauto using InCall_getLabelCalls, getLabelCalls_InCall. Qed. Lemma PPlusSubsteps_PSubsteps: forall upds execs calls, PPlusSubsteps m o upds execs calls -> exists l, PSubsteps m o l /\ upds [=] getLabelUpds l /\ execs [=] getLabelExecs l /\ calls [=] getLabelCalls l. Proof. unfold getLabelUpds, getLabelExecs, getLabelCalls. induction 1; dest. - exists nil. repeat split; auto; constructor; auto. - exists ((u, (Rle rn, cs)) :: x). repeat split; auto; try constructor; auto; simpl. + econstructor; eauto; intros. * clear - H1 H4 HUpds HExecs HCalls HDisjRegs. intro. destruct (HDisjRegs k); auto. left; intro. clear - H1 H4 H H0. rewrite H1 in H. rewrite <- flat_map_concat_map in H. rewrite in_map_iff in H. setoid_rewrite in_flat_map in H. rewrite in_map_iff in *; dest; subst. firstorder fail. * clear - H2 H4 HExecs HNoRle. apply HNoRle. rewrite H2. rewrite in_map_iff. firstorder fail. + rewrite H1 in HUpds; auto. + rewrite HExecs. constructor; auto. + rewrite H3 in HCalls; auto. - exists ((u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs)) :: x). repeat split; auto; try constructor; auto; simpl. + econstructor 3; eauto; intros. * clear - H1 H4 HUpds HExecs HCalls HDisjRegs. intro. destruct (HDisjRegs k); auto. left; intro. clear - H1 H4 H H0. rewrite H1 in H. rewrite <- flat_map_concat_map in H. rewrite in_map_iff in H. setoid_rewrite in_flat_map in H. rewrite in_map_iff in *; dest; subst. firstorder fail. + rewrite H1 in HUpds; auto. + rewrite HExecs. constructor; auto. + rewrite H3 in HCalls; auto. Qed. End BaseModule. Section PPlusSubsteps_rewrite. Lemma PPlusSubsteps_rewrite_regs m o1 o2 upds execs calls: (o1 [=] o2) -> PPlusSubsteps m o1 upds execs calls -> PPlusSubsteps m o2 upds execs calls. Proof. induction 2. - econstructor 1. rewrite <- H; assumption. - econstructor 2;(rewrite <- H || apply (PSemAction_rewrite_state H) in HPAction); eauto. - econstructor 3;(rewrite <- H || apply (PSemAction_rewrite_state H) in HPAction); eauto. Qed. Lemma PPlusSubsteps_rewrite_upds m o execs calls upds1 upds2: (upds1 [=] upds2) -> PPlusSubsteps m o upds1 execs calls -> PPlusSubsteps m o upds2 execs calls. Proof. induction 2. - apply Permutation_nil in H; rewrite H. econstructor 1; assumption. - econstructor 2; eauto. rewrite H in HUpds. assumption. - econstructor 3; eauto. rewrite H in HUpds. assumption. Qed. Lemma PPlusSubsteps_rewrite_execs m o upds calls execs1 execs2: (execs1 [=] execs2) -> PPlusSubsteps m o upds execs1 calls -> PPlusSubsteps m o upds execs2 calls. Proof. induction 2. - apply Permutation_nil in H; rewrite H. econstructor 1; assumption. - econstructor 2; eauto. rewrite H in HExecs. assumption. - econstructor 3; eauto. rewrite H in HExecs. assumption. Qed. Lemma PPlusSubsteps_rewrite_calls m o upds execs calls1 calls2: (calls1 [=] calls2) -> PPlusSubsteps m o upds execs calls1 -> PPlusSubsteps m o upds execs calls2. Proof. induction 2. - apply Permutation_nil in H; rewrite H. econstructor 1; assumption. - econstructor 2; eauto. rewrite H in HCalls. assumption. - econstructor 3; eauto. rewrite H in HCalls. assumption. Qed. Lemma PPlusSubsteps_rewrite_all m o1 o2 upds1 execs1 calls1 upds2 execs2 calls2 : o1 [=] o2 -> upds1 [=] upds2 -> execs1 [=] execs2 -> calls1 [=] calls2 -> PPlusSubsteps m o1 upds1 execs1 calls1 -> PPlusSubsteps m o2 upds2 execs2 calls2. Proof. intros. apply (PPlusSubsteps_rewrite_regs H) in H3; apply (PPlusSubsteps_rewrite_upds H0) in H3; apply (PPlusSubsteps_rewrite_execs H1) in H3; apply (PPlusSubsteps_rewrite_calls H2) in H3; assumption. Qed. Global Instance PPlusSubsteps_rewrite' : Proper (Logic.eq ==> @Permutation (string * {x : FullKind & fullType type x}) ==> @Permutation (string * {x : FullKind & fullType type x}) ==> @Permutation RuleOrMeth ==> @Permutation MethT ==> iff) (@PPlusSubsteps)| 10. Proof. repeat red; intros; split; intros; subst; eauto using Permutation_sym, PPlusSubsteps_rewrite_all. symmetry in H0. symmetry in H1. symmetry in H2. symmetry in H3. eapply PPlusSubsteps_rewrite_all; eauto. Qed. End PPlusSubsteps_rewrite. Lemma Permutation_flat_map_rewrite (A B : Type) (l1 l2 : list A) (f : A -> list B) : l1 [=] l2 -> flat_map f l1 [=] flat_map f l2. Proof. induction 1; simpl in *; auto. - apply Permutation_app_head; assumption. - repeat rewrite app_assoc; apply Permutation_app_tail. rewrite Permutation_app_comm; reflexivity. - rewrite IHPermutation1, IHPermutation2; reflexivity. Qed. Global Instance Permutation_flat_map_rewrite' (A B : Type)(f : A -> list B): Proper (@Permutation A ==> @Permutation B) (@flat_map A B f) | 10. repeat red; intros; intros; eauto using Permutation_flat_map_rewrite. Qed. Lemma PSubsteps_PPlusSubsteps: forall m o l, PSubsteps m o l -> PPlusSubsteps m o (getLabelUpds l) (getLabelExecs l) (getLabelCalls l). Proof. induction 1; unfold getLabelUpds, getLabelExecs, getLabelCalls in *; try setoid_rewrite <- flat_map_concat_map. - econstructor; eauto. - rewrite HLabel; simpl; setoid_rewrite <-flat_map_concat_map in IHPSubsteps. econstructor 2; intros; eauto. + clear - HDisjRegs. induction ls. * firstorder. * intro; simpl in *; rewrite map_app, in_app_iff, DeM1. assert (DisjKey (flat_map (fun x : FullLabel => fst x) ls) u);[eapply IHls; eauto|]. specialize (HDisjRegs a (or_introl _ eq_refl) k); specialize (H k). firstorder fail. + rewrite in_map_iff in H0; dest; rewrite <- H0. eapply HNoRle; eauto. - rewrite HLabel; simpl; setoid_rewrite <- flat_map_concat_map in IHPSubsteps. econstructor 3; intros; eauto. + clear - HDisjRegs. induction ls. * firstorder. * intro; simpl in *; rewrite map_app, in_app_iff, DeM1. assert (DisjKey (flat_map (fun x : FullLabel => fst x) ls) u);[eapply IHls; eauto|]. specialize (HDisjRegs a (or_introl _ eq_refl) k); specialize (H k). firstorder fail. Qed. Section PPlusStep. Variable m: BaseModule. Variable o: RegsT. Lemma PPlusStep_PStep: forall upds execs calls, PPlusStep m o upds execs calls -> exists l, PStep (Base m) o l /\ upds [=] getLabelUpds l /\ execs [=] getLabelExecs l /\ calls [=] getLabelCalls l. Proof. induction 1. apply PPlusSubsteps_PSubsteps in H; dest. exists x; repeat split; eauto. econstructor 1; eauto. intros f HInDef; specialize (H0 f HInDef). unfold getNumCalls, getNumExecs, getLabelExecs, getLabelCalls in *. rewrite <-H3, <-H2; assumption. Qed. Lemma PStep_PPlusStep : forall l, PStep (Base m) o l -> PPlusStep m o (getLabelUpds l) (getLabelExecs l) (getLabelCalls l). Proof. intros; inv H; econstructor. - apply PSubsteps_PPlusSubsteps in HPSubsteps; assumption. - intros f HInDef; specialize (HMatching f). apply HMatching; auto. Qed. End PPlusStep. Section PPlusTrace. Variable m: BaseModule. Lemma PPlusTrace_PTrace o ls : PPlusTrace m o ls -> exists ls', PTrace (Base m) o ls' /\ PermutationEquivLists (map fst ls) (map getLabelUpds ls') /\ PermutationEquivLists (map PPT_execs ls) (map getLabelExecs ls') /\ PermutationEquivLists (map PPT_calls ls) (map getLabelCalls ls'). Proof. induction 1; subst; dest. - exists nil; repeat split; econstructor; eauto. - apply PPlusStep_PStep in HPPlusStep; dest. exists (x0::x); repeat split; eauto; simpl in *; econstructor 2; eauto. + unfold PPlusUpdRegs in HUpdRegs; dest. repeat split; eauto. intros; destruct (H9 _ _ H10). * rewrite H5 in H11; unfold getLabelUpds in H11. rewrite <- flat_map_concat_map, in_flat_map in *; dest. left; exists (fst x1); split; auto. apply (in_map fst) in H11; assumption. * destruct H11; right; split; auto. intro; apply H11; dest. unfold getLabelUpds in *. rewrite H5, <- flat_map_concat_map, in_map_iff. setoid_rewrite in_flat_map. rewrite in_map_iff in H13,H14; dest. exists x2; split; auto. exists x3; subst; auto. Qed. Definition extractTriple (lfl : list FullLabel) : (RegsT * ((list RuleOrMeth) * MethsT)) := (getLabelUpds lfl, (getLabelExecs lfl, getLabelCalls lfl)). Fixpoint extractTriples (llfl : list (list FullLabel)) : list (RegsT * ((list RuleOrMeth) * MethsT)) := match llfl with |lfl::llfl' => (extractTriple lfl)::(extractTriples llfl') |nil => nil end. Lemma extractTriples_nil l : extractTriples l = nil -> l = nil. Proof. destruct l; intros; auto. inv H. Qed. Lemma PTrace_PPlusTrace o ls: PTrace (Base m) o ls -> PPlusTrace m o (extractTriples ls). Proof. induction 1; subst; intros. - econstructor; eauto. - simpl; econstructor 2; eauto. + apply PStep_PPlusStep; apply HPStep. + unfold PUpdRegs,PPlusUpdRegs in *; dest; repeat split; eauto. intros; destruct (H1 _ _ H2);[left|right]; unfold getLabelUpds; dest. * rewrite <- flat_map_concat_map, in_flat_map. rewrite (in_map_iff fst) in H3; dest; rewrite <- H3 in H4. firstorder. * split; auto; intro; apply H3. rewrite <- flat_map_concat_map, in_map_iff in H5; dest. rewrite in_flat_map in H6; dest. exists (fst x0); split. -- rewrite in_map_iff; exists x0; firstorder. -- rewrite <- H5, in_map_iff; exists x; firstorder. + unfold extractTriple; reflexivity. Qed. End PPlusTrace. Section PPlusTraceInclusion. Lemma InExec_rewrite f l: In (Meth f) (getLabelExecs l) <-> InExec f l. Proof. split; unfold InExec; induction l; simpl in *; intros; auto. Qed. Lemma InCall_rewrite f l : In f (getLabelCalls l) <-> InCall f l. Proof. split; unfold InCall; induction l; simpl in *; intros; dest; try contradiction. - unfold getLabelCalls in H. rewrite <- flat_map_concat_map, in_flat_map in H. assumption. - unfold getLabelCalls; rewrite <- flat_map_concat_map, in_flat_map. firstorder fail. Qed. Lemma WeakInclusion_flat_WeakInclusion (l1 l2 : list FullLabel) : WeakInclusion_flat (extractTriple l1) (extractTriple l2) <-> WeakInclusion l1 l2. Proof. split; auto. Qed. Lemma WeakInclusions_flat_WeakInclusions (ls1 ls2 : list (list FullLabel)) : WeakInclusions_flat (extractTriples ls1) (extractTriples ls2) -> WeakInclusions ls1 ls2. Proof. revert ls2; induction ls1; intros; simpl in *; inv H. - symmetry in H0; apply extractTriples_nil in H0; subst; econstructor. - destruct ls2; inv H2. econstructor 2. + eapply IHls1; eauto. + apply WeakInclusion_flat_WeakInclusion; assumption. Qed. Lemma StrongPPlusTraceInclusion_PPlusTraceInclusion m m' : StrongPPlusTraceInclusion m m' -> PPlusTraceInclusion m m'. Proof. unfold StrongPPlusTraceInclusion, PPlusTraceInclusion, PPlusTraceList; intros. specialize (H _ _ H0); dest. exists x; split; auto. exists o; auto. Qed. Lemma WeakInclusions_flat_PermutationEquivLists_r ls1: forall l ls2, WeakInclusions_flat (extractTriples ls1) l -> PermutationEquivLists (map fst l) (map getLabelUpds ls2) -> PermutationEquivLists (map PPT_execs l) (map getLabelExecs ls2) -> PermutationEquivLists (map PPT_calls l) (map getLabelCalls ls2) -> WeakInclusions_flat (extractTriples ls1) (extractTriples ls2). Proof. induction ls1; intros; inv H; simpl in *. - destruct ls2; simpl in *. + econstructor. + inv H2. - destruct ls2; inv H2; inv H1; inv H0; simpl in *. econstructor. + eapply IHls1; eauto. + unfold WeakInclusion_flat in *; dest; simpl in *. split; intros; [unfold getListFullLabel_diff_flat in *; simpl in *; rewrite <-H9, <-H10; apply H|]. apply H0; setoid_rewrite H10; assumption. Qed. Lemma PPlusTraceInclusion_PTraceInclusion (m m' : BaseModule) : PPlusTraceInclusion m m' -> PTraceInclusion (Base m) (Base m'). Proof. repeat intro. apply (PTrace_PPlusTrace) in H0. specialize (H o _ H0); dest. destruct H. apply (PPlusTrace_PTrace) in H; dest. exists x1; split. - exists x0; assumption. - apply WeakInclusions_flat_WeakInclusions. apply (WeakInclusions_flat_PermutationEquivLists_r _ _ H1 H2 H3 H4). Qed. Lemma PPlusTraceInclusion_TraceInclusion (m m' : BaseModule) (Wfm: WfMod type (Base m)) (Wfm': WfMod type (Base m')): PPlusTraceInclusion m m' -> TraceInclusion (Base m) (Base m'). Proof. intros; apply PTraceInclusion_TraceInclusion, PPlusTraceInclusion_PTraceInclusion; auto. Qed. End PPlusTraceInclusion. Lemma NoDup_app_iff (A : Type) (l1 l2 : list A) : NoDup (l1++l2) <-> NoDup l1 /\ NoDup l2 /\ (forall a, In a l1 -> ~In a l2) /\ (forall a, In a l2 -> ~In a l1). Proof. repeat split; intros; dest. - induction l1; econstructor; inv H; firstorder. - induction l2; econstructor; apply NoDup_remove in H; dest; firstorder. - induction l1; auto. simpl in H; rewrite NoDup_cons_iff in H; dest; firstorder. subst; firstorder. - induction l2; auto. apply NoDup_remove in H; dest; firstorder. subst; firstorder. - induction l1; simpl; eauto. constructor. + rewrite in_app_iff, DeM1; split; firstorder. inv H; assumption. + inv H; eapply IHl1; eauto; firstorder. Qed. Lemma NoDup_app_Disj (A : Type) (dec : forall (a1 a2 : A), {a1 = a2}+{a1 <> a2}) : forall (l1 l2 : list A), NoDup (l1++l2) -> (forall a, ~In a l1 \/ ~In a l2). Proof. intros. rewrite NoDup_app_iff in H; dest. destruct (in_dec dec a l1); auto. Qed. Notation remove_calls := (fun x y => negb (getBool (string_dec (fst x) (fst y)))). Notation keep_calls := (fun x y => (getBool (string_dec (fst x) (fst y)))). Definition methcmp (m1 m2 : MethT) : bool := getBool (MethT_dec m1 m2). Definition remove_execs (calls : MethsT) (exec : RuleOrMeth) : bool := match exec with | Rle _ => false | Meth f => existsb (methcmp f) calls end. Lemma key_not_In_filter (f : DefMethT) (calls : MethsT) : key_not_In (fst f) calls -> filter (remove_calls f) calls = calls. Proof. induction calls; unfold key_not_In in *; simpl in *; intros; auto. destruct string_dec; pose proof (H (snd a)); simpl in *. - apply False_ind; apply H0; left. destruct a; simpl in *; rewrite e; reflexivity. - rewrite IHcalls; auto. repeat intro; specialize (H v); apply H; right; assumption. Qed. Lemma PSemAction_inline_notIn (f : DefMethT) o k (a : ActionT type k) readRegs newRegs calls (fret : type k) : PSemAction o a readRegs newRegs calls fret -> ~In (fst f) (map fst calls) -> PSemAction o (inlineSingle a f) readRegs newRegs calls fret. Proof. induction 1; simpl; intros. - destruct (fst f =? meth) eqn:G. rewrite <- (proj1 (String.eqb_eq _ _) G) in *. + apply False_ind; apply H0; rewrite HAcalls; simpl; left; reflexivity. + econstructor 1; eauto. apply IHPSemAction; intro; apply H0; rewrite HAcalls; simpl; right; assumption. - econstructor 2; eauto. - econstructor 3; eauto;[eapply IHPSemAction1|eapply IHPSemAction2]; intro; apply H1; rewrite HUCalls, map_app, in_app_iff;[left|right]; assumption. - econstructor 4; eauto. - econstructor 5; eauto. - econstructor 6; eauto. - econstructor 7; eauto; [eapply IHPSemAction1|eapply IHPSemAction2]; intro; apply H1; rewrite HUCalls, map_app, in_app_iff;[left|right]; assumption. - econstructor 8; eauto; [eapply IHPSemAction1|eapply IHPSemAction2]; intro; apply H1; rewrite HUCalls, map_app, in_app_iff;[left|right]; assumption. - econstructor 9; eauto. - econstructor 10; eauto. Qed. Inductive PSemAction_meth_collector (f : DefMethT) (o : RegsT) : RegsT -> RegsT -> MethsT -> MethsT -> Prop := |NilCalls : PSemAction_meth_collector f o nil nil nil nil |ConsCalls reads1 reads2 reads upds1 upds2 upds calls1 calls2 calls calls' calls'' argV retV: PSemAction_meth_collector f o reads1 upds1 calls1 calls' -> DisjKey upds1 upds2 -> reads [=] reads1 ++ reads2 -> upds [=] upds1 ++ upds2 -> calls [=] calls1 ++ calls2 -> calls'' [=] ((fst f, (existT _ (projT1 (snd f)) (argV, retV)))::calls') -> PSemAction o (projT2 (snd f) type argV) reads2 upds2 calls2 retV -> PSemAction_meth_collector f o reads upds calls calls''. Lemma Produce_action_from_collector (f : DefMethT) (o : RegsT) reads upds calls calls' call: In call calls' -> PSemAction_meth_collector f o reads upds calls calls' -> exists reads1 reads2 upds1 upds2 calls1 calls2 calls'' argV retV, DisjKey upds1 upds2 /\ upds [=] upds2++upds1 /\ calls [=] calls2++calls1 /\ reads [=] reads2 ++ reads1 /\ call = (fst f, (existT _ (projT1 (snd f)) (argV, retV))) /\ calls' [=] call::calls'' /\ PSemAction o (projT2 (snd f) type argV) reads2 upds2 calls2 retV /\ PSemAction_meth_collector f o reads1 upds1 calls1 calls''. Proof. induction 2. - contradiction. - rewrite H5 in H. destruct H. + exists reads1, reads2, upds1, upds2, calls1, calls2, calls', argV, retV; subst. repeat split; auto; (rewrite H2 || rewrite H3 || rewrite H4 || rewrite H5); subst; auto; apply Permutation_app_comm. + specialize (IHPSemAction_meth_collector H); dest. rewrite H8, H9, H10, H12 in *. exists (reads2++x), x0, (upds2++x1), x2, (calls2++x3), x4, ((fst f, existT _ (projT1 (snd f)) (argV, retV))::x5), x6, x7. repeat split; auto. * intro; destruct (H7 k), (H1 k); rewrite map_app,in_app_iff in *; dest; firstorder fail. * rewrite H3, <-app_assoc; apply Permutation_app_head, Permutation_app_comm. * rewrite H4, <-app_assoc; apply Permutation_app_head, Permutation_app_comm. * rewrite H2, <-app_assoc; apply Permutation_app_head, Permutation_app_comm. * rewrite H5; apply perm_swap. * econstructor. -- apply H14. -- assert (DisjKey x1 upds2). ++ intro; destruct (H1 k);[rewrite map_app,in_app_iff,DeM1 in *; dest; left; assumption|right; assumption]. ++ apply H15. -- apply Permutation_app_comm. -- apply Permutation_app_comm. -- apply Permutation_app_comm. -- reflexivity. -- assumption. Qed. Lemma collector_perm_rewrite f o reads upds calls calls1': PSemAction_meth_collector f o reads upds calls calls1' -> forall calls2', calls1' [=] calls2' -> PSemAction_meth_collector f o reads upds calls calls2'. Proof. induction 1; intros. - apply Permutation_nil in H; subst. constructor. - rewrite H6 in H4. econstructor; eauto. Qed. Global Instance collector_perm_rewrite' : Proper (eq ==> eq ==> eq ==> eq ==> eq ==> (@Permutation MethT) ==> iff) (@PSemAction_meth_collector) | 10. Proof. repeat red; intro; split; intros; subst; eauto using collector_perm_rewrite, Permutation_sym. Qed. Lemma collector_split (f : DefMethT) o calls1' calls2' : forall reads upds calls, PSemAction_meth_collector f o reads upds calls (calls1'++calls2') -> exists reads1 reads2 upds1 upds2 calls1 calls2, reads [=] reads1 ++ reads2 /\ upds [=] upds1 ++ upds2 /\ calls [=] calls1 ++ calls2 /\ DisjKey upds1 upds2 /\ PSemAction_meth_collector f o reads1 upds1 calls1 calls1' /\ PSemAction_meth_collector f o reads2 upds2 calls2 calls2'. Proof. induction calls1'; simpl; intros. - exists nil, reads, nil, upds, nil, calls. repeat split; auto. + intro; auto. + constructor. - specialize (Produce_action_from_collector _ (in_eq _ _) H) as TMP; dest. apply Permutation_cons_inv in H5. rewrite <- H5 in H7. specialize (IHcalls1' _ _ _ H7) as TMP; dest. exists (x0++x8), x9, (x2++x10), x11, (x4++x12), x13. repeat split. + rewrite H8, app_assoc in H3; assumption. + rewrite H9, app_assoc in H1; assumption. + rewrite H10, app_assoc in H2; assumption. + intro; specialize (H11 k); specialize (H0 k); clear - H0 H11 H9; rewrite H9,map_app, in_app_iff in *; firstorder fail. + econstructor. * apply H12. * rewrite H9 in H0; assert (DisjKey x10 x2);[intro; specialize (H0 k); rewrite map_app, in_app_iff in *;clear - H0; firstorder fail| apply H14]. * apply Permutation_app_comm. * apply Permutation_app_comm. * apply Permutation_app_comm. * rewrite H4; reflexivity. * assumption. + assumption. Qed. Lemma collector_correct_fst f o reads upds calls calls' call : In call calls' -> PSemAction_meth_collector f o reads upds calls calls' -> fst call = fst f. Proof. intros. specialize (Produce_action_from_collector _ H H0) as TMP; dest. destruct call; inv H5; simpl; reflexivity. Qed. Lemma collector_correct_pair f o reads upds calls calls' call : In call calls' -> PSemAction_meth_collector f o reads upds calls calls' -> (fst call, projT1 (snd call)) = (fst f, projT1 (snd f)). Proof. intros. specialize (Produce_action_from_collector _ H H0) as TMP; dest. destruct call; inv H5; simpl; reflexivity. Qed. Definition called_by (f : DefMethT) (call :MethT) : bool := (getBool (prod_dec string_dec Signature_dec (fst f, projT1 (snd f)) (fst call, projT1 (snd call)))). Local Notation complement f := (fun x => negb (f x)). Definition called_execs (calls : MethsT) (exec : RuleOrMeth) : bool := match exec with | Rle _ => false | Meth f => existsb (methcmp f) calls end. Lemma separate_calls_by_filter (A : Type) (l : list A) (f : A -> bool): l [=] (filter f l) ++ (filter (complement f) l). Proof. induction l; auto; simpl. destruct (f a); simpl; rewrite IHl at 1;[reflexivity|apply Permutation_middle]. Qed. Lemma reduce_called_execs_list execs c : ~In (Meth c) execs -> forall calls, (filter (called_execs (c::calls)) execs) = (filter (called_execs calls) execs). Proof. induction execs; intros; auto. unfold called_execs, methcmp in *; destruct a; simpl in *. - eapply IHexecs. intro; apply H. right; assumption. - destruct MethT_dec; simpl. + apply False_ind; apply H. rewrite e; left; reflexivity. + rewrite IHexecs;[reflexivity|]. intro; apply H; right; assumption. Qed. Corollary collector_called_by_filter_irrel f o calls' : forall reads upds calls, PSemAction_meth_collector f o reads upds calls calls' -> (filter (called_by f) calls') = calls'. Proof. induction calls'; intros; auto. specialize (collector_correct_pair _ (in_eq _ _) H); intro. Opaque prod_dec. unfold called_by; simpl; destruct prod_dec;[simpl;fold (called_by f)|symmetry in H0; contradiction]. specialize (Produce_action_from_collector _ (in_eq _ _ ) H) as TMP; dest. apply Permutation_cons_inv in H6. rewrite <- H6 in H8. erewrite IHcalls'; eauto. Transparent prod_dec. Qed. Corollary collector_complement_called_by_filter_nil f o calls' : forall reads upds calls, PSemAction_meth_collector f o reads upds calls calls' -> (filter (complement (called_by f)) calls') = nil. Proof. intros. specialize (separate_calls_by_filter calls' (called_by f)) as parti. rewrite (collector_called_by_filter_irrel H) in parti. rewrite <- app_nil_r in parti at 1. apply Permutation_app_inv_l in parti. apply Permutation_nil in parti; assumption. Qed. Lemma collector_correct_snd f o reads upds calls calls' call : In call calls' -> PSemAction_meth_collector f o reads upds calls calls' -> exists argV retV, snd call = (existT _ (projT1 (snd f)) (argV, retV)). Proof. intros. specialize (Produce_action_from_collector _ H H0) as TMP; dest. destruct call; inv H5; simpl; exists x6, x7; reflexivity. Qed. Lemma notIn_filter_nil (f : DefMethT) (calls : MethsT) : ~In (fst f, projT1 (snd f)) (getKindAttr calls) -> filter (called_by f) calls = nil. Proof. induction calls; auto; simpl. intro; dest. unfold called_by; destruct prod_dec; simpl; auto. apply False_ind, H; auto. Qed. Lemma notIn_complement_filter_irrel (f : DefMethT) (calls : MethsT) : ~In (fst f, projT1 (snd f)) (getKindAttr calls) -> filter (complement (called_by f)) calls = calls. Proof. induction calls; auto; simpl; intros. unfold called_by in *; destruct prod_dec; simpl in *; [apply False_ind, H|rewrite IHcalls];auto. Qed. Lemma filter_complement_disj (A : Type) (dec : forall (a1 a2 : A), {a1=a2}+{a1<>a2}) (f : A -> bool) (l : list A) : forall x, ~In x (filter f l) \/ ~In x (filter (complement f) l). Proof. intros. destruct (in_dec dec x (filter f l)). - rewrite filter_In in i; dest. right; intro. rewrite filter_In in H1; dest. rewrite H0 in H2; discriminate. - left; assumption. Qed. Lemma PSemAction_NoDup_Key_Writes k o (a : ActionT type k) readRegs newRegs calls (fret : type k) : PSemAction o a readRegs newRegs calls fret -> NoDup (map fst newRegs). Proof. induction 1; eauto;[| rewrite HANewRegs; simpl; econstructor; eauto; intro; specialize (fst_produce_snd _ _ H0) as TMP; dest; specialize (HDisjRegs x); contradiction| | |subst; econstructor]; rewrite HUNewRegs; rewrite map_app,NoDup_app_iff; repeat split; eauto; repeat intro; specialize (HDisjRegs a0); tauto. Qed. Corollary PSemAction_NoDup_Writes k o (a : ActionT type k) readRegs newRegs calls (fret : type k) : PSemAction o a readRegs newRegs calls fret -> NoDup newRegs. Proof. intros; apply PSemAction_NoDup_Key_Writes in H; apply NoDup_map_inv in H; assumption. Qed. Lemma collector_NoDupRegs1 (f : DefMethT) o reads upds calls calls' : PSemAction_meth_collector f o reads upds calls calls' -> NoDup (map fst upds). Proof. induction 1. - constructor. - rewrite H2, map_app, NoDup_app_iff. specialize (PSemAction_NoDup_Key_Writes H5) as ND2. repeat split; auto; repeat intro; specialize (H0 a); firstorder. Qed. Lemma PSemAction_inline_In (f : DefMethT) o: forall {retK2} a calls1 calls2 readRegs newRegs (retV2 : type retK2), PSemAction o a readRegs newRegs (calls1++calls2) retV2 -> ~In (fst f, projT1 (snd f)) (getKindAttr calls2) -> forall readRegs' newRegs' calls', DisjKey newRegs' newRegs -> PSemAction_meth_collector f o readRegs' newRegs' calls' calls1 -> PSemAction o (inlineSingle a f) (readRegs' ++ readRegs) (newRegs' ++ newRegs) (calls'++calls2) retV2. Proof. induction a; intros. - simpl; destruct (fst f =? meth) eqn:G; [rewrite String.eqb_eq in G|rewrite eqb_neq in G]; [destruct Signature_dec | ]; subst. + inv H0; EqDep_subst. assert (In (fst f, existT SignT (projT1 (snd f)) (evalExpr e, mret)) calls1). { case (in_app_or _ _ _ (Permutation_in _ (Permutation_sym (HAcalls)) (in_eq _ _))); auto; intros TMP;apply (in_map (fun x => (fst x, projT1 (snd x)))) in TMP; contradiction. } specialize (Produce_action_from_collector _ H0 H3) as TMP; destruct TMP as [creads1 [creads2 [cupds1 [cupds2 [ccalls1 [ccalls2 [ccalls'' [cargV [cretV decomp]]]]]]]]]. destruct decomp as [HDisju12 [HNr21 [HC21 [HRr21 [Hceq [HC1 [HSa HSac]]]]]]]. inv Hceq; EqDep_subst. econstructor. * rewrite HNr21 in H2. assert (DisjKey cupds2 (cupds1++newRegs)) as HDjk21n;[|apply HDjk21n]. intro; specialize (H2 k); specialize (HDisju12 k); rewrite map_app,in_app_iff, DeM1 in *. clear - H2 HDisju12; firstorder fail. * econstructor; eauto. * rewrite HRr21, <-app_assoc. apply Permutation_app_head. reflexivity. * rewrite HNr21, <-app_assoc; reflexivity. * rewrite HC21, <-app_assoc; reflexivity. * eapply H; auto. -- rewrite HC1 in HAcalls; simpl in *. apply Permutation_cons_inv in HAcalls. symmetry in HAcalls. apply (PSemAction_rewrite_calls HAcalls HPSemAction). -- rewrite HNr21 in H2. intro; specialize (H2 k); rewrite map_app, in_app_iff in *. clear - H2; firstorder fail. -- assumption. + inv H0; EqDep_subst. specialize (Permutation_in _ (Permutation_sym HAcalls) (in_eq _ _)); intro TMP. rewrite in_app_iff in TMP; destruct TMP as [H0|H0];[apply (collector_correct_pair _ H0) in H3; simpl in *; inv H3; contradiction|]. apply in_split in H0; dest. rewrite H0, <-Permutation_middle, Permutation_app_comm in HAcalls; simpl in *. apply Permutation_cons_inv in HAcalls. rewrite Permutation_app_comm in HAcalls. econstructor. * rewrite H0, app_assoc,Permutation_app_comm; simpl. apply perm_skip. setoid_rewrite Permutation_app_comm. rewrite <-app_assoc. reflexivity. * eapply H; auto. -- apply (PSemAction_rewrite_calls (Permutation_sym HAcalls) HPSemAction). -- rewrite H0 in H1. rewrite map_app, in_app_iff in *. simpl in *; repeat rewrite DeM1 in *; clear - H1; firstorder fail. -- assumption. + inv H0; EqDep_subst. specialize (Permutation_in _ (Permutation_sym HAcalls) (in_eq _ _)); intro TMP. rewrite in_app_iff in TMP; destruct TMP as [H0|H0];[apply (collector_correct_pair _ H0) in H3; simpl in *; inv H3; contradiction |]. apply in_split in H0; dest. rewrite H0, <-Permutation_middle, Permutation_app_comm in HAcalls; simpl in *. apply Permutation_cons_inv in HAcalls. rewrite Permutation_app_comm in HAcalls. econstructor. * rewrite H0, app_assoc,Permutation_app_comm; simpl. apply perm_skip. setoid_rewrite Permutation_app_comm. rewrite <-app_assoc. reflexivity. * eapply H; auto. -- apply (PSemAction_rewrite_calls (Permutation_sym HAcalls) HPSemAction). -- rewrite H0 in H1. rewrite map_app, in_app_iff in *. simpl in *; repeat rewrite DeM1 in *; clear - H1; firstorder fail. -- assumption. - inv H0; EqDep_subst. econstructor 2; eauto. - inv H0; EqDep_subst. specialize (Permutation_filter (called_by f) HUCalls) as HC1. rewrite filter_app, (collector_called_by_filter_irrel H3), notIn_filter_nil, app_nil_r in HC1; auto. specialize (Permutation_filter (complement (called_by f)) HUCalls) as HC2. rewrite filter_app, (collector_complement_called_by_filter_nil H3), (notIn_complement_filter_irrel) in HC2; auto; simpl in *. rewrite filter_app in *. rewrite HC1 in H3. specialize (collector_split _ _ H3) as TMP; destruct TMP as [sreads1 [sreads2 [supds1 [supds2 [scalls1 [scalls2 TMP]]]]]]. destruct TMP as [HRr12 [HNr12 [HC12 [HDisjs12 [HCol1 HCol2]]]]]. econstructor 3. + rewrite HNr12, HUNewRegs in H2. specialize (collector_NoDupRegs1 H3); rewrite HNr12, map_app; intros TMP. assert (DisjKey (supds1++newRegs0) (supds2++newRegsCont));[|apply H0]. intro; specialize (H2 k0); specialize (HDisjRegs k0);specialize (NoDup_app_Disj string_dec _ _ TMP k0) as TMP2. repeat rewrite map_app, in_app_iff in *. clear - H2 HDisjRegs TMP2; firstorder fail. + eapply IHa. * apply (PSemAction_rewrite_calls (separate_calls_by_filter calls (called_by f))) in HPSemAction. apply HPSemAction. * intro; apply H1; rewrite HC2, map_app, in_app_iff; left; assumption. *rewrite HNr12, HUNewRegs in H2. intro; specialize (H2 k0); repeat rewrite map_app, in_app_iff in *. clear - H2; firstorder fail. * apply HCol1. + rewrite HRr12, HUReadRegs. repeat rewrite <-app_assoc. apply Permutation_app_head. rewrite app_assoc,Permutation_app_comm. rewrite app_assoc. rewrite Permutation_app_comm. apply Permutation_app_head. apply Permutation_app_comm. + rewrite HNr12, HUNewRegs. repeat rewrite <-app_assoc. apply Permutation_app_head. repeat rewrite app_assoc. apply Permutation_app_tail. apply Permutation_app_comm. + rewrite HC2, HC12. repeat rewrite <-app_assoc. apply Permutation_app_head. rewrite app_assoc, Permutation_app_comm. rewrite app_assoc. rewrite Permutation_app_comm; apply Permutation_app_head. apply Permutation_app_comm. + eapply H; eauto. * apply (PSemAction_rewrite_calls (separate_calls_by_filter callsCont (called_by f)) HPSemActionCont). * rewrite HC2, map_app,in_app_iff in H1; dest; clear - H1; tauto. * rewrite HNr12, HUNewRegs in H2. intro k0; specialize (H2 k0). repeat rewrite map_app, in_app_iff in H2. clear - H2; firstorder fail. - inv H0; EqDep_subst. simpl; econstructor 4; eauto. - inv H0; EqDep_subst. simpl; econstructor 5. + apply HRegVal. + eapply H; eauto. + rewrite HNewReads. symmetry. apply Permutation_middle. - inv H; EqDep_subst. simpl; econstructor 6; auto. + assert (key_not_In r (newRegs'++newRegs0));[|apply H]. intro; rewrite in_app_iff. specialize (HDisjRegs v). intro; destruct H; auto. apply (in_map fst) in H; simpl in *. rewrite HANewRegs in H1; specialize (H1 r). destruct H1;[contradiction|apply H1; left; reflexivity]. + rewrite HANewRegs. rewrite Permutation_app_comm; simpl. apply perm_skip, Permutation_app_comm. + eapply IHa; eauto. rewrite HANewRegs in H1; intro k0; specialize (H1 k0); simpl in *. clear - H1; firstorder fail. - inv H0; EqDep_subst; simpl. + specialize (Permutation_filter (called_by f) HUCalls) as HC1. rewrite filter_app, (collector_called_by_filter_irrel H3), notIn_filter_nil, app_nil_r in HC1; auto. specialize (Permutation_filter (complement (called_by f)) HUCalls) as HC2. rewrite filter_app, (collector_complement_called_by_filter_nil H3), (notIn_complement_filter_irrel) in HC2; auto; simpl in *. rewrite filter_app in *. rewrite HC1 in H3. specialize (collector_split _ _ H3) as TMP; destruct TMP as [sreads1 [sreads2 [supds1 [supds2 [scalls1 [scalls2 TMP]]]]]]. destruct TMP as [HRr12 [HNr12 [HC12 [HDisjs12 [HCol1 HCol2]]]]]. econstructor 7. * rewrite HNr12, HUNewRegs in H2. specialize (collector_NoDupRegs1 H3); rewrite HNr12, map_app; intros TMP. assert (DisjKey (supds1++newRegs1) (supds2++newRegs2));[|apply H0]. intro; specialize (H2 k0); specialize (HDisjRegs k0);specialize (NoDup_app_Disj string_dec _ _ TMP k0) as TMP2. repeat rewrite map_app, in_app_iff in *. clear - H2 HDisjRegs TMP2; firstorder fail. * assumption. * eapply IHa1. -- apply (PSemAction_rewrite_calls (separate_calls_by_filter calls0 (called_by f))) in HAction. apply HAction. -- intro; apply H1; rewrite HC2, map_app, in_app_iff; left; assumption. -- rewrite HNr12, HUNewRegs in H2. intro; specialize (H2 k0); repeat rewrite map_app, in_app_iff in *. clear - H2; firstorder fail. -- apply HCol1. * eapply H. -- apply (PSemAction_rewrite_calls (separate_calls_by_filter calls3 (called_by f)) HPSemAction). -- rewrite HC2, map_app,in_app_iff in H1; clear -H1; firstorder fail. -- rewrite HNr12, HUNewRegs in H2. intro k0; specialize (H2 k0). repeat rewrite map_app, in_app_iff in H2. clear - H2; firstorder fail. --apply HCol2. * rewrite HRr12, HUReadRegs. repeat rewrite <-app_assoc. apply Permutation_app_head. rewrite app_assoc,Permutation_app_comm. rewrite app_assoc. rewrite Permutation_app_comm. apply Permutation_app_head. apply Permutation_app_comm. * rewrite HNr12, HUNewRegs. repeat rewrite <-app_assoc. apply Permutation_app_head. repeat rewrite app_assoc. apply Permutation_app_tail. apply Permutation_app_comm. * rewrite HC2, HC12. repeat rewrite <-app_assoc. apply Permutation_app_head. repeat rewrite app_assoc. apply Permutation_app_tail. apply Permutation_app_comm. + specialize (Permutation_filter (called_by f) HUCalls) as HC1. rewrite filter_app, (collector_called_by_filter_irrel H3), notIn_filter_nil, app_nil_r in HC1; auto. specialize (Permutation_filter (complement (called_by f)) HUCalls) as HC2. rewrite filter_app, (collector_complement_called_by_filter_nil H3), (notIn_complement_filter_irrel) in HC2; auto; simpl in *. rewrite filter_app in *. rewrite HC1 in H3. specialize (collector_split _ _ H3) as TMP; destruct TMP as [sreads1 [sreads2 [supds1 [supds2 [scalls1 [scalls2 TMP]]]]]]. destruct TMP as [HRr12 [HNr12 [HC12 [HDisjs12 [HCol1 HCol2]]]]]. econstructor 8. * rewrite HNr12, HUNewRegs in H2. specialize (collector_NoDupRegs1 H3); rewrite HNr12, map_app; intros TMP. assert (DisjKey (supds1++newRegs1) (supds2++newRegs2));[|apply H0]. intro; specialize (H2 k0); specialize (HDisjRegs k0);specialize (NoDup_app_Disj string_dec _ _ TMP k0) as TMP2. repeat rewrite map_app, in_app_iff in *. clear - H2 HDisjRegs TMP2; firstorder fail. * assumption. * eapply IHa2. -- apply (PSemAction_rewrite_calls (separate_calls_by_filter calls0 (called_by f))) in HAction. apply HAction. -- intro; apply H1; rewrite HC2, map_app, in_app_iff; left; assumption. -- rewrite HNr12, HUNewRegs in H2. intro; specialize (H2 k0); repeat rewrite map_app, in_app_iff in *. clear - H2; firstorder fail. -- apply HCol1. * eapply H. -- apply (PSemAction_rewrite_calls (separate_calls_by_filter calls3 (called_by f)) HPSemAction). -- rewrite HC2, map_app,in_app_iff in H1; dest; clear -H1; firstorder fail. -- rewrite HNr12, HUNewRegs in H2. intro k0; specialize (H2 k0). repeat rewrite map_app, in_app_iff in H2. clear - H2; firstorder fail. --apply HCol2. * rewrite HRr12, HUReadRegs. repeat rewrite <-app_assoc. apply Permutation_app_head. rewrite app_assoc,Permutation_app_comm. rewrite app_assoc. rewrite Permutation_app_comm. apply Permutation_app_head. apply Permutation_app_comm. * rewrite HNr12, HUNewRegs. repeat rewrite <-app_assoc. apply Permutation_app_head. repeat rewrite app_assoc. apply Permutation_app_tail. apply Permutation_app_comm. * rewrite HC2, HC12. repeat rewrite <-app_assoc. apply Permutation_app_head. repeat rewrite app_assoc. apply Permutation_app_tail. apply Permutation_app_comm. - inv H; EqDep_subst. econstructor 9; eauto. - inv H; EqDep_subst. apply app_eq_nil in HCalls; dest; subst. inv H2; simpl in *. + econstructor 10; eauto. + apply Permutation_nil in H7; discriminate. Qed. Lemma Substeps_permutation_invariant m o l l' : l [=] l' -> Substeps m o l -> Substeps m o l'. Proof. induction 1; intros; auto. - inv H0. + inv HLabel. econstructor 2; eauto; setoid_rewrite <- H; auto. + inv HLabel. econstructor 3; eauto; setoid_rewrite <- H; auto. - inv H. + inv HLabel. inv HSubstep; inv HLabel. * specialize (HNoRle _ (in_eq _ _)); simpl in *; contradiction. * econstructor 3; eauto; intros. -- destruct H; subst. ++ simpl. specialize (HDisjRegs _ (in_eq _ _)); simpl in *. apply DisjKey_Commutative; assumption. ++ eapply HDisjRegs0; auto. -- econstructor 2; eauto; intros. ++ eapply HDisjRegs; right; assumption. ++ eapply HNoRle; right; assumption. + inv HLabel. inv HSubsteps; inv HLabel. * econstructor 2; eauto; intros. -- destruct H; subst. ++ simpl. specialize (HDisjRegs _ (in_eq _ _)); simpl in *. apply DisjKey_Commutative; assumption. ++ eapply HDisjRegs0; auto. -- destruct H; subst; simpl in *; auto. eapply HNoRle; eauto. -- econstructor 3; eauto; intros. ++ eapply HDisjRegs; right; assumption. * econstructor 3; eauto; intros. -- destruct H; subst; simpl. ++ specialize (HDisjRegs _ (in_eq _ _)); simpl in *. apply DisjKey_Commutative; assumption. ++ eapply HDisjRegs0; eauto. -- econstructor 3; auto; auto;[apply HAction | | ]; auto; intros. ++ eapply HDisjRegs; right; assumption. Qed. Global Instance Substeps_perm_rewrite' : Proper (eq ==> eq ==> @Permutation FullLabel ==> iff) (@Substeps) | 10. Proof. repeat red; intros; split; intro; subst; eauto using Permutation_sym, Substeps_permutation_invariant. Qed. Lemma KeyMatching2 (l : list DefMethT) (a b : DefMethT): NoDup (map fst l) -> In a l -> In b l -> fst a = fst b -> a = b. Proof. induction l; intros. - inv H0. - destruct H0, H1; subst; auto; simpl in *. + inv H. apply False_ind, H4. rewrite H2, in_map_iff. exists b; firstorder. + inv H. apply False_ind, H4. rewrite <- H2, in_map_iff. exists a; firstorder. + inv H. eapply IHl; eauto. Qed. Lemma extract_exec (f : DefMethT) m o l u cs fb: NoDup (map fst (getMethods m)) -> In f (getMethods m) -> Substeps m o ((u, (Meth ((fst f), fb), cs))::l) -> exists reads e mret, fb = existT SignT (projT1 (snd f)) (e, mret) /\ DisjKey u (getLabelUpds l) /\ SemAction o ((projT2 (snd f) type) e) reads u cs mret /\ SubList (getKindAttr u) (getKindAttr (getRegisters m)) /\ SubList (getKindAttr reads) (getKindAttr (getRegisters m)) /\ Substeps m o l. Proof. intros. inv H1. - inv HLabel. - inv HLabel. destruct f, s0, fb0; simpl in *; subst;EqDep_subst. specialize (KeyMatching2 _ _ _ H HInMeths H0 (eq_refl)) as TMP. inv TMP; EqDep_subst. exists reads, argV, retV; repeat split; auto. + apply DisjKey_Commutative. clear - HDisjRegs. induction ls. * intro; left; auto. * unfold getLabelUpds in *; simpl. intro; rewrite map_app, in_app_iff, DeM1. specialize (HDisjRegs a (in_eq _ _) k) as TMP; simpl in *. assert (forall x, In x ls -> DisjKey (fst x) u0);[intros; eapply HDisjRegs; eauto|]. specialize (IHls H k) as TMP2; destruct TMP, TMP2; tauto. Qed. Lemma List_FullLabel_perm_getLabelUpds_perm l1 l2: List_FullLabel_perm l1 l2 -> getLabelUpds l1 [=] getLabelUpds l2. Proof. induction 1. - reflexivity. - unfold getLabelUpds in *; inv H; simpl in *. rewrite H1, IHList_FullLabel_perm; reflexivity. - unfold getLabelUpds in *; inv H; inv H0; simpl in *. rewrite H2, H, IHList_FullLabel_perm; repeat rewrite app_assoc. apply Permutation_app_tail. apply Permutation_app_comm. - rewrite IHList_FullLabel_perm1, IHList_FullLabel_perm2; reflexivity. Qed. Lemma List_FullLabel_perm_getLabelCalls_perm l1 l2: List_FullLabel_perm l1 l2 -> getLabelCalls l1 [=] getLabelCalls l2. Proof. induction 1. - reflexivity. - unfold getLabelCalls in *; inv H; simpl in *. rewrite H3, IHList_FullLabel_perm; reflexivity. - unfold getLabelCalls in *; inv H; inv H0; simpl in *. rewrite H4, H5, IHList_FullLabel_perm; repeat rewrite app_assoc. apply Permutation_app_tail. apply Permutation_app_comm. - rewrite IHList_FullLabel_perm1, IHList_FullLabel_perm2; reflexivity. Qed. Lemma List_FullLabel_perm_getLabelExecs_perm l1 l2: List_FullLabel_perm l1 l2 -> getLabelExecs l1 [=] getLabelExecs l2. Proof. induction 1. - reflexivity. - unfold getLabelExecs in *; inv H; simpl in *. rewrite IHList_FullLabel_perm; reflexivity. - unfold getLabelExecs in *; inv H; inv H0; simpl in *. rewrite IHList_FullLabel_perm. apply perm_swap. - rewrite IHList_FullLabel_perm1, IHList_FullLabel_perm2; reflexivity. Qed. Lemma extract_exec_P (f : DefMethT) m o l u cs fb: NoDup (map fst (getMethods m)) -> In f (getMethods m) -> PSubsteps m o ((u, (Meth ((fst f),fb), cs))::l) -> exists reads e mret, fb = existT SignT (projT1 (snd f)) (e, mret) /\ DisjKey u (getLabelUpds l) /\ PSemAction o ((projT2 (snd f) type) e) reads u cs mret /\ SubList (getKindAttr u) (getKindAttr (getRegisters m)) /\ SubList (getKindAttr reads) (getKindAttr (getRegisters m)) /\ PSubsteps m o l. Proof. intros. apply (PSubsteps_Substeps) in H1; dest. specialize (List_FullLabel_perm_in H2 _ (in_eq _ _)) as TMP; dest. specialize (in_split _ _ H6) as TMP; dest. rewrite H7, <- Permutation_middle in H2. specialize (List_FullLabel_perm_cons_inv H5 H2) as P2. inv H5. apply (Substeps_permutation_invariant (Permutation_sym (Permutation_middle _ _ _))) in H4. apply (extract_exec f) in H4; auto; dest. exists x0, x1, x4; repeat split; auto. + rewrite H11. rewrite (List_FullLabel_perm_getLabelUpds_perm P2). assumption. + symmetry in H1, H11, H14. apply (PSemAction_rewrite_state H1). apply (PSemAction_rewrite_newRegs H11). apply (PSemAction_rewrite_calls H14). apply SemAction_PSemAction; assumption. + rewrite H11; assumption. + rewrite P2, H1. apply Substeps_PSubsteps; assumption. Qed. Corollary extract_exec_PPlus (f : DefMethT) m o upds execs calls fb: NoDup (map fst (getMethods m)) -> In f (getMethods m) -> PPlusSubsteps m o upds ((Meth ((fst f),fb))::execs) calls -> exists reads upds1 upds2 calls1 calls2 e mret, fb = existT SignT (projT1 (snd f)) (e, mret) /\ PSemAction o ((projT2 (snd f) type) e) reads upds1 calls1 mret /\ upds [=] upds1++upds2 /\ calls [=] calls1++calls2 /\ DisjKey upds1 upds2 /\ SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) /\ SubList (getKindAttr reads) (getKindAttr (getRegisters m)) /\ PPlusSubsteps m o upds2 execs calls2. Proof. intros. apply (PPlusSubsteps_PSubsteps) in H1; dest. unfold getLabelExecs, getLabelUpds, getLabelCalls in *. specialize (Permutation_in _ H3 (in_eq _ _)) as H3'. rewrite (in_map_iff) in H3'; dest; destruct x0, p. apply in_split in H6; dest; rewrite H6,map_app in H4, H3, H2;rewrite concat_app in *; simpl in *. rewrite H5 in *;rewrite H6, <-Permutation_middle in H1. rewrite <- Permutation_middle, <- map_app in H3. apply Permutation_cons_inv in H3. apply extract_exec_P in H1; eauto; dest. exists x2, r, (getLabelUpds (x0++x1)), m0, (getLabelCalls (x0++x1)), x3, x4; repeat split; auto; [rewrite H2; unfold getLabelUpds| rewrite H4; unfold getLabelCalls | rewrite H3; apply PSubsteps_PPlusSubsteps; assumption]; rewrite map_app, concat_app; repeat rewrite app_assoc; apply Permutation_app_tail; rewrite Permutation_app_comm; reflexivity. Qed. Lemma SubList_app_l_iff (A : Type) (l1 l2 l : list A) : SubList (l1++l2) l <-> SubList l1 l /\ SubList l2 l. Proof. split; intros;[apply SubList_app_l; auto|]. destruct H; repeat intro; rewrite in_app_iff in H1; destruct H1; eauto. Qed. Corollary extract_execs_PPlus (f : DefMethT) m o execs fcalls: NoDup (map fst (getMethods m)) -> In f (getMethods m) -> (forall g, In g fcalls -> (fst g = fst f)) -> forall upds calls, PPlusSubsteps m o upds ((map Meth fcalls)++execs) calls -> exists reads upds1 upds2 calls1 calls2, PSemAction_meth_collector f o reads upds1 calls1 fcalls /\ calls [=] calls1++calls2 /\ upds [=] upds1++upds2 /\ DisjKey upds1 upds2 /\ SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) /\ SubList (getKindAttr reads) (getKindAttr (getRegisters m)) /\ PPlusSubsteps m o upds2 execs calls2. Proof. induction fcalls; simpl; intros. - exists nil, nil, upds, nil, calls. repeat split; auto. + constructor. + intro; left; intro; contradiction. + repeat intro; contradiction. + repeat intro; contradiction. - assert (forall g, In g fcalls -> fst g = fst f) as P1;[auto|]. destruct a; specialize (H1 (s, s0) (or_introl _ eq_refl)) as P2; simpl in P2; rewrite P2 in H2. specialize (extract_exec_PPlus _ H H0 H2) as TMP; dest. specialize (IHfcalls H H0 P1 _ _ H10); dest. exists (x++x6), (x0++x7), x8, (x2++x9), x10. repeat split. + econstructor 2. * apply H11. * assert (DisjKey x7 x0) as goal;[|apply goal]. intro k; specialize (H7 k); rewrite H13, map_app, in_app_iff in H7; clear -H7; firstorder fail. * apply Permutation_app_comm. * apply Permutation_app_comm. * apply Permutation_app_comm. * rewrite P2, H3; reflexivity. * assumption. + rewrite H6, H12, app_assoc; reflexivity. + rewrite H5, H13, app_assoc; reflexivity. + intro k; specialize (H14 k); specialize (H7 k). rewrite H13 in H7. rewrite map_app, in_app_iff in *. clear -H14 H7; firstorder fail. + rewrite map_app, SubList_app_l_iff; auto. + rewrite map_app, SubList_app_l_iff; auto. + assumption. Qed. Lemma getNumFromExecs_gt_0 f execs : (0 < getNumFromExecs f execs)%Z -> In (Meth f) execs. Proof. induction execs; intros;[inv H|]. destruct a;[|destruct (MethT_dec f f0)]. - rewrite getNumFromExecs_Rle_cons in H. specialize (IHexecs H). right; assumption. - subst; left; reflexivity. - rewrite getNumFromExecs_neq_cons in H; auto. specialize (IHexecs H). right; assumption. Qed. Lemma getNumFromCalls_gt_0 f calls : (0 < getNumFromCalls f calls)%Z -> In f calls. induction calls; intros;[inv H|]. destruct (MethT_dec f a). - subst; left; reflexivity. - rewrite getNumFromCalls_neq_cons in H; auto. specialize (IHcalls H). right; assumption. Qed. Lemma rewrite_called_execs: forall calls execs, (forall f, getNumFromCalls f calls <= getNumFromExecs f execs)%Z -> exists execs', execs [=] ((map Meth (calls))++execs'). Proof. induction calls; intros. - exists execs; reflexivity. - specialize (H a) as P1. rewrite getNumFromCalls_eq_cons in P1; auto. assert ((0 < getNumFromExecs a execs)%Z) as P2;[specialize (getNumFromCalls_nonneg a calls) as TMP1;Omega.omega|]. specialize (in_split _ _ (getNumFromExecs_gt_0 _ _ P2)) as TMP; dest. rewrite H0 in H; setoid_rewrite <-Permutation_middle in H. assert (forall f, (getNumFromCalls f calls <= getNumFromExecs f (x++x0))%Z). + intros; specialize (H f); destruct (MethT_dec f a);[rewrite getNumFromCalls_eq_cons, getNumFromExecs_eq_cons in H |rewrite getNumFromCalls_neq_cons, getNumFromExecs_neq_cons in H];auto;Omega.omega. + specialize (IHcalls _ H1); dest. exists x1; rewrite H0, <-Permutation_middle. simpl; rewrite H2; reflexivity. Qed. Lemma MatchingExecCalls_flat_surjective f calls execs m : In f (getMethods m) -> MatchingExecCalls_flat calls execs m -> forall g, In g (filter (called_by f) calls) -> In (Meth g) execs. Proof. unfold MatchingExecCalls_flat. induction calls; intros. - contradiction. - Opaque prod_dec. unfold called_by in H1; simpl in H1. destruct prod_dec; subst; simpl in H1. + destruct H1; subst. * apply (in_map (fun x => (fst x, projT1 (snd x)))) in H; rewrite e in H. specialize (H0 _ H). rewrite getNumFromCalls_eq_cons in H0; auto. specialize (getNumFromCalls_nonneg g calls) as P1. apply getNumFromExecs_gt_0; Omega.omega. * apply IHcalls; auto. intros f0 P1; specialize (H0 _ P1). destruct (MethT_dec f0 a);[rewrite getNumFromCalls_eq_cons in H0 |rewrite getNumFromCalls_neq_cons in H0]; auto; Omega.omega. + apply IHcalls; auto. intros f0 P1; specialize (H0 _ P1). destruct (MethT_dec f0 a);[rewrite getNumFromCalls_eq_cons in H0 |rewrite getNumFromCalls_neq_cons in H0]; auto; Omega.omega. Transparent prod_dec. Qed. Lemma MatchingExecCalls_flat_surjective_split f calls m : In f (getMethods m) -> forall execs, MatchingExecCalls_flat calls execs m -> exists execs', execs [=] (map Meth (filter (called_by f) calls))++execs'. Proof. unfold MatchingExecCalls_flat. induction calls; intros. - simpl; exists execs; reflexivity. - destruct (prod_dec string_dec Signature_dec (fst f, projT1 (snd f)) (fst a, projT1 (snd a))). + specialize (in_map (fun x => (fst x, projT1 (snd x))) _ _ H) as P1; simpl in P1; rewrite e in P1. specialize (H0 a P1) as P2. rewrite getNumFromCalls_eq_cons in P2; auto. specialize (getNumFromCalls_nonneg a calls) as P3. assert (0 < getNumFromExecs a execs)%Z as P4;[Omega.omega|]. specialize (getNumFromExecs_gt_0 _ _ P4) as P5; apply in_split in P5; dest. setoid_rewrite H1 in H0; setoid_rewrite <-Permutation_middle in H0. assert (forall f, In (fst f, projT1 (snd f)) (getKindAttr (getMethods m)) -> (getNumFromCalls f calls <= getNumFromExecs f (x++x0))%Z) as P5. * intros f0 HInDef; specialize (H0 _ HInDef). destruct (MethT_dec f0 a);[rewrite getNumFromCalls_eq_cons, getNumFromExecs_eq_cons in H0 |rewrite getNumFromCalls_neq_cons, getNumFromExecs_neq_cons in H0]; auto; Omega.omega. * specialize (IHcalls H _ P5); dest. exists x1. Opaque prod_dec. unfold called_by; simpl; destruct prod_dec;[simpl|contradiction]. rewrite H1, <-Permutation_middle, H2; unfold called_by; reflexivity. + unfold called_by in *; simpl; destruct prod_dec;[contradiction|simpl]. apply IHcalls; auto. intros f0 HInDef; specialize (H0 _ HInDef). destruct (MethT_dec f0 a);[rewrite getNumFromCalls_eq_cons in H0 |rewrite getNumFromCalls_neq_cons in H0]; auto; Omega.omega. Transparent prod_dec. Qed. Lemma filter_preserves_NoDup A (f : A -> bool) l : NoDup l -> NoDup (filter f l). Proof. induction 1. - simpl; constructor. - unfold filter; destruct (f x); fold (filter f l); auto. + econstructor; eauto. intro; apply H. rewrite filter_In in H1; dest; assumption. Qed. Lemma InRule_In_inlined f rn rb m: In (rn, rb) (getRules m) -> In (rn, (fun ty => (inlineSingle (rb ty) f))) (getRules (inlineSingle_Rule_BaseModule f rn m)). Proof. destruct m; simpl in *. - intro; contradiction. - induction rules. + intro; contradiction. + intros. destruct H; subst. * simpl. rewrite eqb_refl. left; reflexivity. * simpl; right; auto. Qed. Lemma InRule_In_inlined_neq f rn1 rn2 rb m: rn1 <> rn2 -> In (rn2, rb) (getRules m) -> In (rn2, rb) (getRules (inlineSingle_Rule_BaseModule f rn1 m)). Proof. destruct m; simpl in *. - intro; contradiction. - induction rules. + intro; contradiction. + intros. destruct H0; subst. * simpl. rewrite <- String.eqb_neq in H; rewrite H. left; auto. * simpl; right; auto. Qed. Lemma PSubsteps_inlineRule_notIn f m o rn l: PSubsteps m o l -> ~In (fst f) (map fst (getLabelCalls l)) -> PSubsteps (inlineSingle_Rule_BaseModule f rn m) o l. Proof. induction 1; intros. - econstructor 1; simpl; assumption. - rewrite HLabel in H0. pose proof H0 as H0'; unfold getLabelCalls in H0. simpl in H0; rewrite map_app, in_app_iff, DeM1 in H0; dest. fold (getLabelCalls ls) in H1. destruct (string_dec rn rn0). + subst. specialize (InRule_In_inlined f _ _ _ HInRules) as P1. econstructor 2 with(u:=u)(reads:=reads); simpl in *; eauto. simpl; apply PSemAction_inline_notIn; auto. + specialize (InRule_In_inlined_neq f _ _ n HInRules) as P1. econstructor 2 with (u:=u)(reads:=reads); simpl in *; eauto. - econstructor 3; simpl; eauto. rewrite HLabel in H0. unfold getLabelCalls in H0; simpl in H0; rewrite map_app, in_app_iff, DeM1 in H0; dest. apply (IHPSubsteps H1). Qed. Lemma Substeps_inline_Rule_NoExec_PSubsteps f m o rn (l : list FullLabel) : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> ~In (Rle rn) (map getRleOrMeth l) -> Substeps m o l -> PSubsteps (inlineSingle_Rule_BaseModule f rn m) o l. Proof. induction 4. - econstructor 1; simpl; rewrite HRegs; reflexivity. - econstructor 2 with (u:= u) (reads:=reads); simpl; eauto. + rewrite HRegs; reflexivity. + assert (rn <> rn0); [intro; subst; apply H1; simpl; left; reflexivity|]. apply InRule_In_inlined_neq; eauto. + apply (SemAction_PSemAction HAction). + rewrite HLabel; reflexivity. + apply IHSubsteps; auto. rewrite HLabel in H1; simpl in H1. intro; apply H1; right; assumption. - econstructor 3 with (u:=u) (reads:=reads); subst; eauto. + rewrite HRegs; reflexivity. + apply (SemAction_PSemAction HAction). + apply IHSubsteps; auto. intro; apply H1; right; assumption. Qed. Lemma List_FullLabel_perm_getRleOrMeth l l' : List_FullLabel_perm l l' -> (map getRleOrMeth l) [=] (map getRleOrMeth l'). Proof. induction 1; auto. - inv H; simpl; rewrite IHList_FullLabel_perm; reflexivity. - inv H; inv H0; simpl. rewrite perm_swap; repeat apply perm_skip; assumption. - rewrite IHList_FullLabel_perm1, IHList_FullLabel_perm2; reflexivity. Qed. Corollary PSubsteps_inline_Rule_NoExec_PSubsteps f m o rn (l : list FullLabel) : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> ~In (Rle rn) (map getRleOrMeth l) -> PSubsteps m o l -> PSubsteps (inlineSingle_Rule_BaseModule f rn m) o l. Proof. intros. apply (PSubsteps_Substeps) in H2; dest. rewrite (List_FullLabel_perm_getRleOrMeth H3) in H1. rewrite H2, H3. apply Substeps_inline_Rule_NoExec_PSubsteps; auto. Qed. Corollary PPlusSubsteps_inline_Rule_NoExec_PPlusSubsteps f m o rn upds execs calls : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> ~In (Rle rn) execs -> PPlusSubsteps m o upds execs calls -> PPlusSubsteps (inlineSingle_Rule_BaseModule f rn m) o upds execs calls. Proof. intros. apply PPlusSubsteps_PSubsteps in H2; dest. rewrite H3, H4, H5. apply PSubsteps_PPlusSubsteps. rewrite H4 in H1; unfold getLabelExecs in H1. apply PSubsteps_inline_Rule_NoExec_PSubsteps; auto. Qed. Lemma Substeps_inline_Rule_NoCall_PSubsteps f m o rn u cs (l : list FullLabel) : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> ~In (fst f) (map fst cs) -> Substeps m o ((u, (Rle rn, cs))::l) -> PSubsteps (inlineSingle_Rule_BaseModule f rn m) o ((u, (Rle rn, cs))::l). Proof. intros. inv H2; inv HLabel. econstructor 2 with (u:=u0) (reads:=reads); eauto. - rewrite HRegs; reflexivity. - apply (InRule_In_inlined f _ _ _ HInRules). - apply PSemAction_inline_notIn; auto. apply (SemAction_PSemAction HAction). - apply Substeps_inline_Rule_NoExec_PSubsteps; auto. intro; rewrite in_map_iff in H2; dest. specialize (HNoRle _ H3). rewrite H2 in HNoRle; contradiction. Qed. Lemma PSubsteps_inline_Rule_NoCall_PSubsteps f m o rn u cs (l : list FullLabel) : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> ~In (fst f) (map fst cs) -> PSubsteps m o ((u, (Rle rn, cs))::l) -> PSubsteps (inlineSingle_Rule_BaseModule f rn m) o ((u, (Rle rn, cs))::l). Proof. intros. apply PSubsteps_Substeps in H2; dest. rewrite H2, H3. specialize (List_FullLabel_perm_in H3 _ (in_eq _ _)) as TMP; dest. inv H6; apply in_split in H7; dest; subst. rewrite <-Permutation_middle in *. rewrite H14 in H1. apply Substeps_inline_Rule_NoCall_PSubsteps; auto. Qed. Lemma KeyMatching3 A B: forall (ab1 ab2 : A*B)(l : list (A*B)), NoDup (map fst l) -> In ab1 l -> In ab2 l -> (fst ab1 = fst ab2) -> ab1 = ab2. Proof. induction l; intros. - inv H0. - destruct H0, H1; subst; simpl in *; auto. + inv H; apply (in_map fst) in H1; rewrite <-H2 in H1; contradiction. + inv H; apply (in_map fst) in H0; rewrite H2 in H0; contradiction. + inv H; apply IHl; auto. Qed. Lemma ExtractRuleAction m o (rle : RuleT) upds execs calls : NoDup (map fst (getRules m)) -> In rle (getRules m) -> In (Rle (fst rle)) execs -> PPlusSubsteps m o upds execs calls -> exists reads execs' upds1 upds2 calls1 calls2 retV, PSemAction o (snd rle type) reads upds1 calls1 retV /\ upds [=] upds1++upds2 /\ calls [=] calls1++calls2 /\ DisjKey upds2 upds1 /\ SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) /\ SubList (getKindAttr reads) (getKindAttr (getRegisters m)) /\ execs [=] ((Rle (fst rle))::execs') /\ (forall s, ~In (Rle s) execs') /\ PPlusSubsteps m o upds2 execs' calls2. Proof. induction 4. - inv H1. - rewrite HExecs in H1. destruct H1;[| specialize (HNoRle _ H1); contradiction]. inv H1. specialize (KeyMatching3 _ _ _ H H0 HInRules (eq_refl)) as P1. destruct rle; simpl in *; inv P1; subst. exists reads, oldExecs, u, oldUpds, cs, oldCalls, WO. repeat split; auto. repeat intro; apply (HNoRle _ H1). - rewrite HExecs in H1. destruct H1;[discriminate|]. specialize (IHPPlusSubsteps H1); dest. exists x, ((Meth (fn, existT _ (projT1 fb) (argV, retV))):: x0), x1, (u++x2), x3, (cs++x4), x5. repeat split; auto. + rewrite HUpds, H4. repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. + rewrite HCalls, H5. repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. + rewrite H4 in HDisjRegs; intro k; specialize (HDisjRegs k); specialize (H6 k). clear - HDisjRegs H6. rewrite map_app, in_app_iff in *; firstorder fail. + rewrite HExecs, H9; apply perm_swap. + repeat intro; destruct H12;[discriminate|eapply H10; eauto]. + econstructor 3; eauto. intro k; specialize (HDisjRegs k);rewrite H4, map_app, in_app_iff in HDisjRegs. clear - HDisjRegs; firstorder fail. Qed. Lemma PPlus_inline_Rule_with_action f m o rn rb upds1 upds2 execs calls1 calls2 reads: In (rn, rb) (getRules m) -> In f (getMethods m) -> NoDup (map fst (getMethods m)) -> (forall rn', ~In (Rle rn') execs) -> SubList (getKindAttr reads) (getKindAttr (getRegisters m)) -> SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) -> DisjKey upds2 upds1 -> PSemAction o (inlineSingle (rb type) f) reads upds1 calls1 WO -> PPlusSubsteps m o upds2 execs calls2 -> PPlusSubsteps (inlineSingle_Rule_BaseModule f rn m) o (upds1++upds2) ((Rle rn)::execs) (calls1++calls2). Proof. intros. econstructor; auto. - inv H7; simpl in *; auto. - apply InRule_In_inlined, H. - simpl; apply H6. - auto. - auto. - intros; destruct x; auto. apply (H2 rn0); assumption. - apply PPlusSubsteps_inline_Rule_NoExec_PPlusSubsteps; auto. Qed. Lemma filter_idemp (A : Type) (f : A -> bool) (l : list A) : (filter f (filter f l)) = (filter f l). Proof. induction l; auto. - simpl; remember (f a) as fa. destruct fa; auto. simpl; rewrite <-Heqfa, IHl; reflexivity. Qed. Lemma filter_complement_nil (A : Type) (f : A -> bool) (l : list A) : (filter f (filter (complement f) l)) = nil. Proof. induction l; auto. - simpl; remember (f a) as fa. destruct fa; auto; simpl. rewrite <- Heqfa, IHl; reflexivity. Qed. Lemma called_by_fst_eq g f l: In g (filter (called_by f) l) -> (fst g = fst f). Proof. induction l;[contradiction|]. Opaque prod_dec. unfold called_by; simpl; destruct prod_dec; simpl; intros. - destruct H; inv e; auto. - specialize (IHl H); auto. Transparent prod_dec. Qed. Lemma called_by_prod_eq g f l: In g (filter (called_by f) l) -> (fst g, projT1 (snd g)) = (fst f, projT1 (snd f)). Proof. induction l;[contradiction|]. Opaque prod_dec. unfold called_by; simpl; destruct prod_dec; simpl; intros. - destruct H; subst; auto. - specialize (IHl H); auto. Transparent prod_dec. Qed. Lemma complement_called_by_neq g f l : In g (filter (complement (called_by f)) l) -> (fst g, projT1 (snd g)) <> (fst f, projT1 (snd f)). Proof. induction l;[contradiction|]. Opaque prod_dec. unfold called_by; simpl; destruct prod_dec; simpl; intros. - specialize (IHl H); auto. - destruct H; subst; auto. Transparent prod_dec. Qed. Lemma cons_app (A : Type) (a : A) (l1 l2 : list A) : a::(l1++l2) = (a::l1)++l2. Proof. auto. Qed. Lemma PPlusSubsteps_inline_Rule_In f m o rn rb upds execs calls : In (rn, rb) (getRules m) -> In f (getMethods m) -> NoDup (map fst (getMethods m)) -> NoDup (map fst (getRules m)) -> In (Rle rn) execs -> MatchingExecCalls_flat calls execs m -> PPlusSubsteps m o upds execs calls -> exists fcalls execs' calls', execs [=] (map Meth fcalls)++execs' /\ calls [=] fcalls++calls' /\ PPlusSubsteps (inlineSingle_Rule_BaseModule f rn m) o upds execs' calls'. Proof. intros. specialize (ExtractRuleAction _ H2 H H3 H5) as TMP; dest. rewrite (separate_calls_by_filter x3 (called_by f)) in H8. apply (PSemAction_rewrite_calls (separate_calls_by_filter x3 (called_by f))) in H6. exists (filter (called_by f) x3). specialize (MatchingExecCalls_flat_surjective_split _ H0 H4) as TMP; dest. specialize (in_eq (Rle (fst (rn, rb))) x0); rewrite <-H12, H15, in_app_iff; intro; destruct H16; [apply False_ind;clear - H16; induction calls; auto; simpl in H16;(destruct (called_by f a));auto; simpl in *; destruct H16; auto; discriminate|]. apply in_split in H16; dest; rewrite H16, <-Permutation_middle in H15. rewrite H12, Permutation_app_comm in H15; simpl in *; apply Permutation_cons_inv in H15. rewrite Permutation_app_comm in H15; rewrite H15 in H14. rewrite H8 in H14; repeat rewrite filter_app in H14. rewrite filter_idemp, filter_complement_nil, app_nil_r, map_app, <-app_assoc in H14. rewrite <-app_assoc in H8. exists ((map Meth (filter (called_by f) x4))++x6), ((filter (complement (called_by f)) x3)++x4). repeat split; auto. - rewrite H12, H15, H16, H8; repeat rewrite filter_app, map_app; rewrite filter_idemp, filter_complement_nil; simpl. repeat rewrite app_assoc; rewrite Permutation_app_comm. repeat rewrite <- app_assoc. rewrite app_comm_cons, Permutation_app_comm; repeat rewrite <-app_assoc; simpl; reflexivity. - assert (forall g, In g (filter (called_by f) x3) -> (fst g = fst f)) as P1;[eauto using called_by_fst_eq|]. specialize (extract_execs_PPlus _ _ _ H1 H0 P1 H14) as TMP; dest. assert (~In (fst f, projT1 (snd f)) (getKindAttr (filter (complement (called_by f)) x3))) as P2; [intro; rewrite in_map_iff in H24; dest; apply (complement_called_by_neq) in H25; contradiction|]. assert (DisjKey x10 x1) as P3;[intro k; specialize (H9 k); rewrite H19, map_app, in_app_iff in H9; clear - H9; firstorder fail|]. specialize (PSemAction_inline_In _ H6 P2 P3 H17) as P4. rewrite Permutation_app_comm. rewrite H7, H16, <-Permutation_middle; simpl. rewrite H18, H19. assert (x1++x10++x11 [=] (x10++x1)++x11) as P5; [rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm| rewrite P5]. assert ((filter (complement (called_by f)) x3) ++ x12 ++ x13 [=] (x12 ++ (filter (complement (called_by f)) x3))++x13) as P6; [rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm| rewrite P6]. rewrite (unique_word_0) in P4. eapply PPlus_inline_Rule_with_action with (reads:= (x9++x)); eauto. + intro; rewrite <-H18, Permutation_app_comm; rewrite H8 in H15; repeat rewrite filter_app, map_app in H15; rewrite filter_idemp, filter_complement_nil in H15. simpl in *; specialize (H13 rn'); rewrite H15 in H13; repeat rewrite in_app_iff in *; clear - H13; tauto. + rewrite map_app, SubList_app_l_iff; auto. + rewrite map_app, SubList_app_l_iff; auto. + intro k; specialize (H20 k); specialize (H9 k); rewrite H19,map_app, in_app_iff in *. clear - H20 H9; tauto. + rewrite <-H18, Permutation_app_comm; assumption. Qed. Lemma call_execs_counts_eq f calls : getNumFromCalls f calls = getNumFromExecs f (map Meth calls). Proof. Opaque getNumFromCalls. Opaque getNumFromExecs. induction calls; auto. destruct (MethT_dec f a). - simpl; rewrite getNumFromCalls_eq_cons, getNumFromExecs_eq_cons; auto; rewrite IHcalls; reflexivity. - simpl; rewrite getNumFromCalls_neq_cons, getNumFromExecs_neq_cons; auto. Transparent getNumFromCalls. Transparent getNumFromExecs. Qed. Corollary MatchingExecCalls_Base_subtract_fcalls m calls calls' execs execs' fcalls: MatchingExecCalls_flat calls execs m -> execs [=] (map Meth fcalls)++execs' -> calls [=] fcalls++calls' -> MatchingExecCalls_flat calls' execs' m. Proof. unfold MatchingExecCalls_flat; intros. specialize (H _ H2); rewrite H0, H1, getNumFromCalls_app, getNumFromExecs_app in H. rewrite (call_execs_counts_eq f fcalls) in H; Omega.omega. Qed. Lemma PPlusStep_inline_Rule_NotIn f m o rn upds execs calls : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> ~In (Rle rn) execs -> PPlusStep m o upds execs calls -> PPlusStep (inlineSingle_Rule_BaseModule f rn m) o upds execs calls. Proof. induction 4. econstructor; eauto. apply PPlusSubsteps_inline_Rule_NoExec_PPlusSubsteps; auto. Qed. Lemma PPlusStep_inline_Rule_In f m o rn rb upds execs calls : In (rn, rb) (getRules m) -> In f (getMethods m) -> NoDup (map fst (getRules m)) -> NoDup (map fst (getMethods m)) -> In (Rle rn) execs -> PPlusStep m o upds execs calls -> exists fcalls execs' calls', execs [=] (map Meth fcalls)++execs' /\ calls [=] fcalls++calls' /\ PPlusStep (inlineSingle_Rule_BaseModule f rn m) o upds execs' calls'. Proof. induction 6. specialize (PPlusSubsteps_inline_Rule_In _ _ _ H H0 H2 H1 H3 H5 H4) as TMP; dest. exists x, x0, x1. repeat split; auto. apply (MatchingExecCalls_Base_subtract_fcalls _ _ _ H5 H6 H7). Qed. Lemma PPlusTrace_inline_Rule_NotIn f m o rn tl : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> (forall t, In t tl -> ~In (Rle rn) (fst (snd t))) -> PPlusTrace m o tl -> PPlusTrace (inlineSingle_Rule_BaseModule f rn m) o tl. Proof. induction 4. - subst; econstructor; eauto. - subst; econstructor 2; eauto. + apply IHPPlusTrace; auto;intros; apply (H1 _ (in_cons _ _ _ H3)). + specialize (H1 _ (in_eq _ _ )); simpl in *. apply (PPlusStep_inline_Rule_NotIn _ _ H H0 H1 HPPlusStep). Qed. Lemma RuleOrMeth_dec : forall (rm1 rm2 : RuleOrMeth), {rm1=rm2}+{rm1<>rm2}. Proof. intros. destruct rm1, rm2; simpl in *. - destruct (string_dec rn rn0); subst; auto. right; intro; inv H; apply n; reflexivity. - right; intro; discriminate. - right; intro; discriminate. - destruct (MethT_dec f f0); subst; auto. right; intro; inv H; apply n; reflexivity. Qed. Lemma PPlusSubsteps_inlined_undef_Rule f rn m o upds execs calls: ~In rn (map fst (getRules m)) -> PPlusSubsteps m o upds execs calls -> PPlusSubsteps (inlineSingle_Rule_BaseModule f rn m) o upds execs calls. Proof. induction 2. - econstructor 1; eauto. - rewrite HUpds, HExecs, HCalls; econstructor 2; eauto. simpl; induction (getRules m);[contradiction|]. simpl; destruct (string_dec rn (fst a)); subst. + apply False_ind, H; simpl; left; reflexivity. + simpl in H; assert (~In rn (map fst l)); auto. specialize (IHl H1). rewrite <- eqb_neq in n; rewrite n. destruct HInRules; subst;[left; reflexivity|]. right; apply IHl; auto. - rewrite HUpds, HExecs, HCalls; econstructor 3; eauto. Qed. Lemma PPlusStep_inlined_undef_Rule f rn m o upds execs calls: ~In rn (map fst (getRules m)) -> PPlusStep m o upds execs calls -> PPlusStep (inlineSingle_Rule_BaseModule f rn m) o upds execs calls. Proof. induction 2. - econstructor 1; eauto. apply PPlusSubsteps_inlined_undef_Rule; auto. Qed. Lemma WfActionT_inline_Rule ty (k : Kind) m (a : ActionT ty k) rn f: WfActionT (getRegisters m) a -> WfActionT (getRegisters (inlineSingle_Rule_BaseModule f rn m)) a. Proof. intros; induction H; econstructor; auto. Qed. Lemma WfActionT_inline_Rule_inline_action ty (k : Kind) m (a : ActionT ty k) rn (f : DefMethT): WfActionT (getRegisters m) a -> (forall v, WfActionT (getRegisters m) (projT2 (snd f) ty v)) -> WfActionT (getRegisters (inlineSingle_Rule_BaseModule f rn m)) (inlineSingle a f). Proof. induction 1; try econstructor; eauto. simpl. destruct String.eqb; [destruct Signature_dec|]; subst; econstructor; eauto. econstructor. intros. specialize (H1 v). eapply WfActionT_inline_Rule; auto. Unshelve. exact meth. exact f. Qed. Lemma inlineSingle_Rule_BaseModule_dec ty rule f rn l: In rule (inlineSingle_Rule_in_list f rn l) -> In rule l \/ exists rule', In rule' l /\ (fst rule' = fst rule) /\ ((inlineSingle (snd rule' ty) f) = snd rule ty). Proof. induction l. - intros; auto. - simpl. destruct String.eqb; subst; intros. + destruct H; subst; destruct a; simpl in *. * right; exists (s, a); simpl; repeat split; auto. * destruct (IHl H); auto. dest. right; exists x; auto. + destruct H; auto. destruct (IHl H); auto. dest. right; exists x; auto. Qed. Lemma inlineSingle_Rule_BaseModule_dec2 f rn rb l: In (rn, rb) l -> In (rn, fun ty : Kind -> Type => inlineSingle (rb ty) f) (inlineSingle_Rule_in_list f rn l). Proof. induction l;[contradiction|]. intros; simpl in *. destruct String.eqb eqn:G, a; subst; simpl in *. - destruct H;[inv H|];auto. - rewrite String.eqb_neq in G. destruct H;[inv H; exfalso; apply G|];auto. Qed. Lemma inlineSingle_Rule_preserves_names f rn l: (map fst l) = (map fst (inlineSingle_Rule_in_list f rn l)). Proof. induction l; auto. simpl; destruct String.eqb, a; simpl;rewrite IHl; reflexivity. Qed. Lemma WfMod_Rule_inlined ty m f rn : WfMod ty (Base m) -> In f (getMethods m) -> WfMod ty (Base (inlineSingle_Rule_BaseModule f rn m)). Proof. intros; inv H; econstructor; eauto. - inv HWfBaseModule. split; intros; simpl in *; dest; try inv HWfBaseModule; eauto; repeat split; intros. pose proof (H1 _ H0); auto. + destruct (inlineSingle_Rule_BaseModule_dec ty _ _ _ _ H2). * specialize (H _ H7). eapply WfActionT_inline_Rule; auto. * dest. specialize (H _ H7). rewrite <- H9. eapply WfActionT_inline_Rule_inline_action; auto. + eapply WfActionT_inline_Rule; auto. + auto. + auto. + rewrite <- inlineSingle_Rule_preserves_names; auto. Unshelve. all : auto. Qed. Lemma PPlusStrongTraceInclusion_inlining_Rules_r m f rn : In f (getMethods m) -> (WfMod type (Base m)) -> StrongPPlusTraceInclusion m (inlineSingle_Rule_BaseModule f rn m). Proof. unfold StrongPPlusTraceInclusion; induction 3; subst. - exists nil; split. + econstructor; eauto. + constructor. - dest. pose proof H0 as sth. specialize (H0). destruct (in_dec (RuleOrMeth_dec) (Rle rn) execs),(in_dec string_dec rn (map fst (getRules m))); inv H0. * rewrite in_map_iff in i0; dest; destruct x0; simpl in *; subst. destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. specialize (PPlusStep_inline_Rule_In _ _ _ H4 H NoDupRle NoDupMeths i HPPlusStep) as TMP; dest. exists ((upds, (x1, x2))::x); split. -- econstructor 2; eauto. -- constructor; auto. unfold WeakInclusion_flat, getListFullLabel_diff_flat. split; intros. ++ simpl;rewrite H6, H7, getNumFromExecs_app, getNumFromCalls_app, (call_execs_counts_eq); Omega.omega. ++ simpl in *. destruct H9; exists x3. rewrite H6, in_app_iff; right; assumption. * exists ((upds, (execs, calls))::x); split. -- econstructor 2; eauto. apply PPlusStep_inlined_undef_Rule; auto. -- econstructor; eauto. unfold WeakInclusion_flat; split; intros; auto. * exists ((upds, (execs, calls))::x); split. -- econstructor 2; eauto. apply (PPlusStep_inline_Rule_NotIn); auto. inv HWfBaseModule; dest; auto. -- econstructor; eauto. unfold WeakInclusion_flat; split; intros; auto. * exists ((upds, (execs, calls))::x); split. -- econstructor 2; eauto. apply (PPlusStep_inline_Rule_NotIn); auto. inv HWfBaseModule; dest; auto. -- econstructor; eauto. unfold WeakInclusion_flat; split; intros; auto. Qed. Lemma TraceInclusion_inlining_Rules_r m f rn : In f (getMethods m) -> (WfMod type (Base m)) -> TraceInclusion (Base m) (Base (inlineSingle_Rule_BaseModule f rn m)). Proof. intros. apply PPlusTraceInclusion_TraceInclusion; auto. intros. specialize (H0). apply (WfMod_Rule_inlined); auto. eauto using StrongPPlusTraceInclusion_PPlusTraceInclusion, PPlusStrongTraceInclusion_inlining_Rules_r. Qed. Theorem TraceInclusion_inlining_Rules_r_new m f rn : In f (getMethods m) -> (WfMod_new type (Base m)) -> TraceInclusion (Base m) (Base (inlineSingle_Rule_BaseModule f rn m)). Proof. rewrite WfMod_new_WfMod_iff; apply TraceInclusion_inlining_Rules_r. Qed. Lemma WfBaseMod_Rule_inlined ty m f rn: WfBaseModule ty m -> In f (getMethods m) -> WfBaseModule ty (inlineSingle_Rule_BaseModule f rn m). Proof. intros. specialize (WfMod_Rule_inlined (ty := ty) (m:=m) f rn); intros. assert (WfMod ty m) as TMP;[constructor; auto|specialize (H1 TMP H0); clear TMP]. inversion H1; auto. Qed. Lemma WfBaseMod_Rule_inlined_new ty m f rn: WfBaseModule_new ty m -> In f (getMethods m) -> WfBaseModule_new ty (inlineSingle_Rule_BaseModule f rn m). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff; apply WfBaseMod_Rule_inlined. Qed. Definition inlineSingle_Rule_BaseModuleWf {f} {ty} rn {m: BaseModuleWf ty} (inMeths: In f (getMethods m)):= Build_BaseModuleWf (WfBaseMod_Rule_inlined f rn (wfBaseModule m) inMeths). Lemma TraceInclusion_inlining_Rules_Wf_r {f} {m : BaseModuleWf type} rn (inMeths: In f (getMethods m)): TraceInclusion m (inlineSingle_Rule_BaseModuleWf rn inMeths). Proof. simpl; apply TraceInclusion_inlining_Rules_r; eauto. constructor; apply wfBaseModule. Qed. Definition inlineSingle_Rule_BaseModuleWf_new {f} {ty} rn {m: BaseModuleWf_new ty} (inMeths: In f (getMethods m)):= Build_BaseModuleWf_new (WfBaseMod_Rule_inlined_new f rn (wfBaseModule_new m) inMeths). Theorem TraceInclusion_inlining_Rules_Wf_r_new {f} {m : BaseModuleWf_new type} rn (inMeths: In f (getMethods m)): TraceInclusion m (inlineSingle_Rule_BaseModuleWf_new rn inMeths). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inlining_Rules_Wf_r _ m'). Unshelve. exact inMeths. Qed. Lemma ProjT1_inline_eq (f g : DefMethT): (projT1 (snd g)) = (projT1 (snd (inlineSingle_Meth f g))). Proof. destruct g, s0; simpl; destruct String.eqb; simpl; reflexivity. Qed. Lemma InMeth_In_inlined f gn gb m: gn <> (fst f) -> In (gn, gb) (getMethods m) -> In (inlineSingle_Meth f (gn, gb)) (getMethods (inlineSingle_Meth_BaseModule f gn m)). Proof. simpl; induction (getMethods m); intros. - contradiction. - destruct H0; subst. + simpl; rewrite String.eqb_refl; destruct String.eqb eqn:G; [left; auto |]; simpl; auto. + specialize (IHl H H0). rewrite <- String.eqb_neq, String.eqb_sym in H; rewrite H. rewrite H in *. simpl; right; eauto. Qed. Lemma InMeth_In_inlined_neq f gn1 gn2 gb m: gn1 <> gn2 -> In (gn2, gb) (getMethods m) -> In (gn2, gb) (getMethods (inlineSingle_Meth_BaseModule f gn1 m)). Proof. simpl; induction (getMethods m); intros. - contradiction. - destruct H0; subst; simpl; auto. + specialize (IHl H); rewrite <- String.eqb_neq in H; rewrite H; auto. Qed. Lemma extract_meths_PPlus gn m o upds execs calls : NoDup (map fst (getMethods m)) -> PPlusSubsteps m o upds execs calls -> exists upds1 upds2 fexecs1 execs2 calls1 calls2, PPlusSubsteps m o upds1 (map Meth fexecs1) calls1 /\ upds [=] upds1++upds2 /\ calls [=] calls1++calls2 /\ DisjKey upds2 upds1 /\ execs [=] (map Meth fexecs1)++execs2 /\ (forall g, In g fexecs1 -> (fst g = gn)) /\ (forall fb, ~In (Meth (gn, fb)) execs2) /\ PPlusSubsteps m o upds2 execs2 calls2. Proof. induction 2. - exists nil, nil, nil, nil, nil, nil. repeat split; simpl; try constructor; auto. intros; contradiction. - dest. exists x, (u++x0), x1, (Rle rn::x2), x3, (cs++x4). repeat split; auto. + rewrite HUpds, H2; repeat rewrite app_assoc. apply Permutation_app_tail, Permutation_app_comm. + rewrite HCalls, H3; repeat rewrite app_assoc. apply Permutation_app_tail, Permutation_app_comm. + intro k; specialize (H4 k); specialize (HDisjRegs k). rewrite H2, map_app, in_app_iff in *. clear -HDisjRegs H4; tauto. + rewrite HExecs, H5; apply Permutation_middle. + repeat intro. destruct H9;[discriminate|specialize (H7 fb); contradiction]. + econstructor 2; eauto. * intro k; specialize (HDisjRegs k); rewrite H2,map_app,in_app_iff in HDisjRegs. clear - HDisjRegs; tauto. * intros x5 HInx5; specialize (HNoRle x5). rewrite H5, in_app_iff in HNoRle. apply (HNoRle (or_intror _ HInx5)). - dest. destruct (string_dec fn gn). + subst. exists (u++x), x0, ((gn, existT _ (projT1 fb) (argV, retV))::x1), x2, (cs++x3), x4. repeat split; auto. * econstructor 3; eauto. -- simpl; reflexivity. -- intro k; specialize (HDisjRegs k). rewrite H2, map_app, in_app_iff in HDisjRegs. clear - HDisjRegs; tauto. * rewrite HUpds, H2, app_assoc; reflexivity. * rewrite HCalls, H3, app_assoc; reflexivity. * intro k; specialize (H4 k); specialize (HDisjRegs k). rewrite H2, map_app, in_app_iff in *. clear - H4 HDisjRegs; tauto. * rewrite HExecs, H5; simpl; reflexivity. * simpl; intros. destruct H9;[subst|apply H6];auto. + exists x, (u++x0), x1, (Meth (fn, existT _ (projT1 fb) (argV, retV))::x2), x3, (cs++x4). repeat split; auto. * rewrite HUpds, H2; repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. * rewrite HCalls, H3; repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. * intro k; specialize (H4 k); specialize (HDisjRegs k). rewrite H2, map_app, in_app_iff in *. clear - H4 HDisjRegs; firstorder fail. * rewrite HExecs, H5; apply Permutation_middle. * repeat intro. destruct H9;[inv H9; apply n; reflexivity|eapply H7; eauto]. * econstructor 3; eauto. intro k; specialize (HDisjRegs k). rewrite H2, map_app, in_app_iff in HDisjRegs. clear - HDisjRegs; firstorder fail. Qed. Lemma PPlusSubsteps_inlineMeth_NotIn f gn m o upds execs calls : In gn (map fst (getMethods m)) -> NoDup (map fst (getMethods m)) -> (gn <> fst f) -> (~In (fst f) (map fst calls)) -> PPlusSubsteps m o upds execs calls -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs calls. Proof. induction 5. - econstructor 1; eauto. - rewrite HUpds, HExecs, HCalls in *; econstructor 2; eauto. apply IHPPlusSubsteps; rewrite map_app, in_app_iff in H2; clear - H2; tauto. - assert (~In (fst f) (map fst cs)) as P1;[rewrite HCalls,map_app,in_app_iff in H2; tauto|]. specialize (PSemAction_inline_notIn _ HPAction P1) as P2. destruct (string_dec gn fn); subst. + specialize (InMeth_In_inlined _ _ _ H1 HInMeths); simpl; intro P3; destruct fb; simpl in *. destruct String.eqb eqn:G; [rewrite String.eqb_eq in G|rewrite String.eqb_neq in G]; rewrite HUpds, HExecs, HCalls in *. * econstructor 3; simpl; eauto. * econstructor 3; simpl; eauto. apply IHPPlusSubsteps; clear - H2; rewrite map_app, in_app_iff in H2; tauto. + specialize (InMeth_In_inlined_neq f _ _ n HInMeths) as P3. rewrite HUpds, HExecs, HCalls in *; econstructor 3; eauto. apply IHPPlusSubsteps. clear - H2; rewrite map_app, in_app_iff in H2; tauto. Qed. Lemma ExtractMethAction m o (g : DefMethT) (f : MethT) upds execs calls : NoDup (map fst (getMethods m)) -> In g (getMethods m) -> In (Meth f) execs -> fst g = fst f -> PPlusSubsteps m o upds execs calls -> exists reads execs' upds1 upds2 calls1 calls2 argV retV, PSemAction o (projT2 (snd g) type argV) reads upds1 calls1 retV /\ upds [=] upds1++upds2 /\ calls [=] calls1++calls2 /\ DisjKey upds2 upds1 /\ SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) /\ SubList (getKindAttr reads) (getKindAttr (getRegisters m)) /\ execs [=] ((Meth f)::execs') /\ snd f = existT SignT (projT1 (snd g)) (argV, retV) /\ PPlusSubsteps m o upds2 execs' calls2. Proof. induction 5. - inv H1. - rewrite HExecs in H1. destruct H1;[discriminate|]. specialize (IHPPlusSubsteps H1); dest. exists x, ((Rle rn)::x0), x1, (u++x2), x3, (cs++x4), x5, x6. repeat split; auto. + rewrite HUpds, H5. repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. + rewrite HCalls, H6. repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. + rewrite H5 in HDisjRegs; intro k; specialize (HDisjRegs k); specialize (H7 k). clear - HDisjRegs H7. rewrite map_app, in_app_iff in *; tauto. + rewrite HExecs, H10; apply perm_swap. + econstructor 2; eauto. * intro k; specialize (HDisjRegs k); rewrite H5, map_app, in_app_iff in HDisjRegs. clear - HDisjRegs; tauto. * intros; eapply HNoRle; eauto. rewrite H10; right; assumption. - rewrite HExecs in H1. destruct H1. + destruct g; inv H1; simpl in *. specialize (KeyMatching3 _ _ _ H H0 HInMeths H2) as P1;inv P1. exists reads, oldExecs, u, oldUpds, cs, oldCalls, argV, retV. repeat split; auto. + specialize (IHPPlusSubsteps H1); dest. exists x, ((Meth (fn, existT _ (projT1 fb) (argV, retV)))::x0), x1, (u++x2), x3, (cs++x4), x5, x6. repeat split; auto. * rewrite HUpds, H5. repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. * rewrite HCalls, H6. repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm. * rewrite H5 in HDisjRegs; intro k; specialize (HDisjRegs k); specialize (H7 k). clear - HDisjRegs H7. rewrite map_app, in_app_iff in *; tauto. * rewrite HExecs, H10; apply perm_swap. * econstructor 3; eauto. -- intro k; specialize (HDisjRegs k); rewrite H5, map_app, in_app_iff in HDisjRegs. clear - HDisjRegs; tauto. Qed. Lemma inline_meths_PPlus f gn m o : forall gexecs fcalls upds1 upds2 calls1 calls2 reads, PPlusSubsteps m o upds2 (map Meth gexecs) (fcalls++calls2) -> (forall g, In g fcalls -> (fst g, projT1 (snd g)) = (fst f, projT1 (snd f))) -> PSemAction_meth_collector f o reads upds1 calls1 fcalls -> DisjKey upds2 upds1 -> SubList (getKindAttr reads) (getKindAttr (getRegisters m)) -> SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) -> gn <> fst f -> NoDup (map fst (getMethods m)) -> (~In (fst f, projT1 (snd f)) (getKindAttr calls2)) -> (forall g, In g gexecs -> (fst g = gn)) -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o (upds1++upds2) (map Meth gexecs) (calls1++calls2). Proof. induction gexecs; simpl. - intros; inv H. + specialize (app_eq_nil _ _ (eq_sym H10)) as TMP; dest; subst. inv H1; simpl in *. * econstructor 1; eauto. * apply Permutation_nil in H14; inv H14. + apply Permutation_nil in HExecs; inv HExecs. + apply Permutation_nil in HExecs; inv HExecs. - intros. assert (exists g, In g (getMethods m) /\ fst g = gn) as TMP. + inv H. * apply False_ind; assert (In (Rle rn) (Meth a:: map Meth gexecs));[rewrite HExecs; left; reflexivity|]. clear - H; induction gexecs;simpl in H;[destruct H;[discriminate|contradiction]|]. destruct H;[discriminate|destruct H;[discriminate|apply (IHgexecs (or_intror H))]]. * exists (fn, fb); split; auto; simpl. assert (In (Meth (fn, existT _ (projT1 fb) (argV, retV))) (Meth a :: map Meth gexecs)); [rewrite HExecs; left; reflexivity |destruct H;[inv H; apply (H8 _ (or_introl _ eq_refl))|]]. rewrite in_map_iff in H; dest; inv H. apply (H8 _ (or_intror _ H9)). + dest; destruct x; simpl in *; subst. specialize (H8 _ (or_introl _ eq_refl)) as TMP. assert (fst (gn, s0) = fst a) as P1; auto; clear TMP. specialize (ExtractMethAction _ _ H6 H9 (in_eq _ _) P1 H) as TMP; dest. apply Permutation_cons_inv in H16; rewrite <-H16 in H18. assert (fcalls [=] filter (called_by f) (x3++x4)) as P2; [rewrite <-H12, filter_app; rewrite (notIn_filter_nil f calls2); auto; rewrite (collector_called_by_filter_irrel H1), app_nil_r; reflexivity|]. specialize (separate_calls_by_filter (x3++x4) (called_by f)) as P3; rewrite <-H12 in P3 at 1; rewrite P2 in P3; apply Permutation_app_inv_l in P3. rewrite P2, filter_app in H1. apply collector_split in H1; dest. rewrite (separate_calls_by_filter x4 (called_by f)) in H18. assert (forall g, In g gexecs -> fst g = gn) as P4; auto. specialize (InMeth_In_inlined _ _ _ H5 H9) as P5; destruct s0; simpl in *. destruct String.eqb eqn:G; [rewrite String.eqb_eq in G; clear - H5 G; apply False_ind, H5; subst; reflexivity|]. econstructor 3. * clear - H18; inv H18; auto. * apply P5. * simpl. apply (PSemAction_rewrite_calls (separate_calls_by_filter x3 (called_by f))) in H10. assert (~In (fst f, projT1 (snd f)) (getKindAttr (filter (complement (called_by f)) x3))) as P6. { Opaque prod_dec. clear; induction x3; simpl; intros; auto. unfold called_by in *; destruct prod_dec; simpl; intro;[|destruct H;[apply n; symmetry; assumption|]]; auto. Transparent prod_dec. } assert (DisjKey x9 x1) as P7. { intro k; specialize (H2 k); rewrite H19, H11 in H2; repeat rewrite map_app, in_app_iff in H2; clear - H2; tauto. } apply (PSemAction_inline_In _ H10 P6 P7 H22). * rewrite H1 in H3; clear - H3 H15; rewrite map_app, SubList_app_l_iff in *; dest; split; auto. * rewrite H19 in H4; clear - H4 H14; rewrite map_app, SubList_app_l_iff in *; dest; split; auto. * rewrite H19, H11; repeat rewrite <-app_assoc. apply Permutation_app_head. rewrite Permutation_app_comm, <-app_assoc. apply Permutation_app_head, Permutation_app_comm. * simpl. destruct a; simpl in *; rewrite H17; rewrite P1; reflexivity. * rewrite H20, P3; repeat rewrite <-app_assoc. apply Permutation_app_head; rewrite filter_app. rewrite Permutation_app_comm, <-app_assoc. apply Permutation_app_head, Permutation_app_comm. * intro k; specialize (H13 k); specialize (H21 k); specialize (H2 k). rewrite H19, H11 in H2; clear - H13 H21 H2. repeat rewrite map_app, in_app_iff in *. tauto. * eapply IHgexecs; eauto. -- Opaque prod_dec. clear; unfold called_by; simpl; induction x4; intros;[contradiction|]. simpl in H; destruct prod_dec; simpl in *; [destruct H; subst; auto|apply (IHx4 _ H)]. Transparent prod_dec. -- intro k; specialize (H2 k); rewrite H19, H11 in H2; clear - H2. repeat rewrite map_app, in_app_iff in *; tauto. -- rewrite H1, map_app, SubList_app_l_iff in H3; dest; auto. -- rewrite H19, map_app, SubList_app_l_iff in H4; dest; auto. -- Opaque prod_dec. clear; induction x4; unfold called_by in *; simpl; auto. destruct prod_dec; simpl; auto. intro; destruct H;[apply n; rewrite H; reflexivity|contradiction]. Transparent prod_dec. Qed. Lemma PPlusSubsteps_inline_Meth_NoExec_PPlusSubsteps f m o gn upds execs calls : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> (forall gb, ~In (Meth (gn, gb)) execs) -> PPlusSubsteps m o upds execs calls -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs calls. Proof. induction 4. - econstructor 1; eauto. - rewrite HUpds, HExecs, HCalls; econstructor 2; eauto. apply IHPPlusSubsteps. repeat intro; apply (H1 gb); rewrite HExecs; right; assumption. - rewrite HUpds, HExecs, HCalls; econstructor 3; eauto. apply InMeth_In_inlined_neq; auto. + intro; subst; eapply H1. rewrite HExecs; left; reflexivity. + eapply IHPPlusSubsteps. repeat intro; apply (H1 gb); rewrite HExecs; right; assumption. Qed. Lemma Disjoint_list_split (A : Type): forall (l1 l2 l3 l4 : list A), l1 ++ l2 [=] l3 ++ l4 -> (forall a, ~In a l1 \/ ~In a l3) -> exists l5, l4 [=] l1++l5. Proof. induction l1; simpl; intros. - exists l4; reflexivity. - assert (In a l4). + specialize (in_app_or l3 l4 a); rewrite <-H; intros. specialize (H1 (in_eq _ _)). destruct H1;auto. apply False_ind. destruct (H0 a);[firstorder fail|contradiction]. + apply in_split in H1; dest. rewrite H1 in H. assert (l3 ++ x ++ a::x0 [=] a::l3++x++x0); [rewrite <-Permutation_middle; repeat rewrite app_assoc, app_comm_cons; apply Permutation_app_tail, Permutation_sym, Permutation_middle|]. rewrite H2 in H; apply Permutation_cons_inv in H. assert (forall a, (~In a l1 \/ ~In a l3)); [intros; specialize (H0 a0); firstorder fail|]. specialize (IHl1 _ _ _ H H3); dest. exists x1. rewrite <-H4, H1; apply Permutation_sym, Permutation_middle. Qed. Lemma PPlusSubsteps_exec_Rule_defined m o upds execs calls rn : In (Rle rn) execs -> PPlusSubsteps m o upds execs calls -> exists rb, In (rn, rb) (getRules m). Proof. induction 2. - contradiction. - rewrite HExecs in H; destruct H. + inv H; exists rb; auto. + apply IHPPlusSubsteps; auto. - rewrite HExecs in H. destruct H;[discriminate|]. apply IHPPlusSubsteps; auto. Qed. Lemma PPlusSubsteps_exec_Meth_defined m o upds execs calls fn fb : In (Meth (fn, fb)) execs -> PPlusSubsteps m o upds execs calls -> exists fb', In (fn, fb') (getMethods m). Proof. induction 2. - contradiction. - rewrite HExecs in H; destruct H;[discriminate|]. apply IHPPlusSubsteps; auto. - rewrite HExecs in H; destruct H. + inv H; exists fb0; auto. + apply IHPPlusSubsteps; auto. Qed. Lemma PPlusSubsteps_upds_SubList m o upds execs calls : PPlusSubsteps m o upds execs calls -> SubList (getKindAttr upds) (getKindAttr (getRegisters m)). Proof. induction 1. - repeat intro; contradiction. - rewrite HUpds, map_app, SubList_app_l_iff; split; auto. - rewrite HUpds, map_app, SubList_app_l_iff; split; auto. Qed. Lemma PPlusSubsteps_upds_NoDup_Keys m o upds execs calls : PPlusSubsteps m o upds execs calls -> NoDup (map fst upds). Proof. induction 1. - constructor. - rewrite HUpds, map_app, NoDup_app_iff; repeat split; auto. + apply (PSemAction_NoDup_Key_Writes HPAction). + repeat intro. destruct (HDisjRegs a); contradiction. + repeat intro. destruct (HDisjRegs a); contradiction. - rewrite HUpds, map_app, NoDup_app_iff; repeat split; auto. + apply (PSemAction_NoDup_Key_Writes HPAction). + repeat intro. destruct (HDisjRegs a); contradiction. + repeat intro. destruct (HDisjRegs a); contradiction. Qed. Lemma PPlusSubsteps_split_execs_OneRle m o : NoDup (map fst (getMethods m)) -> NoDup (map fst (getRules m)) -> forall execs1 execs2 upds calls, PPlusSubsteps m o upds (execs1++execs2) calls -> (forall x y, In x execs1 -> In y execs2 -> match x with | Rle _ => match y with | Rle _ => False | Meth _ => True end | Meth _ => True end). Proof. induction execs1;[contradiction|]. intros; destruct H2. - subst; simpl in H1; destruct x, y; auto. specialize (PPlusSubsteps_exec_Rule_defined _ (in_eq _ _ ) H1) as TMP; dest. assert (In (Rle (fst (rn, x))) (Rle rn::execs1++execs2)) as P1;simpl; auto. specialize (ExtractRuleAction _ H0 H2 P1 H1) as TMP; dest; simpl in *. apply Permutation_cons_inv in H10; specialize (H11 rn0); apply H11; rewrite <-H10, in_app_iff; right; assumption. - destruct a; simpl in *. + specialize (PPlusSubsteps_exec_Rule_defined _ (in_eq _ _ ) H1) as TMP; dest. assert (In (Rle (fst (rn, x))) (Rle rn::execs1++execs2)) as P1;simpl; auto. specialize (ExtractRuleAction _ H0 H4 P1 H1) as TMP; dest; simpl in *. apply Permutation_cons_inv in H11; rewrite <-H11 in H13. eapply IHexecs1; eauto. + destruct f. specialize (PPlusSubsteps_exec_Meth_defined _ _ (in_eq _ _ ) H1) as TMP; dest. assert (fst (s, x0) = fst (s, s0)) as P1; auto. specialize (ExtractMethAction _ _ H H4 (in_eq _ _) P1 H1) as TMP; dest; simpl in *. apply Permutation_cons_inv in H11; rewrite <-H11 in H13. eapply IHexecs1; eauto. Qed. Lemma PPlusSubsteps_merge m o : forall execs1 execs2 upds1 upds2 calls1 calls2, NoDup (map fst (getMethods m)) -> NoDup (map fst (getRules m)) -> DisjKey upds1 upds2 -> (forall x y, In x execs1 -> In y execs2 -> match x with | Rle _ => match y with | Rle _ => False | Meth _ => True end | Meth _ => True end) -> PPlusSubsteps m o upds1 execs1 calls1 -> PPlusSubsteps m o upds2 execs2 calls2 -> PPlusSubsteps m o (upds1++upds2) (execs1++execs2) (calls1++calls2). Proof. induction execs1. - intros. inv H3; simpl; auto. + apply False_ind. apply Permutation_nil in HExecs; inv HExecs. + apply Permutation_nil in HExecs; inv HExecs. - intros; simpl. destruct a. specialize (PPlusSubsteps_exec_Rule_defined _ (in_eq _ _) H3) as TMP; dest. specialize (ExtractRuleAction _ H0 H5 (in_eq _ _ ) H3) as TMP; dest. + econstructor 2. * clear - H14; inv H14; auto. * apply H5. * rewrite unique_word_0 in H6. apply H6. * assumption. * assumption. * rewrite H7, <-app_assoc. apply Permutation_app_head, Permutation_refl. * reflexivity. * rewrite H8, <-app_assoc. apply Permutation_app_head, Permutation_refl. * intro k; specialize (H9 k); specialize (H1 k). rewrite H7 in H1; repeat rewrite map_app, in_app_iff in *. clear - H9 H1; tauto. * intros; rewrite in_app_iff in H15. destruct H15. -- apply Permutation_cons_inv in H12. rewrite H12 in H15; destruct x7; auto. eapply H13; eauto. -- apply (H2 _ _ (in_eq _ _) H15). * apply Permutation_cons_inv in H12; rewrite <-H12 in H14. apply IHexecs1; auto. -- intro k; specialize (H1 k); rewrite H7, map_app, in_app_iff in H1. clear - H1; tauto. -- intros; apply H2; auto; right; assumption. + destruct f. specialize (PPlusSubsteps_exec_Meth_defined _ _ (in_eq _ _) H3) as TMP; dest. assert (fst (s, x) = fst (s, s0)); auto. specialize (ExtractMethAction _ _ H H5 (in_eq _ _) H6 H3) as TMP; dest. econstructor 3. * clear - H15; inv H15; auto. * apply H5. * apply H7. * assumption. * assumption. * rewrite H8, <-app_assoc. apply Permutation_app_head, Permutation_refl. * simpl in *; rewrite H14; reflexivity. * rewrite H9, <-app_assoc. apply Permutation_app_head, Permutation_refl. * intro k; specialize (H10 k); specialize (H1 k). rewrite H8 in H1; repeat rewrite map_app, in_app_iff in *. clear - H10 H1; tauto. * apply Permutation_cons_inv in H13. rewrite <- H13 in H15. apply IHexecs1; auto. -- intro k; specialize (H1 k); rewrite H8, map_app, in_app_iff in H1. clear - H1; tauto. -- intros; apply H2; auto; right; assumption. Qed. Lemma SameKeys_inline_Meth f gn l: (map fst (inlineSingle_Meth_in_list f gn l)) = (map fst l). Proof. induction l. - reflexivity. - simpl; destruct String.eqb; simpl;[|rewrite IHl; reflexivity]. unfold inlineSingle_Meth; destruct a, String.eqb; simpl; rewrite IHl; reflexivity. Qed. Lemma SameKindAttr_inline_Meth f gn l : (getKindAttr (inlineSingle_Meth_in_list f gn l)) = (getKindAttr l). Proof. induction l. - reflexivity. - simpl; destruct String.eqb; simpl;[|rewrite IHl; reflexivity]. unfold inlineSingle_Meth; destruct a, String.eqb; simpl; rewrite IHl; auto. destruct s0; reflexivity. Qed. Lemma PPlusSubsteps_inline_Meth f m o gn gb upds execs calls : In (gn, gb) (getMethods m) -> In f (getMethods m) -> NoDup (map fst (getMethods m)) -> NoDup (map fst (getRules m)) -> MatchingExecCalls_flat calls execs m -> (gn <> fst f) -> PPlusSubsteps m o upds execs calls -> exists fcalls execs' calls', execs [=] (map Meth fcalls)++execs' /\ calls [=] fcalls++calls' /\ PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs' calls'. Proof. intros. specialize (extract_meths_PPlus gn H1 H5) as TMP; dest. rewrite H7, H8, H10 in H5. specialize (MatchingExecCalls_flat_surjective_split _ H0 H3) as TMP; dest. assert (forall a, ~In a (map Meth (filter (called_by f) calls)) \/ ~In a (map Meth x1)); [intro; destruct (in_dec RuleOrMeth_dec a (map Meth x1)), (in_dec RuleOrMeth_dec a (map Meth (filter (called_by f) calls))); auto; rewrite in_map_iff in i, i0; dest;specialize (H11 _ H18); apply called_by_fst_eq in H16; rewrite <-H17 in H15; inv H15; contradiction |]. rewrite H14 in H10. destruct (Disjoint_list_split _ _ _ _ H10 H15). rewrite H8, filter_app, map_app, <-app_assoc in H16. exists (filter (called_by f) x3), ((map Meth (filter (called_by f) x4))++x5), ((filter (complement (called_by f)) x3)++x4). repeat split. - rewrite H14, H8, filter_app, map_app, app_assoc; reflexivity. - rewrite app_assoc, <-(separate_calls_by_filter x3 (called_by f)); assumption. - rewrite H16 in H13. assert (forall g, In g (filter (called_by f) x3) -> (fst g, projT1 (snd g)) = (fst f, projT1 (snd f))); [intros; eapply called_by_prod_eq; eauto|]. assert (forall g, In g (filter (called_by f) x3) -> (fst g = fst f)) as P0. { intros; eapply called_by_fst_eq; eauto. } specialize (extract_execs_PPlus _ _ _ H1 H0 P0 H13) as TMP; dest. rewrite (separate_calls_by_filter x3 (called_by f)) in H6. assert (DisjKey x x8); [intro k; specialize (H9 k); rewrite H20, map_app, in_app_iff in H9; clear - H9; firstorder fail|]. assert (~In (fst f, projT1 (snd f)) (getKindAttr (filter (complement (called_by f)) x3))). { clear; induction x3; auto. Opaque prod_dec. unfold called_by in *; simpl; destruct prod_dec; simpl; auto. intro; destruct H; auto. Transparent prod_dec. } specialize (inline_meths_PPlus _ _ H6 H17 H18 H25 H23 H22 H4 H1 H26 H11) as P1. rewrite (separate_calls_by_filter x3 (called_by f)) in H6. assert (forall gb : {x : Kind * Kind & SignT x}, ~ In (Meth (gn, gb)) (map Meth (filter (called_by f) x4)++x6)); [repeat intro; apply (H12 gb0); rewrite H16; clear - H27; repeat rewrite in_app_iff in *; tauto|]. specialize (PPlusSubsteps_inline_Meth_NoExec_PPlusSubsteps _ _ H1 H0 H27 H24) as P2. assert (upds [=] ((x8++x) ++ x9)) as TMP; [rewrite H7, H20, app_assoc; apply Permutation_app_tail, Permutation_app_comm |rewrite TMP; clear TMP]. assert ((map Meth (filter (called_by f) x4)) ++ x5 [=] (map Meth x1)++(map Meth (filter (called_by f) x4) ++ x6)) as TMP; [rewrite app_assoc, <-map_app, <-filter_app, <-H8 in H16; rewrite H16, app_assoc, Permutation_app_comm in H10; apply Permutation_sym in H10; rewrite Permutation_app_comm, app_assoc in H10; apply Permutation_app_inv_r in H10; symmetry; rewrite Permutation_app_comm, <-app_assoc; apply Permutation_app_head; assumption |rewrite TMP; clear TMP]. assert ((filter (complement (called_by f)) x3)++x4 [=] ((x10++(filter (complement (called_by f)) x3))++x11)) as TMP; [symmetry; rewrite <-app_assoc, Permutation_app_comm, <-app_assoc; apply Permutation_app_head; rewrite H19; apply Permutation_app_comm| rewrite TMP; clear TMP]. apply PPlusSubsteps_merge; simpl; auto. + rewrite SameKeys_inline_Meth; assumption. + intro k; specialize (H9 k); specialize (H21 k); rewrite H20 in H9; clear - H9 H21. rewrite map_app, in_app_iff in *; tauto. + specialize (PPlusSubsteps_split_execs_OneRle H1 H2 _ _ H5) as P3; clear - P3 H16. intros; specialize (P3 x y H). rewrite H16, in_app_iff in P3. apply (P3 (or_intror _ H0)). Qed. Lemma PPlusStep_inline_Meth_In f m o gn gb upds execs calls : In (gn, gb) (getMethods m) -> In f (getMethods m) -> NoDup (map fst (getRules m)) -> NoDup (map fst (getMethods m)) -> (gn <> fst f) -> PPlusStep m o upds execs calls -> exists fcalls execs' calls', execs [=] (map Meth fcalls)++execs' /\ calls [=] fcalls++calls' /\ PPlusStep (inlineSingle_Meth_BaseModule f gn m) o upds execs' calls'. Proof. induction 6. specialize (PPlusSubsteps_inline_Meth _ _ H H0 H2 H1 H5 H3 H4) as TMP; dest. exists x, x0, x1. repeat split; auto. unfold MatchingExecCalls_flat in *. simpl; rewrite SameKindAttr_inline_Meth; intros; specialize (H5 _ H9). rewrite H6, H7, getNumFromCalls_app, getNumFromExecs_app, call_execs_counts_eq in H5. Omega.omega. Qed. Lemma PPlusSubsteps_inline_Meth_NotInDef f m o gn upds execs calls : ~In gn (map fst (getMethods m)) -> PPlusSubsteps m o upds execs calls -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs calls. Proof. induction 2. - econstructor 1; auto. - econstructor 2; simpl; eauto. - econstructor 3; simpl; eauto. clear - H HInMeths. induction (getMethods m);[contradiction|]. destruct HInMeths; subst. + simpl; destruct String.eqb eqn:G; [rewrite String.eqb_eq in G|rewrite String.eqb_neq in G]; [destruct String.eqb eqn:G1;subst;simpl;[left; reflexivity|]|left; reflexivity]. apply False_ind, H; simpl; left; reflexivity. + simpl; destruct String.eqb; right; apply IHl; auto; intro; apply H; simpl; right; assumption. Qed. Corollary PPlusStep_inline_Meth_NotInDef f m o gn upds execs calls : ~In gn (map fst (getMethods m)) -> PPlusStep m o upds execs calls -> PPlusStep (inlineSingle_Meth_BaseModule f gn m) o upds execs calls. Proof. induction 2. constructor;[apply PPlusSubsteps_inline_Meth_NotInDef; auto|]. intros g HInDef; simpl in *. rewrite SameKindAttr_inline_Meth in HInDef. specialize (H1 _ HInDef); assumption. Qed. Lemma PPlusSubsteps_inline_Meth_identical f m o gn upds execs calls : gn = fst f -> PPlusSubsteps m o upds execs calls -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs calls. Proof. induction 2. - econstructor 1; eauto. - econstructor 2; simpl; eauto. - econstructor 3; simpl; eauto. clear - H HInMeths. induction (getMethods m);[contradiction|]. destruct HInMeths; subst. + simpl; destruct String.eqb; left; reflexivity. + simpl; destruct String.eqb; right; apply IHl; auto. Qed. Corollary PPlusStep_inline_Meth_identical f m o gn upds execs calls : gn = fst f -> PPlusStep m o upds execs calls -> PPlusStep (inlineSingle_Meth_BaseModule f gn m) o upds execs calls. Proof. induction 2. constructor;[apply PPlusSubsteps_inline_Meth_identical; auto|]. intros g HInDef; simpl in *. rewrite SameKindAttr_inline_Meth in HInDef. specialize (H1 _ HInDef); assumption. Qed. Lemma WfActionT_inline_Meth ty (k : Kind) m (a : ActionT ty k) rn f: WfActionT (getRegisters m) a -> WfActionT (getRegisters (inlineSingle_Meth_BaseModule f rn m)) a. Proof. intros; induction H; econstructor; auto. Qed. Lemma WfActionT_inline_Meth_inline_action ty (k : Kind) m (a : ActionT ty k) gn (f : DefMethT): WfActionT (getRegisters m) a -> (forall v, WfActionT (getRegisters m) (projT2 (snd f) ty v)) -> WfActionT (getRegisters (inlineSingle_Meth_BaseModule f gn m)) (inlineSingle a f). Proof. induction 1; try econstructor; eauto. simpl. destruct String.eqb;[destruct Signature_dec|]; subst; econstructor; eauto. econstructor. intros. specialize (H1 v). eapply (WfActionT_inline_Meth); auto. Unshelve. exact gn. exact f. Qed. Lemma inlineSingle_Meth_BaseModule_dec meth f gn l: In meth (inlineSingle_Meth_in_list f gn l) -> In meth l \/ exists meth', In meth' l /\ (inlineSingle_Meth f meth' = meth). Proof. induction l. - intros; simpl in *; contradiction. - simpl; destruct String.eqb; subst; intros. + destruct H; subst. * right; exists a; split; auto. * specialize (IHl H). destruct IHl;auto; dest; subst. right; exists x; split; auto. + destruct H; subst; auto. destruct (IHl H); auto; dest; subst. right; exists x; split; auto. Qed. Lemma WfMod_Meth_inlined ty m f gn : (WfMod ty (Base m)) -> In f (getMethods m) -> (WfMod ty (Base (inlineSingle_Meth_BaseModule f gn m))). Proof. intros. pose proof H as sth. specialize (H). inv H; econstructor; eauto. - split; intros; simpl in *; inv HWfBaseModule. + eapply WfActionT_inline_Meth; auto. + repeat split; dest; intros; try rewrite SameKeys_inline_Meth; auto. * destruct (inlineSingle_Meth_BaseModule_dec _ _ _ _ H5). -- specialize (H1 _ H6 v); eapply WfActionT_inline_Meth; auto. -- dest. destruct x, s0, meth, s1; simpl in *. inv H7; destruct String.eqb. ++ inv H10; EqDep_subst; simpl in *. specialize (H1 _ H6 v); simpl in *; eapply WfActionT_inline_Meth; assumption. ++ inv H10; EqDep_subst. eapply WfActionT_inline_Meth_inline_action; auto. specialize (H1 _ H6 v); simpl in *; assumption. Unshelve. all : auto. Qed. Lemma WfMod_Meth_inlined_new ty m f gn : (WfMod_new ty (Base m)) -> In f (getMethods m) -> (WfMod_new ty (Base (inlineSingle_Meth_BaseModule f gn m))). Proof. repeat rewrite WfMod_new_WfMod_iff. apply WfMod_Meth_inlined. Qed. Lemma PPlusStrongTraceInclusion_inlining_Meth_r m f gn : In f (getMethods m) -> (WfMod type (Base m)) -> StrongPPlusTraceInclusion m (inlineSingle_Meth_BaseModule f gn m). Proof. unfold StrongPPlusTraceInclusion; induction 3; subst. - exists nil; split. + econstructor; eauto. + constructor. - dest;destruct (string_dec gn (fst f)). + exists ((upds, (execs, calls))::x); split. * econstructor 2; eauto. apply PPlusStep_inline_Meth_identical; auto. * constructor; auto; unfold WeakInclusion_flat; split; intro; auto. + destruct (in_dec string_dec gn (map fst (getMethods m))). * rewrite in_map_iff in i; dest. specialize (H0). inv H0; destruct x0; simpl in *. destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. specialize (PPlusStep_inline_Meth_In _ _ H5 H NoDupRle NoDupMeths n HPPlusStep) as TMP; dest. exists ((upds, (x1, x2))::x); split. -- econstructor 2; eauto. -- constructor; auto. unfold WeakInclusion_flat, getListFullLabel_diff_flat; simpl; split; intros; auto. ++ rewrite H6, H7, getNumFromExecs_app, getNumFromCalls_app, call_execs_counts_eq; Omega.omega. ++ dest; exists x3. rewrite ?H6, ?H7, in_app_iff; right; assumption. * exists ((upds, (execs, calls))::x); split. -- econstructor 2; eauto. apply PPlusStep_inline_Meth_NotInDef; auto. -- constructor; auto. unfold WeakInclusion_flat; split; intros; auto. Qed. Lemma TraceInclusion_inlining_Meth_r m f gn : In f (getMethods m) -> (WfMod type (Base m)) -> TraceInclusion (Base m) (Base (inlineSingle_Meth_BaseModule f gn m)). Proof. intros. apply PPlusTraceInclusion_TraceInclusion; auto. apply (WfMod_Meth_inlined); auto. eauto using StrongPPlusTraceInclusion_PPlusTraceInclusion, PPlusStrongTraceInclusion_inlining_Meth_r. Qed. Theorem TraceInclusion_inlining_Meth_r_new m f gn : In f (getMethods m) -> (WfMod_new type (Base m)) -> TraceInclusion (Base m) (Base (inlineSingle_Meth_BaseModule f gn m)). Proof. rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlining_Meth_r. Qed. Lemma WfBaseMod_Meth_inlined ty m f gn : (WfBaseModule ty m) -> In f (getMethods m) -> (WfBaseModule ty (inlineSingle_Meth_BaseModule f gn m)). Proof. intros. specialize (WfMod_Meth_inlined (ty := ty) (m:=m) f gn); intro. assert (WfMod ty m) as TMP;[constructor; auto|specialize (H1 TMP H0); clear TMP]. inv H1; auto. Qed. Lemma WfBaseMod_Meth_inlined_new ty m f gn : (WfBaseModule_new ty m) -> In f (getMethods m) -> (WfBaseModule_new ty (inlineSingle_Meth_BaseModule f gn m)). Proof. intros. specialize (@WfMod_Meth_inlined_new ty m f gn); intro. assert (WfMod_new ty (inlineSingle_Meth_BaseModule f gn m)); auto. Qed. Definition inlineSingle_Meth_BaseModuleWf {f} {ty} {m: BaseModuleWf ty} gn (inMeths: In f (getMethods m)):= Build_BaseModuleWf (WfBaseMod_Meth_inlined f gn (wfBaseModule m) inMeths). Definition inlineSingle_Meth_BaseModuleWf_new {f} {ty} {m: BaseModuleWf_new ty} gn (inMeths: In f (getMethods m)):= Build_BaseModuleWf_new (WfBaseMod_Meth_inlined_new f gn (wfBaseModule_new m) inMeths). Lemma TraceInclusion_inlining_Meth_Wf_r {f} {m : BaseModuleWf type} rn (inMeths: In f (getMethods m)): TraceInclusion m (inlineSingle_Meth_BaseModuleWf rn inMeths). Proof. simpl; apply TraceInclusion_inlining_Meth_r; eauto. constructor; apply wfBaseModule. Qed. Theorem TraceInclusion_inlining_Meth_Wf_r_new {f} {m : BaseModuleWf_new type} rn (inMeths: In f (getMethods m)): TraceInclusion m (inlineSingle_Meth_BaseModuleWf_new rn inMeths). Proof. simpl; apply TraceInclusion_inlining_Meth_r_new; eauto. constructor; apply wfBaseModule_new. Qed. Section Rel. Variable A B: Type. Variable f: B -> A -> A. Variable R: A -> A -> Prop. Lemma fold_right_Rel ls: forall x b, (forall x b, R x (f b x)) -> R (fold_right f x ls) (f b (fold_right f x ls)). Proof. induction ls; simpl; auto; intros. Qed. End Rel. Lemma Method_list_invariance f gn ls: ~In gn (map fst ls) -> ls = inlineSingle_Meth_in_list f gn ls. Proof. induction ls; auto. simpl; intros. destruct String.eqb eqn:G; [rewrite String.eqb_eq in G | rewrite String.eqb_neq in G]. - apply False_ind, H; rewrite G; auto. - rewrite IHls at 1;[reflexivity|]. intro; apply H; auto. Qed. Lemma Rule_list_invariance f rn ls: ~In rn (map fst ls) -> ls = inlineSingle_Rule_in_list f rn ls. Proof. induction ls; auto. simpl; intros. destruct String.eqb eqn:G. - apply False_ind, H; rewrite String.eqb_eq in G; auto. - rewrite IHls at 1;[reflexivity|]. intro; apply H; auto. Qed. Section transform_nth_right. Lemma inlineSingle_Meth_transform_nth f ls: NoDup (map fst ls) -> forall i, i < length ls -> exists val, In val ls /\ transform_nth_right (inlineSingle_Meth f) i ls = inlineSingle_Meth_in_list f (fst val) ls. Proof. induction ls; destruct i; simpl in *; auto; intros; try Omega.omega. - exists a; repeat split; auto. rewrite String.eqb_refl. f_equal. inv H. apply Method_list_invariance; auto. - inv H. specialize (IHls H4 i ltac:(Omega.omega)); dest. exists x. repeat split; auto. destruct (String.eqb (fst x) (fst a)) eqn:G. apply in_map with (f := fst) in H. + rewrite String.eqb_eq in G. rewrite G in *; tauto. + rewrite H1; auto. Qed. Lemma inlineSingle_Rule_transform_nth f ls: NoDup (map fst ls) -> forall i, i < length ls -> exists val, In val ls /\ transform_nth_right (inlineSingle_Rule f) i ls = inlineSingle_Rule_in_list f (fst val) ls. Proof. induction ls; destruct i; simpl in *; auto; intros; try Omega.omega. - exists a; repeat split; auto. rewrite String.eqb_refl. f_equal. inv H. apply Rule_list_invariance; auto. - inv H. specialize (IHls H4 i ltac:(Omega.omega)); dest. exists x. repeat split; auto. destruct (String.eqb (fst x) (fst a)) eqn:G. apply in_map with (f := fst) in H. + rewrite String.eqb_eq in G; rewrite G in *; tauto. + rewrite H1; auto. Qed. Lemma inlineSingle_Meth_transform_nth_keys f ls : forall i, map fst (transform_nth_right (inlineSingle_Meth f) i ls) = map fst ls. Proof. induction ls; destruct i; simpl in *; auto; intros; try Omega.omega. - destruct a; simpl; reflexivity. - rewrite (IHls i); auto. Qed. Lemma inlineSingle_Rule_transform_nth_keys f ls : forall i, map fst (transform_nth_right (inlineSingle_Rule f) i ls) = map fst ls. Proof. induction ls; destruct i; simpl in *; auto; intros; try Omega.omega. - destruct a; simpl; reflexivity. - rewrite (IHls i); auto. Qed. Lemma inlineSingle_transform_gt (A : Type) (f : A -> A) ls : forall i, length ls <= i -> transform_nth_right f i ls = ls. Proof. induction ls; destruct i; simpl in *; auto; intros; try Omega.omega. rewrite (IHls i ltac:(Omega.omega)); reflexivity. Qed. End transform_nth_right. Lemma fold_right_nil xs (A: Type) (f : A -> A) : (fold_right (transform_nth_right f) nil xs) = nil. Proof. induction xs; simpl; auto. rewrite IHxs; simpl; destruct a; simpl; reflexivity. Qed. Lemma transform_len (A : Type) (f : A -> A) ls : forall i, length (transform_nth_right f i ls) = length ls. Proof. induction ls; destruct i; simpl; auto. Qed. Lemma fold_right_len xs (A : Type) (f : A -> A) ls : length (fold_right (transform_nth_right f) ls xs) = length ls. Proof. induction xs; simpl; auto. rewrite transform_len; auto. Qed. Lemma SameKeys_Meth_fold_right ls xs f : (map fst ls = map fst (fold_right (transform_nth_right (inlineSingle_Meth f)) ls xs)). Proof. induction xs; simpl; auto. rewrite inlineSingle_Meth_transform_nth_keys; auto. Qed. Lemma SameKeys_Rule_fold_right ls xs f : (map fst ls = map fst (fold_right (transform_nth_right (inlineSingle_Rule f)) ls xs)). Proof. induction xs; simpl; auto. rewrite inlineSingle_Rule_transform_nth_keys; auto. Qed. Lemma inline_Meth_not_transformed f ls : In f ls -> forall i, In f (transform_nth_right (inlineSingle_Meth f) i ls). Proof. induction ls; destruct i; simpl; auto. - destruct H; subst; auto. unfold inlineSingle_Meth; destruct f, String.eqb eqn:G; auto. rewrite String.eqb_neq in G. apply False_ind, G; reflexivity. - destruct H; auto. Qed. Lemma inlined_Meth_not_transformed_fold_right ls xs f : In f ls -> In f (fold_right (transform_nth_right (inlineSingle_Meth f)) ls xs). Proof. induction xs; simpl; auto. intros; specialize (IHxs H). apply inline_Meth_not_transformed; assumption. Qed. Lemma WfMod_inline_all_Meth ty regs rules meths f xs: In f meths -> (WfMod ty (Base (BaseMod regs rules meths))) -> (WfMod ty (Base (BaseMod regs rules (fold_right (transform_nth_right (inlineSingle_Meth f)) meths xs)))). Proof. induction xs; auto. simpl. intros; specialize (IHxs H). destruct (lt_dec a (length meths)). - pose proof H0 as H0'. specialize (H0). inv H0; simpl in *. destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. simpl in *. rewrite (SameKeys_Meth_fold_right meths xs f) in NoDupMeths. rewrite <- (fold_right_len xs (inlineSingle_Meth f) meths) in l. specialize (inlineSingle_Meth_transform_nth f _ NoDupMeths l) as TMP; dest. rewrite H3. assert (In f (fold_right (transform_nth_right (inlineSingle_Meth f)) meths xs)); [apply inlined_Meth_not_transformed_fold_right; auto|]. specialize (WfMod_Meth_inlined _ (fst x) (IHxs H0') H4) as P1. unfold inlineSingle_Meth_BaseModule in P1; simpl in *. eauto. - apply Nat.nlt_ge in n. rewrite <- (fold_right_len xs (inlineSingle_Meth f) meths) in n. rewrite inlineSingle_transform_gt; auto. Qed. Lemma WfMod_inline_all_Rule ty regs rules meths f xs: In f meths -> (WfMod ty (Base (BaseMod regs rules meths))) -> (WfMod ty (Base (BaseMod regs (fold_right (transform_nth_right (inlineSingle_Rule f)) rules xs) meths))). Proof. induction xs; auto. simpl. intros; specialize (IHxs H). destruct (lt_dec a (length rules)). - pose proof H0 as H0'. specialize (H0). inv H0; simpl in *. destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. simpl in *. rewrite (SameKeys_Rule_fold_right rules xs f) in NoDupRle. rewrite <- (fold_right_len xs (inlineSingle_Rule f) rules) in l. specialize (inlineSingle_Rule_transform_nth f _ NoDupRle l) as TMP; dest. rewrite H3. specialize (WfMod_Rule_inlined _ (fst x) (IHxs H0') H) as P1. unfold inlineSingle_Rule_BaseModule in P1; simpl in *; assumption. - apply Nat.nlt_ge in n. rewrite <- (fold_right_len xs (inlineSingle_Rule f) rules) in n. rewrite inlineSingle_transform_gt; auto. Qed. Lemma inline_meth_transform f regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> forall i, TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (transform_nth_right (inlineSingle_Meth f) i meths))). Proof. intros; destruct (lt_dec i (length meths)). - pose proof H as H'. inv H; simpl in *. destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. simpl in *. specialize (inlineSingle_Meth_transform_nth f _ NoDupMeths l) as TMP; dest. rewrite H3. assert (In f (getMethods (BaseMod regs rules meths))); auto. specialize (TraceInclusion_inlining_Meth_r _ (fst x) H4 H') as P1. unfold inlineSingle_Meth_BaseModule in P1; simpl in *; assumption. - apply Nat.nlt_ge in n. rewrite inlineSingle_transform_gt; auto. apply TraceInclusion_refl. Qed. Theorem inline_meth_transform_new f regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> forall i, TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (transform_nth_right (inlineSingle_Meth f) i meths))). Proof. rewrite WfMod_new_WfMod_iff; apply inline_meth_transform. Qed. Lemma WfBaseMod_inline_nth_Meth ty m f i: In f (getMethods m) -> (WfBaseModule ty m) -> (WfBaseModule ty (BaseMod (getRegisters m) (getRules m) (transform_nth_right (inlineSingle_Meth f) i (getMethods m)))). Proof. intros. destruct (lt_dec i (length (getMethods m))). - pose proof H0 as H0'. destruct H0 as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. simpl in *. specialize (inlineSingle_Meth_transform_nth f _ NoDupMeths l) as TMP; dest. rewrite H3. assert (In f (transform_nth_right (inlineSingle_Meth f) i (getMethods m))); [apply inline_Meth_not_transformed; auto|]. assert (WfMod ty m) as P1; [constructor; auto|]. specialize (WfMod_Meth_inlined _ (fst x) P1 H) as P2. unfold inlineSingle_Meth_BaseModule in P2; simpl in *. inv P2; eauto. - apply Nat.nlt_ge in n. rewrite inlineSingle_transform_gt; auto. Qed. Lemma WfBaseMod_inline_nth_Meth_new ty m f i: In f (getMethods m) -> (WfBaseModule_new ty m) -> (WfBaseModule_new ty (BaseMod (getRegisters m) (getRules m) (transform_nth_right (inlineSingle_Meth f) i (getMethods m)))). Proof. intros. destruct (lt_dec i (length (getMethods m))). - pose proof H0 as H0'. destruct H0 as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. simpl in *. specialize (inlineSingle_Meth_transform_nth f _ NoDupMeths l) as TMP; dest. rewrite H3. assert (In f (transform_nth_right (inlineSingle_Meth f) i (getMethods m))); [apply inline_Meth_not_transformed; auto|]. assert (WfMod_new ty m) as P1; [constructor; auto|]. specialize (WfMod_Meth_inlined_new _ (fst x) P1 H) as P2. unfold inlineSingle_Meth_BaseModule in P2; simpl in *. exact P2. - apply Nat.nlt_ge in n. rewrite inlineSingle_transform_gt; auto. Qed. Definition inline_nth_Meth_BaseModuleWf {f} {ty} {m : BaseModuleWf ty} i (inMeths : In f (getMethods m)):= (Build_BaseModuleWf (WfBaseMod_inline_nth_Meth f i inMeths (wfBaseModule m))). Definition inline_nth_Meth_BaseModuleWf_new {f} {ty} {m : BaseModuleWf_new ty} i (inMeths : In f (getMethods m)):= (Build_BaseModuleWf_new (WfBaseMod_inline_nth_Meth_new f i inMeths (wfBaseModule_new m))). Lemma inline_meth_transform_Wf {f} {m : BaseModuleWf type} i (inMeths : In f (getMethods m)): TraceInclusion m (inline_nth_Meth_BaseModuleWf i inMeths). Proof. intros; simpl. specialize (TraceInclusion_flatten_r m) as P1. specialize (wfMod (flatten_ModWf m)) as P2; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (inline_meth_transform f P2 inMeths i) as P3. eauto using TraceInclusion_trans. Qed. Theorem inline_meth_transform_Wf_new {f} {m : BaseModuleWf_new type} i (inMeths : In f (getMethods m)): TraceInclusion m (inline_nth_Meth_BaseModuleWf_new i inMeths). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as x. eapply (@inline_meth_transform_Wf f x). Unshelve. exact inMeths. Qed. Lemma WfBaseMod_inline_all_Meth ty m f xs: In f (getMethods m) -> (WfBaseModule ty m) -> (WfBaseModule ty (BaseMod (getRegisters m) (getRules m) (fold_right (transform_nth_right (inlineSingle_Meth f)) (getMethods m) xs))). Proof. intros. assert (WfMod ty (Base m)) as P1;[constructor; auto|]. specialize (WfMod_WfBaseMod_flat P1) as P2. unfold getFlat in P2; simpl in *. assert (WfMod ty (Base (BaseMod (getRegisters m) (getRules m) (getMethods m)))) as P3; [constructor; auto|]. specialize (WfMod_inline_all_Meth f xs H P3) as P4. inv P4; auto. Qed. Lemma WfBaseMod_inline_all_Meth_new ty m f xs: In f (getMethods m) -> (WfBaseModule_new ty m) -> (WfBaseModule_new ty (BaseMod (getRegisters m) (getRules m) (fold_right (transform_nth_right (inlineSingle_Meth f)) (getMethods m) xs))). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inline_all_Meth. Qed. Definition inline_all_Meth_BaseModuleWf {f} {ty} {m : BaseModuleWf ty} xs (inMeths : In f (getMethods m)):= (Build_BaseModuleWf (WfBaseMod_inline_all_Meth f xs inMeths (wfBaseModule m))). Definition inline_all_Meth_BaseModuleWf_new {f} {ty} {m : BaseModuleWf_new ty} xs (inMeths : In f (getMethods m)):= (Build_BaseModuleWf_new (WfBaseMod_inline_all_Meth_new f xs inMeths (wfBaseModule_new m))). Lemma WfBaseMod_inline_all_Rule ty m f xs: In f (getMethods m) -> (WfBaseModule ty m) -> (WfBaseModule ty (BaseMod (getRegisters m) (fold_right (transform_nth_right (inlineSingle_Rule f)) (getRules m) xs) (getMethods m))). Proof. intros. assert (WfMod ty (Base m)) as P1;[constructor; auto|]. specialize (WfMod_WfBaseMod_flat P1) as P2. unfold getFlat in P2; simpl in *. assert (WfMod ty (Base (BaseMod (getRegisters m) (getRules m) (getMethods m)))) as P3; [constructor; auto|]. specialize (WfMod_inline_all_Rule f xs H P3) as P4. inv P4; auto. Qed. Lemma WfBaseMod_inline_all_Rule_new ty m f xs: In f (getMethods m) -> (WfBaseModule_new ty m) -> (WfBaseModule_new ty (BaseMod (getRegisters m) (fold_right (transform_nth_right (inlineSingle_Rule f)) (getRules m) xs) (getMethods m))). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inline_all_Rule. Qed. Definition inline_all_Rule_BaseModuleWf {f} {ty} {m : BaseModuleWf ty} xs (inMeths : In f (getMethods m)):= (Build_BaseModuleWf (WfBaseMod_inline_all_Rule f xs inMeths (wfBaseModule m))). Definition inline_all_Rule_BaseModuleWf_new {f} {ty} {m : BaseModuleWf_new ty} xs (inMeths : In f (getMethods m)):= (Build_BaseModuleWf_new (WfBaseMod_inline_all_Rule_new f xs inMeths (wfBaseModule_new m))). Lemma inline_rule_transform f regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> forall i, TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (transform_nth_right (inlineSingle_Rule f) i rules) meths)). Proof. intros; destruct (lt_dec i (length rules)). - pose proof H as H'. inv H; simpl in *. destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. simpl in *. specialize (inlineSingle_Rule_transform_nth f _ NoDupRle l) as TMP; dest. rewrite H3. assert (In f (getMethods (BaseMod regs rules meths))); auto. specialize (TraceInclusion_inlining_Rules_r _ (fst x) H4 H') as P1. unfold inlineSingle_Rule_BaseModule in P1; simpl in *; assumption. - apply Nat.nlt_ge in n. rewrite inlineSingle_transform_gt; auto. apply TraceInclusion_refl. Qed. Theorem inline_rule_transform_new f regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> forall i, TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (transform_nth_right (inlineSingle_Rule f) i rules) meths)). Proof. rewrite WfMod_new_WfMod_iff; apply inline_rule_transform. Qed. Lemma WfBaseMod_inline_nth_Rule ty m f i: In f (getMethods m) -> (WfBaseModule ty m) -> (WfBaseModule ty (BaseMod (getRegisters m) (transform_nth_right (inlineSingle_Rule f) i (getRules m)) (getMethods m))). Proof. intros. destruct (lt_dec i (length (getRules m))). - pose proof H0 as H0'. destruct H0 as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. specialize (inlineSingle_Rule_transform_nth f _ NoDupRle l) as TMP; dest. rewrite H3. assert (WfMod ty m) as P1; [constructor; auto|]. specialize (WfMod_Rule_inlined _ (fst x) P1 H) as P2. unfold inlineSingle_Rule_BaseModule in P2; simpl in *. inv P2; eauto. - apply Nat.nlt_ge in n. rewrite inlineSingle_transform_gt; auto. Qed. Lemma WfBaseMod_inline_nth_Rule_new ty m f i: In f (getMethods m) -> (WfBaseModule_new ty m) -> (WfBaseModule_new ty (BaseMod (getRegisters m) (transform_nth_right (inlineSingle_Rule f) i (getRules m)) (getMethods m))). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inline_nth_Rule. Qed. Definition inline_nth_Rule_BaseModuleWf {f} {ty} {m : BaseModuleWf ty} i (inMeths : In f (getMethods m)):= (Build_BaseModuleWf (WfBaseMod_inline_nth_Rule f i inMeths (wfBaseModule m))). Definition inline_nth_Rule_BaseModuleWf_new {f} {ty} {m : BaseModuleWf_new ty} i (inMeths : In f (getMethods m)):= (Build_BaseModuleWf_new (WfBaseMod_inline_nth_Rule_new f i inMeths (wfBaseModule_new m))). Lemma inline_rule_transform_Wf {f} {m : BaseModuleWf type} i (inMeths : In f (getMethods m)): TraceInclusion m (inline_nth_Rule_BaseModuleWf i inMeths). Proof. intros; simpl. specialize (TraceInclusion_flatten_r m) as P1. specialize (wfMod (flatten_ModWf m)) as P2; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (inline_rule_transform f P2 inMeths i) as P3. eauto using TraceInclusion_trans. Qed. Theorem inline_rule_transform_Wf_new {f} {m : BaseModuleWf_new type} i (inMeths : In f (getMethods m)): TraceInclusion m (inline_nth_Rule_BaseModuleWf_new i inMeths). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as x. eapply (@inline_rule_transform_Wf f x). Unshelve. exact inMeths. Qed. Section inlineSingle_nth. Variable (f : DefMethT). Variable (regs: list RegInitT) (rules: list RuleT) (meths: list DefMethT). Variable (Wf : WfMod type (Base (BaseMod regs rules meths))). Lemma inline_meth_fold_right xs: In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (fold_right (transform_nth_right (inlineSingle_Meth f)) meths xs))). Proof. induction xs; intros. - simpl; apply TraceInclusion_refl. - simpl. specialize (IHxs H). specialize (WfMod_inline_all_Meth _ xs H Wf) as P1. specialize (inlined_Meth_not_transformed_fold_right _ xs _ H) as P2. specialize (inline_meth_transform _ P1 P2 a) as P3. apply (TraceInclusion_trans IHxs P3). Qed. Lemma inline_rule_fold_right xs: In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (fold_right (transform_nth_right (inlineSingle_Rule f)) rules xs) meths)). Proof. induction xs; intros. - simpl; apply TraceInclusion_refl. - simpl. specialize (IHxs H). specialize (WfMod_inline_all_Rule _ xs H Wf) as P1. specialize (inline_rule_transform _ P1 H a) as P2. apply (TraceInclusion_trans IHxs P2). Qed. End inlineSingle_nth. Section inlineSingle_nth_new. Variable (f : DefMethT). Variable (regs: list RegInitT) (rules: list RuleT) (meths: list DefMethT). Variable (Wf : WfMod_new type (Base (BaseMod regs rules meths))). Theorem inline_meth_fold_right_new xs: In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (fold_right (transform_nth_right (inlineSingle_Meth f)) meths xs))). Proof. rewrite WfMod_new_WfMod_iff in Wf. eapply inline_meth_fold_right; eauto. Qed. Theorem inline_rule_fold_right_new xs: In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (fold_right (transform_nth_right (inlineSingle_Rule f)) rules xs) meths)). Proof. rewrite WfMod_new_WfMod_iff in Wf. eapply inline_rule_fold_right; eauto. Qed. End inlineSingle_nth_new. Lemma inline_meth_fold_right_Wf {f} {m : BaseModuleWf type} xs (inMeth : In f (getMethods m)): TraceInclusion m (inline_all_Meth_BaseModuleWf xs inMeth). Proof. specialize (TraceInclusion_flatten_r m) as P1. simpl in *; unfold flatten, getFlat in P1; simpl in *. assert (WfMod type m) as TMP. { constructor; apply wfBaseModule. } specialize (WfMod_getFlat TMP) as P2; clear TMP. specialize (inline_meth_fold_right f P2 xs inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem inline_meth_fold_right_Wf_new {f} {m : BaseModuleWf_new type} xs (inMeth : In f (getMethods m)): TraceInclusion m (inline_all_Meth_BaseModuleWf_new xs inMeth). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@inline_meth_fold_right_Wf _ m'). Unshelve. exact inMeth. Qed. Lemma inline_rule_fold_right_Wf {f} {m : BaseModuleWf type} xs (inMeth : In f (getMethods m)): TraceInclusion m (inline_all_Rule_BaseModuleWf xs inMeth). Proof. specialize (TraceInclusion_flatten_r m) as P1. simpl in *; unfold flatten, getFlat in P1; simpl in *. assert (WfMod type m) as TMP. { constructor; apply wfBaseModule. } specialize (WfMod_getFlat TMP) as P2; clear TMP. specialize (inline_rule_fold_right f P2 xs inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem inline_rule_fold_right_Wf_new {f} {m : BaseModuleWf_new type} xs (inMeth : In f (getMethods m)): TraceInclusion m (inline_all_Rule_BaseModuleWf_new xs inMeth). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@inline_rule_fold_right_Wf f m'). Unshelve. exact inMeth. Qed. Lemma TraceInclusion_inline_BaseModule_rules regs rules meths f: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (map (inlineSingle_Rule f) rules) meths)). Proof. intros. specialize (inline_rule_fold_right f H (seq 0 (length rules)) H0) as P1. specialize (WfMod_inline_all_Rule _ (seq 0 (length rules)) H0 H) as P2. repeat rewrite map_fold_right_eq in *. assumption. Qed. Theorem TraceInclusion_inline_BaseModule_rules_new regs rules meths f: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (map (inlineSingle_Rule f) rules) meths)). Proof. rewrite WfMod_new_WfMod_iff; apply TraceInclusion_inline_BaseModule_rules. Qed. Lemma WfBaseMod_inline_BaseModule_Rules ty m f: In f (getMethods m) -> WfBaseModule ty m -> WfBaseModule ty (BaseMod (getRegisters m) (map (inlineSingle_Rule f) (getRules m)) (getMethods m)). Proof. intros. assert (WfMod ty m) as TMP;[constructor; auto|specialize (WfMod_getFlat TMP) as P1; clear TMP]. specialize (WfMod_inline_all_Rule _ (seq 0 (length (getRules m))) H P1) as P2. repeat rewrite map_fold_right_eq in *; simpl in *. inv P2; auto. Qed. Lemma WfBaseMod_inline_BaseModule_Rules_new ty m f: In f (getMethods m) -> WfBaseModule_new ty m -> WfBaseModule_new ty (BaseMod (getRegisters m) (map (inlineSingle_Rule f) (getRules m)) (getMethods m)). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inline_BaseModule_Rules. Qed. Definition inline_BaseModule_rules_BaseModuleWf {f} {ty} {m : BaseModuleWf ty} (inMeth : In f (getMethods m)) := Build_BaseModuleWf (WfBaseMod_inline_BaseModule_Rules _ inMeth (wfBaseModule m)). Definition inline_BaseModule_rules_BaseModuleWf_new {f} {ty} {m : BaseModuleWf_new ty} (inMeth : In f (getMethods m)) := Build_BaseModuleWf_new (WfBaseMod_inline_BaseModule_Rules_new _ inMeth (wfBaseModule_new m)). Lemma TraceInclusion_inline_BaseModule_rules_Wf {f} {m : BaseModuleWf type} (inMeth : In f (getMethods m)): TraceInclusion m (inline_BaseModule_rules_BaseModuleWf inMeth). Proof. specialize (TraceInclusion_flatten_r m) as P1. simpl in *; unfold flatten, getFlat in P1; simpl in *. assert (WfMod type m) as TMP;[constructor; apply wfBaseModule |specialize (WfMod_getFlat TMP) as P2; clear TMP]. specialize (TraceInclusion_inline_BaseModule_rules f P2 inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inline_BaseModule_rules_Wf_new {f} {m : BaseModuleWf_new type} (inMeth : In f (getMethods m)): TraceInclusion m (inline_BaseModule_rules_BaseModuleWf_new inMeth). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inline_BaseModule_rules_Wf f m'). Unshelve. exact inMeth. Qed. Lemma TraceInclusion_inline_BaseModule_meths regs rules meths f: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (map (inlineSingle_Meth f) meths))). Proof. intros. unfold inlineSingle_BaseModule. specialize (inline_meth_fold_right f H (seq 0 (length meths)) H0) as P1. repeat rewrite map_fold_right_eq in *. assumption. Qed. Theorem TraceInclusion_inline_BaseModule_meths_new regs rules meths f: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (map (inlineSingle_Meth f) meths))). Proof. rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inline_BaseModule_meths. Qed. Lemma WfBaseMod_inline_BaseModule_Meths ty m f: In f (getMethods m) -> WfBaseModule ty m -> WfBaseModule ty (BaseMod (getRegisters m) (getRules m) (map (inlineSingle_Meth f) (getMethods m))). Proof. intros. assert (WfMod ty m) as TMP;[constructor; auto|specialize (WfMod_getFlat TMP) as P1; clear TMP]. specialize (WfMod_inline_all_Meth _ (seq 0 (length (getMethods m))) H P1) as P2. repeat rewrite map_fold_right_eq in *; simpl in *. inv P2; auto. Qed. Lemma WfBaseMod_inline_BaseModule_Meths_new ty m f: In f (getMethods m) -> WfBaseModule_new ty m -> WfBaseModule_new ty (BaseMod (getRegisters m) (getRules m) (map (inlineSingle_Meth f) (getMethods m))). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inline_BaseModule_Meths. Qed. Definition inline_BaseModule_meths_BaseModuleWf {f} {ty} {m : BaseModuleWf ty} (inMeth : In f (getMethods m)) := Build_BaseModuleWf (WfBaseMod_inline_BaseModule_Meths _ inMeth (wfBaseModule m)). Definition inline_BaseModule_meths_BaseModuleWf_new {f} {ty} {m : BaseModuleWf_new ty} (inMeth : In f (getMethods m)) := Build_BaseModuleWf_new (WfBaseMod_inline_BaseModule_Meths_new _ inMeth (wfBaseModule_new m)). Lemma TraceInclusion_inline_BaseModule_meths_Wf {f} {m : BaseModuleWf type} (inMeth : In f (getMethods m)): TraceInclusion m (inline_BaseModule_meths_BaseModuleWf inMeth). Proof. specialize (TraceInclusion_flatten_r m) as P1. simpl in *; unfold flatten, getFlat in P1; simpl in *. assert (WfMod type m) as TMP;[constructor; apply wfBaseModule |specialize (WfMod_getFlat TMP) as P2; clear TMP]. specialize (TraceInclusion_inline_BaseModule_meths f P2 inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inline_BaseModule_meths_Wf_new {f} {m : BaseModuleWf_new type} (inMeth : In f (getMethods m)): TraceInclusion m (inline_BaseModule_meths_BaseModuleWf_new inMeth). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inline_BaseModule_meths_Wf f m'). Unshelve. exact inMeth. Qed. Lemma TraceInclusion_inline_BaseModule_all regs rules meths f: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (inlineSingle_BaseModule f regs rules meths)). Proof. intros. unfold inlineSingle_BaseModule. specialize (TraceInclusion_inline_BaseModule_rules f H H0) as P1. specialize (WfMod_inline_all_Rule _ (seq 0 (length rules)) H0 H) as P2. specialize (TraceInclusion_inline_BaseModule_meths f P2 H0) as P3. repeat rewrite map_fold_right_eq in *. apply (TraceInclusion_trans P1 P3). Qed. Theorem TraceInclusion_inline_BaseModule_all_new regs rules meths f: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs rules meths)) (Base (inlineSingle_BaseModule f regs rules meths)). Proof. rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inline_BaseModule_all. Qed. Lemma WfBaseMod_inlineSingle_BaseModule ty m f: In f (getMethods m) -> WfBaseModule ty m -> WfBaseModule ty (inlineSingle_BaseModule f (getRegisters m) (getRules m) (getMethods m)). Proof. intros. unfold inlineSingle_BaseModule. specialize (WfBaseMod_inline_BaseModule_Rules f H H0) as P1. assert (In f (getMethods ((BaseMod (getRegisters m) (map (inlineSingle_Rule f) (getRules m)) (getMethods m))))) as P2;[simpl; auto|]. apply (WfBaseMod_inline_BaseModule_Meths f P2 P1). Qed. Lemma WfBaseMod_inlineSingle_BaseModule_new ty m f: In f (getMethods m) -> WfBaseModule_new ty m -> WfBaseModule_new ty (inlineSingle_BaseModule f (getRegisters m) (getRules m) (getMethods m)). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inlineSingle_BaseModule. Qed. Definition inlineSingle_BaseModuleWf {f} {ty} {m : BaseModuleWf ty} (inMeth : In f (getMethods m)):= Build_BaseModuleWf (WfBaseMod_inlineSingle_BaseModule _ inMeth (wfBaseModule m)). Definition inlineSingle_BaseModuleWf_new {f} {ty} {m : BaseModuleWf_new ty} (inMeth : In f (getMethods m)):= Build_BaseModuleWf_new (WfBaseMod_inlineSingle_BaseModule_new _ inMeth (wfBaseModule_new m)). Lemma TraceInclusion_inline_BaseModule_all_Wf {f} {m : BaseModuleWf type} (inMeth : In f (getMethods m)): TraceInclusion m (inlineSingle_BaseModuleWf inMeth). Proof. specialize (TraceInclusion_flatten_r m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inline_BaseModule_all _ P2 inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inline_BaseModule_all_Wf_new {f} {m : BaseModuleWf_new type} (inMeth : In f (getMethods m)): TraceInclusion m (inlineSingle_BaseModuleWf_new inMeth). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inline_BaseModule_all_Wf f m'). Unshelve. exact inMeth. Qed. Section inline_all_all. Lemma TraceInclusion_inlineSingle_pos_Rules regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> forall n, (WfMod type (Base (BaseMod regs (inlineSingle_Rules_pos meths n rules) meths))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (inlineSingle_Rules_pos meths n rules) meths)). Proof. intros WfH n. unfold inlineSingle_Rules_pos. case_eq (nth_error meths n); intros sth; [intros sthEq|split; [assumption | apply TraceInclusion_refl]]. split. - apply nth_error_In in sthEq. pose proof (WfMod_inline_all_Rule sth (seq 0 (length rules)) sthEq WfH). repeat rewrite map_fold_right_eq in *. assumption. - apply TraceInclusion_inline_BaseModule_rules; auto. eapply nth_error_In; eauto. Qed. Theorem TraceInclusion_inlineSingle_pos_Rules_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> forall n, (WfMod_new type (Base (BaseMod regs (inlineSingle_Rules_pos meths n rules) meths))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (inlineSingle_Rules_pos meths n rules) meths)). Proof. intros. rewrite WfMod_new_WfMod_iff in *. apply TraceInclusion_inlineSingle_pos_Rules; auto. Qed. Lemma WfBaseMod_inlineSingle_Rules_pos ty m n: WfBaseModule ty m -> WfBaseModule ty (BaseMod (getRegisters m) (inlineSingle_Rules_pos (getMethods m) n (getRules m)) (getMethods m)). Proof. intros. assert (WfMod ty m) as P1;[constructor; auto|apply WfMod_getFlat in P1]. unfold getFlat in P1; simpl in *. unfold inlineSingle_Rules_pos. destruct (nth_error) eqn:G; auto. apply nth_error_In in G. pose proof (WfMod_inline_all_Rule d (seq 0 (length (getRules m))) G P1). repeat rewrite map_fold_right_eq in *. inv H0. assumption. Qed. Lemma WfBaseMod_inlineSingle_Rules_pos_new ty m n: WfBaseModule_new ty m -> WfBaseModule_new ty (BaseMod (getRegisters m) (inlineSingle_Rules_pos (getMethods m) n (getRules m)) (getMethods m)). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inlineSingle_Rules_pos. Qed. Definition inlineSingle_Rules_pos_BaseModuleWf {ty} (m : BaseModuleWf ty) n := Build_BaseModuleWf (WfBaseMod_inlineSingle_Rules_pos n (wfBaseModule m)). Definition inlineSingle_Rules_pos_BaseModuleWf_new {ty} (m : BaseModuleWf_new ty) n := Build_BaseModuleWf_new (WfBaseMod_inlineSingle_Rules_pos_new n (wfBaseModule_new m)). Lemma TraceInclusion_inlineSingle_pos_Rules_Wf (m : BaseModuleWf type) n : TraceInclusion m (inlineSingle_Rules_pos_BaseModuleWf m n). Proof. specialize (TraceInclusion_flatten_r m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineSingle_pos_Rules P2 n) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineSingle_pos_Rules_Wf_new (m : BaseModuleWf_new type) n : TraceInclusion m (inlineSingle_Rules_pos_BaseModuleWf_new m n). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (TraceInclusion_inlineSingle_pos_Rules_Wf m'). Qed. Lemma TraceInclusion_inlineAll_pos_Rules regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> (WfMod type (Base (BaseMod regs (inlineAll_Rules meths rules) meths))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (inlineAll_Rules meths rules) meths)). Proof. intros WfH. unfold inlineAll_Rules. induction (Datatypes.length meths); [simpl in *; split; [assumption | apply TraceInclusion_refl]|]. rewrite seq_eq. rewrite fold_left_app; simpl in *. destruct IHn as [IHn1 IHn2]. pose proof (TraceInclusion_inlineSingle_pos_Rules IHn1 n) as [sth1 sth2]. destruct n; simpl in *; auto. split; auto. eapply TraceInclusion_trans; eauto. Qed. Theorem TraceInclusion_inlineAll_pos_Rules_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> (WfMod_new type (Base (BaseMod regs (inlineAll_Rules meths rules) meths))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs (inlineAll_Rules meths rules) meths)). Proof. repeat rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlineAll_pos_Rules. Qed. Lemma WfBaseMod_inlineAll_Rules ty m : WfBaseModule ty m -> WfBaseModule ty (BaseMod (getRegisters m) (inlineAll_Rules (getMethods m) (getRules m)) (getMethods m)). Proof. intros. assert (WfMod ty m) as P1;[constructor; auto|apply WfMod_getFlat in P1]. unfold getFlat in P1; simpl in *. unfold inlineAll_Rules. remember (Datatypes.length (getMethods m)) as n1. setoid_rewrite <- Heqn1. clear Heqn1. induction n1; auto. rewrite seq_eq. rewrite fold_left_app; simpl in *. pose proof (WfBaseMod_inlineSingle_Rules_pos n1 IHn1); simpl in *; auto. Qed. Lemma WfBaseMod_inlineAll_Rules_new ty m : WfBaseModule_new ty m -> WfBaseModule_new ty (BaseMod (getRegisters m) (inlineAll_Rules (getMethods m) (getRules m)) (getMethods m)). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inlineAll_Rules. Qed. Definition inlineAll_Rules_BaseModuleWf {ty} (m : BaseModuleWf ty) := Build_BaseModuleWf (WfBaseMod_inlineAll_Rules (wfBaseModule m)). Definition inlineAll_Rules_BaseModuleWf_new {ty} (m : BaseModuleWf_new ty) := Build_BaseModuleWf_new (WfBaseMod_inlineAll_Rules_new (wfBaseModule_new m)). Lemma TraceInclusion_inlineAll_pos_Rules_Wf (m : BaseModuleWf type) : TraceInclusion m (inlineAll_Rules_BaseModuleWf m). Proof. specialize (TraceInclusion_flatten_r m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineAll_pos_Rules P2) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineAll_pos_Rules_Wf_new (m : BaseModuleWf_new type) : TraceInclusion m (inlineAll_Rules_BaseModuleWf_new m). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (TraceInclusion_inlineAll_pos_Rules_Wf m'). Qed. Lemma TraceInclusion_inlineSingle_pos_Meths regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> forall n, (WfMod type (Base (BaseMod regs rules (inlineSingle_Meths_pos meths n)))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (inlineSingle_Meths_pos meths n))). Proof. intros WfH n. unfold inlineSingle_Meths_pos. case_eq (nth_error meths n); intros sth; [intros sthEq|split; [assumption | apply TraceInclusion_refl]]. split. - apply nth_error_In in sthEq. pose proof (WfMod_inline_all_Meth sth (seq 0 (length meths)) sthEq WfH). repeat rewrite map_fold_right_eq in *. assumption. - apply TraceInclusion_inline_BaseModule_meths; auto. eapply nth_error_In; eauto. Qed. Theorem TraceInclusion_inlineSingle_pos_Meths_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> forall n, (WfMod_new type (Base (BaseMod regs rules (inlineSingle_Meths_pos meths n)))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (inlineSingle_Meths_pos meths n))). Proof. intros. rewrite WfMod_new_WfMod_iff in *. apply TraceInclusion_inlineSingle_pos_Meths; auto. Qed. Lemma WfBaseMod_inlineSingle_Meths_pos ty m n: WfBaseModule ty m -> WfBaseModule ty (BaseMod (getRegisters m) (getRules m) (inlineSingle_Meths_pos (getMethods m) n)). Proof. intros. assert (WfMod ty m) as P1;[constructor; auto|apply WfMod_getFlat in P1]. unfold getFlat in P1; simpl in *. unfold inlineSingle_Meths_pos; destruct nth_error eqn:G; auto. apply nth_error_In in G. pose proof (WfMod_inline_all_Meth d (seq 0 (length (getMethods m))) G P1). repeat rewrite map_fold_right_eq in *. inv H0; assumption. Qed. Lemma WfBaseMod_inlineSingle_Meths_pos_new ty m n: WfBaseModule_new ty m -> WfBaseModule_new ty (BaseMod (getRegisters m) (getRules m) (inlineSingle_Meths_pos (getMethods m) n)). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inlineSingle_Meths_pos. Qed. Definition inlineSingle_Meths_pos_BaseModuleWf {ty} (m : BaseModuleWf ty) n := Build_BaseModuleWf (WfBaseMod_inlineSingle_Meths_pos n (wfBaseModule m)). Definition inlineSingle_Meths_pos_BaseModuleWf_new {ty} (m : BaseModuleWf_new ty) n := Build_BaseModuleWf_new (WfBaseMod_inlineSingle_Meths_pos_new n (wfBaseModule_new m)). Lemma TraceInclusion_inlineSingle_pos_Meths_Wf (m : BaseModuleWf type) n : TraceInclusion m (inlineSingle_Meths_pos_BaseModuleWf m n). Proof. specialize (TraceInclusion_flatten_r m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineSingle_pos_Meths P2 n) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineSingle_pos_Meths_Wf_new (m : BaseModuleWf_new type) n : TraceInclusion m (inlineSingle_Meths_pos_BaseModuleWf_new m n). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (TraceInclusion_inlineSingle_pos_Meths_Wf m'). Qed. Lemma TraceInclusion_inlineAll_pos_Meths regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> (WfMod type (Base (BaseMod regs rules (inlineAll_Meths meths)))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (inlineAll_Meths meths))). Proof. intros WfH. unfold inlineAll_Meths. induction (Datatypes.length meths); [simpl; split; [assumption | apply TraceInclusion_refl]|]. rewrite seq_eq. rewrite fold_left_app; simpl. destruct IHn as [IHn1 IHn2]. pose proof (TraceInclusion_inlineSingle_pos_Meths IHn1 n) as [sth1 sth2]. destruct n; simpl in *; auto. split; auto. eapply TraceInclusion_trans; eauto. Qed. Theorem TraceInclusion_inlineAll_pos_Meths_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> (WfMod_new type (Base (BaseMod regs rules (inlineAll_Meths meths)))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (BaseMod regs rules (inlineAll_Meths meths))). Proof. repeat rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlineAll_pos_Meths. Qed. Lemma WfBaseMod_inlineAll_Meths ty m : WfBaseModule ty m -> WfBaseModule ty (BaseMod (getRegisters m) (getRules m) (inlineAll_Meths (getMethods m))). Proof. intros. assert (WfMod ty m) as P1;[constructor; auto|apply WfMod_getFlat in P1]. unfold getFlat in P1; simpl in *. unfold inlineAll_Meths. remember (Datatypes.length (getMethods m)) as n1. setoid_rewrite <- Heqn1. clear Heqn1. induction n1; auto. rewrite seq_eq. rewrite fold_left_app; simpl in *. pose proof (WfBaseMod_inlineSingle_Meths_pos n1 IHn1); simpl in *; auto. Qed. Lemma WfBaseMod_inlineAll_Meths_new ty m : WfBaseModule_new ty m -> WfBaseModule_new ty (BaseMod (getRegisters m) (getRules m) (inlineAll_Meths (getMethods m))). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inlineAll_Meths. Qed. Definition inlineAll_Meths_BaseModuleWf {ty} (m : BaseModuleWf ty) := Build_BaseModuleWf (WfBaseMod_inlineAll_Meths (wfBaseModule m)). Definition inlineAll_Meths_BaseModuleWf_new {ty} (m : BaseModuleWf_new ty) := Build_BaseModuleWf_new (WfBaseMod_inlineAll_Meths_new (wfBaseModule_new m)). Lemma TraceInclusion_inlineAll_pos_Meths_Wf (m : BaseModuleWf type) : TraceInclusion m (inlineAll_Meths_BaseModuleWf m). Proof. specialize (TraceInclusion_flatten_r m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineAll_pos_Meths P2) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineAll_pos_Meths_Wf_new (m : BaseModuleWf_new type) : TraceInclusion m (inlineAll_Meths_BaseModuleWf_new m). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (TraceInclusion_inlineAll_pos_Meths_Wf m'). Qed. Lemma TraceInclusion_inlineAll_pos regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> (WfMod type (Base (inlineAll_All regs rules meths))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (inlineAll_All regs rules meths)). Proof. unfold inlineAll_All in *. intros WfH1. pose proof (TraceInclusion_inlineAll_pos_Meths WfH1) as [WfH2 P2]. pose proof (TraceInclusion_inlineAll_pos_Rules WfH2) as [WfH3 P3]. split; auto. eapply TraceInclusion_trans; eauto. Qed. Theorem TraceInclusion_inlineAll_pos_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> (WfMod_new type (Base (inlineAll_All regs rules meths))) /\ TraceInclusion (Base (BaseMod regs rules meths)) (Base (inlineAll_All regs rules meths)). Proof. repeat rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlineAll_pos. Qed. Lemma WfBaseMod_inlineAll_All ty m : WfBaseModule ty m -> WfBaseModule ty (inlineAll_All (getRegisters m) (getRules m) (getMethods m)). Proof. intros. assert (WfMod ty m) as P1;[constructor; auto|apply WfMod_getFlat in P1]. unfold getFlat in P1; simpl in *. unfold inlineAll_All in *. inv P1. pose proof (WfBaseMod_inlineAll_Meths HWfBaseModule) as P2. pose proof (WfBaseMod_inlineAll_Rules P2) as P3; simpl in *; auto. Qed. Lemma WfBaseMod_inlineAll_All_new ty m : WfBaseModule_new ty m -> WfBaseModule_new ty (inlineAll_All (getRegisters m) (getRules m) (getMethods m)). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply WfBaseMod_inlineAll_All. Qed. Definition inlineAll_All_BaseModuleWf {ty} (m : BaseModuleWf ty) := Build_BaseModuleWf (WfBaseMod_inlineAll_All (wfBaseModule m)). Definition inlineAll_All_BaseModuleWf_new {ty} (m : BaseModuleWf_new ty) := Build_BaseModuleWf_new (WfBaseMod_inlineAll_All_new (wfBaseModule_new m)). Lemma TraceInclusion_inlineAll_pos_Wf (m : BaseModuleWf type) : TraceInclusion m (inlineAll_All_BaseModuleWf m). Proof. specialize (TraceInclusion_flatten_r m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineAll_pos P2) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineAll_pos_Wf_new (m : BaseModuleWf_new type) : TraceInclusion m (inlineAll_All_BaseModuleWf_new m). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (TraceInclusion_inlineAll_pos_Wf m'). Qed. End inline_all_all. Section flatten_and_inline_all. Lemma inline_preserves_key_Meth (f : DefMethT) (meth : DefMethT): fst (inlineSingle_Meth f meth) = fst meth. Proof. destruct meth; auto. Qed. Lemma inline_preserves_KindAttr_Meth (f : DefMethT) (meth : DefMethT): (fst (inlineSingle_Meth f meth), projT1 (snd (inlineSingle_Meth f meth))) = (fst meth, projT1 (snd meth)). Proof. destruct meth; simpl. apply f_equal. destruct (String.eqb); auto. destruct s0; simpl; auto. Qed. Corollary inline_preserves_keys_Meth (f : DefMethT) (l : list DefMethT) : (map fst (map (inlineSingle_Meth f) l)) = (map fst l). Proof. induction l; auto. simpl;rewrite inline_preserves_key_Meth; rewrite IHl; reflexivity. Qed. Corollary inline_preserves_KindAttrs_Meth (f : DefMethT) (l : list DefMethT) : (getKindAttr (map (inlineSingle_Meth f) l)) = (getKindAttr l). Proof. induction l; auto. simpl; rewrite inline_preserves_KindAttr_Meth, IHl; reflexivity. Qed. Lemma SameKeys_inlineSingle_Meth_pos meths : forall n, map fst meths = map fst (inlineSingle_Meths_pos meths n). Proof. induction meths; destruct n; simpl in *; auto. - rewrite inline_preserves_key_Meth, inline_preserves_keys_Meth; reflexivity. - unfold inlineSingle_Meths_pos in *; simpl in *. specialize (IHmeths n); case_eq (nth_error meths n);intros;[setoid_rewrite H; setoid_rewrite H in IHmeths|]. + simpl; rewrite inline_preserves_key_Meth, inline_preserves_keys_Meth; reflexivity. + setoid_rewrite H; simpl; reflexivity. Qed. Lemma SameKindAttr_inlineSingle_Meth_pos meths : forall n, getKindAttr meths =getKindAttr (inlineSingle_Meths_pos meths n). Proof. induction meths; destruct n; simpl in *; auto. - rewrite inline_preserves_KindAttr_Meth, inline_preserves_KindAttrs_Meth; reflexivity. - unfold inlineSingle_Meths_pos in *; simpl in *. specialize (IHmeths n); case_eq (nth_error meths n);intros;[setoid_rewrite H; setoid_rewrite H in IHmeths|]. + simpl; rewrite inline_preserves_KindAttr_Meth, inline_preserves_KindAttrs_Meth; reflexivity. + setoid_rewrite H; simpl; reflexivity. Qed. Lemma fold_left_nil xs : fold_left inlineSingle_Meths_pos xs nil = nil. Proof. induction xs; simpl; auto. unfold inlineSingle_Meths_pos in *; simpl. case_eq (nth_error (nil: list DefMethT) a); auto. Qed. Lemma SameKeys_inlineSome_Meths : forall xs meths, map fst meths = map fst (fold_left inlineSingle_Meths_pos xs meths). Proof. induction xs; simpl; auto. unfold inlineSingle_Meths_pos at 2. intros. case_eq (nth_error meths a);intros;setoid_rewrite H; auto. erewrite <-IHxs. rewrite inline_preserves_keys_Meth; reflexivity. Qed. Lemma SameKindAttrs_inlineSome_Meths : forall xs meths, getKindAttr meths = getKindAttr (fold_left inlineSingle_Meths_pos xs meths). Proof. induction xs; simpl; auto. unfold inlineSingle_Meths_pos at 2. intros. case_eq (nth_error meths a);intros;setoid_rewrite H; auto. erewrite <-IHxs. rewrite inline_preserves_KindAttrs_Meth; reflexivity. Qed. (* Lemma SameKeys_inlineSome_Rules : forall (xs : nat) (meths : list DefMethT) (rules : list RuleT), map fst rules = map fst (inlineSingle_Rules_pos meths xs rules). Proof. induction xs; simpl. - intros; unfold inlineSingle_Rules_pos. simpl; destruct meths; auto. unfold inlineSingle_Rules_pos. intros. case_eq (nth_error meths a);intros;setoid_rewrite H; auto. erewrite <-IHxs. rewrite inline_preserves_keys_Meth; reflexivity. Qed.*) Corollary SameKeys_inlineAll_Meths meths: map fst meths = map fst (inlineAll_Meths meths). Proof. unfold inlineAll_Meths; rewrite <-SameKeys_inlineSome_Meths; reflexivity. Qed. Corollary SameKindAttrs_inlineAll_Meths meths: getKindAttr meths = getKindAttr (inlineAll_Meths meths). Proof. unfold inlineAll_Meths; rewrite <-SameKindAttrs_inlineSome_Meths; reflexivity. Qed. Lemma map_inlineSingle_Rule_SameKey f rules: map fst (map (inlineSingle_Rule f) rules) = map fst rules. Proof. induction rules; simpl; auto. unfold inlineSingle_Rule at 1; destruct a; simpl. rewrite IHrules; reflexivity. Qed. Lemma SameKeys_inlineSome_Rules a: forall rules meths, map fst rules = map fst (inlineSingle_Rules_pos meths a rules). Proof. intros; unfold inlineSingle_Rules_pos. case_eq (nth_error meths a); intros; auto. rewrite map_inlineSingle_Rule_SameKey; reflexivity. Qed. Lemma SameKeys_inlineAll_Rules meths: forall rules, map fst rules = map fst (inlineAll_Rules meths rules). Proof. unfold inlineAll_Rules. induction (seq 0 (Datatypes.length meths)); simpl; auto. intros. rewrite <- IHl. apply SameKeys_inlineSome_Rules. Qed. Lemma flatten_inline_everything_Wf ty (m : ModWf ty) : WfMod ty (flatten_inline_everything m). Proof. unfold flatten_inline_everything, inlineAll_All_mod. pose proof (flatten_WfMod (wfMod m)) as HWfm'. pose proof (HWfm') as HWfm. unfold flatten, getFlat in *. setoid_rewrite WfMod_createHide in HWfm'; dest. rewrite WfMod_createHide in *; dest. split; simpl in *. - repeat intro; specialize (H _ H3); rewrite <-SameKeys_inlineAll_Meths; assumption. - inv H2. specialize (WfBaseMod_inlineAll_All HWfBaseModule) as P1; simpl in P1; constructor; assumption. Qed. Theorem flatten_inline_everything_Wf_new ty (m : ModWf_new ty) : WfMod_new ty (flatten_inline_everything m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. rewrite WfMod_new_WfMod_iff. apply (flatten_inline_everything_Wf m'). Qed. Definition flatten_inline_everything_ModWf {ty} (m : ModWf ty) : ModWf ty := (Build_ModWf (flatten_inline_everything_Wf m)). Definition flatten_inline_everything_ModWf_new {ty} (m : ModWf_new ty) : ModWf_new ty := (Build_ModWf_new _ _ (flatten_inline_everything_Wf_new m)). Lemma TraceHide_Trace m o s ls: Trace (HideMeth m s) o ls -> Trace m o ls. Proof. induction 1. - econstructor 1; eauto. - econstructor 2; eauto. inv HStep; auto. Qed. Lemma Trace_TraceHide m o s ls : Trace m o ls -> (forall l, In l ls -> (forall v, In (s, projT1 v) (getKindAttr (getAllMethods m)) -> getListFullLabel_diff (s, v) l = 0%Z)) -> Trace (HideMeth m s) o ls. Proof. induction 1; subst; simpl in *; intros. - constructor; auto. - econstructor 2; eauto. econstructor 2; eauto. Qed. Lemma Trace_TraceHide' m o s ls : Trace (HideMeth m s) o ls -> (forall l, In l ls -> (forall v, In (s, projT1 v) (getKindAttr (getAllMethods m)) -> getListFullLabel_diff (s, v) l = 0%Z)) /\ Trace m o ls. Proof. induction 1; subst; simpl in *; intros. - split; intros; try contradiction. constructor; auto. - dest; split; intros. + destruct H2;[subst|eapply H0; eauto]. inv HStep. eapply HHidden; eauto. + econstructor 2; eauto. inv HStep; eauto. Qed. Lemma TraceHide_same m o ls: Trace m o ls -> forall s, ~ In s (map fst (getAllMethods m)) -> Trace (HideMeth m s) o ls. Proof. induction 1; simpl; subst; auto; intros. - econstructor; eauto. - econstructor 2; eauto. constructor; auto; intros. apply (in_map fst) in H1; rewrite fst_getKindAttr in H1; contradiction. Qed. Lemma TraceHide_same' m o ls s: Trace (HideMeth m s) o ls -> Trace m o ls. Proof. intros. apply Trace_TraceHide' with (s := s) in H; auto. dest. auto. Qed. Lemma WeakInclusions_In_l l ls: In l ls -> forall ls', WeakInclusions ls ls' -> exists l', In l' ls' /\ WeakInclusion l l'. Proof. induction ls; intros; try contradiction. destruct H; subst; inv H0. - exists l'; split; auto. left; reflexivity. - specialize (IHls H _ H3); dest. exists x; split; auto. right; assumption. Qed. Lemma WeakInclusions_In_r l ls': In l ls' -> forall ls, WeakInclusions ls ls' -> exists l', In l' ls /\ WeakInclusion l' l. Proof. induction ls'; intros; inv H0; try contradiction. destruct H; subst. - exists l0; split; auto. left; reflexivity. - specialize (IHls' H _ H4); dest. exists x; split; auto. right; assumption. Qed. Lemma TraceInclusion'_HideMeth m m' s: TraceInclusion' m m' -> TraceInclusion' (HideMeth m s) (HideMeth m' s). Proof. unfold TraceInclusion'. intros. specialize (H _ _ (TraceHide_Trace H0)); dest. exists x; split; auto. destruct H; unfold TraceList; exists x0. apply Trace_TraceHide; auto; intros. inv H0; [inv H1; contradiction|]. inv HStep. apply Trace_TraceHide' in HOldTrace; dest. destruct (in_dec (prod_dec string_dec Signature_dec) (s, projT1 v) (getKindAttr (getAllMethods m))). - inv H1. specialize (HHidden _ i). destruct H2; subst. + destruct H9; specialize (H1 (s, v)). Omega.omega. + specialize (WeakInclusions_In_r _ H1 H7) as TMP; dest. specialize (H0 _ H2 _ i); destruct H5. specialize (H5 (s, v)); Omega.omega. - specialize (WeakInclusions_In_r _ H2 H1) as TMP; dest. assert (In (fst (s, v), projT1 (snd (s, v))) (getKindAttr (getAllMethods m'))) as P0. { simpl; assumption. } assert (~In (fst (s, v), projT1 (snd (s, v))) (getKindAttr (getAllMethods m))) as P1. { simpl; assumption. } specialize (In_nth_error _ _ H2) as TMP; dest. specialize (Trace_meth_InCall_InDef_InExec H _ _ H7 P0) as P2. specialize (getNumCalls_nonneg (s, v) x1) as P3. inv H6; specialize (H8 (s, v)); unfold getListFullLabel_diff in *. inv H5. + rewrite (NotInDef_ZeroExecs_Step' _ P1 HStep0) in *; lia. + specialize (In_nth_error _ _ H6) as TMP; dest. rewrite (NotInDef_ZeroExecs_Trace' _ H4 P1 _ H5) in *; lia. Qed. Corollary TraceInclusion_HideMeth m m' s: TraceInclusion m m' -> TraceInclusion (HideMeth m s) (HideMeth m' s). Proof. intros. apply TraceInclusion'_TraceInclusion. apply TraceInclusion_TraceInclusion' in H. eauto using TraceInclusion'_HideMeth. Qed. Lemma TraceInclusion_createHideMod m m' ls: TraceInclusion m m' -> TraceInclusion (createHideMod m ls) (createHideMod m' ls). Proof. intros; induction ls; auto; simpl in *. apply TraceInclusion_HideMeth. assumption. Qed. Lemma TraceInclusion'_TraceInclusion_iff m m' : TraceInclusion m m' <-> TraceInclusion' m m'. Proof. split; intros; eauto using TraceInclusion'_TraceInclusion, TraceInclusion_TraceInclusion'. Qed. Lemma Trace_createHide l m m' : TraceInclusion (Base m) (Base m') -> TraceInclusion (createHide m l) (createHide m' l). Proof. induction l; simpl in *; auto. intros. apply TraceInclusion_TraceInclusion' in H. apply TraceInclusion'_TraceInclusion. apply TraceInclusion'_HideMeth. apply TraceInclusion_TraceInclusion'; apply TraceInclusion'_TraceInclusion in H; auto. Qed. Lemma WfMod_WfBase_getFlat ty m: (WfMod ty m) -> (WfMod ty (Base (getFlat m))). Proof. intro. induction m; simpl in *. - intros. constructor 1; intros; apply WfMod_WfBaseMod_flat; auto; specialize (H ty); inv H; auto. - intros. unfold getFlat in *; simpl in *; apply IHm. intros. specialize (H). inv H; auto. - intros. assert (HWf1: WfMod ty m1) by (specialize (H); inv H; auto). assert (HWf2: WfMod ty m2) by (specialize (H); inv H; auto). assert (WfConcat1: WfConcat ty m1 m2) by (specialize (H); inv H; auto). assert (WfConcat2: WfConcat ty m2 m1) by (specialize (H); inv H; auto). specialize (H). inv H. specialize (IHm1 HWf1); specialize (IHm2 HWf2). constructor 1; ((apply WfMod_WfBaseMod_flat; constructor 3; auto) || (specialize (IHm1); specialize (IHm2); inv IHm1; inv IHm2; simpl in *; apply NoDupKey_Expand; auto)). Qed. Lemma TraceInclusion_flatten_inline_everything_r (m : ModWf type) : TraceInclusion m (flatten_inline_everything_ModWf m). Proof. specialize (wfMod (flatten_inline_everything_ModWf m)) as Wf1. simpl. specialize (TraceInclusion_flatten_r m) as P1. unfold flatten, getFlat in *. assert (WfMod type (Base (getFlat m))). { intros. apply (WfMod_WfBase_getFlat (wfMod m)). } unfold getFlat in *. specialize (TraceInclusion_inlineAll_pos H) as TMP; dest. unfold inlineAll_All in *. apply (Trace_createHide (getHidden m)) in H1. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_flatten_inline_everything_r_new (m : ModWf_new type) : TraceInclusion m (flatten_inline_everything_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (TraceInclusion_flatten_inline_everything_r m'). Qed. End flatten_and_inline_all. Lemma inlineSingle_Rule_map_Wf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)): WfMod ty (createHide (inlineSingle_Rule_map_BaseModule f (getFlat m)) (getHidden m)). Proof. intros. unfold inlineSingle_Rule_map_BaseModule. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. specialize (WfMod_inline_all_Rule (ty:=ty ) (regs:= (getAllRegisters m)) (rules:= (getAllRules m)) (meths:= (getAllMethods m)) f (seq 0 (length (getAllRules m))) inMeths) as P2. repeat rewrite map_fold_right_eq in *. unfold getFlat in *; simpl in *. rewrite WfMod_createHide in *; dest; simpl in *; split; eauto. Qed. Theorem inlineSingle_Rule_map_Wf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)): WfMod_new ty (createHide (inlineSingle_Rule_map_BaseModule f (getFlat m)) (getHidden m)). Proof. rewrite WfMod_new_WfMod_iff. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (@inlineSingle_Rule_map_Wf _ m'). exact inMeths. Qed. Definition inlineSingle_Rule_map_ModWf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) := (Build_ModWf (inlineSingle_Rule_map_Wf inMeths)). Definition inlineSingle_Rule_map_ModWf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) := (Build_ModWf_new _ _ (inlineSingle_Rule_map_Wf_new inMeths)). Lemma inlineSingle_Meth_map_Wf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) : WfMod ty (createHide (inlineSingle_Meth_map_BaseModule f (getFlat m)) (getHidden m)). Proof. intros. unfold inlineSingle_Meth_map_BaseModule. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. specialize (WfMod_inline_all_Meth (ty:=ty) (regs:= (getAllRegisters m)) (rules:= (getAllRules m)) (meths:= (getAllMethods m)) f (seq 0 (length (getAllMethods m))) inMeths) as P2. repeat rewrite map_fold_right_eq in *. unfold getFlat in *; simpl in *. rewrite WfMod_createHide in *; dest; simpl in *; split; eauto. rewrite <- SameKeys_Meth_fold_right. assumption. Qed. Theorem inlineSingle_Meth_map_Wf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) : WfMod_new ty (createHide (inlineSingle_Meth_map_BaseModule f (getFlat m)) (getHidden m)). Proof. rewrite WfMod_new_WfMod_iff. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (@inlineSingle_Meth_map_Wf _ m'). exact inMeths. Qed. Definition inlineSingle_Meth_map_ModWf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) := (Build_ModWf (inlineSingle_Meth_map_Wf inMeths)). Definition inlineSingle_Meth_map_ModWf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) := (Build_ModWf_new _ _ (inlineSingle_Meth_map_Wf_new inMeths)). Lemma inlineSingle_Rule_map_TraceInclusion {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)): TraceInclusion m (inlineSingle_Rule_map_ModWf inMeths). Proof. intros. specialize (TraceInclusion_flatten_r m) as TI_flatten; simpl in *. unfold flatten, inlineSingle_Rule_map_BaseModule, getFlat in *; simpl in *. specialize (TraceInclusion_inline_BaseModule_rules f (WfMod_WfBase_getFlat (wfMod m)) inMeths) as P1. specialize (Trace_createHide (getHidden m) P1) as P2. apply (TraceInclusion_trans TI_flatten P2). Qed. Theorem inlineSingle_Rule_map_TraceInclusion_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)): TraceInclusion m (inlineSingle_Rule_map_ModWf_new inMeths). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_Rule_map_TraceInclusion m'). Unshelve. exact inMeths. Qed. Lemma inlineSingle_Meth_map_TraceInclusion {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)) : TraceInclusion m (inlineSingle_Meth_map_ModWf inMeths). Proof. intros. specialize (TraceInclusion_flatten_r m) as TI_flatten; simpl in *. unfold flatten, inlineSingle_Meth_map_BaseModule, getFlat in *; simpl in *. specialize (TraceInclusion_inline_BaseModule_meths f (WfMod_WfBase_getFlat (wfMod m)) inMeths) as P1. specialize (Trace_createHide (getHidden m) P1) as P2. apply (TraceInclusion_trans TI_flatten P2). Qed. Theorem inlineSingle_Meth_map_TraceInclusion_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)) : TraceInclusion m (inlineSingle_Meth_map_ModWf_new inMeths). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_Meth_map_TraceInclusion m'). Unshelve. exact inMeths. Qed. Definition inlineSingle_Module (f : DefMethT) (m : Mod) := createHide (inlineSingle_BaseModule f (getAllRegisters m) (getAllRules m) (getAllMethods m)) (getHidden m). Lemma inlineSingle_Module_Wf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) : WfMod ty (inlineSingle_Module f m). Proof. unfold inlineSingle_Module, inlineSingle_BaseModule; simpl. specialize (inlineSingle_Rule_map_Wf inMeths) as P1; unfold inlineSingle_Rule, inlineSingle_Rule_map_BaseModule, getFlat in P1; simpl in *. assert (In f (getAllMethods (createHide (inlineSingle_Rule_map_BaseModule f (getFlat m)) (getHidden m)))) as P2. - unfold inlineSingle_Rule_map_BaseModule, getFlat; simpl. rewrite createHide_Meths; simpl; assumption. - specialize (inlineSingle_Meth_map_Wf (m := Build_ModWf P1) P2) as P3; simpl in *. rewrite createHide_hides in P3; simpl in P3; unfold getFlat in P3. rewrite createHide_Regs, createHide_Rules, createHide_Meths in P3; simpl in P3. unfold inlineSingle_Meth_map_BaseModule in P3; simpl in P3. assumption. Qed. Theorem inlineSingle_Module_Wf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) : WfMod_new ty (inlineSingle_Module f m). Proof. apply WfMod_WfMod_new. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (@inlineSingle_Module_Wf _ m'). exact inMeths. Qed. Definition inlineSingle_Module_ModWf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) := (Build_ModWf (inlineSingle_Module_Wf inMeths)). Definition inlineSingle_Module_ModWf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) := (Build_ModWf_new _ _ (inlineSingle_Module_Wf_new inMeths)). Lemma inlineSingle_BaseModule_TraceInclusion {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)) : TraceInclusion m (inlineSingle_Module_ModWf inMeths). Proof. specialize (TraceInclusion_flatten_r m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (TraceInclusion_inline_BaseModule_all _ H0 inMeths) as P2. specialize (Trace_createHide (getHidden m) P2) as P3. apply (TraceInclusion_trans TI_flatten P3). Qed. Theorem inlineSingle_BaseModule_TraceInclusion_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)) : TraceInclusion m (inlineSingle_Module_ModWf_new inMeths). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_BaseModule_TraceInclusion m'). Unshelve. exact inMeths. Qed. Lemma inlineSingle_BaseModule_nth_Meth_Wf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : WfMod ty (createHide (inlineSingle_BaseModule_nth_Meth f (getAllRegisters m) (getAllRules m) (getAllMethods m) xs) (getHidden m)). Proof. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in *; dest. specialize (WfMod_inline_all_Meth f xs inMeths H0) as P3. split; auto; simpl in *. rewrite <- SameKeys_Meth_fold_right; assumption. Qed. Theorem inlineSingle_BaseModule_nth_Meth_Wf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : WfMod_new ty (createHide (inlineSingle_BaseModule_nth_Meth f (getAllRegisters m) (getAllRules m) (getAllMethods m) xs) (getHidden m)). Proof. apply WfMod_WfMod_new. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (@inlineSingle_BaseModule_nth_Meth_Wf _ m'). exact inMeths. Qed. Definition inlineSingle_BaseModule_nth_Meth_ModWf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) := (Build_ModWf (inlineSingle_BaseModule_nth_Meth_Wf inMeths xs)). Definition inlineSingle_BaseModule_nth_Meth_ModWf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) := (Build_ModWf_new _ _ (inlineSingle_BaseModule_nth_Meth_Wf_new inMeths xs)). Lemma inlineSingle_BaseModule_nth_Meth_TraceInclusion {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : TraceInclusion m (inlineSingle_BaseModule_nth_Meth_ModWf inMeths xs). Proof. specialize (TraceInclusion_flatten_r m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (inline_meth_fold_right _ H0 xs inMeths) as P2. specialize (Trace_createHide (getHidden m) P2) as P3. apply (TraceInclusion_trans TI_flatten P3). Qed. Theorem inlineSingle_BaseModule_nth_Meth_TraceInclusion_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : TraceInclusion m (inlineSingle_BaseModule_nth_Meth_ModWf_new inMeths xs). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_BaseModule_nth_Meth_TraceInclusion m'). Unshelve. exact inMeths. Qed. Lemma inlineSingle_BaseModule_nth_Rule_Wf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : WfMod ty (createHide (inlineSingle_BaseModule_nth_Rule f (getAllRegisters m) (getAllRules m) (getAllMethods m) xs) (getHidden m)). Proof. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in *; dest; split; auto. apply (WfMod_inline_all_Rule f xs inMeths H0). Qed. Theorem inlineSingle_BaseModule_nth_Rule_Wf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : WfMod_new ty (createHide (inlineSingle_BaseModule_nth_Rule f (getAllRegisters m) (getAllRules m) (getAllMethods m) xs) (getHidden m)). Proof. apply WfMod_WfMod_new. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (@inlineSingle_BaseModule_nth_Rule_Wf _ m'). exact inMeths. Qed. Definition inlineSingle_BaseModule_nth_Rule_ModWf {ty} {m : ModWf ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) := (Build_ModWf (inlineSingle_BaseModule_nth_Rule_Wf inMeths xs)). Definition inlineSingle_BaseModule_nth_Rule_ModWf_new {ty} {m : ModWf_new ty} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) := (Build_ModWf_new _ _ (inlineSingle_BaseModule_nth_Rule_Wf_new inMeths xs)). Lemma inlineSingle_BaseModule_nth_Rule_TraceInclusion {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : TraceInclusion m (inlineSingle_BaseModule_nth_Rule_ModWf inMeths xs). Proof. specialize (TraceInclusion_flatten_r m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (inline_rule_fold_right _ H0 xs inMeths) as P2. specialize (Trace_createHide (getHidden m) P2) as P3. apply (TraceInclusion_trans TI_flatten P3). Qed. Theorem inlineSingle_BaseModule_nth_Rule_TraceInclusion_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : TraceInclusion m (inlineSingle_BaseModule_nth_Rule_ModWf_new inMeths xs). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_BaseModule_nth_Rule_TraceInclusion m'). Unshelve. exact inMeths. Qed. Definition inlineAll_Rules_Mod (m : Mod) := (createHide (inlineAll_Rules_mod (getFlat m)) (getHidden m)). Lemma inlineAll_Rules_Wf ty (m : ModWf ty): WfMod ty (inlineAll_Rules_Mod m). Proof. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. unfold inlineAll_Rules_Mod; rewrite WfMod_createHide in *; dest; split; auto. inv H0; constructor. apply (WfBaseMod_inlineAll_Rules HWfBaseModule). Qed. Theorem inlineAll_Rules_Wf_new ty (m : ModWf_new ty): WfMod_new ty (inlineAll_Rules_Mod m). Proof. apply WfMod_WfMod_new. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (inlineAll_Rules_Wf m'). Qed. Definition inlineAll_Rules_ModWf {ty} (m : ModWf ty) := (Build_ModWf (inlineAll_Rules_Wf m)). Definition inlineAll_Rules_ModWf_new {ty} (m : ModWf_new ty) := (Build_ModWf_new _ _ (inlineAll_Rules_Wf_new m)). Lemma inlineAll_Rules_TraceInclusion (m : ModWf type) : TraceInclusion m (inlineAll_Rules_ModWf m). Proof. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (TraceInclusion_inlineAll_pos_Rules H0) as P2; dest. specialize (Trace_createHide (getHidden m) H2) as P1. specialize (TraceInclusion_flatten_r m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. apply (TraceInclusion_trans TI_flatten P1). Qed. Theorem inlineAll_Rules_TraceInclusion_new (m : ModWf_new type) : TraceInclusion m (inlineAll_Rules_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (inlineAll_Rules_TraceInclusion m'). Qed. Definition inlineAll_Meths_Mod (m : Mod) := (createHide (inlineAll_Meths_mod (getFlat m)) (getHidden m)). Lemma inlineAll_Meths_Wf ty (m : ModWf ty) : WfMod ty (inlineAll_Meths_Mod m). Proof. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. unfold inlineAll_Meths_Mod, inlineAll_Meths_Mod, inlineAll_Meths_mod, inlineAll_Meths; rewrite WfMod_createHide in *; dest; split; simpl in *. - rewrite <- SameKeys_inlineSome_Meths; assumption. - inv H0; constructor. apply (WfBaseMod_inlineAll_Meths HWfBaseModule). Qed. Lemma inlineAll_Meths_Wf_new ty (m : ModWf_new ty) : WfMod_new ty (inlineAll_Meths_Mod m). Proof. apply WfMod_WfMod_new. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (inlineAll_Meths_Wf m'). Qed. Definition inlineAll_Meths_ModWf {ty} (m : ModWf ty) := (Build_ModWf (inlineAll_Meths_Wf m)). Definition inlineAll_Meths_ModWf_new {ty} (m : ModWf_new ty) := (Build_ModWf_new _ _ (inlineAll_Meths_Wf_new m)). Lemma inlineAll_Meths_TraceInclusion (m : ModWf type) : TraceInclusion m (inlineAll_Meths_ModWf m). Proof. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (TraceInclusion_inlineAll_pos_Meths H0) as P2; dest. specialize (Trace_createHide (getHidden m) H2) as P1. specialize (TraceInclusion_flatten_r m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. apply (TraceInclusion_trans TI_flatten P1). Qed. Theorem inlineAll_Meths_TraceInclusion_new (m : ModWf_new type) : TraceInclusion m (inlineAll_Meths_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (inlineAll_Meths_TraceInclusion m'). Qed. Lemma flatten_inline_remove_Wf ty (m : ModWf ty) : WfMod ty (flatten_inline_remove m). Proof. unfold flatten_inline_remove. specialize (WfMod_WfBase_getFlat (wfMod m)) as P1; inv P1. specialize (WfBaseMod_inlineAll_All HWfBaseModule) as P1. unfold WfBaseModule in *; dest. econstructor; repeat split; unfold removeHides; simpl in *; intros; eauto. - rewrite filter_In in H9; dest. specialize (H0 _ H9 v). induction H0; econstructor; eauto. - clear - H1. induction (inlineAll_Meths (getAllMethods m)); simpl; auto. destruct negb. + simpl in *; econstructor; inv H1; auto. intro P1; apply H2. rewrite in_map_iff in P1; dest. rewrite <- H. rewrite filter_In in H0; dest. rewrite in_map_iff; exists x; auto. + inv H1; auto. Qed. Theorem flatten_inline_remove_Wf_new ty (m : ModWf_new ty) : WfMod_new ty (flatten_inline_remove m). Proof. apply WfMod_WfMod_new. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (flatten_inline_remove_Wf m'). Qed. Definition flatten_inline_remove_ModWf {ty} (m : ModWf ty) := (Build_ModWf (flatten_inline_remove_Wf m)). Definition flatten_inline_remove_ModWf_new {ty} (m : ModWf_new ty) := (Build_ModWf_new _ _ (flatten_inline_remove_Wf_new m)). Definition removeMeth (m : BaseModule) (s : string) := (BaseMod (getRegisters m) (getRules m) ((filter (fun df => (negb (String.eqb s (fst df))))) (getMethods m))). Lemma getNumFromExecs_monotonic : forall (f : MethT) (exec : RuleOrMeth) (execs : list RuleOrMeth), (getNumFromExecs f execs <= getNumFromExecs f (exec :: execs))%Z. Proof. intros. assert (exec :: execs = [exec] ++ execs) as P0; auto. rewrite P0, getNumFromExecs_app. specialize (getNumFromExecs_nonneg f [exec]) as P1. lia. Qed. Lemma Substeps_removeMeth (f : string) (m : BaseModule) (o : RegsT) (l : list FullLabel): Substeps m o l -> (forall v, getNumExecs (f, v) l = 0%Z) -> Substeps (removeMeth m f) o l. Proof. induction 1; intros. - econstructor 1; eauto. - rewrite HLabel in *; simpl in *. econstructor; eauto. - rewrite HLabel in *; simpl in *. econstructor 3; eauto. + destruct (string_dec f fn); subst. * exfalso; specialize (H0 (existT SignT (projT1 fb) (argV, retV))). unfold getNumExecs in H0; rewrite map_cons in H0. assert ((fst (snd (u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs)))) = Meth (fn, existT SignT (projT1 fb) (argV, retV))) as TMP; auto; rewrite TMP, getNumFromExecs_eq_cons in H0; clear TMP; auto. specialize (getNumFromExecs_nonneg (fn, existT SignT (projT1 fb) (argV, retV)) (map PPT_execs ls)) as TMP; omega. * unfold removeMeth; simpl; rewrite filter_In; split; auto. rewrite <- String.eqb_neq in n; simpl; rewrite n; reflexivity. + apply IHSubsteps; intros. unfold getNumExecs in *; rewrite map_cons in H0; specialize (H0 v). assert ((fst (snd (u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs)))) = Meth (fn, existT SignT (projT1 fb) (argV, retV))) as TMP; auto; rewrite TMP in H0; clear TMP; auto. specialize (getNumFromExecs_monotonic (f, v) (Meth (fn, existT SignT (projT1 fb) (argV, retV))) (map PPT_execs ls)) as P0. rewrite H0 in P0. specialize (getNumFromExecs_nonneg (f, v) (map PPT_execs ls)) as P1. lia. Qed. Lemma Step_removeMeth (f : string) (m : BaseModule) (o : RegsT) (l : list FullLabel) : Step m o l -> (forall v, getNumExecs (f, v) l = 0%Z) -> Step (removeMeth m f) o l. Proof. intros. inv H. econstructor; eauto using Substeps_removeMeth. unfold MatchingExecCalls_Base in *; simpl. intros. specialize (HMatching f0). rewrite in_map_iff in H; dest. rewrite filter_In in H1; dest. rewrite <- H in HMatching. apply (in_map (fun x => (fst x, projT1 (snd x)))) in H1. auto. Qed. Lemma Substeps_HideMeth (f : string) (m : BaseModule) (o :RegsT) (l : list FullLabel) : Substeps (removeMeth m f) o l -> Substeps m o l. Proof. induction 1. - econstructor 1; eauto. - subst; econstructor 2; eauto. - subst; econstructor 3; eauto. simpl in HInMeths. rewrite filter_In in HInMeths; destruct HInMeths; auto. Qed. Lemma Step_removeMeth_HideMeth_noCalls (f : string) (m : BaseModule) (o : RegsT) (l : list FullLabel) : Step (removeMeth m f) o l -> (forall v, In (f, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (f, v) l = 0%Z) -> Step (HideMeth m f) o l. Proof. intros; inv H. econstructor. - econstructor. + eapply Substeps_HideMeth; eauto. + intros f0 P1. specialize (HMatching f0); simpl in *. destruct (String.eqb f (fst f0)) eqn:G; [rewrite String.eqb_eq in G|rewrite String.eqb_neq in G]; subst. * destruct f0; simpl in *; rewrite H0; auto. apply getNumExecs_nonneg. * rewrite (in_map_iff) in P1; inv P1; dest; destruct f0, s0; simpl in *; inv H. assert (In x (filter (fun df : string * sigT MethodT => negb (String.eqb f (fst df))) (getMethods m))). { rewrite filter_In; split; auto. rewrite <- String.eqb_neq in G. rewrite G; auto. } apply (in_map (fun x => (fst x, projT1 (snd x)))) in H. apply HMatching; assumption. - intros; unfold getListFullLabel_diff; rewrite H0; auto. assert (~In f (map fst (getMethods (removeMeth m f)))). { intro; rewrite in_map_iff in H1; inv H1; inv H2. simpl in H3; rewrite filter_In in H3; inv H3. rewrite eqb_refl in H2; discriminate. } rewrite in_map_iff in H; dest; inv H. rewrite (NotInDef_ZeroExecs_Substeps (fst x, v) H1 HSubsteps); simpl; reflexivity. Qed. Lemma Step_HideMeth_removeMeth_noCalls (f : string) (m : BaseModule) (o : RegsT) (l : list FullLabel) (wfMod : WfMod type m): Step (HideMeth m f) o l -> (forall v, In (f, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (f, v) l = 0%Z) -> Step (removeMeth m f) o l. Proof. intros; inv H. apply Step_removeMeth; auto; intros. destruct (in_dec (prod_dec string_dec Signature_dec) (f, projT1 v) (getKindAttr (getMethods m))). - specialize (HHidden _ i); specialize (H0 v). unfold getListFullLabel_diff in HHidden. setoid_rewrite H0 in HHidden; auto; rewrite Z.sub_0_r in HHidden. assumption. - eapply NotInDef_ZeroExecs_Step'; simpl; eauto. assumption. Qed. Lemma Trace_HideMeth_removeMeth_noCalls (f : string) (m : BaseModule) (o : RegsT) (ls : list (list FullLabel)) (wfMod : WfMod type m) : Trace (HideMeth m f) o ls -> (forall l, In l ls -> forall v, In (f, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (f, v) l = 0%Z) -> Trace (removeMeth m f) o ls. Proof. induction 1; subst; intros. - econstructor 1; eauto. - econstructor 2; eauto. + eapply IHTrace; intros. eapply H0; eauto; right; assumption. + apply Step_HideMeth_removeMeth_noCalls; auto; intros. eapply H0; auto; left; reflexivity. Qed. Lemma Trace_removeMeth_HideMeth_noCalls (f : string) (m : BaseModule) (o : RegsT) (ls : list (list FullLabel)) (wfMod : WfMod type m) : Trace (removeMeth m f) o ls -> (forall l, In l ls -> forall v, In (f, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (f, v) l = 0%Z) -> Trace (HideMeth m f) o ls. Proof. induction 1; subst; intros. - econstructor 1; eauto. - econstructor 2; eauto. + eapply IHTrace; intros. eapply H0; auto; right; assumption. + apply Step_removeMeth_HideMeth_noCalls; auto. intros; apply H0; auto; left; reflexivity. Qed. Lemma NoSelfCallBaseModule_Substeps f m o l: NoSelfCallBaseModule m -> Substeps m o l -> (forall v, In (f, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (f, v) l = 0%Z). Proof. induction 2; intros. - apply getNumCalls_nil. - rewrite HLabel in *. rewrite getNumCalls_cons, (IHSubsteps _ H1), Z.add_0_r; simpl. rewrite (NoSelfCallRule_Impl _ H HInRules HAction (f, v) H1); reflexivity. - rewrite HLabel in *. rewrite getNumCalls_cons; simpl in *. rewrite (IHSubsteps _ H1). rewrite (NoSelfCallMeth_Impl _ H HInMeths argV HAction (f, v) H1). simpl; reflexivity. Qed. Lemma NoSelfCallBaseModule_Step f m o l: NoSelfCallBaseModule m -> Step m o l -> (forall v, In (f, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (f, v) l = 0%Z). Proof. intros; inv H0; eapply NoSelfCallBaseModule_Substeps; eauto. Qed. Lemma NoSelfCallBaseModule_Trace f m o ls : NoSelfCallBaseModule m -> Trace m o ls -> (forall l, In l ls -> (forall v, In (f, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (f, v) l = 0%Z)). Proof. induction 2; subst; simpl in *; intros. - contradiction. - destruct H1; subst. + eapply NoSelfCallBaseModule_Step; eauto. + eapply IHTrace; eauto. Qed. Lemma NoSelfCallBaseModule_TraceHide f (m : BaseModuleWf type) o ls : NoSelfCallBaseModule m -> Trace (HideMeth m f) o ls -> Trace (removeMeth m f) o ls. Proof. intros. eapply Trace_HideMeth_removeMeth_noCalls; eauto. - constructor; apply wfBaseModule. - eapply NoSelfCallBaseModule_Trace; eauto. eapply TraceHide_Trace; eauto. Qed. Lemma SubstepsRemove_Substeps m o s l : Substeps (removeMeth m s) o l -> Substeps m o l. Proof. induction 1. - econstructor 1; eauto. - rewrite HLabel; econstructor 2; eauto. - rewrite HLabel; econstructor 3; eauto. simpl in HInMeths. rewrite filter_In in HInMeths; inv HInMeths; auto. Qed. Lemma StepRemove_Step m o s l : (forall v, In (s, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (s, v) l = 0%Z) -> Step (removeMeth m s) o l -> Step m o l. Proof. intros; inv H0. econstructor; eauto using SubstepsRemove_Substeps. intros f P1. destruct f; simpl in *. destruct (string_dec s s0); subst. - rewrite H; eauto. apply getNumExecs_nonneg. - assert (In (s0, projT1 s1) (getKindAttr (getMethods (removeMeth m s)))). { simpl; rewrite in_map_iff in *; dest. inv H0. exists x; split; auto. rewrite filter_In; split; auto. destruct String.eqb eqn:G; simpl; auto. exfalso; apply n. rewrite <- String.eqb_eq; congruence. } apply HMatching; simpl; auto. Qed. Lemma TraceRemove_Trace m o s ls : (forall l, In l ls -> forall v, In (s, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (s, v) l = 0%Z) -> Trace (removeMeth m s) o ls -> Trace m o ls. Proof. intros. induction H0; subst. - econstructor 1; eauto. - econstructor 2; eauto. + apply IHTrace. intros; apply H; auto. right; assumption. + eapply (StepRemove_Step); eauto. eapply H. left; reflexivity. Qed. Lemma Substeps_NoSelfCallBaseModule_Remove m o s l : NoSelfCallBaseModule m -> Substeps (removeMeth m s) o l -> (forall v, In (s, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (s, v) l = 0%Z). Proof. intros. apply SubstepsRemove_Substeps in H0. eapply NoSelfCallBaseModule_Substeps; eauto. Qed. Lemma Step_NoSelfCallBaseModule_Remove m o s l : NoSelfCallBaseModule m -> Step (removeMeth m s) o l -> (forall v, In (s, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (s, v) l = 0%Z). Proof. intros. inv H0. eapply Substeps_NoSelfCallBaseModule_Remove; eauto. Qed. Lemma Trace_NoSelfCallBaseModule_Remove m o s ls : NoSelfCallBaseModule m -> Trace (removeMeth m s) o ls -> (forall l, In l ls -> forall v, In (s, projT1 v) (getKindAttr (getMethods m)) -> getNumCalls (s, v) l = 0%Z). Proof. intros. induction H0; subst; destruct H1; subst. - eapply Step_NoSelfCallBaseModule_Remove; eauto. - apply IHTrace; auto. Qed. Lemma Trace_NoSelfCallBaseModule_Remove_Hide m o s ls : In s (map fst (getMethods m)) -> NoSelfCallBaseModule m -> Trace (removeMeth m s) o ls -> Trace (HideMeth m s) o ls. Proof. intros. apply Trace_TraceHide. - eapply TraceRemove_Trace; eauto. eapply Trace_NoSelfCallBaseModule_Remove; eauto. - intros; unfold getListFullLabel_diff. rewrite (Trace_NoSelfCallBaseModule_Remove H0 H1 _ H2 v); auto. specialize (In_nth_error _ _ H2) as P1. destruct P1 as [n P2]. erewrite (NotInDef_ZeroExecs_Trace); simpl; auto. + apply H1. + simpl; intro P1. rewrite in_map_iff in P1. inv P1; inv H4. rewrite filter_In in H6; inv H6. rewrite String.eqb_refl in H5; discriminate. + apply P2. Qed. Lemma removeMeth_removeHides m f : (getMethods (removeMeth m f)) = (getMethods (removeHides m [f])). Proof. simpl. induction (getMethods m). simpl; auto. simpl. rewrite IHl. rewrite (String.eqb_sym). rewrite orb_false_r. reflexivity. Qed. Lemma removeHides_cons m f l: (getMethods (removeHides m (f::l))) = (getMethods (removeHides (removeHides m l) [f])). Proof. simpl. induction (getMethods m); simpl; auto. destruct String.eqb eqn:G; [rewrite String.eqb_eq in G|]; subst; simpl; repeat rewrite IHl0; simpl; destruct (existsb (String.eqb (fst a)) l) eqn:G1; simpl in *; auto. - rewrite String.eqb_refl; simpl; reflexivity. - rewrite G; simpl; reflexivity. Qed. Lemma removeMeth_removeHides_cons m f l: (getMethods (removeHides m (f::l)) = (getMethods (removeMeth (removeHides m l) f))). Proof. rewrite removeHides_cons, removeMeth_removeHides; reflexivity. Qed. Lemma removeHidesWfActionT ty (m : BaseModule)(k : Kind) (a : ActionT ty k) (l : list string): WfActionT (getRegisters m) a -> WfActionT (getRegisters (removeHides m l)) a. Proof. induction 1; econstructor; eauto. Qed. Lemma NoDup_filtered_keys {B : Type} (l : list (string*B)) (f : (string*B) -> bool): NoDup (map fst l) -> NoDup (map fst (filter f l)). Proof. induction l; intros; auto. inv H; simpl; destruct (f a); eauto. simpl; constructor; eauto. intro; apply H2. rewrite in_map_iff in *. destruct H; destruct H; subst. rewrite filter_In in H0; destruct H0. eauto. Qed. Lemma removeHidesWf ty (m : BaseModule) (l : list string): WfBaseModule ty m -> WfBaseModule ty (removeHides m l). Proof. intros. inv H; inv H1; inv H2; inv H3. repeat split; intros; auto. - simpl in H3. rewrite (filter_In) in H3; inv H3. specialize (H _ H5 v). apply removeHidesWfActionT; auto. - simpl. apply NoDup_filtered_keys; auto. Qed. Lemma removeHidesWf_new ty (m : BaseModule) (l : list string): WfBaseModule_new ty m -> WfBaseModule_new ty (removeHides m l). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply removeHidesWf. Qed. Lemma removeMethWf ty (m : BaseModule) (f : string) : WfBaseModule ty m -> WfBaseModule ty (removeMeth m f). Proof. intros. specialize (WfMod_WfBaseMod_flat (BaseWf (removeHidesWf [f] H))) as P1. unfold getFlat in P1. assert (getAllMethods (removeHides m [f]) = getMethods (removeHides m [f])) as P2; auto. rewrite P2 in P1. rewrite <- removeMeth_removeHides in P1. unfold removeMeth; simpl in P1; assumption. Qed. Lemma removeMethWf_new ty (m : BaseModule) (f : string) : WfBaseModule_new ty m -> WfBaseModule_new ty (removeMeth m f). Proof. repeat rewrite <- WfBaseModule_WfBaseModule_new_iff. apply removeMethWf. Qed. Definition removeHides_ModWf {ty} (m : BaseModuleWf ty) (l : list string) := Build_BaseModuleWf (removeHidesWf l (wfBaseModule m)). Definition removeHides_ModWf_new {ty} (m : BaseModuleWf_new ty) (l : list string) := Build_BaseModuleWf_new (removeHidesWf_new l (wfBaseModule_new m)). Lemma WfMod_createHide1 ty (m : BaseModuleWf ty) (l : list string) (subList : SubList l (map fst (getMethods m))): WfMod ty (createHide m l). Proof. rewrite WfMod_createHide; split; auto. apply (BaseWf (wfBaseModule m)). Qed. Lemma WfMod_createHide1_new ty (m : BaseModuleWf_new ty) (l : list string) (subList : SubList l (map fst (getMethods m))): WfMod_new ty (createHide m l). Proof. apply WfMod_WfMod_new. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (WfMod_createHide1 m'); auto. Qed. Definition createHide_ModWf {ty} (m : BaseModuleWf ty) (l : list string) (subList : SubList l (map fst (getMethods m))) := (Build_ModWf (WfMod_createHide1 m subList)). Definition createHide_ModWf_new {ty} (m : BaseModuleWf_new ty) (l : list string) (subList : SubList l (map fst (getMethods m))) := (Build_ModWf_new _ _ (WfMod_createHide1_new m subList)). Lemma HideMeth_removeMeth_TraceInclusion (m : BaseModuleWf type) (f : string): NoSelfCallBaseModule m -> TraceInclusion (HideMeth m f) (removeMeth m f). Proof. repeat intro. exists o1, ls1; repeat split; auto. apply NoSelfCallBaseModule_TraceHide; auto. apply (WeakInclusions_WeakInclusion (WeakInclusionsRefl ls1)). Qed. Lemma removeMeth_HideMeth_TraceInclusion (m : BaseModuleWf type) (f : string): NoSelfCallBaseModule m -> In f (map fst (getMethods m)) -> TraceInclusion (removeMeth m f) (HideMeth m f). Proof. repeat intro. exists o1, ls1; repeat split. - apply Trace_NoSelfCallBaseModule_Remove_Hide; auto. - apply WeakInclusions_WeakInclusion; apply WeakInclusionsRefl. Qed. Lemma NoSelfCallBaseModule_removeHides (m : BaseModule) (l : list string) : NoSelfCallBaseModule m -> NoSelfCallBaseModule (removeHides m l). Proof. unfold NoSelfCallBaseModule; intros; inv H; split. - repeat intro. specialize (H0 _ ty H). induction H0; econstructor; eauto. simpl; intro. apply H0. rewrite in_map_iff in *; inv H4; inv H5. rewrite filter_In in H6; inv H6. exists x; auto. - repeat intro. simpl in *; rewrite filter_In in H; inv H. specialize (H1 _ ty H2 arg). induction H1; econstructor; eauto. intro; apply H. rewrite in_map_iff in *; inv H5; inv H6. rewrite filter_In in H7; inv H7. exists x; auto. Qed. Lemma NoSelfCallBaseModule_removeMeth (m : BaseModule) (f : string) : NoSelfCallBaseModule m -> NoSelfCallBaseModule (removeMeth m f). Proof. intros; inv H. split; repeat intro. - specialize (H0 _ ty H). induction H0; econstructor; eauto. intro; apply H0. rewrite in_map_iff in *. inv H4; inv H5. exists x; split; auto. simpl in H6; rewrite filter_In in H6; inv H6. destruct String.eqb; simpl in *;[discriminate|auto]. - assert (In meth (getMethods m)). + simpl in *; rewrite filter_In in H; inv H; auto. + specialize (H1 _ ty H2 arg). induction H1; econstructor; eauto. intro; apply H1. rewrite in_map_iff in *; inv H5; inv H6. exists x; split; auto. simpl in *; rewrite filter_In in H7. inv H7; auto. Qed. Lemma removeHides_removeMeth_TraceInclusion m l a : TraceInclusion (removeMeth (@removeHides_ModWf type m l) a) (removeHides_ModWf m (a::l)). Proof. specialize (TraceInclusion_flatten_r (Build_ModWf (BaseWf (removeMethWf a (wfBaseModule (removeHides_ModWf m l)))))) as P1. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (removeMeth_removeHides_cons m a l) as P2; simpl in *. rewrite <- P2 in P1. unfold removeMeth, removeHides in *; simpl in *. assumption. Qed. Lemma removeMeth_removeHides_TraceInclusion m l a : TraceInclusion (@removeHides_ModWf type m (a::l)) (removeMeth (removeHides_ModWf m l) a). Proof. specialize (TraceInclusion_flatten_l (Build_ModWf (BaseWf (removeMethWf a (wfBaseModule (removeHides_ModWf m l)))))) as P1. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (removeMeth_removeHides_cons m a l) as P2; simpl in *. rewrite <- P2 in P1. unfold removeMeth, removeHides in *; simpl in *. assumption. Qed. Lemma createHide_Step_In m l a o ls: In a l -> Step (createHide m l) o ls -> (forall v, In (a, projT1 v) (getKindAttr (getAllMethods m)) -> getListFullLabel_diff (a, v) ls = 0%Z). Proof. induction l; simpl; [tauto|]. intros. destruct H; subst; inv H0; auto. apply HHidden. rewrite createHide_Meths; assumption. Qed. Lemma createHide_idempotent m l a : In a l -> TraceInclusion (createHide m l) (HideMeth (createHide m l) a). Proof. repeat intro. exists o1, ls1. repeat split; auto. - induction H0; subst. + econstructor; eauto. + econstructor 2; eauto. econstructor 2; eauto. intros; eapply createHide_Step_In. * apply H. * apply HStep. * rewrite createHide_Meths in H1; simpl in *; auto. - apply WeakInclusions_WeakInclusion; apply WeakInclusionsRefl. Qed. Lemma removeMeth_removeHides_cons_In m f l: In f l -> getMethods (removeHides m l) = getMethods (removeMeth (removeHides m l) f). Proof. intros; simpl. induction (getMethods m); simpl; auto. - destruct existsb eqn:G; simpl; auto. destruct String.eqb eqn:G1; [rewrite String.eqb_eq in G1|]; subst; simpl. rewrite existsb_nexists_str in G; contradiction. rewrite IHl0 at 1; reflexivity. Qed. Lemma removeMeth_idempotent ty (m : BaseModuleWf ty) l a : In a l -> (removeHides m l) = (removeMeth (removeHides m l) a). Proof. intros. specialize (removeMeth_removeHides_cons_In m _ _ H) as P1. unfold removeHides, removeMeth in *; simpl in *; rewrite P1 at 1. reflexivity. Qed. Lemma removeHides_createHide_TraceInclusion (m : BaseModuleWf type) (l : list string) (subList : SubList l (map fst (getMethods m))): NoSelfCallBaseModule m -> TraceInclusion (removeHides_ModWf m l) (createHide_ModWf m subList). Proof. induction l; simpl; intros. - unfold removeHides; simpl. rewrite filter_true_list; simpl; auto. specialize (TraceInclusion_flatten_l m) as P1. simpl in *; unfold flatten, getFlat in *; simpl in *. assumption. - specialize (removeMeth_removeHides_TraceInclusion (m:=m) (l:=l) (a:=a)) as P1. assert (SubList l (map fst (getMethods m))) as P2;[repeat intro; apply (subList x (in_cons a _ _ H0))|]. specialize (TraceInclusion_TraceInclusion' (IHl P2 H)) as P3. specialize (TraceInclusion'_TraceInclusion (TraceInclusion'_HideMeth P3 (s:=a))) as P4; clear P3. destruct (in_dec string_dec a l). + specialize (createHide_idempotent m _ _ i) as P5. simpl in P1. rewrite <- removeMeth_idempotent in P1; auto. specialize (IHl P2 H). eauto using TraceInclusion_trans. + assert (In a (map fst (getMethods (removeHides_ModWf m l)))) as P5. * simpl; rewrite in_map_iff. specialize (subList _ (in_eq _ _)). rewrite in_map_iff in subList. inv subList; inv H0. exists x; split; auto. rewrite filter_In; split; auto. destruct existsb eqn:G; simpl; auto. rewrite existsb_exists in G; dest. rewrite String.eqb_eq in H1; congruence. * specialize (removeMeth_HideMeth_TraceInclusion (removeHides_ModWf m l) (NoSelfCallBaseModule_removeHides l H) (f:= a) P5) as P6. eauto using TraceInclusion_trans. Qed. Theorem removeHides_createHide_TraceInclusion_new (m : BaseModuleWf_new type) (l : list string) (subList : SubList l (map fst (getMethods m))): NoSelfCallBaseModule m -> TraceInclusion (removeHides_ModWf_new m l) (createHide_ModWf_new m subList). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@removeHides_createHide_TraceInclusion m'). Unshelve. auto. Qed. Lemma createHide_removeHides_TraceInclusion (m : BaseModuleWf type) (l : list string) (subList : SubList l (map fst (getMethods m))): NoSelfCallBaseModule m -> TraceInclusion (createHide_ModWf m subList) (removeHides_ModWf m l). Proof. induction l; simpl; intros. - unfold removeHides; simpl. rewrite filter_true_list; simpl; auto. specialize (TraceInclusion_flatten_r m) as P1. simpl in *; unfold flatten, getFlat in *; simpl in *. apply P1. - specialize (SubList_cons subList) as P0; inv P0. specialize (TraceInclusion_TraceInclusion' (IHl H1 H)) as P1. specialize (TraceInclusion'_TraceInclusion (TraceInclusion'_HideMeth P1 (s:= a))) as P2; clear P1. specialize (HideMeth_removeMeth_TraceInclusion (removeHides_ModWf m l) (f:=a) (NoSelfCallBaseModule_removeHides l H)) as P1. specialize (removeHides_removeMeth_TraceInclusion) as P3; specialize (P3 m l a). eauto using TraceInclusion_trans. Qed. Theorem createHide_removeHides_TraceInclusion_new (m : BaseModuleWf_new type) (l : list string) (subList : SubList l (map fst (getMethods m))): NoSelfCallBaseModule m -> TraceInclusion (createHide_ModWf_new m subList) (removeHides_ModWf_new m l). Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@createHide_removeHides_TraceInclusion m'). Unshelve. auto. Qed. Lemma flatten_inline_remove_TraceInclusion_r_lemma (m : ModWf type) : NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_everything m) (flatten_inline_remove_ModWf m). Proof. simpl; unfold flatten_inline_everything, flatten_inline_remove. intros. specialize (WfMod_WfBase_getFlat (wfMod m)) as P1; unfold getFlat in *. specialize (TraceInclusion_inlineAll_pos P1) as P2; inv P2. inv H0. assert (SubList (getHidden m) (map fst (getAllMethods m))) as P2; [repeat intro; apply (WfMod_Hidden (wfMod m) _ H0)|]. specialize (createHide_removeHides_TraceInclusion (Build_BaseModuleWf HWfBaseModule) (l := (getHidden m))) as P3; simpl in *. rewrite <- SameKeys_inlineAll_Meths in P3. apply (P3 P2); eauto. Qed. Theorem flatten_inline_remove_TraceInclusion_r_lemma_new (m : ModWf_new type) : NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_everything m) (flatten_inline_remove_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (@flatten_inline_remove_TraceInclusion_r_lemma m'). Qed. Lemma PSemAction_meth_collector_stitch f o readRegs1 newRegs1 calls1 calls2: PSemAction_meth_collector f o readRegs1 newRegs1 calls1 calls2 -> forall readRegs2 newRegs2 calls3 calls4, DisjKey newRegs1 newRegs2 -> PSemAction_meth_collector f o readRegs2 newRegs2 calls3 calls4 -> PSemAction_meth_collector f o (readRegs1++readRegs2) (newRegs1++newRegs2) (calls1++calls3) (calls2++calls4). Proof. induction 1; simpl; auto; intros. rewrite H4. econstructor. - apply IHPSemAction_meth_collector; auto. + assert (DisjKey upds1 newRegs2) as P1;[|apply P1]. rewrite H2 in H6; intro k; specialize (H6 k). clear - H6; rewrite map_app, in_app_iff in *; firstorder. + apply H7. - assert (DisjKey (upds1++newRegs2) upds2) as P1;[|apply P1]. rewrite H2 in H6; intro k; specialize (H6 k); specialize (H0 k). clear - H0 H6; rewrite map_app, in_app_iff in *; firstorder. - rewrite H1; repeat rewrite <- app_assoc. apply Permutation_app_head, Permutation_app_comm. - rewrite H2; repeat rewrite <- app_assoc. apply Permutation_app_head, Permutation_app_comm. - rewrite H3; repeat rewrite <- app_assoc. apply Permutation_app_head, Permutation_app_comm. - simpl; reflexivity. - assumption. Qed. Lemma PSemAction_In_inline (f : DefMethT) o: forall {retK2} a readRegs newRegs calls (retV2 : type retK2), PSemAction o (inlineSingle a f) readRegs newRegs calls retV2 -> exists readRegs1 readRegs2 newRegs1 newRegs2 calls1 calls2 calls3, DisjKey newRegs1 newRegs2 /\ readRegs [=] readRegs1++readRegs2 /\ newRegs [=] newRegs1++newRegs2 /\ calls [=] calls1++calls2 /\ PSemAction_meth_collector f o readRegs1 newRegs1 calls1 calls3 /\ PSemAction o a readRegs2 newRegs2 (calls3++calls2) retV2. Proof. intros retK2 a. induction a; subst; simpl in *; intros. - destruct String.eqb eqn:G;[destruct Signature_dec|]; subst; simpl in *. + inv H0; EqDep_subst. inv HPSemAction; EqDep_subst. specialize (H _ _ _ _ _ HPSemActionCont); dest. exists (readRegs0++x), x0, (newRegs0++x1), x2, (calls0++x3), x4, (((fst f),(existT SignT (projT1 (snd f)) (evalExpr e, v)))::x5). repeat split; auto. * intro k; clear - H HDisjRegs H1; rewrite H1 in *; specialize (H k); specialize (HDisjRegs k). rewrite map_app, in_app_iff in *; firstorder. * clear -H0 HUReadRegs. rewrite H0, app_assoc in *; assumption. * clear -H1 HUNewRegs. rewrite H1, app_assoc in *; assumption. * clear -H2 HUCalls. rewrite H2, app_assoc in *; assumption. * econstructor 2. -- eapply H3. -- rewrite H1 in HDisjRegs. assert (DisjKey x1 newRegs0) as P1; [intro k; specialize (HDisjRegs k); rewrite map_app, in_app_iff in *; clear - HDisjRegs; firstorder| apply P1]. -- apply Permutation_app_comm. -- apply Permutation_app_comm. -- apply Permutation_app_comm. -- reflexivity. -- assumption. * econstructor; eauto. rewrite String.eqb_eq in G; rewrite G; auto. + inv H0; EqDep_subst. specialize (H _ _ _ _ _ HPSemAction); dest. exists x, x0, x1, x2, x3, ((fst f, existT SignT s (evalExpr e, mret))::x4), x5. repeat split; auto. * rewrite Permutation_app_comm; simpl. rewrite H2 in HAcalls. rewrite HAcalls. rewrite String.eqb_eq in G; rewrite G. constructor; apply Permutation_app_comm. * apply (PSemAction_rewrite_calls (Permutation_app_comm _ _)). apply (PSemAction_rewrite_calls (Permutation_app_comm _ _)) in H4; simpl in *. rewrite String.eqb_eq in G; rewrite G. econstructor; eauto. + inv H0; EqDep_subst. specialize (H _ _ _ _ _ HPSemAction); dest. exists x, x0, x1, x2, x3, ((meth, existT SignT s (evalExpr e, mret)) ::x4), x5. repeat split; auto. * rewrite Permutation_app_comm; simpl; rewrite HAcalls. constructor; rewrite H2. apply Permutation_app_comm. * apply (PSemAction_rewrite_calls (Permutation_app_comm _ _)). apply (PSemAction_rewrite_calls (Permutation_app_comm _ _)) in H4; simpl in *. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HPSemAction); dest. exists x, x0, x1, x2, x3, x4, x5; repeat split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HPSemActionCont); dest. specialize (IHa _ _ _ _ HPSemAction); dest. exists (x++x6), (x0++x7), (x1++x8), (x2++x9), (x3++x10), (x4++x11), (x5++x12). repeat split; auto. + rewrite H7, H1 in HDisjRegs. clear - H H5 HDisjRegs. intro k; specialize (H k); specialize (H5 k); specialize (HDisjRegs k). repeat rewrite map_app, in_app_iff in *; firstorder. + rewrite HUReadRegs, H6, H0; simpl. rewrite Permutation_app_comm. repeat rewrite app_assoc. apply Permutation_app_tail. repeat rewrite <- app_assoc. apply Permutation_app_head. apply Permutation_app_comm. + rewrite HUNewRegs, H7, H1. rewrite Permutation_app_comm. repeat rewrite app_assoc. apply Permutation_app_tail. repeat rewrite <- app_assoc. apply Permutation_app_head. apply Permutation_app_comm. + rewrite HUCalls, H8, H2. rewrite Permutation_app_comm. repeat rewrite app_assoc. apply Permutation_app_tail. repeat rewrite <- app_assoc. apply Permutation_app_head. apply Permutation_app_comm. + eapply PSemAction_meth_collector_stitch; eauto. rewrite H7, H1 in HDisjRegs. intro k0; specialize (HDisjRegs k0); clear - HDisjRegs. repeat rewrite map_app, in_app_iff in *. firstorder. + econstructor. * assert (DisjKey x9 x2) as P1;[|apply P1]. rewrite H7, H1 in HDisjRegs; clear -HDisjRegs; intro k; specialize (HDisjRegs k). repeat rewrite map_app, in_app_iff in *; firstorder. * apply H10. * apply Permutation_app_comm. * apply Permutation_app_comm. * assert ((x5 ++ x12) ++ x4 ++ x11 [=] (x12++x11)++(x4++x5)) as P1;[|apply P1]. repeat rewrite <- app_assoc; rewrite Permutation_app_comm. repeat rewrite app_assoc. apply Permutation_app_tail. repeat rewrite <- app_assoc. apply Permutation_app_head, Permutation_app_comm. * apply (PSemAction_rewrite_calls (Permutation_app_comm _ _)); assumption. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HPSemAction); dest. exists x, x0, x1, x2, x3, x4, x5. repeat split; auto. econstructor; eauto. - inv H0; EqDep_subst. specialize (H _ _ _ _ _ HPSemAction); dest. exists x, ((r, existT (fullType type) k regV) ::x0), x1, x2, x3, x4, x5. repeat split; eauto. + rewrite HNewReads, H0; simpl; apply Permutation_middle. + econstructor; eauto. - inv H; EqDep_subst. specialize (IHa _ _ _ _ HPSemAction); dest. exists x, x0, x1, ((r, existT (fullType type) k (evalExpr e))::x2), x3, x4, x5. repeat split; eauto. + rewrite key_not_In_fst in HDisjRegs; rewrite H1, map_app, in_app_iff in HDisjRegs. clear - HDisjRegs H. intro k0; specialize (H k0); simpl. destruct (string_dec r k0); subst; simpl in *; firstorder. + rewrite HANewRegs, H1; simpl; apply Permutation_middle. + econstructor; auto. clear - H1 HDisjRegs. rewrite key_not_In_fst, H1, map_app, in_app_iff in *; firstorder. - inv H0; EqDep_subst. + specialize (IHa1 _ _ _ _ HAction); dest. specialize (H _ _ _ _ _ HPSemAction); dest. rewrite H2, H7 in HDisjRegs. exists (x++x6), (x0++x7), (x1++x8), (x2++x9), (x3++x10), (x4++x11), (x5++x12). repeat split; auto. * clear - HDisjRegs H0 H. intro k0; specialize (HDisjRegs k0); specialize (H0 k0); specialize (H k0). repeat rewrite map_app, in_app_iff in *; firstorder. * rewrite HUReadRegs, H1, H6. repeat rewrite app_assoc; apply Permutation_app_tail. repeat rewrite <- app_assoc; apply Permutation_app_head, Permutation_app_comm. * rewrite HUNewRegs, H2, H7. repeat rewrite app_assoc; apply Permutation_app_tail. repeat rewrite <- app_assoc; apply Permutation_app_head, Permutation_app_comm. * rewrite HUCalls, H3, H8. repeat rewrite app_assoc; apply Permutation_app_tail. repeat rewrite <- app_assoc; apply Permutation_app_head, Permutation_app_comm. * apply PSemAction_meth_collector_stitch; auto. clear - HDisjRegs. intro k; specialize (HDisjRegs k); repeat rewrite map_app, in_app_iff in *; firstorder. * econstructor. -- assert (DisjKey x2 x9) as P1;[|apply P1]. clear - HDisjRegs; intro k; specialize (HDisjRegs k). repeat rewrite map_app, in_app_iff in *; firstorder. -- assumption. -- apply H5. -- apply H10. -- reflexivity. -- reflexivity. -- repeat rewrite <- app_assoc. apply Permutation_app_head. repeat rewrite app_assoc. apply Permutation_app_tail, Permutation_app_comm. + specialize (IHa2 _ _ _ _ HAction); dest. specialize (H _ _ _ _ _ HPSemAction); dest. rewrite H2, H7 in HDisjRegs. exists (x++x6), (x0++x7), (x1++x8), (x2++x9), (x3++x10), (x4++x11), (x5++x12). repeat split; auto. * clear - HDisjRegs H0 H. intro k0; specialize (HDisjRegs k0); specialize (H0 k0); specialize (H k0). repeat rewrite map_app, in_app_iff in *; firstorder. * rewrite HUReadRegs, H1, H6. repeat rewrite app_assoc; apply Permutation_app_tail. repeat rewrite <- app_assoc; apply Permutation_app_head, Permutation_app_comm. * rewrite HUNewRegs, H2, H7. repeat rewrite app_assoc; apply Permutation_app_tail. repeat rewrite <- app_assoc; apply Permutation_app_head, Permutation_app_comm. * rewrite HUCalls, H3, H8. repeat rewrite app_assoc; apply Permutation_app_tail. repeat rewrite <- app_assoc; apply Permutation_app_head, Permutation_app_comm. * apply PSemAction_meth_collector_stitch; auto. clear - HDisjRegs. intro k; specialize (HDisjRegs k); repeat rewrite map_app, in_app_iff in *; firstorder. * econstructor 8. -- assert (DisjKey x2 x9) as P1;[|apply P1]. clear - HDisjRegs; intro k; specialize (HDisjRegs k). repeat rewrite map_app, in_app_iff in *; firstorder. -- assumption. -- apply H5. -- apply H10. -- reflexivity. -- reflexivity. -- repeat rewrite <- app_assoc. apply Permutation_app_head. repeat rewrite app_assoc. apply Permutation_app_tail, Permutation_app_comm. - inv H; EqDep_subst. specialize (IHa _ _ _ _ HPSemAction); dest. exists x, x0, x1, x2, x3, x4, x5; repeat split; auto. econstructor; eauto. - inv H; EqDep_subst. exists nil, nil, nil, nil, nil, nil, nil; simpl; repeat split; auto. + intro; simpl; tauto. + constructor. + constructor; auto. Qed. Lemma inlineSingle_Rule_in_list_notKey rn0 rn rb f l: rn <> rn0 -> In (rn0, rb) (inlineSingle_Rule_in_list f rn l) -> In (rn0, rb) l. Proof. induction l; intros; simpl in *; auto. destruct String.eqb eqn:G, a; simpl in *; subst. - destruct H0. + rewrite String.eqb_eq in G; inversion H0; congruence. + right; apply IHl; auto. - destruct H0; auto. Qed. Lemma PPlusSubsteps_PPlusSubsteps_inline_Rule_NoExec f m o rn upds execs calls : NoDup (map fst (getRules m)) -> ~In (Rle rn) execs -> PPlusSubsteps (inlineSingle_Rule_BaseModule f rn m) o upds execs calls -> PPlusSubsteps m o upds execs calls. Proof. induction 3; simpl in *. - econstructor 1; eauto. - rewrite HUpds, HExecs, HCalls. econstructor 2; eauto. + assert (rn <> rn0);[intro; subst; apply H0; rewrite HExecs; left; reflexivity|]. eapply inlineSingle_Rule_in_list_notKey; eauto. + apply IHPPlusSubsteps. intro; apply H0; rewrite HExecs; right; auto. - rewrite HUpds, HExecs, HCalls. econstructor 3; eauto. apply IHPPlusSubsteps. intro; apply H0; rewrite HExecs; right; auto. Qed. Lemma Rle_injective rn rn0 : Rle rn = Rle rn0 <-> rn = rn0. Proof. split; intro; subst; auto; inv H; auto. Qed. Lemma PPlus_inlineSingle_BaseModule_with_action f m o rn rb upds execs calls: PPlusSubsteps (inlineSingle_Rule_BaseModule f rn m) o upds ((Rle rn)::execs) calls -> In (rn, rb) (getRules m) -> In f (getMethods m) -> NoDup (map fst (getMethods m)) -> NoDup (map fst (getRules m)) -> exists upds1 upds2 calls1 calls2 reads, upds [=] upds1++upds2 /\ calls [=] calls1++calls2 /\ DisjKey upds2 upds1 /\ SubList (getKindAttr reads) (getKindAttr (getRegisters m)) /\ SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) /\ PSemAction o (inlineSingle (rb type) f) reads upds1 calls1 WO /\ PPlusSubsteps m o upds2 execs calls2. Proof. intros. rewrite (inlineSingle_Rule_preserves_names f rn) in H3. apply (inlineSingle_Rule_BaseModule_dec2 f) in H0; dest. eapply (ExtractRuleAction) in H; simpl in *; eauto; dest. simpl in *. exists x1, x2, x3, x4, x; repeat split; auto. - rewrite unique_word_0 in H; assumption. - apply Permutation_cons_inv in H9. rewrite H9. rewrite <- (inlineSingle_Rule_preserves_names) in H3. apply (PPlusSubsteps_PPlusSubsteps_inline_Rule_NoExec (rn:=rn)(f:=f)); auto. Qed. Lemma place_execs_PPlus f m o reads upds1 calls1 fcalls : PSemAction_meth_collector f o reads upds1 calls1 fcalls -> NoDup (map fst (getMethods m)) -> In f (getMethods m) -> SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) -> SubList (getKindAttr reads) (getKindAttr (getRegisters m)) -> forall upds2 execs calls2, DisjKey upds1 upds2 -> PPlusSubsteps m o upds2 execs calls2 -> PPlusSubsteps m o (upds1++upds2) ((map Meth fcalls) ++ execs) (calls1++calls2). Proof. induction 1; simpl in *; auto. intros; destruct f; simpl in *. assert (upds ++ upds0 [=] upds2 ++ (upds1++upds0)) as P1; [rewrite H2, app_assoc; apply Permutation_app_tail, Permutation_app_comm |rewrite P1; clear P1]. assert (calls ++ calls0 [=] calls2 ++ (calls1++calls0)) as P1; [rewrite H3, app_assoc; apply Permutation_app_tail, Permutation_app_comm |rewrite P1; clear P1]. rewrite H4; simpl. assert (SubList (getKindAttr upds1) (getKindAttr (getRegisters m))) as P2; [repeat intro; apply H8; rewrite H2, map_app, in_app_iff; left; auto|]. assert (SubList (getKindAttr reads1) (getKindAttr (getRegisters m))) as P3; [repeat intro; apply H9; rewrite H1, map_app, in_app_iff; left; auto|]. assert (DisjKey upds1 upds0) as P4; [intro k; specialize (H10 k); rewrite H2, map_app, in_app_iff in H10; clear - H10; tauto|]. specialize (IHPSemAction_meth_collector H6 H7 P2 P3 _ _ _ P4 H11). econstructor 3; eauto. - inv H11; auto. - repeat intro; apply H9. rewrite H1, map_app, in_app_iff; auto. - repeat intro; apply H8. rewrite H2, map_app, in_app_iff; auto. - rewrite H2 in H10. clear - H0 H10. intro k; specialize (H0 k); specialize (H10 k). rewrite map_app, in_app_iff in *; tauto. Qed. Lemma MatchingExecCalls_Base_add_fcalls m calls fcalls execs : MatchingExecCalls_flat calls execs m -> MatchingExecCalls_flat (fcalls++calls) ((map Meth fcalls)++execs) m. Proof. induction fcalls; simpl; auto; intros. specialize (IHfcalls H); clear H. unfold MatchingExecCalls_flat in *; intros; specialize (IHfcalls _ H). destruct (MethT_dec f a);[rewrite getNumFromCalls_eq_cons, getNumFromExecs_eq_cons |rewrite getNumFromCalls_neq_cons, getNumFromExecs_neq_cons]; auto. omega. Qed. Lemma InRule_In_inlined_neq2 f rn1 rn2 rb m: rn1 <> rn2 -> In (rn2, rb) (getRules (inlineSingle_Rule_BaseModule f rn1 m)) -> In (rn2, rb) (getRules m). Proof. simpl. apply inlineSingle_Rule_in_list_notKey. Qed. Lemma PPlusStep_NotIn_inline_Rule f m o rn upds execs calls : NoDup (map fst (getRules m)) -> In f (getMethods m) -> ~In (Rle rn) execs -> PPlusStep (inlineSingle_Rule_BaseModule f rn m) o upds execs calls -> PPlusStep m o upds execs calls. Proof. induction 4; econstructor. - induction H2. + econstructor 1; auto. + rewrite HUpds, HExecs, HCalls. econstructor 2; eauto. * eapply InRule_In_inlined_neq2; eauto. intro; subst; apply H1; rewrite HExecs; left; reflexivity. * eapply PPlusSubsteps_PPlusSubsteps_inline_Rule_NoExec; eauto. intro; apply H1; rewrite HExecs; right; assumption. + rewrite HUpds, HExecs, HCalls. econstructor 3; eauto. eapply PPlusSubsteps_PPlusSubsteps_inline_Rule_NoExec; eauto. intro; apply H1; rewrite HExecs; right; assumption. - intros g P1. apply H3; simpl; auto. Qed. Lemma PPlusSubsteps_undef_inline_Rule f m o rn upds execs calls: ~In rn (map fst (getRules m)) -> PPlusSubsteps (inlineSingle_Rule_BaseModule f rn m) o upds execs calls -> PPlusSubsteps m o upds execs calls. Proof. induction 2. - econstructor 1; eauto. - econstructor 2; eauto. apply InRule_In_inlined_neq2 in HInRules; auto. apply (in_map fst) in HInRules; simpl in *. rewrite <-inlineSingle_Rule_preserves_names in HInRules. intro; subst; contradiction. - econstructor 3; eauto. Qed. Lemma PPlusStep_undef_inline_Rule f m o rn upds execs calls: ~In rn (map fst (getRules m)) -> PPlusStep (inlineSingle_Rule_BaseModule f rn m) o upds execs calls -> PPlusStep m o upds execs calls. Proof. induction 2. econstructor. - eapply PPlusSubsteps_undef_inline_Rule; eauto. - apply H1. Qed. Lemma PPlusTrace_undef_inline_Rule f m rn l: ~In rn (map fst (getRules m)) -> forall o, PPlusTrace (inlineSingle_Rule_BaseModule f rn m) o l -> PPlusTrace m o l. Proof. induction l; subst. - intros; inv H0; simpl in *. + econstructor 1; eauto. + discriminate. - intros. inv H0;[discriminate|]. inv HPPlusTrace. econstructor 2; eauto. eapply PPlusStep_undef_inline_Rule; eauto. Qed. Lemma PPlusStep_In_inline_Rule f m o rn upds execs calls: In rn (map fst (getRules m)) -> In f (getMethods m) -> NoDup (map fst (getRules m)) -> NoDup (map fst (getMethods m)) -> In (Rle rn) execs -> PPlusStep (inlineSingle_Rule_BaseModule f rn m) o upds execs calls -> exists fcalls, PPlusStep m o upds ((map Meth fcalls)++execs) (fcalls++calls). Proof. induction 6. rewrite in_map_iff in H; destruct H as [x TMP]; destruct TMP as [fst_eq H]; destruct x; subst. specialize (in_split _ _ H3) as P1; dest. assert (execs [=] (Rle s)::(x++x0)) as P1;[rewrite H6; rewrite Permutation_middle; reflexivity | rewrite P1 in *]. specialize (PPlus_inlineSingle_BaseModule_with_action _ H4 H H0 H2 H1) as P2; dest. specialize (PSemAction_In_inline _ _ H12) as P2; dest. exists x12. econstructor. - assert (SubList (getKindAttr x6) (getKindAttr (getRegisters m))) as P2; [repeat intro; apply H10; rewrite H15, map_app, in_app_iff; auto|]. assert (SubList (getKindAttr x8) (getKindAttr (getRegisters m))) as P3; [repeat intro; apply H11; rewrite H16, map_app, in_app_iff; auto|]. assert (DisjKey x8 x2) as P4; [rewrite H16 in H9; clear - H9; intro k; specialize (H9 k); rewrite map_app, in_app_iff in *; firstorder|]. specialize (place_execs_PPlus H18 H2 H0 P3 P2 P4 H13) as P5. assert (map Meth x12 ++ execs [=] ((Rle s)::(map Meth x12 ++ x ++ x0))) as TMP; [simpl; rewrite P1; repeat rewrite Permutation_middle; apply Permutation_app_tail; auto |rewrite TMP; clear TMP]. assert (x12++calls [=] ((x12++x11)++(x10++x4))) as TMP; [rewrite H8, <- app_assoc; apply Permutation_app_head; rewrite app_assoc; apply Permutation_app_tail; rewrite H17; apply Permutation_app_comm |rewrite TMP; clear TMP]. assert (upds [=] (x9 ++(x8++x2))) as TMP; [rewrite H7, H16, app_assoc; apply Permutation_app_tail, Permutation_app_comm |rewrite TMP; clear TMP]. econstructor 2; eauto. + inv P5; auto. + repeat intro; apply H10; rewrite H15, map_app, in_app_iff; auto. + repeat intro; apply H11; rewrite H16, map_app, in_app_iff; auto. + rewrite H16 in H9; clear - H9 H14. intro k; specialize (H9 k); specialize (H14 k); rewrite map_app, in_app_iff in *; firstorder. + assert (NoDup (map fst (getRules (inlineSingle_Rule_BaseModule f s m)))) as P6; [simpl; rewrite <-inlineSingle_Rule_preserves_names; auto|]. assert (NoDup (map fst (getMethods (inlineSingle_Rule_BaseModule f s m)))) as P7; [auto|]. assert ((Rle s :: x ++ x0) [=] ([Rle s]++(x++x0))) as TMP; [auto|rewrite TMP in H4; clear TMP]. specialize (PPlusSubsteps_split_execs_OneRle P7 P6 _ _ H4). intros. rewrite in_app_iff in H21. destruct H21. * clear - H21. induction x12; simpl in *;[contradiction|destruct H21; subst; auto; apply IHx12; auto]. * assert (In (Rle s) [Rle s]) as P8;[left; reflexivity|]. specialize (H20 _ _ P8 H21); simpl in *; assumption. - apply MatchingExecCalls_Base_add_fcalls. intros f0 P2. apply H5; auto. Qed. Lemma PPlusStrongTraceInclusion_inlining_Rules_l m f rn : In f (getMethods m) -> (WfMod type (Base m)) -> StrongPPlusTraceInclusion (inlineSingle_Rule_BaseModule f rn m) m. Proof. unfold StrongPPlusTraceInclusion; induction 3; subst. - exists nil; split. + econstructor; eauto. + constructor. - dest. pose proof H0 as sth. specialize (H0). destruct (in_dec (RuleOrMeth_dec) (Rle rn) execs),(in_dec string_dec rn (map fst (getRules m))); inv H0. * destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. specialize (PPlusStep_In_inline_Rule i0 H NoDupRle NoDupMeths i HPPlusStep) as TMP; dest. exists ((upds, ((map Meth x0 ++ execs), (x0++calls)))::x); split. -- econstructor 2; eauto. -- constructor; auto. unfold WeakInclusion_flat, getListFullLabel_diff_flat. split; intros; simpl. ++ symmetry; rewrite getNumFromExecs_app, getNumFromCalls_app, (call_execs_counts_eq); omega. ++ simpl in *. destruct H6; exists x1; rewrite in_app_iff in *. destruct H6; auto. exfalso; clear -H6; induction x0; simpl in *; eauto. destruct H6;[discriminate|auto]. * exists ((upds, (execs, calls))::x); split. -- econstructor 2; eauto. eapply PPlusStep_undef_inline_Rule; eauto. -- econstructor; eauto. unfold WeakInclusion_flat; split; intros; auto. * exists ((upds, (execs, calls))::x); split. -- econstructor 2; eauto. eapply PPlusStep_NotIn_inline_Rule; eauto. inv HWfBaseModule; dest; auto. -- econstructor; eauto. unfold WeakInclusion_flat; split; intros; auto. * exists ((upds, (execs, calls))::x); split. -- econstructor 2; eauto. eapply (PPlusStep_NotIn_inline_Rule); eauto. inv HWfBaseModule; dest; auto. -- econstructor; eauto. unfold WeakInclusion_flat; split; intros; auto. Qed. Lemma TraceInclusion_inlining_Rules_l m f rn: In f (getMethods m) -> WfMod type m -> TraceInclusion (inlineSingle_Rule_BaseModule f rn m) m. Proof. intros. apply PPlusTraceInclusion_TraceInclusion; auto. - apply WfMod_Rule_inlined; auto. - apply StrongPPlusTraceInclusion_PPlusTraceInclusion. apply PPlusStrongTraceInclusion_inlining_Rules_l; auto. Qed. Theorem TraceInclusion_inlining_Rules_l_new m f rn: In f (getMethods m) -> WfMod_new type m -> TraceInclusion (inlineSingle_Rule_BaseModule f rn m) m. Proof. rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlining_Rules_l. Qed. Lemma TraceInclusion_inlining_Rules_Wf_l {f} {m : BaseModuleWf type} rn (inMeths: In f (getMethods m)): TraceInclusion (inlineSingle_Rule_BaseModuleWf rn inMeths) m. Proof. simpl; apply TraceInclusion_inlining_Rules_l; eauto. constructor; apply wfBaseModule. Qed. Theorem TraceInclusion_inlining_Rules_Wf_l_new {f} {m : BaseModuleWf_new type} rn (inMeths: In f (getMethods m)): TraceInclusion (inlineSingle_Rule_BaseModuleWf_new rn inMeths) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inlining_Rules_Wf_l f m'). Unshelve. exact inMeths. Qed. Lemma inlineSingle_Meth_in_list_body fb f gn l: (fst f) <> gn-> In (gn, fb) (inlineSingle_Meth_in_list f gn l) -> exists (fb' : {x : Signature & MethodT x}), (fb = existT (fun sig : Signature => forall ty : Kind -> Type, ty (fst sig) -> ActionT ty (snd sig)) (projT1 fb') (fun (ty : Kind -> Type) (X : ty (fst (projT1 fb'))) => inlineSingle ((projT2 fb') ty X) f)) /\ In (gn, fb') l. Proof. intros. induction l;[contradiction| destruct a]. simpl in H0; destruct String.eqb eqn:G. - destruct H0; subst; auto. + exists s0; simpl. destruct (String.eqb (fst f) s) eqn:G1; [elim H; rewrite String.eqb_eq in G,G1; congruence|simpl in *; inversion H0]. destruct fb; inv H0. split; auto. destruct s0; simpl in *; reflexivity. + specialize (IHl H0); dest. exists x; split; auto. right; assumption. - destruct H0;[exfalso;inv H0; rewrite String.eqb_neq in G; apply G; reflexivity|auto]. specialize (IHl H0); dest. exists x; split; auto. right; assumption. Qed. Lemma PPlus_uninline_meths f gn m o: (fst f) <> gn -> NoDup (map fst (getMethods m)) -> forall gexecs, (forall g, In g gexecs -> (fst g = gn)) -> forall upds calls, PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds (map Meth gexecs) calls -> exists upds1 upds2 calls1 calls2 fcalls reads, upds [=] upds1++upds2 /\ calls [=] calls1++calls2 /\ DisjKey upds2 upds1 /\ SubList (getKindAttr reads) (getKindAttr (getRegisters m)) /\ SubList (getKindAttr upds1) (getKindAttr (getRegisters m)) /\ PPlusSubsteps m o upds2 (map Meth gexecs) (fcalls++calls2) /\ PSemAction_meth_collector f o reads upds1 calls1 fcalls. Proof. induction gexecs. intros; inv H2. - exists nil, nil, nil, nil, nil, nil; simpl; repeat split; auto. + intro; simpl; auto. + repeat intro; simpl in *; contradiction. + repeat intro; simpl in *; contradiction. + constructor; auto. + constructor. - exfalso; simpl in *. apply Permutation_nil in HExecs. discriminate. - exfalso; simpl in *. apply Permutation_nil in HExecs. discriminate. - simpl in *; intros. inv H2. + exfalso. subst. specialize (in_eq (Rle rn) (oldExecs)) as P1; rewrite <-HExecs in P1. clear - P1; simpl in *. destruct P1;[discriminate|]. induction gexecs; simpl in *; auto. destruct H;[discriminate|auto]. + assert ((fn, existT _ (projT1 fb) (argV, retV)) = a \/ In (fn, existT _ (projT1 fb) (argV, retV)) gexecs) as P1; [specialize (in_eq (Meth (fn, existT _ (projT1 fb) (argV, retV))) oldExecs) as TMP; rewrite <- HExecs in TMP; destruct TMP as [TMP|TMP]; [inversion TMP; auto| rewrite in_map_iff in TMP; dest; inversion H2; subst; auto]|]. assert (forall g, In g gexecs -> fst g = gn) as P2;[intros; apply H1; auto|]. destruct P1 as [P1|P1]. * subst. apply Permutation_cons_inv in HExecs. rewrite <- HExecs in HPSubstep. specialize (IHgexecs P2 _ _ HPSubstep); dest. simpl in *. assert (fn = gn);[clear - H1; specialize (H1 _ (or_introl eq_refl)); auto|subst]. specialize (inlineSingle_Meth_in_list_body _ _ _ H HInMeths) as TMP; dest. destruct fb; inv H9; EqDep_subst; simpl in *. apply PSemAction_In_inline in HPAction; dest. exists (x++x8), (x9++x0), (x1++x10), (x2++x11), (x3++x12), (x4++x6). repeat split. -- rewrite HUpds, H2, H12; repeat rewrite app_assoc. apply Permutation_app_tail; rewrite Permutation_app_comm, app_assoc; reflexivity. -- rewrite HCalls, H3, H13, app_assoc; rewrite Permutation_app_comm. symmetry; rewrite Permutation_app_comm, <-app_assoc. apply Permutation_app_head. rewrite <-app_assoc, Permutation_app_comm, <-app_assoc, Permutation_app_comm, app_assoc. reflexivity. -- rewrite H2, H12 in HDisjRegs; intro k; specialize (HDisjRegs k); specialize (H9 k); specialize (H4 k); clear - HDisjRegs H9 H4. repeat rewrite map_app, in_app_iff in *; firstorder. -- rewrite H11, map_app in *; clear - HReadsGood H5; rewrite SubList_app_l_iff in *; firstorder. -- rewrite H12, map_app in *; clear - HUpdGood H6; rewrite SubList_app_l_iff in *; firstorder. -- assert ((x3++x12)++x2++x11 [=] (x12++x11)++(x3++x2)) as P3; [rewrite Permutation_app_comm, <-app_assoc; symmetry; rewrite app_assoc, Permutation_app_comm; apply Permutation_app_head; rewrite <-app_assoc; symmetry; rewrite app_assoc, Permutation_app_comm; reflexivity|rewrite P3]. econstructor 3; eauto. ++ rewrite H11 in HReadsGood; clear - HReadsGood; rewrite map_app, SubList_app_l_iff in *; firstorder. ++ rewrite H12 in HUpdGood; clear - HUpdGood; rewrite map_app, SubList_app_l_iff in *; firstorder. ++ rewrite H12, H2 in HDisjRegs; intro k; clear - HDisjRegs H9 H4; specialize (HDisjRegs k); specialize (H9 k); specialize (H4 k). repeat rewrite map_app, in_app_iff in *; firstorder. -- apply PSemAction_meth_collector_stitch; auto. rewrite H12, H2 in HDisjRegs; intro k; clear - HDisjRegs H9 H4; specialize (HDisjRegs k); specialize (H9 k); specialize (H4 k); repeat rewrite map_app, in_app_iff in *; firstorder. * specialize (in_split _ _ P1) as TMP; destruct TMP as [l1 [l2 TMP]]. rewrite TMP, map_app, Permutation_middle in HExecs; simpl in HExecs. rewrite perm_swap, Permutation_app_comm, <-app_comm_cons in HExecs. apply Permutation_cons_inv in HExecs. rewrite <-app_comm_cons, Permutation_app_comm in HExecs. rewrite <- HExecs in HPSubstep. destruct a. assert (NoDup (map fst (getMethods (inlineSingle_Meth_BaseModule f gn m)))) as P3; [simpl; rewrite SameKeys_inline_Meth; auto|]. specialize (H1 _ (or_introl eq_refl)) as TMP2; simpl in TMP2; rewrite TMP2 in *; clear TMP2. assert (fn = gn) as TMP2; [specialize (H1 _ (or_intror P1)); assumption|rewrite TMP2 in *; clear TMP2]. specialize (extract_exec_PPlus _ P3 HInMeths HPSubstep) as TMP2; dest; rewrite H2 in *; clear H2. assert (DisjKey x1 u) as P4; [rewrite H4 in HDisjRegs; clear - HDisjRegs H6; intro k; specialize (HDisjRegs k); specialize (H6 k); rewrite map_app, in_app_iff in *; firstorder |]. specialize (PPlusAddMeth HRegs _ HInMeths HPAction HReadsGood HUpdGood (Permutation_refl _) (Permutation_refl _) (Permutation_refl _) P4 H9) as P5. rewrite Permutation_middle in P5. rewrite TMP, map_app in IHgexecs; rewrite TMP in P2; simpl in IHgexecs. specialize (IHgexecs P2 _ _ P5); dest. specialize (inlineSingle_Meth_in_list_body _ _ _ H HInMeths) as TMP2; dest; subst; simpl in *. apply (PSemAction_In_inline) in H3; dest. exists (x6++x15), (x16++x7), (x8++x17), (x18++x9), (x10++x19), (x11++x13); repeat split. -- rewrite HUpds, H4, H18, Permutation_app_comm, <-app_assoc. rewrite Permutation_app_comm in H2; rewrite H2; repeat rewrite app_assoc. apply Permutation_app_tail. rewrite Permutation_app_comm, <-app_assoc; reflexivity. -- rewrite HCalls, H5, H19, Permutation_app_comm, <-app_assoc. rewrite Permutation_app_comm in H10; rewrite H10; repeat rewrite app_assoc. apply Permutation_app_tail. rewrite Permutation_app_comm, <-app_assoc; reflexivity. -- intro k; specialize (H6 k); specialize (H3 k); specialize (HDisjRegs k); specialize (H11 k). rewrite H4, H18 in HDisjRegs. rewrite H18 in H6. clear - H2 H10 H11 HDisjRegs H3 H6. repeat rewrite map_app, in_app_iff in *. firstorder. ++ assert (~In k (map fst (x6++x7)));[rewrite <-H2, map_app, in_app_iff;tauto |rewrite map_app, in_app_iff in *]. tauto. ++ assert (~In k (map fst (x6++x7)));[rewrite <-H2, map_app, in_app_iff;tauto |rewrite map_app, in_app_iff in *]. tauto. -- rewrite H16, map_app, SubList_app_l_iff in *; clear - H8 H12; tauto. -- rewrite H18, map_app, SubList_app_l_iff in *; clear - H7 H13; tauto. -- econstructor 3; eauto. ++ rewrite H16, map_app, SubList_app_l_iff in *; clear - H8; dest; auto. ++ rewrite H18, map_app, SubList_app_l_iff in *; clear - H7; dest; auto. ++ repeat rewrite <-app_assoc; rewrite Permutation_app_comm, <-app_assoc. apply Permutation_app_head. rewrite <-app_assoc; apply Permutation_app_head, Permutation_app_comm. ++ rewrite H4, H18 in HDisjRegs; rewrite H18 in H6. clear - H6 H3 HDisjRegs H11 H2. intro k; specialize (H6 k); specialize (H3 k); specialize (HDisjRegs k); specialize (H11 k). repeat rewrite map_app, in_app_iff in *. firstorder. ** assert (~In k (map fst (x6++x7)));[rewrite <-H2, map_app, in_app_iff;tauto |rewrite map_app, in_app_iff in *]. tauto. ++ rewrite map_app; simpl; auto. -- apply PSemAction_meth_collector_stitch; auto. ++ rewrite H4, H18 in HDisjRegs; rewrite H18 in H6. clear - H6 H3 HDisjRegs H11 H2. intro k; specialize (H6 k); specialize (H3 k); specialize (HDisjRegs k); specialize (H11 k). repeat rewrite map_app, in_app_iff in *. firstorder. assert (~In k (map fst (x6++x7)));[rewrite <-H2, map_app, in_app_iff;tauto |rewrite map_app, in_app_iff in *]. tauto. Qed. Corollary PPlus_uninline_meths2 f gn m o: In f (getMethods m) -> (fst f) <> gn -> NoDup (map fst (getMethods m)) -> forall gexecs, (forall g, In g gexecs -> (fst g = gn)) -> forall upds calls, PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds (map Meth gexecs) calls -> exists fcalls, PPlusSubsteps m o upds (map Meth (fcalls++gexecs)) (fcalls++calls). Proof. intros. apply PPlus_uninline_meths in H3; auto; dest. apply DisjKey_Commutative in H5. exists x3; rewrite map_app. specialize (place_execs_PPlus H9 H1 H H7 H6 H5 H8) as P1. rewrite H3, H4. assert (x3++x1++x2 [=] x1++x3++x2) as TMP; [repeat rewrite app_assoc; apply Permutation_app_tail, Permutation_app_comm |rewrite TMP; clear TMP]. assumption. Qed. Lemma key_neq_inlineSingle_Meth fn fb f gn l: fn <> gn -> In (fn, fb) (inlineSingle_Meth_in_list f gn l) -> In (fn, fb) l. Proof. intros;induction l; simpl in *; auto. destruct String.eqb eqn:G; [rewrite String.eqb_eq in G | rewrite String.eqb_neq in G]. - destruct H0, a; simpl in *; subst; auto. exfalso; inv H0; apply H; reflexivity. - destruct H0; auto. Qed. Lemma PPlusSubsteps_NoExec_PPlusSubsteps_inline_Meth f m o gn upds execs calls : NoDup (map fst (getMethods m)) -> In f (getMethods m) -> (forall g, In (Meth g) execs -> fst g <> gn) -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs calls -> PPlusSubsteps m o upds execs calls. Proof. induction 4. - econstructor 1; eauto. - rewrite HUpds, HExecs, HCalls. econstructor 2; eauto. apply IHPPlusSubsteps; repeat intro. eapply H1; eauto; rewrite HExecs; right; auto. - rewrite HUpds, HExecs, HCalls. econstructor 3; eauto. + simpl in HInMeths. eapply key_neq_inlineSingle_Meth; eauto. intro; subst. eapply H1; eauto;[rewrite HExecs; left; reflexivity|];auto. + apply IHPPlusSubsteps; repeat intro. eapply H1;[rewrite HExecs; right|]; eauto. Qed. Lemma PPlusSubsteps_split m o execs1: forall execs2 upds calls, NoDup (map fst (getMethods m)) -> NoDup (map fst (getRules m)) -> PPlusSubsteps m o upds (execs1++execs2) calls -> exists upds1 upds2 calls1 calls2, DisjKey upds1 upds2 /\ upds [=] upds1++upds2 /\ calls [=] calls1++calls2 /\ PPlusSubsteps m o upds1 execs1 calls1 /\ PPlusSubsteps m o upds2 execs2 calls2. Proof. induction execs1; intros; simpl in *. - exists nil, upds, nil, calls. repeat split; auto. + intro; simpl; auto. + econstructor; inv H1; auto. - destruct a. + specialize (PPlusSubsteps_exec_Rule_defined _ (in_eq (Rle rn) (execs1++execs2)) H1) as TMP; dest. specialize (ExtractRuleAction _ H0 H2 (in_eq (Rle rn) (execs1++execs2)) H1) as TMP; dest. simpl in *; apply Permutation_cons_inv in H9; rewrite <-H9 in H11. specialize (IHexecs1 _ _ _ H H0 H11); dest. exists (x2++x7), x8, (x4++x9), x10. repeat split. * rewrite H13 in H6; intro; clear - H6 H12. specialize (H12 k); specialize (H6 k). rewrite map_app, in_app_iff in *; firstorder. * rewrite H4, H13, app_assoc; reflexivity. * rewrite H5, H14, app_assoc; reflexivity. * econstructor 2; auto. -- inv H11; auto. -- apply H2. -- rewrite unique_word_0 in H3; apply H3. -- assumption. -- assumption. -- rewrite H13 in H6; clear - H6; intro k. specialize (H6 k); rewrite map_app, in_app_iff in *; firstorder. -- setoid_rewrite <- H9 in H10. intro; destruct x11; auto. intro; eapply H10; rewrite in_app_iff; left; apply H17. * apply H16. + destruct f. specialize (PPlusSubsteps_exec_Meth_defined _ _ (in_eq (Meth (s, s0)) (execs1++execs2)) H1)as TMP; dest. specialize (extract_exec_PPlus _ H H2 H1) as TMP; dest; subst; simpl in *. specialize (IHexecs1 _ _ _ H H0 H10); dest. exists (x1++x7), x8, (x3++x9), x10. repeat split; auto. * rewrite H11 in H7; intro k; clear - H7 H3. specialize (H3 k); specialize (H7 k); rewrite map_app, in_app_iff in *; firstorder. * rewrite H5, H11, app_assoc; reflexivity. * rewrite H6, H12, app_assoc; reflexivity. * econstructor 3. -- inv H10; eauto. -- apply H2. -- apply H4. -- assumption. -- assumption. -- reflexivity. -- reflexivity. -- reflexivity. -- rewrite H11 in H7. intro k; specialize (H7 k); clear - H7; rewrite map_app, in_app_iff in *. firstorder. -- assumption. Qed. Lemma PPlusSubsteps_PPlusSubsteps_inline_Meth_NotDef f gn m o: forall execs upds calls, ~In gn (map fst (getMethods m)) -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs calls -> PPlusSubsteps m o upds execs calls. Proof. induction 2. - econstructor 1; eauto. - rewrite HUpds, HExecs, HCalls. econstructor 2; eauto. - rewrite HUpds, HExecs, HCalls. econstructor 3; eauto. simpl in HInMeths. rewrite <-Method_list_invariance in HInMeths; auto. Qed. Definition gexecs (gn : string) (exec : RuleOrMeth) : bool := match exec with | Rle _ => false | Meth f => (getBool (string_dec gn (fst f))) end. Lemma gexecs_all_Meth_correct gn execs : exists meths, (filter (gexecs gn) execs) = (map Meth meths) /\ (forall g, In g meths -> fst g = gn). Proof. induction execs. - exists nil; simpl; split; intros; auto; contradiction. - destruct a; auto. unfold gexecs; simpl. destruct string_dec; simpl; auto. dest; exists (f::x). simpl; rewrite <-H; split; intros; auto. destruct H1; subst; auto. Qed. Lemma gexecs_correct gn execs: (forall g, In (Meth g) (filter (gexecs gn) execs) -> fst g = gn). Proof. induction execs; intros; simpl in *; try contradiction. unfold gexecs in H; destruct a; simpl in *; auto. destruct string_dec; simpl in *; auto. destruct H;[inv H|]; auto. Qed. Lemma gexecs_complement_correct gn execs: (forall g, In (Meth g) (filter (complement (gexecs gn)) execs) -> fst g <> gn). Proof. induction execs; intros; simpl in *; try contradiction. unfold gexecs in H; destruct a; simpl in *. - destruct H;[discriminate|auto]. - destruct string_dec; simpl in *; auto. destruct H; auto. inv H;intro; apply n; auto. Qed. Lemma inlineSingle_Meth_in_list_key_match f gn l: (fst f) = gn -> inlineSingle_Meth_in_list f gn l = l. Proof. induction l; simpl; auto. intros. destruct String.eqb eqn:G; [rewrite String.eqb_eq in G | rewrite String.eqb_neq in G]. - unfold inlineSingle_Meth. destruct a; simpl in *; subst. rewrite String.eqb_refl. rewrite IHl; auto. - rewrite IHl; auto. Qed. Lemma PPlusSubsteps_Meth_key_match f gn m o upds execs calls: (fst f) = gn -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs calls -> PPlusSubsteps m o upds execs calls. Proof. induction 2. - econstructor 1; eauto. - rewrite HUpds, HExecs, HCalls. econstructor 2; eauto. - rewrite HUpds, HExecs, HCalls. econstructor 3; eauto. clear - H HInMeths. simpl in *; rewrite inlineSingle_Meth_in_list_key_match in HInMeths; auto. Qed. Lemma PPlusSubsteps_PPlusSubsteps_inline_Meth f gn m o : forall execs upds calls, In f (getMethods m) -> NoDup (map fst (getMethods m)) -> NoDup (map fst (getRules m)) -> PPlusSubsteps (inlineSingle_Meth_BaseModule f gn m) o upds execs calls -> exists fcalls, PPlusSubsteps m o upds ((map Meth (fcalls))++execs) (fcalls++calls). Proof. destruct (in_dec string_dec gn (map fst (getMethods m))). - destruct (string_dec (fst f) gn). + intros. exists nil; simpl in *. eapply PPlusSubsteps_Meth_key_match; eauto. + rewrite in_map_iff in i; dest; destruct x; subst; simpl in *. intros; specialize (separate_calls_by_filter execs (gexecs s)) as P1. rewrite P1 in H3. assert (NoDup (map fst (getMethods (inlineSingle_Meth_BaseModule f s m)))) as P2; [simpl; rewrite SameKeys_inline_Meth; auto|]. assert (NoDup (map fst (getRules (inlineSingle_Meth_BaseModule f s m)))) as P3; auto. specialize (PPlusSubsteps_split_execs_OneRle P2 P3 _ _ H3) as P4. specialize (gexecs_all_Meth_correct s execs) as P5; dest. rewrite H4 in H3. apply PPlusSubsteps_split in H3; auto. * dest; specialize (PPlus_uninline_meths2 H n H1 _ H5 H8) as P5; dest. specialize (gexecs_complement_correct (gn:=s) execs) as P5. specialize (PPlusSubsteps_NoExec_PPlusSubsteps_inline_Meth H1 H P5 H9) as P6. exists x4; rewrite H6, H7, P1, H4, app_assoc, <-map_app, app_assoc. eapply PPlusSubsteps_merge; eauto. intros; destruct x5;[exfalso; clear -H11; induction (x4++x)|];auto. apply IHl; simpl in H11; destruct H11; auto; discriminate. - intros; exists nil; simpl. eapply PPlusSubsteps_PPlusSubsteps_inline_Meth_NotDef; eauto. Qed. Lemma PPlusStep_PPlusStep_inline_Meth f gn m o : forall execs upds calls, In f (getMethods m) -> NoDup (map fst (getMethods m)) -> NoDup (map fst (getRules m)) -> PPlusStep (inlineSingle_Meth_BaseModule f gn m) o upds execs calls -> exists fcalls, PPlusStep m o upds ((map Meth (fcalls))++execs) (fcalls++calls). Proof. induction 4. apply PPlusSubsteps_PPlusSubsteps_inline_Meth in H2; auto. dest; exists x. econstructor; eauto. intros f0 P1. rewrite getNumFromCalls_app, getNumFromExecs_app, call_execs_counts_eq. specialize (H3 f0); simpl in *; rewrite SameKindAttr_inline_Meth in *. specialize (H3 P1); omega. Qed. Lemma PPlusStrongTraceInclusion_inlining_Meths_l m f rn : In f (getMethods m) -> (WfMod type (Base m)) -> StrongPPlusTraceInclusion (inlineSingle_Meth_BaseModule f rn m) m. Proof. unfold StrongPPlusTraceInclusion; induction 3; subst. - exists nil; split. + econstructor; eauto. + constructor. - inv H0; inv HWfBaseModule; dest. apply (PPlusStep_PPlusStep_inline_Meth) in HPPlusStep; auto; dest. exists ((upds, ((map Meth x0 ++ execs), (x0++calls)))::x); split. + econstructor 2; eauto. + constructor; auto. unfold WeakInclusion_flat; unfold getListFullLabel_diff_flat; simpl; split; intros. * rewrite getNumFromCalls_app, getNumFromExecs_app. repeat rewrite call_execs_counts_eq; omega. * dest; exists x1; rewrite in_app_iff in H9. destruct H9; auto. clear - H9; induction x0; simpl in *;[contradiction|]. destruct H9;[discriminate|auto]. Qed. Lemma TraceInclusion_inlining_Meths_l m f rn: In f (getMethods m) -> WfMod type m -> TraceInclusion (inlineSingle_Meth_BaseModule f rn m) m. Proof. intros. apply PPlusTraceInclusion_TraceInclusion; auto. - apply WfMod_Meth_inlined; auto. - apply StrongPPlusTraceInclusion_PPlusTraceInclusion. apply PPlusStrongTraceInclusion_inlining_Meths_l; auto. Qed. Theorem TraceInclusion_inlining_Meths_l_new m f rn: In f (getMethods m) -> WfMod_new type m -> TraceInclusion (inlineSingle_Meth_BaseModule f rn m) m. Proof. rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlining_Meths_l. Qed. Lemma TraceInclusion_inlining_Meths_Wf_l {f} {m : BaseModuleWf type} rn (inMeths: In f (getMethods m)): TraceInclusion (inlineSingle_Meth_BaseModuleWf rn inMeths) m. Proof. simpl; apply TraceInclusion_inlining_Meths_l; eauto. constructor; apply wfBaseModule. Qed. Theorem TraceInclusion_inlining_Meths_Wf_l_new {f} {m : BaseModuleWf_new type} rn (inMeths: In f (getMethods m)): TraceInclusion (inlineSingle_Meth_BaseModuleWf_new rn inMeths) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inlining_Meths_Wf_l f m'). Unshelve. auto. Qed. Lemma inline_meth_transform_l f regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> forall i, TraceInclusion (Base (BaseMod regs rules (transform_nth_right (inlineSingle_Meth f) i meths))) (Base (BaseMod regs rules meths)). Proof. intros; destruct (lt_dec i (length meths)). - pose proof H as H'. inv H; simpl in *. destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. simpl in *. specialize (inlineSingle_Meth_transform_nth f _ NoDupMeths l) as TMP; dest. rewrite H3. assert (In f (getMethods (BaseMod regs rules meths))); auto. specialize (TraceInclusion_inlining_Meths_l (rn:=(fst x)) H4 H') as P1. unfold inlineSingle_Meth_BaseModule in P1; simpl in *; assumption. - apply Nat.nlt_ge in n. rewrite inlineSingle_transform_gt; auto. apply TraceInclusion_refl. Qed. Theorem inline_meth_transform_l_new f regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> forall i, TraceInclusion (Base (BaseMod regs rules (transform_nth_right (inlineSingle_Meth f) i meths))) (Base (BaseMod regs rules meths)). Proof. rewrite WfMod_new_WfMod_iff. apply inline_meth_transform_l. Qed. Lemma inline_meth_transform_Wf_l {f} {m : BaseModuleWf type} i (inMeths : In f (getMethods m)): TraceInclusion (inline_nth_Meth_BaseModuleWf i inMeths) m. Proof. intros; simpl. specialize (TraceInclusion_flatten_l m) as P1. specialize (wfMod (flatten_ModWf m)) as P2; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (inline_meth_transform_l f P2 inMeths i) as P3. eauto using TraceInclusion_trans. Qed. Theorem inline_meth_transform_Wf_l_new {f} {m : BaseModuleWf_new type} i (inMeths : In f (getMethods m)): TraceInclusion (inline_nth_Meth_BaseModuleWf_new i inMeths) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@inline_meth_transform_Wf_l f m'). Unshelve. auto. Qed. Lemma inline_rule_transform_l f regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> forall i, TraceInclusion (Base (BaseMod regs (transform_nth_right (inlineSingle_Rule f) i rules) meths)) (Base (BaseMod regs rules meths)). Proof. intros; destruct (lt_dec i (length rules)). - pose proof H as H'. inv H; simpl in *. destruct HWfBaseModule as [? [? [NoDupMeths [NoDupRegisters NoDupRle]]]]. simpl in *. specialize (inlineSingle_Rule_transform_nth f _ NoDupRle l) as TMP; dest. rewrite H3. assert (In f (getMethods (BaseMod regs rules meths))); auto. specialize (TraceInclusion_inlining_Rules_l (rn:=fst x) H4 H') as P1. unfold inlineSingle_Rule_BaseModule in P1; simpl in *; assumption. - apply Nat.nlt_ge in n. rewrite inlineSingle_transform_gt; auto. apply TraceInclusion_refl. Qed. Theorem inline_rule_transform_l_new f regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> forall i, TraceInclusion (Base (BaseMod regs (transform_nth_right (inlineSingle_Rule f) i rules) meths)) (Base (BaseMod regs rules meths)). Proof. rewrite WfMod_new_WfMod_iff. apply inline_rule_transform_l. Qed. Lemma inline_rule_transform_Wf_l {f} {m : BaseModuleWf type} i (inMeths : In f (getMethods m)): TraceInclusion (inline_nth_Rule_BaseModuleWf i inMeths) m. Proof. intros; simpl. specialize (TraceInclusion_flatten_l m) as P1. specialize (wfMod (flatten_ModWf m)) as P2; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (inline_rule_transform_l f P2 inMeths i) as P3. eauto using TraceInclusion_trans. Qed. Theorem inline_rule_transform_Wf_l_new {f} {m : BaseModuleWf_new type} i (inMeths : In f (getMethods m)): TraceInclusion (inline_nth_Rule_BaseModuleWf_new i inMeths) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@inline_rule_transform_Wf_l f m'). Unshelve. auto. Qed. Section inlineSingle_nth_l. Variable (f : DefMethT). Variable (regs: list RegInitT) (rules: list RuleT) (meths: list DefMethT). Variable (Wf : WfMod type (Base (BaseMod regs rules meths))). Lemma inline_meth_fold_right_l xs: In f meths -> TraceInclusion (Base (BaseMod regs rules (fold_right (transform_nth_right (inlineSingle_Meth f)) meths xs))) (Base (BaseMod regs rules meths)). Proof. induction xs; intros. - simpl; apply TraceInclusion_refl. - simpl. specialize (IHxs H). specialize (WfMod_inline_all_Meth _ xs H Wf) as P1. specialize (inlined_Meth_not_transformed_fold_right _ xs _ H) as P2. specialize (inline_meth_transform_l _ P1 P2 a) as P3. apply (TraceInclusion_trans P3 IHxs). Qed. Lemma inline_rule_fold_right_l xs: In f meths -> TraceInclusion (Base (BaseMod regs (fold_right (transform_nth_right (inlineSingle_Rule f)) rules xs) meths)) (Base (BaseMod regs rules meths)). Proof. induction xs; intros. - simpl; apply TraceInclusion_refl. - simpl. specialize (IHxs H). specialize (WfMod_inline_all_Rule _ xs H Wf) as P1. specialize (inline_rule_transform_l _ P1 H a) as P2. apply (TraceInclusion_trans P2 IHxs). Qed. End inlineSingle_nth_l. Section inlineSingle_nth_l_new. Variable (f : DefMethT). Variable (regs: list RegInitT) (rules: list RuleT) (meths: list DefMethT). Variable (Wf : WfMod_new type (Base (BaseMod regs rules meths))). Theorem inline_meth_fold_right_l_new xs: In f meths -> TraceInclusion (Base (BaseMod regs rules (fold_right (transform_nth_right (inlineSingle_Meth f)) meths xs))) (Base (BaseMod regs rules meths)). Proof. apply inline_meth_fold_right_l. apply WfMod_new_WfMod; auto. Qed. Theorem inline_rule_fold_right_l_new xs: In f meths -> TraceInclusion (Base (BaseMod regs (fold_right (transform_nth_right (inlineSingle_Rule f)) rules xs) meths)) (Base (BaseMod regs rules meths)). Proof. apply inline_rule_fold_right_l. apply WfMod_new_WfMod; auto. Qed. End inlineSingle_nth_l_new. Lemma inline_meth_fold_right_Wf_l {f} {m : BaseModuleWf type} xs (inMeth : In f (getMethods m)): TraceInclusion (inline_all_Meth_BaseModuleWf xs inMeth) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. simpl in *; unfold flatten, getFlat in P1; simpl in *. assert (WfMod type m) as TMP;[constructor; apply wfBaseModule |specialize (WfMod_getFlat TMP) as P2; clear TMP]. specialize (inline_meth_fold_right_l f P2 xs inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem inline_meth_fold_right_Wf_l_new {f} {m : BaseModuleWf_new type} xs (inMeth : In f (getMethods m)): TraceInclusion (inline_all_Meth_BaseModuleWf_new xs inMeth) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@inline_meth_fold_right_Wf_l f m'). Unshelve. auto. Qed. Lemma inline_rule_fold_right_Wf_l {f} {m : BaseModuleWf type} xs (inMeth : In f (getMethods m)): TraceInclusion (inline_all_Rule_BaseModuleWf xs inMeth) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. simpl in *; unfold flatten, getFlat in P1; simpl in *. assert (WfMod type m) as TMP;[constructor; apply wfBaseModule |specialize (WfMod_getFlat TMP) as P2; clear TMP]. specialize (inline_rule_fold_right_l f P2 xs inMeth) as P3. eauto using TraceInclusion_trans. Qed. Lemma inline_rule_fold_right_Wf_l_new {f} {m : BaseModuleWf_new type} xs (inMeth : In f (getMethods m)): TraceInclusion (inline_all_Rule_BaseModuleWf_new xs inMeth) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@inline_rule_fold_right_Wf_l f m'). Unshelve. auto. Qed. Lemma TraceInclusion_inline_BaseModule_rules_l regs rules meths f: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs (map (inlineSingle_Rule f) rules) meths)) (Base (BaseMod regs rules meths)). Proof. intros. unfold inlineSingle_BaseModule. specialize (inline_rule_fold_right_l f H (seq 0 (length rules)) H0) as P1. specialize (WfMod_inline_all_Rule _ (seq 0 (length rules)) H0 H) as P2. repeat rewrite map_fold_right_eq in *. assumption. Qed. Theorem TraceInclusion_inline_BaseModule_rules_l_new regs rules meths f: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs (map (inlineSingle_Rule f) rules) meths)) (Base (BaseMod regs rules meths)). Proof. rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inline_BaseModule_rules_l. Qed. Lemma TraceInclusion_inline_BaseModule_rules_Wf_l {f} {m : BaseModuleWf type} (inMeth : In f (getMethods m)): TraceInclusion (inline_BaseModule_rules_BaseModuleWf inMeth) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. simpl in *; unfold flatten, getFlat in P1; simpl in *. assert (WfMod type m) as TMP;[constructor; apply wfBaseModule |specialize (WfMod_getFlat TMP) as P2; clear TMP]. specialize (TraceInclusion_inline_BaseModule_rules_l f P2 inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inline_BaseModule_rules_Wf_l_new {f} {m : BaseModuleWf_new type} (inMeth : In f (getMethods m)): TraceInclusion (inline_BaseModule_rules_BaseModuleWf_new inMeth) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inline_BaseModule_rules_Wf_l f m'). Unshelve. auto. Qed. Lemma TraceInclusion_inline_BaseModule_meths_l regs rules meths f: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs rules (map (inlineSingle_Meth f) meths))) (Base (BaseMod regs rules meths)). Proof. intros. unfold inlineSingle_BaseModule. specialize (inline_meth_fold_right_l f H (seq 0 (length meths)) H0) as P1. repeat rewrite map_fold_right_eq in *. assumption. Qed. Theorem TraceInclusion_inline_BaseModule_meths_l_new regs rules meths f: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (BaseMod regs rules (map (inlineSingle_Meth f) meths))) (Base (BaseMod regs rules meths)). Proof. rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inline_BaseModule_meths_l. Qed. Lemma TraceInclusion_inline_BaseModule_meths_Wf_l {f} {m : BaseModuleWf type} (inMeth : In f (getMethods m)): TraceInclusion (inline_BaseModule_meths_BaseModuleWf inMeth) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. simpl in *; unfold flatten, getFlat in P1; simpl in *. assert (WfMod type m) as TMP;[constructor; apply wfBaseModule |specialize (WfMod_getFlat TMP) as P2; clear TMP]. specialize (TraceInclusion_inline_BaseModule_meths_l f P2 inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inline_BaseModule_meths_Wf_l_new {f} {m : BaseModuleWf_new type} (inMeth : In f (getMethods m)): TraceInclusion (inline_BaseModule_meths_BaseModuleWf_new inMeth) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inline_BaseModule_meths_Wf_l f m'). Unshelve. auto. Qed. Lemma TraceInclusion_inline_BaseModule_all_l regs rules meths f: (WfMod type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (inlineSingle_BaseModule f regs rules meths)) (Base (BaseMod regs rules meths)). Proof. intros. unfold inlineSingle_BaseModule. specialize (TraceInclusion_inline_BaseModule_rules_l f H H0) as P1. specialize (WfMod_inline_all_Rule _ (seq 0 (length rules)) H0 H) as P2. specialize (TraceInclusion_inline_BaseModule_meths_l f P2 H0) as P3. repeat rewrite map_fold_right_eq in *. apply (TraceInclusion_trans P3 P1). Qed. Theorem TraceInclusion_inline_BaseModule_all_l_new regs rules meths f: (WfMod_new type (Base (BaseMod regs rules meths))) -> In f meths -> TraceInclusion (Base (inlineSingle_BaseModule f regs rules meths)) (Base (BaseMod regs rules meths)). Proof. rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inline_BaseModule_all_l. Qed. Lemma TraceInclusion_inline_BaseModule_all_Wf_l {f} {m : BaseModuleWf type} (inMeth : In f (getMethods m)): TraceInclusion (inlineSingle_BaseModuleWf inMeth) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inline_BaseModule_all_l P2 inMeth) as P3. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inline_BaseModule_all_Wf_l_new {f} {m : BaseModuleWf_new type} (inMeth : In f (getMethods m)): TraceInclusion (inlineSingle_BaseModuleWf_new inMeth) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. eapply (@TraceInclusion_inline_BaseModule_all_Wf_l f m'). Unshelve. auto. Qed. Section inline_all_all_l. Lemma TraceInclusion_inlineSingle_pos_Rules_l regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> forall n, (WfMod type (Base (BaseMod regs (inlineSingle_Rules_pos meths n rules) meths))) /\ TraceInclusion (Base (BaseMod regs (inlineSingle_Rules_pos meths n rules) meths)) (Base (BaseMod regs rules meths)). Proof. intros WfH n. unfold inlineSingle_Rules_pos. case_eq (nth_error meths n); intros sth; [intros sthEq|split; [assumption | apply TraceInclusion_refl]]. split. - apply nth_error_In in sthEq. pose proof (WfMod_inline_all_Rule sth (seq 0 (length rules)) sthEq WfH). repeat rewrite map_fold_right_eq in *. assumption. - apply TraceInclusion_inline_BaseModule_rules_l; auto. eapply nth_error_In; eauto. Qed. Theorem TraceInclusion_inlineSingle_pos_Rules_l_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> forall n, (WfMod_new type (Base (BaseMod regs (inlineSingle_Rules_pos meths n rules) meths))) /\ TraceInclusion (Base (BaseMod regs (inlineSingle_Rules_pos meths n rules) meths)) (Base (BaseMod regs rules meths)). Proof. intros. rewrite WfMod_new_WfMod_iff in *. apply TraceInclusion_inlineSingle_pos_Rules_l; auto. Qed. Lemma TraceInclusion_inlineSingle_pos_Rules_Wf_l (m : BaseModuleWf type) n : TraceInclusion (inlineSingle_Rules_pos_BaseModuleWf m n) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineSingle_pos_Rules_l P2 n) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineSingle_pos_Rules_Wf_l_new (m : BaseModuleWf_new type) n : TraceInclusion (inlineSingle_Rules_pos_BaseModuleWf_new m n) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (@TraceInclusion_inlineSingle_pos_Rules_Wf_l m'). Qed. Lemma TraceInclusion_inlineAll_pos_Rules_l regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> (WfMod type (Base (BaseMod regs (inlineAll_Rules meths rules) meths))) /\ TraceInclusion (Base (BaseMod regs (inlineAll_Rules meths rules) meths)) (Base (BaseMod regs rules meths)). Proof. intros WfH. unfold inlineAll_Rules. induction (Datatypes.length meths); [simpl in *; split; [assumption | apply TraceInclusion_refl]|]. rewrite seq_eq. rewrite fold_left_app; simpl in *. destruct IHn as [IHn1 IHn2]. pose proof (TraceInclusion_inlineSingle_pos_Rules_l IHn1 n) as [sth1 sth2]. destruct n; simpl in *; auto. split; auto. eapply TraceInclusion_trans; eauto. Qed. Theorem TraceInclusion_inlineAll_pos_Rules_l_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> (WfMod_new type (Base (BaseMod regs (inlineAll_Rules meths rules) meths))) /\ TraceInclusion (Base (BaseMod regs (inlineAll_Rules meths rules) meths)) (Base (BaseMod regs rules meths)). Proof. repeat rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlineAll_pos_Rules_l. Qed. Lemma TraceInclusion_inlineAll_pos_Rules_Wf_l (m : BaseModuleWf type) : TraceInclusion (inlineAll_Rules_BaseModuleWf m) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineAll_pos_Rules_l P2) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineAll_pos_Rules_Wf_l_new (m : BaseModuleWf_new type) : TraceInclusion (inlineAll_Rules_BaseModuleWf_new m) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (@TraceInclusion_inlineAll_pos_Rules_Wf_l m'). Qed. Lemma TraceInclusion_inlineSingle_pos_Meths_l regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> forall n, (WfMod type (Base (BaseMod regs rules (inlineSingle_Meths_pos meths n)))) /\ TraceInclusion (Base (BaseMod regs rules (inlineSingle_Meths_pos meths n))) (Base (BaseMod regs rules meths)). Proof. intros WfH n. unfold inlineSingle_Meths_pos. case_eq (nth_error meths n); intros sth; [intros sthEq|split; [assumption | apply TraceInclusion_refl]]. split. - apply nth_error_In in sthEq. pose proof (WfMod_inline_all_Meth sth (seq 0 (length meths)) sthEq WfH). repeat rewrite map_fold_right_eq in *. assumption. - apply TraceInclusion_inline_BaseModule_meths_l; auto. eapply nth_error_In; eauto. Qed. Theorem TraceInclusion_inlineSingle_pos_Meths_l_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> forall n, (WfMod_new type (Base (BaseMod regs rules (inlineSingle_Meths_pos meths n)))) /\ TraceInclusion (Base (BaseMod regs rules (inlineSingle_Meths_pos meths n))) (Base (BaseMod regs rules meths)). Proof. intros. rewrite WfMod_new_WfMod_iff in *. apply TraceInclusion_inlineSingle_pos_Meths_l; auto. Qed. Lemma TraceInclusion_inlineSingle_pos_Meths_Wf_l (m : BaseModuleWf type) n : TraceInclusion (inlineSingle_Meths_pos_BaseModuleWf m n) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineSingle_pos_Meths_l P2 n) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineSingle_pos_Meths_Wf_l_new (m : BaseModuleWf_new type) n : TraceInclusion (inlineSingle_Meths_pos_BaseModuleWf_new m n) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (@TraceInclusion_inlineSingle_pos_Meths_Wf_l m'). Qed. Lemma TraceInclusion_inlineAll_pos_Meths_l regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> (WfMod type (Base (BaseMod regs rules (inlineAll_Meths meths)))) /\ TraceInclusion (Base (BaseMod regs rules (inlineAll_Meths meths))) (Base (BaseMod regs rules meths)). Proof. intros WfH. unfold inlineAll_Meths. induction (Datatypes.length meths); [simpl; split; [assumption | apply TraceInclusion_refl]|]. rewrite seq_eq. rewrite fold_left_app; simpl. destruct IHn as [IHn1 IHn2]. pose proof (TraceInclusion_inlineSingle_pos_Meths_l IHn1 n) as [sth1 sth2]. destruct n; simpl in *; auto. split; auto. eapply TraceInclusion_trans; eauto. Qed. Theorem TraceInclusion_inlineAll_pos_Meths_l_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> (WfMod_new type (Base (BaseMod regs rules (inlineAll_Meths meths)))) /\ TraceInclusion (Base (BaseMod regs rules (inlineAll_Meths meths))) (Base (BaseMod regs rules meths)). Proof. repeat rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlineAll_pos_Meths_l. Qed. Lemma TraceInclusion_inlineAll_pos_Meths_Wf_l (m : BaseModuleWf type) : TraceInclusion (inlineAll_Meths_BaseModuleWf m) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineAll_pos_Meths_l P2) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineAll_pos_Meths_Wf_l_new (m : BaseModuleWf_new type) : TraceInclusion (inlineAll_Meths_BaseModuleWf_new m) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (@TraceInclusion_inlineAll_pos_Meths_Wf_l m'). Qed. Lemma TraceInclusion_inlineAll_pos_l regs rules meths: (WfMod type (Base (BaseMod regs rules meths))) -> (WfMod type (Base (inlineAll_All regs rules meths))) /\ TraceInclusion (Base (inlineAll_All regs rules meths)) (Base (BaseMod regs rules meths)). Proof. unfold inlineAll_All in *. intros WfH1. pose proof (TraceInclusion_inlineAll_pos_Meths_l WfH1) as [WfH2 P2]. pose proof (TraceInclusion_inlineAll_pos_Rules_l WfH2) as [WfH3 P3]. split; auto. eapply TraceInclusion_trans; eauto. Qed. Theorem TraceInclusion_inlineAll_pos_l_new regs rules meths: (WfMod_new type (Base (BaseMod regs rules meths))) -> (WfMod_new type (Base (inlineAll_All regs rules meths))) /\ TraceInclusion (Base (inlineAll_All regs rules meths)) (Base (BaseMod regs rules meths)). Proof. repeat rewrite WfMod_new_WfMod_iff. apply TraceInclusion_inlineAll_pos_l. Qed. Lemma TraceInclusion_inlineAll_pos_Wf_l (m : BaseModuleWf type) : TraceInclusion (inlineAll_All_BaseModuleWf m) m. Proof. specialize (TraceInclusion_flatten_l m) as P1. specialize (wfMod (flatten_ModWf m)) as P2. simpl in *; unfold flatten, getFlat in *; simpl in *. specialize (TraceInclusion_inlineAll_pos_l P2) as TMP; dest. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_inlineAll_pos_Wf_l_new (m : BaseModuleWf_new type) : TraceInclusion (inlineAll_All_BaseModuleWf_new m) m. Proof. destruct m. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as m'. apply (@TraceInclusion_inlineAll_pos_Wf_l m'). Qed. End inline_all_all_l. Lemma TraceInclusion_flatten_inline_everything_l (m : ModWf type) : TraceInclusion (flatten_inline_everything_ModWf m) m. Proof. specialize (wfMod (flatten_inline_everything_ModWf m)) as Wf1. simpl. specialize (TraceInclusion_flatten_l m) as P1. unfold flatten, getFlat in *. assert (WfMod type (Base (getFlat m))). { intros. apply (WfMod_WfBase_getFlat (wfMod m)). } unfold getFlat in *. specialize (TraceInclusion_inlineAll_pos_l H) as TMP; dest. unfold inlineAll_All in *. apply (Trace_createHide (getHidden m)) in H1. eauto using TraceInclusion_trans. Qed. Theorem TraceInclusion_flatten_inline_everything_l_new (m : ModWf_new type) : TraceInclusion (flatten_inline_everything_ModWf_new m) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. apply (@TraceInclusion_flatten_inline_everything_l m'). Qed. Lemma inlineSingle_Rule_map_TraceInclusion_l {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)): TraceInclusion (inlineSingle_Rule_map_ModWf inMeths) m. Proof. intros. specialize (TraceInclusion_flatten_l m) as TI_flatten; simpl in *. unfold flatten, inlineSingle_Rule_map_BaseModule, getFlat in *; simpl in *. specialize (TraceInclusion_inline_BaseModule_rules_l f (WfMod_WfBase_getFlat (wfMod m)) inMeths) as P1. specialize (Trace_createHide (getHidden m) P1) as P2. eauto using TraceInclusion_trans. Qed. Theorem inlineSingle_Rule_map_TraceInclusion_l_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)): TraceInclusion (inlineSingle_Rule_map_ModWf_new inMeths) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_Rule_map_TraceInclusion_l m'). Unshelve. auto. Qed. Lemma inlineSingle_Meth_map_TraceInclusion_l {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)) : TraceInclusion (inlineSingle_Meth_map_ModWf inMeths) m. Proof. intros. specialize (TraceInclusion_flatten_l m) as TI_flatten; simpl in *. unfold flatten, inlineSingle_Meth_map_BaseModule, getFlat in *; simpl in *. specialize (TraceInclusion_inline_BaseModule_meths_l f (WfMod_WfBase_getFlat (wfMod m)) inMeths) as P1. specialize (Trace_createHide (getHidden m) P1) as P2. eauto using TraceInclusion_trans. Qed. Theorem inlineSingle_Meth_map_TraceInclusion_l_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)) : TraceInclusion (inlineSingle_Meth_map_ModWf_new inMeths) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_Meth_map_TraceInclusion_l m'). Unshelve. auto. Qed. Lemma inlineSingle_BaseModule_TraceInclusion_l {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)) : TraceInclusion (inlineSingle_Module_ModWf inMeths) m. Proof. specialize (TraceInclusion_flatten_l m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (TraceInclusion_inline_BaseModule_all_l H0 inMeths) as P2. specialize (Trace_createHide (getHidden m) P2) as P3. eauto using TraceInclusion_trans. Qed. Theorem inlineSingle_BaseModule_TraceInclusion_l_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)) : TraceInclusion (inlineSingle_Module_ModWf_new inMeths) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_BaseModule_TraceInclusion_l m'). Unshelve. auto. Qed. Lemma inlineSingle_BaseModule_nth_Meth_TraceInclusion_l {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : TraceInclusion (inlineSingle_BaseModule_nth_Meth_ModWf inMeths xs) m. Proof. specialize (TraceInclusion_flatten_l m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (inline_meth_fold_right_l _ H0 xs inMeths) as P2. specialize (Trace_createHide (getHidden m) P2) as P3. eauto using TraceInclusion_trans. Qed. Theorem inlineSingle_BaseModule_nth_Meth_TraceInclusion_l_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : TraceInclusion (inlineSingle_BaseModule_nth_Meth_ModWf_new inMeths xs) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_BaseModule_nth_Meth_TraceInclusion_l m'). Unshelve. auto. Qed. Lemma inlineSingle_BaseModule_nth_Rule_TraceInclusion_l {m : ModWf type} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : TraceInclusion (inlineSingle_BaseModule_nth_Rule_ModWf inMeths xs) m. Proof. specialize (TraceInclusion_flatten_l m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (inline_rule_fold_right_l _ H0 xs inMeths) as P2. specialize (Trace_createHide (getHidden m) P2) as P3. eauto using TraceInclusion_trans. Qed. Theorem inlineSingle_BaseModule_nth_Rule_TraceInclusion_l_new {m : ModWf_new type} {f : DefMethT} (inMeths : In f (getAllMethods m)) (xs : list nat) : TraceInclusion (inlineSingle_BaseModule_nth_Rule_ModWf_new inMeths xs) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineSingle_BaseModule_nth_Rule_TraceInclusion_l m'). Unshelve. auto. Qed. Lemma inlineAll_Rules_TraceInclusion_l (m : ModWf type) : TraceInclusion (inlineAll_Rules_ModWf m) m. Proof. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (TraceInclusion_inlineAll_pos_Rules_l H0) as P2; dest. specialize (Trace_createHide (getHidden m) H2) as P1. specialize (TraceInclusion_flatten_l m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. eauto using TraceInclusion_trans. Qed. Theorem inlineAll_Rules_TraceInclusion_l_new (m : ModWf_new type) : TraceInclusion (inlineAll_Rules_ModWf_new m) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineAll_Rules_TraceInclusion_l m'). Qed. Lemma inlineAll_Meths_TraceInclusion_l (m : ModWf type) : TraceInclusion (inlineAll_Meths_ModWf m) m. Proof. specialize (flatten_WfMod (wfMod m)) as P1; unfold flatten, getFlat in P1; simpl in P1. rewrite WfMod_createHide in P1; dest. specialize (TraceInclusion_inlineAll_pos_Meths_l H0) as P2; dest. specialize (Trace_createHide (getHidden m) H2) as P1. specialize (TraceInclusion_flatten_l m) as TI_flatten; simpl in *. unfold flatten, getFlat in *; simpl in *. eauto using TraceInclusion_trans. Qed. Theorem inlineAll_Meths_TraceInclusion_l_new (m : ModWf_new type) : TraceInclusion (inlineAll_Meths_ModWf_new m) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@inlineAll_Meths_TraceInclusion_l m'). Qed. Lemma flatten_inline_remove_TraceInclusion_l_lemma (m : ModWf type) : NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_remove_ModWf m) (flatten_inline_everything m). Proof. simpl; unfold flatten_inline_everything, flatten_inline_remove. intros. specialize (WfMod_WfBase_getFlat (wfMod m)) as P1; unfold getFlat in *. specialize (TraceInclusion_inlineAll_pos_l P1) as P2; inv P2. inv H0. assert (SubList (getHidden m) (map fst (getMethods (Build_BaseModuleWf (HWfBaseModule))))) as P2; [repeat intro; simpl; rewrite <- SameKeys_inlineAll_Meths; eapply WfMod_Hidden; eauto using (wfMod m)|]. apply (removeHides_createHide_TraceInclusion P2 H). Qed. Theorem flatten_inline_remove_TraceInclusion_l_lemma_new (m : ModWf_new type) : NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_remove_ModWf_new m) (flatten_inline_everything m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@flatten_inline_remove_TraceInclusion_l_lemma m'). Qed. Lemma TraceInclusion_flatten_inline_remove_ModWf_l_lemma (m : ModWf type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_remove_ModWf m) (flatten_inline_everything_ModWf m). Proof. intros. unfold flatten_inline_everything_ModWf. eauto using flatten_inline_remove_TraceInclusion_l_lemma. Qed. Theorem TraceInclusion_flatten_inline_remove_ModWf_l_lemma_new (m : ModWf_new type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_remove_ModWf_new m) (flatten_inline_everything_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@TraceInclusion_flatten_inline_remove_ModWf_l_lemma m'). Qed. Lemma TraceInclusion_flatten_inline_remove_ModWf_r_lemma (m : ModWf type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_everything_ModWf m) (flatten_inline_remove_ModWf m). Proof. intros. unfold flatten_inline_everything_ModWf. eauto using flatten_inline_remove_TraceInclusion_r_lemma. Qed. Theorem TraceInclusion_flatten_inline_remove_ModWf_r_lemma_new (m : ModWf_new type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_everything_ModWf_new m) (flatten_inline_remove_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@TraceInclusion_flatten_inline_remove_ModWf_r_lemma m'). Qed. Lemma flatten_inline_remove_TraceInclusion_l (m : ModWf type) : NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_remove_ModWf m) m. Proof. intros H. eapply TraceInclusion_trans. - eapply TraceInclusion_flatten_inline_remove_ModWf_l_lemma; eauto. - eapply TraceInclusion_flatten_inline_everything_l. Qed. Theorem flatten_inline_remove_TraceInclusion_l_new (m : ModWf_new type) : NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_remove_ModWf_new m) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@flatten_inline_remove_TraceInclusion_l m'). Qed. Lemma flatten_inline_remove_TraceInclusion_r (m : ModWf type) : NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion m (flatten_inline_remove_ModWf m). Proof. intros H. eapply TraceInclusion_trans. - eapply TraceInclusion_flatten_inline_everything_r. - eapply TraceInclusion_flatten_inline_remove_ModWf_r_lemma; eauto. Qed. Theorem flatten_inline_remove_TraceInclusion_r_new (m : ModWf_new type) : NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion m (flatten_inline_remove_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@flatten_inline_remove_TraceInclusion_r m'). Qed. Lemma TraceInclusion_flatten_inline_remove_ModWf_l (m : ModWf type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_remove_ModWf m) m. Proof. intros. unfold flatten_inline_remove_ModWf. eauto using flatten_inline_remove_TraceInclusion_l. Qed. Theorem TraceInclusion_flatten_inline_remove_ModWf_l_new (m : ModWf_new type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion (flatten_inline_remove_ModWf_new m) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@TraceInclusion_flatten_inline_remove_ModWf_l m'). Qed. Lemma TraceInclusion_flatten_inline_remove_ModWf_r (m : ModWf type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion m (flatten_inline_remove_ModWf m). Proof. intros. unfold flatten_inline_remove_ModWf. eauto using flatten_inline_remove_TraceInclusion_r. Qed. Theorem TraceInclusion_flatten_inline_remove_ModWf_r_new (m : ModWf_new type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceInclusion m (flatten_inline_remove_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@TraceInclusion_flatten_inline_remove_ModWf_r m'). Qed. Lemma TraceEquiv_flatten_inline_remove_ModWf (m: ModWf type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceEquiv m (flatten_inline_remove_ModWf m). Proof. unfold TraceEquiv. intros. split. - eapply TraceInclusion_flatten_inline_remove_ModWf_r; auto. - eapply TraceInclusion_flatten_inline_remove_ModWf_l; auto. Qed. Theorem TraceEquiv_flatten_inline_remove_ModWf_new (m: ModWf_new type): NoSelfCallBaseModule (inlineAll_All_mod m) -> TraceEquiv m (flatten_inline_remove_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@TraceEquiv_flatten_inline_remove_ModWf m'). Qed. Lemma distributeHideWf ty (m1 m2 : Mod) (h : string) (HNeverCall : NeverCallMod m1): WfMod ty (HideMeth (ConcatMod m1 m2) h) -> ~ In h (map fst (getAllMethods m1)) -> WfMod ty (ConcatMod m1 (HideMeth m2 h)). Proof. intros; inv H. inv HWf. econstructor; simpl in *; eauto. - econstructor; eauto. rewrite map_app, in_app_iff in *. destruct HHideWf; auto. exfalso; tauto. - inv WfConcat1; econstructor; intros. + specialize (H _ H2). induction HNeverCall. -- inv HNCBaseModule. specialize (H3 _ ty H2). induction H; inv H3; EqDep_subst; econstructor; eauto. tauto. -- eapply IHHNeverCall; eauto. ++ inv HWf1; assumption. ++ assert (forall f, In f (getHidden m) -> In f (getHidden (HideMeth m s))) as P0; [intros; simpl in *; right; assumption|];inv WfConcat2; split. ** intros; specialize (H3 _ H5). clear - H3 P0. induction H3; econstructor; eauto. ** intros; specialize (H4 _ H5 v). clear - H4 P0. induction H4; econstructor; eauto. -- simpl in *. rewrite map_app, in_map_iff, in_app_iff in *. apply Decidable.not_or in H0; dest. destruct H2. ++ eapply IHHNeverCall1; eauto. ** intro; dest. apply H0. rewrite in_map_iff. eauto. ** right. destruct HHideWf; auto. exfalso. rewrite map_app, in_app_iff in *. clear - H0 H3 H4; tauto. ** clear - HDisjRegs. intro k; specialize (HDisjRegs k). rewrite map_app, in_app_iff in *. firstorder. ** clear - HDisjRules. intro k; specialize (HDisjRules k). rewrite map_app, in_app_iff in *. firstorder. ** clear - HDisjMeths. intro k; specialize (HDisjMeths k). rewrite map_app, in_app_iff in *. tauto. ** inv HWf1; auto. ** clear - WfConcat2. inv WfConcat2. assert (forall f, ~In f (getHidden (ConcatMod m1 m0)) -> ~In f (getHidden m1)) as P0; [intros; simpl in *; intro; apply H1; rewrite in_app_iff; tauto|]. split. --- intros; specialize (H _ H1). clear - H P0. induction H; econstructor; eauto. --- intros; specialize (H0 _ H1 v). clear - H0 P0. induction H0; econstructor; eauto. ** intros; eapply H1. rewrite in_app_iff; left; assumption. ++ eapply IHHNeverCall2; eauto. ** intro; dest. apply H3. rewrite in_map_iff. eauto. ** right. destruct HHideWf; auto. exfalso. rewrite map_app, in_app_iff in *. clear - H0 H3 H4; tauto. ** clear - HDisjRegs. intro k; specialize (HDisjRegs k). rewrite map_app, in_app_iff in *. firstorder. ** clear - HDisjRules. intro k; specialize (HDisjRules k). rewrite map_app, in_app_iff in *. firstorder. ** clear - HDisjMeths. intro k; specialize (HDisjMeths k). rewrite map_app, in_app_iff in *. tauto. ** inv HWf1; auto. ** clear - WfConcat2. inv WfConcat2. assert (forall f, ~In f (getHidden (ConcatMod m1 m0)) -> ~In f (getHidden m0)) as P0; [intros; simpl in *; intro; apply H1; rewrite in_app_iff; tauto|]. split. --- intros; specialize (H _ H1). clear - H P0. induction H; econstructor; eauto. --- intros; specialize (H0 _ H1 v). clear - H0 P0. induction H0; econstructor; eauto. ** intros; eapply H1. rewrite in_app_iff; right; assumption. + specialize (H1 _ H2 v). induction HNeverCall. -- inv HNCBaseModule. specialize (H4 _ ty H2 v). induction H1; inv H4; EqDep_subst; econstructor; eauto. tauto. -- eapply IHHNeverCall; eauto. ++ inv HWf1; assumption. ++ assert (forall f, In f (getHidden m) -> In f (getHidden (HideMeth m s))) as P0; [intros; simpl in *; right; assumption|];inv WfConcat2; split. ** intros; specialize (H3 _ H5). clear - H3 P0. induction H3; econstructor; eauto. ** intros; specialize (H4 _ H5 v0). clear - H4 P0. induction H4; econstructor; eauto. -- simpl in *. rewrite map_app, in_map_iff, in_app_iff in *. apply Decidable.not_or in H0; dest. destruct H2. ++ eapply IHHNeverCall1; eauto. ** intro; dest. apply H0. rewrite in_map_iff. eauto. ** right. destruct HHideWf; auto. exfalso. rewrite map_app, in_app_iff in *. clear - H0 H3 H4; tauto. ** clear - HDisjRegs. intro k; specialize (HDisjRegs k). rewrite map_app, in_app_iff in *. firstorder. ** clear - HDisjRules. intro k; specialize (HDisjRules k). rewrite map_app, in_app_iff in *. firstorder. ** clear - HDisjMeths. intro k; specialize (HDisjMeths k). rewrite map_app, in_app_iff in *. tauto. ** inv HWf1; auto. ** clear - WfConcat2. inv WfConcat2. assert (forall f, ~In f (getHidden (ConcatMod m1 m0)) -> ~In f (getHidden m1)) as P0; [intros; simpl in *; intro; apply H1; rewrite in_app_iff; tauto|]. split. --- intros; specialize (H _ H1). clear - H P0. induction H; econstructor; eauto. --- intros; specialize (H0 _ H1 v). clear - H0 P0. induction H0; econstructor; eauto. ** intros; eapply H. rewrite in_app_iff; left; assumption. ++ eapply IHHNeverCall2; eauto. ** intro; dest. apply H3. rewrite in_map_iff. eauto. ** right. destruct HHideWf; auto. exfalso. rewrite map_app, in_app_iff in *. clear - H0 H3 H4; tauto. ** clear - HDisjRegs. intro k; specialize (HDisjRegs k). rewrite map_app, in_app_iff in *. firstorder. ** clear - HDisjRules. intro k; specialize (HDisjRules k). rewrite map_app, in_app_iff in *. firstorder. ** clear - HDisjMeths. intro k; specialize (HDisjMeths k). rewrite map_app, in_app_iff in *. tauto. ** inv HWf1; auto. ** clear - WfConcat2. inv WfConcat2. assert (forall f, ~In f (getHidden (ConcatMod m1 m0)) -> ~In f (getHidden m0)) as P0; [intros; simpl in *; intro; apply H1; rewrite in_app_iff; tauto|]. split. --- intros; specialize (H _ H1). clear - H P0. induction H; econstructor; eauto. --- intros; specialize (H0 _ H1 v). clear - H0 P0. induction H0; econstructor; eauto. ** intros; eapply H. rewrite in_app_iff; right; assumption. Qed. Lemma distributeHidesWf ty (m1 m2 : Mod) (hl1 hl2 : list string) (HNeverCall : NeverCallMod m1): WfMod ty (createHideMod (ConcatMod m1 m2) (hl1++hl2)) -> (forall h, In h hl1 -> ~ In h (map fst (getAllMethods m1))) -> WfMod ty (createHideMod (ConcatMod m1 (createHideMod m2 hl1)) hl2). Proof. induction hl1; simpl; intros; auto. rewrite WfMod_createHideMod; split. - simpl. repeat intro. rewrite map_app, in_app_iff. rewrite getAllMethods_createHideMod. inv H. rewrite WfMod_createHideMod in HWf; dest. specialize (H x (in_or_app _ _ _(or_intror _ H1))); simpl in *. rewrite map_app, in_app_iff in *; destruct H; auto. - apply distributeHideWf; auto. constructor; inv H. + rewrite getAllMethods_createHideMod in *; simpl in *. rewrite map_app, in_app_iff, getAllMethods_createHideMod in *; assumption. + assert (forall h : string, In h hl1 -> ~ In h (map fst (getAllMethods m1))) as P0; [intros; apply H0; auto|]. specialize (IHhl1 HWf P0). rewrite WfMod_createHideMod in IHhl1; dest; assumption. Qed. Lemma WfMod_perm ty (m : Mod) (hl1 hl2: list string): hl1 [=] hl2 -> WfMod ty (createHideMod m hl1) -> WfMod ty (createHideMod m hl2). Proof. intros. rewrite WfMod_createHideMod in *; dest; split; auto. repeat intro. rewrite <- H in H2. specialize (H0 _ H2). assumption. Qed. Definition StrongTraceInclusion' (m m' : Mod) : Prop := forall (o : RegsT) (ls : list (list FullLabel)), Trace m o ls -> exists (ls' : list (list FullLabel)), Trace m' o ls' /\ WeakInclusions ls ls'. Lemma StrongTI'_TI' (m m' : Mod) : StrongTraceInclusion' m m' -> TraceInclusion' m m'. Proof. repeat intro. specialize (H _ _ H0). dest. exists x; split;[exists o|];assumption. Qed. Lemma action_noCalls {k : Kind} (o : RegsT) (a : ActionT type k) (reads u : RegsT) (cs : MethsT) (fret : type k) (HNeverCallAct : NeverCallActionT a): SemAction o a reads u cs fret -> cs = []. Proof. induction 1; auto; try inv HNeverCallAct; EqDep_subst; eauto. - tauto. - rewrite IHSemAction1, IHSemAction2; auto. - rewrite IHSemAction1, IHSemAction2; auto. - rewrite IHSemAction1, IHSemAction2; auto. Qed. Lemma Substeps_NeverCall_getNumCalls_0 (m : BaseModule)(o : RegsT)(l : list FullLabel) (HNeverCallBase : NeverCallBaseModule m) : Substeps m o l -> forall (f : MethT), getNumCalls f l = 0%Z. Proof. induction 1; intros; simpl. - apply getNumCalls_nil. - subst. rewrite getNumCalls_cons, IHSubsteps; simpl. inv HNeverCallBase. specialize (H0 _ type HInRules); simpl in *. rewrite (action_noCalls H0 HAction); simpl. reflexivity. - subst. rewrite getNumCalls_cons, IHSubsteps; simpl. inv HNeverCallBase. specialize (H1 _ type HInMeths argV). rewrite (action_noCalls H1 HAction); simpl. reflexivity. Qed. Lemma Step_NeverCall_getNumCalls_0 (m : Mod)(o : RegsT)(l : list FullLabel) (HNeverCall : NeverCallMod m) : Step m o l -> forall (f : MethT), getNumCalls f l = 0%Z. Proof. induction 1; simpl; intros. - inv HNeverCall. rewrite (Substeps_NeverCall_getNumCalls_0 HNCBaseModule HSubsteps). reflexivity. - inv HNeverCall. rewrite IHStep; auto. - subst. inv HNeverCall. rewrite getNumCalls_app, IHStep1, IHStep2; auto. Qed. Lemma distributeHide_TraceInclusion (m1 m2 : Mod) (h : string) (HNeverCall : NeverCallMod m1): ~ In h (map fst (getAllMethods m1)) -> TraceInclusion (HideMeth (ConcatMod m1 m2) h) (ConcatMod m1 (HideMeth m2 h)). Proof. intros. apply TraceInclusion'_TraceInclusion, StrongTI'_TI'. unfold StrongTraceInclusion'. intros. induction H0; subst. - exists nil; split;[|apply WeakInclusionsRefl]. econstructor; eauto. - dest. exists (l::x). split;[|constructor; [assumption|apply WeakInclusionRefl]]. econstructor 2; eauto. clear - HStep HNeverCall H. inv HStep. inv HStep0. econstructor 3; eauto. + econstructor 2; eauto. intros; simpl in *; specialize (HHidden v). rewrite map_app, in_app_iff in *. specialize (HHidden (or_intror H0)). unfold getListFullLabel_diff in *. rewrite getNumExecs_app, getNumCalls_app in *. rewrite (Step_NeverCall_getNumCalls_0 HNeverCall HStep1) in *. clear - HStep1 HStep2 HHidden HNeverCall H H0. rewrite (NotInDef_ZeroExecs_Step (m:=m1)(o:=o1)(ls:=l1) (h, v)) in *; auto. + unfold MatchingExecCalls_Concat in *; intros; simpl in *. split; [|eapply HMatching1; eauto]. intro; apply H0. rewrite (Step_NeverCall_getNumCalls_0 HNeverCall HStep1) in *. reflexivity. Qed. Lemma distributeHides_TraceInclusion (m1 m2 : Mod) (hl : list string) (HNeverCall : NeverCallMod m1) : (forall h, In h hl -> ~In h (map fst (getAllMethods m1))) -> TraceInclusion (createHideMod (ConcatMod m1 m2) hl) (ConcatMod m1 (createHideMod m2 hl)). Proof. induction hl; simpl; intros. - apply TraceInclusion_refl. - assert (forall h : string, In h hl -> ~ In h (map fst (getAllMethods m1))) as P0; [intros; apply (H _ (or_intror H0))|]. specialize (IHhl P0). apply TraceInclusion_TraceInclusion' in IHhl. specialize (TraceInclusion'_HideMeth (s:=a) IHhl) as P1. apply TraceInclusion'_TraceInclusion in P1. specialize (H a (or_introl eq_refl)). specialize (distributeHide_TraceInclusion HNeverCall H (m2:=(createHideMod m2 hl))) as P2. eauto using TraceInclusion_trans. Qed. Lemma createHides_perm_TraceInclusion (m : Mod) (hl1 hl2: list string): hl1 [=] hl2 -> TraceInclusion (createHideMod m hl1) (createHideMod m hl2). Proof. induction 1. - apply TraceInclusion_refl. - simpl. apply TraceInclusion'_TraceInclusion, TraceInclusion'_HideMeth, TraceInclusion_TraceInclusion'; assumption. - simpl. apply TraceInclusion'_TraceInclusion, StrongTI'_TI'. unfold StrongTraceInclusion'; intros. exists ls; split;[|apply WeakInclusionsRefl]. induction H. + econstructor 1; auto. + econstructor 2; eauto. clear - HStep. inv HStep. inv HStep0. constructor; auto. constructor; auto. - eauto using TraceInclusion_trans. Qed. Lemma distributeHides_app_TraceInclusion (m1 m2 : Mod) (hl1 hl2 : list string) (HNeverCall : NeverCallMod m1) : (forall h, In h hl1 -> ~In h (map fst (getAllMethods m1))) -> TraceInclusion (createHideMod (ConcatMod m1 m2) (hl1++hl2)) (createHideMod (ConcatMod m1 (createHideMod m2 hl1)) hl2). Proof. intros. induction hl2; simpl; [rewrite app_nil_r|]. - apply distributeHides_TraceInclusion; auto. - apply TraceInclusion_TraceInclusion' in IHhl2. specialize (TraceInclusion'_HideMeth (s:=a) IHhl2) as P1. specialize (createHides_perm_TraceInclusion (ConcatMod m1 m2) (Permutation_sym (Permutation_middle hl1 hl2 a))) as P2; simpl in *. apply TraceInclusion'_TraceInclusion in P1. eauto using TraceInclusion_trans. Qed. Lemma factorHideWf ty (m1 m2 : Mod) (h : string) (HNeverCall : NeverCallMod m1): WfMod ty (ConcatMod m1 (HideMeth m2 h)) -> WfMod ty (HideMeth (ConcatMod m1 m2) h) /\ ~ In h (map fst (getAllMethods m1)). Proof. intros. inv H. split. - constructor; simpl; inv HWf2. + rewrite map_app, in_app_iff. right; assumption. + constructor; auto. clear - WfConcat1 HNeverCall. inv WfConcat1; constructor; intros. * induction HNeverCall; simpl in *; eauto. -- inv HNCBaseModule. specialize (H _ H1). specialize (H2 _ ty H1). clear - H H2. induction H; inv H2; EqDep_subst; econstructor; eauto. tauto. -- rewrite in_app_iff in *. destruct H1. ++ apply IHHNeverCall1; intros; eauto; [eapply H| eapply H0];rewrite in_app_iff; left; assumption. ++ apply IHHNeverCall2; intros; eauto; [eapply H| eapply H0];rewrite in_app_iff; right; assumption. * induction HNeverCall; simpl in *; eauto. -- inv HNCBaseModule. specialize (H0 _ H1 v). specialize (H3 _ ty H1 v). clear - H0 H3. induction H0; inv H3; EqDep_subst; econstructor; eauto. tauto. -- rewrite in_app_iff in *. destruct H1. ++ apply IHHNeverCall1; intros; eauto; [eapply H| eapply H0];rewrite in_app_iff; left; assumption. ++ apply IHHNeverCall2; intros; eauto; [eapply H| eapply H0];rewrite in_app_iff; right; assumption. - intro. inv HWf2. simpl in *. clear - HDisjMeths H HHideWf. specialize (HDisjMeths h); tauto. Qed. Lemma factorHidesWf ty (m1 m2 : Mod) (hl1 hl2: list string) (HNeverCall : NeverCallMod m1): WfMod ty (createHideMod (ConcatMod m1 (createHideMod m2 hl1)) hl2) -> WfMod ty (createHideMod (ConcatMod m1 m2) (hl1++hl2)) /\ (forall h, In h hl1 -> ~ In h (map fst (getAllMethods m1))). Proof. induction hl1; simpl in *; auto. intros. rewrite WfMod_createHideMod in H; dest; split; intros;[constructor|]. - rewrite getAllMethods_createHideMod; simpl in *. rewrite map_app, in_app_iff, getAllMethods_createHideMod in *. inv H0; inv HWf2. rewrite getAllMethods_createHideMod in *. right; assumption. - specialize (factorHideWf HNeverCall H0) as P0; dest. eapply IHhl1. rewrite WfMod_createHideMod; split; auto. inv H1; assumption. - destruct H1; subst. + inv H0; inv HWf2. rewrite getAllMethods_createHideMod in *. specialize (HDisjMeths h); simpl in *; rewrite getAllMethods_createHideMod in *. clear - HHideWf HDisjMeths; tauto. + eapply IHhl1; auto. rewrite WfMod_createHideMod; split; auto. specialize (factorHideWf HNeverCall H0) as P0; dest. inv H2; assumption. Qed. Lemma factorHide_TraceInclusion (m1 m2 : Mod) (h : string) (HNeverCall : NeverCallMod m1): ~In h (map fst (getAllMethods m1)) -> TraceInclusion (ConcatMod m1 (HideMeth m2 h) ) (HideMeth (ConcatMod m1 m2) h). Proof. intros. apply TraceInclusion'_TraceInclusion, StrongTI'_TI'. repeat intro. induction H0; subst; simpl in *. - exists nil; split;[econstructor; eauto|apply WeakInclusionsRefl]. - dest. exists (l::x); split. + econstructor 2; eauto. econstructor 2; inv HStep. * inv HStep2. econstructor 3; eauto. clear - HMatching1 HNeverCall. unfold MatchingExecCalls_Concat in *. intros; simpl in *; split;[|eapply HMatching1; eauto]. specialize (HMatching1 _ H H0); dest. apply Decidable.not_or in H1; dest; assumption. * intros; inv HStep2. unfold MatchingExecCalls_Concat, getListFullLabel_diff in *; simpl in *. specialize (HHidden v). rewrite map_app, in_app_iff in *; destruct H3; [apply (in_map fst) in H3; rewrite fst_getKindAttr in H3; tauto | specialize (HHidden H3)]. rewrite getNumExecs_app, getNumCalls_app. specialize (Step_NeverCall_getNumCalls_0 HNeverCall HStep1 (h, v)) as P0. specialize (NotInDef_ZeroExecs_Step (h, v) H HStep1) as P1. clear - HHidden P0 P1; omega. + constructor;[assumption |apply WeakInclusionRefl]. Qed. Lemma factorHides_TraceInclusion1 (m1 m2 : Mod) (hl : list string) (HNeverCall : NeverCallMod m1): (forall h, In h hl -> ~In h (map fst (getAllMethods m1))) -> TraceInclusion (ConcatMod m1 (createHideMod m2 hl)) (createHideMod (ConcatMod m1 m2) hl). Proof. induction hl; simpl; intros. - apply TraceInclusion_refl. - assert (forall h : string, In h hl -> ~ In h (map fst (getAllMethods m1))) as TMP. {intros; eapply H; right; assumption. } specialize (IHhl TMP); clear TMP. specialize (TraceInclusion_HideMeth IHhl (s:=a)) as P1. specialize (factorHide_TraceInclusion (m2:=createHideMod m2 hl) HNeverCall (H _ (or_introl eq_refl))) as P2. eauto using TraceInclusion_trans. Qed. Lemma factorHides_TraceInclusion_app (m1 m2 : Mod) (hl1 hl2 : list string) (HNeverCall : NeverCallMod m1): (forall h, In h hl1 -> ~In h (map fst (getAllMethods m1))) -> TraceInclusion (createHideMod (ConcatMod m1 (createHideMod m2 hl1)) hl2) (createHideMod (ConcatMod m1 m2) (hl1++hl2)). Proof. induction hl2; simpl;[rewrite app_nil_r|]. - intros. apply factorHides_TraceInclusion1; auto. - intros; specialize (TraceInclusion_HideMeth (IHhl2 H) (s:=a)) as P0. specialize (createHides_perm_TraceInclusion (ConcatMod m1 m2) (Permutation_middle hl1 hl2 a)) as P1. simpl in *. eauto using TraceInclusion_trans. Qed. Lemma removeMeth_neg (m : BaseModule) (f g : string): (g <> f /\ In f (map fst (getMethods m))) <-> In f (map fst (getMethods (removeMeth m g))). Proof. intros. split; intros. - simpl in *. rewrite in_map_iff in *; dest. exists x; split; subst; auto. rewrite filter_In; split; auto. destruct String.eqb eqn:G; [rewrite String.eqb_eq in G|]; simpl in *; auto. - split; simpl in *; rewrite in_map_iff in *; dest. + rewrite filter_In in H0; dest. destruct String.eqb eqn:G; [| rewrite String.eqb_neq in G]; subst; auto. discriminate. + exists x; split; auto; rewrite filter_In in *; dest; assumption. Qed. Lemma removeMeth_neg' (m : BaseModule) (f : DefMethT) (g : string): (g <> fst f /\ In f (getMethods m)) <-> In f (getMethods (removeMeth m g)). Proof. intros; split; intros; dest. - simpl in *. rewrite filter_In; split; auto. destruct String.eqb eqn:G; [rewrite String.eqb_eq in G|]; simpl in *; auto. - simpl in *; rewrite filter_In in *; dest; split; auto. rewrite negb_true_iff, eqb_neq in H0; assumption. Qed. Lemma removeHides_neg (m : BaseModule) (l : list string): forall f, In f (map fst (getMethods m)) /\ ~ In f l <-> In f (map fst (getMethods (removeHides m l))). Proof. intros; split; dest. - intros; induction l; dest. + simpl in *; rewrite (filter_true_list); auto. + rewrite removeMeth_removeHides_cons. simpl in H0; apply Decidable.not_or in H0; dest. rewrite <- removeMeth_neg; eauto. - intros; split; auto; induction l; auto. + simpl in H; rewrite in_map_iff in *; dest. rewrite filter_true_list in H0; auto. exists x; split; auto. + rewrite removeMeth_removeHides_cons in H. rewrite <- removeMeth_neg in H; dest; auto. + rewrite removeMeth_removeHides_cons in H. rewrite <- removeMeth_neg in H; dest. intro; inv H1; auto. apply IHl; assumption. Qed. Lemma removeHides_neg' (m : BaseModule) (l : list string): forall f, In f (getMethods m) /\ ~ In (fst f) l <-> In f (getMethods (removeHides m l)). Proof. intros; split; intros; dest. - induction l. + simpl in *; rewrite (filter_true_list); auto; intros. + rewrite removeMeth_removeHides_cons. simpl in H0; apply Decidable.not_or in H0; dest. rewrite <- removeMeth_neg'; auto. - induction l; split; auto. + simpl in H; rewrite filter_true_list in H; auto. + rewrite removeMeth_removeHides_cons in H. rewrite <- removeMeth_neg' in H; dest. apply IHl; assumption. + rewrite removeMeth_removeHides_cons in H. rewrite <- removeMeth_neg' in H; dest. intro; inv H1; auto. apply IHl; assumption. Qed. Lemma createHideMod_createHide_BaseModule (m : BaseModule) (l : list string) : (createHide m l) = (createHideMod m l). Proof. induction l; simpl in *; auto. rewrite IHl; reflexivity. Qed. Lemma Concat_removeHide (m1 : Mod) {m2 : BaseModule} (hl1 hl2 : list string) (NoSelfCall : NoSelfCallBaseModule m2): WfMod type (createHideMod (ConcatMod m1 (createHideMod m2 hl1)) hl2) -> TraceInclusion (createHideMod (ConcatMod m1 (createHideMod m2 hl1)) hl2) (createHideMod (ConcatMod m1 (removeHides m2 hl1)) hl2). Proof. intros. rewrite WfMod_createHideMod in H; dest. apply TraceInclusion_createHideMod. apply ModularSubstitution; auto. - intros; apply iff_refl. - intros; split; intros; split; dest; auto. + rewrite in_map_iff in H1; dest. rewrite in_map_iff; exists x0; split; auto. apply removeHides_neg'; split. * rewrite getAllMethods_createHideMod in *; assumption. * rewrite getHidden_createHideMod, in_app_iff in *; apply Decidable.not_or in H2; dest. inv H1; rewrite H6; assumption. + assert (getAllMethods (removeHides m2 hl1) = getMethods (removeHides m2 hl1)) as P0; auto; rewrite P0 in *. rewrite in_map_iff in *; dest; exists x0; split; auto. rewrite <- removeHides_neg', getAllMethods_createHideMod in *; dest; assumption. + assert (getAllMethods (removeHides m2 hl1) = getMethods (removeHides m2 hl1)) as P0; auto; rewrite P0 in *. rewrite in_map_iff in *; dest. rewrite <- removeHides_neg', getHidden_createHideMod, in_app_iff in * ; dest; intro; apply H4. destruct H5;[inv H1; rewrite H7; assumption| simpl in *; tauto]. - inv H0; constructor; simpl in *; auto. + rewrite getAllRegisters_createHideMod in *; assumption. + rewrite getAllRules_createHideMod in *; assumption. + repeat intro; specialize (HDisjMeths k). destruct HDisjMeths; auto. right; intro; apply H0. rewrite in_map_iff in *; dest; rewrite filter_In in *; dest. exists x; split; auto; rewrite getAllMethods_createHideMod. assumption. + constructor; apply removeHidesWf. rewrite WfMod_createHideMod in HWf2; dest; inv H1. assumption. + inv WfConcat1; constructor. * intros; specialize (H0 _ H2). clear - H0. induction H0; econstructor; eauto. * intros; specialize (H1 _ H2 v). clear - H1. induction H1; econstructor; eauto. + inv WfConcat2; constructor. * intros; simpl in *. rewrite getAllRules_createHideMod in *. specialize (H0 _ H2); assumption. * intros; simpl in *. rewrite filter_In in *; dest. rewrite getAllMethods_createHideMod in *. specialize (H1 _ H2 v); assumption. - apply TraceInclusion_refl. - inv H0. rewrite WfMod_createHideMod in *; dest. inv H1. specialize (createHide_removeHides_TraceInclusion (Build_BaseModuleWf HWfBaseModule)) as P0. simpl in *. rewrite <- createHideMod_createHide_BaseModule. apply P0; auto. Qed. Lemma removeMeth_removes (m : BaseModule) (f : string): ~In f (map fst (getMethods (removeMeth m f))). Proof. rewrite in_map_iff; intro; dest. simpl in *; rewrite filter_In in *; dest. subst; rewrite String.eqb_refl in H1; discriminate. Qed. Lemma removeHides_removes (m : BaseModule) (hl : list string): forall f, In f hl -> ~In f (map fst (getMethods (removeHides m hl))). Proof. intros. induction hl. - simpl in *; tauto. - rewrite removeMeth_removeHides_cons. inv H. + apply removeMeth_removes. + specialize (IHhl H0). intro; apply IHhl. rewrite in_map_iff in *; dest; simpl in *. exists x; split; auto. repeat rewrite filter_In in *; dest; split; auto. Qed. Lemma Concat_createHide (m1 : Mod) {m2 : BaseModule} (hl1 hl2 : list string) (NoSelfCall : NoSelfCallBaseModule m2): WfMod type (createHideMod (ConcatMod m1 (createHideMod m2 hl1)) hl2) -> TraceInclusion (createHideMod (ConcatMod m1 (removeHides m2 hl1)) hl2) (createHideMod (ConcatMod m1 (createHideMod m2 hl1)) hl2). Proof. intros. rewrite WfMod_createHideMod in H; dest. apply TraceInclusion_createHideMod. apply ModularSubstitution; auto. - intros; apply iff_refl. - intros; split; intros; split; dest; auto. + assert (getAllMethods (removeHides m2 hl1) = getMethods (removeHides m2 hl1)) as P0; auto; rewrite P0 in *. rewrite in_map_iff in *; dest; exists x0; split; auto. rewrite <- removeHides_neg', getAllMethods_createHideMod in *; dest; assumption. + assert (getAllMethods (removeHides m2 hl1) = getMethods (removeHides m2 hl1)) as P0; auto; rewrite P0 in *. rewrite in_map_iff in *; dest. rewrite <- removeHides_neg', getHidden_createHideMod, in_app_iff in * ; dest; intro; apply H4. destruct H5;[inv H1; rewrite H7; assumption| simpl in *; tauto]. + rewrite in_map_iff in *; dest. exists x0; split; auto. apply removeHides_neg'; split. * rewrite getAllMethods_createHideMod in *; assumption. * rewrite getHidden_createHideMod, in_app_iff in *; apply Decidable.not_or in H2; dest. inv H1; rewrite H6; assumption. - inv H0; constructor; simpl in *; auto. + rewrite getAllRegisters_createHideMod in *; assumption. + rewrite getAllRules_createHideMod in *; assumption. + repeat intro; specialize (HDisjMeths k). destruct HDisjMeths; auto. right; intro; apply H0. rewrite in_map_iff in *; dest; rewrite filter_In in *; dest. exists x; split; auto; rewrite getAllMethods_createHideMod. assumption. + constructor; apply removeHidesWf. rewrite WfMod_createHideMod in HWf2; dest; inv H1. assumption. + inv WfConcat1; constructor. * intros; specialize (H0 _ H2). clear - H0. induction H0; econstructor; eauto. * intros; specialize (H1 _ H2 v). clear - H1. induction H1; econstructor; eauto. + inv WfConcat2; constructor. * intros; simpl in *. rewrite getAllRules_createHideMod in *. specialize (H0 _ H2); assumption. * intros; simpl in *. rewrite filter_In in *; dest. rewrite getAllMethods_createHideMod in *. specialize (H1 _ H2 v); assumption. - apply TraceInclusion_refl. - inv H0. rewrite WfMod_createHideMod in *; dest. inv H1. specialize (removeHides_createHide_TraceInclusion (m := (Build_BaseModuleWf HWfBaseModule)) H0) as P0. simpl in *. rewrite <- createHideMod_createHide_BaseModule. apply P0; auto. Qed. Lemma RegFileBase_noCalls (rf : RegFileBase) : NeverCallMod (BaseRegFile rf). Proof. constructor; split; simpl; intros;[tauto|]. unfold getRegFileMethods in *. destruct rf; simpl in *. destruct H; subst; simpl in *. - destruct rfIsWrMask; repeat econstructor; eauto. - destruct rfRead; induction reads; simpl in *. + tauto. + destruct H; subst. * repeat econstructor. * eauto. + unfold readSyncRegFile in *. destruct isAddr; simpl in *;tauto. + unfold readSyncRegFile in *; simpl in *. destruct isAddr. * simpl in H; destruct H; subst. -- repeat econstructor. -- repeat rewrite in_app_iff in *. destruct H. ++ apply IHreads; auto. ++ inv H; [repeat econstructor| eauto]. * inv H. -- repeat econstructor. -- rewrite in_app_iff in *. destruct H0; eauto. inv H;[repeat econstructor|eauto]. Qed. Corollary mergeFile_noCalls (rfl : list RegFileBase) : NeverCallMod (mergeSeparatedBaseFile rfl). Proof. induction rfl. - simpl. constructor; split; simpl; intros; tauto. - simpl. constructor; auto. apply RegFileBase_noCalls. Qed. Lemma WfConcatActionT_inlineSingle_Meth {ty} {k : Kind} (f: DefMethT) (a : ActionT ty k) m: (forall v, WfConcatActionT (projT2 (snd f) ty v) m) -> WfConcatActionT a m -> WfConcatActionT (inlineSingle a f) m. Proof. intros. induction a; unfold inlineSingle; inv H0; EqDep_subst; try econstructor; eauto. destruct String.eqb;[destruct Signature_dec|]; subst; simpl in *; econstructor; eauto. econstructor; eauto. Qed. Lemma WfConcatActionT_inlineSingle_Rule_map ty rule (f : DefMethT) rules m: (forall v, WfConcatActionT (projT2 (snd f) ty v) m) -> In rule (map (inlineSingle_Rule f) rules) -> (forall rule', In rule' rules -> WfConcatActionT (snd rule' ty) m) -> WfConcatActionT (snd rule ty) m. Proof. intros. induction rules; simpl in *;[tauto|]. destruct H0; subst; eauto. specialize (H1 _ (or_introl (eq_refl _))). unfold inlineSingle_Rule; destruct a, f; simpl in *. eapply WfConcatActionT_inlineSingle_Meth; eauto. Qed. Lemma WfConcatActionT_inlineSingle_Meth_map ty meth (f : DefMethT) meths m: (forall v, WfConcatActionT (projT2 (snd f) ty v) m) -> In meth (map (inlineSingle_Meth f) meths) -> (forall meth', In meth' meths -> (forall v', WfConcatActionT (projT2 (snd meth') ty v') m)) -> (forall v, WfConcatActionT (projT2 (snd meth) ty v) m). Proof. intros. induction meths; simpl in *;[tauto|]. destruct H0; subst; eauto. specialize (H1 _ (or_introl (eq_refl _))). unfold inlineSingle_Meth; destruct a, f; simpl in *. destruct (String.eqb s1 s), s0; subst; simpl; eauto. eapply WfConcatActionT_inlineSingle_Meth; eauto. Qed. Lemma WfConcatActionT_inlineSingle_Rule_pos ty rule meths m xs: (forall (f : DefMethT), In f meths -> (forall v, WfConcatActionT (projT2 (snd f) ty v) m)) -> forall (rules : list RuleT), (forall rule', In rule' rules -> WfConcatActionT (snd rule' ty) m) -> In rule (fold_left (fun (newRules : list RuleT) (n : nat) => inlineSingle_Rules_pos meths n newRules) xs rules) -> WfConcatActionT (snd rule ty) m. Proof. induction xs; simpl; intros; simpl in *; auto. eapply IHxs;[ | | apply H1]; eauto. unfold inlineSingle_Rules_pos in *. case_eq (nth_error meths a); intros; eauto. rewrite H2 in H1. eapply WfConcatActionT_inlineSingle_Rule_map; eauto. apply H. apply (nth_error_In _ _ H2). Qed. Lemma WfConcatActionT_inlineSingle_Meth_pos ty meth m xs: forall meths, (forall (f : DefMethT), In f meths -> (forall v, WfConcatActionT (projT2 (snd f) ty v) m)) -> In meth (fold_left inlineSingle_Meths_pos xs meths) -> (forall v, WfConcatActionT (projT2 (snd meth) ty v) m). Proof. induction xs; simpl; intros; simpl in *; auto. eapply IHxs;[|apply H0]. intros. unfold inlineSingle_Meths_pos in H1. case_eq (nth_error meths a); intros. - rewrite H2 in H1. eapply WfConcatActionT_inlineSingle_Meth_map; eauto. eapply H. apply (nth_error_In _ _ H2). - rewrite H2 in H1. apply H; auto. Qed. Corollary WfConcatActionT_inlineAll_Meths ty meth meths m: (forall (f : DefMethT), In f meths -> (forall v, WfConcatActionT (projT2 (snd f) ty v) m)) -> In meth (inlineAll_Meths meths) -> (forall v, WfConcatActionT (projT2 (snd meth) ty v) m). Proof. unfold inlineAll_Meths. eauto using WfConcatActionT_inlineSingle_Meth_pos. Qed. Corollary WfConcatActionT_inlineAll_Rules ty rule (rules : list RuleT) meths m: (forall (f : DefMethT), In f meths -> (forall v, WfConcatActionT (projT2 (snd f) ty v) m)) -> (forall rule', In rule' rules -> WfConcatActionT (snd rule' ty) m) -> In rule (inlineAll_Rules meths rules) -> WfConcatActionT (snd rule ty) m. Proof. unfold inlineAll_Rules. eauto using WfConcatActionT_inlineSingle_Rule_pos. Qed. Lemma mergeSeparatedDistributed_Wf ty (m : ModWf ty): let t := separateModHides m in WfMod ty (createHideMod (ConcatMod (mergeSeparatedBaseFile (fst (snd t))) (snd (snd t))) (fst t)). Proof. specialize (WfMod_merge (wfMod m)) as P0. unfold mergeSeparatedMod, separateMod in P0; simpl in *. unfold separateModHides, separateMod. destruct separateBaseMod; simpl in *. specialize (separate_calls_by_filter (getHidden m) (hiddenByBase (map BaseRegFile l))) as P1. rewrite Permutation_app_comm in P1. apply (WfMod_perm _ P1) in P0. apply distributeHidesWf in P0. - rewrite WfMod_createHideMod in *; dest; split. + clear - H; simpl in *. unfold flatten_inline_everything. rewrite createHide_Meths. unfold inlineAll_All_mod; simpl. rewrite map_app, <-SameKeys_inlineAll_Meths, getAllMethods_createHideMod in *. assumption. + clear - H0. inv H0; constructor; auto. * rewrite createHide_Regs, getAllRegisters_createHideMod in *; assumption. * rewrite createHide_Rules, getAllRules_createHideMod in *; simpl. intro k; destruct (HDisjRules k); auto; right. rewrite <- SameKeys_inlineAll_Rules; assumption. * rewrite createHide_Meths, getAllMethods_createHideMod in *; simpl. intro k; destruct (HDisjMeths k); auto; right. rewrite <- SameKeys_inlineAll_Meths; assumption. * rewrite WfMod_createHideMod in HWf2; dest. rewrite WfMod_createHide; split; auto. -- unfold inlineAll_All_mod; simpl. rewrite <- SameKeys_inlineAll_Meths; assumption. -- unfold inlineAll_All_mod; constructor. specialize (WfMod_WfBaseMod_flat H0) as P0. unfold getFlat in P0. apply (WfBaseMod_inlineAll_All P0). * clear - WfConcat1. assert (getHidden (createHide (inlineAll_All_mod (mergeSeparatedBaseMod l0)) (filter (complement (hiddenByBase (map BaseRegFile l))) (getHidden m))) = getHidden (createHideMod (mergeSeparatedBaseMod l0) (filter (complement (hiddenByBase (map BaseRegFile l))) (getHidden m))) ) as P0. { rewrite createHide_hides, getHidden_createHideMod, mergeSeparatedBaseMod_noHides, app_nil_r; reflexivity. } inv WfConcat1; split; intros. -- specialize (H _ H1). clear - H P0. induction H; econstructor; eauto. rewrite P0; assumption. -- specialize (H0 _ H1 v). clear - H0 P0. induction H0; econstructor; eauto. rewrite P0; assumption. * clear - WfConcat2. inv WfConcat2; split; intros. -- rewrite createHide_Rules in H1; simpl in H1. rewrite getAllRules_createHideMod in *. rewrite getAllMethods_createHideMod in *. assert (forall meth, In meth (inlineAll_Meths (getAllMethods (mergeSeparatedBaseMod l0))) -> forall v : ty (fst (projT1 (snd meth))), WfConcatActionT (projT2 (snd meth) ty v) (mergeSeparatedBaseFile l)). { intros. eapply WfConcatActionT_inlineAll_Meths; eauto. } clear H0. eapply WfConcatActionT_inlineAll_Rules; eauto. -- rewrite createHide_Meths in H1; simpl in H1. rewrite getAllMethods_createHideMod in *. eapply WfConcatActionT_inlineAll_Meths; eauto. - apply mergeFile_noCalls. - intros. clear - H. unfold hiddenByBase, hiddenBy in *. rewrite filter_In in *; dest. destruct existsb eqn:G; simpl in *;[discriminate|]. rewrite existsb_nexists_str in G; auto. induction l; simpl in *; auto. unfold getAllBaseMethods in G; simpl in G. rewrite map_app, in_app_iff in *. intros [|]. elim G; tauto. apply IHl; tauto. Qed. Definition mergeSeparatedDistributed_ModWf {ty} (m : ModWf ty) : ModWf ty := Build_ModWf (mergeSeparatedDistributed_Wf m). Lemma ConcatMod_CreateHide_RemoveHides ty (m1 : Mod) (m2 : BaseModule) (hl1 hl2 : list string): (forall h, ~In h hl1 \/ ~In h hl2) -> WfMod ty (createHideMod (ConcatMod m1 (createHide m2 hl1)) hl2)-> WfMod ty (createHideMod (ConcatMod m1 (removeHides m2 hl1)) hl2). Proof. intros. rewrite WfMod_createHideMod in *; split; dest. - repeat intro. specialize (H0 _ H2). simpl in *; rewrite map_app, in_app_iff in *. destruct H0; auto. right. rewrite createHide_Meths in *. rewrite in_map_iff in *; dest. exists x0; split; auto. rewrite filter_In; split; auto. destruct existsb eqn:G; simpl in *; auto. rewrite existsb_exists in G; dest. rewrite String.eqb_eq in H5. elim (H x); congruence. - clear - H1. inv H1; rewrite createHide_Rules, createHide_Meths, createHide_Regs in *. constructor; simpl; auto. + intro; destruct (HDisjMeths k); auto. clear - H; right; rewrite in_map_iff in *; intro; apply H; dest. rewrite filter_In in *; dest. exists x; auto. + rewrite WfMod_createHide in HWf2; dest. clear - H0. inv H0; constructor. apply removeHidesWf; auto. + unfold WfConcat in *; dest; repeat split. * clear - H1; intros. specialize (H1 _ H). induction H1; econstructor; eauto. * clear - H2; intros. specialize (H2 _ H v). induction H2; econstructor; eauto. + unfold WfConcat in *; dest; repeat split. * clear - H; intros. rewrite createHide_Rules in *. simpl in *. specialize (H _ H0). induction H; econstructor; eauto. * clear - H0; intros. rewrite createHide_Meths in *. simpl in *. rewrite filter_In in *; dest. specialize (H0 _ H v). induction H0; econstructor; eauto. Qed. Lemma mergeSeparatedRemoved_Wf ty (m : ModWf ty): let t := separateModRemove m in WfMod ty (createHideMod (ConcatMod (mergeSeparatedBaseFile (fst (snd t))) (snd (snd t))) (fst t)). Proof. intros. specialize (mergeSeparatedDistributed_Wf m); intros. unfold separateModHides, separateModRemove in *. unfold t; destruct separateMod, p; simpl in *. apply ConcatMod_CreateHide_RemoveHides; auto. clear. specialize (filter_complement_disj string_dec (hiddenByBase (map BaseRegFile l0)) l) as P0. intro h; specialize (P0 h); destruct P0; auto. Qed. Lemma mergeSeparatedRemoved_Wf_new ty (m : ModWf_new ty): let t := separateModRemove m in WfMod_new ty (createHideMod (ConcatMod (mergeSeparatedBaseFile (fst (snd t))) (snd (snd t))) (fst t)). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. rewrite WfMod_new_WfMod_iff. eapply (@mergeSeparatedRemoved_Wf _ m'). Qed. Definition mergeSeparatedRemoved_ModWf {ty} (m : ModWf ty) : ModWf ty := Build_ModWf (mergeSeparatedRemoved_Wf m). Definition mergeSeparatedRemoved_ModWf_new {ty} (m : ModWf_new ty) : ModWf_new ty := Build_ModWf_new _ _ (mergeSeparatedRemoved_Wf_new m). Lemma mergeSeparatedRemoved_TraceInclusion_l (m : ModWf type): baseNoSelfCalls m -> TraceInclusion (mergeSeparatedRemoved_ModWf m) m. Proof. specialize (WfMod_merge (wfMod m)) as P0. specialize (TraceInclusion_Merge_r m) as P1; simpl in *; unfold mergeSeparatedMod in *. specialize (mergeSeparatedDistributed_Wf m) as P2. intros; simpl; unfold separateModRemove, separateModHides, baseNoSelfCalls in *. destruct separateMod, p; simpl in *. rewrite createHideMod_createHide_BaseModule in P2. specialize (Concat_createHide _ _ _ H P2) as P3. specialize (mergeFile_noCalls l0) as P4. assert (forall h, In h (filter (complement (hiddenByBase (map BaseRegFile l0))) l) -> ~ In h (map fst (getAllMethods (mergeSeparatedBaseFile l0)))) as P5. { repeat intro. rewrite filter_In in H0; dest. unfold hiddenByBase, getAllBaseMethods, hiddenBy in H2. destruct existsb eqn:G; [discriminate|]. clear - G H1. rewrite existsb_nexists_str in G. induction l0; simpl in *; auto. rewrite map_app, in_app_iff in *. apply Decidable.not_or in G; dest. destruct H1; auto. } specialize (factorHides_TraceInclusion_app (inlineAll_All_mod (mergeSeparatedBaseMod l1)) _ (filter (hiddenByBase (map BaseRegFile l0)) l) P4 P5) as P6. specialize (createHides_perm_TraceInclusion (ConcatMod (mergeSeparatedBaseFile l0) (inlineAll_All_mod (mergeSeparatedBaseMod l1))) (Permutation_sym (Permutation_trans (separate_calls_by_filter l (hiddenByBase (map BaseRegFile l0))) (Permutation_app_comm _ _)))) as P7. assert (TraceInclusion (createHideMod (ConcatMod (mergeSeparatedBaseFile l0) (inlineAll_All_mod (mergeSeparatedBaseMod l1))) l) (createHideMod (ConcatMod (mergeSeparatedBaseFile l0) (mergeSeparatedBaseMod l1)) l)). { apply TraceInclusion_createHideMod. apply ModularSubstitution. - reflexivity. - simpl; rewrite <-SameKindAttrs_inlineAll_Meths, mergeSeparatedBaseMod_noHides. reflexivity. - rewrite WfMod_createHideMod in P0; dest. inv H1. constructor; auto. + clear - HDisjRules. intro k; specialize (HDisjRules k); simpl. rewrite <-SameKeys_inlineAll_Rules. assumption. + clear - HDisjMeths. intro k; specialize (HDisjMeths k); simpl. rewrite <-SameKeys_inlineAll_Meths. assumption. + unfold inlineAll_All_mod. specialize (WfMod_WfBase_getFlat HWf2) as TMP2. unfold getFlat in TMP2. apply (TraceInclusion_inlineAll_pos TMP2). + clear - WfConcat1. unfold WfConcat in *; split; dest; intros. * specialize (H _ H1); induction H; econstructor; eauto. * specialize (H0 _ H1 v); induction H0; econstructor; eauto. + clear - WfConcat2. unfold WfConcat in *; split; dest; intros. * induction (snd rule type); econstructor; eauto. rewrite mergeSeparatedBaseFile_noHides; auto. * induction (projT2 (snd meth) type v); econstructor; eauto. rewrite mergeSeparatedBaseFile_noHides; auto. - rewrite WfMod_createHideMod in P0; dest. assumption. - apply TraceInclusion_refl. - unfold inlineAll_All_mod. rewrite WfMod_createHideMod in P0; dest. inv H1. specialize (TraceInclusion_inlineAll_pos_l (WfMod_WfBase_getFlat HWf2)) as TMP2; dest. specialize (TraceInclusion_flatten_l (Build_ModWf HWf2)) as TMP3; simpl in *. unfold flatten, getFlat in *. rewrite mergeSeparatedBaseMod_noHides in TMP3; simpl in *. eauto using TraceInclusion_trans. } eauto using TraceInclusion_trans. Qed. Theorem mergeSeparatedRemoved_TraceInclusion_l_new (m : ModWf_new type): baseNoSelfCalls m -> TraceInclusion (mergeSeparatedRemoved_ModWf_new m) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@mergeSeparatedRemoved_TraceInclusion_l m'). Qed. Lemma mergeSeparatedRemoved_TraceInclusion_r (m : ModWf type): baseNoSelfCalls m -> TraceInclusion m (mergeSeparatedRemoved_ModWf m). Proof. specialize (WfMod_merge (wfMod m)) as P0. specialize (TraceInclusion_Merge_l m) as P1; simpl in *; unfold mergeSeparatedMod in *. specialize (mergeSeparatedDistributed_Wf m) as P2. intros; simpl; unfold separateModRemove, separateModHides, baseNoSelfCalls in *. destruct separateMod, p; simpl in *. rewrite createHideMod_createHide_BaseModule in P2. specialize (Concat_removeHide _ _ _ H P2) as P3. specialize (mergeFile_noCalls l0) as P4. assert (forall h, In h (filter (complement (hiddenByBase (map BaseRegFile l0))) l) -> ~ In h (map fst (getAllMethods (mergeSeparatedBaseFile l0)))) as P5. { repeat intro. rewrite filter_In in H0; dest. unfold hiddenByBase, getAllBaseMethods, hiddenBy in H2. destruct existsb eqn:G; [discriminate|]. clear - G H1. rewrite existsb_nexists_str in G. induction l0; simpl in *; auto. rewrite map_app, in_app_iff in *. apply Decidable.not_or in G; dest. destruct H1; auto. } specialize (distributeHides_app_TraceInclusion (inlineAll_All_mod (mergeSeparatedBaseMod l1)) _ (filter (hiddenByBase (map BaseRegFile l0)) l) P4 P5) as P6. specialize (createHides_perm_TraceInclusion (ConcatMod (mergeSeparatedBaseFile l0) (inlineAll_All_mod (mergeSeparatedBaseMod l1))) (Permutation_trans (separate_calls_by_filter l (hiddenByBase (map BaseRegFile l0))) (Permutation_app_comm _ _))) as P7. assert (TraceInclusion (createHideMod (ConcatMod (mergeSeparatedBaseFile l0) (mergeSeparatedBaseMod l1)) l) (createHideMod (ConcatMod (mergeSeparatedBaseFile l0) (inlineAll_All_mod (mergeSeparatedBaseMod l1))) l)). { apply TraceInclusion_createHideMod. apply ModularSubstitution. - reflexivity. - simpl; rewrite <-SameKindAttrs_inlineAll_Meths, mergeSeparatedBaseMod_noHides. reflexivity. - rewrite WfMod_createHideMod in P0; dest. assumption. - rewrite WfMod_createHideMod in P0; dest. inv H1. constructor; auto. + clear - HDisjRules. intro k; specialize (HDisjRules k); simpl. rewrite <-SameKeys_inlineAll_Rules. assumption. + clear - HDisjMeths. intro k; specialize (HDisjMeths k); simpl. rewrite <-SameKeys_inlineAll_Meths. assumption. + unfold inlineAll_All_mod. specialize (WfMod_WfBase_getFlat HWf2) as TMP2. unfold getFlat in TMP2. apply (TraceInclusion_inlineAll_pos TMP2). + clear - WfConcat1. unfold WfConcat in *; split; dest; intros. * specialize (H _ H1); induction H; econstructor; eauto. * specialize (H0 _ H1 v); induction H0; econstructor; eauto. + clear - WfConcat2. unfold WfConcat in *; split; dest; intros. * induction (snd rule type); econstructor; eauto. rewrite mergeSeparatedBaseFile_noHides; auto. * induction (projT2 (snd meth) type v); econstructor; eauto. rewrite mergeSeparatedBaseFile_noHides; auto. - apply TraceInclusion_refl. - unfold inlineAll_All_mod. rewrite WfMod_createHideMod in P0; dest. inv H1. specialize (TraceInclusion_inlineAll_pos (WfMod_WfBase_getFlat HWf2)) as TMP2; dest. specialize (TraceInclusion_flatten_r (Build_ModWf HWf2)) as TMP3; simpl in *. unfold flatten, getFlat in *. rewrite mergeSeparatedBaseMod_noHides in TMP3; simpl in *. eauto using TraceInclusion_trans. } eauto using TraceInclusion_trans. Qed. Theorem mergeSeparatedRemoved_TraceInclusion_r_new (m : ModWf_new type): baseNoSelfCalls m -> TraceInclusion m (mergeSeparatedRemoved_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (@mergeSeparatedRemoved_TraceInclusion_r m'). Qed. (* Begin Basic Properties *) Lemma NoCallActionT_SubList k ty (a : ActionT ty k): forall l1 l2, SubList l2 l1 -> NoCallActionT l1 a -> NoCallActionT l2 a. Proof. induction a; intros; (inv H1 || inv H0); EqDep_subst; econstructor; eauto. intro; apply H5; rewrite in_map_iff in *; dest; inv H1. exists x; split; auto. Qed. Lemma NoCallActionT_Stitch k ty (a : ActionT ty k) : forall l1 l2, NoCallActionT l1 a -> NoCallActionT l2 a -> NoCallActionT (l1 ++ l2) a. Proof. induction a; intros; inv H0; (inv H1 || inv H); EqDep_subst; econstructor; eauto. rewrite map_app, in_app_iff; intro TMP; destruct TMP as [P0|P0]; [apply H5| apply H4]; assumption. Qed. Lemma inlineSingle_NoCalls_ident k ty (a : ActionT ty k) l f : In f l -> NoCallActionT l a -> inlineSingle a f = a. Proof. induction a; intros; try (inv H1; EqDep_subst; simpl); try (apply f_equal || apply f_equal2 || apply f_equal3); eauto using functional_extensionality. - simpl; remember (String.eqb _ _) as strb; symmetry in Heqstrb; destruct strb. + rewrite String.eqb_eq in *; subst; destruct Signature_dec; subst; [|apply f_equal; eauto using functional_extensionality]. exfalso; apply H5; rewrite in_map_iff; exists f; split; auto. + apply f_equal; eauto using functional_extensionality. - inv H0; EqDep_subst; simpl; apply f_equal; auto. - inv H0; EqDep_subst; simpl; apply f_equal; auto. Qed. Lemma inlineSingle_NoCalls_ident' k ty (a : ActionT ty k) l f : In (fst f, projT1 (snd f)) (getKindAttr l) -> NoCallActionT l a -> inlineSingle a f = a. Proof. induction a; intros; try (inv H1; EqDep_subst; simpl); try (apply f_equal || apply f_equal2 || apply f_equal3); eauto using functional_extensionality. - simpl; remember (String.eqb _ _) as strb; symmetry in Heqstrb; destruct strb. + rewrite String.eqb_eq in *; subst; destruct Signature_dec; subst; [|apply f_equal; eauto using functional_extensionality]. exfalso; apply H5; rewrite in_map_iff; exists f; split; auto. contradiction. + apply f_equal; eauto using functional_extensionality. - inv H0; EqDep_subst; simpl; apply f_equal; auto. - inv H0; EqDep_subst; simpl; apply f_equal; auto. Qed. Lemma inlineSingle_Meth_NoCalls_ident (l : list DefMethT) (f meth : DefMethT): In f l -> (forall ty arg, NoCallActionT l (projT2 (snd meth) ty arg)) -> inlineSingle_Meth f meth = meth. Proof. unfold inlineSingle_Meth; destruct meth, String.eqb; auto. destruct s0; intros. repeat apply f_equal. apply functional_extensionality_dep; intros; apply functional_extensionality; intros. eapply inlineSingle_NoCalls_ident; eauto. Qed. Lemma inlineSingle_Meth_NoCalls_ident' (l : list DefMethT) (f meth : DefMethT): In (fst f, projT1 (snd f)) (getKindAttr l) -> (forall ty arg, NoCallActionT l (projT2 (snd meth) ty arg)) -> inlineSingle_Meth f meth = meth. Proof. unfold inlineSingle_Meth; destruct meth, String.eqb; auto. destruct s0; intros. repeat apply f_equal. apply functional_extensionality_dep; intros; apply functional_extensionality; intros. eapply inlineSingle_NoCalls_ident'; eauto. Qed. Lemma inlineSingle_Rule_NoCalls_ident (l : list DefMethT) (f : DefMethT) (rle : RuleT) : In f l -> (forall ty, NoCallActionT l (snd rle ty)) -> inlineSingle_Rule f rle = rle. Proof. unfold inlineSingle_Rule; destruct rle; intros. apply f_equal, functional_extensionality_dep; intros. eapply inlineSingle_NoCalls_ident; eauto. Qed. Lemma inlineSingle_Rule_NoCalls_ident' (l : list DefMethT) (f : DefMethT) (rle : RuleT) : In (fst f, projT1 (snd f)) (getKindAttr l) -> (forall ty, NoCallActionT l (snd rle ty)) -> inlineSingle_Rule f rle = rle. Proof. unfold inlineSingle_Rule; destruct rle; intros. apply f_equal, functional_extensionality_dep; intros. eapply inlineSingle_NoCalls_ident'; eauto. Qed. Lemma inlineSingle_Meths_pos_NoCalls_ident (l1 l2 : list DefMethT) n : SubList l1 l2 -> (forall meth, In meth l1 -> (forall ty arg, NoCallActionT l2 (projT2 (snd meth) ty arg))) -> inlineSingle_Meths_pos l1 n = l1. Proof. unfold inlineSingle_Meths_pos; remember (nth_error _ _) as nth_err0; symmetry in Heqnth_err0; destruct nth_err0; simpl; auto; intros; apply nth_error_In in Heqnth_err0. rewrite <- (map_id l1) at 2. rewrite forall_map; intros. eapply inlineSingle_Meth_NoCalls_ident with (l := l2); eauto. Qed. Lemma inlineSingle_Meths_pos_NoCalls_ident' (l1 l2 : list DefMethT) n : SubList (getKindAttr l1) (getKindAttr l2) -> (forall meth, In meth l1 -> (forall ty arg, NoCallActionT l2 (projT2 (snd meth) ty arg))) -> inlineSingle_Meths_pos l1 n = l1. Proof. unfold inlineSingle_Meths_pos; remember (nth_error _ _) as nth_err0; symmetry in Heqnth_err0; destruct nth_err0; simpl; auto; intros; apply nth_error_In in Heqnth_err0. rewrite <- (map_id l1) at 2. rewrite forall_map; intros. eapply inlineSingle_Meth_NoCalls_ident' with (l := l2); eauto. apply H; rewrite in_map_iff; exists d; split; auto. Qed. Lemma inlineSingle_Rules_pos_NoCalls_ident (l1 l2 :list DefMethT) n (rules : list RuleT): SubList l1 l2 -> (forall rle, In rle rules -> forall ty, NoCallActionT l2 (snd rle ty)) -> inlineSingle_Rules_pos l1 n rules = rules. Proof. unfold inlineSingle_Rules_pos; remember (nth_error _ _) as nth_err0; symmetry in Heqnth_err0; destruct nth_err0; simpl; auto; intros; apply nth_error_In in Heqnth_err0. rewrite <- (map_id rules) at 2. rewrite forall_map; intros. eapply inlineSingle_Rule_NoCalls_ident with (l := l2); eauto. Qed. Lemma inlineSingle_Rules_pos_NoCalls_ident' (l1 l2 :list DefMethT) n (rules : list RuleT): SubList (getKindAttr l1) (getKindAttr l2) -> (forall rle, In rle rules -> forall ty, NoCallActionT l2 (snd rle ty)) -> inlineSingle_Rules_pos l1 n rules = rules. Proof. unfold inlineSingle_Rules_pos; remember (nth_error _ _) as nth_err0; symmetry in Heqnth_err0; destruct nth_err0; simpl; auto; intros; apply nth_error_In in Heqnth_err0. rewrite <- (map_id rules) at 2. rewrite forall_map; intros. eapply inlineSingle_Rule_NoCalls_ident' with (l := l2); eauto. apply H; rewrite in_map_iff; exists d; split; auto. Qed. Lemma inlineSome_Meths_pos_NoCalls_ident (l1 l2 : list DefMethT) xs : SubList l1 l2 -> (forall meth, In meth l1 -> (forall ty arg, NoCallActionT l2 (projT2 (snd meth) ty arg))) -> fold_left inlineSingle_Meths_pos xs l1 = l1. Proof. induction xs; auto; simpl; intros. erewrite inlineSingle_Meths_pos_NoCalls_ident; eauto. Qed. Lemma inlineSome_Meths_pos_NoCalls_ident' (l1 l2 : list DefMethT) xs : SubList (getKindAttr l1) (getKindAttr l2) -> (forall meth, In meth l1 -> (forall ty arg, NoCallActionT l2 (projT2 (snd meth) ty arg))) -> fold_left inlineSingle_Meths_pos xs l1 = l1. Proof. induction xs; auto; simpl; intros. erewrite inlineSingle_Meths_pos_NoCalls_ident'; eauto. Qed. Lemma inlineSome_Rules_pos_NoCalls_ident (l1 l2 : list DefMethT) xs (rules : list RuleT): SubList l1 l2 -> (forall rle ty, In rle rules -> NoCallActionT l2 (snd rle ty)) -> fold_left (fun newRules n => inlineSingle_Rules_pos l1 n newRules) xs rules = rules. Proof. induction xs; auto; simpl; intros. erewrite inlineSingle_Rules_pos_NoCalls_ident; eauto. Qed. Lemma inlineSome_Rules_pos_NoCalls_ident' (l1 l2 : list DefMethT) xs (rules : list RuleT): SubList (getKindAttr l1) (getKindAttr l2) -> (forall rle ty, In rle rules -> NoCallActionT l2 (snd rle ty)) -> fold_left (fun newRules n => inlineSingle_Rules_pos l1 n newRules) xs rules = rules. Proof. induction xs; auto; simpl; intros. erewrite inlineSingle_Rules_pos_NoCalls_ident'; eauto. Qed. Lemma NeverCall_NoCalls ty k (a : ActionT ty k) : NeverCallActionT a -> (forall l, NoCallActionT l a). Proof. intro; induction a; inv H; EqDep_subst; econstructor; eauto; intros; contradiction. Qed. Lemma SignatureReplace_NoCall k ty (a : ActionT ty k) : forall (ls ls' : list DefMethT), getKindAttr ls = getKindAttr ls' -> NoCallActionT ls a -> NoCallActionT ls' a. Proof. induction a; intros; simpl; eauto; try ((inv H1 || inv H0); EqDep_subst; econstructor; eauto). rewrite <- H0; assumption. Qed. Lemma NeverCall_inline k ty (a : ActionT ty k): forall (f : DefMethT), (forall v, NeverCallActionT (projT2 (snd f) ty v)) -> NoCallActionT [f] (inlineSingle a f). Proof. induction a; intros; simpl; eauto; try (econstructor; eauto). - destruct String.eqb eqn:G; [destruct Signature_dec|]; subst; econstructor; eauto. + econstructor; eauto; simpl; intro. apply NeverCall_NoCalls; eauto. + intros B0; inv B0; [| contradiction]. inv H1; apply n; reflexivity. + rewrite String.eqb_neq in G; intro B0; inv B0; [|contradiction]. inv H1; apply G; reflexivity. Qed. Lemma NeverCall_inline_persistent k ty (a : ActionT ty k): forall (f : DefMethT) (ls : list DefMethT), (forall v, NeverCallActionT (projT2 (snd f) ty v)) -> NoCallActionT ls a -> NoCallActionT ls (inlineSingle a f). Proof. induction a; intros; simpl; eauto; try ((inv H1 || inv H0); EqDep_subst;econstructor; eauto). inv H1; EqDep_subst. destruct (String.eqb _ _) eqn:G;[rewrite String.eqb_eq in G; destruct Signature_dec|]; subst; try (econstructor; eauto). econstructor; eauto using NeverCall_NoCalls. Qed. Lemma NotCalled_NotInlined ty k (a : ActionT ty k) : forall (ls : list DefMethT) (f : DefMethT), In (fst f, projT1 (snd f)) (getKindAttr ls) -> NoCallActionT ls a -> inlineSingle a f = a. Proof. induction a; simpl; auto; intros; (inv H1 || inv H0); EqDep_subst; try ((apply f_equal || apply f_equal2 || apply f_equal3); eauto using functional_extensionality). - remember (String.eqb _ _) as strb; symmetry in Heqstrb. destruct strb;[destruct Signature_dec|]; subst. + exfalso; rewrite String.eqb_eq in *; subst; auto. + apply f_equal2; eauto using functional_extensionality. + apply f_equal2; eauto using functional_extensionality. Qed. Lemma NilNoCall k ty (a : ActionT ty k) : NoCallActionT nil a. Proof. induction a; intros; econstructor; eauto. Qed. Lemma unifyWO (x : word 0): x = (evalExpr (Const type WO)). Proof. simpl. rewrite (unique_word_0 x). reflexivity. Qed. Local Coercion BaseRegFile : RegFileBase >-> BaseModule. Lemma RegFileBase_inlineSingle_invar (rf : RegFileBase) f: map (inlineSingle_Meth f) (getMethods rf) = getMethods rf. Proof. destruct rf, rfRead; simpl in *. - assert (map (inlineSingle_Meth f) (readRegFile rfNum rfDataArray reads rfIdxNum rfData) = (readRegFile rfNum rfDataArray reads rfIdxNum rfData)) as P0. { unfold readRegFile. induction reads; simpl; auto. destruct String.eqb; rewrite IHreads; auto. } destruct String.eqb, rfIsWrMask; rewrite P0; auto. - assert (map (inlineSingle_Meth f) (readSyncRegFile isAddr rfNum rfDataArray reads rfIdxNum rfData) = readSyncRegFile isAddr rfNum rfDataArray reads rfIdxNum rfData) as P0. { destruct isAddr; simpl; rewrite map_app; apply f_equal2; induction reads; simpl; auto; destruct String.eqb; rewrite IHreads; auto. } rewrite P0. destruct String.eqb; auto. destruct rfIsWrMask; auto. Qed. Lemma RegFileBase_inlineSome_invar (rf : RegFileBase) xs: fold_left inlineSingle_Meths_pos xs (getMethods rf) = getMethods rf. Proof. induction xs; simpl in *; auto. unfold inlineSingle_Meths_pos in *. remember (nth_error (getRegFileMethods rf) a) as nth_err. destruct nth_err; setoid_rewrite <- Heqnth_err; simpl; auto. specialize (nth_error_In _ _ (eq_sym Heqnth_err)) as P0. setoid_rewrite RegFileBase_inlineSingle_invar; assumption. Qed. Corollary RegFileBase_inlineAll_invar (rf : RegFileBase) : inlineAll_Meths (getMethods rf) = getMethods rf. Proof. unfold inlineAll_Meths. apply RegFileBase_inlineSome_invar. Qed. Lemma NeverCall_inline_invar (f g : DefMethT) : (forall ty arg, NeverCallActionT (projT2 (snd g) ty arg)) -> inlineSingle_Meth f g = g. Proof. intros. eapply inlineSingle_Meth_NoCalls_ident with (l := [f]); eauto using NeverCall_NoCalls. left; reflexivity. Qed. Lemma inlineAll_Meths_RegFile_flat1 : forall (l l' : list DefMethT) (HNeverCall : forall meth ty, In meth l' -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))) n (Hlen : n < length l), inlineSingle_Meths_pos (l ++ l') n = inlineSingle_Meths_pos l n ++ l'. Proof. intros; unfold inlineSingle_Meths_pos. remember (nth_error _ _ ) as err0. destruct err0. - rewrite nth_error_app1 in Heqerr0; auto. rewrite <- Heqerr0; rewrite map_app. induction l'; auto; simpl. rewrite NeverCall_inline_invar. + repeat apply f_equal2; auto. eapply app_inv_head, IHl'; intros. apply HNeverCall. right; assumption. + intros; apply HNeverCall; left; reflexivity. - exfalso. symmetry in Heqerr0. rewrite nth_error_None, app_length in *; lia. Qed. Lemma inlineAll_Meths_RegFile_flat2 : forall (l l' : list DefMethT) (HNeverCall : forall meth ty, In meth l' -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))) n (Hlen : length l <= n) f (HSome : nth_error l' (n - length l) = Some f), inlineSingle_Meths_pos (l ++ l') n = (map (inlineSingle_Meth f) l) ++ l'. Proof. intros; unfold inlineSingle_Meths_pos. remember (nth_error (l ++ l') n) as err0. destruct err0. - rewrite nth_error_app2 in Heqerr0; auto. rewrite <- Heqerr0 in HSome; inv HSome. rewrite map_app. enough (forall f', In f' l' -> map (inlineSingle_Meth f') l' = l'). { rewrite (H f); auto. symmetry in Heqerr0; eapply nth_error_In; eauto. } intros. rewrite <- map_id; apply map_ext_in; intros. apply NeverCall_inline_invar; eauto. - exfalso. symmetry in Heqerr0; rewrite nth_error_None, app_length in *. specialize (nth_error_Some l' (n - length l)) as P0. rewrite HSome in *. assert (n - length l < length l') as P1. { rewrite <- P0; intros; discriminate. } clear - P1 Heqerr0 Hlen. lia. Qed. Lemma inlineSingle_Meths_pos_length l n : length (inlineSingle_Meths_pos l n) = length l. Proof. setoid_rewrite <- (map_length fst). rewrite <- SameKeys_inlineSingle_Meth_pos; reflexivity. Qed. Lemma inlineSome_Meths_pos_length l xs : length (fold_left inlineSingle_Meths_pos xs l) = length l. Proof. setoid_rewrite <- (map_length fst). rewrite <- SameKeys_inlineSome_Meths; reflexivity. Qed. Lemma inlineAll_Meths_RegFile_fold_flat1 n : forall (l l' : list DefMethT) (HNeverCall : forall meth ty, In meth l' -> (forall arg, NeverCallActionT (projT2 (snd meth) ty arg))) (Hlen : n <= length l), fold_left inlineSingle_Meths_pos (seq 0 n) (l ++ l') = fold_left inlineSingle_Meths_pos (seq 0 n) l ++ l'. Proof. intros; repeat rewrite <- fold_left_rev_right. induction n. - simpl; auto. - rewrite seq_eq, rev_app_distr; simpl. rewrite IHn; [|lia]. rewrite (inlineAll_Meths_RegFile_flat1); auto. assert (forall xs, length (fold_right (fun y x => inlineSingle_Meths_pos x y) l xs) = length l) as P0. { clear. induction xs; simpl; auto. rewrite inlineSingle_Meths_pos_length; assumption. } rewrite P0; lia. Qed. Lemma inline_NeverCall k ty (a : ActionT ty k) : forall (f : DefMethT) ls, (forall v, NeverCallActionT (projT2 (snd f) ty v)) -> ~In (fst f, projT1 (snd f)) (getKindAttr ls) -> NoCallActionT ls (inlineSingle a f) -> NoCallActionT ls a. Proof. induction a; intros; simpl in *; [remember (String.eqb _ _ ) as strb; symmetry in Heqstrb; destruct strb;[rewrite String.eqb_eq in *; destruct Signature_dec|]; subst | | | | | | | | ]; (inv H2 || inv H1); EqDep_subst; constructor; intros; eauto. Qed. Lemma inlineSingle_Rules_app_l : forall (l l' : list DefMethT) (lr : list RuleT) n, n < length l -> inlineSingle_Rules_pos (l ++ l') n lr = inlineSingle_Rules_pos l n lr. Proof. intros; unfold inlineSingle_Rules_pos; rewrite nth_error_app1; auto. Qed. Lemma inlineSome_Rules_app_l xs : forall (l l' : list DefMethT) (lr : list RuleT), (forall n, In n xs -> n < length l) -> fold_left (fun lr' n => inlineSingle_Rules_pos (l ++ l') n lr') xs lr = fold_left (fun lr' n => inlineSingle_Rules_pos l n lr') xs lr. Proof. induction xs; auto; simpl; intros. rewrite inlineSingle_Rules_app_l; eauto. Qed. Lemma inlineSingle_Rules_app_r : forall (l l' : list DefMethT) (lr : list RuleT) n, length l <= n -> inlineSingle_Rules_pos (l ++ l') n lr = inlineSingle_Rules_pos l' (n - length l) lr. Proof. intros; unfold inlineSingle_Rules_pos; rewrite nth_error_app2; eauto. Qed. Lemma inlineSome_Rules_app_r xs : forall (l l' : list DefMethT) (lr : list RuleT), (forall n, In n xs -> length l <= n) -> fold_left (fun lr' n => inlineSingle_Rules_pos (l ++ l') n lr') xs lr = fold_left (fun lr' n => inlineSingle_Rules_pos l' n lr') (map (fun m => m - length l) xs) lr. Proof. induction xs; auto; simpl; intros. rewrite inlineSingle_Rules_app_r; eauto. Qed. Lemma inlineAll_Rules_NoCalls : forall (l l' : list DefMethT) (lr : list RuleT), inlineAll_Rules (l ++ l') lr = inlineAll_Rules l' (inlineAll_Rules l lr). Proof. unfold inlineAll_Rules; intros. assert (length l <= length (l ++ l')) as P0. { rewrite app_length; lia. } rewrite (seq_app' _ P0), app_length, minus_plus, plus_O_n, fold_left_app, inlineSome_Rules_app_r at 1; [setoid_rewrite inlineSome_Rules_app_l|]. - rewrite Reduce_seq, Nat.sub_diag; reflexivity. - intros; rewrite in_seq in *; lia. - intros; rewrite in_seq in *; dest; assumption. Qed. Lemma inlineAll_Meths_same_len l : length (inlineAll_Meths l) = length l. Proof. setoid_rewrite <- (map_length fst); rewrite <- SameKeys_inlineAll_Meths; reflexivity. Qed. Lemma NoSelfCall_nil (m : BaseModule) : getMethods m = nil -> NoSelfCallBaseModule m. Proof. enough (forall {k : Kind} ty (a : ActionT ty k), NoCallActionT nil a). { intros. unfold NoSelfCallBaseModule, NoSelfCallRulesBaseModule, NoSelfCallMethsBaseModule. split; simpl; intros; rewrite H0; auto. } intros; induction a; econstructor; eauto. Qed. Lemma WfBaseMod_inlineSingle ty (m : BaseModule) (HWfMod : WfBaseModule ty m) k (a : ActionT ty k): forall (f : DefMethT), In f (getMethods m) -> WfActionT (getRegisters m) a -> WfActionT (getRegisters m) (inlineSingle a f). Proof. induction a; simpl; intros; (inv H1||inv H0); EqDep_subst; try (econstructor; eauto). unfold WfBaseModule in *; dest. destruct String.eqb; [destruct Signature_dec; subst|]; repeat (econstructor; eauto). Qed. Lemma NeverCallMod_NeverCalls m : NeverCallMod m -> (forall rule ty, In rule (getAllRules m) -> NeverCallActionT (snd rule ty)) /\ (forall meth ty, In meth (getAllMethods m) -> forall v, NeverCallActionT (projT2 (snd meth) ty v)). Proof. induction 1; simpl; eauto; dest. setoid_rewrite in_app_iff; split; intros; inv H5; eauto. Qed. Lemma WfExpand ty k (a : ActionT ty k): forall r1 r2, SubList r1 r2 -> WfActionT r1 a -> WfActionT r2 a. Proof. induction a; intros; (inv H1||inv H0); EqDep_subst; econstructor; eauto. - rewrite in_map_iff in H7; dest; inv H1; specialize (H0 _ H2). rewrite in_map_iff; exists x; split; auto. - rewrite in_map_iff in H7; dest; inv H0; specialize (H _ H1). rewrite in_map_iff; exists x; split; auto. Qed. Lemma WfExpand_new ty k (a : ActionT ty k): forall r1 r2, NoDup (map fst r2) -> SubList r1 r2 -> WfActionT_new r1 a -> WfActionT_new r2 a. Proof. induction a; simpl in *; intros; dest; try split; eauto. - destruct lookup eqn:G; try contradiction. destruct s. apply lookup_In in G; dest; subst. specialize (SubList_map (fun x => (fst x, projT1 (snd x))) H1) as P. specialize (P _ G). specialize (In_lookup _ _ _ H0 P) as TMP; dest; subst. rewrite H4; split; auto; intros. eapply H; eauto. - destruct lookup eqn:G; try contradiction. destruct s. apply lookup_In in G; dest; subst. specialize (SubList_map (fun x => (fst x, projT1 (snd x))) H0) as P. specialize (P _ G). specialize (In_lookup _ _ _ H P) as TMP; dest; subst. rewrite H3; split; auto; intros. eapply IHa; eauto. Qed. (* End Basic Properties *) ================================================ FILE: PProperties.v ================================================ Require Import Kami.Syntax. Require Import Kami.Properties. Import ListNotations. Require Import Coq.Sorting.Permutation. Require Import Coq.Sorting.PermutEq. Require Import RelationClasses Setoid Morphisms. Require Import ZArith. Lemma PSemAction_SemAction o k: forall (a : ActionT type k) (readRegs newRegs : RegsT) (calls : MethsT) (fret : type k), PSemAction o a readRegs newRegs calls fret -> (exists (readRegs' newRegs' : RegsT) (calls' : MethsT), readRegs [=] readRegs' /\ newRegs [=] newRegs' /\ calls [=] calls' /\ SemAction o a readRegs' newRegs' calls' fret). Proof. induction 1; dest. - exists x, x0, ((meth, existT SignT s (evalExpr marg, mret))::x1). repeat split; eauto. + rewrite <- H2; assumption. + econstructor 1; auto. - exists x, x0, x1. repeat split; eauto. econstructor 2; assumption. - exists (x2++x), (x3++x0), (x4++x1). rewrite H1, H5 in HUReadRegs; rewrite H2, H6 in HUNewRegs; rewrite H3, H7 in HUCalls. repeat split; auto. + constructor 3 with (readRegs := x2) (newRegs := x3) (readRegsCont := x) (newRegsCont := x0) (calls := x4) (callsCont := x1) (v := v); eauto. * intro; specialize (HDisjRegs k0); rewrite <- H6, <- H2; assumption. - exists x, x0, x1. repeat split; auto. econstructor 4; eauto. - exists ((r, existT (fullType type) regT regV)::x), x0, x1. repeat split; eauto. + rewrite <- H0; assumption. + econstructor 5; eauto. - exists x, ((r, existT (fullType type) k (evalExpr e))::x0), x1. repeat split; eauto. + rewrite <- H1; assumption. + econstructor 6; auto. intro; specialize (HDisjRegs v); rewrite H1 in HDisjRegs; apply HDisjRegs. - exists (x2++x), (x3++x0), (x4++x1). rewrite H1, H5 in HUReadRegs; rewrite H2, H6 in HUNewRegs; rewrite H3, H7 in HUCalls. repeat split; auto. econstructor 7; auto. + intro; specialize (HDisjRegs k); rewrite H2, H6 in HDisjRegs; apply HDisjRegs. + apply H8. + assumption. - exists (x2++x), (x3++x0), (x4++x1). rewrite H1, H5 in HUReadRegs; rewrite H2, H6 in HUNewRegs; rewrite H3, H7 in HUCalls. repeat split; auto. econstructor 8; auto. + intro; specialize (HDisjRegs k); rewrite H2, H6 in HDisjRegs; apply HDisjRegs. + apply H8. + assumption. - exists x, x0, x1. repeat split; auto. econstructor; eauto. - exists nil, nil, nil. repeat split; subst; auto. econstructor; eauto. Qed. Lemma SemAction_PSemAction o k: forall (a : ActionT type k) (readRegs newRegs : RegsT) (calls : MethsT) (fret : type k), SemAction o a readRegs newRegs calls fret -> PSemAction o a readRegs newRegs calls fret. Proof. induction 1; subst. - econstructor 1; eauto. - econstructor 2; eauto. - econstructor 3; eauto. - econstructor 4; eauto. - econstructor 5; eauto. - econstructor 6; eauto. - econstructor 7; eauto. - econstructor 8; eauto. - econstructor 9; eauto. - econstructor 10; eauto. Qed. Lemma key_in_split' : forall (A B C : Type)(l : list (A*B))(x : (A*C)), In (fst x) (map fst l) -> (exists (l1 l2 : list (A*B))(y : B), l = l1++(((fst x), y)::l2)). Proof. induction l; simpl; intros; auto. - contradiction. - destruct H. + exists nil, l; simpl. destruct a, x; simpl in *; subst. exists b; reflexivity. + specialize (IHl _ H). dest. exists (a::x0), x1. simpl. exists x2. rewrite H0; reflexivity. Qed. Lemma map_in_split A B (f : A -> B): forall (l : list A)(x : A), In (f x) (map f l) -> (exists (l1 l2 : list A), (map f l) = (map f l1)++((f x)::(map f l2))). Proof. induction l; simpl; intros; auto. - contradiction. - destruct H. + exists nil, l; simpl. rewrite H; reflexivity. + specialize (IHl _ H). dest. exists (a::x0), x1. simpl. rewrite H0; reflexivity. Qed. Lemma getKindAttr_perm_eq (A B : Type)(P : B -> Type)(Q : B -> Type) : forall (l1 : list (A * {x : B & P x}))(l2 : list (A * {x : B & Q x})), getKindAttr l1 [=] getKindAttr l2 -> (exists l2', l2 [=] l2' /\ getKindAttr l2' = getKindAttr l1). Proof. induction l1. - intros. exists nil. repeat split; auto. destruct l2;[reflexivity|specialize (Permutation_nil H);discriminate]. - simpl; intros. assert (In (fst a, projT1 (snd a)) (getKindAttr l2));[rewrite <- H; left; reflexivity|]. rewrite in_map_iff in H0; dest. specialize (in_split _ _ H1) as TMP; dest; subst. rewrite map_app in H; simpl in H; rewrite H0 in H. specialize (Permutation_cons_app_inv _ _ H) as TMP. rewrite <- map_app in TMP. specialize (IHl1 _ TMP); dest. exists (x::x2); split. rewrite <- H2; symmetry; apply Permutation_cons_app; reflexivity. simpl; rewrite H3, H0; reflexivity. Qed. Lemma fst_produce_snd A B: forall (l : list (A * B)) (a : A), In a (map fst l) -> (exists (b : B), In (a, b) l). Proof. induction l; simpl; intros. - inversion H. - destruct a. destruct H. + exists b. inversion H; subst. left; reflexivity. + specialize (IHl _ H); dest. exists x. right; assumption. Qed. Lemma key_perm_eq (A B C : Type): forall (l : list (A*C))(l' : list (A*B)), (map fst l) [=] (map fst l') -> (exists l'', l' [=] l'' /\ map fst l = map fst l''). Proof. induction l. - intros. apply Permutation_nil,map_eq_nil in H; subst;exists nil; split; auto. - intros. specialize (key_in_split' _ _ (Permutation_in _ H (in_eq _ _))) as TMP; dest. rewrite H0 in H; simpl in H; rewrite map_app in H;simpl in H;apply Permutation_cons_app_inv in H. rewrite <- map_app in H. specialize (IHl _ H); dest. exists ((fst a, x1)::x2); split. + rewrite H0, <- H1; symmetry; apply Permutation_middle. + simpl; rewrite H2; reflexivity. Qed. Section PSemAction_rewrites. Variable (k : Kind) (a : ActionT type k) (fret : type k). Lemma PSemAction_rewrite_state readRegs newRegs calls o1 o2: (o1 [=] o2) -> PSemAction o1 a readRegs newRegs calls fret -> PSemAction o2 a readRegs newRegs calls fret. Proof. induction 2. - econstructor 1; eauto. - econstructor 2; eauto. - econstructor 3; eauto. - econstructor 4; eauto. - econstructor 5; eauto. rewrite <- H. assumption. - econstructor 6; eauto. rewrite <- H. assumption. - econstructor 7; eauto. - econstructor 8; eauto. - econstructor 9; eauto. - econstructor 10; eauto. Qed. Lemma PSemAction_rewrite_calls readRegs newRegs calls1 calls2 o: (calls1 [=] calls2) -> PSemAction o a readRegs newRegs calls1 fret -> PSemAction o a readRegs newRegs calls2 fret. Proof. induction 2. - econstructor 1; eauto. rewrite <- H; assumption. - econstructor 2; eauto. - econstructor 3; eauto. rewrite <- H; assumption. - econstructor 4; eauto. - econstructor 5; eauto. - econstructor 6; eauto. - econstructor 7; eauto. rewrite <- H; assumption. - econstructor 8; eauto. rewrite <- H; assumption. - econstructor 9; eauto. - econstructor 10; eauto. rewrite HCalls in H; apply (Permutation_nil H). Qed. Lemma SubList_refl A (l : list A) : SubList l l. Proof. firstorder. Qed. Global Instance SubList_PreOrder A : PreOrder (@SubList A) | 10 := { PreOrder_Reflexive := (@SubList_refl A); PreOrder_Transitive := (@SubList_transitive A)}. Lemma PSemAction_rewrite_readRegs readRegs1 readRegs2 newRegs calls o: readRegs1 [=] readRegs2 -> PSemAction o a readRegs1 newRegs calls fret -> PSemAction o a readRegs2 newRegs calls fret. Proof. induction 2. - econstructor 1; eauto. - econstructor 2; eauto. - econstructor 3; eauto. rewrite <- H; assumption. - econstructor 4; eauto. - econstructor 5; eauto. rewrite <- H; assumption. - econstructor 6; eauto. - econstructor 7; eauto. rewrite <- H; assumption. - econstructor 8; eauto. rewrite <- H; assumption. - econstructor 9; eauto. - econstructor 10; eauto. rewrite HReadRegs in H; apply (Permutation_nil H). Qed. Lemma PSemAction_rewrite_newRegs readRegs newRegs1 newRegs2 calls o: newRegs1 [=] newRegs2 -> PSemAction o a readRegs newRegs1 calls fret -> PSemAction o a readRegs newRegs2 calls fret. Proof. induction 2. - econstructor 1; eauto. - econstructor 2; eauto. - econstructor 3; eauto. rewrite <- H; assumption. - econstructor 4; eauto. - econstructor 5; eauto. - econstructor 6; eauto. rewrite <- H; assumption. - econstructor 7; eauto. rewrite <- H; assumption. - econstructor 8; eauto. rewrite <- H; assumption. - econstructor 9; eauto. - econstructor 10; eauto. rewrite HNewRegs in H; apply (Permutation_nil H). Qed. Global Instance PSemAction_rewrite' : Proper (@Permutation (string * {x : FullKind & fullType type x}) ==> @Permutation (string * {x : FullKind & fullType type x}) ==> @Permutation (string * {x : FullKind & fullType type x}) ==> @Permutation MethT ==> iff) (fun w x y z => @PSemAction w k a x y z fret) |10. Proof. repeat red; subst; split; intros; eauto using PSemAction_rewrite_state, PSemAction_rewrite_calls, PSemAction_rewrite_readRegs, PSemAction_rewrite_newRegs. apply Permutation_sym in H; apply Permutation_sym in H0;apply Permutation_sym in H1;apply Permutation_sym in H2. eauto using PSemAction_rewrite_state, PSemAction_rewrite_calls, PSemAction_rewrite_readRegs, PSemAction_rewrite_newRegs. Qed. End PSemAction_rewrites. Inductive FullLabel_perm : FullLabel -> FullLabel -> Prop := | FL_eq (u u' : RegsT) (cs cs' : MethsT) (rm rm' : RuleOrMeth): u [=] u' -> rm = rm' -> cs [=] cs' -> FullLabel_perm (u, (rm, cs)) (u', (rm', cs')). Inductive List_FullLabel_perm : list FullLabel -> list FullLabel -> Prop := | LFL_eq_nil : List_FullLabel_perm nil nil | LFL_eq_cons_1 (fl1 fl2 : FullLabel)(ls1 ls2 : list FullLabel): FullLabel_perm fl1 fl2 -> List_FullLabel_perm ls1 ls2 -> List_FullLabel_perm (fl1::ls1) (fl2::ls2) | LFL_eq_cons_2 (fl1 fl2 fl3 fl4 : FullLabel)(ls1 ls2 : list FullLabel) : FullLabel_perm fl1 fl2 -> FullLabel_perm fl3 fl4 -> List_FullLabel_perm ls1 ls2 -> List_FullLabel_perm (fl1::fl3::ls1) (fl4::fl2::ls2) | LFL_eq_trans ls1 ls2 ls3 : List_FullLabel_perm ls1 ls2 -> List_FullLabel_perm ls2 ls3 -> List_FullLabel_perm ls1 ls3. Lemma FullLabel_perm_refl fl : FullLabel_perm fl fl. Proof. destruct fl, p; constructor; auto. Qed. Lemma FullLabel_perm_sym fl fl' : FullLabel_perm fl fl' -> FullLabel_perm fl' fl. Proof. induction 1; econstructor; eauto using Permutation_sym. Qed. Lemma FullLabel_perm_trans fl fl' fl'' : FullLabel_perm fl fl' -> FullLabel_perm fl' fl'' -> FullLabel_perm fl fl''. Proof. induction 1; intro; inv H2; econstructor;eauto using Permutation_trans. Qed. Global Instance FullLabel_perm_Equivalence : Equivalence (@FullLabel_perm) | 10 :={ Equivalence_Reflexive := @FullLabel_perm_refl; Equivalence_Symmetric := @FullLabel_perm_sym; Equivalence_Transitive := @FullLabel_perm_trans}. Lemma List_FullLabel_perm_refl ls : List_FullLabel_perm ls ls. Proof. induction ls; econstructor; eauto using FullLabel_perm_refl. Qed. Lemma List_FullLabel_perm_sym ls ls': List_FullLabel_perm ls ls' -> List_FullLabel_perm ls' ls. Proof. induction 1. - econstructor. - econstructor 2; eauto using FullLabel_perm_sym. - econstructor 3; eauto using FullLabel_perm_sym. - econstructor 4; eauto. Qed. Lemma List_FullLabel_perm_trans : forall (ls ls' ls'' : list FullLabel), List_FullLabel_perm ls ls' -> List_FullLabel_perm ls' ls'' -> List_FullLabel_perm ls ls''. Proof. exact LFL_eq_trans. Qed. Global Instance List_FullLabel_perm_Equivalence : Equivalence (@List_FullLabel_perm) | 10 :={ Equivalence_Reflexive := @List_FullLabel_perm_refl; Equivalence_Symmetric := @List_FullLabel_perm_sym; Equivalence_Transitive := @List_FullLabel_perm_trans}. Lemma List_FullLabel_perm_in: forall l l', List_FullLabel_perm l l' -> forall a, In a l -> (exists x, FullLabel_perm a x /\ In x l'). Proof. induction 1. - contradiction. - intros; destruct H1. + subst. exists fl2; repeat split;[|left]; auto. + specialize (IHList_FullLabel_perm _ H1); dest. exists x; split;[|right]; auto. - intros; destruct H2;[|destruct H2]; subst. + exists fl2; repeat split;[|right;left];auto. + exists fl4; repeat split;[|left];auto. + specialize (IHList_FullLabel_perm _ H2); dest. exists x; split; [|right; right]; auto. - intros; specialize (IHList_FullLabel_perm1 _ H1); dest. specialize (IHList_FullLabel_perm2 _ H3); dest. exists x0; repeat split; eauto using FullLabel_perm_trans. Qed. Lemma List_FullLabel_perm_getRleOrMeth l1 l2: List_FullLabel_perm l1 l2 -> (map getRleOrMeth l1) [=] (map getRleOrMeth l2). Proof. induction 1; eauto using Permutation_trans. - inv H; simpl. econstructor 2; eauto. - inv H; inv H0; simpl. rewrite perm_swap; repeat econstructor 2; eauto. Qed. Corollary List_FullLabel_perm_InExec_rewrite f l1 l2: List_FullLabel_perm l1 l2 -> InExec f l1 -> InExec f l2. Proof. intros; apply List_FullLabel_perm_getRleOrMeth in H. unfold InExec. rewrite <- H; assumption. Qed. Global Instance List_FullLabel_perm_InExec_rewrite' f: Proper (List_FullLabel_perm ==> iff) (@InExec f) |10. Proof. repeat red; intros; split; intros; eauto using List_FullLabel_perm_InExec_rewrite, List_FullLabel_perm_sym. Qed. Lemma Perm_rewrite_List_FullLabel_perm_l l1 l2: l1 [=] l2 -> forall l, List_FullLabel_perm l1 l -> List_FullLabel_perm l2 l. Proof. induction 1. - intros; assumption. - intros. rewrite <- H0. econstructor 2. + reflexivity. + eapply IHPermutation. reflexivity. - intros. rewrite <- H. econstructor 3; reflexivity. - intros. rewrite <- H1. eapply IHPermutation2. eapply IHPermutation1. reflexivity. Qed. Corollary Perm_rewrite_List_FullLabel_perm l1 l2 l3 l4 : l1 [=] l2 -> l3 [=] l4 -> List_FullLabel_perm l1 l3 -> List_FullLabel_perm l2 l4. Proof. intros. eauto using Perm_rewrite_List_FullLabel_perm_l, List_FullLabel_perm_sym. Qed. Global Instance Perm_rewrite_List_FullLabel_perm' : Proper (@Permutation FullLabel ==> @Permutation FullLabel ==> iff) (@List_FullLabel_perm) |10. Proof. repeat red; split; intros; eauto using Perm_rewrite_List_FullLabel_perm, Permutation_sym. Qed. Section Permutation_filter. Variable A : Type. Variable f : A -> bool. Lemma Permutation_filter l l': l [=] l' -> filter f l [=] filter f l'. Proof. induction 1; auto. - rewrite (filter_app _ (x::nil) l); rewrite (filter_app _ (x::nil) l'). rewrite IHPermutation; reflexivity. - rewrite (filter_app _ (y::x::nil) l); rewrite (filter_app _ (x::y::nil) l). apply Permutation_app_tail. rewrite (filter_app _ (y::nil) (x::nil)); rewrite (filter_app _ (x::nil) (y::nil)). rewrite (Permutation_app_comm); reflexivity. - rewrite IHPermutation1; rewrite IHPermutation2; reflexivity. Qed. Global Instance Permutation_filter' : Proper (@Permutation A ==> @Permutation A) (@filter A f) | 10. Proof. intro; eauto using Permutation_filter. Qed. End Permutation_filter. Section SubList_rewrites. Variable A : Type. Lemma SubList_rewrite (l1 l2 l3 l4 : list A): l1 [=] l3 -> l2 [=] l4 -> SubList l1 l2 -> SubList l3 l4. Proof. unfold SubList; intros. rewrite <- H0. apply (H1 x). rewrite H. assumption. Qed. Global Instance SubList_rewrite' : Proper (@Permutation A ==> @Permutation A ==> iff) (@SubList A) | 10. repeat red; intros; split; eauto using SubList_rewrite, Permutation_sym. Qed. End SubList_rewrites. Lemma List_FullLabel_perm_InCall_rewrite f l1 l2: List_FullLabel_perm l1 l2 -> InCall f l1 -> InCall f l2. Proof. induction 1; auto. - assert (fl1::ls1 =[fl1]++ls1); auto; rewrite H1; clear H1. assert (fl2::ls2 = [fl2]++ls2); auto; rewrite H1; clear H1. repeat rewrite InCall_app_iff; intro. destruct H1; auto. left; unfold InCall in *; dest. exists fl2; simpl; split; auto. inv H; simpl in *. destruct H1;[subst|contradiction]. rewrite <- H5; assumption. - assert (fl1::fl3::ls1 = [fl1]++[fl3]++ls1); auto; rewrite H2; clear H2. assert (fl4::fl2::ls2 = [fl4]++[fl2]++ls2); auto; rewrite H2; clear H2. repeat rewrite InCall_app_iff; intro. destruct H2;[|destruct H2; auto]; unfold InCall in *;dest. + right; left; exists fl2; simpl in *; split; auto. destruct H2;[subst|contradiction]. inv H; simpl in *; rewrite <- H5; assumption. + left; exists fl4; simpl in *; split; auto. destruct H2;[subst|contradiction]. inv H0; simpl in *; rewrite <- H5; assumption. Qed. Global Instance List_FullLabel_perm_InCall_rewrite' : Proper (eq ==> @List_FullLabel_perm ==> iff) (@InCall) | 10. Proof. repeat red; intros; split; intro; subst; eauto using List_FullLabel_perm_InCall_rewrite, List_FullLabel_perm_sym. Qed. Lemma PSubsteps_Substeps m: forall (o : RegsT)(l : list FullLabel), PSubsteps m o l -> (exists (o' : RegsT)(l' : list FullLabel), o [=] o' /\ List_FullLabel_perm l l' /\ getKindAttr o' = getKindAttr (getRegisters m) /\ Substeps m o' l'). Proof. induction 1. - specialize (getKindAttr_perm_eq _ _ _ _ (Permutation_sym HRegs)) as TMP ; dest;exists x, nil; repeat split; auto; econstructor 1; eauto. - dest; apply (PSemAction_rewrite_state H0) in HPAction; apply PSemAction_SemAction in HPAction; dest. exists x, ((x2, (Rle rn, x3))::x0); repeat split; auto;[destruct l|]. + apply Permutation_nil in HLabel; discriminate. + rewrite HLabel. econstructor; eauto. econstructor; eauto. + econstructor 2; eauto. * rewrite H4 in HReadsGood; assumption. * rewrite H5 in HUpdGood; assumption. * intros;specialize (List_FullLabel_perm_in (List_FullLabel_perm_sym H1) _ H8) as TMP; dest;specialize (HDisjRegs _ H10); intro; inversion H9; simpl; destruct (HDisjRegs k);[left|right];intro; apply H16. -- rewrite <- H15; simpl. rewrite <- H11; assumption. -- rewrite H5; assumption. * intros. specialize (List_FullLabel_perm_in (List_FullLabel_perm_sym H1) _ H8) as TMP; dest;specialize (HNoRle _ H10); inversion H9;rewrite <- H15 in HNoRle; simpl in *;rewrite H12;assumption. - dest; apply (PSemAction_rewrite_state H0) in HPAction; apply PSemAction_SemAction in HPAction; dest. exists x, ((x2, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), x3))::x0); repeat split; auto;[destruct l|]. + apply Permutation_nil in HLabel; discriminate. + rewrite HLabel. econstructor; eauto. econstructor; eauto. + econstructor 3; eauto. * rewrite H4 in HReadsGood; assumption. * rewrite H5 in HUpdGood; assumption. * intros;specialize (List_FullLabel_perm_in (List_FullLabel_perm_sym H1) _ H8) as TMP; dest;specialize (HDisjRegs _ H10); intro; inversion H9; simpl; destruct (HDisjRegs k);[left|right];intro; apply H16. -- rewrite <- H15; simpl. rewrite <- H11; assumption. -- rewrite H5; assumption. Qed. Lemma Substeps_PSubsteps m: forall (o : RegsT) (l : list FullLabel), Substeps m o l -> PSubsteps m o l. induction 1; subst. - econstructor 1; rewrite HRegs; reflexivity. - econstructor 2;[rewrite HRegs|apply HInRules| apply (SemAction_PSemAction HAction)| | | | | | ]; eauto. - econstructor 3;[rewrite HRegs|apply HInMeths| apply (SemAction_PSemAction HAction)| | | | | ]; eauto. Qed. Lemma List_FullLabel_perm_nil l : List_FullLabel_perm nil l -> l = nil. Proof. intros; remember (@nil FullLabel) as m in H. induction H; [eauto| | | eauto];discriminate. Qed. Lemma List_FullLabel_perm_len l1 l2 : List_FullLabel_perm l1 l2 -> length l1 = length l2. Proof. induction 1; simpl; eauto using eq_trans. Qed. Lemma List_FullLabel_perm_ind_bis : forall (P : list FullLabel -> list FullLabel -> Prop), P [] [] -> (forall (x x' : FullLabel) (l l' : list FullLabel),FullLabel_perm x x' -> List_FullLabel_perm l l' -> P l l' -> P (x :: l) (x' :: l')) -> (forall (x y x' y' : FullLabel) (l l' : list FullLabel), FullLabel_perm x x' -> FullLabel_perm y y' -> List_FullLabel_perm l l' -> P l l' -> P (y :: x :: l) (x' :: y' :: l')) -> (forall l l' l'' : list FullLabel, List_FullLabel_perm l l' -> P l l' -> List_FullLabel_perm l' l'' -> P l' l'' -> P l l'') -> forall l l' : list FullLabel, List_FullLabel_perm l l' -> P l l'. Proof. intros P Hnil Hskip Hswap Htrans. induction 1; auto. eapply Htrans with ls2; auto. Qed. Lemma List_FullLabel_perm_Add a b l l' : FullLabel_perm a b -> List.Add a l l' -> List_FullLabel_perm (b::l) l'. Proof. induction 2; simpl. - econstructor 2; eauto using FullLabel_perm_sym, List_FullLabel_perm_refl. - eapply LFL_eq_trans with (x::b::l). + econstructor 3; eauto using FullLabel_perm_refl, List_FullLabel_perm_refl. + econstructor 2; eauto using FullLabel_perm_refl. Qed. Local Ltac FLInvAdd := repeat (match goal with | H: List.Add ?x _ (_ :: _) |- _ => inversion H; clear H; subst end). Lemma List_FullLabel_perm_Add_inv l1 l2: List_FullLabel_perm l1 l2 -> forall l1' l2' a b, FullLabel_perm a b -> List.Add a l1' l1 -> List.Add b l2' l2 -> List_FullLabel_perm l1' l2'. Proof. revert l1 l2. refine (List_FullLabel_perm_ind_bis _ _ _ _ _). inversion_clear 2. - (* skip *) intros x x' l1 l2 FL_E LFLE IH. intros. FLInvAdd; auto. + rewrite <- LFLE. eapply List_FullLabel_perm_Add; rewrite <- FL_E in H; eauto using FullLabel_perm_trans, FullLabel_perm_sym. + rewrite LFLE. symmetry; eapply List_FullLabel_perm_Add; rewrite H in FL_E; eauto using FullLabel_perm_trans, FullLabel_perm_sym. + econstructor 2; eauto. - (* swap *) intros x y x' y' l1 l2 FL_E1 FL_E2 PFLE IH. intros. FLInvAdd. + try econstructor; eauto using FullLabel_perm_trans, FullLabel_perm_sym. + try econstructor; eauto using FullLabel_perm_trans, FullLabel_perm_sym. + try econstructor; eauto using FullLabel_perm_trans, FullLabel_perm_sym. rewrite <- PFLE. eapply List_FullLabel_perm_Add; rewrite <- FL_E1 in H; eauto. + try econstructor; eauto using FullLabel_perm_trans, FullLabel_perm_sym. + try econstructor; eauto using FullLabel_perm_trans, FullLabel_perm_sym. + assert (y::x::l0 [=] x::y::l0);[constructor| rewrite H0]. econstructor 2; eauto. rewrite <- PFLE. eapply List_FullLabel_perm_Add;[rewrite FL_E2;apply H|];eauto. + try econstructor; eauto using FullLabel_perm_trans, FullLabel_perm_sym. rewrite PFLE; symmetry; eapply List_FullLabel_perm_Add;[rewrite <-FL_E2; symmetry; apply H| assumption]. + assert (x'::y'::l0 [=] y'::x'::l0);[constructor| rewrite H0]. econstructor 2; eauto. symmetry; rewrite PFLE; eapply List_FullLabel_perm_Add;[symmetry; rewrite <- FL_E1; apply H| assumption]. + econstructor 3; eauto. - (* trans *) intros l1 l l2 PE IH PE' IH' l1' l2' a b FL_E AD1 AD2. assert (In a l1). rewrite (List.Add_in AD1); left; reflexivity. specialize (List_FullLabel_perm_in PE _ H) as TMP; dest. destruct (Add_inv _ _ H1) as (l', AD). transitivity l'. + eapply IH;[apply H0| |];auto. + rewrite H0 in FL_E. eapply IH';[apply FL_E| |];auto. Qed. Lemma List_FullLabel_perm_cons_inv fl1 fl2 l1 l2: FullLabel_perm fl1 fl2 -> List_FullLabel_perm (fl1::l1) (fl2::l2) -> List_FullLabel_perm l1 l2. Proof. intros; eapply List_FullLabel_perm_Add_inv; eauto using List.Add_head. Qed. Lemma List_FullLabel_perm_app l1 l2: List_FullLabel_perm l1 l2 -> forall l3 l4, List_FullLabel_perm l3 l4 -> List_FullLabel_perm (l1++l3) (l2++l4). Proof. induction 1; intros. - repeat rewrite app_nil_r; assumption. - repeat rewrite <- Permutation_middle; econstructor 2; eauto. - repeat rewrite <- Permutation_middle; econstructor 3; eauto. - eapply List_FullLabel_perm_trans; eauto. apply IHList_FullLabel_perm2; reflexivity. Qed. Lemma PSubsteps_List_FullLabel_perm_rewrite m o l : PSubsteps m o l -> forall l', List_FullLabel_perm l l' -> PSubsteps m o l'. Proof. induction 1. - intros; apply List_FullLabel_perm_nil in H; subst. econstructor 1; eauto. - intros; rewrite HLabel in *. specialize (List_FullLabel_perm_in H0 (u, (Rle rn, cs)) (in_eq _ _)) as TMP; dest. inversion H1; subst; apply (PSemAction_rewrite_newRegs H6) in HPAction; apply (PSemAction_rewrite_calls H9) in HPAction; rewrite H6 in HUpdGood. apply in_split in H2; dest. assert (l' [=] (u', (Rle rn, cs'))::(x++x0)); subst. + symmetry; apply Permutation_cons_app; reflexivity. + econstructor 2; eauto;rewrite H3 in H0; apply List_FullLabel_perm_cons_inv in H0; auto; intros. * specialize (List_FullLabel_perm_in (List_FullLabel_perm_sym H0) _ H2) as TMP; dest. specialize (HDisjRegs _ H5). intro; destruct (HDisjRegs k);[left|right];intro; apply H7; inv H4; simpl in *;[rewrite <- H10| rewrite H6]; assumption. * specialize (List_FullLabel_perm_in (List_FullLabel_perm_sym H0) _ H2) as TMP; dest. specialize (HNoRle _ H5). inv H4; simpl in *; assumption. - intros; rewrite HLabel in *. specialize (List_FullLabel_perm_in H0 (u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs)) (in_eq _ _)) as TMP; dest. inversion H1; subst; apply (PSemAction_rewrite_newRegs H6) in HPAction; apply (PSemAction_rewrite_calls H9) in HPAction; rewrite H6 in HUpdGood. apply in_split in H2; dest. assert (l' [=] (u', (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs'))::(x++x0)); subst. + symmetry; apply Permutation_cons_app; reflexivity. + econstructor 3; eauto;rewrite H3 in H0; apply List_FullLabel_perm_cons_inv in H0; auto; intros. * specialize (List_FullLabel_perm_in (List_FullLabel_perm_sym H0) _ H2) as TMP; dest. specialize (HDisjRegs _ H5). intro; destruct (HDisjRegs k);[left|right];intro; apply H7; inv H4; simpl in *;[rewrite <- H10| rewrite H6]; assumption. Qed. Global Instance PSubsteps_List_FullLabel_perm_rewrite' : Proper (Logic.eq ==> Logic.eq ==> List_FullLabel_perm ==> iff) (@PSubsteps) | 10. repeat red; intros; split; intros; subst; eauto using List_FullLabel_perm_sym, PSubsteps_List_FullLabel_perm_rewrite. Qed. Lemma List_FullLabel_perm_getRleOrMeth_perm l l' : List_FullLabel_perm l l' -> (map getRleOrMeth l) [=] (map getRleOrMeth l'). Proof. induction 1; auto. - inv H; simpl; apply perm_skip; assumption. - inv H; inv H0; simpl. rewrite perm_swap; repeat apply perm_skip; assumption. - eauto using Permutation_trans. Qed. Lemma List_FullLabel_perm_getNumExecs_rewrite f l l' : List_FullLabel_perm l l' -> (getNumExecs f l = getNumExecs f l')%Z. Proof. unfold getNumExecs; intros; rewrite (List_FullLabel_perm_getRleOrMeth_perm H); reflexivity. Qed. Lemma List_FullLabel_perm_getNumCalls_rewrite f l l' : List_FullLabel_perm l l' -> (getNumCalls f l = getNumCalls f l'). Proof. induction 1; auto. - inv H; unfold getNumCalls in *; simpl. rewrite H3;repeat rewrite getNumFromCalls_app. rewrite IHList_FullLabel_perm; reflexivity. - inv H; inv H0; unfold getNumCalls in *; simpl. repeat rewrite getNumFromCalls_app. rewrite H4, H5, IHList_FullLabel_perm; ring. - eauto using eq_trans. Qed. Global Instance ListFullLabel_perm_getNumExecs_rewrite' : Proper (eq ==> List_FullLabel_perm ==> eq) (@getNumExecs) | 10. Proof. repeat red; intros; subst; eauto using List_FullLabel_perm_getNumExecs_rewrite. Qed. Global Instance ListFullLabel_perm_getNumCalls_rewrite' : Proper (eq ==> List_FullLabel_perm ==> eq) (@getNumCalls) | 10. Proof. repeat red; intros; subst; eauto using List_FullLabel_perm_getNumCalls_rewrite. Qed. Lemma List_FullLabel_perm_WeakInclusion l l' : List_FullLabel_perm l l' -> WeakInclusion l l'. Proof. unfold WeakInclusion. intros; split; intros. - unfold getListFullLabel_diff; rewrite (List_FullLabel_perm_getNumExecs_rewrite _ H), (List_FullLabel_perm_getNumCalls_rewrite _ H); reflexivity. - setoid_rewrite (List_FullLabel_perm_getRleOrMeth_perm H); assumption. Qed. Lemma MatchingExecCalls_Base_List_FullLabel_perm_rewrite m l l' : List_FullLabel_perm l l' -> MatchingExecCalls_Base l m -> MatchingExecCalls_Base l' m. Proof. unfold MatchingExecCalls_Base. intros; rewrite <-H; apply H0; auto. Qed. Lemma MatchingExecCalls_Concat_List_FullLabel_perm_rewrite_1 m l l' l'': List_FullLabel_perm l l' -> MatchingExecCalls_Concat l l'' m -> MatchingExecCalls_Concat l' l'' m. Proof. unfold MatchingExecCalls_Concat; intros. rewrite <-H; apply H0; auto. rewrite H; assumption. Qed. Lemma MatchingExecCalls_Concat_List_FullLabel_perm_rewrite_2 m l l' l'': List_FullLabel_perm l l' -> MatchingExecCalls_Concat l'' l m -> MatchingExecCalls_Concat l'' l' m. Proof. unfold MatchingExecCalls_Concat; intros. rewrite <-H; apply H0; auto. Qed. Global Instance MatchingExecCalls_Base_List_FullLabel_perm_rewrite' : Proper (List_FullLabel_perm ==> Logic.eq ==> iff) (@MatchingExecCalls_Base) | 10. Proof. repeat red; intros; split; intros; subst; eauto using MatchingExecCalls_Base_List_FullLabel_perm_rewrite, List_FullLabel_perm_sym. Qed. Global Instance MatchingExecCalls_Concat_List_FullLabel_perm_rewrite' : Proper (List_FullLabel_perm ==> List_FullLabel_perm ==> Logic.eq ==> iff) (@MatchingExecCalls_Concat) | 10. Proof. repeat red; intros; split; intros; subst; eauto using MatchingExecCalls_Concat_List_FullLabel_perm_rewrite_1, MatchingExecCalls_Concat_List_FullLabel_perm_rewrite_2, List_FullLabel_perm_sym. Qed. Lemma PStep_Step m o l: PStep m o l -> (exists o' l', o [=] o' /\ getKindAttr o' = getKindAttr (getAllRegisters m) /\ List_FullLabel_perm l l' /\ Step m o' l'). Proof. induction 1. - apply PSubsteps_Substeps in HPSubsteps; dest. exists x, x0. repeat split; auto. econstructor 1; auto. rewrite <- H0; assumption. - dest. exists x, x0; repeat split; eauto. econstructor 2; auto. intros; unfold getListFullLabel_diff in *. rewrite <-H2; apply HHidden; auto. - dest. exists (x1++x), (x2++x0). repeat split. + rewrite HRegs, H5, H1; reflexivity. + simpl; repeat rewrite map_app; rewrite H2, H6; reflexivity. + rewrite HLabels. eapply List_FullLabel_perm_app; eauto. + econstructor 3; eauto. * rewrite <- H7; rewrite <- H3; assumption. * rewrite <- H7; rewrite <- H3; assumption. * intros. apply (List_FullLabel_perm_in (List_FullLabel_perm_sym H7)) in H9; apply (List_FullLabel_perm_in (List_FullLabel_perm_sym H3)) in H10; dest. specialize (HNoRle _ _ H12 H11). inv H9; inv H10; subst; simpl in *; assumption. Qed. Lemma Step_PStep m o l: Step m o l -> PStep m o l. Proof. induction 1; econstructor; subst;eauto. - apply Substeps_PSubsteps; assumption. Qed. Inductive List_FullLabel_perm_Lists : (list (list FullLabel)) -> (list (list FullLabel)) -> Prop := |PermutationEquiv_nil : List_FullLabel_perm_Lists nil nil |PermutationEquiv_cons ls ls' l l' : List_FullLabel_perm_Lists ls ls' -> List_FullLabel_perm l l' -> List_FullLabel_perm_Lists (l::ls) (l'::ls'). Lemma List_FullLabel_perm_Lists_refl l : List_FullLabel_perm_Lists l l. Proof. induction l; econstructor; eauto. reflexivity. Qed. Lemma List_FullLabel_perm_Lists_sym l l' : List_FullLabel_perm_Lists l l' -> List_FullLabel_perm_Lists l' l. Proof. induction 1; econstructor; eauto using List_FullLabel_perm_sym. Qed. Lemma List_FullLabel_perm_Lists_trans l: forall l' l'', List_FullLabel_perm_Lists l l' -> List_FullLabel_perm_Lists l' l'' -> List_FullLabel_perm_Lists l l''. Proof. induction l; eauto; intros; inv H; inv H0. - constructor. - constructor. + eapply IHl; eauto. + rewrite H5; assumption. Qed. Lemma List_FullLabel_perm_Lists_len l l' : List_FullLabel_perm_Lists l l' -> length l = length l'. Proof. induction 1;[|simpl; rewrite IHList_FullLabel_perm_Lists]; reflexivity. Qed. Lemma List_FullLabel_perm_Lists_WeakInclusions l l' : List_FullLabel_perm_Lists l l' -> WeakInclusions l l'. Proof. induction 1. - apply WeakInclusionsRefl. - econstructor; eauto. apply List_FullLabel_perm_WeakInclusion in H0; assumption. Qed. Lemma RegInit_generalized_list x: forall o' l, o' [=] x -> map fst l = map fst x -> (forall (o : string * {x : FullKind & fullType type x}) (r : string * {x : FullKind & option (ConstFullT x)}), In o o' -> In r l -> fst o = fst r -> exists pf : projT1 (snd o) = projT1 (snd r), match projT2 (snd r) with | Some x => match pf in (_ = Y) return (fullType type Y) with | eq_refl => projT2 (snd o) end = evalConstFullT x | None => True end) -> Forall2 (fun (o'0 : string * {x : FullKind & fullType type x}) (r : string * {x0 : FullKind & option (ConstFullT x0)}) => fst o'0 = fst r /\ (exists pf : projT1 (snd o'0) = projT1 (snd r), match projT2 (snd r) with | Some x0 => match pf in (_ = Y) return (fullType type Y) with | eq_refl => projT2 (snd o'0) end = evalConstFullT x0 | None => True end)) x l. Proof. induction x; intros; inv H0. - apply map_eq_nil in H3; rewrite H3. constructor. - destruct l; inv H3. constructor. + split; [symmetry; assumption|]. apply (H1 a p (Permutation_in _ (Permutation_sym H) (in_eq _ _)) (in_eq _ _) (eq_sym H2)). + eapply IHx; eauto. intros. eapply H1;[rewrite H | |]; try right; assumption. Qed. Lemma keys_establish_order (A B : Type): forall (l : list (A*B)), NoDup (map fst l) -> forall (l' : list (A*B)), l [=] l' -> (map fst l = map fst l') -> l = l'. Proof. induction l; eauto; intros. - apply Permutation_nil in H0; rewrite H0; reflexivity. - destruct l';[ symmetry in H0; apply Permutation_nil in H0; inv H0|]. simpl in *; inv H1; inv H. specialize (Permutation_in _ H0 (in_eq _ _)) as T; destruct T. + subst. apply Permutation_cons_inv in H0. rewrite (IHl H6 _ H0 H4); reflexivity. + apply False_ind. apply H5; rewrite H4. apply (in_map fst) in H; assumption. Qed. Lemma List_FullLabel_perm_fst l l': List_FullLabel_perm l l' -> forall a, In a (map fst l) -> (exists a', a [=] a' /\ In a' (map fst l')). Proof. induction 1; simpl; eauto; intros. - destruct H1; subst. + inv H; simpl in *. exists u'; split; eauto. + specialize (IHList_FullLabel_perm a H1); dest. exists x; split; eauto. - repeat destruct H2; subst. + inv H. exists u'; split; eauto. + inv H0. exists u'; split; eauto. + specialize (IHList_FullLabel_perm a H2); dest. exists x; split; eauto. - specialize (IHList_FullLabel_perm1 a H1); dest. specialize (IHList_FullLabel_perm2 x H3); dest. exists x0; split; eauto using Permutation_trans. Qed. Lemma Forall2_RegInit_keymatch x : forall l, Forall2 (fun (o'0 : string * {x : FullKind & fullType type x}) (r : Attribute (sigT RegInitValT)) => fst o'0 = fst r /\ (exists pf : projT1 (snd o'0) = projT1 (snd r), match projT2 (snd r) with | None => True | Some x0 => match pf in (_ = Y) return (fullType type Y) with | eq_refl => projT2 (snd o'0) end = evalConstFullT x0 end)) x l -> map fst x = map fst l. Proof. induction x; intros; inv H. - reflexivity. - simpl. destruct H2. rewrite H. rewrite (IHx _ H4); reflexivity. Qed. Lemma PTrace_Trace m o ls: (WfMod type m) -> PTrace m o ls -> (exists o' ls', o' [=] o /\ map fst o' = map fst (getAllRegisters m) /\ List_FullLabel_perm_Lists ls ls' /\ Trace m o' ls'). Proof. induction 2; subst. - exists o'', nil; repeat split; eauto using Permutation_sym; try econstructor; eauto. apply Forall2_RegInit_keymatch; assumption. - specialize (WfNoDups H) as TMP; dest. apply PStep_Step in HPStep; dest. unfold PUpdRegs in HPUpdRegs; dest. rewrite <- H4 in H12. specialize (getKindAttr_perm_eq _ _ _ _ (H12)) as TMP; dest. exists x3, (x2::x0). rewrite <- H5 in H1. rewrite <- H4 in H8. specialize (getKindAttr_map_fst _ _ H9); intros. rewrite <- H5 in H16. specialize (keys_establish_order H1 H8 (eq_sym H16)) as eq_x_x1. specialize (getKindAttr_map_fst _ _ H15); intros. setoid_rewrite <- H17 in H1. repeat split; eauto using Permutation_sym. + setoid_rewrite H17; setoid_rewrite H5; reflexivity. + econstructor; eauto. + econstructor 2; eauto. * rewrite eq_x_x1; assumption. * specialize (List_FullLabel_perm_fst H10). intros. split; eauto. intros. rewrite <- H14 in H19. specialize (H13 _ _ H19); dest. destruct H13;[left|right];dest. -- specialize (H18 _ H13); dest. exists x5; split; auto. rewrite <- H18; assumption. -- split;[|rewrite H4];auto. intro; dest. apply H13. specialize (List_FullLabel_perm_fst (List_FullLabel_perm_sym H10) _ H21) as TMP; dest. exists x5; split; eauto. rewrite <- H23; assumption. Qed. Lemma Trace_PTrace m o ls : Trace m o ls -> PTrace m o ls. Proof. induction 1; subst. - econstructor; eauto. - econstructor 2; eauto. + apply Step_PStep in HStep. assumption. + unfold PUpdRegs; unfold UpdRegs in HUpdRegs; dest. split; eauto. rewrite H0; reflexivity. Qed. Lemma PTraceInclusion_TraceInclusion m1 m2 : (WfMod type m1) -> (WfMod type m2) -> PTraceInclusion m1 m2 -> TraceInclusion m1 m2. Proof. intros. apply TraceInclusion'_TraceInclusion. repeat intro. apply Trace_PTrace in H2. specialize (H1 o ls H2); dest. unfold PTraceList in H1; dest. apply PTrace_Trace in H1; dest; eauto. exists x2; split. - exists x1; assumption. - specialize (List_FullLabel_perm_Lists_WeakInclusions H5) as trans. apply (WeakInclusionsTrans H3 trans). Qed. Section PSubsteps_rewrite. Lemma PSubsteps_rewrite_regs m o1 o2 l: (o1 [=] o2) -> PSubsteps m o1 l -> PSubsteps m o2 l. Proof. induction 2. - econstructor 1. rewrite <- H; assumption. - econstructor 2;[rewrite <- H|apply HInRules|apply (PSemAction_rewrite_state H) in HPAction; apply HPAction| | |apply HLabel| | | ];assumption. - econstructor 3;[rewrite <- H|apply HInMeths|apply (PSemAction_rewrite_state H) in HPAction; apply HPAction| | |apply HLabel| | ];assumption. Qed. Lemma PSubsteps_rewrite_lists m o l1 l2: (l1 [=] l2) -> PSubsteps m o l1 -> PSubsteps m o l2. Proof. induction 2. - apply Permutation_nil in H; rewrite H. econstructor 1; assumption. - econstructor 2; eauto. rewrite H in HLabel. assumption. - econstructor 3; eauto. rewrite H in HLabel. assumption. Qed. Lemma PSubsteps_rewrite_both m o1 o2 l1 l2 : o1 [=] o2 -> l1 [=] l2 -> PSubsteps m o1 l1 -> PSubsteps m o2 l2. Proof. intros; apply (PSubsteps_rewrite_regs H) in H1; apply (PSubsteps_rewrite_lists H0) in H1; assumption. Qed. Inductive BaseModule_perm : BaseModule -> BaseModule -> Prop := | perm_equiv m m' (HRegsPerm : getRegisters m [=] getRegisters m') (HMethsPerm : getMethods m [=] getMethods m') (HRulesPerm : getRules m [=] getRules m') : BaseModule_perm m m'. Lemma BaseModule_perm_refl m : BaseModule_perm m m. Proof. constructor; auto. Qed. Lemma BaseModule_perm_sym m m' : BaseModule_perm m m' -> BaseModule_perm m' m. Proof. intro; induction H; constructor; eauto using Permutation_sym. Qed. Lemma BaseModule_perm_trans m m' m'': BaseModule_perm m m' -> BaseModule_perm m' m'' -> BaseModule_perm m m''. Proof. intros. induction H, H0; constructor; eauto using Permutation_trans. Qed. Global Instance BaseModule_perm_Equivalence : Equivalence (@BaseModule_perm) | 10 := { Equivalence_Reflexive := @BaseModule_perm_refl; Equivalence_Symmetric := @BaseModule_perm_sym; Equivalence_Transitive:= @BaseModule_perm_trans}. Lemma PSubsteps_BaseModule_rewrite m m' o l : BaseModule_perm m m' -> PSubsteps m o l -> PSubsteps m' o l. Proof. intro; inv H; induction 1. - econstructor 1; rewrite <- HRegsPerm; assumption. - econstructor 2; try rewrite <- HRegsPerm; try rewrite <- HRulesPerm; eauto. - econstructor 3; try rewrite <- HRegsPerm; try rewrite <- HMethsPerm; eauto. Qed. Lemma PSubsteps_rewrite_all m m' o o' l l' : BaseModule_perm m m' -> o [=] o' -> l [=] l' -> PSubsteps m o l -> PSubsteps m' o' l'. Proof. intros. apply (PSubsteps_BaseModule_rewrite H) in H2. apply (PSubsteps_rewrite_both H0 H1) in H2. assumption. Qed. Lemma List_FullLabel_perm_app_rewrite_l l1 l2 l3 : List_FullLabel_perm l1 l2 -> List_FullLabel_perm (l1++l3) (l2++l3). Proof. induction 1; simpl; eauto using List_FullLabel_perm_refl, LFL_eq_cons_1, LFL_eq_cons_2, LFL_eq_trans. Qed. Lemma List_FullLabel_perm_app_rewrite_r l1 l2 l3 : List_FullLabel_perm l1 l2 -> List_FullLabel_perm (l3++l1) (l3++l2). Proof. intros. rewrite Permutation_app_comm; apply List_FullLabel_perm_sym; rewrite Permutation_app_comm; apply List_FullLabel_perm_sym. apply List_FullLabel_perm_app_rewrite_l; auto. Qed. Global Instance List_FullLabel_perm_app_rewrite : Proper (List_FullLabel_perm ==> List_FullLabel_perm ==> List_FullLabel_perm) (@app FullLabel) | 10. Proof. repeat red; intros. specialize (List_FullLabel_perm_app_rewrite_l x0 H) as P1. specialize (List_FullLabel_perm_app_rewrite_r y H0) as P2. eauto using List_FullLabel_perm_trans. Qed. Global Instance PSubsteps_rewrite' : Proper (@BaseModule_perm ==> @Permutation (string * {x : FullKind & fullType type x}) ==> @Permutation (FullLabel) ==> iff) (@PSubsteps)| 10. Proof. repeat red; intros; split; intros; eauto using Permutation_sym, BaseModule_perm_sym, PSubsteps_rewrite_all. Qed. End PSubsteps_rewrite. Section InExec_InCall_perm. Variable f : MethT. Lemma InCall_perm l l' : l [=] l' -> InCall f l -> InCall f l'. induction 1; intros. - assumption. - apply (InCall_app_iff f (x::nil) l'). apply (InCall_app_iff f (x::nil) l) in H0. destruct H0;[left|right; apply IHPermutation];assumption. - apply (InCall_app_iff f (x::y::nil) l). apply (InCall_app_iff f (y::x::nil) l) in H. destruct H;[left;apply (InCall_app_iff f (x::nil) (y::nil)) | right]; [apply (InCall_app_iff f (y::nil) (x::nil)) in H; destruct H;[right|left]|];assumption. - apply (IHPermutation2 (IHPermutation1 H1)). Qed. Lemma InExec_perm l l' : l [=] l' -> InExec f l -> InExec f l'. induction 1; intros. - assumption. - apply (InExec_app_iff f (x::nil) l'). apply (InExec_app_iff f (x::nil) l) in H0. destruct H0;[left|right; apply IHPermutation];assumption. - apply (InExec_app_iff f (x::y::nil) l). apply (InExec_app_iff f (y::x::nil) l) in H. destruct H;[left;apply (InExec_app_iff f (x::nil) (y::nil)) | right]; [apply (InExec_app_iff f (y::nil) (x::nil)) in H; destruct H;[right|left]|];assumption. - apply (IHPermutation2 (IHPermutation1 H1)). Qed. Global Instance InCall_perm' : Proper (@Permutation (FullLabel) ==> iff) (@InCall f) | 10. Proof. repeat red; intros; specialize (Permutation_sym H) as TMP; eauto using InCall_perm. Qed. Global Instance InExec_perm' : Proper (@Permutation (FullLabel) ==> iff) (@InExec f) | 10. Proof. repeat red; intros; specialize (Permutation_sym H) as TMP; eauto using InExec_perm. Qed. End InExec_InCall_perm. Section PStep_rewrite. Lemma PStep_rewrite m o1 o2 l1 l2 : (o1 [=] o2) -> (l1 [=] l2) -> PStep m o1 l1 -> PStep m o2 l2. Proof. induction 3. - econstructor 1. apply (PSubsteps_rewrite_regs H). apply (PSubsteps_rewrite_lists H0). assumption. rewrite <- H0. assumption. - econstructor 2; eauto. intros. unfold getListFullLabel_diff in *. rewrite <- H0. eapply HHidden; eauto. - econstructor 3; eauto. + rewrite <- H; assumption. + rewrite <- H0; assumption. Qed. Lemma List_FullLabel_perm_app_split l1 l2 : forall l3, List_FullLabel_perm (l1++l2) l3 -> exists l1' l2', List_FullLabel_perm l1 l1' /\ List_FullLabel_perm l2 l2' /\ l3 [=] l1'++l2'. Proof. induction l1; simpl. - intros; exists nil, l3. repeat split; auto. reflexivity. - intros. specialize (List_FullLabel_perm_in H _ (in_eq _ _)) as TMP; dest. apply in_split in H1; dest; subst. rewrite <-Permutation_middle in H. apply List_FullLabel_perm_cons_inv in H; auto. specialize (IHl1 _ H); dest. exists (x::x2), x3; repeat split;auto. + constructor 2; auto. + rewrite <-Permutation_middle, H3; simpl; reflexivity. Qed. Lemma PStep_rewrite2 m o l1 : PStep m o l1 -> forall l2, List_FullLabel_perm l1 l2 -> PStep m o l2. Proof. induction 1; auto. - econstructor 1; rewrite <-H; auto. - econstructor 2; auto. unfold getListFullLabel_diff in *; setoid_rewrite <-H0; auto. - intros; rewrite HLabels in H1. specialize (List_FullLabel_perm_app_split _ _ H1) as TMP; dest. econstructor 3; auto. + eapply IHPStep1; eauto. + eapply IHPStep2; eauto. + rewrite H2, H3 in HMatching1; assumption. + rewrite H2, H3 in HMatching2; assumption. + intros. specialize (List_FullLabel_perm_in (List_FullLabel_perm_sym H2) _ H5) as TMP; dest. specialize (List_FullLabel_perm_in (List_FullLabel_perm_sym H3) _ H6) as TMP; dest. specialize (HNoRle _ _ H8 H10). inv H7; inv H9; simpl in *; assumption. + assumption. + assumption. Qed. Global Instance PStep_perm_rewrite' : Proper (Logic.eq ==> @Permutation (string * {x : FullKind & fullType type x}) ==> @List_FullLabel_perm ==> iff) (@PStep) | 10. repeat red; split; intros; subst; specialize (Permutation_sym H0) as TMP; specialize (List_FullLabel_perm_sym H1) as TMP1; eauto using PStep_rewrite, PStep_rewrite2. Qed. End PStep_rewrite. Lemma PSemActionUpdSub o k a reads upds calls ret: @PSemAction o k a reads upds calls ret -> SubList (getKindAttr upds) (getKindAttr o). Proof. induction 1; auto; unfold SubList in *; intros; rewrite ?in_app_iff in *. - rewrite HUNewRegs in *. rewrite map_app, in_app_iff in *. destruct H1; firstorder fail. - subst; rewrite HANewRegs in *. destruct H0; subst; simpl; auto. - rewrite HUNewRegs in *. rewrite map_app, in_app_iff in *. destruct H1; intuition. - rewrite HUNewRegs in *. rewrite map_app, in_app_iff in *. destruct H1; intuition. - subst; simpl in *; intuition. Qed. Lemma PSemActionExpandRegs o k a reads upds calls ret: @PSemAction o k a reads upds calls ret -> forall o', SubList reads o' -> SubList (getKindAttr upds) (getKindAttr o') -> @PSemAction o' k a reads upds calls ret. Proof. intros. induction H; try solve [econstructor; auto]. - subst. specialize (IHPSemAction H0). econstructor; eauto. - rewrite HUReadRegs in *; rewrite HUNewRegs in *. apply SubList_app_l in H0; dest. rewrite map_app in *. apply SubList_app_l in H1; dest. specialize (IHPSemAction1 H0 H1). specialize (IHPSemAction2 H3 H4). econstructor; eauto. - rewrite HNewReads in *. apply SubList_cons in H0; dest. specialize (IHPSemAction H2 H1). econstructor; eauto. - rewrite HANewRegs in *. simpl in *. apply SubList_cons in H1; dest. specialize (IHPSemAction H0 H2). econstructor; eauto. - rewrite HUReadRegs in *; rewrite HUNewRegs in *. apply SubList_app_l in H0; dest. rewrite map_app in *. apply SubList_app_l in H1; dest. specialize (IHPSemAction1 H0 H1). specialize (IHPSemAction2 H3 H4). econstructor; eauto. - rewrite HUReadRegs in *; rewrite HUNewRegs in *. apply SubList_app_l in H0; dest. rewrite map_app in *. apply SubList_app_l in H1; dest. specialize (IHPSemAction1 H0 H1). specialize (IHPSemAction2 H3 H4). econstructor 8; eauto. Qed. Lemma PSubsteps_upd_SubList_key m o l: PSubsteps m o l -> forall x s v, In x (map fst l) -> In (s, v) x -> In s (map fst (getRegisters m)). Proof. induction 1; intros. - simpl in *; tauto. - subst; rewrite HLabel in H0. destruct H0; subst; simpl in *. + apply (in_map (fun x => (fst x, projT1 (snd x)))) in H1; simpl in *. specialize (HUpdGood _ H1). apply (in_map fst) in HUpdGood. rewrite map_map in HUpdGood. simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HUpdGood; auto. + eapply IHPSubsteps; eauto. - subst; rewrite HLabel in H0. destruct H0; subst; simpl in *. + apply (in_map (fun x => (fst x, projT1 (snd x)))) in H1; simpl in *. specialize (HUpdGood _ H1). apply (in_map fst) in HUpdGood. rewrite map_map in HUpdGood. simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HUpdGood; auto. + eapply IHPSubsteps; eauto. Qed. Lemma PSubsteps_upd_In m o l: PSubsteps m o l -> forall x, In x (map fst l) -> forall s: string, In s (map fst x) -> In s (map fst (getRegisters m)). Proof. intros. rewrite in_map_iff in H1; dest; subst. destruct x0; simpl. eapply PSubsteps_upd_SubList_key; eauto. Qed. Lemma PSubsteps_meth_In m o l : PSubsteps m o l -> forall u f cs, In (u, (Meth f, cs)) l -> In (fst f) (map fst (getMethods m)). Proof. intros. apply (PSubsteps_Substeps) in H; dest. specialize (List_FullLabel_perm_in H1 _ H0) as TMP; dest. inv H4. apply (Substeps_meth_In H3 _ _ _ H5). Qed. Lemma PSubsteps_combine m1 o1 l1: PSubsteps m1 o1 l1 -> forall m2 o2 l2 (DisjRegs: DisjKey (getRegisters m1) (getRegisters m2)) (DisjMeths: DisjKey (getMethods m1) (getMethods m2)) (HOneRle: forall x1 x2, In x1 l1 -> In x2 l2 -> match fst (snd x1), fst (snd x2) with | Rle _, Rle _ => False | _, _ => True end), PSubsteps m2 o2 l2 -> PSubsteps (BaseMod (getRegisters m1 ++ getRegisters m2) (getRules m1 ++ getRules m2) (getMethods m1 ++ getMethods m2)) (o1 ++ o2) (l1 ++ l2). Proof. intros. apply PSubsteps_Substeps in H; apply PSubsteps_Substeps in H0. dest; rewrite H, H0. rewrite H1, H4. apply Substeps_PSubsteps. eapply Substeps_combine; eauto. intros; clear - H1 H4 H7 H8 HOneRle. apply (in_map getRleOrMeth) in H7; apply (in_map getRleOrMeth) in H8. rewrite <-(List_FullLabel_perm_getRleOrMeth H4) in H7. rewrite <-(List_FullLabel_perm_getRleOrMeth H1) in H8. rewrite in_map_iff in H7, H8; dest. specialize (HOneRle _ _ H3 H0); rewrite H, H2 in HOneRle; assumption. Qed. Corollary PStep_meth_InExec m o l : PStep m o l -> forall f : MethT, InExec f l -> In (fst f) (map fst (getAllMethods m)). Proof. intros. apply PStep_Step in H; dest. eapply (Step_meth_InExec H3 f). apply (List_FullLabel_perm_InExec_rewrite f H2); assumption. Qed. Lemma List_FullLabel_perm_MatchingExecCalls_Base_rewrite l l' m : List_FullLabel_perm l l' -> MatchingExecCalls_Base l m -> MatchingExecCalls_Base l' m. Proof. intros LFL_perm HMec1 f HInDef. specialize (HMec1 f HInDef). rewrite <-LFL_perm; assumption. Qed. Lemma List_FullLabel_perm_MatchingExecCalls_Concat_rewrite1 l1 l2 l3 m : List_FullLabel_perm l1 l2 -> MatchingExecCalls_Concat l1 l3 m -> MatchingExecCalls_Concat l2 l3 m. Proof. unfold MatchingExecCalls_Concat. intros; rewrite <-H. apply H0; auto. rewrite H; assumption. Qed. Lemma List_FullLabel_perm_MatchingExecCalls_Concat_rewrite2 l1 l2 l3 m : List_FullLabel_perm l1 l2 -> MatchingExecCalls_Concat l3 l1 m -> MatchingExecCalls_Concat l3 l2 m. Proof. unfold MatchingExecCalls_Concat. intros; rewrite <-H. apply H0; auto. Qed. Lemma PStep_substitute' m o l: PStep m o l -> forall (HWfMod: WfMod type m), PStepSubstitute m o l. Proof. intros. apply PStep_Step in H; dest. specialize (HWfMod). apply (@Step_substitute' type) in H2; auto. unfold StepSubstitute in H2; dest. unfold PStepSubstitute; repeat split. - rewrite H, H1; apply Substeps_PSubsteps; auto. - rewrite H1; assumption. - intros; unfold getListFullLabel_diff in *; rewrite H1. apply H4; auto. Qed. Lemma PStepSubstitute_flatten m o l (HWfMod: WfMod type m): PStep (flatten m) o l <-> PStepSubstitute m o l. Proof. unfold flatten, getFlat, PStepSubstitute. split; intros. - induction (getHidden m). + simpl in *. inv H. split; [auto| split; [auto| intros; tauto]]. + simpl in *. inv H. specialize (IHl0 HPStep); dest. split; [auto| split; [auto| intros]]. rewrite createHide_Meths in *; simpl in *. destruct H3; [subst |clear - H1 H2 H3; apply H1; auto]. apply HHidden; assumption. - induction (getHidden m); simpl; auto; dest. + constructor; auto. + assert (sth: PStep (createHide (BaseMod (getAllRegisters m) (getAllRules m) (getAllMethods m)) l0) o l) by (apply IHl0; repeat split; auto; intros; apply H1; simpl; auto). assert (sth2: forall v, In (a, projT1 v) (getKindAttr (getAllMethods m)) -> (getListFullLabel_diff (a, v) l = 0%Z)) by (intros; apply H1; auto; left; reflexivity). constructor; auto. rewrite createHide_Meths. auto. Qed. Lemma PStep_substitute m o l (HWfMod: WfMod type m): PStep m o l -> PStep (flatten m) o l. Proof. intros Stp. apply PStep_substitute' in Stp; auto. rewrite PStepSubstitute_flatten in *; auto. Qed. Lemma splitRegs_perm o m1 m2 (DisjRegisters: DisjKey (getRegisters m1) (getRegisters m2)): getKindAttr o [=] getKindAttr (getRegisters m1 ++ getRegisters m2) -> getKindAttr (filter (fun x : string * {x : FullKind & fullType type x} => getBool (in_dec string_dec (fst x) (map fst (getRegisters m1)))) o) [=] getKindAttr (getRegisters m1). Proof. intros HRegs. rewrite map_app in *. pose proof (filter_map_simple (fun x: string * {x: FullKind & fullType type x} => (fst x, projT1 (snd x))) (fun x => getBool (in_dec string_dec (fst x) (map fst (getRegisters m1)))) o) as sth. simpl in sth. setoid_rewrite <- sth. setoid_rewrite HRegs. rewrite filter_app. setoid_rewrite filter_false_list at 2. - rewrite filter_true_list at 1. + rewrite app_nil_r; auto. + intros. apply (in_map fst) in H. rewrite map_map in H. simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in H; try tauto. destruct (in_dec string_dec (fst a) (map fst (getRegisters m1))); auto. - intros. apply (in_map fst) in H. rewrite map_map in H. simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in H; try tauto. destruct (in_dec string_dec (fst a) (map fst (getRegisters m1))); auto. specialize (DisjRegisters (fst a)). tauto. Qed. Global Instance BaseModuleFilter_rewrite' : Proper (Logic.eq ==> @Permutation (FullLabel) ==> @Permutation (FullLabel)) (@ModuleFilterLabels) | 10. Proof. unfold ModuleFilterLabels; repeat red; intros; rewrite H, H0; reflexivity. Qed. Lemma WfActionT_ReadsWellDefined_perm : forall (k : Kind)(a : ActionT type k)(retl : type k) (m1 : BaseModule)(o readRegs newRegs : RegsT)(calls : MethsT), WfActionT (getRegisters m1) a -> PSemAction o a readRegs newRegs calls retl -> SubList (getKindAttr readRegs) (getKindAttr (getRegisters m1)). Proof. intros. apply (PSemAction_SemAction) in H0; dest. rewrite H0. eapply (WfActionT_ReadsWellDefined _ H H3); eauto. Qed. Lemma WfActionT_WritesWellDefined_perm : forall (k : Kind)(a : ActionT type k)(retl : type k) (m1 : BaseModule)(o readRegs newRegs : RegsT)(calls : MethsT), WfActionT (getRegisters m1) a -> PSemAction o a readRegs newRegs calls retl -> SubList (getKindAttr newRegs) (getKindAttr (getRegisters m1)). Proof. intros. apply (PSemAction_SemAction) in H0; dest. rewrite H1. eapply (WfActionT_WritesWellDefined); eauto. Qed. Lemma WfActionT_PSemAction : forall (k : Kind)(a : ActionT type k)(retl : type k) (m1 : BaseModule)(o readRegs newRegs : RegsT)(calls : MethsT), WfActionT (getRegisters m1) a -> NoDup (map fst o) -> PSemAction o a readRegs newRegs calls retl -> (forall (o1 : RegsT), SubList o1 o -> getKindAttr o1 [=] getKindAttr (getRegisters m1) -> PSemAction o1 a readRegs newRegs calls retl). induction 3; intro; subst; inversion H; EqDep_subst. - intros TMP1 TMP2; specialize (IHPSemAction (H4 mret) o1 TMP1 TMP2). econstructor 1; eauto. - intros TMP1 TMP2; specialize (IHPSemAction (H4 (evalExpr e)) o1 TMP1 TMP2). econstructor 2; eauto. - intros TMP1 TMP2; specialize (IHPSemAction1 (H4) o1 TMP1 TMP2); specialize (IHPSemAction2 (H6 v) o1 TMP1 TMP2). econstructor 3; eauto. - intros TMP1 TMP2; specialize (IHPSemAction (H4 valueV) o1 TMP1 TMP2). econstructor 4; eauto. - intros TMP1 TMP2; specialize (IHPSemAction (H5 regV) o1 TMP1 TMP2). econstructor 5; eauto. apply (KeyRefinement (r, existT (fullType type) regT regV) H0 TMP1 HRegVal). rewrite <- TMP2 in H7; apply (in_map fst) in H7; specialize (GKA_fst (A:=string)(fullType type) o1); intro. simpl in *. setoid_rewrite H2; assumption. - intros TMP1 TMP2; specialize (IHPSemAction H5 o1 TMP1 TMP2). econstructor 6; eauto. rewrite TMP2; assumption. - intros TMP1 TMP2; specialize (IHPSemAction1 H8 o1 TMP1 TMP2); specialize (IHPSemAction2 (H5 r1) o1 TMP1 TMP2). econstructor 7; eauto. - intros TMP1 TMP2; specialize (IHPSemAction1 H9 o1 TMP1 TMP2); specialize (IHPSemAction2 (H5 r1) o1 TMP1 TMP2). econstructor 8; eauto. - intros TMP1 TMP2; specialize (IHPSemAction H4 o1 TMP1 TMP2). econstructor 9; eauto. - intros; econstructor 10; eauto. Qed. Lemma papp_sublist_l : forall {A : Type} (l1 l2 l : list A), l [=] l1++l2 -> SubList l1 l. Proof. repeat intro. rewrite H. apply (in_app_iff l1 l2 x); left; assumption. Qed. Lemma papp_sublist_r : forall {A : Type} (l1 l2 l : list A), l [=] l1++l2 -> SubList l2 l. Proof. repeat intro. rewrite H. apply (in_app_iff l1 l2 x); right; assumption. Qed. Section SplitSubsteps. Variable m1 m2: BaseModule. Variable DisjRegs: DisjKey (getRegisters m1) (getRegisters m2). Variable DisjRules: DisjKey (getRules m1) (getRules m2). Variable DisjMeths: DisjKey (getMethods m1) (getMethods m2). Variable WfMod1: WfBaseModule type m1. Variable WfMod2: WfBaseModule type m2. Lemma pfilter_perm o l : PSubsteps (concatFlat m1 m2) o l -> l [=] ((ModuleFilterLabels m1 l)++(ModuleFilterLabels m2 l)). Proof. induction 1; subst. - simpl; apply Permutation_refl. - unfold ModuleFilterLabels; setoid_rewrite HLabel; fold (ModuleFilterLabels m1 ((u, (Rle rn, cs))::ls)); fold (ModuleFilterLabels m2 ((u, (Rle rn, cs))::ls)). apply in_app_iff in HInRules. destruct HInRules as [HInRules | HInRules]; rewrite (InRules_Filter _ _ _ _ _ _ HInRules). + destruct (DisjRules rn). * generalize (in_map_iff fst (getRules m1) rn). intro TMP; destruct TMP as [L R];clear L. assert (exists x, fst x = rn /\ In x (getRules m1));[exists (rn, rb); auto| specialize (R H1); contradiction]. * rewrite (NotInRules_Filter _ _ _ _ _ H0). constructor. assumption. + destruct (DisjRules rn). * rewrite (NotInRules_Filter _ _ _ _ _ H0). apply (Permutation_cons_app _ _ _ IHPSubsteps). * generalize (in_map_iff fst (getRules m2) rn). intro TMP; destruct TMP as [L R];clear L. assert (exists x, fst x = rn /\ In x (getRules m2));[exists (rn, rb); auto | specialize (R H1); contradiction]. - apply in_app_iff in HInMeths. unfold ModuleFilterLabels; rewrite HLabel; fold (ModuleFilterLabels m1 ( (u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs))::ls)); fold (ModuleFilterLabels m2 ((u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs))::ls)); destruct HInMeths as [HInMeths | HInMeths]; rewrite (InMethods_Filter _ _ _ _ _ _ _ _ HInMeths). + destruct (DisjMeths fn). * generalize (in_map_iff fst (getMethods m1) fn). intro TMP; destruct TMP as [L R]; clear L. assert (exists x, fst x = fn /\ In x (getMethods m1)); [exists (fn, fb); auto| specialize (R H1); contradiction]. * rewrite (NotInMethods_Filter _ _ _ _ _ _ _ _ H0). constructor. assumption. + destruct (DisjMeths fn). * rewrite (NotInMethods_Filter _ _ _ _ _ _ _ _ H0). apply (Permutation_cons_app _ _ _ IHPSubsteps). * generalize (in_map_iff fst (getMethods m2) fn). intro TMP; destruct TMP as [L R]; clear L. assert (exists x, fst x = fn /\ In x (getMethods m2)); [exists (fn, fb); auto| specialize (R H1); contradiction]. Qed. Lemma split_f A B (f : A -> B) : forall (ls : list A) (l1 l2 : list B), map f ls [=] l1 ++ l2 -> (exists (ls1 ls2 : list A), (ls [=] ls1++ls2) /\ (map f ls1 [=] l1) /\ (map f ls2 [=] l2)). Proof. induction ls; intros. - exists nil, nil. apply (Permutation_nil) in H; destruct (app_eq_nil _ _ H). repeat split. + reflexivity. + rewrite H0; reflexivity. + rewrite H1; reflexivity. - assert (In (f a) (map f (a::ls)));[left; reflexivity|]. rewrite H in H0. destruct (in_app_or _ _ _ H0). + specialize (in_split _ _ H1) as TMP; dest. rewrite H2 in H; simpl in H. rewrite <- app_assoc in H. specialize (Permutation_cons_app_inv (l:=(map f ls)) x (x0++l2) H) as TMP. rewrite app_assoc in TMP. specialize (IHls (x ++ x0) (l2) TMP) as TMP2; dest. exists (a::x1), x2. repeat split. * simpl; constructor; auto. * simpl; rewrite H2. apply Permutation_cons_app. assumption. * assumption. + specialize (in_split _ _ H1) as TMP; dest. rewrite H2 in H; simpl in H. rewrite app_assoc in H. specialize (Permutation_cons_app_inv (l:=(map f ls)) (l1++x) x0 H) as TMP. rewrite <- app_assoc in TMP. specialize (IHls (l1) (x++x0) TMP) as TMP2; dest. exists (x1), (a::x2). repeat split. * apply Permutation_cons_app; assumption. * assumption. * simpl; rewrite H2. apply Permutation_cons_app. assumption. Qed. Lemma List_FullLabel_perm_filter_rewrite m l l' : List_FullLabel_perm l l' -> List_FullLabel_perm (ModuleFilterLabels m l) (ModuleFilterLabels m l'). Proof. induction 1; auto. - reflexivity. - inv H; simpl; unfold BaseModuleFilter; simpl. destruct rm'. + destruct (existsb (strcmp rn) (map fst (getRules m))); auto. constructor 2; auto. constructor; auto. + destruct (existsb (strcmp (fst f)) (map fst (getMethods m))); auto. constructor 2; auto. constructor; auto. - inv H; inv H0; simpl; unfold BaseModuleFilter; simpl. destruct rm', rm'0. + destruct (existsb (strcmp rn) (map fst (getRules m))), (existsb (strcmp rn0) (map fst (getRules m))); auto. * apply LFL_eq_cons_2; auto; constructor; auto. * apply LFL_eq_cons_1; auto; constructor; auto. * apply LFL_eq_cons_1; auto; constructor; auto. + destruct (existsb (strcmp rn) (map fst (getRules m))), (existsb (strcmp (fst f)) (map fst (getMethods m))); auto. * apply LFL_eq_cons_2; auto; constructor; auto. * apply LFL_eq_cons_1; auto; constructor; auto. * apply LFL_eq_cons_1; auto; constructor; auto. + destruct (existsb (strcmp rn) (map fst (getRules m))), (existsb (strcmp (fst f)) (map fst (getMethods m))); auto. * apply LFL_eq_cons_2; auto; constructor; auto. * apply LFL_eq_cons_1; auto; constructor; auto. * apply LFL_eq_cons_1; auto; constructor; auto. + destruct (existsb (strcmp (fst f0)) (map fst (getMethods m))), (existsb (strcmp (fst f)) (map fst (getMethods m))); auto. * apply LFL_eq_cons_2; auto; constructor; auto. * apply LFL_eq_cons_1; auto; constructor; auto. * apply LFL_eq_cons_1; auto; constructor; auto. - eauto using List_FullLabel_perm_trans. Qed. Lemma split_PSubsteps1 o l: NoDup (map fst (getRegisters m1)) -> NoDup (map fst (getRegisters m2)) -> PSubsteps (concatFlat m1 m2) o l -> (exists o1 o2, getKindAttr o1 [=] getKindAttr (getRegisters m1) /\ getKindAttr o2 [=] getKindAttr (getRegisters m2) /\ o [=] o1++o2 /\ PSubsteps m1 o1 (ModuleFilterLabels m1 l) /\ PSubsteps m2 o2 (ModuleFilterLabels m2 l)). Proof. intros. apply PSubsteps_Substeps in H1; dest. apply split_Substeps1 in H4; dest; auto. exists x1, x2. repeat split. - rewrite H4; reflexivity. - rewrite H5; reflexivity. - rewrite H1, <- H6; reflexivity. - rewrite (List_FullLabel_perm_filter_rewrite m1 H2). apply Substeps_PSubsteps; assumption. - rewrite (List_FullLabel_perm_filter_rewrite m2 H2). apply Substeps_PSubsteps; assumption. Qed. Lemma split_PSubsteps2 o l: PSubsteps (concatFlat m1 m2) o l -> (forall x y : FullLabel, In x (ModuleFilterLabels m1 l) -> In y (ModuleFilterLabels m2 l) -> match fst (snd x) with | Rle _ => match fst (snd y) with | Rle _ => False | Meth _ => True end | Meth _ => True end). Proof. intros. apply PSubsteps_Substeps in H; dest. specialize (List_FullLabel_perm_filter_rewrite m1 H2) as P1; specialize (List_FullLabel_perm_filter_rewrite m2 H2) as P2. specialize (List_FullLabel_perm_in P1 _ H0) as TMP; dest. specialize (List_FullLabel_perm_in P2 _ H1) as TMP; dest. specialize (split_Substeps2 DisjRules DisjMeths H4 _ _ H6 H8) as P3. inv H5; inv H7; simpl in *; auto. Qed. End SplitSubsteps. Lemma PSubsteps_flatten m o l: PSubsteps (BaseMod (getRegisters m) (getRules m) (getMethods m)) o l -> PSubsteps m o l. Proof. induction 1; simpl; auto. - constructor 1; auto. - econstructor 2; eauto. - econstructor 3; eauto. Qed. Lemma flatten_PSubsteps m o l: PSubsteps m o l -> PSubsteps (BaseMod (getRegisters m) (getRules m) (getMethods m)) o l. induction 1; simpl; auto. - constructor 1; auto. - econstructor 2; eauto. - econstructor 3; eauto. Qed. Lemma substitute_PStep' m (HWfMod: WfMod type m): forall o l, PStepSubstitute m o l -> PStep m o l. Proof. unfold PStepSubstitute. intros; dest. apply PSubsteps_Substeps in H; dest. rewrite H2 in H0. unfold getListFullLabel_diff in H1. setoid_rewrite H2 in H1. assert (StepSubstitute m x x0). - unfold StepSubstitute; auto. - specialize (substitute_Step' HWfMod H5) as TMP; dest. rewrite H6 in H2; rewrite H, H2. apply Step_PStep; auto. Qed. Lemma substitute_PStep m o l (HWfMod: WfMod type m): PStep (flatten m) o l -> PStep m o l. Proof. rewrite PStepSubstitute_flatten in *; auto. apply substitute_PStep'; auto. Qed. Section PTraceSubstitute. Variable m: Mod. Variable WfMod_m: WfMod type m. Lemma PTrace_flatten_same1: forall o l, PTrace m o l -> PTrace (flatten m) o l. Proof. induction 1; subst. - (constructor 1 with (o'':= o'')); unfold flatten; auto. rewrite createHide_Regs. auto. - apply PStep_substitute in HPStep; auto. econstructor 2; eauto. Qed. Lemma PTrace_flatten_same2: forall o l, PTrace (flatten m) o l -> PTrace m o l. Proof. induction 1; subst. - rewrite getAllRegisters_flatten in *;constructor 1 with (o'' := o''); auto. - apply substitute_PStep in HPStep;auto; dest. + econstructor 2; eauto. Qed. Lemma PTraceInclusion_flatten_r: PTraceInclusion m (flatten m). Proof. unfold PTraceInclusion; intros. exists ls. split;[|apply WeakInclusionsRefl]. unfold PTraceList. exists o. apply PTrace_flatten_same1; assumption. Qed. Lemma PTraceInclusion_flatten_l: PTraceInclusion (flatten m) m. Proof. unfold PTraceInclusion; intros. apply PTrace_flatten_same2 in H. exists ls. split. - unfold PTraceList; exists o; auto. - apply WeakInclusionsRefl. Qed. End PTraceSubstitute. Section ModWf_rewrite. Inductive ModWf_perm ty : ModWf ty -> ModWf ty -> Prop := |Wf_perm_equiv (m m': ModWf ty) (HAllRegsPerm : getAllRegisters m [=] getAllRegisters m') (HAllMethsPerm : getAllMethods m [=] getAllMethods m') (HAllRulesPerm : getAllRules m [=] getAllRules m') (HHiddenPerm : getHidden m [=] getHidden m') : ModWf_perm m m'. Lemma ModWf_perm_refl ty m : @ModWf_perm ty m m. Proof. constructor; auto. Qed. Lemma ModWf_perm_sym ty m m': @ModWf_perm ty m m' -> ModWf_perm m' m. Proof. constructor; inv H; eauto using Permutation_sym. Qed. Lemma ModWf_perm_trans ty m m' m'' : @ModWf_perm ty m m' -> ModWf_perm m' m'' -> ModWf_perm m m''. Proof. constructor; inv H; inv H0; eauto using Permutation_trans. Qed. Global Instance ModWf_perm_Equivalence : forall ty, Equivalence (@ModWf_perm ty) | 10 := { Equivalence_Reflexive := @ModWf_perm_refl _; Equivalence_Symmetric := @ModWf_perm_sym _; Equivalence_Transitive:= @ModWf_perm_trans _}. Lemma PStep_rewrite_base m1' m2' o l hl: BaseModule_perm m1' m2' -> PStep (createHide m1' hl) o l-> PStep (createHide m2' hl) o l. Proof. induction hl; simpl. - intros. inv H0; econstructor 1. + rewrite <- H; assumption. + intros f InDefm2. apply (HMatching f); simpl in *. inversion H; subst. rewrite HMethsPerm; assumption. - intros. inv H0; econstructor 2; auto; intros. eapply HHidden; auto. rewrite createHide_Meths in *. inversion H; subst. rewrite HMethsPerm; assumption. Qed. Lemma PStep_rewrite_hides m o l: forall hl' hl, hl [=] hl' -> PStep (createHide m hl) o l-> PStep (createHide m hl') o l. Proof. induction 1; auto; intros. - simpl in *; inv H0; econstructor 2; auto. intros. rewrite createHide_Meths in *. eapply HHidden; eauto. - simpl in *. inv H; inv HPStep. econstructor 2;[econstructor 2|]; auto. Qed. Lemma PStep_ModWf_rewrite m1 m2 o l : @ModWf_perm type m1 m2 -> PStep m1 o l -> PStep m2 o l. Proof. intros. apply (substitute_PStep); eauto using (wfMod m2). apply (PStep_substitute) in H0; eauto using (wfMod m1). unfold flatten in *. assert (BaseModule_perm (getFlat m1) (getFlat m2));[inv H;unfold getFlat;constructor;auto|]. apply (PStep_rewrite_base (getHidden m1) H1) in H0. inv H. apply (PStep_rewrite_hides _ HHiddenPerm H0). Qed. Lemma Forall2_perm (A B : Type) (l2 l3 : list B)(P : A -> B -> Prop): l2 [=] l3 -> forall l1, Forall2 P l1 l2 -> (exists l4, l1 [=] l4 /\ Forall2 P l4 l3). induction 1. - intros; inv H. exists nil; split; eauto. - intros. destruct l1; inv H0. specialize (IHPermutation _ H6);dest. exists (a::x0). split; auto. - intros. destruct l1; inv H. destruct l1; inv H5. exists (a0::a::l1); split; auto. econstructor 3. - intros. specialize (IHPermutation1 _ H1);dest. specialize (IHPermutation2 _ H3);dest. exists x0; split; eauto using Permutation_trans. Qed. Lemma PTrace_ModWf_rewrite m1 m2 o ls: @ModWf_perm type m1 m2 -> PTrace m1 o ls -> PTrace m2 o ls. Proof. induction 2; subst; inv H. - specialize (Forall2_perm HAllRegsPerm HUpdRegs) as TMP; dest. econstructor 1 with (o'':=x);eauto. rewrite <- H; assumption. - econstructor 2; eauto. eapply (PStep_ModWf_rewrite) in HPStep; eauto. econstructor; eauto. Qed. Lemma PTrace_RegsT_rewrite m o1 o2 ls : o1 [=] o2 -> PTrace m o1 ls -> PTrace m o2 ls. Proof. intros; inv H0. - econstructor 1 with (o'':=o''); eauto using Permutation_sym, Permutation_trans. - econstructor 2; eauto. unfold PUpdRegs in *; dest. repeat split; auto. + rewrite <- H; assumption. + intros. rewrite <- H in H2. specialize (H1 s v H2). assumption. Qed. Lemma PTrace_rewrite m1 m2 o1 o2 ls: o1 [=] o2 -> @ModWf_perm type m1 m2 -> PTrace m1 o1 ls -> PTrace m2 o2 ls. Proof. intros; eauto using PTrace_ModWf_rewrite, PTrace_RegsT_rewrite. Qed. Global Instance PStep_ModWf_rewrite' : Proper (@ModWf_perm type ==> Logic.eq ==> Logic.eq ==> iff) (@PStep) |10. Proof. repeat red; split; intros; subst; eauto using ModWf_perm_sym,PStep_ModWf_rewrite. Qed. Global Instance Trace_rewrite' : Proper (@ModWf_perm type ==> @Permutation (string * {x : FullKind & fullType type x}) ==> Logic.eq ==> iff) (@PTrace) | 10. Proof. repeat red; split; intros; subst; eauto using ModWf_perm_sym, Permutation_sym, PTrace_rewrite. Qed. End ModWf_rewrite. Lemma WfNilMod ty: WfMod ty (Base (BaseMod nil nil nil)). Proof. constructor; simpl; constructor; repeat split; intros; try contradiction; simpl; constructor. Qed. Lemma WfConcatActionTNil ty (k : Kind) (a : ActionT ty k): WfConcatActionT a (Base (BaseMod nil nil nil)). Proof. induction a; econstructor; eauto. Qed. Lemma WfConcatNil ty m: WfMod ty m -> WfMod ty (ConcatMod m (Base (BaseMod nil nil nil))). Proof. constructor; unfold DisjKey; simpl; intros; auto. - apply WfNilMod. - split; intros; eapply WfConcatActionTNil. - split; intros; contradiction. Qed. Lemma WfNilConcat ty m: WfMod ty (ConcatMod m (Base (BaseMod nil nil nil))) -> WfMod ty m. Proof. intros; inv H; assumption. Qed. Lemma WfConcatComm ty m1 m2 : WfMod ty (ConcatMod m1 m2) -> WfMod ty (ConcatMod m2 m1). Proof. intros; inv H. econstructor; eauto using DisjKey_Commutative. Qed. Lemma DeM1 (A : Type): forall (l1 l2 : list A) (a : A), ~(In a l1 \/ In a l2) <-> ~In a l1 /\ ~In a l2. Proof. split;intros. - split; intro; apply H; auto. - destruct H. intro; destruct H1; auto. Qed. Lemma WfConcatSplits ty m1 m2 (k : Kind) (a : ActionT ty k): WfConcatActionT a (ConcatMod m1 m2) -> WfConcatActionT a m1 /\ WfConcatActionT a m2. Proof. induction a. - intros; split; econstructor 1; eauto; inv H0; EqDep_subst; intro; try eapply H; eauto; apply H8; simpl; rewrite in_app_iff; eauto. - intros; split; intros; econstructor 2; eauto; intros; inv H0; EqDep_subst; destruct (H v (H6 v)); auto. - intros; split; econstructor 3; eauto; inv H0; EqDep_subst; try intro; try eapply IHa; eauto; eapply H; eauto. - intros; split; econstructor 4; eauto; inv H0; EqDep_subst; intros; eapply H; eauto. - intros; split; econstructor 5; eauto; inv H0; EqDep_subst; intros; eapply H; eauto. - intros; split; econstructor 6; eauto; inv H; EqDep_subst; eapply IHa; eauto. - intros; split; econstructor 7; eauto; inv H0; EqDep_subst; try intros; try eapply H; eauto; try eapply IHa1; eauto; eapply IHa2; eauto. - intros; split; econstructor 8; eauto; inv H; EqDep_subst; eapply IHa; eauto. - intros; split; econstructor 9; eauto; inv H; EqDep_subst; eapply IHa; eauto. Qed. Lemma WfConcatMerge ty m1 m2 (k : Kind) (a : ActionT ty k) : WfConcatActionT a m1 -> WfConcatActionT a m2 -> WfConcatActionT a (ConcatMod m1 m2). Proof. induction a; intros. - econstructor 1; inv H0; inv H1; EqDep_subst; intros; try eapply H; eauto; simpl; rewrite in_app_iff; intro; destruct H0;auto. - econstructor 2; inv H0; inv H1; EqDep_subst; intros; eapply (H v); eauto. - econstructor 3; inv H0; inv H1; EqDep_subst; try eapply H; eauto. - econstructor 4; inv H0; inv H1; EqDep_subst; intros; eapply H; eauto. - econstructor 5; inv H0; inv H1; EqDep_subst; intros; eapply H; eauto. - econstructor 6; inv H; inv H0; EqDep_subst; eapply IHa; eauto. - econstructor 7; inv H0; inv H1; EqDep_subst; intros; try eapply H, IHa1, IHa2; eauto. - econstructor 8; inv H; inv H0; EqDep_subst; eapply IHa; eauto. - econstructor 9; inv H; inv H0; EqDep_subst; eapply IHa; eauto. Qed. Lemma WfConcatAssoc1 ty m1 m2 m3 : WfMod ty (ConcatMod m1 (ConcatMod m2 m3)) -> WfMod ty (ConcatMod (ConcatMod m1 m2) m3). Proof. intros; inv H; inv HWf2; inv WfConcat1; inv WfConcat2. econstructor; simpl in *; eauto. - intro. destruct (HDisjRegs k), (HDisjRegs0 k); simpl in *; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *; auto. destruct H3; right; assumption. - intro. destruct (HDisjRules k), (HDisjRules0 k); simpl in *; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *; auto. destruct H3; right; assumption. - intro. destruct (HDisjMeths k), (HDisjMeths0 k); simpl in *; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *; auto. destruct H3; right; assumption. - econstructor; eauto; simpl in *. + intro. destruct (HDisjRegs k), (HDisjRegs0 k); simpl in *; auto; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *; auto. destruct H3; right; assumption. + intro. destruct (HDisjRules k), (HDisjRules0 k); simpl in *; auto; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *. destruct H3; right; assumption. + intro. destruct (HDisjMeths k), (HDisjMeths0 k); simpl in *; auto; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *. destruct H3; right; assumption. + econstructor; intros. * specialize (H _ H3). apply (WfConcatSplits H). * specialize (H0 _ H3 v). apply (WfConcatSplits H0). + econstructor; intros. * apply (H1 rule (in_or_app _ _ _ (or_introl _ H3))). * apply (H2 meth (in_or_app _ _ _ (or_introl _ H3)) v). - split; intros; simpl in *; rewrite in_app_iff in *; destruct H3. + specialize (H _ H3); apply (WfConcatSplits H). + inv WfConcat0; eauto. + specialize (H0 _ H3 v); apply (WfConcatSplits H0). + inv WfConcat0; eauto. - split; intros; simpl in *;inv WfConcat3. + eapply WfConcatMerge; eauto. apply (H1 rule (in_or_app _ _ _ (or_intror _ H3))). + eapply WfConcatMerge; eauto. apply (H2 meth (in_or_app _ _ _ (or_intror _ H3)) v). Qed. Theorem WfConcatAssoc1_new ty m1 m2 m3 : WfMod_new ty (ConcatMod m1 (ConcatMod m2 m3)) -> WfMod_new ty (ConcatMod (ConcatMod m1 m2) m3). Proof. repeat rewrite WfMod_new_WfMod_iff. apply WfConcatAssoc1. Qed. Lemma WfConcatAssoc2 ty m1 m2 m3 : WfMod ty (ConcatMod (ConcatMod m1 m2) m3) -> WfMod ty (ConcatMod m1 (ConcatMod m2 m3)). Proof. intros. inv H; inv HWf1; inv WfConcat1; inv WfConcat2. econstructor; try intro; simpl in *; eauto. - destruct (HDisjRegs k), (HDisjRegs0 k); simpl in *; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *; auto. destruct H3; left; assumption. - destruct (HDisjRules k), (HDisjRules0 k); simpl in *; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *; auto. destruct H3; left; assumption. - destruct (HDisjMeths k), (HDisjMeths0 k); simpl in *; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *; auto. destruct H3; left; assumption. - econstructor; try intro; simpl in *; eauto. + destruct (HDisjRegs k), (HDisjRegs0 k); simpl in *; auto; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *. destruct H3; left; assumption. + destruct (HDisjRules k), (HDisjRules0 k); simpl in *; auto; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *. destruct H3; left; assumption. + destruct (HDisjMeths k), (HDisjMeths0 k); simpl in *; auto; rewrite map_app in *; rewrite in_app_iff in *; rewrite DeM1 in *. destruct H3; left; assumption. + split; intros. * apply (H rule (in_or_app _ _ _ (or_intror _ H3))). * apply (H0 meth (in_or_app _ _ _ (or_intror _ H3)) v). + split; intros. * eapply WfConcatSplits; eauto. * eapply WfConcatSplits; eauto. - split; intros; inv WfConcat0; inv WfConcat3. + eapply WfConcatMerge; eauto. apply (H rule (in_or_app _ _ _ (or_introl _ H3))). + eapply WfConcatMerge; eauto. apply (H0 meth (in_or_app _ _ _ (or_introl _ H3)) v). - econstructor; intros; simpl in *; rewrite in_app_iff in *; destruct H3; inv WfConcat0; inv WfConcat3; eauto; eapply (WfConcatSplits (m1 :=m1) (m2 := m2)); eauto. Qed. Theorem WfConcatAssoc2_new ty m1 m2 m3 : WfMod_new ty (ConcatMod (ConcatMod m1 m2) m3) -> WfMod_new ty (ConcatMod m1 (ConcatMod m2 m3)). Proof. repeat rewrite WfMod_new_WfMod_iff. apply WfConcatAssoc2. Qed. Lemma WfMod_createHideMod l : forall ty m, WfMod ty (createHideMod m l) <-> (SubList l (map fst (getAllMethods m)) /\ WfMod ty m). Proof. split. - induction l; simpl; intros; split; auto. + repeat intro; contradiction. + inv H. specialize (IHl HWf); dest. repeat intro. destruct H1; subst; rewrite getAllMethods_createHideMod in HHideWf; auto. + inv H. specialize (IHl HWf); dest; auto. - induction l; intros; dest; simpl; eauto. destruct (SubList_cons H). econstructor; eauto. rewrite getAllMethods_createHideMod; auto. Qed. Lemma SeparatedBaseMod_concat l1 l2: getAllRegisters (mergeSeparatedBaseMod (l1++l2)) [=] getAllRegisters (mergeSeparatedBaseMod l1) ++ getAllRegisters (mergeSeparatedBaseMod l2). Proof. induction l1. - simpl; reflexivity. - simpl. rewrite <- app_assoc. apply Permutation_app_head. rewrite IHl1. reflexivity. Qed. Lemma SeparatedBaseMod_concat_Rules l1 l2: getAllRules (mergeSeparatedBaseMod (l1++l2)) [=] getAllRules (mergeSeparatedBaseMod l1) ++ getAllRules (mergeSeparatedBaseMod l2). Proof. induction l1. - simpl; reflexivity. - simpl. rewrite <- app_assoc. apply Permutation_app_head. rewrite IHl1. reflexivity. Qed. Lemma SeparatedBaseMod_concat_Meths l1 l2: getAllMethods (mergeSeparatedBaseMod (l1++l2)) [=] getAllMethods (mergeSeparatedBaseMod l1) ++ getAllMethods (mergeSeparatedBaseMod l2). Proof. induction l1. - simpl; reflexivity. - simpl. rewrite <- app_assoc. apply Permutation_app_head. rewrite IHl1. reflexivity. Qed. Lemma SeparatedBaseFile_concat l1 l2: getAllRegisters (mergeSeparatedBaseFile (l1++l2)) [=] getAllRegisters (mergeSeparatedBaseFile l1) ++ getAllRegisters (mergeSeparatedBaseFile l2). Proof. induction l1. - simpl; reflexivity. - simpl. rewrite <- app_assoc. apply Permutation_app_head. rewrite IHl1. reflexivity. Qed. Lemma SeparatedBaseFile_concat_Rules l1 l2: getAllRules (mergeSeparatedBaseFile (l1++l2)) [=] getAllRules (mergeSeparatedBaseFile l1) ++ getAllRules (mergeSeparatedBaseFile l2). Proof. induction l1. - simpl; reflexivity. - simpl; assumption. Qed. Lemma SeparatedBaseFile_concat_Meths l1 l2: getAllMethods (mergeSeparatedBaseFile (l1++l2)) [=] getAllMethods (mergeSeparatedBaseFile l1) ++ getAllMethods (mergeSeparatedBaseFile l2). Proof. induction l1. - simpl; reflexivity. - simpl. rewrite <- app_assoc. apply Permutation_app_head. rewrite IHl1. reflexivity. Qed. Lemma DisjKey_perm_rewrite (A B : Type) (l1 l2 l3 l4 : list (A*B)) : l1 [=] l2 -> l3 [=] l4 -> DisjKey l1 l3 -> DisjKey l2 l4. Proof. repeat intro; destruct (H1 k); [left; rewrite <- H|right; rewrite <- H0]; auto. Qed. Global Instance DisjKey_perm_rewrite' A B : Proper (@Permutation (A*B) ==> @Permutation (A*B) ==> iff) (@DisjKey A B) | 10. Proof. repeat red; intros; split; intros; eauto using DisjKey_perm_rewrite, Permutation_sym. Qed. Lemma WfActionTConcatAssoc1 ty m1 m2 m3 (k : Kind) (a : ActionT ty k) : WfConcatActionT a (ConcatMod (ConcatMod m1 m2) m3) -> WfConcatActionT a (ConcatMod m1 (ConcatMod m2 m3)). Proof. intros. induction a; inv H; econstructor; EqDep_subst; intros; simpl in *; eauto. rewrite app_assoc; assumption. Qed. Lemma WfActionTConcatAssoc2 ty m1 m2 m3 (k : Kind) (a : ActionT ty k) : WfConcatActionT a (ConcatMod m1 (ConcatMod m2 m3)) -> WfConcatActionT a (ConcatMod (ConcatMod m1 m2) m3). Proof. intros. induction a; inv H; econstructor; EqDep_subst; intros; simpl in *; eauto. rewrite <- app_assoc; assumption. Qed. Lemma WfConcatBaseFiles ty l1 l2 (k : Kind) (a : ActionT ty k): WfConcatActionT a (ConcatMod (mergeSeparatedBaseFile l1) (mergeSeparatedBaseFile l2)) -> WfConcatActionT a (mergeSeparatedBaseFile (l1 ++ l2)). Proof. induction l1. - intros. apply WfConcatSplits in H; dest; assumption. - simpl. intros. apply WfActionTConcatAssoc1 in H. apply WfConcatSplits in H; dest. apply WfConcatMerge; eauto. Qed. Lemma WfConcatBaseModules ty l1 l2 (k : Kind) (a : ActionT ty k): WfConcatActionT a (ConcatMod (mergeSeparatedBaseMod l1) (mergeSeparatedBaseMod l2)) -> WfConcatActionT a (mergeSeparatedBaseMod (l1 ++ l2)). Proof. induction l1. - intros. apply WfConcatSplits in H; dest; assumption. - simpl. intros. apply WfActionTConcatAssoc1 in H. apply WfConcatSplits in H; dest. apply WfConcatMerge; eauto. Qed. Lemma WfAppBaseFiles ty l1 l2: WfMod ty (mergeSeparatedBaseFile l1) -> WfMod ty (mergeSeparatedBaseFile l2) -> WfMod ty (ConcatMod (mergeSeparatedBaseFile l1) (mergeSeparatedBaseFile l2)) -> WfMod ty (mergeSeparatedBaseFile (l1 ++ l2)). Proof. induction l1; intros; simpl in *; auto. apply WfConcatAssoc2 in H1. econstructor; inv H1; simpl in *; auto. - rewrite <- SeparatedBaseFile_concat in HDisjRegs; assumption. - intro; left; intro; contradiction. - rewrite <- SeparatedBaseFile_concat_Meths in HDisjMeths; assumption. - pose proof (HWf2) as HWf2'. inv HWf2; eapply IHl1; eauto. - split; intros; destruct WfConcat1. + simpl in *; contradiction. + specialize (H3 _ H1 v). apply WfConcatBaseFiles in H3; assumption. - split; intros; destruct WfConcat2. rewrite getAllRules_mergeBaseFile in H1; contradiction. simpl in H3; repeat rewrite getAllMethods_mergeBaseFile in *. rewrite map_app, concat_app in *. specialize (H3 _ H1 v); assumption. Qed. Lemma WfAppBaseMods ty l1 l2: WfMod ty (mergeSeparatedBaseMod l1) -> WfMod ty (mergeSeparatedBaseMod l2) -> WfMod ty (ConcatMod (mergeSeparatedBaseMod l1) (mergeSeparatedBaseMod l2)) -> WfMod ty (mergeSeparatedBaseMod (l1 ++ l2)). Proof. induction l1; intros; simpl in *; auto. apply WfConcatAssoc2 in H1. econstructor; inv H1; simpl in *; auto. - rewrite <- SeparatedBaseMod_concat in HDisjRegs; assumption. - rewrite <- SeparatedBaseMod_concat_Rules in HDisjRules; assumption. - rewrite <- SeparatedBaseMod_concat_Meths in HDisjMeths; assumption. - pose proof (HWf2) as HWf2'. inv HWf2; eapply IHl1; eauto. - split; intros; destruct WfConcat1. + specialize (H2 _ H1). apply WfConcatBaseModules in H2; assumption. + specialize (H3 _ H1 v). apply WfConcatBaseModules in H3; assumption. - split; intros; destruct WfConcat2. + simpl in *. repeat rewrite getAllRules_mergeBaseMod in *. rewrite map_app, concat_app in *. specialize (H2 _ H1); assumption. + simpl in H3; repeat rewrite getAllMethods_mergeBaseMod in *. rewrite map_app, concat_app in *. specialize (H3 _ H1 v); assumption. Qed. Lemma Base_File_Disjoint_Registers ty m : WfMod ty m -> DisjKey (getAllRegisters (mergeSeparatedBaseFile (fst (separateBaseMod m)))) (getAllRegisters (mergeSeparatedBaseMod (snd (separateBaseMod m)))). Proof. intros; induction m; inv H. - destruct m; simpl; rewrite app_nil_r; repeat intro;[right|left];intro; contradiction. - specialize (IHm HWf). simpl; assumption. - specialize (IHm1 HWf1); specialize (IHm2 HWf2). intro. destruct (HDisjRegs k). + rewrite separateBaseMod_flatten in H; simpl in H. unfold mergeSeparatedMod in H. rewrite getAllRegisters_createHideMod in H; simpl in *; rewrite map_app,in_app_iff, DeM1 in H; dest. destruct (separateBaseMod m1), (separateBaseMod m2); simpl. rewrite SeparatedBaseMod_concat, SeparatedBaseFile_concat; repeat rewrite map_app, in_app_iff; repeat rewrite DeM1. destruct (IHm1 k), (IHm2 k); simpl in *. * left; split; auto. * right; split; auto. * left; split; auto. * right; split; auto. + rewrite separateBaseMod_flatten in H; simpl in H. unfold mergeSeparatedMod in H. rewrite getAllRegisters_createHideMod in H; simpl in *; rewrite map_app,in_app_iff, DeM1 in H; dest. destruct (separateBaseMod m1), (separateBaseMod m2); simpl. rewrite SeparatedBaseMod_concat, SeparatedBaseFile_concat; repeat rewrite map_app, in_app_iff; repeat rewrite DeM1. destruct (IHm1 k), (IHm2 k); simpl in *. * left; split; auto. * left; split; auto. * right; split; auto. * right; split; auto. Qed. Lemma WfActionBreakDownFile ty m (k : Kind) (a : ActionT ty k): WfConcatActionT a m -> WfConcatActionT a (mergeSeparatedBaseFile (fst (snd (separateMod m)))). Proof. induction a; simpl; intros; econstructor; intros; try inv H0; try inv H; EqDep_subst; eauto. - rewrite mergeSeparatedBaseFile_noHides; intro; contradiction. Qed. Lemma WfActionBreakDownMod ty m (k : Kind) (a : ActionT ty k): WfConcatActionT a m -> WfConcatActionT a (mergeSeparatedBaseMod (snd (snd (separateMod m)))). Proof. induction a; simpl; intros; econstructor; intros; try inv H0; try inv H; EqDep_subst; eauto. - rewrite mergeSeparatedBaseMod_noHides; intro; contradiction. Qed. Lemma WfModBreakDownFile ty m : WfMod ty m -> WfMod ty (mergeSeparatedBaseFile (fst (snd (separateMod m)))). Proof. induction m. - destruct m; simpl; intros; eauto using WfConcatNil, WfNilMod. - intro; inv H; simpl; eapply IHm; eauto. - intro; inv H. rewrite (separateBaseMod_flatten m1), (separateBaseMod_flatten m2) in HDisjRegs. rewrite (separateBaseModule_flatten_Rules m1), (separateBaseModule_flatten_Rules m2) in HDisjRules. rewrite (separateBaseModule_flatten_Methods m1), (separateBaseModule_flatten_Methods m2) in HDisjMeths. inv WfConcat1; inv WfConcat2. setoid_rewrite (separateBaseModule_flatten_Rules m1) in H; setoid_rewrite (separateBaseModule_flatten_Rules m2) in H1. setoid_rewrite (separateBaseModule_flatten_Methods m1) in H0; setoid_rewrite (separateBaseModule_flatten_Methods m2) in H2. simpl in *. unfold mergeSeparatedMod in *; repeat rewrite getAllRegisters_createHideMod in *; repeat rewrite getAllMethods_createHideMod in *; repeat rewrite getAllRules_createHideMod in *; simpl in *. remember (separateBaseMod m1) as sbm1; remember (separateBaseMod m2) as sbm2. destruct sbm1, sbm2; simpl in *. apply WfAppBaseFiles; eauto. econstructor; eauto. + intro; specialize (HDisjRegs k); repeat rewrite map_app, in_app_iff, DeM1 in *. destruct HDisjRegs; dest; eauto. + intro; specialize (HDisjRules k); repeat rewrite map_app, in_app_iff, DeM1 in *. destruct HDisjRules; dest; eauto. + intro; specialize (HDisjMeths k); repeat rewrite map_app, in_app_iff, DeM1 in *. destruct HDisjMeths; dest; eauto. + split; intros. * setoid_rewrite in_app_iff in H. specialize (H _ (or_introl _ H3)). apply WfActionBreakDownFile in H. unfold separateMod in H; simpl in *; rewrite <- Heqsbm2 in H; simpl in *; assumption. * setoid_rewrite in_app_iff in H0. specialize (H0 _ (or_introl _ H3) v). apply WfActionBreakDownFile in H0. unfold separateMod in H0; simpl in *; rewrite <- Heqsbm2 in H0; simpl in *; assumption. + split; intros. * setoid_rewrite in_app_iff in H1. specialize (H1 _ (or_introl _ H3)). apply WfActionBreakDownFile in H1. unfold separateMod in H1; simpl in *; rewrite <- Heqsbm1 in H1; simpl in *; assumption. * setoid_rewrite in_app_iff in H2. specialize (H2 _ (or_introl _ H3) v). apply WfActionBreakDownFile in H2. unfold separateMod in H2; simpl in *; rewrite <- Heqsbm1 in H2; simpl in *; assumption. Qed. Theorem WfModBreakDownFile_new ty m : WfMod_new ty m -> WfMod_new ty (mergeSeparatedBaseFile (fst (snd (separateMod m)))). Proof. repeat rewrite WfMod_new_WfMod_iff. apply WfModBreakDownFile. Qed. Lemma WfModBreakDownMod ty m : WfMod ty m -> WfMod ty (mergeSeparatedBaseMod (snd (snd (separateMod m)))). Proof. induction m. - destruct m; simpl; intros; eauto using WfConcatNil, WfNilMod. - intro; inv H; simpl; eapply IHm; eauto. - intro; inv H. rewrite (separateBaseMod_flatten m1), (separateBaseMod_flatten m2) in HDisjRegs. rewrite (separateBaseModule_flatten_Rules m1), (separateBaseModule_flatten_Rules m2) in HDisjRules. rewrite (separateBaseModule_flatten_Methods m1), (separateBaseModule_flatten_Methods m2) in HDisjMeths. inv WfConcat1; inv WfConcat2. setoid_rewrite (separateBaseModule_flatten_Rules m1) in H; setoid_rewrite (separateBaseModule_flatten_Rules m2) in H1. setoid_rewrite (separateBaseModule_flatten_Methods m1) in H0; setoid_rewrite (separateBaseModule_flatten_Methods m2) in H2. simpl in *. unfold mergeSeparatedMod in *; repeat rewrite getAllRegisters_createHideMod in *; repeat rewrite getAllMethods_createHideMod in *; repeat rewrite getAllRules_createHideMod in *; simpl in *. remember (separateBaseMod m1) as sbm1; remember (separateBaseMod m2) as sbm2. destruct sbm1, sbm2; simpl in *. apply WfAppBaseMods; eauto. econstructor; eauto. + intro; specialize (HDisjRegs k); repeat rewrite map_app, in_app_iff, DeM1 in *. destruct HDisjRegs; dest; eauto. + intro; specialize (HDisjRules k); repeat rewrite map_app, in_app_iff, DeM1 in *. destruct HDisjRules; dest; eauto. + intro; specialize (HDisjMeths k); repeat rewrite map_app, in_app_iff, DeM1 in *. destruct HDisjMeths; dest; eauto. + split; intros. * setoid_rewrite in_app_iff in H. specialize (H _ (or_intror _ H3)). apply WfActionBreakDownMod in H. unfold separateMod in H; simpl in *; rewrite <- Heqsbm2 in H; simpl in *; assumption. * setoid_rewrite in_app_iff in H0. specialize (H0 _ (or_intror _ H3) v). apply WfActionBreakDownMod in H0. unfold separateMod in H0; simpl in *; rewrite <- Heqsbm2 in H0; simpl in *; assumption. + split; intros. * setoid_rewrite in_app_iff in H1. specialize (H1 _ (or_intror _ H3)). apply WfActionBreakDownMod in H1. unfold separateMod in H1; simpl in *; rewrite <- Heqsbm1 in H1; simpl in *; assumption. * setoid_rewrite in_app_iff in H2. specialize (H2 _ (or_intror _ H3) v). apply WfActionBreakDownMod in H2. unfold separateMod in H2; simpl in *; rewrite <- Heqsbm1 in H2; simpl in *; assumption. Qed. Theorem WfModBreakDownMod_new ty m : WfMod_new ty m -> WfMod_new ty (mergeSeparatedBaseMod (snd (snd (separateMod m)))). Proof. repeat rewrite WfMod_new_WfMod_iff. apply WfModBreakDownMod. Qed. Lemma WfConcat_noHide ty m1 m2 : getHidden m2 = nil -> WfConcat ty m1 m2. Proof. intros. split; intros. - induction (snd rule ty); econstructor; eauto. rewrite H; intro; contradiction. - induction (projT2 (snd meth) ty v); econstructor; eauto. rewrite H; intro; contradiction. Qed. Theorem WfMod_merge ty m: WfMod ty m -> WfMod ty (mergeSeparatedMod (separateMod m)). Proof. induction 1. - destruct m; simpl in *. + unfold mergeSeparatedMod; simpl. repeat apply WfConcatNil. econstructor; eauto. + unfold mergeSeparatedMod; simpl. apply WfConcatAssoc2,WfConcatNil,WfConcatComm,WfConcatNil. econstructor; eauto. - unfold mergeSeparatedMod in *. rewrite WfMod_createHideMod in *; dest; simpl in *; split; eauto. + unfold SubList; intros. destruct H2; subst. * rewrite (separateBaseModule_flatten_Methods m) in HHideWf. unfold mergeSeparatedMod in HHideWf. rewrite getAllMethods_createHideMod in HHideWf; simpl in *; assumption. * eapply H0; eauto. - unfold mergeSeparatedMod in *. rewrite WfMod_createHideMod in *; dest; split. + unfold separateMod in *. repeat intro. specialize (separateBaseModule_flatten_Methods (ConcatMod m1 m2)) as TMP1. specialize (separateBaseModule_flatten_Methods m1) as TMP2. specialize (separateBaseModule_flatten_Methods m2) as TMP3. unfold mergeSeparatedMod in *; rewrite getAllMethods_createHideMod in *. rewrite <- TMP1. rewrite <- TMP2 in H3. rewrite <- TMP3 in H1. simpl in *; rewrite map_app in *; rewrite in_app_iff in *. destruct H5. * left; eapply H3; eauto. * right; eapply H1; eauto. + inv H4; inv H2. econstructor. * specialize (separateBaseMod_flatten (ConcatMod m1 m2)) as TMP1; specialize (separateBaseMod_flatten m1) as TMP2; specialize (separateBaseMod_flatten m2) as TMP3. unfold mergeSeparatedMod in *; rewrite getAllRegisters_createHideMod in *; simpl in *; intro. specialize (HDisjRegs k); rewrite TMP2, TMP3 in HDisjRegs. repeat rewrite map_app,in_app_iff,DeM1 in *. destruct (separateBaseMod m1), (separateBaseMod m2); simpl in *. rewrite SeparatedBaseMod_concat, SeparatedBaseFile_concat; repeat rewrite map_app, in_app_iff, DeM1. destruct HDisjRegs,(HDisjRegs0 k),(HDisjRegs1 k); dest;[left|right|left|right|left|left|right|right];split; auto. * specialize (separateBaseModule_flatten_Rules (ConcatMod m1 m2)) as TMP1; specialize (separateBaseModule_flatten_Rules m1) as TMP2; specialize (separateBaseModule_flatten_Rules m2) as TMP3. unfold mergeSeparatedMod in *; rewrite getAllRules_createHideMod in *; simpl in *; intro. specialize (HDisjRules k); rewrite TMP2, TMP3 in HDisjRules. repeat rewrite map_app,in_app_iff,DeM1 in *. destruct (separateBaseMod m1), (separateBaseMod m2); simpl in *. rewrite SeparatedBaseMod_concat_Rules, SeparatedBaseFile_concat_Rules; repeat rewrite map_app, in_app_iff, DeM1. destruct HDisjRules,(HDisjRules0 k),(HDisjRules1 k); dest;[left|right|left|right|left|left|right|right];split; auto. * specialize (separateBaseModule_flatten_Methods (ConcatMod m1 m2)) as TMP1; specialize (separateBaseModule_flatten_Methods m1) as TMP2; specialize (separateBaseModule_flatten_Methods m2) as TMP3. unfold mergeSeparatedMod in *; rewrite getAllMethods_createHideMod in *; simpl in *; intro. specialize (HDisjMeths k); rewrite TMP2, TMP3 in HDisjMeths. repeat rewrite map_app,in_app_iff,DeM1 in *. destruct (separateBaseMod m1), (separateBaseMod m2); simpl in *. rewrite SeparatedBaseMod_concat_Meths, SeparatedBaseFile_concat_Meths; repeat rewrite map_app, in_app_iff, DeM1. destruct HDisjMeths,(HDisjMeths0 k),(HDisjMeths1 k); dest;[left|right|left|right|left|left|right|right];split; auto. * apply WfModBreakDownFile; econstructor; eauto. * apply WfModBreakDownMod; econstructor; eauto. * apply WfConcat_noHide. apply mergeSeparatedBaseMod_noHides. * apply WfConcat_noHide. apply mergeSeparatedBaseFile_noHides. Qed. Theorem WfMod_merge_new ty m: WfMod_new ty m -> WfMod_new ty (mergeSeparatedMod (separateMod m)). Proof. repeat rewrite WfMod_new_WfMod_iff. apply WfMod_merge. Qed. Lemma WfMod_getFlat ty m: (WfMod ty m) -> (WfMod ty (Base (getFlat m))). Proof. intros. pose proof (WfNoDups H). pose proof (WfMod_WfBaseMod_flat H). specialize (H). unfold getFlat in *. specialize (H1). constructor; tauto. Qed. Theorem WfMod_getFlat_new ty m: (WfMod_new ty m) -> (WfMod_new ty (Base (getFlat m))). Proof. repeat rewrite WfMod_new_WfMod_iff. apply WfMod_getFlat. Qed. Definition WfGetFlatMod ty (m: ModWf ty) : ModWf ty := (Build_ModWf (WfMod_getFlat (wfMod m))). Definition merge_ModWf ty (m : ModWf ty) : ModWf ty := (Build_ModWf (WfMod_merge (wfMod m))). Definition merge_ModWf_new ty (m : ModWf_new ty) : ModWf_new ty := (Build_ModWf_new _ _ (WfMod_merge_new _ _(wfMod_new m))). Lemma merged_perm_equality ty m : @ModWf_perm ty m (merge_ModWf m). Proof. constructor; simpl. - apply separateBaseMod_flatten. - apply separateBaseModule_flatten_Methods. - apply separateBaseModule_flatten_Rules. - apply separateBaseModule_flatten_Hides. Qed. Lemma TraceInclusion_Merge_l (m : ModWf type) : TraceInclusion m (merge_ModWf m). Proof. apply PTraceInclusion_TraceInclusion; try apply wfMod. repeat intro. apply (PTrace_ModWf_rewrite (merged_perm_equality m)) in H. exists ls. split. - unfold PTraceList; exists o; eauto. - apply WeakInclusionsRefl. Qed. Theorem TraceInclusion_Merge_l_new (m : ModWf_new type) : TraceInclusion m (merge_ModWf_new m). Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (TraceInclusion_Merge_l m'). Qed. Lemma TraceInclusion_Merge_r (m : ModWf type) : TraceInclusion (merge_ModWf m) m. Proof. apply PTraceInclusion_TraceInclusion; try apply wfMod. repeat intro. apply (PTrace_ModWf_rewrite (ModWf_perm_sym (merged_perm_equality m))) in H. exists ls. split. - unfold PTraceList; exists o; eauto. - apply WeakInclusionsRefl. Qed. Theorem TraceInclusion_Merge_r_new (m : ModWf_new type) : TraceInclusion (merge_ModWf_new m) m. Proof. destruct m. pose (Build_ModWf (WfMod_new_WfMod _ _ wfMod_new)) as m'. eapply (TraceInclusion_Merge_r m'). Qed. Section Comm. Variable m1 m2: Mod. Variable wfMod: WfMod type (ConcatMod m1 m2). Theorem ConcatMod_comm: TraceInclusion (ConcatMod m1 m2) (ConcatMod m2 m1). Proof. apply PTraceInclusion_TraceInclusion; auto. - intros; eapply WfConcatComm; eauto. - unfold PTraceInclusion, TraceList. intros. assert (sth: WfMod type (ConcatMod m2 m1)) by (intros; specialize (wfMod); eapply WfConcatComm; eauto). assert (sth2: ModWf_perm (Build_ModWf wfMod) (Build_ModWf sth)) by (constructor; simpl; auto; apply Permutation_app_comm). pose proof (@PTrace_ModWf_rewrite (Build_ModWf wfMod) (Build_ModWf sth) o ls sth2 H). exists ls. split. + exists o; auto. + apply WeakInclusionsRefl. Qed. End Comm. Section Comm_new. Variable m1 m2: Mod. Variable wfMod: WfMod_new type (ConcatMod m1 m2). Theorem ConcatMod_comm_new: TraceInclusion (ConcatMod m1 m2) (ConcatMod m2 m1). Proof. rewrite WfMod_new_WfMod_iff in wfMod. apply ConcatMod_comm; auto. Qed. End Comm_new. Section Assoc. Variable m1 m2 m3: Mod. Variable wfMod: WfMod type (ConcatMod (ConcatMod m1 m2) m3). Lemma ConcatModAssoc1: TraceInclusion (ConcatMod m1 (ConcatMod m2 m3)) (ConcatMod (ConcatMod m1 m2) m3). Proof. apply PTraceInclusion_TraceInclusion; auto. - intros; eapply WfConcatAssoc2; eauto. - unfold PTraceInclusion, TraceList. intros. assert (sth: WfMod type (ConcatMod m1 (ConcatMod m2 m3))) by (intros; specialize (wfMod); eapply WfConcatAssoc2; eauto). assert (sth2: ModWf_perm (Build_ModWf sth) (Build_ModWf wfMod)) by (constructor; simpl; rewrite app_assoc; auto). pose proof (@PTrace_ModWf_rewrite (Build_ModWf sth) (Build_ModWf wfMod) o ls sth2 H). exists ls. split. + exists o; auto. + apply WeakInclusionsRefl. Qed. Lemma ConcatModAssoc2: TraceInclusion (ConcatMod (ConcatMod m1 m2) m3) (ConcatMod m1 (ConcatMod m2 m3)). Proof. apply PTraceInclusion_TraceInclusion; auto. - intros; eapply WfConcatAssoc2; eauto. - unfold PTraceInclusion, TraceList. intros. assert (sth: WfMod type (ConcatMod m1 (ConcatMod m2 m3))) by (intros; specialize (wfMod); eapply WfConcatAssoc2; eauto). assert (sth2: ModWf_perm (Build_ModWf wfMod) (Build_ModWf sth)) by (constructor; simpl; rewrite app_assoc; auto). pose proof (@PTrace_ModWf_rewrite (Build_ModWf wfMod) (Build_ModWf sth) o ls sth2 H). exists ls. split. + exists o; auto. + apply WeakInclusionsRefl. Qed. End Assoc. Section Assoc_new. Variable m1 m2 m3: Mod. Variable wfMod: WfMod_new type (ConcatMod (ConcatMod m1 m2) m3). Theorem ConcatModAssoc1_new : TraceInclusion (ConcatMod m1 (ConcatMod m2 m3)) (ConcatMod (ConcatMod m1 m2) m3). Proof. rewrite WfMod_new_WfMod_iff in wfMod. apply ConcatModAssoc1; auto. Qed. Theorem ConcatModAssoc2_new : TraceInclusion (ConcatMod (ConcatMod m1 m2) m3) (ConcatMod m1 (ConcatMod m2 m3)). Proof. rewrite WfMod_new_WfMod_iff in wfMod. apply ConcatModAssoc2; auto. Qed. End Assoc_new. ================================================ FILE: Properties.v ================================================ Require Import Kami.Syntax Kami.Lib.Fold. Import Word.Notations. Import ListNotations. Require Import Coq.Sorting.Permutation. Require Import Coq.Sorting.PermutEq. Require Import RelationClasses Setoid Morphisms. Require Import ZArith. Definition filterRegs f m (o: RegsT) := filter (fun x => f (getBool (in_dec string_dec (fst x) (map fst (getAllRegisters m))))) o. Definition filterExecs f m (l: list FullLabel) := filter (fun x => f match fst (snd x) with | Rle y => getBool (in_dec string_dec y (map fst (getAllRules m))) | Meth (y, _) => getBool (in_dec string_dec y (map fst (getAllMethods m))) end) l. Inductive WeakInclusions : list (list FullLabel) -> list (list (FullLabel)) -> Prop := | WI_Nil : WeakInclusions nil nil | WI_Cons : forall (ls ls' : list (list FullLabel)) (l l' : list FullLabel), WeakInclusions ls ls' -> WeakInclusion l l' -> WeakInclusions (l::ls)(l'::ls'). Definition WeakEqualities ls ls' := WeakInclusions ls ls' /\ WeakInclusions ls' ls. Notation "l '[=]' r" := ((@Permutation _ (l) (r))) (at level 70, no associativity). Section Semantics. Variable o: RegsT. Inductive PSemAction: forall k, ActionT type k -> RegsT -> RegsT -> MethsT -> type k -> Prop := | PSemMCall meth s (marg: Expr type (SyntaxKind (fst s))) (mret: type (snd s)) retK (fret: type retK) (cont: type (snd s) -> ActionT type retK) readRegs newRegs (calls: MethsT) acalls (HAcalls: acalls [=] (meth, (existT _ _ (evalExpr marg, mret))) :: calls) (HPSemAction: PSemAction (cont mret) readRegs newRegs calls fret): PSemAction (MCall meth s marg cont) readRegs newRegs acalls fret | PSemLetExpr k (e: Expr type k) retK (fret: type retK) (cont: fullType type k -> ActionT type retK) readRegs newRegs calls (HPSemAction: PSemAction (cont (evalExpr e)) readRegs newRegs calls fret): PSemAction (LetExpr e cont) readRegs newRegs calls fret | PSemLetAction k (a: ActionT type k) (v: type k) retK (fret: type retK) (cont: type k -> ActionT type retK) readRegs newRegs readRegsCont newRegsCont calls callsCont (HDisjRegs: DisjKey newRegs newRegsCont) (HPSemAction: PSemAction a readRegs newRegs calls v) ureadRegs unewRegs ucalls (HUReadRegs: ureadRegs [=] readRegs ++ readRegsCont) (HUNewRegs: unewRegs [=] newRegs ++ newRegsCont) (HUCalls: ucalls [=] calls ++ callsCont) (HPSemActionCont: PSemAction (cont v) readRegsCont newRegsCont callsCont fret): PSemAction (LetAction a cont) (ureadRegs) (unewRegs) (ucalls) fret | PSemReadNondet valueT (valueV: fullType type valueT) retK (fret: type retK) (cont: fullType type valueT -> ActionT type retK) readRegs newRegs calls (HPSemAction: PSemAction (cont valueV) readRegs newRegs calls fret): PSemAction (ReadNondet _ cont) readRegs newRegs calls fret | PSemReadReg (r: string) regT (regV: fullType type regT) retK (fret: type retK) (cont: fullType type regT -> ActionT type retK) readRegs newRegs calls areadRegs (HRegVal: In (r, existT _ regT regV) o) (HPSemAction: PSemAction (cont regV) readRegs newRegs calls fret) (HNewReads: areadRegs [=] (r, existT _ regT regV) :: readRegs): PSemAction (ReadReg r _ cont) areadRegs newRegs calls fret | PSemWriteReg (r: string) k (e: Expr type k) retK (fret: type retK) (cont: ActionT type retK) readRegs newRegs calls anewRegs (HRegVal: In (r, k) (getKindAttr o)) (HDisjRegs: key_not_In r newRegs) (HANewRegs: anewRegs [=] (r, (existT _ _ (evalExpr e))) :: newRegs) (HPSemAction: PSemAction cont readRegs newRegs calls fret): PSemAction (WriteReg r e cont) readRegs anewRegs calls fret | PSemIfElseTrue (p: Expr type (SyntaxKind Bool)) k1 (a: ActionT type k1) (a': ActionT type k1) (r1: type k1) k2 (cont: type k1 -> ActionT type k2) readRegs1 readRegs2 newRegs1 newRegs2 calls1 calls2 (r2: type k2) (HDisjRegs: DisjKey newRegs1 newRegs2) (HTrue: evalExpr p = true) (HAction: PSemAction a readRegs1 newRegs1 calls1 r1) (HPSemAction: PSemAction (cont r1) readRegs2 newRegs2 calls2 r2) ureadRegs unewRegs ucalls (HUReadRegs: ureadRegs [=] readRegs1 ++ readRegs2) (HUNewRegs: unewRegs [=] newRegs1 ++ newRegs2) (HUCalls: ucalls [=] calls1 ++ calls2) : PSemAction (IfElse p a a' cont) ureadRegs unewRegs ucalls r2 | PSemIfElseFalse (p: Expr type (SyntaxKind Bool)) k1 (a: ActionT type k1) (a': ActionT type k1) (r1: type k1) k2 (cont: type k1 -> ActionT type k2) readRegs1 readRegs2 newRegs1 newRegs2 calls1 calls2 (r2: type k2) (HDisjRegs: DisjKey newRegs1 newRegs2) (HFalse: evalExpr p = false) (HAction: PSemAction a' readRegs1 newRegs1 calls1 r1) (HPSemAction: PSemAction (cont r1) readRegs2 newRegs2 calls2 r2) ureadRegs unewRegs ucalls (HUReadRegs: ureadRegs [=] readRegs1 ++ readRegs2) (HUNewRegs: unewRegs [=] newRegs1 ++ newRegs2) (HUCalls: ucalls [=] calls1 ++ calls2): PSemAction (IfElse p a a' cont) ureadRegs unewRegs ucalls r2 | PSemDisplay (ls: list (SysT type)) k (cont: ActionT type k) r readRegs newRegs calls (HPSemAction: PSemAction cont readRegs newRegs calls r): PSemAction (Sys ls cont) readRegs newRegs calls r | PSemReturn k (e: Expr type (SyntaxKind k)) evale (HEvalE: evale = evalExpr e) readRegs newRegs calls (HReadRegs: readRegs = nil) (HNewRegs: newRegs = nil) (HCalls: calls = nil) : PSemAction (Return e) readRegs newRegs calls evale. End Semantics. Section BaseModule. Variable m: BaseModule. Variable o: RegsT. Inductive PSubsteps: list FullLabel -> Prop := | NilPSubstep (HRegs: getKindAttr o [=] getKindAttr (getRegisters m)) : PSubsteps nil | PAddRule (HRegs: getKindAttr o [=] getKindAttr (getRegisters m)) rn rb (HInRules: In (rn, rb) (getRules m)) reads u cs (HPAction: PSemAction o (rb type) reads u cs WO) (HReadsGood: SubList (getKindAttr reads) (getKindAttr (getRegisters m))) (HUpdGood: SubList (getKindAttr u) (getKindAttr (getRegisters m))) l ls (HLabel: l [=] (u, (Rle rn, cs)) :: ls) (HDisjRegs: forall x, In x ls -> DisjKey (fst x) u) (HNoRle: forall x, In x ls -> match fst (snd x) with | Rle _ => False | _ => True end) (HPSubstep: PSubsteps ls): PSubsteps l | PAddMeth (HRegs: getKindAttr o [=] getKindAttr (getRegisters m)) fn fb (HInMeths: In (fn, fb) (getMethods m)) reads u cs argV retV (HPAction: PSemAction o ((projT2 fb) type argV) reads u cs retV) (HReadsGood: SubList (getKindAttr reads) (getKindAttr (getRegisters m))) (HUpdGood: SubList (getKindAttr u) (getKindAttr (getRegisters m))) l ls (HLabel: l [=] (u, (Meth (fn, existT _ _ (argV, retV)), cs)) :: ls ) (HDisjRegs: forall x, In x ls -> DisjKey (fst x) u) (HPSubsteps: PSubsteps ls): PSubsteps l. Inductive PPlusSubsteps: RegsT -> list RuleOrMeth -> MethsT -> Prop := | NilPPlusSubstep (HRegs: getKindAttr o [=] getKindAttr (getRegisters m)) : PPlusSubsteps nil nil nil | PPlusAddRule (HRegs: getKindAttr o [=] getKindAttr (getRegisters m)) rn rb (HInRules: In (rn, rb) (getRules m)) reads u cs (HPAction: PSemAction o (rb type) reads u cs WO) (HReadsGood: SubList (getKindAttr reads) (getKindAttr (getRegisters m))) (HUpdGood: SubList (getKindAttr u) (getKindAttr (getRegisters m))) upds execs calls oldUpds oldExecs oldCalls (HUpds: upds [=] u ++ oldUpds) (HExecs: execs [=] Rle rn :: oldExecs) (HCalls: calls [=] cs ++ oldCalls) (HDisjRegs: DisjKey oldUpds u) (HNoRle: forall x, In x oldExecs -> match x with | Rle _ => False | _ => True end) (HPSubstep: PPlusSubsteps oldUpds oldExecs oldCalls): PPlusSubsteps upds execs calls | PPlusAddMeth (HRegs: getKindAttr o [=] getKindAttr (getRegisters m)) fn fb (HInMeths: In (fn, fb) (getMethods m)) reads u cs argV retV (HPAction: PSemAction o ((projT2 fb) type argV) reads u cs retV) (HReadsGood: SubList (getKindAttr reads) (getKindAttr (getRegisters m))) (HUpdGood: SubList (getKindAttr u) (getKindAttr (getRegisters m))) upds execs calls oldUpds oldExecs oldCalls (HUpds: upds [=] u ++ oldUpds) (HExecs: execs [=] Meth (fn, existT _ _ (argV, retV)) :: oldExecs) (HCalls: calls [=] cs ++ oldCalls) (HDisjRegs: DisjKey oldUpds u) (HPSubstep: PPlusSubsteps oldUpds oldExecs oldCalls): PPlusSubsteps upds execs calls. End BaseModule. Inductive PStep: Mod -> RegsT -> list FullLabel -> Prop := | PBaseStep m o l (HPSubsteps: PSubsteps m o l) (HMatching: MatchingExecCalls_Base l m): PStep (Base m) o l | PHideMethStep m s o l (HPStep: PStep m o l) (HHidden : forall v, In (s, projT1 v) (getKindAttr (getAllMethods m)) -> getListFullLabel_diff (s, v) l = 0%Z): PStep (HideMeth m s) o l | PConcatModStep m1 m2 o1 o2 l1 l2 (HPStep1: PStep m1 o1 l1) (HPStep2: PStep m2 o2 l2) (HMatching1: MatchingExecCalls_Concat l1 l2 m2) (HMatching2: MatchingExecCalls_Concat l2 l1 m1) (HNoRle: forall x y, In x l1 -> In y l2 -> match fst (snd x), fst (snd y) with | Rle _, Rle _ => False | _, _ => True end) o l (HRegs: o [=] o1 ++ o2) (HLabels: l [=] l1 ++ l2): PStep (ConcatMod m1 m2) o l. Section PPlusStep. Variable m: BaseModule. Variable o: RegsT. Definition MatchingExecCalls_flat (calls : MethsT) (execs : list RuleOrMeth) (m : BaseModule) := forall (f : MethT), In (fst f, projT1 (snd f)) (getKindAttr (getMethods m)) -> (getNumFromCalls f calls <= getNumFromExecs f execs)%Z. Inductive PPlusStep : RegsT -> list RuleOrMeth -> MethsT -> Prop := | BasePPlusStep upds execs calls: PPlusSubsteps m o upds execs calls -> MatchingExecCalls_flat calls execs m -> PPlusStep upds execs calls. End PPlusStep. Section Trace. Variable m: Mod. Definition PUpdRegs (u: list RegsT) (o o': RegsT) := getKindAttr o [=] getKindAttr o' /\ (forall s v, In (s, v) o' -> ((exists x, In x u /\ In (s, v) x) \/ ((~ exists x, In x u /\ In s (map fst x)) /\ In (s, v) o))). Inductive PTrace: RegsT -> list (list FullLabel) -> Prop := | PInitTrace (o' o'' : RegsT) ls' (HPerm : o' [=] o'') (HUpdRegs : Forall2 regInit o'' (getAllRegisters m)) (HTrace: ls' = nil): PTrace o' ls' | PContinueTrace o ls l o' ls' (PHOldTrace: PTrace o ls) (HPStep: PStep m o l) (HPUpdRegs: PUpdRegs (map fst l) o o') (HTrace: ls' = l :: ls): PTrace o' ls'. End Trace. Definition PPlusUpdRegs (u o o' : RegsT) := getKindAttr o [=] getKindAttr o' /\ (forall s v, In (s, v) o' -> In (s, v) u \/ (~ In s (map fst u) /\ In (s, v) o)). Section PPlusTrace. Variable m: BaseModule. Inductive PPlusTrace : RegsT -> list (RegsT * ((list RuleOrMeth) * MethsT)) -> Prop := | PPlusInitTrace (o' o'' : RegsT) ls' (HPerm : o' [=] o'') (HUpdRegs : Forall2 regInit o'' (getRegisters m)) (HTrace : ls' = nil): PPlusTrace o' ls' | PPlusContinueTrace (o o' : RegsT) (upds : RegsT) (execs : list RuleOrMeth) (calls : MethsT) (ls ls' : list (RegsT * ((list RuleOrMeth) * MethsT))) (PPlusOldTrace : PPlusTrace o ls) (HPPlusStep : PPlusStep m o upds execs calls) (HUpdRegs : PPlusUpdRegs upds o o') (HPPlusTrace : ls' = ((upds, (execs, calls))::ls)): PPlusTrace o' ls'. End PPlusTrace. Definition PTraceList (m : Mod) (ls : list (list FullLabel)) := (exists (o : RegsT), PTrace m o ls). Definition PTraceInclusion (m m' : Mod) := forall (o : RegsT) (ls : list (list FullLabel)), PTrace m o ls -> exists (ls' : list (list FullLabel)), PTraceList m' ls' /\ WeakInclusions ls ls'. Definition PStepSubstitute m o l := PSubsteps (BaseMod (getAllRegisters m) (getAllRules m) (getAllMethods m)) o l /\ MatchingExecCalls_Base l (getFlat m) /\ (forall s v, In (s, projT1 v) (getKindAttr (getAllMethods m)) -> In s (getHidden m) -> (getListFullLabel_diff (s, v) l = 0%Z)). Definition StepSubstitute m o l := Substeps (BaseMod (getAllRegisters m) (getAllRules m) (getAllMethods m)) o l /\ MatchingExecCalls_Base l (getFlat m) /\ (forall s v, In (s, projT1 v) (getKindAttr (getAllMethods m)) -> In s (getHidden m) -> (getListFullLabel_diff (s, v) l = 0%Z)). Definition InExec f (l: list (RegsT * (RuleOrMeth * MethsT))) := In (Meth f) (map getRleOrMeth l). Definition InCall f (l: list (RegsT * (RuleOrMeth * MethsT))) := exists x, In x l /\ In f (snd (snd x)). Lemma Kind_eq: forall k, Kind_dec k k = left eq_refl. Proof. intros; destruct (Kind_dec k k). - f_equal. apply Eqdep_dec.UIP_dec. apply Kind_dec. - apply (match n eq_refl with end). Qed. (* Lemma Signature_eq: forall sig, Signature_dec sig sig = left eq_refl. Proof. intros; destruct (Signature_dec sig sig). - f_equal. apply Eqdep_dec.UIP_dec. apply Signature_dec. - apply (match n eq_refl with end). Qed. *) Section InverseSemAction. Variable o: RegsT. Lemma inversionSemAction k a reads news calls retC (evalA: @SemAction o k a reads news calls retC): match a with | MCall m s e c => exists mret pcalls, SemAction o (c mret) reads news pcalls retC /\ calls = (m, (existT _ _ (evalExpr e, mret))) :: pcalls | LetExpr _ e cont => SemAction o (cont (evalExpr e)) reads news calls retC | LetAction _ a cont => exists reads1 news1 calls1 reads2 news2 calls2 r1, DisjKey news1 news2 /\ SemAction o a reads1 news1 calls1 r1 /\ SemAction o (cont r1) reads2 news2 calls2 retC /\ reads = reads1 ++ reads2 /\ news = news1 ++ news2 /\ calls = calls1 ++ calls2 | ReadNondet k c => exists rv, SemAction o (c rv) reads news calls retC | ReadReg r k c => exists rv reads2, In (r, existT _ k rv) o /\ SemAction o (c rv) reads2 news calls retC /\ reads = (r, existT _ k rv) :: reads2 | WriteReg r k e a => exists pnews, In (r, k) (getKindAttr o) /\ key_not_In r pnews /\ SemAction o a reads pnews calls retC /\ news = (r, (existT _ _ (evalExpr e))) :: pnews | IfElse p _ aT aF c => exists reads1 news1 calls1 reads2 news2 calls2 r1, DisjKey news1 news2 /\ match evalExpr p with | true => SemAction o aT reads1 news1 calls1 r1 /\ SemAction o (c r1) reads2 news2 calls2 retC /\ reads = reads1 ++ reads2 /\ news = news1 ++ news2 /\ calls = calls1 ++ calls2 | false => SemAction o aF reads1 news1 calls1 r1 /\ SemAction o (c r1) reads2 news2 calls2 retC /\ reads = reads1 ++ reads2 /\ news = news1 ++ news2 /\ calls = calls1 ++ calls2 end | Sys _ c => SemAction o c reads news calls retC | Return e => retC = evalExpr e /\ news = nil /\ calls = nil /\ reads = nil end. Proof. destruct evalA; eauto; repeat eexists; try destruct (evalExpr p); eauto; try discriminate. Qed. Lemma SemActionReadsSub k a reads upds calls ret: @SemAction o k a reads upds calls ret -> SubList reads o. Proof. induction 1; auto; subst; unfold SubList in *; intros; rewrite ?in_app_iff in *. - subst; firstorder. - repeat (subst; firstorder). - subst. rewrite ?in_app_iff in H1. destruct H1; intuition. - subst. rewrite ?in_app_iff in H1. destruct H1; intuition. - subst; simpl in *; intuition. Qed. End InverseSemAction. Section evalExpr. Lemma castBits_same ty ni no (pf: ni = no) (e: Expr ty (SyntaxKind (Bit ni))): castBits pf e = match pf in _ = Y return Expr ty (SyntaxKind (Bit Y)) with | eq_refl => e end. Proof. unfold castBits. destruct pf. rewrite nat_cast_same. auto. Qed. Lemma evalExpr_castBits: forall ni no (pf: ni = no) (e: Expr type (SyntaxKind (Bit ni))), evalExpr (castBits pf e) = nat_cast (fun n => word n) pf (evalExpr e). Proof. intros. unfold castBits. destruct pf. rewrite ?nat_cast_same. auto. Qed. Lemma evalExpr_BinBit: forall kl kr k (op: BinBitOp kl kr k) (l1 l2: Expr type (SyntaxKind (Bit kl))) (r1 r2: Expr type (SyntaxKind (Bit kr))), evalExpr l1 = evalExpr l2 -> evalExpr r1 = evalExpr r2 -> evalExpr (BinBit op l1 r1) = evalExpr (BinBit op l2 r2). Proof. intros. induction op; simpl; try congruence. Qed. Lemma evalExpr_ZeroExtend: forall lsb msb (e1 e2: Expr type (SyntaxKind (Bit lsb))), evalExpr e1 = evalExpr e2 -> evalExpr (ZeroExtend msb e1) = evalExpr (ZeroExtend msb e2). Proof. intros. unfold ZeroExtend. erewrite evalExpr_BinBit; eauto. Qed. Lemma evalExpr_pack_Bool: forall (e1 e2: Expr type (SyntaxKind Bool)), evalExpr e1 = evalExpr e2 -> evalExpr (pack e1) = evalExpr (pack e2). Proof. intros. simpl. rewrite H. reflexivity. Qed. Lemma evalExpr_Void (e: Expr type (SyntaxKind (Bit 0))): evalExpr e = WO. Proof. destruct (evalExpr e). arithmetizeWord; simpl in *. rewrite Z.mod_1_r; lia. Qed. Lemma evalExpr_countLeadingZeros ni: forall no (e: Expr type (SyntaxKind (Bit ni))), evalExpr (countLeadingZeros no e) = countLeadingZerosWord _ no (evalExpr e). Proof. induction ni; simpl; intros; auto. rewrite evalExpr_castBits. simpl. unfold wzero at 2. rewrite wzero_wplus. match goal with | |- (if getBool ?P then _ else _) = (if ?P then _ else _) => destruct P; auto end. repeat f_equal. rewrite IHni. simpl. rewrite evalExpr_castBits. repeat f_equal. Qed. Lemma fin_to_nat_bound : forall n (x: Fin.t n), proj1_sig (Fin.to_nat x) < n. Proof. induction x; cbn; try lia. destruct (Fin.to_nat x); cbn in *; lia. Qed. Lemma fin_to_word_id : forall n (i : Fin.t n), wordToNat (natToWord (Nat.log2_up n) (proj1_sig (Fin.to_nat i))) = proj1_sig (Fin.to_nat i). Proof. intros. pose proof (log2_up_pow2 n); pose proof (fin_to_nat_bound i). rewrite wordToNat_natToWord; lia. Qed. Lemma eval_ReadArray_in_bounds : forall A n (arr : Expr type (SyntaxKind (Array n A))) i m, n <= 2 ^ m -> evalExpr (ReadArray arr (Var type (SyntaxKind (Bit m)) (natToWord m (proj1_sig (Fin.to_nat i))))) = evalExpr arr i. Proof. intros. simpl. pose proof (fin_to_nat_bound i). rewrite Z.mod_small. rewrite Nat2Z.id. destruct (lt_dec (proj1_sig (to_nat i)) n); try lia. unfold evalExpr at 1. erewrite Fin.of_nat_ext, Fin.of_nat_to_nat_inv; eauto. split; try lia. rewrite pow2_of_nat. apply Nat2Z.inj_lt. lia. Qed. Corollary eval_ReadArray_in_bounds_log : forall A n (arr : Expr type (SyntaxKind (Array n A))) i, evalExpr (ReadArray arr (Var type (SyntaxKind (Bit (Nat.log2_up n))) (natToWord (Nat.log2_up n) (proj1_sig (Fin.to_nat i))))) = evalExpr arr i. Proof. intros; apply eval_ReadArray_in_bounds, log2_up_pow2. Qed. Corollary eval_ReadArray_in_bounds_pow : forall A n (arr : Expr type (SyntaxKind (Array (2 ^ n) A))) i, evalExpr (ReadArray arr (Var type (SyntaxKind (Bit n)) (natToWord n (proj1_sig (Fin.to_nat i))))) = evalExpr arr i. Proof. intros; apply eval_ReadArray_in_bounds; auto. Qed. End evalExpr. Lemma seq_nil n m : seq n m = nil -> m = 0. Proof. induction m; auto; intro; exfalso. rewrite seq_eq in H. apply app_eq_nil in H; dest. inv H0. Qed. Lemma Reduce_seq : forall m n k, k <= n -> (map (fun x => x - k) (seq n m)) = (seq (n - k) m). Proof. induction m; intros; simpl; auto. apply f_equal2; auto. rewrite IHm, Nat.sub_succ_l; auto. Qed. Lemma getKindAttr_fst {A B : Type} {P : B -> Type} {Q : B -> Type} (l1 : list (A * {x : B & P x})): forall (l2 : list (A * {x : B & Q x})), getKindAttr l1 = getKindAttr l2 -> (map fst l1) = (map fst l2). Proof. induction l1, l2; intros; auto; simpl in *; inv H. erewrite IHl1; eauto. Qed. Lemma NoDup_app_split {A : Type} (l l' : list A) : NoDup (l++l') -> forall a, In a l -> ~ In a l'. Proof. induction l'; repeat intro;[inv H1|]. specialize (NoDup_remove _ _ _ H) as P0; dest. inv H1; apply H3; rewrite in_app_iff; auto. exfalso; eapply IHl'; eauto. Qed. Lemma KeyMatch (l1 : RegsT) : NoDup (map fst l1) -> forall l2, map fst l1 = map fst l2 -> (forall s v, In (s, v) l1 -> In (s, v) l2) -> l1 = l2. Proof. induction l1; intros. - destruct l2; inv H0; auto. - destruct a; simpl in *. destruct l2; inv H0. destruct p; simpl in *. inv H. specialize (H1 _ _ (or_introl (eq_refl))) as TMP; destruct TMP. + rewrite H in *. assert (forall s v, In (s, v) l1 -> In (s, v) l2). { intros. destruct (H1 _ _ (or_intror H0)); auto. exfalso. inv H2. apply H3. rewrite in_map_iff. exists (s2, v); auto. } rewrite (IHl1 H5 _ H4 H0). reflexivity. + exfalso. apply H3. rewrite H4, in_map_iff. exists (s, s0); auto. Qed. Lemma seq_app' s e : forall m (Hm_lte_e : m <= e), seq s e = seq s m ++ seq (s + m) (e - m). Proof. induction e; intros. - rewrite Nat.le_0_r in *; subst; simpl; reflexivity. - destruct (le_lt_or_eq _ _ Hm_lte_e). + rewrite Nat.sub_succ_l; [|lia]. repeat rewrite seq_eq. assert (s + m + (e - m) = s + e) as P0. { lia. } rewrite (IHe m), app_assoc, P0; auto. lia. + rewrite <- H. rewrite Nat.sub_diag, app_nil_r; reflexivity. Qed. Lemma fst_getKindAttr {A B : Type} {P : B -> Type} (l : list (A * {x : B & P x})) : map fst (getKindAttr l) = map fst l. Proof. induction l; simpl; auto. rewrite IHl; reflexivity. Qed. Lemma key_not_In_app {A B : Type} (key : A) (ls1 ls2 : list (A * B)): key_not_In key (ls1 ++ ls2) -> key_not_In key ls1 /\ key_not_In key ls2. Proof. induction ls1; simpl; intros; split; repeat intro; auto; eapply H; eauto; simpl; rewrite in_app_iff; eauto. inv H0; eauto. Qed. Lemma key_not_In_app_iff {A B : Type} (key : A) (ls1 ls2 : list (A * B)): key_not_In key (ls1 ++ ls2) <-> key_not_In key ls1 /\ key_not_In key ls2. Proof. split; eauto using key_not_In_app. repeat intro; dest. rewrite in_app_iff in H0. destruct H0. - eapply H; eauto. - eapply H1; eauto. Qed. Lemma existsb_nexists_str str l : existsb (String.eqb str) l = false <-> ~ In str l. Proof. split; repeat intro. - assert (exists x, In x l /\ (String.eqb str) x = true) as P0. { exists str; split; auto. apply String.eqb_refl. } rewrite <- existsb_exists in P0; rewrite P0 in *; discriminate. - remember (existsb _ _) as exb; symmetry in Heqexb; destruct exb; auto. exfalso; rewrite existsb_exists in Heqexb; dest. rewrite String.eqb_eq in *; subst; auto. Qed. Lemma nth_error_map_None_iff : forall {A B : Type} (f : A -> B) (l : list A) (n : nat), nth_error l n = None <-> nth_error (map f l) n = None. Proof. intros; split; intros; rewrite nth_error_None, map_length in *; assumption. Qed. Lemma nth_error_map_Some1 : forall {A B : Type} (f : A -> B) (l : list A) (b : B) (n : nat), nth_error (map f l) n = Some b -> exists a, nth_error l n = Some a /\ (f a = b). Proof. intros. specialize (nth_error_map f (fun b => nth_error (map f l) n = Some b) n l) as P0. rewrite H in P0. remember (nth_error l _) as err0; symmetry in Heqerr0; destruct err0. - exists a; split; auto. destruct P0 as [P0 P1]. specialize (P0 eq_refl); inv P0; reflexivity. - exfalso. rewrite nth_error_None in Heqerr0. enough (Some b <> None). { eapply H0; rewrite <- H. rewrite nth_error_None, map_length; assumption. } intro; discriminate. Qed. Lemma nth_error_map_Some2 : forall {A B : Type} (f : A -> B) (l : list A) (b : B) (n : nat), (exists a, nth_error l n = Some a /\ (f a = b)) -> nth_error (map f l) n = Some b. Proof. intros; dest. rewrite <- H0; eapply map_nth_error; eauto. Qed. Lemma nth_error_map_iff : forall {A B : Type} (f : A -> B) (l : list A) (b : B) (n : nat), nth_error (map f l) n = Some b <-> (exists a, nth_error l n = Some a /\ (f a = b)). Proof. repeat red; intros; dest; eauto using nth_error_map_Some1, nth_error_map_Some2. Qed. Lemma nth_error_nil_None : forall {A : Type} (n : nat), nth_error (nil : list A) n = None. Proof. intros; rewrite nth_error_None; simpl; lia. Qed. Lemma SubList_map_iff {A B : Type} (f : A -> B) (l' : list B) : forall (l : list A), SubList l' (map f l) <-> exists l'', SubList l'' l /\ (map f l'' = l'). Proof. intros; split. - induction l'; simpl; intros. + exists nil; simpl; split; repeat intro; auto. destruct l; auto. exfalso; inv H0. + unfold SubList in *; simpl in *. specialize (IHl' (ltac : (eauto))); dest. specialize (H _ (or_introl eq_refl)); rewrite in_map_iff in H; dest. exists (x0 :: x); split; intros; [inv H3; auto|]. simpl; apply f_equal2; assumption. - repeat intro; dest. rewrite <- H1 in H0. rewrite in_map_iff in *; dest. specialize (H _ H2). exists x1; split; assumption. Qed. Lemma KeyPair_Equiv {A B : Type} (l : list (A * B)) : NoDup (map fst l) -> forall l', SubList l l' -> map fst l = map fst l' -> l = l'. Proof. induction l; simpl; intros. - rewrite (map_eq_nil _ _ (eq_sym H1)); reflexivity. - destruct l'; [discriminate|]. apply f_equal2; simpl in *. + assert (In a (p :: l')). { apply H0; left; reflexivity. } inv H2; eauto. exfalso. apply (in_map fst) in H3; rewrite H1 in H; inv H1. rewrite <- H4 in H; inv H; contradiction. + enough (SubList l l'). { inv H; inv H1; eapply IHl; eauto. } repeat intro. specialize (H0 _ (in_cons _ _ _ H2)). inv H0; eauto. exfalso. apply (in_map fst) in H2. inv H1; rewrite H3 in H; inv H; contradiction. Qed. Lemma getNumCalls_nil f : getNumCalls f nil = 0%Z. Proof. reflexivity. Qed. Lemma getNumExecs_nil f : getNumExecs f nil = 0%Z. Proof. reflexivity. Qed. Lemma getNumFromCalls_eq_cons f g l : f = g -> getNumFromCalls f (g::l) = (1 + (getNumFromCalls f l))%Z. Proof. intro;unfold getNumFromCalls; destruct MethT_dec; auto; contradiction. Qed. Lemma getNumFromCalls_neq_cons f g l : f <> g -> getNumFromCalls f (g::l) = getNumFromCalls f l. Proof. intro; unfold getNumFromCalls; destruct MethT_dec; auto; contradiction. Qed. Opaque getNumFromCalls. Lemma getNumFromCalls_app f l1: forall l2, getNumFromCalls f (l1++l2) = (getNumFromCalls f l1 + getNumFromCalls f l2)%Z. Proof. induction l1. - simpl; reflexivity. - intros. destruct (MethT_dec f a). + simpl; repeat rewrite getNumFromCalls_eq_cons; auto. rewrite IHl1; ring. + simpl; repeat rewrite getNumFromCalls_neq_cons; auto. Qed. Transparent getNumFromCalls. Corollary getNumCalls_app f l1 : forall l2, getNumCalls f (l1 ++ l2) = (getNumCalls f l1 + getNumCalls f l2)%Z. Proof. unfold getNumCalls. intro. rewrite map_app, concat_app, getNumFromCalls_app. reflexivity. Qed. Lemma getNumCalls_cons f a l : getNumCalls f (a::l) = ((getNumFromCalls f (snd (snd a))) + getNumCalls f l)%Z. Proof. unfold getNumCalls. simpl; rewrite getNumFromCalls_app; reflexivity. Qed. Transparent getNumFromCalls. Lemma getNumFromCalls_nonneg f l : (0 <= getNumFromCalls f l)%Z. Proof. induction l. - unfold getNumFromCalls; reflexivity. - destruct (MethT_dec f a);[rewrite getNumFromCalls_eq_cons; auto| rewrite getNumFromCalls_neq_cons; auto]. Omega.omega. Qed. Lemma getNumCalls_nonneg f l: (0 <= (getNumCalls f l))%Z. Proof. induction l. - rewrite getNumCalls_nil;reflexivity. - rewrite getNumCalls_cons. specialize (getNumFromCalls_nonneg f (snd (snd a))) as B1. Omega.omega. Qed. Lemma getNumFromExecs_eq_cons f g l : f = g -> getNumFromExecs f ((Meth g)::l) = (1 + (getNumFromExecs f l))%Z. Proof. intros; simpl; destruct (MethT_dec f g); auto; contradiction. Qed. Lemma getNumFromExecs_neq_cons f g l : f <> g -> getNumFromExecs f ((Meth g)::l) = (getNumFromExecs f l). Proof. intros; simpl; destruct (MethT_dec f g); auto; contradiction. Qed. Lemma getNumFromExecs_Rle_cons f rn l: getNumFromExecs f ((Rle rn)::l) = (getNumFromExecs f l). Proof. intros; simpl; reflexivity. Qed. Opaque getNumFromExecs. Lemma getNumFromExecs_app f l1: forall l2, getNumFromExecs f (l1++l2) = (getNumFromExecs f l1 + getNumFromExecs f l2)%Z. Proof. induction l1. - simpl; reflexivity. - intros; destruct a;[|destruct (MethT_dec f f0)];simpl. + repeat rewrite getNumFromExecs_Rle_cons; apply IHl1. + repeat rewrite getNumFromExecs_eq_cons; auto. rewrite IHl1; ring. + repeat rewrite getNumFromExecs_neq_cons; auto. Qed. Transparent getNumFromExecs. Corollary getNumExecs_app f l1 : forall l2, getNumExecs f (l1++l2) = (getNumExecs f l1 + getNumExecs f l2)%Z. Proof. unfold getNumExecs. intros;rewrite map_app, getNumFromExecs_app; reflexivity. Qed. Lemma getNumFromExecs_nonneg f l: (0 <= (getNumFromExecs f l))%Z. Proof. induction l. - simpl; reflexivity. - destruct a;[rewrite getNumFromExecs_Rle_cons |destruct (MethT_dec f f0);[rewrite getNumFromExecs_eq_cons |rewrite getNumFromExecs_neq_cons]]; auto; Omega.omega. Qed. Corollary getNumExecs_nonneg f l : (0 <= (getNumExecs f l))%Z. Proof. unfold getNumExecs;apply getNumFromExecs_nonneg. Qed. Lemma getNumFromCalls_perm f l l': l [=] l' -> getNumFromCalls f l = getNumFromCalls f l'. Proof. induction 1; auto. - destruct (MethT_dec f x);[repeat rewrite getNumFromCalls_eq_cons| repeat rewrite getNumFromCalls_neq_cons];auto. rewrite IHPermutation; reflexivity. - destruct (MethT_dec f x), (MethT_dec f y). + repeat rewrite getNumFromCalls_eq_cons; auto. + rewrite getNumFromCalls_neq_cons, getNumFromCalls_eq_cons, getNumFromCalls_eq_cons, getNumFromCalls_neq_cons ; auto. + rewrite getNumFromCalls_eq_cons, getNumFromCalls_neq_cons, getNumFromCalls_neq_cons, getNumFromCalls_eq_cons ; auto. + repeat rewrite getNumFromCalls_neq_cons; auto. - rewrite IHPermutation1, IHPermutation2; reflexivity. Qed. Global Instance getNumFromCalls_perm_rewrite' : Proper (eq ==> @Permutation (MethT) ==> eq) (@getNumFromCalls) | 10. Proof. repeat red; intros; subst; eauto using getNumFromCalls_perm. Qed. Lemma concat_perm_rewrite (A : Type) (l l' : list (list A)): l [=] l' -> concat l [=] concat l'. Proof. induction 1. - reflexivity. - simpl; rewrite IHPermutation; reflexivity. - simpl; repeat rewrite app_assoc. apply Permutation_app_tail, Permutation_app_comm. - eauto using Permutation_trans. Qed. Global Instance concat_perm_rewrite' {A : Type}: Proper (@Permutation (list A) ==> @Permutation A) (@concat A) | 10. Proof. repeat red; eauto using concat_perm_rewrite. Qed. Corollary getNumCalls_perm_rewrite f l l': l [=] l' -> getNumCalls f l = getNumCalls f l'. Proof. unfold getNumCalls. intros; rewrite H; reflexivity. Qed. Global Instance getNumCalls_perm_rewrite' : Proper (eq ==> @Permutation FullLabel ==> eq) (@getNumCalls) | 10. Proof. repeat red; intros; subst; eauto using getNumCalls_perm_rewrite. Qed. Lemma getNumFromExecs_perm f l l': l [=] l' -> getNumFromExecs f l = getNumFromExecs f l'. Proof. induction 1; auto. - destruct x;[repeat rewrite getNumFromExecs_Rle_cons;rewrite IHPermutation; reflexivity|]. destruct (MethT_dec f f0);[repeat rewrite getNumFromExecs_eq_cons| repeat rewrite getNumFromExecs_neq_cons];auto. rewrite IHPermutation; reflexivity. - destruct x, y. + repeat rewrite getNumFromExecs_Rle_cons; reflexivity. + destruct (MethT_dec f f0). * rewrite getNumFromExecs_eq_cons, getNumFromExecs_Rle_cons, getNumFromExecs_Rle_cons, getNumFromExecs_eq_cons; auto. * rewrite getNumFromExecs_neq_cons, getNumFromExecs_Rle_cons, getNumFromExecs_Rle_cons, getNumFromExecs_neq_cons; auto. + destruct (MethT_dec f f0). * rewrite getNumFromExecs_eq_cons, getNumFromExecs_Rle_cons, getNumFromExecs_Rle_cons, getNumFromExecs_eq_cons; auto. * rewrite getNumFromExecs_neq_cons, getNumFromExecs_Rle_cons, getNumFromExecs_Rle_cons, getNumFromExecs_neq_cons; auto. + destruct (MethT_dec f f0), (MethT_dec f f1). * repeat rewrite getNumFromExecs_eq_cons; auto. * rewrite getNumFromExecs_neq_cons, getNumFromExecs_eq_cons, getNumFromExecs_eq_cons, getNumFromExecs_neq_cons; auto. * rewrite getNumFromExecs_eq_cons, getNumFromExecs_neq_cons, getNumFromExecs_neq_cons, getNumFromExecs_eq_cons; auto. * repeat rewrite getNumFromExecs_neq_cons; auto. - eauto using eq_trans. Qed. Global Instance getNumFromExecs_perm_rewrite' : Proper (eq ==> @Permutation RuleOrMeth ==> eq) (@getNumFromExecs) | 10. Proof. repeat red; intros; subst; eauto using getNumFromExecs_perm. Qed. Corollary getNumExecs_perm_rewrite f l l': l [=] l' -> getNumExecs f l = getNumExecs f l'. Proof. intros; unfold getNumExecs; rewrite H; reflexivity. Qed. Global Instance getNumExecs_perm_rewrite' : Proper (eq ==> @Permutation FullLabel ==> eq) (@getNumExecs) | 10. Proof. repeat red; intros; subst; eauto using getNumExecs_perm_rewrite. Qed. Definition UpdRegs' (u: list RegsT) (o o': RegsT) := map fst o = map fst o' /\ (forall s v, In (s, v) o' -> ((exists x, In x u /\ In (s, v) x) \/ ((~ exists x, In x u /\ In s (map fst x)) /\ In (s, v) o))). Lemma UpdRegs_same: forall u o o', UpdRegs u o o' -> UpdRegs' u o o'. Proof. unfold UpdRegs, UpdRegs'. intros; dest. apply (f_equal (map fst)) in H. rewrite ?map_map in H; simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in H; tauto. Qed. Lemma getKindAttr_map_fst A (P Q: A -> Type) : forall (l2: list (Attribute (sigT P))) (l1: list (Attribute (sigT Q))), getKindAttr l1 = getKindAttr l2 -> map fst l1 = map fst l2. Proof. induction l2; simpl; auto; intros. - apply map_eq_nil in H; subst; auto. - destruct l1; simpl in *. + discriminate. + inv H; f_equal. apply IHl2; auto. Qed. Lemma Step_getAllRegisters m o l: Step m o l -> getKindAttr o = getKindAttr (getAllRegisters m). Proof. induction 1; auto; simpl. - inv HSubsteps; auto. - rewrite map_app. rewrite <- IHStep1, <- IHStep2, HRegs. rewrite map_app. auto. Qed. Lemma Step_getAllRegisters_fst m o l: Step m o l -> map fst o = map fst (getAllRegisters m). Proof. intros. apply Step_getAllRegisters in H. eapply getKindAttr_map_fst; eauto. Qed. Lemma DisjRegs_1_id (l1: list RegInitT): forall l2 (o1 o2: RegsT), DisjKey l1 l2 -> map fst o1 = map fst l1 -> map fst o2 = map fst l2 -> filter (fun x => id (getBool (in_dec string_dec (fst x) (map fst l1)))) (o1 ++ o2) = o1. Proof. intros. rewrite filter_app. rewrite <- H0. erewrite filter_in_dec_map. erewrite filter_not_in_dec_map. - rewrite app_nil_r; auto. - unfold DisjKey in *; intros. specialize (H k). firstorder congruence. Qed. Lemma DisjRegs_1_negb (l1: list RegInitT): forall l2 (o1 o2: RegsT), DisjKey l1 l2 -> map fst o1 = map fst l1 -> map fst o2 = map fst l2 -> filter (fun x => negb (getBool (in_dec string_dec (fst x) (map fst l1)))) (o1 ++ o2) = o2. Proof. intros. rewrite filter_app. rewrite <- H0. erewrite filter_negb_in_dec_map. erewrite filter_negb_not_in_dec_map. - auto. - unfold DisjKey in *; intros. specialize (H k). firstorder congruence. Qed. Lemma DisjRegs_2_id (l1: list RegInitT): forall l2 (o1 o2: RegsT), DisjKey l1 l2 -> map fst o1 = map fst l1 -> map fst o2 = map fst l2 -> filter (fun x => id (getBool (in_dec string_dec (fst x) (map fst l2)))) (o1 ++ o2) = o2. Proof. intros. rewrite filter_app. rewrite <- H1. erewrite filter_in_dec_map. erewrite filter_not_in_dec_map. - rewrite ?app_nil_r; auto. - unfold DisjKey in *; intros. specialize (H k). firstorder congruence. Qed. Lemma DisjRegs_2_negb (l1: list RegInitT): forall l2 (o1 o2: RegsT), DisjKey l1 l2 -> map fst o1 = map fst l1 -> map fst o2 = map fst l2 -> filter (fun x => negb (getBool (in_dec string_dec (fst x) (map fst l2)))) (o1 ++ o2) = o1. Proof. intros. rewrite filter_app. rewrite <- H1. erewrite filter_negb_in_dec_map. erewrite filter_negb_not_in_dec_map. - rewrite ?app_nil_r; auto. - unfold DisjKey in *; intros. specialize (H k). firstorder congruence. Qed. Lemma Substeps_rm_In m o l: Substeps m o l -> forall fv, In fv l -> match fst (snd fv) with | Rle r => getBool (in_dec string_dec r (map fst (getRules m))) | Meth (f, v) => getBool (in_dec string_dec f (map fst (getMethods m))) end = true. Proof. induction 1; simpl; intros; subst; try tauto. - simpl in *. destruct H0. + inv H0. simpl. destruct (in_dec string_dec rn (map fst (getRules m))); simpl; auto. exfalso; apply (n (in_map fst _ _ HInRules)). + eapply IHSubsteps; eauto. - simpl in *. destruct H0. + inv H0. simpl. destruct (in_dec string_dec fn (map fst (getMethods m))); simpl; auto. exfalso; apply (n (in_map fst _ _ HInMeths)). + eapply IHSubsteps; eauto. Qed. Lemma Step_rm_In m o l: Step m o l -> forall fv, In fv l -> match fst (snd fv) with | Rle r => getBool (in_dec string_dec r (map fst (getAllRules m))) | Meth (f, v) => getBool (in_dec string_dec f (map fst (getAllMethods m))) end = true. Proof. induction 1; simpl; auto; intros. - eapply Substeps_rm_In; eauto. - subst. specialize (IHStep1 fv). specialize (IHStep2 fv). rewrite ?map_app, in_app_iff in *. destruct fv as [? [b ?]]; simpl; auto. destruct b as [b | b]; auto; simpl in *; [| destruct b]; match goal with | |- getBool ?P = _ => destruct P end; simpl; auto; rewrite in_app_iff in *. + destruct (in_dec string_dec b (map fst (getAllRules m1))), (in_dec string_dec b (map fst (getAllRules m2))); simpl in *; tauto. + destruct (in_dec string_dec s (map fst (getAllMethods m1))), (in_dec string_dec s (map fst (getAllMethods m2))); simpl in *; tauto. Qed. Lemma Substeps_rm_not_In m1 m2 o l: DisjKey (getAllRules m1) (getRules m2) -> DisjKey (getAllMethods m1) (getMethods m2) -> Substeps m2 o l -> forall fv, In fv l -> match fst (snd fv) with | Rle r => getBool (in_dec string_dec r (map fst (getAllRules m1))) | Meth (f, v) => getBool (in_dec string_dec f (map fst (getAllMethods m1))) end = false. Proof. intros DisjRules DisjMeths. induction 1; simpl; auto; intros; subst; try tauto. - destruct H0. + inv H0. simpl. destruct (in_dec string_dec rn (map fst (getAllRules m1))); simpl; auto. apply (in_map fst) in HInRules. clear - DisjRules DisjMeths HInRules i. specialize (DisjRules rn); specialize (DisjMeths rn); tauto. + eapply IHSubsteps; eauto. - simpl in *. destruct H0. + inv H0. simpl. destruct (in_dec string_dec fn (map fst (getAllMethods m1))); simpl; auto. apply (in_map fst) in HInMeths. clear - DisjRules DisjMeths HInMeths i. specialize (DisjRules fn); specialize (DisjMeths fn); tauto. + eapply IHSubsteps; eauto. Qed. Lemma Step_rm_not_In m1 m2 o l: DisjKey (getAllRules m1) (getAllRules m2) -> DisjKey (getAllMethods m1) (getAllMethods m2) -> Step m2 o l -> forall fv, In fv l -> match fst (snd fv) with | Rle r => getBool (in_dec string_dec r (map fst (getAllRules m1))) | Meth (f, v) => getBool (in_dec string_dec f (map fst (getAllMethods m1))) end = false. Proof. intros DisjRules DisjMeths. induction 1; simpl; auto; intros. - eapply Substeps_rm_not_In; eauto. - subst. assert (sth1: DisjKey (getAllRules m1) (getAllRules m0)) by (clear - DisjRules; unfold DisjKey in *; simpl in *; rewrite ?map_app in *; setoid_rewrite in_app_iff in DisjRules; firstorder fail). assert (sth2: DisjKey (getAllMethods m1) (getAllMethods m0)) by (clear - DisjMeths; unfold DisjKey in *; simpl in *; intro k; rewrite ?map_app in *; specialize (DisjMeths k); rewrite in_app_iff in DisjMeths; tauto). assert (sth3: DisjKey (getAllRules m1) (getAllRules m2)) by (clear - DisjRules; unfold DisjKey in *; simpl in *; intro k; rewrite ?map_app in *; specialize (DisjRules k); rewrite in_app_iff in DisjRules; tauto). assert (sth4: DisjKey (getAllMethods m1) (getAllMethods m2)) by (clear - DisjMeths; unfold DisjKey in *; simpl in *; intro k; rewrite ?map_app in *; specialize (DisjMeths k); rewrite in_app_iff in DisjMeths; tauto). specialize (IHStep1 sth1 sth2 fv). specialize (IHStep2 sth3 sth4 fv). rewrite ?map_app, in_app_iff in *. destruct fv as [? [b ?]]; simpl; auto. destruct b as [b | b]; auto; simpl in *; [| destruct b]; match goal with | |- getBool ?P = _ => destruct P end; simpl; auto; rewrite ?in_app_iff in *; simpl in *; clear - IHStep1 IHStep2 H1; firstorder fail. Qed. Lemma DisjMeths_1_id m1 o1 l1 m2 o2 l2: DisjKey (getAllRules m1) (getAllRules m2) -> DisjKey (getAllMethods m1) (getAllMethods m2) -> Step m1 o1 l1 -> Step m2 o2 l2 -> filterExecs id m1 (l1 ++ l2) = l1. Proof. intros DisjRules DisjMeths Step1 Step2. unfold filterExecs, id. rewrite filter_app. rewrite filter_true_list at 1. - rewrite filter_false_list at 1. + rewrite ?app_nil_r; auto. + eapply Step_rm_not_In; eauto. - eapply Step_rm_In; eauto. Qed. Lemma DisjMeths_2_id m1 o1 l1 m2 o2 l2: DisjKey (getAllRules m1) (getAllRules m2) -> DisjKey (getAllMethods m1) (getAllMethods m2) -> Step m1 o1 l1 -> Step m2 o2 l2 -> filterExecs id m2 (l1 ++ l2) = l2. Proof. intros DisjRules DisjMeths Step1 Step2. unfold filterExecs, id. rewrite filter_app. rewrite filter_false_list at 1. - rewrite filter_true_list at 1. + rewrite ?app_nil_r; auto. + eapply Step_rm_In; eauto. - eapply Step_rm_not_In; eauto. + clear - DisjRules; firstorder fail. + clear - DisjMeths; intro k; specialize (DisjMeths k); tauto. Qed. Lemma DisjMeths_1_negb m1 o1 l1 m2 o2 l2: DisjKey (getAllRules m1) (getAllRules m2) -> DisjKey (getAllMethods m1) (getAllMethods m2) -> Step m1 o1 l1 -> Step m2 o2 l2 -> filterExecs negb m1 (l1 ++ l2) = l2. Proof. intros DisjRules DisjMeths Step1 Step2. unfold filterExecs, id. rewrite filter_app. rewrite filter_false_list at 1. - rewrite filter_true_list at 1. + rewrite ?app_nil_r; auto. + setoid_rewrite negb_true_iff. eapply Step_rm_not_In; eauto. - setoid_rewrite negb_false_iff. eapply Step_rm_In; eauto. Qed. Lemma DisjMeths_2_negb m1 o1 l1 m2 o2 l2: DisjKey (getAllRules m1) (getAllRules m2) -> DisjKey (getAllMethods m1) (getAllMethods m2) -> Step m1 o1 l1 -> Step m2 o2 l2 -> filterExecs negb m2 (l1 ++ l2) = l1. Proof. intros DisjRules DisjMeths Step1 Step2. unfold filterExecs, id. rewrite filter_app. rewrite filter_true_list at 1. - rewrite filter_false_list at 1. + rewrite ?app_nil_r; auto. + setoid_rewrite negb_false_iff. eapply Step_rm_In; eauto. - setoid_rewrite negb_true_iff. eapply Step_rm_not_In; eauto. + clear - DisjRules; firstorder fail. + clear - DisjMeths; intro k; specialize (DisjMeths k); tauto. Qed. Lemma Substeps_upd_SubList_key m o l: Substeps m o l -> forall x s v, In x (map fst l) -> In (s, v) x -> In s (map fst (getRegisters m)). Proof. induction 1; intros. - simpl in *; tauto. - subst. destruct H0; subst; simpl in *. + apply (in_map (fun x => (fst x, projT1 (snd x)))) in H1; simpl in *. specialize (HUpdGood _ H1). apply (in_map fst) in HUpdGood. rewrite map_map in HUpdGood. simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HUpdGood; auto. + eapply IHSubsteps; eauto. - subst. destruct H0; subst; simpl in *. + apply (in_map (fun x => (fst x, projT1 (snd x)))) in H1; simpl in *. specialize (HUpdGood _ H1). apply (in_map fst) in HUpdGood. rewrite map_map in HUpdGood. simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HUpdGood; auto. + eapply IHSubsteps; eauto. Qed. Lemma Substeps_upd_In m o l: Substeps m o l -> forall x, In x (map fst l) -> forall s: string, In s (map fst x) -> In s (map fst (getRegisters m)). Proof. intros. rewrite in_map_iff in H1; dest; subst. destruct x0; simpl. eapply Substeps_upd_SubList_key; eauto. Qed. Lemma Substeps_read m o l: Substeps m o l -> forall s v, In (s, v) o -> In s (map fst (getRegisters m)). Proof. induction 1; intros. - apply (f_equal (map fst)) in HRegs. rewrite ?map_map in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HRegs; auto. apply (in_map fst) in H. simpl in *. congruence. - subst. apply (f_equal (map fst)) in HRegs. rewrite ?map_map in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HRegs; auto. apply (in_map fst) in H0. simpl in *. congruence. - subst. apply (f_equal (map fst)) in HRegs. rewrite ?map_map in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HRegs; auto. apply (in_map fst) in H0. simpl in *. congruence. Qed. Lemma Step_upd_SubList_key m o l: Step m o l -> forall x s v, In x (map fst l) -> In (s, v) x -> In s (map fst (getAllRegisters m)). Proof. induction 1; intros. - eapply Substeps_upd_SubList_key; eauto. - eapply IHStep; eauto. - simpl. subst. rewrite map_app in *. rewrite in_app_iff in *. specialize (IHStep1 x s v). specialize (IHStep2 x s v). tauto. Qed. Lemma Step_read m o l: Step m o l -> forall s v, In (s, v) o -> In s (map fst (getAllRegisters m)). Proof. induction 1; intros. - eapply Substeps_read; eauto. - eapply IHStep; eauto. - simpl. subst. rewrite map_app in *. rewrite in_app_iff in *. specialize (IHStep1 s v). specialize (IHStep2 s v). tauto. Qed. Lemma Forall2_impl A B (P Q: A -> B -> Prop): (forall a b, P a b -> Q a b) -> forall la lb, Forall2 P la lb -> Forall2 Q la lb. Proof. induction la; destruct lb; simpl; auto; intros. - inv H0; tauto. - inv H0; tauto. - inv H0; constructor; firstorder fail. Qed. Lemma Forall2_map_eq A B C (f: A -> C) (g: B -> C): forall la lb, Forall2 (fun a b => f a = g b) la lb -> map f la = map g lb. Proof. induction la; destruct lb; simpl; auto; intros. - inv H. - inv H. - inv H. f_equal; firstorder fail. Qed. Lemma Forall2_app_eq_length A B (P: A -> B -> Prop) : forall l1a l2a l1b l2b, Forall2 P (l1a ++ l2a) (l1b ++ l2b) -> length l1a = length l1b -> Forall2 P l1a l1b /\ Forall2 P l2a l2b. Proof. induction l1a; simpl; auto; intros. - apply eq_sym in H0. rewrite length_zero_iff_nil in H0. subst; simpl in *. split; auto. - destruct l1b; simpl in *; [discriminate|]. split; inv H; [| eapply IHl1a; eauto]. constructor; auto. specialize (IHl1a _ _ _ H6). destruct IHl1a; auto. Qed. Lemma same_length_map_DisjKey A B (o: list (Attribute A)): forall (l1 l2: list (Attribute B)), map fst o = map fst l1 ++ map fst l2 -> DisjKey l1 l2 -> o = filter (fun x => getBool (in_dec string_dec (fst x) (map fst l1))) o ++ filter (fun x => getBool (in_dec string_dec (fst x) (map fst l2))) o -> length (map fst l1) = length (filter (fun x => getBool (in_dec string_dec (fst x) (map fst l1))) o). Proof. induction o; simpl; auto; intros. - apply eq_sym in H. apply app_eq_nil in H; subst; dest; subst. rewrite H; auto. - destruct l1; simpl; rewrite ?filter_false; auto; simpl in *. inv H; subst. rewrite H3 in *. destruct (string_dec (fst p) (fst p)); [simpl in *| exfalso; clear - n; tauto]. inv H1. assert (sth: DisjKey l1 l2) by (clear - H0; firstorder fail). specialize (IHo _ _ H4 sth). destruct (in_dec string_dec (fst p) (map fst l2)); simpl in *. + unfold DisjKey in *. specialize (H0 (fst p)); simpl in *. destruct H0; tauto. + rewrite <- H2. simpl in *. assert (sth2: (fun x : string * A => getBool match string_dec (fst p) (fst x) with | left e => left (or_introl e) | right n => match in_dec string_dec (fst x) (map fst l1) with | left i => left (or_intror i) | right n0 => right (fun H0 : fst p = fst x \/ In (fst x) (map fst l1) => match H0 with | or_introl Hc1 => n Hc1 | or_intror Hc2 => n0 Hc2 end) end end) = (fun x : string * A => match string_dec (fst p) (fst x) with | left _ => true | right _ => getBool (in_dec string_dec (fst x) (map fst l1)) end)). { extensionality x. destruct (string_dec (fst p) (fst x)); auto. destruct (in_dec string_dec (fst x) (map fst l1)); auto. } setoid_rewrite sth2 in H2. setoid_rewrite sth2. clear sth2. destruct (in_dec string_dec (fst p) (map fst l1)). * assert (sth3: (fun x: string * A => if string_dec (fst p) (fst x) then true else getBool (in_dec string_dec (fst x) (map fst l1))) = fun x => getBool (in_dec string_dec (fst x) (map fst l1))). { extensionality x. destruct (string_dec (fst p) (fst x)); auto. rewrite <- e0. destruct (in_dec string_dec (fst p) (map fst l1)); auto. exfalso; tauto. } rewrite sth3 in *. specialize (IHo H2). auto. * assert (sth2: ~ In (fst p) (map fst o)). { rewrite H4. rewrite in_app_iff. intro. tauto. } assert (sth3: filter (fun x: string * A => if string_dec (fst p) (fst x) then true else getBool (in_dec string_dec (fst x) (map fst l1))) o = filter (fun x => getBool (in_dec string_dec (fst x) (map fst l1))) o). { clear - sth2. generalize p sth2; clear p sth2. induction o; simpl; auto; intros. assert (sth4: ~ In (fst p) (map fst o)) by tauto. assert (sth5: fst a <> fst p) by tauto. specialize (IHo _ sth4). rewrite IHo. destruct (string_dec (fst p) (fst a)); try tauto. rewrite e in *; tauto. } rewrite sth3 in *. specialize (IHo H2). auto. Qed. Section SplitJoin. Variable m1 m2: Mod. Variable DisjRegs: DisjKey (getAllRegisters m1) (getAllRegisters m2). Variable DisjRules: DisjKey (getAllRules m1) (getAllRules m2). Variable DisjMethods: DisjKey (getAllMethods m1) (getAllMethods m2). Lemma SplitStep o l: Step (ConcatMod m1 m2) o l -> Step m1 (filterRegs id m1 o) (filterExecs id m1 l) /\ Step m2 (filterRegs id m2 o) (filterExecs id m2 l) /\ o = filterRegs id m1 o ++ filterRegs id m2 o /\ MatchingExecCalls_Concat (filterExecs id m1 l) (filterExecs id m2 l) m2 /\ MatchingExecCalls_Concat (filterExecs id m2 l) (filterExecs id m1 l) m1 /\ (forall x y : FullLabel, In x (filterExecs id m1 l) -> In y (filterExecs id m2 l) -> match fst (snd x) with | Rle _ => match fst (snd y) with | Rle _ => False | Meth _ => True end | Meth _ => True end) /\ l = filterExecs id m1 l ++ filterExecs id m2 l. Proof. intros H. inv H; intros. pose proof (Step_getAllRegisters_fst HStep1) as HRegs1. pose proof (Step_getAllRegisters_fst HStep2) as HRegs2. unfold filterRegs. rewrite DisjRegs_1_id with (l2 := getAllRegisters m2) (o1 := o1), DisjRegs_2_id with (l1 := getAllRegisters m1) (o2 := o2); auto. rewrite DisjMeths_1_id with (m2 := m2) (o1 := o1) (o2 := o2), DisjMeths_2_id with (m1 := m1) (o1 := o1) (o2 := o2); auto. Opaque MatchingExecCalls_Concat. repeat split; auto. Transparent MatchingExecCalls_Concat. Qed. Lemma Step_upd_1 o l: Step (ConcatMod m1 m2) o l -> forall x s v, In x (map fst l) -> In (s, v) x -> In s (map fst (getAllRegisters m1)) -> In x (map fst (filterExecs id m1 l)). Proof. remember (ConcatMod m1 m2) as m. destruct 1; try discriminate; intros. inv Heqm. pose proof (Step_getAllRegisters_fst H) as HRegs1. pose proof (Step_getAllRegisters_fst H0) as HRegs2. unfold filterRegs. rewrite DisjMeths_1_id with (m2 := m2) (o1 := o1) (o2 := o2); auto. rewrite map_app in *. rewrite in_app_iff in *. destruct H1; auto. pose proof (Step_upd_SubList_key H0 _ _ _ H1 H2) as sth. specialize (DisjRegs s); tauto. Qed. Lemma Step_upd_2 o l: Step (ConcatMod m1 m2) o l -> forall x s v, In x (map fst l) -> In (s, v) x -> In s (map fst (getAllRegisters m2)) -> In x (map fst (filterExecs id m2 l)). Proof. remember (ConcatMod m1 m2) as m. destruct 1; try discriminate; intros. inv Heqm. pose proof (Step_getAllRegisters_fst H) as HRegs1. pose proof (Step_getAllRegisters_fst H0) as HRegs2. unfold filterRegs. rewrite DisjMeths_2_id with (m1 := m1) (o1 := o1) (o2 := o2); auto. rewrite map_app in *. rewrite in_app_iff in *. destruct H1; auto. pose proof (Step_upd_SubList_key H _ _ _ H1 H2) as sth. specialize (DisjRegs s); tauto. Qed. Local Notation optFullType := (fun fk => option (fullType type fk)). Lemma SplitTrace o ls: Trace (ConcatMod m1 m2) o ls -> Trace m1 (filterRegs id m1 o) (map (filterExecs id m1) ls) /\ Trace m2 (filterRegs id m2 o) (map (filterExecs id m2) ls) /\ o = filterRegs id m1 o ++ filterRegs id m2 o /\ mapProp (fun l => MatchingExecCalls_Concat (filterExecs id m1 l) (filterExecs id m2 l) m2 /\ MatchingExecCalls_Concat (filterExecs id m2 l) (filterExecs id m1 l) m1 /\ (forall x y : FullLabel, In x (filterExecs id m1 l) -> In y (filterExecs id m2 l) -> match fst (snd x) with | Rle _ => match fst (snd y) with | Rle _ => False | Meth _ => True end | Meth _ => True end) /\ l = filterExecs id m1 l ++ filterExecs id m2 l) ls /\ map fst o = map fst (getAllRegisters (ConcatMod m1 m2)). Proof. Opaque MatchingExecCalls_Concat. induction 1; subst; simpl. - unfold filterRegs, filterExecs; simpl. rewrite ?map_app, ?filter_app. unfold id in *. assert (sth: Forall2 (fun o' r => fst o' = fst r) o' (getAllRegisters (ConcatMod m1 m2))) by (eapply Forall2_impl; eauto; intros; simpl in *; tauto). apply Forall2_map_eq in sth. simpl in sth. rewrite map_app in sth. assert (DisjRegs': DisjKey (getAllRegisters m2) (getAllRegisters m1)) by (clear - DisjRegs; firstorder). match goal with | |- _ /\ _ /\ ?P /\ _ /\ _ => assert P by (eapply filter_map_app_sameKey; eauto) end. simpl in *. pose proof (same_length_map_DisjKey sth DisjRegs H) as sth2. rewrite H in HUpdRegs. apply Forall2_app_eq_length in HUpdRegs; auto; dest. repeat split; auto; constructor; auto; subst; rewrite ?filter_app in *. rewrite map_length in *. congruence. - pose proof HStep as HStep'. apply SplitStep in HStep. dest. repeat split; try econstructor 2; eauto. + unfold UpdRegs in *; dest. repeat split; intros. * unfold filterRegs, id. pose proof (filter_map_simple (fun x => (fst x, projT1 (snd x))) (fun x => getBool (in_dec string_dec (fst x) (map fst (getAllRegisters m1)))) o) as sth_o. pose proof (filter_map_simple (fun x => (fst x, projT1 (snd x))) (fun x => getBool (in_dec string_dec (fst x) (map fst (getAllRegisters m1)))) o') as sth_o'. simpl in sth_o, sth_o'. rewrite <- ?sth_o, <- ?sth_o'. rewrite H12; auto. * unfold filterRegs, id in H14. rewrite filter_In in H14; dest. simpl in *. destruct (in_dec string_dec s (map fst (getAllRegisters m1))); [simpl in *| discriminate]. specialize (H13 _ _ H14). destruct H13; [left; dest | right]. -- exists x; repeat split; auto. eapply Step_upd_1; eauto. -- split; try intro; dest. ++ unfold filterExecs, id in H16. rewrite in_map_iff in H16; dest. rewrite filter_In in H19; dest. setoid_rewrite in_map_iff at 1 in H13. clear - H13 H16 H19 H18. firstorder fail. ++ unfold filterRegs, id. rewrite filter_In. simpl. destruct (in_dec string_dec s (map fst (getAllRegisters m1))); simpl; auto. + unfold UpdRegs in *; dest. repeat split; intros. * unfold filterRegs, id. pose proof (filter_map_simple (fun x => (fst x, projT1 (snd x))) (fun x => getBool (in_dec string_dec (fst x) (map fst (getAllRegisters m2)))) o) as sth_o. pose proof (filter_map_simple (fun x => (fst x, projT1 (snd x))) (fun x => getBool (in_dec string_dec (fst x) (map fst (getAllRegisters m2)))) o') as sth_o'. simpl in sth_o, sth_o'. rewrite <- ?sth_o, <- ?sth_o'. rewrite H12; auto. * unfold filterRegs, id in H14. rewrite filter_In in H14; dest. simpl in *. destruct (in_dec string_dec s (map fst (getAllRegisters m2))); [simpl in *| discriminate]. specialize (H13 _ _ H14). destruct H13; [left; dest | right]. -- exists x; repeat split; auto. eapply Step_upd_2; eauto. -- split; try intro; dest. ++ unfold filterExecs, id in H16. rewrite in_map_iff in H16; dest. rewrite filter_In in H19; dest. setoid_rewrite in_map_iff at 1 in H13. clear - H13 H16 H19 H18. firstorder fail. ++ unfold filterRegs, id. rewrite filter_In. simpl. destruct (in_dec string_dec s (map fst (getAllRegisters m2))); simpl; auto. + apply UpdRegs_same in HUpdRegs. unfold UpdRegs' in *; dest. rewrite H12 in H4. simpl in H4. rewrite map_app in H4. unfold filterRegs, id. apply filter_map_app_sameKey; auto. + apply UpdRegs_same in HUpdRegs. unfold UpdRegs' in *; dest. rewrite H12 in H4. simpl in H4. auto. Transparent MatchingExecCalls_Concat. Qed. Lemma JoinStep o1 o2 l1 l2: Step m1 o1 l1 -> Step m2 o2 l2 -> (MatchingExecCalls_Concat l1 l2 m2) -> (MatchingExecCalls_Concat l2 l1 m1) -> (forall x1 x2, In x1 l1 -> In x2 l2 -> match fst (snd x1), fst (snd x2) with | Rle _, Rle _ => False | _, _ => True end) -> Step (ConcatMod m1 m2) (o1 ++ o2) (l1 ++ l2). Proof. intros. econstructor 3; eauto. Qed. Lemma JoinTrace_basic l: forall o1 o2, Trace m1 o1 (map fst l) -> Trace m2 o2 (map snd l) -> (mapProp2 (fun l1 l2 => MatchingExecCalls_Concat l1 l2 m2) l) -> (mapProp2 (fun l1 l2 => MatchingExecCalls_Concat l2 l1 m1) l) -> (mapProp2 (fun l1 l2 => (forall x1 x2 : RegsT * (RuleOrMeth * MethsT), In x1 l1 -> In x2 l2 -> match fst (snd x1) with | Rle _ => match fst (snd x2) with | Rle _ => False | Meth _ => True end | Meth _ => True end)) l) -> Trace (ConcatMod m1 m2) (o1 ++ o2) (map (fun x => fst x ++ snd x) l). Proof. induction l; simpl; intros. - inversion H; inversion H0; subst; try discriminate. constructor; auto. simpl. eapply Forall2_app in HUpdRegs0; eauto. - destruct a; simpl in *; dest. inv H; [discriminate| ]; inv H0; [discriminate|]. inv HTrace; inv HTrace0. specialize (IHl _ _ HOldTrace HOldTrace0 H6 H5 H4). econstructor 2 with (o := o ++ o0); eauto. eapply JoinStep; eauto. unfold UpdRegs in *; dest. split. + rewrite ?map_app. congruence. + intros. rewrite in_app_iff in H9. destruct H9. * specialize (H8 _ _ H9). rewrite ?map_app. repeat setoid_rewrite in_app_iff. destruct H8; [left; dest | right; dest]. -- exists x; split; auto. -- split; auto. intro. dest. destruct H11;[apply H8; eexists; eauto|]. rewrite in_map_iff in H12; dest. destruct x0. subst. simpl in *. pose proof (Step_upd_SubList_key HStep0 _ _ _ H11 H13). pose proof (Step_read HStep _ _ H10). specialize (DisjRegs s0); tauto. * specialize (H0 _ _ H9). rewrite ?map_app. repeat setoid_rewrite in_app_iff. destruct H0; [left; dest | right; dest]. -- exists x; split; auto. -- split; auto. intro. dest. destruct H11; [|apply H0; eexists; eauto]. rewrite in_map_iff in H12; dest. destruct x0. subst. simpl in *. pose proof (Step_upd_SubList_key HStep _ _ _ H11 H13). pose proof (Step_read HStep0 _ _ H10). specialize (DisjRegs s0); tauto. Qed. Lemma JoinTrace_len l1: forall l2 o1 o2, length l1 = length l2 -> Trace m1 o1 l1 -> Trace m2 o2 l2 -> (mapProp_len (fun l1 l2 => MatchingExecCalls_Concat l1 l2 m2) l1 l2) -> (mapProp_len (fun l1 l2 => MatchingExecCalls_Concat l2 l1 m1) l1 l2) -> (mapProp_len (fun l1 l2 => (forall x1 x2 : RegsT * (RuleOrMeth * MethsT), In x1 l1 -> In x2 l2 -> match fst (snd x1) with | Rle _ => match fst (snd x2) with | Rle _ => False | Meth _ => True end | Meth _ => True end)) l1 l2) -> Trace (ConcatMod m1 m2) (o1 ++ o2) (map (fun x => fst x ++ snd x) (List.combine l1 l2)). Proof. intros. eapply JoinTrace_basic; rewrite ?fst_combine, ?snd_combine; eauto; eapply mapProp2_len_same; eauto. Qed. Lemma JoinTrace l1: forall l2 o1 o2, length l1 = length l2 -> Trace m1 o1 l1 -> Trace m2 o2 l2 -> nthProp2 (fun l1 l2 => MatchingExecCalls_Concat l1 l2 m2 /\ MatchingExecCalls_Concat l2 l1 m1 /\ (forall x1 x2 : RegsT * (RuleOrMeth * MethsT), In x1 l1 -> In x2 l2 -> match fst (snd x1) with | Rle _ => match fst (snd x2) with | Rle _ => False | Meth _ => True end | Meth _ => True end)) l1 l2 -> Trace (ConcatMod m1 m2) (o1 ++ o2) (map (fun x => fst x ++ snd x) (List.combine l1 l2)). Proof. intros ? ? ? ?. setoid_rewrite <- mapProp_len_nthProp2; auto. repeat rewrite mapProp_len_conj; auto. pose proof (@JoinTrace_len l1 l2 o1 o2 H). intros; dest. eapply H0; eauto. Qed. End SplitJoin. Lemma InExec_dec: forall x l, {InExec x l} + {~ InExec x l}. Proof. unfold InExec; intros. apply in_dec; intros. decide equality. - apply string_dec. - apply MethT_dec. Qed. Lemma Substeps_meth_In m o l: Substeps m o l -> forall u f cs, In (u, (Meth f, cs)) l -> In (fst f) (map fst (getMethods m)). Proof. induction 1; simpl; intros; subst; try tauto. - simpl in *. destruct H0. + inv H0. + eapply IHSubsteps; eauto. - simpl in *. destruct H0. + inv H0. simpl. apply (in_map fst _ _ HInMeths). + eapply IHSubsteps; eauto. Qed. Lemma Step_meth_In m o l: Step m o l -> forall u f cs, In (u, (Meth f, cs)) l -> In (fst f) (map fst (getAllMethods m)). Proof. induction 1; simpl; intros; subst; try tauto. - eapply Substeps_meth_In; eauto. - eauto. - rewrite map_app, in_app_iff in *. clear - IHStep1 IHStep2 H1. specialize (IHStep1 u f cs); specialize (IHStep2 u f cs). tauto. Qed. Lemma Step_meth_InExec m o l: Step m o l -> forall f, InExec f l -> In (fst f) (map fst (getAllMethods m)). Proof. intros. unfold InExec in *. rewrite in_map_iff in H0. dest. destruct x; simpl in *. destruct p; simpl in *; subst. eapply Step_meth_In; eauto. Qed. Lemma Trace_meth_In m o ls: Trace m o ls -> forall u f cs i l, nth_error ls i = Some l -> In (u, (Meth f, cs)) l -> In (fst f) (map fst (getAllMethods m)). Proof. induction 1; simpl; intros; auto; destruct i; simpl in *. - subst; simpl in *; congruence. - subst; simpl in *; congruence. - subst. eapply Step_meth_In with (o := o) (u := u) (f := f) (cs := cs) in H1; eauto. inv H0; auto. - subst; simpl in *. eapply IHTrace; eauto. Qed. Lemma Trace_meth_In_map m o ls: Trace m o ls -> forall f i l, nth_error ls i = Some l -> In (Meth f) (map (fun x => fst (snd x)) l) -> In (fst f) (map fst (getAllMethods m)). Proof. intros. rewrite in_map_iff in H1; dest. destruct x. destruct p. simpl in *; subst. eapply Trace_meth_In; eauto. Qed. Lemma Trace_meth_InExec m o ls: Trace m o ls -> forall f i l, nth_error ls i = Some l -> InExec f l -> In (fst f) (map fst (getAllMethods m)). Proof. apply Trace_meth_In_map. Qed. Lemma InExec_app_iff: forall x l1 l2, InExec x (l1 ++ l2) <-> InExec x l1 \/ InExec x l2. Proof. unfold InExec in *; intros. rewrite map_app. rewrite in_app_iff. tauto. Qed. Lemma InCall_app_iff: forall x l1 l2, InCall x (l1 ++ l2) <-> InCall x l1 \/ InCall x l2. Proof. unfold InCall in *; intros. setoid_rewrite in_app_iff. firstorder fail. Qed. Lemma NotInDef_ZeroExecs_Substeps m o ls f : ~In (fst f) (map fst (getMethods m)) -> Substeps m o ls -> (getNumExecs f ls = 0%Z). Proof. induction 2. - reflexivity. - rewrite HLabel. unfold getNumExecs in *; simpl; assumption. - rewrite HLabel. unfold getNumExecs. Opaque getNumFromExecs. simpl; destruct (MethT_dec f (fn, existT _ (projT1 fb) (argV, retV))). + destruct f; inv e. apply (in_map fst) in HInMeths; simpl in *; contradiction. + rewrite getNumFromExecs_neq_cons; auto. Transparent getNumFromExecs. Qed. Lemma NotInDef_ZeroExecs_Substeps' m o ls f : ~In (fst f, projT1 (snd f)) (getKindAttr (getMethods m)) -> Substeps m o ls -> (getNumExecs f ls = 0%Z). Proof. induction 2. - reflexivity. - rewrite HLabel. unfold getNumExecs in *; simpl; assumption. - rewrite HLabel. unfold getNumExecs. Opaque getNumFromExecs. simpl; destruct (MethT_dec f (fn, existT _ (projT1 fb) (argV, retV))); subst. + apply (in_map (fun x => (fst x, projT1 (snd x)))) in HInMeths; contradiction. + rewrite getNumFromExecs_neq_cons; auto. Transparent getNumFromExecs. Qed. Lemma NotInDef_ZeroExecs_Step m o ls f: ~In (fst f) (map fst (getAllMethods m)) -> Step m o ls -> (getNumExecs f ls = 0%Z). Proof. induction 2; simpl in *; auto. - apply (NotInDef_ZeroExecs_Substeps _ H HSubsteps). - rewrite HLabels. rewrite getNumExecs_app. rewrite map_app, in_app_iff in H. assert (~In (fst f) (map fst (getAllMethods m1)) /\ ~In (fst f) (map fst (getAllMethods m2)));[tauto|]; dest. rewrite IHStep1, IHStep2; auto. Qed. Lemma NotInDef_ZeroExecs_Step' m o ls f: ~In (fst f, projT1 (snd f)) (getKindAttr (getAllMethods m)) -> Step m o ls -> (getNumExecs f ls = 0%Z). Proof. induction 2; simpl in *; auto. - apply (NotInDef_ZeroExecs_Substeps' _ H HSubsteps). - rewrite HLabels. rewrite getNumExecs_app. rewrite map_app, in_app_iff in H. rewrite IHStep1, IHStep2; auto. Qed. Lemma Trace_meth_InExec' m o ls: Trace m o ls -> forall f i l, nth_error ls i = Some l -> (0 < getNumExecs f l)%Z -> In (fst f) (map fst (getAllMethods m)). Proof. induction 1; subst; simpl; intros; auto; destruct i; simpl in *; try discriminate. - inv H0. destruct (in_dec string_dec (fst f) (map fst (getAllMethods m))); auto. specialize (NotInDef_ZeroExecs_Step _ n HStep) as noExec_zero. apply False_ind; Omega.omega. - eapply IHTrace; eauto. Qed. Lemma Step_meth_InCall_InDef_InExec m o ls: Step m o ls -> forall (f : MethT), In (fst f, projT1 (snd f)) (getKindAttr (getAllMethods m)) -> (getNumCalls f ls <= getNumExecs f ls)%Z. Proof. induction 1; eauto. - subst. simpl. rewrite map_app. setoid_rewrite getNumCalls_app. setoid_rewrite getNumExecs_app. setoid_rewrite in_app_iff. intros. unfold MatchingExecCalls_Concat in *. specialize (getNumExecs_nonneg f l1) as P1;specialize (getNumExecs_nonneg f l2) as P2. destruct H1. + specialize (IHStep1 _ H1); destruct (Z.eq_dec (getNumCalls f l2) 0%Z). * rewrite e, Z.add_0_r;Omega.omega. * specialize (HMatching2 _ n H1); dest; Omega.omega. + specialize (IHStep2 _ H1); destruct (Z.eq_dec (getNumCalls f l1) 0%Z). * rewrite e; simpl; Omega.omega. * specialize (HMatching1 _ n H1); dest; Omega.omega. Qed. Lemma Trace_meth_InCall_InDef_InExec m o ls: Trace m o ls -> forall (f : MethT) (i : nat) (l : list (RegsT * (RuleOrMeth * MethsT))), nth_error ls i = Some l -> In (fst f, projT1 (snd f)) (getKindAttr (getAllMethods m)) -> (getNumCalls f l <= getNumExecs f l)%Z. Proof. induction 1; subst; auto; simpl; intros. - destruct i; simpl in *; try congruence. - destruct i; simpl in *. + inv H0. eapply Step_meth_InCall_InDef_InExec; eauto. + eapply IHTrace; eauto. Qed. Lemma Trace_meth_InCall_not_InExec_not_InDef m o ls: Trace m o ls -> forall (f : MethT) (i : nat) (l : list (RegsT * (RuleOrMeth * MethsT))), nth_error ls i = Some l -> ~(getNumCalls f l <= getNumExecs f l)%Z -> ~ In (fst f, projT1 (snd f)) (getKindAttr (getAllMethods m)). Proof. repeat intro. eapply Trace_meth_InCall_InDef_InExec in H2; eauto. Qed. Lemma InCall_dec: forall x l, InCall x l \/ ~ InCall x l. Proof. unfold InCall; intros. induction l; simpl. - right. intro. dest; auto. - destruct IHl; dest. + left. exists x0. split; tauto. + pose proof (in_dec MethT_dec x (snd (snd a))). destruct H0. * left; exists a; tauto. * right; intro. dest. destruct H0; subst. -- auto. -- firstorder fail. Qed. Lemma InCall_dec_quant1: forall (f: string) l, {exists v: {x: Kind * Kind & SignT x}, In (f, v) l} + {forall v, ~ In (f, v) l}. Proof. unfold InCall; intros. induction l; simpl. - right; intro; intro; auto. - destruct IHl. + left. dest. exists x; tauto. + assert (sth: {exists v, a = (f, v)} + {forall v, a <> (f, v)}). { destruct a; simpl in *. destruct (string_dec f s); subst. - left. exists s0; auto. - right; intro; intro. inv H. tauto. } destruct sth. * left. dest. exists x; auto. * right. intro. specialize (n v). specialize (n0 v). tauto. Qed. Lemma InCall_dec_quant2: forall f l, (exists v, InCall (f, v) l) \/ forall v, ~ InCall (f, v) l. Proof. unfold InCall; intros. induction l; simpl. - right. intro. intro. dest; auto. - destruct IHl; dest. + left. exists x. exists x0. split; tauto. + destruct (InCall_dec_quant1 f (snd (snd a))). * left; dest. exists x. exists a. tauto. * right; intro; intro. dest. specialize (H v). specialize (n v). destruct H0; subst; auto. firstorder fail. Qed. Lemma TraceInclusion_refl: forall m, TraceInclusion m m. Proof. unfold TraceInclusion; intros. exists o1, ls1. repeat split; auto. unfold nthProp2; intros. destruct (nth_error ls1 i); auto. repeat split; intros; tauto. Qed. Lemma TraceInclusion_trans: forall m1 m2 m3, TraceInclusion m1 m2 -> TraceInclusion m2 m3 -> TraceInclusion m1 m3. Proof. unfold TraceInclusion; intros. specialize (H _ _ H1); dest. specialize (H0 _ _ H); dest. exists x1, x2. repeat split; auto. - congruence. - unfold nthProp2, WeakInclusion in *; intros. specialize (H3 i); specialize (H5 i). case_eq (nth_error ls1 i); case_eq (nth_error x0 i); case_eq (nth_error x2 i); intros; auto. + rewrite H6, H7, H8 in *. dest. split;[eauto using eq_trans|auto]. + pose proof (nth_error_len _ _ _ H7 H6 H4); contradiction. Qed. Global Instance TraceEquiv_rewrite_l: Proper (eq ==> TraceEquiv ==> iff) TraceInclusion. Proof. unfold Proper, iff, Basics.flip, Basics.impl, TraceEquiv, respectful; intros; dest; try split; intros; auto; subst; repeat (eapply TraceInclusion_trans; eauto). Qed. Global Instance TraceEquiv_rewrite_r: Proper (TraceEquiv ==> eq ==> iff) TraceInclusion. Proof. unfold Proper, iff, Basics.flip, Basics.impl, TraceEquiv, respectful; intros; dest; try split; intros; auto; subst; repeat (eapply TraceInclusion_trans; eauto). Qed. Section Test. Variable m1 m2 m3 m4: Mod. Variable H1: TraceEquiv m1 m2. Variable H2: TraceEquiv m3 m4. Goal TraceInclusion m2 m4 <-> TraceInclusion m1 m3. Proof. rewrite H1. rewrite H2. tauto. Qed. Goal TraceInclusion m1 m4 <-> TraceInclusion m2 m3. rewrite H1. rewrite H2. tauto. Qed. End Test. Lemma UpdRegs_nil_upd: forall o, NoDup (map fst o) -> forall o', UpdRegs [] o o' -> o = o'. Proof. unfold UpdRegs. intros. dest. simpl in *. assert (sth: forall s v, In (s, v) o' -> In (s, v) o). { intros. specialize (H1 s v H2). destruct H1; dest; try auto. tauto. } clear H1. generalize o' H H0 sth. clear o' H H0 sth. induction o; destruct o'; simpl; auto; intros. - discriminate. - discriminate. - inv H0. inv H. specialize (IHo _ H6 H4). destruct p, a; simpl in *; subst; auto; repeat f_equal; auto. + specialize (sth s s0 (or_introl eq_refl)). destruct sth. * inv H; subst; auto. * apply (in_map fst) in H; simpl in *; tauto. + eapply IHo; intros. specialize (sth _ _ (or_intror H)). destruct sth; [|auto]. inv H0; subst. apply (f_equal (map fst)) in H4. rewrite ?map_map in *; simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in H4; try tauto. apply (in_map fst) in H; simpl in *; congruence. Qed. Lemma Trace_NoDup m o l: Trace m o l -> NoDup (map fst (getAllRegisters m)) -> NoDup (map fst o). Proof. induction 1; subst. - intros. assert (sth: Forall2 (fun o' r => fst o' = fst r) o' (getAllRegisters m)) by (eapply Forall2_impl; eauto; intros; simpl in *; tauto). clear HUpdRegs. apply Forall2_map_eq in sth. congruence. - unfold UpdRegs in *; intros; dest. apply (f_equal (map fst)) in H1. rewrite ?map_map in *; simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in H1; try tauto. rewrite H1 in *; eapply IHTrace; eauto. Qed. Lemma Trace_sameRegs m o l: Trace m o l -> getKindAttr o = getKindAttr (getAllRegisters m). Proof. induction 1; subst; auto. - assert (sth: Forall2 (fun o' r => (fun x => (fst x, projT1 (snd x))) o' = (fun x => (fst x, projT1 (snd x))) r) o' (getAllRegisters m)). { eapply Forall2_impl; eauto; intro; simpl in *. intros; dest. f_equal; auto. } clear HUpdRegs. apply Forall2_map_eq in sth. congruence. - unfold UpdRegs in *; dest. congruence. Qed. Lemma Step_empty m: forall o, getKindAttr o = getKindAttr (getAllRegisters m) -> Step m o []. Proof. induction m; simpl; intros; auto. - constructor; auto. + constructor; auto. + unfold MatchingExecCalls_Base. intros; rewrite getNumCalls_nil, getNumExecs_nil; reflexivity. - constructor 2. + eapply IHm; eauto. + intros. unfold getListFullLabel_diff; auto. - rewrite map_app in H. pose proof (list_split _ _ _ _ _ H). dest. specialize (IHm1 _ H1). specialize (IHm2 _ H2). eapply ConcatModStep with (o1 := x) (o2 := x0) (l1 := []) (l2 := []); eauto. + unfold MatchingExecCalls_Concat; intros. rewrite getNumCalls_nil in H3; apply False_ind; apply H3; reflexivity. + unfold MatchingExecCalls_Concat; intros. rewrite getNumCalls_nil in H3; apply False_ind; apply H3; reflexivity. + intros. simpl in *; tauto. Qed. Lemma Trace_Step_empty m o l: Trace m o l -> Step m o []. Proof. intros. apply Trace_sameRegs in H. apply Step_empty in H. auto. Qed. Section StepSimulation. Variable imp spec: Mod. Variable simRel: RegsT -> RegsT -> Prop. Variable initRel: forall rimp, Forall2 regInit rimp (getAllRegisters imp) -> exists rspec, Forall2 regInit rspec (getAllRegisters spec) /\ simRel rimp rspec. Variable NoDupRegs: NoDup (map fst (getAllRegisters imp)). Variable stepSimulationNonZero: forall oImp lImp oImp', Step imp oImp lImp -> lImp <> nil -> UpdRegs (map fst lImp) oImp oImp' -> forall oSpec, simRel oImp oSpec -> exists lSpec oSpec', Step spec oSpec lSpec /\ UpdRegs (map fst lSpec) oSpec oSpec' /\ simRel oImp' oSpec' /\ WeakInclusion lImp lSpec. Lemma StepSimulation': forall (oImp : RegsT) (lsImp : list (list FullLabel)), Trace imp oImp lsImp -> exists (oSpec : RegsT) (lsSpec : list (list FullLabel)), Trace spec oSpec lsSpec /\ Datatypes.length lsImp = Datatypes.length lsSpec /\ nthProp2 WeakInclusion lsImp lsSpec /\ simRel oImp oSpec. Proof. induction 1; subst; simpl; auto; intros. - pose proof (initRel HUpdRegs) as [rspec rspecProp]. exists rspec, []; repeat split; dest; auto. + econstructor 1; eauto. + unfold nthProp2; intros. destruct (nth_error [] i); auto. repeat split; intros; tauto. - dest. destruct l. + simpl in *. exists x, ([] :: x0); repeat split; simpl in *; auto. * constructor 2 with (o := x) (ls := x0) (l := []); simpl; auto. -- eapply Trace_Step_empty; eauto. -- clear. unfold UpdRegs; split; intros; try tauto. right; split; try intro; dest; auto. * rewrite nthProp2_cons; split; simpl; auto; repeat split; dest; simpl in *; try tauto. * pose proof (Trace_NoDup H NoDupRegs) as sth. pose proof (UpdRegs_nil_upd sth HUpdRegs); subst; auto. + specialize (stepSimulationNonZero HStep ltac:(intro; discriminate) HUpdRegs H3). destruct stepSimulationNonZero as [lSpec [oSpec' [stepSpec [updSpec [sim lSpecProp]]]]]. exists oSpec', (lSpec :: x0); repeat split; simpl in *; auto. * econstructor 2; eauto. * simpl. rewrite nthProp2_cons; split; auto. Qed. Theorem StepSimulation: TraceInclusion imp spec. Proof. unfold TraceInclusion; intros. eapply StepSimulation' in H. dest. exists x, x0. repeat split; auto. Qed. End StepSimulation. Lemma NoMeths_Substeps m o ls: getMethods m = [] -> Substeps m o ls -> ls = nil \/ exists u rl cs, ls = (u, (Rle rl, cs)) :: nil. Proof. intros nilMeths substeps. induction substeps; intros; auto; subst. - destruct IHsubsteps; subst. + right. repeat eexists; eauto. + dest; subst. specialize (HNoRle _ (or_introl eq_refl)); simpl in *. tauto. - rewrite nilMeths in *. simpl in *. tauto. Qed. Section SimulationZero. Variable imp spec: BaseModule. Variable simRel: RegsT -> RegsT -> Prop. Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable NoDupRegs: NoDup (map fst (getRegisters imp)). Variable NoMeths: getMethods imp = []. Variable NoMethsSpec: getMethods spec = []. Variable simulation: forall oImp uImp rleImp csImp oImp', Substeps imp oImp [(uImp, (Rle rleImp, csImp))] -> UpdRegs [uImp] oImp oImp' -> forall oSpec, simRel oImp oSpec -> ((getKindAttr oSpec = getKindAttr (getRegisters spec) /\ simRel oImp' oSpec /\ csImp = []) \/ (exists uSpec rleSpec oSpec', Substeps spec oSpec [(uSpec, (Rle rleSpec, csImp))] /\ UpdRegs [uSpec] oSpec oSpec' /\ simRel oImp' oSpec')). Theorem simulationZero: TraceInclusion (Base imp) (Base spec). Proof. apply StepSimulation with (simRel := simRel); auto; intros. inv H. pose proof HSubsteps as sth. inv HSubsteps; simpl in *. - tauto. - pose proof (NoMeths_Substeps NoMeths HSubstep). destruct H; [subst | dest; subst]. + simpl in *. specialize (@simulation _ _ _ _ oImp' sth H1 _ H2). destruct simulation; dest; subst. * exists nil, oSpec. repeat split; auto. constructor; auto. -- constructor; auto. -- unfold MatchingExecCalls_Base; intros; reflexivity. -- intros. right; split; try intro; dest; simpl in *; try tauto. -- intros; dest. inv H4. * exists [(x, (Rle x0, cs))], x1. repeat split; auto. -- constructor; auto. unfold MatchingExecCalls_Base; intros. rewrite NoMethsSpec in *; simpl in *; tauto. -- unfold UpdRegs in *; dest. auto. -- intros. unfold UpdRegs in *; dest. simpl in *. eapply H6; eauto. -- intros; dest. destruct H5;simpl in *; inv H5. exists rn; left; reflexivity. + specialize (HNoRle _ (or_introl eq_refl)); simpl in *; tauto. - rewrite NoMeths in *. simpl in *; tauto. Qed. End SimulationZero. Lemma createHide_hides: forall hides m, getHidden (createHide m hides) = hides. Proof. induction hides; simpl; auto; intros; f_equal; auto. Qed. Lemma createHide_Regs: forall m l, getAllRegisters (createHide m l) = getRegisters m. Proof. intros. induction l; simpl; auto; intros. Qed. Lemma createHide_Rules: forall m l, getAllRules (createHide m l) = getRules m. Proof. intros. induction l; simpl; auto; intros. Qed. Lemma createHide_Meths: forall m l, getAllMethods (createHide m l) = getMethods m. Proof. intros. induction l; simpl; auto; intros. Qed. Lemma createHideMod_Meths: forall m l, getAllMethods (createHideMod m l) = getAllMethods m. Proof. intros. induction l; simpl; auto; intros. Qed. Lemma getFlat_Hide m s: getFlat (HideMeth m s) = getFlat m. Proof. unfold getFlat; auto. Qed. Lemma getAllRegisters_flatten: forall m, getAllRegisters (flatten m) = getAllRegisters m. Proof. unfold flatten, getFlat; intros. rewrite createHide_Regs. auto. Qed. Lemma WfMod_Hidden ty m: WfMod ty m -> forall s, In s (getHidden m) -> In s (map fst (getAllMethods m)). Proof. induction 1; simpl; auto; intros. - tauto. - destruct H0; subst; auto. - rewrite map_app, in_app_iff in *. specialize (IHWfMod1 s); specialize (IHWfMod2 s); tauto. Qed. Lemma SemActionUpdSub o k a reads upds calls ret: @SemAction o k a reads upds calls ret -> SubList (getKindAttr upds) (getKindAttr o). Proof. induction 1; auto; subst; unfold SubList in *; intros; rewrite ?in_app_iff in *. - rewrite map_app, in_app_iff in *. destruct H1; firstorder fail. - subst; firstorder; simpl in *. subst. assumption. - subst. rewrite map_app, in_app_iff in *. destruct H1; intuition. - subst. rewrite map_app, in_app_iff in *. destruct H1; intuition. - subst; simpl in *; intuition. Qed. Lemma SemActionExpandRegs o k a reads upds calls ret: @SemAction o k a reads upds calls ret -> forall o', SubList reads o' -> SubList (getKindAttr upds) (getKindAttr o') -> @SemAction o' k a reads upds calls ret. Proof. intros. induction H; try solve [econstructor; auto]. - subst. specialize (IHSemAction H0). econstructor; eauto. - subst. apply SubList_app_l in H0; dest. rewrite map_app in *. apply SubList_app_l in H1; dest. specialize (IHSemAction1 H0 H1). specialize (IHSemAction2 H3 H4). econstructor; eauto. - subst. apply SubList_cons in H0; dest. specialize (IHSemAction H2 H1). econstructor; eauto. - subst. simpl in *. apply SubList_cons in H1; dest. specialize (IHSemAction H0 H2). econstructor; eauto. - subst. apply SubList_app_l in H0; dest. rewrite map_app in *. apply SubList_app_l in H1; dest. specialize (IHSemAction1 H0 H1). specialize (IHSemAction2 H3 H4). econstructor; eauto. - subst. apply SubList_app_l in H0; dest. rewrite map_app in *. apply SubList_app_l in H1; dest. specialize (IHSemAction1 H0 H1). specialize (IHSemAction2 H3 H4). econstructor 8; eauto. Qed. Lemma Substeps_combine m1 o1 l1: Substeps m1 o1 l1 -> forall m2 o2 l2 (DisjRegs: DisjKey (getRegisters m1) (getRegisters m2)) (DisjMeths: DisjKey (getMethods m1) (getMethods m2)) (HOneRle: forall x1 x2, In x1 l1 -> In x2 l2 -> match fst (snd x1), fst (snd x2) with | Rle _, Rle _ => False | _, _ => True end), Substeps m2 o2 l2 -> Substeps (BaseMod (getRegisters m1 ++ getRegisters m2) (getRules m1 ++ getRules m2) (getMethods m1 ++ getMethods m2)) (o1 ++ o2) (l1 ++ l2). Proof. induction 1; intros. - induction H; simpl in *. + constructor 1; auto; simpl. rewrite ?map_app; congruence. + econstructor 2; eauto; simpl; rewrite ?map_app; try congruence. * rewrite in_app_iff; right; eassumption. * pose proof (SemActionReadsSub HAction). pose proof (SemActionUpdSub HAction). eapply SemActionExpandRegs; eauto; unfold SubList in *; intros; rewrite ?map_app, ?in_app_iff; right. -- eapply H0; eauto. -- eapply H1; eauto. * unfold SubList in *; intros. rewrite in_app_iff; right; eapply HReadsGood; eauto. * unfold SubList in *; intros. rewrite in_app_iff; right; eapply HUpdGood; eauto. * eapply IHSubsteps; intros; unfold InCall in *; simpl in *; dest; tauto. + econstructor 3; eauto; simpl; rewrite ?map_app; try congruence. * rewrite in_app_iff; right; eassumption. * pose proof (SemActionReadsSub HAction). pose proof (SemActionUpdSub HAction). eapply SemActionExpandRegs; eauto; unfold SubList in *; intros; rewrite ?map_app, ?in_app_iff; right. -- eapply H0; eauto. -- eapply H1; eauto. * unfold SubList in *; intros. rewrite in_app_iff; right; eapply HReadsGood; eauto. * unfold SubList in *; intros. rewrite in_app_iff; right; eapply HUpdGood; eauto. * eapply IHSubsteps; intros; unfold InCall in *; simpl in *; dest; tauto. - subst; simpl. assert (sth_else: forall x1 x2, In x1 ls -> In x2 l2 -> match fst (snd x1), fst (snd x2) with | Rle _, Rle _ => False | _, _ => True end) by (clear - HOneRle; firstorder fail). econstructor 2; eauto; simpl; rewrite ?map_app; try congruence. + inv H0; congruence. + rewrite in_app_iff; left; eassumption. + pose proof (SemActionReadsSub HAction). pose proof (SemActionUpdSub HAction). eapply SemActionExpandRegs; eauto; unfold SubList in *; intros; rewrite ?map_app, ?in_app_iff; left. * eapply H1; eauto. * eapply H2; eauto. + unfold SubList in *; intros. rewrite in_app_iff; left; eapply HReadsGood; eauto. + unfold SubList in *; intros. rewrite in_app_iff; left; eapply HUpdGood; eauto. + intros. rewrite in_app_iff in *. destruct H1; [eapply HDisjRegs; eauto| ]. rewrite DisjKeyWeak_same by apply string_dec; intro; intros. rewrite in_map_iff in H2; dest; subst. pose proof (Substeps_upd_In H0 _ (in_map fst _ _ H1) _ (in_map fst _ _ H4)). apply (SubList_map fst) in HUpdGood. rewrite ?map_map in *; simpl in *. rewrite ?(functional_extensionality (fun x => fst x) fst) in HUpdGood by tauto. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HUpdGood; [|tauto]. specialize (HUpdGood _ H3). clear - H2 DisjRegs HUpdGood; firstorder fail. + intros. rewrite in_app_iff in *. destruct H1; [eapply HNoRle; eauto| ]. unfold SubList in *. specialize (HOneRle _ x (or_introl eq_refl) H1); simpl in *; assumption. - subst; simpl. assert (sth_else: forall x1 x2, In x1 ls -> In x2 l2 -> match fst (snd x1), fst (snd x2) with | Rle _, Rle _ => False | _, _ => True end) by (clear - HOneRle; firstorder fail). econstructor 3; eauto; simpl; rewrite ?map_app; try congruence. + inv H0; congruence. + rewrite in_app_iff; left; eassumption. + pose proof (SemActionReadsSub HAction). pose proof (SemActionUpdSub HAction). eapply SemActionExpandRegs; eauto; unfold SubList in *; intros; rewrite ?map_app, ?in_app_iff; left. * eapply H1; eauto. * eapply H2; eauto. + unfold SubList in *; intros. rewrite in_app_iff; left; eapply HReadsGood; eauto. + unfold SubList in *; intros. rewrite in_app_iff; left; eapply HUpdGood; eauto. + intros. rewrite in_app_iff in *. destruct H1; [eapply HDisjRegs; eauto| ]. rewrite DisjKeyWeak_same by apply string_dec; intro; intros. rewrite in_map_iff in H2; dest; subst. pose proof (Substeps_upd_In H0 _ (in_map fst _ _ H1) _ (in_map fst _ _ H4)). apply (SubList_map fst) in HUpdGood. rewrite ?map_map in *; simpl in *. rewrite ?(functional_extensionality (fun x => fst x) fst) in HUpdGood by tauto. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in HUpdGood; [|tauto]. specialize (HUpdGood _ H3). clear - H2 DisjRegs HUpdGood; firstorder fail. Qed. Lemma Substeps_flatten m o l: Substeps (BaseMod (getRegisters m) (getRules m) (getMethods m)) o l -> Substeps m o l. Proof. induction 1; simpl; auto. - constructor 1; auto. - econstructor 2; eauto. - econstructor 3; eauto. Qed. Lemma flatten_Substeps m o l: Substeps m o l -> Substeps (BaseMod (getRegisters m) (getRules m) (getMethods m)) o l. induction 1; simpl; auto. - constructor 1; auto. - econstructor 2; eauto. - econstructor 3; eauto. Qed. Lemma Step_substitute' ty m o l: Step m o l -> forall (HWfMod: WfMod ty m), StepSubstitute m o l. Proof. unfold StepSubstitute. induction 1; auto; simpl; intros; dest; unfold MatchingExecCalls_Base in *; simpl in *. - repeat split. clear HMatching. induction HSubsteps. + econstructor 1; eauto. + econstructor 2; eauto. + econstructor 3; eauto. + simpl; tauto. + intros; tauto. - inv HWfMod. specialize (IHStep HWf); dest. repeat split; auto. intros; destruct H4. + subst. apply HHidden; auto. + apply H2; auto. - inv HWfMod. specialize (IHStep1 HWf1). specialize (IHStep2 HWf2). dest. subst; repeat split; auto. + pose proof (Substeps_combine H4 HDisjRegs HDisjMeths HNoRle H1 (m2 := BaseMod (getAllRegisters m2) _ _)). simpl in *. assumption. + intros. rewrite getNumCalls_app, getNumExecs_app. rewrite map_app, in_app_iff in H7. destruct H7. * destruct (Z.eq_dec (getNumCalls f l2) 0%Z). -- rewrite e. specialize (H5 _ H7). specialize (getNumExecs_nonneg f l2); intros. Omega.omega. -- destruct (HMatching2 f n H7). assert (getNumExecs f l2 = 0%Z) as P1. { destruct (HDisjMeths (fst f)). - apply (in_map fst) in H7; simpl in *; rewrite fst_getKindAttr in H7; contradiction. - eapply NotInDef_ZeroExecs_Substeps; eauto; simpl; assumption. } Omega.omega. * destruct (Z.eq_dec (getNumCalls f l1) 0%Z). -- rewrite e. specialize (H2 _ H7). specialize (getNumExecs_nonneg f l1); intros. Omega.omega. -- destruct (HMatching1 f n H7). assert (getNumExecs f l1 = 0%Z) as P1. { destruct (HDisjMeths (fst f)). - eapply NotInDef_ZeroExecs_Substeps; eauto; simpl; assumption. - apply (in_map fst) in H7; simpl in *; rewrite fst_getKindAttr in H7; contradiction. } Omega.omega. + intros s v. rewrite map_app;repeat rewrite in_app_iff. unfold getListFullLabel_diff in *. rewrite getNumExecs_app, getNumCalls_app. intros. destruct H7, H8, (HDisjMeths s); try (apply (in_map fst) in H7; rewrite fst_getKindAttr in H7; contradiction). * assert (getNumExecs (s, v) l2 = 0%Z) as P1. { eapply NotInDef_ZeroExecs_Substeps; eauto; simpl; assumption. } destruct (Z.eq_dec (getNumCalls (s, v) l2) 0%Z). { specialize (H6 _ v H7 H8); Omega.omega. } destruct (HMatching2 _ n H7); contradiction. * pose proof (WfMod_Hidden HWf2 _ H8); contradiction. * pose proof (WfMod_Hidden HWf1 _ H8); contradiction. * assert (getNumExecs (s, v) l1 = 0%Z) as P1. { eapply NotInDef_ZeroExecs_Substeps; eauto; simpl; assumption. } destruct (Z.eq_dec (getNumCalls (s, v) l1) 0%Z); [specialize (H3 _ v H7 H8);Omega.omega|]. destruct (HMatching1 _ n H7); contradiction. Qed. Lemma StepSubstitute_flatten m o l: Step (flatten m) o l <-> StepSubstitute m o l. Proof. unfold flatten, getFlat, StepSubstitute. split; intros. - induction (getHidden m). + simpl in *. inv H. split; [auto| split; [auto| intros; tauto]]. + simpl in *. inv H. specialize (IHl0 HStep); dest. split; [auto| split; [auto| intros]]. rewrite createHide_Meths in *; simpl in *. destruct H3; [subst |clear - H1 H2 H3; apply H1; auto]. eapply HHidden; eauto. - induction (getHidden m); simpl; auto; dest. + constructor; auto. + assert (sth: Step (createHide (BaseMod (getAllRegisters m) (getAllRules m) (getAllMethods m)) l0) o l). { eapply IHl0; repeat split; auto. intros; apply H1; auto; right; assumption. } assert (sth2: forall v, In (a, projT1 v) (getKindAttr (getAllMethods m)) -> (getListFullLabel_diff (a, v) l = 0%Z)). { intros; apply H1; auto; left; reflexivity. } constructor; auto. rewrite createHide_Meths; auto. Qed. Lemma Step_substitute ty m o l (HWfMod: WfMod ty m): Step m o l -> Step (flatten m) o l. Proof. intros Stp. apply (@Step_substitute' ty) in Stp; auto. rewrite (@StepSubstitute_flatten) in *; auto. Qed. Lemma splitRegs o m1 m2 (DisjRegisters: DisjKey (getRegisters m1) (getRegisters m2)): getKindAttr o = getKindAttr (getRegisters m1 ++ getRegisters m2) -> getKindAttr (filter (fun x : string * {x : FullKind & fullType type x} => getBool (in_dec string_dec (fst x) (map fst (getRegisters m1)))) o) = getKindAttr (getRegisters m1). Proof. intros HRegs. rewrite map_app in *. pose proof (filter_map_simple (fun x: string * {x: FullKind & fullType type x} => (fst x, projT1 (snd x))) (fun x => getBool (in_dec string_dec (fst x) (map fst (getRegisters m1)))) o) as sth. simpl in sth. setoid_rewrite <- sth. setoid_rewrite HRegs. rewrite filter_app. setoid_rewrite filter_false_list at 2. - rewrite filter_true_list at 1. + rewrite app_nil_r; auto. + intros. apply (in_map fst) in H. rewrite map_map in H. simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in H; try tauto. destruct (in_dec string_dec (fst a) (map fst (getRegisters m1))); auto. - intros. apply (in_map fst) in H. rewrite map_map in H. simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in H; try tauto. destruct (in_dec string_dec (fst a) (map fst (getRegisters m1))); auto. specialize (DisjRegisters (fst a)). tauto. Qed. Definition strcmp (s1 s2 : string) : bool := if (string_dec s1 s2) then true else false. Definition BaseModuleFilter (m : BaseModule)(fl : FullLabel) : bool := match getRleOrMeth fl with | Rle rn => existsb (strcmp rn) (map fst (getRules m)) | Meth f => existsb (strcmp (fst f)) (map fst (getMethods m)) end. Definition ModuleFilterLabels (m : BaseModule)(l : list FullLabel) : list FullLabel := filter (BaseModuleFilter m) l. Lemma InRules_Filter : forall (u : RegsT)(rn : string)(rb : Action Void)(l : list FullLabel)(cs : MethsT)(m1 : BaseModule), In (rn, rb) (getRules m1) -> ModuleFilterLabels m1 ((u, (Rle rn, cs))::l) = ((u, (Rle rn, cs))::ModuleFilterLabels m1 l). Proof. intros. unfold ModuleFilterLabels, BaseModuleFilter. simpl. generalize (existsb_exists (strcmp rn) (map fst (getRules m1))). destruct (existsb (strcmp rn) (map fst (getRules m1))); intro;[reflexivity | destruct H0; clear H0]. assert (false=true);[apply H1; exists rn; split| discriminate]. - apply in_map_iff; exists (rn, rb); auto. - unfold strcmp;destruct (string_dec rn rn);[reflexivity|contradiction]. Qed. Lemma NotInRules_Filter : forall (u : RegsT)(rn : string)(l : list FullLabel)(cs : MethsT)(m1 : BaseModule), ~In rn (map fst (getRules m1)) -> ModuleFilterLabels m1 ((u, (Rle rn, cs))::l) = ModuleFilterLabels m1 l. Proof. intros. unfold ModuleFilterLabels, BaseModuleFilter. simpl. generalize (existsb_exists (strcmp rn) (map fst (getRules m1))). destruct (existsb (strcmp rn) (map fst (getRules m1))); intro H0; destruct H0;[|reflexivity]. apply False_ind; apply H. assert (true=true) as TMP;[reflexivity|specialize (H0 TMP); dest]. unfold strcmp in H2; destruct (string_dec rn x); subst;[assumption|discriminate]. Qed. Lemma InMethods_Filter : forall (u : RegsT)(fn : string)(fb : {x : Signature & MethodT x}) (argV : type (fst (projT1 fb)))(retV : type (snd (projT1 fb))) (l : list FullLabel)(cs : MethsT)(m1 : BaseModule), In (fn, fb) (getMethods m1) -> ModuleFilterLabels m1 ((u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs))::l) = ((u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs)):: ModuleFilterLabels m1 l). Proof. intros. unfold ModuleFilterLabels, BaseModuleFilter. simpl. generalize (existsb_exists (strcmp fn) (map fst (getMethods m1))). destruct (existsb (strcmp fn) (map fst (getMethods m1))); intro;[reflexivity | destruct H0; clear H0]. assert (false=true);[apply H1; exists fn; split| discriminate]. - apply in_map_iff; exists (fn, fb); auto. - unfold strcmp;destruct (string_dec fn fn);[reflexivity|contradiction]. Qed. Lemma NotInMethods_Filter : forall (u : RegsT)(fn : string)(fb : {x : Signature & MethodT x}) (argV : type (fst (projT1 fb)))(retV : type (snd (projT1 fb))) (l : list FullLabel)(cs : MethsT)(m1 : BaseModule), ~In fn (map fst (getMethods m1)) -> ModuleFilterLabels m1 ((u, (Meth (fn, existT SignT (projT1 fb) (argV, retV)), cs))::l) = ModuleFilterLabels m1 l. Proof. intros. unfold ModuleFilterLabels, BaseModuleFilter. simpl. generalize (existsb_exists (strcmp fn) (map fst (getMethods m1))). destruct (existsb (strcmp fn) (map fst (getMethods m1))); intro H0; destruct H0;[|reflexivity]. apply False_ind; apply H. assert (true=true) as TMP;[reflexivity|specialize (H0 TMP); dest]. unfold strcmp in H2; destruct (string_dec fn x); subst;[assumption|discriminate]. Qed. Lemma InCall_split_InCall f l m1 : InCall f (ModuleFilterLabels m1 l) -> InCall f l. Proof. unfold InCall, ModuleFilterLabels. intros; dest. generalize (filter_In (BaseModuleFilter m1) x l) as TMP; intro; destruct TMP as [L R];clear R; apply L in H; destruct H. exists x; split; assumption. Qed. Lemma InExec_split_InExec f l m1 : InExec f (ModuleFilterLabels m1 l) -> InExec f l. Proof. unfold InExec, ModuleFilterLabels. intros. apply in_map_iff; apply in_map_iff in H;dest. exists x; split;[assumption|]. generalize (filter_In (BaseModuleFilter m1) x l) as TMP; intro; destruct TMP as [L R]; clear R; apply L in H0; destruct H0. assumption. Qed. Lemma InCall_perm l l' f : InCall f l -> Permutation l l' -> InCall f l'. induction 2. assumption. - apply (InCall_app_iff f (x::nil) l'). apply (InCall_app_iff f (x::nil) l) in H. destruct H;[left|right; apply IHPermutation];assumption. - apply (InCall_app_iff f (x::y::nil) l). apply (InCall_app_iff f (y::x::nil) l) in H. destruct H;[left;apply (InCall_app_iff f (x::nil) (y::nil)) | right];[apply (InCall_app_iff f (y::nil) (x::nil)) in H; destruct H;[right|left]|];assumption. - apply (IHPermutation2 (IHPermutation1 H)). Qed. Lemma InExec_perm l l' f : InExec f l -> Permutation l l' -> InExec f l'. induction 2. assumption. - apply (InExec_app_iff f (x::nil) l'). apply (InExec_app_iff f (x::nil) l) in H. destruct H;[left|right; apply IHPermutation];assumption. - apply (InExec_app_iff f (x::y::nil) l). apply (InExec_app_iff f (y::x::nil) l) in H. destruct H;[left;apply (InExec_app_iff f (x::nil) (y::nil)) | right];[apply (InExec_app_iff f (y::nil) (x::nil)) in H; destruct H;[right|left]|];assumption. - apply (IHPermutation2 (IHPermutation1 H)). Qed. Lemma MatchingExecCalls_Base_perm_rewrite l1 l2 m1 : l1 [=] l2 -> MatchingExecCalls_Base l1 m1 -> MatchingExecCalls_Base l2 m1. Proof. intros HPerm HMec1 f HInDef. specialize (HMec1 f HInDef). repeat rewrite <-HPerm. assumption. Qed. Global Instance MatchingExecCalls_Base_perm_rewrite' : Proper (@Permutation FullLabel ==> eq ==> iff) (@MatchingExecCalls_Base) | 10. Proof. repeat red; split; intros; subst; eauto using MatchingExecCalls_Base_perm_rewrite, Permutation_sym. Qed. Lemma MatchingExecCalls_Concat_perm1 l1 l2 l3 m1 : l1 [=] l2 -> MatchingExecCalls_Concat l1 l3 m1 -> MatchingExecCalls_Concat l2 l3 m1. Proof. unfold MatchingExecCalls_Concat. intros. rewrite <-H. apply H0; auto. rewrite H; assumption. Qed. Lemma MatchingExecCalls_Concat_perm2 l1 l2 l3 m1 : l1 [=] l2 -> MatchingExecCalls_Concat l3 l1 m1 -> MatchingExecCalls_Concat l3 l2 m1. Proof. unfold MatchingExecCalls_Concat. intros. rewrite <- H. apply H0; auto. Qed. Corollary MatchingExecCalls_Concat_rewrite l1 l2 l3 l4 m : l1 [=] l2 -> l3 [=] l4 -> MatchingExecCalls_Concat l1 l3 m -> MatchingExecCalls_Concat l2 l4 m. Proof. eauto using MatchingExecCalls_Concat_perm1, MatchingExecCalls_Concat_perm2. Qed. Global Instance MatchingExecCalls_Concat_rewrite' : Proper (@Permutation FullLabel ==> @Permutation FullLabel ==> eq ==> iff) (@MatchingExecCalls_Concat) | 10. Proof. repeat red; intros; split; intro; subst; eauto using MatchingExecCalls_Concat_rewrite, Permutation_sym. Qed. Lemma InExec_ModuleFilterLabels : forall (f : MethT)(m : BaseModule)(l : list FullLabel), In (fst f) (map fst (getMethods m)) -> (getNumExecs f l = getNumExecs f (ModuleFilterLabels m l)). Proof. Opaque getNumFromExecs. intros. assert (existsb (strcmp (fst f)) (map fst (getMethods m)) = true);[apply (existsb_exists (strcmp (fst f))(map fst (getMethods m)));exists (fst f);split; [assumption|unfold strcmp; destruct (string_dec(fst f)(fst f));[reflexivity|contradiction]]|]. induction l; auto. - destruct a, p, r0. + unfold ModuleFilterLabels, BaseModuleFilter, getNumExecs in *; simpl. destruct (existsb (strcmp rn) (map fst (getRules m))); simpl; rewrite getNumFromExecs_Rle_cons; assumption. + unfold ModuleFilterLabels, BaseModuleFilter, getNumExecs in *; simpl. destruct (MethT_dec f f0); subst; [rewrite H0; simpl; repeat rewrite getNumFromExecs_eq_cons; auto; rewrite IHl; reflexivity|]. destruct (existsb (strcmp (fst f0)) (map fst (getMethods m))); simpl; repeat rewrite getNumFromExecs_neq_cons; auto. Transparent getNumFromExecs. Qed. Lemma getNumExecs_le_length (f : MethT) (l : list FullLabel) : (getNumExecs f l <= Zlength l)%Z. Proof. Opaque getNumFromExecs. induction l. - reflexivity. - destruct a, p, r0; unfold getNumExecs in *;simpl. + rewrite getNumFromExecs_Rle_cons, Zlength_cons; Omega.omega. + destruct (MethT_dec f f0); simpl in *;[rewrite getNumFromExecs_eq_cons|rewrite getNumFromExecs_neq_cons];auto; rewrite Zlength_cons; Omega.omega. Transparent getNumFromExecs. Qed. Lemma getNumFromCalls_le_length (f : MethT) (l : MethsT): (getNumFromCalls f l <= Zlength l)%Z. Proof. induction l. - reflexivity. - destruct (MethT_dec f a);[rewrite getNumFromCalls_eq_cons|rewrite getNumFromCalls_neq_cons]; auto; rewrite Zlength_cons; Omega.omega. Qed. Lemma filter_reduces_calls (f : MethT) (g : FullLabel -> bool) (l : list FullLabel) : (getNumCalls f (filter g l) <= getNumCalls f l)%Z. Proof. induction l; simpl. - reflexivity. - specialize (getNumFromCalls_nonneg f (snd (snd a))) as P1. destruct (g a); repeat rewrite getNumCalls_cons; Omega.omega. Qed. Lemma filter_reduces_execs (f : MethT) (g : FullLabel -> bool) (l : list FullLabel) : (getNumExecs f (filter g l) <= getNumExecs f l)%Z. Proof. Opaque getNumFromExecs. induction l; simpl. - reflexivity. - destruct (g a), a, p, r0; unfold getNumExecs in *; simpl in *. + repeat rewrite getNumFromExecs_Rle_cons; assumption. + destruct (MethT_dec f f0);[repeat rewrite getNumFromExecs_eq_cons|repeat rewrite getNumFromExecs_neq_cons];auto;Omega.omega. + rewrite getNumFromExecs_Rle_cons; assumption. + destruct (MethT_dec f f0);[rewrite getNumFromExecs_eq_cons|rewrite getNumFromExecs_neq_cons];auto;Omega.omega. Transparent getNumFromExecs. Qed. Lemma MatchingExecCalls_Split (l : list FullLabel) (m1 m2 : BaseModule) : MatchingExecCalls_Base l (concatFlat m1 m2) -> MatchingExecCalls_Base (ModuleFilterLabels m1 l) m1. Proof. intros Mec1 f HDef. specialize (Mec1 f); simpl in *. rewrite map_app, in_app_iff in *. specialize (Mec1 (or_introl _ HDef)). unfold ModuleFilterLabels. specialize (filter_reduces_calls f (BaseModuleFilter m1) l) as P1. fold ((ModuleFilterLabels m1) l). rewrite <-InExec_ModuleFilterLabels; eauto using Z.le_trans. apply (in_map fst) in HDef; rewrite fst_getKindAttr in HDef; assumption. Qed. Lemma MatchingExecCalls_Split2 (l : list FullLabel) (m1 m2 : BaseModule) : MatchingExecCalls_Base l (concatFlat m1 m2) -> MatchingExecCalls_Base (ModuleFilterLabels m2 l) m2. Proof. intros Mec1 f HDef. specialize (Mec1 f); simpl in *. rewrite map_app, in_app_iff in *. specialize (Mec1 (or_intror _ HDef)). unfold ModuleFilterLabels. specialize (filter_reduces_calls f (BaseModuleFilter m2) l) as P1. fold ((ModuleFilterLabels m2) l). rewrite <-InExec_ModuleFilterLabels; eauto using Z.le_trans. apply (in_map fst) in HDef; rewrite fst_getKindAttr in HDef; assumption. Qed. Lemma MatchingExecCalls_Concat_comm : forall (l l' : list FullLabel) (m1 m2 : BaseModule), MatchingExecCalls_Concat l l' (Base (concatFlat m1 m2)) -> MatchingExecCalls_Concat l l' (Base (concatFlat m2 m1)). Proof. repeat intro. specialize (H f H0). simpl in *. apply H. rewrite (map_app) in *; apply in_app_iff; apply in_app_iff in H1. tauto. Qed. Lemma MatchingExecCalls_Base_comm : forall (l : list FullLabel) (m1 m2 : BaseModule), MatchingExecCalls_Base l (concatFlat m1 m2) -> MatchingExecCalls_Base l (concatFlat m2 m1). Proof. repeat intro. specialize (H f). simpl in *; apply H; auto. rewrite map_app, in_app_iff in *; tauto. Qed. Lemma WfActionT_ReadsWellDefined : forall (k : Kind)(a : ActionT type k)(retl : type k) (m1 : BaseModule)(o readRegs newRegs : RegsT)(calls : MethsT), WfActionT (getRegisters m1) a -> SemAction o a readRegs newRegs calls retl -> SubList (getKindAttr readRegs) (getKindAttr (getRegisters m1)). Proof. induction 2; intros; subst; inversion H; EqDep_subst; auto. - rewrite map_app. repeat intro. apply in_app_iff in H0; destruct H0. + apply (IHSemAction1 H3 _ H0). + apply (IHSemAction2 (H5 v) _ H0). - inversion H; EqDep_subst. repeat intro. destruct H1;[subst;assumption|apply IHSemAction; auto]. - rewrite map_app; repeat intro. apply in_app_iff in H0; destruct H0. + apply (IHSemAction1 H7 _ H0). + apply (IHSemAction2 (H4 r1) _ H0). - inversion H; EqDep_subst. rewrite map_app; repeat intro. apply in_app_iff in H0; destruct H0. + apply (IHSemAction1 H8 _ H0). + apply (IHSemAction2 (H4 r1) _ H0). - repeat intro; auto. contradiction. Qed. Lemma WfActionT_WritesWellDefined : forall (k : Kind)(a : ActionT type k)(retl : type k) (m1 : BaseModule)(o readRegs newRegs : RegsT)(calls : MethsT), WfActionT (getRegisters m1) a -> SemAction o a readRegs newRegs calls retl -> SubList (getKindAttr newRegs) (getKindAttr (getRegisters m1)). Proof. induction 2; intros; subst; inversion H; EqDep_subst; auto. - rewrite map_app. repeat intro. apply in_app_iff in H0; destruct H0. + apply (IHSemAction1 H3 _ H0). + apply (IHSemAction2 (H5 v) _ H0). - inversion H; EqDep_subst. repeat intro. destruct H1;[subst;assumption|apply IHSemAction; auto]. - rewrite map_app; repeat intro. apply in_app_iff in H0; destruct H0. + apply (IHSemAction1 H7 _ H0). + apply (IHSemAction2 (H4 r1) _ H0). - inversion H; EqDep_subst. rewrite map_app; repeat intro. apply in_app_iff in H0; destruct H0. + apply (IHSemAction1 H8 _ H0). + apply (IHSemAction2 (H4 r1) _ H0). - repeat intro; auto. contradiction. Qed. Lemma KeyMatching : forall (l : RegsT) (a b : string * {x : FullKind & fullType type x}), NoDup (map fst l) -> In a l -> In b l -> fst a = fst b -> a = b. Proof. induction l; intros. - inversion H0. - destruct H0; destruct H1. + symmetry; rewrite <- H1; assumption. + rewrite (map_cons fst) in H. inversion H; subst. apply (in_map fst l b) in H1. apply False_ind. apply H5. destruct a0; destruct b; simpl in *. rewrite H2; assumption. + rewrite (map_cons fst) in H. inversion H; subst. apply (in_map fst l a0) in H0. apply False_ind; apply H5. destruct a0, b; simpl in *. rewrite <- H2; assumption. + inversion H; subst. apply IHl; auto. Qed. Lemma KeyRefinement : forall (l l' : RegsT) (a : string * {x: FullKind & fullType type x}), NoDup (map fst l) -> SubList l' l -> In a l -> In (fst a) (map fst l') -> In a l'. Proof. induction l'; intros; inversion H2; subst. - assert (In a (a::l')) as TMP;[left; reflexivity|specialize (H0 _ TMP); rewrite (KeyMatching _ _ _ H H0 H1 H3); left; reflexivity]. - right; apply IHl'; auto. repeat intro. apply (H0 x (or_intror _ H4)). Qed. Lemma GKA_fst : forall (A B : Type)(P : B -> Type)(o : list (A * {x : B & P x})), (map fst o) = (map fst (getKindAttr o)). Proof. induction o; simpl. - reflexivity. - rewrite IHo. reflexivity. Qed. Lemma NoDupKey_Expand : forall (A B : Type)(l1 l2 : list (A * B)), NoDup (map fst l1) -> NoDup (map fst l2) -> DisjKey l1 l2 -> NoDup (map fst (l1++l2)). Proof. intros; rewrite (map_app fst). induction l1; auto. inversion_clear H. destruct (H1 (fst a)). - apply False_ind. apply H; left; reflexivity. - assert (~(In (fst a) ((map fst l1)++(map fst l2)))). + intro in_app12; apply in_app_iff in in_app12; destruct in_app12;[apply H2|apply H]; assumption. + assert (DisjKey l1 l2); repeat intro. * destruct (H1 k);[left|right];intro; apply H5;simpl;auto. * apply (NoDup_cons (fst a) (l:=(map fst l1 ++ map fst l2)) H4 (IHl1 H3 H5)). Qed. Lemma WfActionT_SemAction : forall (k : Kind)(a : ActionT type k)(retl : type k) (m1 : BaseModule)(o readRegs newRegs : RegsT)(calls : MethsT), WfActionT (getRegisters m1) a -> NoDup (map fst o) -> SemAction o a readRegs newRegs calls retl -> (forall (o1 : RegsT), SubList o1 o -> getKindAttr o1 = getKindAttr (getRegisters m1) -> SemAction o1 a readRegs newRegs calls retl). induction 3; intro; subst; inversion H; EqDep_subst. - intros TMP1 TMP2; specialize (IHSemAction (H4 mret) o1 TMP1 TMP2). econstructor 1; eauto. - intros TMP1 TMP2; specialize (IHSemAction (H4 (evalExpr e)) o1 TMP1 TMP2). econstructor 2; eauto. - intros TMP1 TMP2; specialize (IHSemAction1 (H4) o1 TMP1 TMP2); specialize (IHSemAction2 (H6 v) o1 TMP1 TMP2). econstructor 3; eauto. - intros TMP1 TMP2; specialize (IHSemAction (H4 valueV) o1 TMP1 TMP2). econstructor 4; eauto. - intros TMP1 TMP2; specialize (IHSemAction (H5 regV) o1 TMP1 TMP2). econstructor 5; eauto. apply (KeyRefinement (r, existT (fullType type) regT regV) H0 TMP1 HRegVal). change (fun x => RegInitValT x) with RegInitValT in H7. rewrite <- TMP2 in H7; apply (in_map fst) in H7; specialize (GKA_fst (A:=string)(fullType type) o1); intro. simpl in *. setoid_rewrite H2; assumption. - intros TMP1 TMP2; specialize (IHSemAction H5 o1 TMP1 TMP2). econstructor 6; eauto. rewrite TMP2; assumption. - intros TMP1 TMP2; specialize (IHSemAction1 H8 o1 TMP1 TMP2); specialize (IHSemAction2 (H5 r1) o1 TMP1 TMP2). econstructor 7; eauto. - intros TMP1 TMP2; specialize (IHSemAction1 H9 o1 TMP1 TMP2); specialize (IHSemAction2 (H5 r1) o1 TMP1 TMP2). econstructor 8; eauto. - intros TMP1 TMP2; specialize (IHSemAction H4 o1 TMP1 TMP2). econstructor 9; eauto. - intros; econstructor 10; eauto. Qed. Lemma app_sublist_l : forall {A : Type} (l1 l2 l : list A), l = l1++l2 -> SubList l1 l. Proof. repeat intro. rewrite H. apply (in_app_iff l1 l2 x); left; assumption. Qed. Lemma app_sublist_r : forall {A : Type} (l1 l2 l : list A), l = l1++l2 -> SubList l2 l. Proof. repeat intro. rewrite H. apply (in_app_iff l1 l2 x); right; assumption. Qed. Section SplitSubsteps. Variable m1 m2: BaseModule. Variable DisjRegs: DisjKey (getRegisters m1) (getRegisters m2). Variable DisjRules: DisjKey (getRules m1) (getRules m2). Variable DisjMeths: DisjKey (getMethods m1) (getMethods m2). Variable WfMod1: WfBaseModule type m1. Variable WfMod2: WfBaseModule type m2. Lemma filter_perm o l : Substeps (concatFlat m1 m2) o l -> Permutation l ((ModuleFilterLabels m1 l)++(ModuleFilterLabels m2 l)). induction 1; subst. - simpl; apply Permutation_refl. - apply in_app_iff in HInRules. destruct HInRules as [HInRules | HInRules]; rewrite (InRules_Filter _ _ _ _ _ _ HInRules). + destruct (DisjRules rn). * generalize (in_map_iff fst (getRules m1) rn). intro TMP; destruct TMP as [L R];clear L. assert (exists x, fst x = rn /\ In x (getRules m1));[exists (rn, rb); auto| specialize (R H1); contradiction]. * rewrite (NotInRules_Filter _ _ _ _ _ H0). constructor. assumption. + destruct (DisjRules rn). * rewrite (NotInRules_Filter _ _ _ _ _ H0). apply (Permutation_cons_app _ _ _ IHSubsteps). * generalize (in_map_iff fst (getRules m2) rn). intro TMP; destruct TMP as [L R];clear L. assert (exists x, fst x = rn /\ In x (getRules m2));[exists (rn, rb); auto | specialize (R H1); contradiction]. - apply in_app_iff in HInMeths. destruct HInMeths as [HInMeths | HInMeths]; rewrite (InMethods_Filter _ _ _ _ _ _ _ _ HInMeths). + destruct (DisjMeths fn). * generalize (in_map_iff fst (getMethods m1) fn). intro TMP; destruct TMP as [L R]; clear L. assert (exists x, fst x = fn /\ In x (getMethods m1)); [exists (fn, fb); auto| specialize (R H1); contradiction]. * rewrite (NotInMethods_Filter _ _ _ _ _ _ _ _ H0). constructor. assumption. + destruct (DisjMeths fn). * rewrite (NotInMethods_Filter _ _ _ _ _ _ _ _ H0). apply (Permutation_cons_app _ _ _ IHSubsteps). * generalize (in_map_iff fst (getMethods m2) fn). intro TMP; destruct TMP as [L R]; clear L. assert (exists x, fst x = fn /\ In x (getMethods m2)); [exists (fn, fb); auto| specialize (R H1); contradiction]. Qed. Lemma MatchingExecCalls_Mix2 : forall (l : list FullLabel) (o : RegsT), Substeps (concatFlat m1 m2) o l -> MatchingExecCalls_Base l (concatFlat m1 m2) -> MatchingExecCalls_Concat (ModuleFilterLabels m1 l) (ModuleFilterLabels m2 l) (Base m2). Proof. repeat intro. split;[auto|]. rewrite <- getNumCalls_app. rewrite <- (filter_perm H). specialize (H0 f); simpl in *;rewrite map_app, in_app_iff in H0. specialize (H0 (or_intror _ H2)). rewrite <-InExec_ModuleFilterLabels; auto. apply (in_map fst) in H2; rewrite fst_getKindAttr in H2; assumption. Qed. Lemma MatchingExecCalls_Mix1 : forall (l : list FullLabel) (o : RegsT), Substeps (concatFlat m1 m2) o l -> MatchingExecCalls_Base l (concatFlat m1 m2) -> MatchingExecCalls_Concat (ModuleFilterLabels m2 l) (ModuleFilterLabels m1 l) (Base m1). Proof. repeat intro. split;[auto|]. rewrite Z.add_comm. rewrite <- getNumCalls_app. rewrite <- (filter_perm H). specialize (H0 f); simpl in *;rewrite map_app, in_app_iff in H0. specialize (H0 (or_introl _ H2)). rewrite <-InExec_ModuleFilterLabels; auto. apply (in_map fst) in H2; rewrite fst_getKindAttr in H2; assumption. Qed. Lemma split_Substeps1 o l: NoDup (map fst (getRegisters m1)) -> NoDup (map fst (getRegisters m2)) -> Substeps (concatFlat m1 m2) o l -> (exists o1 o2, getKindAttr o1 = getKindAttr (getRegisters m1) /\ getKindAttr o2 = getKindAttr (getRegisters m2) /\ o = o1++o2 /\ Substeps m1 o1 (ModuleFilterLabels m1 l) /\ Substeps m2 o2 (ModuleFilterLabels m2 l)). Proof. unfold concatFlat; induction 3; simpl in *. - rewrite map_app in *; apply list_split in HRegs; dest. exists x, x0;split;[|split;[|split;[|split;[constructor|constructor]]]];assumption. - rewrite map_app in *;apply in_app_iff in HInRules; specialize (DisjRules rn). assert (NoDup (map fst o));[setoid_rewrite GKA_fst;setoid_rewrite HRegs; rewrite <- map_app; rewrite <- GKA_fst; apply (NoDupKey_Expand H H0 DisjRegs)|]. destruct HInRules as [HInRules|HInRules];generalize (in_map fst _ _ HInRules);destruct DisjRules;try contradiction. + subst; dest; exists x, x0;split;[|split;[|split;[|split]]];auto. rewrite (InRules_Filter _ _ _ _ _ _ HInRules). destruct (WfMod1) as [WfMod_Rle1 WfMod_Meth1];destruct (WfMod2) as [WfMod_Rle2 WfMod_Meth2]. specialize (WfActionT_ReadsWellDefined _ (@WfMod_Rle1 _ HInRules) HAction) as Reads_sublist; specialize (WfActionT_WritesWellDefined _ (WfMod_Rle1 _ HInRules) HAction) as Writes_sublist. constructor 2 with (rn:= rn)(rb:=rb)(reads:=reads)(u:=u)(cs:=cs)(ls:=(ModuleFilterLabels m1 ls)); auto. * specialize (app_sublist_l _ _ H6) as SL_o_x. specialize (WfMod_Rle1 (rn, rb) HInRules); specialize (WfActionT_SemAction _ WfMod_Rle1 H2 HAction SL_o_x H4). simpl; auto. * unfold ModuleFilterLabels;intros;apply HDisjRegs; destruct (filter_In (BaseModuleFilter m1) x1 ls) as [L R]; destruct (L H10);assumption. * intros; apply HNoRle; destruct (filter_In (BaseModuleFilter m1) x1 ls) as [L R]; destruct (L H10);assumption. * rewrite (NotInRules_Filter _ _ _ _ _ H3); assumption. + subst; dest; exists x, x0; split;[|split;[|split;[|split]]];auto. rewrite (NotInRules_Filter _ _ _ _ _ H3); assumption. rewrite (InRules_Filter _ _ _ _ _ _ HInRules). destruct (WfMod1) as [WfMod_Rle1 WfMod_Meth1];destruct (WfMod2) as [WfMod_Rle2 WfMod_Meth2]; specialize (WfActionT_ReadsWellDefined _ (WfMod_Rle2 _ HInRules) HAction) as Reads_sublist; specialize (WfActionT_WritesWellDefined _ (WfMod_Rle2 _ HInRules) HAction) as Writes_sublist. constructor 2 with (rn:= rn)(rb:=rb)(reads:=reads)(u:=u)(cs:=cs)(ls:=(ModuleFilterLabels m2 ls)); auto. * specialize (app_sublist_r _ _ H6) as SL_o_x. specialize (WfMod_Rle2 (rn, rb) HInRules); specialize (WfActionT_SemAction _ WfMod_Rle2 H2 HAction SL_o_x H5). simpl; auto. * unfold ModuleFilterLabels;intros;apply HDisjRegs; destruct (filter_In (BaseModuleFilter m2) x1 ls) as [L R]; destruct (L H10);assumption. * intros; apply HNoRle; destruct (filter_In (BaseModuleFilter m2) x1 ls) as [L R]; destruct (L H10);assumption. - rewrite map_app in *;apply in_app_iff in HInMeths; specialize (DisjMeths fn). assert (NoDup (map fst o));[setoid_rewrite GKA_fst;setoid_rewrite HRegs; rewrite <- map_app; rewrite <- GKA_fst; apply (NoDupKey_Expand H H0 DisjRegs)|]. destruct HInMeths as [HInMeths|HInMeths];generalize (in_map fst _ _ HInMeths);destruct DisjMeths;try contradiction;intros. + subst; dest; exists x, x0;split;[|split;[|split;[|split]]];auto. * rewrite (InMethods_Filter _ _ _ _ _ _ _ _ HInMeths). destruct (WfMod1) as [WfMod_Rle1 [WfMod_Meth1 _]];destruct (WfMod2) as [WfMod_Rle2 [WfMod_Meth2 _]]. specialize (WfActionT_ReadsWellDefined _ (WfMod_Meth1 (fn, fb) HInMeths argV) HAction) as Reads_sublist. specialize (WfActionT_WritesWellDefined _ (WfMod_Meth1 (fn, fb) HInMeths argV) HAction) as Writes_sublist. constructor 3 with (fn:=fn)(fb:=fb)(reads:=reads)(u:=u)(cs:=cs)(argV:=argV)(retV:=retV)(ls:=(ModuleFilterLabels m1 ls)); auto. -- specialize (app_sublist_l _ _ H7) as SL_o_x. specialize (WfMod_Meth1 (fn, fb) HInMeths argV); specialize (WfActionT_SemAction _ WfMod_Meth1 H2 HAction SL_o_x H5). simpl; auto. -- intros; apply HDisjRegs; destruct (filter_In (BaseModuleFilter m1) x1 ls) as [L R]; destruct (L H10); assumption. * rewrite (NotInMethods_Filter _ _ _ _ _ _ _ _ H3); assumption. + subst; dest; exists x, x0;split;[|split;[|split;[|split]]]; auto. * rewrite (NotInMethods_Filter _ _ _ _ _ _ _ _ H3); assumption. * rewrite (InMethods_Filter _ _ _ _ _ _ _ _ HInMeths). destruct (WfMod1) as [WfMod_Rle1 [WfMod_Meth1 _]];destruct (WfMod2) as [WfMod_Rle2 [WfMod_Meth2 _]]. specialize (WfActionT_ReadsWellDefined _ (WfMod_Meth2 (fn, fb) HInMeths argV) HAction) as Reads_sublist. specialize (WfActionT_WritesWellDefined _ (WfMod_Meth2 (fn, fb) HInMeths argV) HAction) as Writes_sublist. constructor 3 with (fn:=fn)(fb:=fb)(reads:=reads)(u:=u)(cs:=cs)(argV:=argV)(retV:=retV)(ls:=(ModuleFilterLabels m2 ls)); auto. -- specialize (app_sublist_r _ _ H7) as SL_o_x. specialize (WfMod_Meth2 (fn, fb) HInMeths argV); specialize (WfActionT_SemAction _ WfMod_Meth2 H2 HAction SL_o_x H6). simpl; auto. -- intros; apply HDisjRegs; destruct (filter_In (BaseModuleFilter m2) x1 ls) as [L R]; destruct (L H10); assumption. Qed. Lemma split_Substeps2 o l: Substeps (concatFlat m1 m2) o l -> (forall x y : FullLabel, In x (ModuleFilterLabels m1 l) -> In y (ModuleFilterLabels m2 l) -> match fst (snd x) with | Rle _ => match fst (snd y) with | Rle _ => False | Meth _ => True end | Meth _ => True end). Proof. induction 1; intros; auto; subst. - intros; contradiction. - simpl in HInRules. destruct (in_app_or _ _ _ HInRules) as [Rle_in | Rle_in]; specialize (in_map fst _ _ Rle_in) as map_Rle_in; destruct (DisjRules rn); try contradiction; rewrite (InRules_Filter u _ _ ls cs _ Rle_in) in *;rewrite (NotInRules_Filter u _ ls cs _ H2) in *; intros. + destruct H0. * rewrite <- H0; simpl. apply HNoRle. unfold ModuleFilterLabels in H1; apply filter_In in H1; destruct H1; assumption. * eapply IHSubsteps; eauto. + destruct H1. * rewrite <- H1; simpl. apply HNoRle. unfold ModuleFilterLabels in H0; apply filter_In in H0; destruct H0; assumption. * eapply IHSubsteps; eauto. - simpl in HInMeths; rewrite in_app_iff in HInMeths; destruct HInMeths, (DisjMeths fn);specialize (in_map fst _ _ H2) as P1 ; try contradiction. + setoid_rewrite (NotInMethods_Filter u _ fb argV retV ls cs _ H3) in H1. setoid_rewrite (InMethods_Filter _ _ _ _ _ _ _ _ H2) in H0. destruct H0;[subst;simpl in *;auto|]. apply IHSubsteps; auto. + setoid_rewrite (NotInMethods_Filter u _ fb argV retV ls cs _ H3) in H0. setoid_rewrite (InMethods_Filter _ _ _ _ _ _ _ _ H2) in H1. destruct H1;[subst;simpl in *;destruct x,p,r0;simpl;auto|]. apply IHSubsteps;auto. Qed. End SplitSubsteps. Definition PWeakInclusion (l1 l2 : list FullLabel) : Prop := (forall f : MethT, InExec f l1 /\ ~ InCall f l1 <-> InExec f l2 /\ ~ InCall f l2) /\ (forall f : MethT, ~ InExec f l1 /\ InCall f l1 <-> ~ InExec f l2 /\ InCall f l2) /\ (forall f : MethT, InExec f l1 /\ InCall f l1 \/ (forall v, ~ InExec (fst f, v) l1 ) /\ (forall v, ~ InCall (fst f, v) l1) <-> InExec f l2 /\ InCall f l2 \/ (forall v, ~ InExec (fst f, v) l2) /\ (forall v, ~ InCall (fst f, v) l2)) /\ ((exists rle : string, In (Rle rle) (map getRleOrMeth l2)) -> exists rle : string, In (Rle rle) (map getRleOrMeth l1)). Lemma InExec_app_comm : forall l1 l2 e, InExec e (l1++l2) -> InExec e (l2++l1). Proof. intros; rewrite InExec_app_iff in *; firstorder. Qed. Lemma InCall_app_comm : forall l1 l2 e, InCall e (l1++l2) -> InCall e (l2++l1). Proof. intros; rewrite InCall_app_iff in *; firstorder. Qed. Lemma WeakInclusion_app_comm : forall l1 l2, WeakInclusion (l1++l2)(l2++l1). Proof. intros. unfold WeakInclusion;split;intros. - unfold getListFullLabel_diff; repeat rewrite getNumExecs_app, getNumCalls_app; ring. - dest; exists x; rewrite map_app,in_app_iff in *; firstorder fail. Qed. Definition WeakEquality (l1 l2 : list FullLabel) : Prop := WeakInclusion l1 l2 /\ WeakInclusion l2 l1. Lemma commutative_Concat : forall m1 m2 o l, Step (ConcatMod m1 m2) o l -> exists l' o', Step (ConcatMod m2 m1) o' l' /\ WeakEquality l l'. Proof. intros. inversion_clear H. exists (l2++l1). exists (o2++o1). split. econstructor; try eassumption. intros. generalize (HNoRle y x H0 H). intros. destruct x. subst. destruct y. simpl in *. destruct p. destruct p0. simpl in *. destruct r2. assumption. destruct r1. assumption. assumption. reflexivity. reflexivity. subst. split. apply WeakInclusion_app_comm. apply WeakInclusion_app_comm. Qed. Lemma WeakInclusionRefl : forall l, WeakInclusion l l. intros. unfold WeakInclusion. split;intros; try assumption. reflexivity. Qed. Corollary WeakEqualityRefl : forall l, WeakEquality l l. intros. unfold WeakEquality. split; apply WeakInclusionRefl. Qed. Lemma WeakInclusionTrans : forall l1 l2 l3, WeakInclusion l1 l2 -> WeakInclusion l2 l3 -> WeakInclusion l1 l3. intros. unfold WeakInclusion in *. dest. split;intros;eauto using eq_trans. Qed. Corollary WeakEqualityTrans : forall l1 l2 l3, WeakEquality l1 l2 -> WeakEquality l2 l3 -> WeakEquality l1 l3. unfold WeakEquality; intros;dest; split; eauto using WeakInclusionTrans. Qed. Lemma WeakEqualitySym : forall l1 l2, WeakEquality l1 l2 -> WeakEquality l2 l1. intros. destruct H; split; auto. Qed. Lemma WfNoDups ty m (HWfMod : WfMod ty m) : NoDup (map fst (getAllRegisters m)) /\ NoDup (map fst (getAllMethods m)) /\ NoDup (map fst (getAllRules m)). Proof. specialize (HWfMod). induction m. - inv HWfMod. inv HWfBaseModule. dest. tauto. - inversion HWfMod; subst; apply IHm in HWf. assumption. - inversion HWfMod;subst;destruct (IHm1 HWf1) as [ND_Regs1 [ND_Meths1 ND_Rles1]];destruct (IHm2 HWf2) as [ND_Regs2 [ND_Meths2 ND_Rles2]];split;[|split]. + simpl;rewrite map_app. induction (getAllRegisters m1); simpl;[assumption|]. constructor. * intro. destruct (HDisjRegs (fst a));apply H0;[left; reflexivity|]. inversion_clear ND_Regs1. apply in_app_or in H; destruct H; contradiction. * apply (IHl). intro;split;[|split];auto. -- inversion_clear ND_Regs1; assumption. -- unfold DisjKey; intro; destruct (HDisjRegs k);[left|right]; intro; apply H; auto. right; assumption. -- inversion_clear ND_Regs1; assumption. + simpl;rewrite map_app. induction (getAllMethods m1); simpl;[assumption|]. constructor. * intro. destruct (HDisjMeths (fst a));apply H0;[left; reflexivity|]. inversion_clear ND_Meths1. apply in_app_or in H; destruct H; contradiction. * apply (IHl). intro;split;[|split];auto. -- inversion_clear ND_Meths1; assumption. -- unfold DisjKey; intro; destruct (HDisjMeths k);[left|right]; intro; apply H; auto. right; assumption. -- inversion_clear ND_Meths1; assumption. + simpl;rewrite map_app. induction (getAllRules m1); simpl;[assumption|]. constructor. * intro. destruct (HDisjRules (fst a));apply H0;[left; reflexivity|]. inversion_clear ND_Rles1. apply in_app_or in H; destruct H; contradiction. * apply (IHl). intro;split;[|split];auto. -- inversion_clear ND_Rles1; assumption. -- unfold DisjKey; intro; destruct (HDisjRules k);[left|right]; intro; apply H; auto. right; assumption. -- inversion_clear ND_Rles1; assumption. Qed. Lemma WfMod_WfBaseMod_flat ty m (HWfMod : WfMod ty m): WfBaseModule ty (getFlat m). Proof. specialize (HWfMod). unfold getFlat;induction m. - simpl; inversion HWfMod; subst; destruct HWfBaseModule. unfold WfBaseModule in *; split; intros. + specialize (H rule H1). induction H; econstructor; eauto. + dest; intros. repeat split; auto; intros. - inversion_clear HWfMod. specialize (IHm HWf). assumption. - inversion_clear HWfMod. specialize (IHm1 HWf1). specialize (IHm2 HWf2). simpl in *. constructor;simpl; repeat split; auto; intros; try destruct (in_app_or _ _ _ H) as [In1 | In1]. + destruct IHm1 as [Rle Meth]; clear Meth; specialize (Rle _ In1). induction Rle; econstructor; eauto; setoid_rewrite map_app; apply in_or_app;left; assumption. + destruct IHm2 as [Rle Meth]; clear Meth; specialize (Rle _ In1). induction Rle; econstructor; eauto; setoid_rewrite map_app; apply in_or_app;right; assumption. + destruct IHm1 as [Rle [Meth _]]; clear Rle; specialize (Meth _ In1 v). induction Meth; econstructor; eauto; setoid_rewrite map_app; apply in_or_app;left; assumption. + destruct IHm2 as [Rle [Meth _]]; clear Rle; specialize (Meth _ In1 v). induction Meth; econstructor; eauto; setoid_rewrite map_app; apply in_or_app;right;assumption. + inv IHm1; inv IHm2; dest; apply NoDup_DisjKey; auto. + inv IHm1; inv IHm2; dest; apply NoDup_DisjKey; auto. + inv IHm1; inv IHm2; dest; apply NoDup_DisjKey; auto. Qed. Lemma WfConcatNotInCalls : forall (m : Mod)(o : RegsT)(k : Kind)(a : ActionT type k) (readRegs newRegs : RegsT)(cs : MethsT)(fret : type k) (f : MethT), WfConcatActionT a m -> SemAction o a readRegs newRegs cs fret -> In (fst f) (getHidden m) -> ~In f cs. Proof. intros. induction H0; subst; eauto; inversion H; EqDep_subst; eauto. - specialize (IHSemAction (H8 mret)). intro TMP; destruct TMP;[subst; contradiction|contradiction]. - intro TMP; apply in_app_or in TMP; destruct TMP. + eapply IHSemAction1; eauto. + eapply IHSemAction2; eauto. - intro TMP; apply in_app_or in TMP; destruct TMP. + eapply IHSemAction1; eauto. + eapply IHSemAction2; eauto. - intro TMP; apply in_app_or in TMP; destruct TMP. + eapply IHSemAction1; eauto. + eapply IHSemAction2; eauto. Qed. Lemma getNumFromCalls_notIn f cs : ~In f cs -> (getNumFromCalls f cs = 0%Z). Proof. induction cs; intros; auto. destruct (MethT_dec f a);[subst;apply False_ind; apply H;left|rewrite getNumFromCalls_neq_cons];auto. apply IHcs; intro; apply H; right; assumption. Qed. Lemma WfConcats : forall (m1 m2 : Mod) (o : RegsT)(l : list FullLabel), (WfConcat type m2 m1) -> Substeps (getFlat m2) o l -> (forall (s: string)(v : {x : Kind*Kind & SignT x}), In s (getHidden m1) -> (getNumCalls (s, v) l = 0%Z)). Proof. intros. induction H0; subst. - reflexivity. - specialize (H). inversion H; simpl in HInRules;specialize (H2 _ HInRules). rewrite getNumCalls_cons; rewrite IHSubsteps;simpl. assert (In (fst (s, v)) (getHidden m1)) as P1;auto. rewrite (getNumFromCalls_notIn _ _ (WfConcatNotInCalls _ H2 HAction P1)); ring. - specialize (H). inversion H; simpl in HInMeths;specialize (H3 _ HInMeths argV). rewrite getNumCalls_cons; rewrite IHSubsteps;simpl. assert (In (fst (s, v)) (getHidden m1)) as P1;auto. rewrite (getNumFromCalls_notIn _ _ (WfConcatNotInCalls _ H3 HAction P1)); ring. Qed. Lemma WfConcats_Substeps : forall (m1 : Mod) m2 (o : RegsT)(l : list FullLabel), (WfConcat type (Base m2) m1) -> Substeps m2 o l -> forall f, In (fst f) (getHidden m1) -> (getNumCalls f l = 0%Z). Proof. intros. induction H0; subst. - reflexivity. - specialize (H). inversion H; simpl in HInRules;specialize (H2 _ HInRules). rewrite getNumCalls_cons; rewrite IHSubsteps;simpl. assert (In (fst f) (getHidden m1)) as P1;auto. rewrite (getNumFromCalls_notIn _ _ (WfConcatNotInCalls _ H2 HAction P1)); ring. - specialize (H). inversion H; simpl in HInMeths;specialize (H3 _ HInMeths argV). rewrite getNumCalls_cons; rewrite IHSubsteps;simpl. assert (In (fst f) (getHidden m1)) as P1;auto. rewrite (getNumFromCalls_notIn _ _ (WfConcatNotInCalls _ H3 HAction P1)); ring. Qed. Lemma WfConcats_Step : forall (m1 m2 : Mod) (o : RegsT) (l : list FullLabel), (WfConcat type m2 m1) -> Step m2 o l -> (forall f, In (fst f) (getHidden m1) -> (getNumCalls f l = 0%Z)). Proof. intros. induction H0; subst. - eapply WfConcats_Substeps; eauto. - unfold WfConcat in *; simpl in *. specialize (IHStep H); auto. - unfold WfConcat in *; simpl in *. setoid_rewrite in_app_iff in H. assert (sth1: (forall rule : RuleT, In rule (getAllRules m0) -> WfConcatActionT (snd rule type) m1) /\ (forall meth : string * {x : Signature & MethodT x}, In meth (getAllMethods m0) -> forall v : type (fst (projT1 (snd meth))), WfConcatActionT (projT2 (snd meth) type v) m1)) by (split; dest; intros; auto). assert (sth2: (forall rule : RuleT, In rule (getAllRules m2) -> WfConcatActionT (snd rule type) m1) /\ (forall meth : string * {x : Signature & MethodT x}, In meth (getAllMethods m2) -> forall v : type (fst (projT1 (snd meth))), WfConcatActionT (projT2 (snd meth) type v) m1) ) by (split; dest; intros; auto). specialize (IHStep1 sth1). specialize (IHStep2 sth2). rewrite getNumCalls_app; Omega.omega. Qed. Lemma WfConcats_Trace : forall (m1 m2 : Mod) (o : RegsT) ls (l : list FullLabel), Trace m2 o ls -> (WfConcat type m2 m1) -> forall i, nth_error ls i = Some l -> (forall f, In (fst f) (getHidden m1) -> (getNumCalls f l = 0%Z)). Proof. induction 1; subst; auto; intros. - destruct i; discriminate. - destruct i; simpl in *. + inv H1. eapply WfConcats_Step; eauto. + eapply IHTrace; eauto. Qed. Lemma substitute_Step' m (HWfMod: WfMod type m): forall o l, StepSubstitute m o l -> exists l', Permutation l l' /\ Step m o l'. Proof. unfold StepSubstitute. induction m; simpl in *; intros; dest. - exists l; split;[apply Permutation_refl|constructor; auto]. eapply Substeps_flatten; eauto. - assert (exists l' : list FullLabel, l [=] l' /\ Step m o l');[apply IHm;auto|dest;exists x;split;auto]. + intros; specialize (HWfMod); inv HWfMod; auto. + constructor 2; auto. intros. unfold getListFullLabel_diff in *;rewrite <-H2. apply H1; auto. - assert (HWf1: WfMod type m1) by (intros; specialize (HWfMod); inv HWfMod; auto). assert (HWf2: WfMod type m2) by (intros; specialize (HWfMod); inv HWfMod; auto). specialize (IHm1 HWf1). specialize (IHm2 HWf2). destruct (WfNoDups HWf1) as [ND_Regs1 [ND_Meths1 ND_Rules1]]. destruct (WfNoDups HWf2) as [ND_Regs2 [ND_Meths2 ND_Rules2]]. specialize (WfMod_WfBaseMod_flat HWf1) as WfBaseMod1. specialize (WfMod_WfBaseMod_flat HWf2) as WfBaseMod2. pose proof (HWfMod) as hwfmod2. assert (WfConcat1: WfConcat type m1 m2 ) by (intros; specialize (HWfMod); inv HWfMod; auto). assert (WfConcat2: WfConcat type m2 m1 ) by (intros; specialize (HWfMod); inv HWfMod; auto). inv hwfmod2. pose proof (@split_Substeps1 (getFlat m1) (getFlat m2) HDisjRegs HDisjRules HDisjMeths WfBaseMod1 WfBaseMod2 _ _ ND_Regs1 ND_Regs2 H);dest. assert (Substeps (BaseMod (getAllRegisters m1) (getAllRules m1) (getAllMethods m1)) x (ModuleFilterLabels (getFlat m1) l) /\ MatchingExecCalls_Base (ModuleFilterLabels (getFlat m1) l) (getFlat m1) /\ (forall (s : string) (v : {x : Kind * Kind & SignT x}), In (s, projT1 v) (getKindAttr (getAllMethods m1)) -> In s (getHidden m1) -> (getListFullLabel_diff (s, v) (ModuleFilterLabels (getFlat m1) l) = 0%Z))). + split; unfold getFlat at 1 in H5. assumption. split. * unfold getFlat in H0. simpl in H0. unfold getFlat; simpl. assert (MatchingExecCalls_Base l (concatFlat (getFlat m1) (getFlat m2)));[unfold concatFlat, getFlat;simpl; assumption|]. apply (MatchingExecCalls_Split H7). * intros; specialize (WfConcats WfConcat2 H6 _ v H8) as P1. rewrite map_app in H1. specialize (H1 s v (in_or_app _ _ _ (or_introl H7)) (in_or_app _ _ _ (or_introl H8))); unfold getListFullLabel_diff in *. assert (DisjKey (getRules (getFlat m1)) (getRules (getFlat m2))) as P2;[repeat intro; apply HDisjRules|]. assert (DisjKey (getMethods (getFlat m1))(getMethods (getFlat m2))) as P3;[repeat intro;apply HDisjMeths|]. specialize (filter_perm P2 P3 H) as P4. rewrite P4, getNumExecs_app, getNumCalls_app in H1. setoid_rewrite P1 in H1. destruct (P3 s) as [P5|P5];[simpl in P5; apply (in_map fst) in H7; rewrite fst_getKindAttr in H7; contradiction|]. assert (~In (fst (s,v)) (map fst (getMethods (getFlat m2)))) as P6;auto. setoid_rewrite (NotInDef_ZeroExecs_Substeps _ P6 H6) in H1; rewrite <-H1. repeat rewrite Z.add_0_r. reflexivity. + assert (Substeps (BaseMod (getAllRegisters m2) (getAllRules m2) (getAllMethods m2)) x0 (ModuleFilterLabels (getFlat m2) l) /\ MatchingExecCalls_Base (ModuleFilterLabels (getFlat m2) l) (getFlat m2) /\ (forall (s : string) (v : {x : Kind * Kind & SignT x}), In (s, projT1 v) (getKindAttr (getAllMethods m2)) -> In s (getHidden m2) -> (getListFullLabel_diff (s, v) (ModuleFilterLabels (getFlat m2) l) = 0%Z))). * split;unfold getFlat at 1 in H6. assumption. split. -- unfold getFlat in H0. simpl in H0. unfold getFlat; simpl. assert (MatchingExecCalls_Base l (concatFlat (getFlat m1) (getFlat m2)));[unfold concatFlat, getFlat;simpl; assumption|]. apply MatchingExecCalls_Base_comm in H8. eapply (MatchingExecCalls_Split H8). -- intros; specialize (WfConcats WfConcat1 H5 _ v H9) as P1. rewrite map_app in H1. specialize (H1 s v (in_or_app _ _ _ (or_intror H8)) (in_or_app _ _ _ (or_intror H9))); unfold getListFullLabel_diff in *. assert (DisjKey (getRules (getFlat m1)) (getRules (getFlat m2))) as P2;[repeat intro; apply HDisjRules|]. assert (DisjKey (getMethods (getFlat m1))(getMethods (getFlat m2))) as P3;[repeat intro;apply HDisjMeths|]. specialize (filter_perm P2 P3 H) as P4. rewrite P4, getNumExecs_app, getNumCalls_app in H1. setoid_rewrite P1 in H1. destruct (P3 s) as [P5|P5];[|simpl in P5; apply (in_map fst) in H8; rewrite fst_getKindAttr in H8; contradiction]. assert (~In (fst (s,v)) (map fst (getMethods (getFlat m1)))) as P6;auto. setoid_rewrite (NotInDef_ZeroExecs_Substeps _ P6 H5) in H1; rewrite <-H1. repeat rewrite Z.add_0_r. reflexivity. * specialize (IHm1 x (ModuleFilterLabels (getFlat m1) l) H7). specialize (IHm2 x0 (ModuleFilterLabels (getFlat m2) l) H8); dest. exists (x2++x1). split. -- specialize (filter_perm (m1:=(getFlat m1)) (m2:=(getFlat m2)) HDisjRules HDisjMeths H). intro. specialize (Permutation_app H15 H13). intro. apply (Permutation_trans H17 H18). -- econstructor; eauto; specialize (split_Substeps2 (m1:=(getFlat m1)) (m2:=(getFlat m2)) HDisjRules HDisjMeths (o:=o)(l:=l) H); intros. ++ repeat intro. split. ** intro;specialize (WfConcats WfConcat1 H5 _ (snd f) H20);intro. rewrite <-H15 in H18; destruct f; simpl in *; contradiction. ** assert (MatchingExecCalls_Base l (concatFlat (getFlat m1) (getFlat m2)));[apply H0|]. rewrite <-H15, <-H13. assert (DisjKey (getRules (getFlat m1)) (getRules (getFlat m2))) as P1; auto. assert (DisjKey (getMethods (getFlat m1)) (getMethods (getFlat m2))) as P2; auto. specialize (MatchingExecCalls_Mix2 P1 P2 H H20) as P3. rewrite <-H15 in H18. specialize (P3 _ H18 H19); dest; assumption. ++ repeat intro. split. ** intro; specialize (WfConcats WfConcat2 H6 _ (snd f) H20); intro. rewrite <-H13 in H18; destruct f; simpl in *; contradiction. ** assert (MatchingExecCalls_Base l (concatFlat (getFlat m1) (getFlat m2)));[apply H0|]. rewrite <- H15, <-H13. assert (DisjKey (getRules (getFlat m1)) (getRules (getFlat m2))) as P1; auto. assert (DisjKey (getMethods (getFlat m1)) (getMethods (getFlat m2))) as P2; auto. specialize (MatchingExecCalls_Mix1 P1 P2 H H20) as P3. rewrite <-H13 in H18. specialize (P3 _ H18 H19); dest; assumption. ++ rewrite <- H15 in H18; rewrite <- H13 in H19. specialize (H17 _ _ H18 H19); assumption. Qed. Lemma WeakInclusionsRefl l : WeakInclusions l l. Proof. induction l; constructor. - assumption. - apply WeakInclusionRefl. Qed. Corollary WeakEqualitiesRefl l : WeakEqualities l l. Proof. unfold WeakEqualities; split; apply WeakInclusionsRefl. Qed. Lemma WeakInclusionsTrans : forall (l1 l2 l3 : list (list FullLabel)), WeakInclusions l1 l2 -> WeakInclusions l2 l3 -> WeakInclusions l1 l3. Proof. induction l1, l2, l3; intros; auto; try inversion H; try inversion H0; subst. constructor. - apply (IHl1 _ _ H4 H10). - apply (WeakInclusionTrans H6 H12). Qed. Corollary WeakEqualitesTrans ls1 ls2 ls3 : WeakEqualities ls1 ls2 -> WeakEqualities ls2 ls3 -> WeakEqualities ls1 ls3. Proof. unfold WeakEqualities; intros; dest; split; eapply WeakInclusionsTrans; eauto. Qed. Lemma WeakEqualitiesSymm ls1 ls2 : WeakEqualities ls1 ls2 -> WeakEqualities ls2 ls1. Proof. firstorder. Qed. Lemma WeakInclusionsLen_consistent ls1 ls2 : WeakInclusions ls1 ls2 -> length ls1 = length ls2. Proof. induction 1; simpl; auto. Qed. Lemma WeakInclusions_WeakInclusion : forall (ls1 ls2 : list (list FullLabel)), WeakInclusions ls1 ls2 -> nthProp2 WeakInclusion ls1 ls2. Proof. induction ls1, ls2; unfold nthProp2; intros; try destruct (nth_error nil i); auto; try inversion H; subst. - apply WeakInclusionRefl. - destruct i; simpl;[|apply IHls1];assumption. Qed. Lemma WeakInclusion_WeakInclusions : forall (ls1 ls2 : list (list FullLabel)), length ls1 = length ls2 -> nthProp2 WeakInclusion ls1 ls2 -> WeakInclusions ls1 ls2. Proof. induction ls1, ls2; intros; try constructor; try inversion H; try apply nthProp2_cons in H0; try destruct H0;[apply (IHls1 _ H2 H0)|assumption]. Qed. Definition TraceList (m : Mod) (ls : list (list FullLabel)) := (exists (o : RegsT), Trace m o ls). Definition TraceInclusion' (m m' : Mod) := forall (o : RegsT)(ls : list (list FullLabel)), Trace m o ls -> exists (ls': list (list FullLabel)), TraceList m' ls' /\ WeakInclusions ls ls'. Lemma TraceInclusion'_TraceInclusion : forall (m m' : Mod), TraceInclusion' m m' -> TraceInclusion m m'. Proof. unfold TraceInclusion', TraceInclusion; intros; generalize (H o1 ls1 H0); unfold TraceList; intros; dest;exists x0, x. repeat split. - assumption. - apply (WeakInclusionsLen_consistent H2). - apply WeakInclusions_WeakInclusion;assumption. Qed. Lemma TraceInclusion_TraceInclusion' : forall (m m' : Mod), TraceInclusion m m' -> TraceInclusion' m m'. Proof. unfold TraceInclusion'; intros; generalize (H _ _ H0); intros; dest; unfold TraceList; exists x0. split. - exists x; assumption. - apply (WeakInclusion_WeakInclusions H2 H3). Qed. Lemma PermutationInCall : forall (l l' : list FullLabel), Permutation l l' -> (forall (f : MethT), InCall f l <-> InCall f l'). Proof. induction 1. - firstorder. - intro; split; intros; try assumption. + apply (InCall_app_iff f (x::nil) l'); apply (InCall_app_iff f (x::nil) l) in H0. destruct H0;[left|right;apply IHPermutation];assumption. + apply (InCall_app_iff f (x::nil) l); apply (InCall_app_iff f (x::nil) l') in H0. destruct H0;[left|right;apply IHPermutation];assumption. - split; intros. + apply (InCall_app_iff f (x::y::nil) l); apply (InCall_app_iff f (y::x::nil) l) in H. destruct H;[left;simpl|right];firstorder. + apply (InCall_app_iff f (y::x::nil) l); apply (InCall_app_iff f (x::y::nil) l) in H;firstorder. - intros; split;intros. + apply IHPermutation2; apply IHPermutation1; assumption. + apply IHPermutation1; apply IHPermutation2; assumption. Qed. Corollary neg_PermutationInCall : forall (l l' : list FullLabel), Permutation l l' -> (forall (f : MethT), ~InCall f l <-> ~InCall f l'). Proof. intros; split; repeat intro; apply H0;specialize (Permutation_sym H) as TMP; eapply PermutationInCall; eauto. Qed. Lemma PermutationInExec : forall (l l' : list FullLabel), Permutation l l' -> (forall (f : MethT), InExec f l <-> InExec f l'). Proof. induction 1; firstorder. Qed. Corollary neg_PermutationInExec : forall (l l' : list FullLabel), Permutation l l' -> (forall (f : MethT), ~InExec f l <-> ~InExec f l'). Proof. intros; split; repeat intro; apply H0; specialize (Permutation_sym H) as TMP; eapply PermutationInExec; eauto. Qed. Lemma PermutationWI : forall (l l' : list FullLabel), Permutation l l' -> WeakInclusion l l'. Proof. unfold WeakInclusion; repeat split; intros. - unfold getListFullLabel_diff; rewrite H; reflexivity. - setoid_rewrite H; assumption. Qed. Corollary PermutationWE : forall (l l' : list FullLabel), Permutation l l' -> WeakEquality l l'. Proof. intros;unfold WeakEquality; split;[apply PermutationWI|apply PermutationWI;apply Permutation_sym];assumption. Qed. Lemma substitute_Step m o l (HWfMod: WfMod type m): Step (flatten m) o l -> exists l', Permutation l l' /\ Step m o l'. Proof. rewrite (@StepSubstitute_flatten) in *; auto. apply substitute_Step'; auto. Qed. Inductive PermutationEquivLists {A : Type} : (list (list A)) -> (list (list A)) -> Prop := |PermutationEquiv_nil : PermutationEquivLists nil nil |PermutationEquiv_cons ls ls' l l' : PermutationEquivLists ls ls' -> Permutation l l' -> PermutationEquivLists (l::ls) (l'::ls'). Lemma PermutationEquivLists_WeakInclusions : forall (ls ls' : list (list FullLabel)), PermutationEquivLists ls ls' -> WeakInclusions ls ls'. Proof. induction 1. - constructor. - constructor; auto. apply PermutationWI; assumption. Qed. Lemma UpdRegs_perm u u' o o' : UpdRegs u o o' -> Permutation u u' -> UpdRegs u' o o'. Proof. unfold UpdRegs; intros; dest. split; auto. intros. specialize (H1 s v H2). destruct H1;[left|right]. - dest; exists x;split;auto. eapply Permutation_in; eauto. - destruct H1; split;[intro; apply H1|assumption]. dest; exists x; split;[|assumption]. apply Permutation_sym in H0. eapply Permutation_in; eauto. Qed. Lemma SameTrace m1 m2: (forall o1 l, Trace m1 o1 l -> exists o2, Trace m2 o2 l) -> TraceInclusion m1 m2. Proof. unfold TraceInclusion; intros. pose proof (H _ _ H0); dest. exists x, ls1; auto. repeat split; auto. - unfold nthProp2; intros. destruct (nth_error ls1 i); auto. repeat split; tauto. Qed. Lemma WfMod_createHide l: forall ty m, WfMod ty (createHide m l) <-> (SubList l (map fst (getMethods m)) /\ WfMod ty (Base m)). Proof. split. - induction l; simpl; intros; split; unfold SubList; simpl; intros; try tauto. + inv H. destruct H0; subst; rewrite createHide_Meths in *; auto. specialize (IHl HWf); dest; apply H0; assumption. + inv H. destruct (IHl HWf); assumption. - unfold SubList; induction l; simpl; intros; try tauto; dest; constructor. + rewrite createHide_Meths; apply (H a); left; reflexivity. + apply IHl; intros; split;auto. Qed. Lemma WfMod_createHideMod l: forall ty m, WfMod ty (createHideMod m l) <-> (SubList l (map fst (getAllMethods m)) /\ WfMod ty m). Proof. split. - induction l; simpl; intros; split; unfold SubList; simpl; intros; try tauto. + inv H. destruct H0; subst; rewrite createHideMod_Meths in *; auto. specialize (IHl HWf); dest; apply H0; assumption. + inv H. destruct (IHl HWf); assumption. - unfold SubList; induction l; simpl; intros; try tauto; dest; constructor. + rewrite createHideMod_Meths; apply (H a); left; reflexivity. + apply IHl; intros; split;auto. Qed. Lemma WfActionT_flatten m k ty: forall (a : ActionT ty k), WfActionT (getRegisters m) a <-> WfActionT (getRegisters (getFlat (Base m))) a. Proof. intro; split; induction 1; econstructor; eauto. Qed. Theorem flatten_WfMod ty m: WfMod ty m -> WfMod ty (flatten m). Proof. unfold flatten. induction 1; simpl; auto; intros. - constructor; auto. - constructor; auto. rewrite createHide_Meths. auto. - unfold getFlat in *; simpl. rewrite WfMod_createHide in *; dest; simpl in *. split. + rewrite map_app. unfold SubList in *; intros. rewrite in_app_iff in *. specialize (H3 x). specialize (H1 x). tauto. + constructor;inversion H4; inversion H2; inversion HWfBaseModule; inversion HWfBaseModule0; subst. * split; intros. -- destruct (in_app_or _ _ _ H6). ++ specialize (H5 _ H7). induction H5; econstructor; eauto; simpl; rewrite map_app; apply in_or_app; left; assumption. ++ specialize (H9 _ H7). induction H9; econstructor; eauto; simpl; rewrite map_app; apply in_or_app; right; assumption. -- repeat split; simpl; intros; dest; try (eapply NoDup_DisjKey; eauto). ++ destruct (in_app_or _ _ _ H6). ** specialize (H8 _ H16 v). induction H8; econstructor; eauto; simpl; rewrite map_app; apply in_or_app; left; assumption. ** specialize (H7 _ H16 v). induction H7; econstructor; eauto; simpl; rewrite map_app; apply in_or_app; right; assumption. Qed. Theorem flatten_WfMod_new ty m : WfMod_new ty m -> WfMod_new ty (flatten m). Proof. repeat rewrite WfMod_new_WfMod_iff. apply flatten_WfMod. Qed. Definition flatten_ModWf ty m: ModWf ty := (Build_ModWf (flatten_WfMod (wfMod m))). Definition flatten_ModWf_new ty m: ModWf_new ty := (Build_ModWf_new _ _ (flatten_WfMod_new _ _ (wfMod_new m))). Section TraceSubstitute. Variable m: ModWf type. Lemma Trace_flatten_same1: forall o l, Trace m o l -> Trace (flatten m) o l. Proof. induction 1; subst. - constructor 1; auto. unfold flatten. rewrite createHide_Regs. auto. - apply (@Step_substitute type) in HStep; auto. + econstructor 2; eauto. + destruct m; auto. Qed. Lemma Trace_flatten_same2: forall o l, Trace (flatten m) o l -> (exists l', (PermutationEquivLists l l') /\ Trace m o l'). Proof. induction 1; subst. - rewrite getAllRegisters_flatten in *. exists nil;split;constructor 1; auto. - apply substitute_Step in HStep;auto; dest. exists (x0::x);split. + constructor; auto. + econstructor 2; eauto. apply (Permutation_map fst) in H2. eapply UpdRegs_perm; eauto. + destruct m; auto. Qed. Theorem TraceInclusion_flatten_r: TraceInclusion m (flatten_ModWf m). Proof. unfold TraceInclusion; intros. exists o1, ls1. repeat split; auto; intros; unfold nthProp2; intros; try destruct (nth_error ls1 i); auto; repeat split; intros; try tauto. apply Trace_flatten_same1; auto. Qed. Theorem TraceInclusion_flatten_l: TraceInclusion (flatten_ModWf m) m. Proof. apply TraceInclusion'_TraceInclusion. unfold TraceInclusion'; intros. apply Trace_flatten_same2 in H. dest. exists x. split. - unfold TraceList; exists o; auto. - apply PermutationEquivLists_WeakInclusions. assumption. Qed. End TraceSubstitute. Section TraceSubstitute_new. Variable m: ModWf_new type. Lemma Trace_flatten_same1_new: forall o l, Trace m o l -> Trace (flatten m) o l. Proof. induction 1; subst. - constructor 1; auto. unfold flatten. rewrite createHide_Regs. auto. - apply (@Step_substitute type) in HStep; auto. + econstructor 2; eauto. + destruct m; apply WfMod_new_WfMod; auto. Qed. Lemma Trace_flatten_same2_new : forall o l, Trace (flatten m) o l -> (exists l', (PermutationEquivLists l l') /\ Trace m o l'). Proof. induction 1; subst. - rewrite getAllRegisters_flatten in *. exists nil;split;constructor 1; auto. - apply substitute_Step in HStep;auto; dest. exists (x0::x);split. + constructor; auto. + econstructor 2; eauto. apply (Permutation_map fst) in H2. eapply UpdRegs_perm; eauto. + destruct m; apply WfMod_new_WfMod; auto. Qed. Theorem TraceInclusion_flatten_r_new : TraceInclusion m (flatten_ModWf_new m). Proof. unfold TraceInclusion; intros. exists o1, ls1. repeat split; auto; intros; unfold nthProp2; intros; try destruct (nth_error ls1 i); auto; repeat split; intros; auto. apply Trace_flatten_same1_new; auto. Qed. Theorem TraceInclusion_flatten_l_new : TraceInclusion (flatten_ModWf_new m) m. Proof. apply TraceInclusion'_TraceInclusion. unfold TraceInclusion'; intros. apply Trace_flatten_same2_new in H. dest. exists x. split. - unfold TraceList; exists o; auto. - apply PermutationEquivLists_WeakInclusions. assumption. Qed. End TraceSubstitute_new. Section test. Variable ty: Kind -> Type. Definition Slt2 n (e1 e2: Expr ty (SyntaxKind (Bit (n + 1)))) := ITE (Eq (UniBit (TruncMsb n 1) e1) (Const ty WO~0)) (ITE (Eq (UniBit (TruncMsb n 1) e2) (Const ty WO~0)) (BinBitBool (LessThan _) e1 e2) (Const ty false)) (ITE (Eq (UniBit (TruncMsb n 1) e2) (Const ty WO~1)) (BinBitBool (LessThan _) e1 e2) (Const ty true)). End test. Lemma Slt_same n e1 e2: evalExpr (Slt2 n e1 e2) = evalExpr (Slt n e1 e2). Proof. unfold Slt2, Slt. simpl. destruct (weq (@truncMsb 1 (n+1) (evalExpr e1)) (ZToWord 1 0)); simpl; auto. - rewrite e. destruct (weq (@truncMsb 1 (n+1) (evalExpr e2)) (ZToWord 1 0)); simpl; auto. + rewrite e0. destruct (wltu (evalExpr e1) (evalExpr e2)); simpl; auto. + case_eq (wltu (evalExpr e1) (evalExpr e2)); intros; simpl; auto. * destruct (weq (ZToWord 1 0) (@truncMsb 1 (n+1) (evalExpr e2))); simpl; auto. * destruct (weq (ZToWord 1 0) (@truncMsb 1 (n+1) (evalExpr e2))); simpl; auto. apply word0_neq in n0. rewrite n0 in n1. assert ((wordVal 1 (truncMsb (evalExpr e1))) < (wordVal 1 (truncMsb (evalExpr e2))))%Z. rewrite e. rewrite n0. simpl. rewrite Zmod_0_l. rewrite Zmod_1_l. lia. rewrite Z.pow_pos_fold. lia. specialize truncMsbLtTrue. intros. specialize (H1 (n+1) 1 (evalExpr e1) (evalExpr e2) H0). rewrite H1 in H. eapply (eq_sym H). - destruct (weq (@truncMsb 1 (n+1) (evalExpr e2)) (ZToWord 1 0)); simpl; auto. + rewrite e. case_eq (wltu (evalExpr e1) (evalExpr e2)); intros; simpl; auto. * destruct (weq (@truncMsb 1 (n+1) (evalExpr e1)) (ZToWord 1 0)); simpl; auto. apply word0_neq in n1. assert (sth: (wordVal 1 (truncMsb (evalExpr e2)) < wordVal 1 (truncMsb (evalExpr e1)))%Z). { rewrite e, n1. reflexivity. } pose proof (@truncMsbLtFalse (n+1) 1 (evalExpr e2) (evalExpr e1) sth) as sth2. congruence. * destruct (weq (@truncMsb 1 (n+1) (evalExpr e1)) (ZToWord 1 0)); simpl; auto. tauto. + apply word0_neq in n0. apply word0_neq in n1. rewrite ?n0, ?n1. simpl. case_eq (wltu (evalExpr e1) (evalExpr e2)); intros; simpl; auto. Qed. Lemma mergeSeparatedBaseFile_noHides (rfl : list RegFileBase) : getHidden (mergeSeparatedBaseFile rfl) = nil. Proof. induction rfl; auto. Qed. Lemma mergeSeparatedBaseMod_noHides (bl : list BaseModule) : getHidden (mergeSeparatedBaseMod bl) = nil. Proof. induction bl; auto. Qed. Lemma getHidden_createHideMod (m : Mod) (hides : list string) : getHidden (createHideMod m hides) = hides++(getHidden m). Proof. induction hides; auto. - simpl; rewrite IHhides; reflexivity. Qed. Lemma getAllRegisters_createHideMod (m : Mod) (hides : list string) : getAllRegisters (createHideMod m hides) = getAllRegisters m. Proof. induction hides; auto. Qed. Lemma getAllRegisters_mergeBaseFile (rfl : list RegFileBase) : getAllRegisters (mergeSeparatedBaseFile rfl) = (concat (map getRegFileRegisters rfl)). Proof. induction rfl;auto. simpl; rewrite IHrfl; reflexivity. Qed. Lemma getAllRegisters_mergeBaseMod (bl : list BaseModule) : getAllRegisters (mergeSeparatedBaseMod bl) = (concat (map getRegisters bl)). Proof. induction bl; auto. simpl; rewrite IHbl; reflexivity. Qed. Lemma getAllMethods_createHideMod (m : Mod) (hides : list string) : getAllMethods (createHideMod m hides) = getAllMethods m. Proof. induction hides; auto. Qed. Lemma getAllMethods_mergeBaseFile (rfl : list RegFileBase) : getAllMethods (mergeSeparatedBaseFile rfl) = (concat (map getRegFileMethods rfl)). Proof. induction rfl;auto. simpl; rewrite IHrfl; reflexivity. Qed. Lemma getAllMethods_mergeBaseMod (bl : list BaseModule) : getAllMethods (mergeSeparatedBaseMod bl) = (concat (map getMethods bl)). Proof. induction bl; auto. simpl; rewrite IHbl; reflexivity. Qed. Lemma getAllRules_createHideMod (m : Mod) (hides : list string) : getAllRules (createHideMod m hides) = getAllRules m. Proof. induction hides; auto. Qed. Lemma getAllRules_mergeBaseFile (rfl : list RegFileBase) : getAllRules (mergeSeparatedBaseFile rfl) = nil. Proof. induction rfl;auto. Qed. Lemma getAllRules_mergeBaseMod (bl : list BaseModule) : getAllRules (mergeSeparatedBaseMod bl) = (concat (map getRules bl)). Proof. induction bl; auto. simpl; rewrite IHbl; reflexivity. Qed. Lemma separateBaseMod_flatten (m : Mod) : getAllRegisters m [=] getAllRegisters (mergeSeparatedMod (separateMod m)). Proof. unfold mergeSeparatedMod. rewrite getAllRegisters_createHideMod. unfold separateMod; simpl. rewrite getAllRegisters_mergeBaseFile, getAllRegisters_mergeBaseMod. induction m. - destruct m; simpl; repeat rewrite app_nil_r; reflexivity. - simpl; assumption. - simpl in *. destruct (separateBaseMod m1), (separateBaseMod m2). simpl in *. repeat rewrite map_app, concat_app; rewrite IHm1, IHm2. repeat rewrite <- app_assoc; apply Permutation_app_head. repeat rewrite app_assoc; apply Permutation_app_tail. apply Permutation_app_comm. Qed. Lemma separateBaseModule_flatten_Methods (m : Mod) : getAllMethods m [=] getAllMethods (mergeSeparatedMod (separateMod m)). Proof. unfold mergeSeparatedMod. rewrite getAllMethods_createHideMod. unfold separateMod; simpl. rewrite getAllMethods_mergeBaseFile, getAllMethods_mergeBaseMod. induction m. - destruct m; simpl; repeat rewrite app_nil_r; reflexivity. - simpl; assumption. - simpl in *. destruct (separateBaseMod m1), (separateBaseMod m2). simpl in *. repeat rewrite map_app, concat_app; rewrite IHm1, IHm2. repeat rewrite <- app_assoc; apply Permutation_app_head. repeat rewrite app_assoc; apply Permutation_app_tail. apply Permutation_app_comm. Qed. Lemma separateBaseModule_flatten_Rules (m : Mod) : getAllRules m [=] getAllRules (mergeSeparatedMod (separateMod m)). Proof. unfold mergeSeparatedMod. rewrite getAllRules_createHideMod. unfold separateMod; simpl. rewrite getAllRules_mergeBaseFile, getAllRules_mergeBaseMod; simpl. induction m. - destruct m; simpl; repeat rewrite app_nil_r; reflexivity. - simpl; assumption. - simpl in *. destruct (separateBaseMod m1), (separateBaseMod m2). simpl in *. repeat rewrite map_app, concat_app; rewrite IHm1, IHm2. reflexivity. Qed. Lemma separateBaseModule_flatten_Hides (m : Mod) : getHidden m [=] getHidden (mergeSeparatedMod (separateMod m)). Proof. unfold mergeSeparatedMod. rewrite getHidden_createHideMod;simpl. rewrite mergeSeparatedBaseFile_noHides. rewrite mergeSeparatedBaseMod_noHides. repeat rewrite app_nil_r. reflexivity. Qed. Lemma dec_def_notHidden f m: (In f (map fst (getAllMethods m)) /\ ~ In f (getHidden m)) \/ (~ In f (map fst (getAllMethods m))) \/ (In f (map fst (getAllMethods m)) /\ In f (getHidden m)). Proof. destruct (in_dec string_dec f (map fst (getAllMethods m))), (in_dec string_dec f (getHidden m)); auto. Qed. Lemma NotInDef_ZeroExecs_Trace: forall (m : Mod) (o : RegsT) lss (ls : list FullLabel) (f : string * {x : Kind * Kind & SignT x}), Trace m o lss -> ~ In (fst f) (map fst (getAllMethods m)) -> forall i, nth_error lss i = Some ls -> getNumExecs f ls = 0%Z. Proof. induction 1; subst; simpl; auto; intros; simpl in *. - destruct i; simpl in *; discriminate. - specialize (IHTrace H0). destruct i; simpl in *. + inv H1. eapply NotInDef_ZeroExecs_Step; eauto. + eauto. Qed. Lemma NotInDef_ZeroExecs_Trace' : forall (m : Mod) (o : RegsT) lss (ls : list FullLabel) (f : string * {x : Kind * Kind & SignT x}), Trace m o lss -> ~ In (fst f, projT1 (snd f)) (getKindAttr (getAllMethods m)) -> forall i, nth_error lss i = Some ls -> getNumExecs f ls = 0%Z. Proof. induction 1; subst; simpl; auto; intros; simpl in *. - destruct i; simpl in *; discriminate. - specialize (IHTrace H0). destruct i; simpl in *. + inv H1. eapply NotInDef_ZeroExecs_Step'; eauto. + eauto. Qed. Section ModularSubstitution. Variable a b a' b': Mod. Variable SameList_a: forall (x : MethT), (In (fst x, projT1 (snd x)) (getKindAttr (getAllMethods a)) /\ ~ In (fst x) (getHidden a)) <-> (In (fst x, projT1 (snd x)) (getKindAttr (getAllMethods a')) /\ ~ In (fst x) (getHidden a')). Variable SameList_b: forall (x : MethT), (In (fst x, projT1 (snd x)) (getKindAttr (getAllMethods b)) /\ ~ In (fst x) (getHidden b)) <-> (In (fst x, projT1 (snd x)) (getKindAttr (getAllMethods b')) /\ ~ In (fst x) (getHidden b')). Variable wfAConcatB: WfMod type (ConcatMod a b). Variable wfA'ConcatB': WfMod type (ConcatMod a' b'). Theorem ModularSubstitution: TraceInclusion a a' -> TraceInclusion b b' -> TraceInclusion (ConcatMod a b) (ConcatMod a' b'). Proof. assert (WfConcat1: WfConcat type a b) by (intros; specialize (wfAConcatB); inv wfAConcatB; auto). assert (WfConcat2: WfConcat type b a) by (intros; specialize (wfAConcatB); inv wfAConcatB; auto). assert (WfConcat0: WfConcat type a' b') by (intros; specialize (wfA'ConcatB'); inv wfA'ConcatB'; auto). assert (WfConcat3: WfConcat type b' a') by (intros; specialize (wfA'ConcatB'); inv wfA'ConcatB'; auto). pose proof (wfAConcatB) as wfAConcatB_dup. pose proof (wfA'ConcatB') as wfA'ConcatB'_dup. inv wfAConcatB_dup. inv wfA'ConcatB'_dup. unfold TraceInclusion, WeakInclusion,getListFullLabel_diff in *; intros. pose proof (SplitTrace HDisjRegs HDisjRules HDisjMeths H1); dest. specialize (@H _ _ H2). specialize (@H0 _ _ H3). dest. exists (x1 ++ x). exists (map (fun x => fst x ++ snd x) (List.combine x2 x0)). pose proof H9 as sth1. pose proof H7 as sth2. rewrite map_length in H9, H7. rewrite H9 in H7. rewrite mapProp_nthProp in H5. repeat split. - apply JoinTrace; auto; unfold nthProp, nthProp2 in *; intros; auto. specialize (H10 i); specialize (H8 i); specialize (H5 i). rewrite nth_error_map in H10, H8; case_eq (nth_error x2 i); case_eq (nth_error x0 i); case_eq (nth_error ls1 i); intros; try congruence; auto; [rewrite H11, H12, H13 in *; dest| solve [exfalso; apply (nth_error_len _ _ _ H11 H13 H9)]]. Opaque MatchingExecCalls_Concat. repeat split; intros. Transparent MatchingExecCalls_Concat. + unfold MatchingExecCalls_Concat in *; intros. repeat match goal with | H : forall (x: MethT), _ |- _ => specialize (H f) end; try specialize (HDisjMeths (fst f)); try specialize (HDisjMeths0 (fst f)); try specialize (SameList_a (fst f)); try specialize (SameList_b (fst f)); try specialize (Subset_a (fst f)); try specialize (Subset_b (fst f)). specialize (getNumExecs_nonneg f l1) as P1; rewrite Z.lt_eq_cases in P1; destruct P1; [specialize (Trace_meth_InExec' H _ _ H13 H21) as P2; clear - HDisjMeths0 P2 H20; apply (in_map fst) in H20; rewrite fst_getKindAttr in H20; tauto|]. specialize (getNumCalls_nonneg f l1) as P1; rewrite Z.lt_eq_cases in P1; destruct P1;[|symmetry in H22; contradiction]. rewrite <- H21 in H10; simpl in H10. specialize (getNumExecs_nonneg f (filterExecs id a l)) as P1. specialize (getNumCalls_nonneg f (filterExecs id a l)) as P2. assert (getNumCalls f (filterExecs id a l) <> 0%Z);[clear - P1 P2 H22 H10;Omega.omega|]. specialize (H5 H23). assert (helper: (getNumExecs f (filterExecs id a l) < getNumCalls f (filterExecs id a l))%Z) by Omega.omega. pose proof (Trace_meth_InCall_InDef_InExec H2 f i) as sth10. pose proof (map_nth_error (filterExecs id a) _ _ H11) as sth11. specialize (sth10 _ sth11). pose proof (in_dec (prod_dec string_dec Signature_dec) (fst f, projT1 (snd f)) (getKindAttr (getAllMethods a))) as [th1 | th2]. * clear - H11 H2 helper th1 sth10 sth11. specialize (sth10 th1). pose proof (Trace_meth_InCall_InDef_InExec H2 f i) as sth0. Omega.omega. * pose proof (NotInDef_ZeroExecs_Trace' f H2 th2 _ sth11) as sth12. assert (sth13: (getNumCalls f (filterExecs id a l) > 0)%Z) by (Omega.omega). rewrite sth12 in *. assert (sth14: getNumCalls f (filterExecs id a l) = getNumCalls f l1) by Omega.omega. destruct (in_dec (prod_dec string_dec Signature_dec) (fst f, projT1 (snd f)) (getKindAttr (getAllMethods b))) as [ez|hard]. -- specialize (H5 ez); dest. rewrite sth14 in *. split; [tauto |Omega.omega]. -- destruct (in_dec string_dec (fst f) (getHidden b')) as [lhs | rhs]; [ |tauto ]. apply (in_map fst) in H20; rewrite fst_getKindAttr in H20. pose proof (WfConcats_Trace H WfConcat0 _ H13 f lhs). Omega.omega. + unfold MatchingExecCalls_Concat in *; intros. repeat match goal with | H : forall (x: MethT), _ |- _ => specialize (H f) end; try specialize (HDisjMeths (fst f)); try specialize (HDisjMeths0 (fst f)); try specialize (SameList_a (fst f)); try specialize (SameList_b (fst f)); try specialize (Subset_a (fst f)); try specialize (Subset_b (fst f)). specialize (getNumExecs_nonneg f l0) as P1; rewrite Z.lt_eq_cases in P1; destruct P1; [specialize (Trace_meth_InExec' H0 _ _ H12 H21) as P2; clear - HDisjMeths0 P2 H20; apply (in_map fst) in H20; rewrite fst_getKindAttr in H20; tauto|]. specialize (getNumCalls_nonneg f l0) as P1; rewrite Z.lt_eq_cases in P1; destruct P1;[|symmetry in H22; contradiction]. rewrite <- H21 in H8; simpl in H8. specialize (getNumExecs_nonneg f (filterExecs id b l)) as P1. specialize (getNumCalls_nonneg f (filterExecs id b l)) as P2. assert (getNumCalls f (filterExecs id b l) <> 0%Z);[clear - P1 P2 H22 H8;Omega.omega|]. specialize (H14 H23). assert (helper: (getNumExecs f (filterExecs id b l) < getNumCalls f (filterExecs id b l))%Z) by Omega.omega. pose proof (Trace_meth_InCall_InDef_InExec H3 f i) as sth10. pose proof (map_nth_error (filterExecs id b) _ _ H11) as sth11. specialize (sth10 _ sth11). pose proof (in_dec (prod_dec string_dec Signature_dec) (fst f, projT1 (snd f)) (getKindAttr (getAllMethods b))) as [th1 | th2]. * clear - H11 H3 helper th1 sth10 sth11. specialize (sth10 th1). pose proof (Trace_meth_InCall_InDef_InExec H3 f i) as sth0. Omega.omega. * pose proof (NotInDef_ZeroExecs_Trace' f H3 th2 _ sth11) as sth12. assert (sth13: (getNumCalls f (filterExecs id b l) > 0)%Z) by (Omega.omega). rewrite sth12 in *. assert (sth14: getNumCalls f (filterExecs id b l) = getNumCalls f l0) by Omega.omega. destruct (in_dec (prod_dec string_dec Signature_dec) (fst f, projT1 (snd f)) (getKindAttr (getAllMethods a))) as [ez|hard]. -- specialize (H14 ez); dest. rewrite sth14 in *. split; [tauto|Omega.omega]. -- destruct (in_dec string_dec (fst f) (getHidden a')) as [lhs | rhs]; [ | tauto]. pose proof (WfConcats_Trace H0 WfConcat3 _ H12 f lhs). Omega.omega. + destruct x3, x4, p, p0, r1, r2; simpl; auto. pose proof (in_map (fun x => fst (snd x)) _ _ H19) as sth3. pose proof (in_map (fun x => fst (snd x)) _ _ H20) as sth4. simpl in *. assert (sth5: exists rle, In (Rle rle) (map (fun x => fst (snd x)) (filterExecs id a l))) by (clear - H18 sth3; eauto). assert (sth6: exists rle, In (Rle rle) (map (fun x => fst (snd x)) (filterExecs id b l))) by (clear - H17 sth4; eauto). dest. rewrite in_map_iff in *; dest. specialize (H15 _ _ H24 H23). rewrite H22, H21 in *. assumption. - rewrite map_length. rewrite length_combine_cond; congruence. - unfold nthProp, nthProp2 in *; intros. specialize (H10 i); specialize (H8 i); specialize (H5 i). rewrite nth_error_map in *. simpl in *. case_eq (nth_error ls1 i); intros; rewrite H11 in *; auto. setoid_rewrite (nth_error_combine (fun x3 => fst x3 ++ snd x3) _ i x2 x0); auto. case_eq (nth_error x2 i); case_eq (nth_error x0 i); intros; auto; rewrite H12, H13 in *; simpl in *; intros. split; intros. + dest. rewrite H16 at 1 2. repeat rewrite getNumExecs_app, getNumCalls_app. specialize (H8 f);specialize (H10 f). clear - H8 H10; Omega.omega. + dest. rewrite H17. rewrite map_app, in_app_iff in *; setoid_rewrite in_app_iff. clear - H19 H18 H14. destruct H14. specialize (H19 (ex_intro _ x3 H )); dest; eauto. specialize (H18 (ex_intro _ x3 H )); dest; eauto. Qed. End ModularSubstitution. Section ModularSubstitution_new. Variable a b a' b': Mod. Variable SameList_a: forall (x : MethT), (In (fst x, projT1 (snd x)) (getKindAttr (getAllMethods a)) /\ ~ In (fst x) (getHidden a)) <-> (In (fst x, projT1 (snd x)) (getKindAttr (getAllMethods a')) /\ ~ In (fst x) (getHidden a')). Variable SameList_b: forall (x : MethT), (In (fst x, projT1 (snd x)) (getKindAttr (getAllMethods b)) /\ ~ In (fst x) (getHidden b)) <-> (In (fst x, projT1 (snd x)) (getKindAttr (getAllMethods b')) /\ ~ In (fst x) (getHidden b')). Variable wfAConcatB: WfMod_new type (ConcatMod a b). Variable wfA'ConcatB': WfMod_new type (ConcatMod a' b'). Theorem ModularSubstitution_new : TraceInclusion a a' -> TraceInclusion b b' -> TraceInclusion (ConcatMod a b) (ConcatMod a' b'). Proof. rewrite WfMod_new_WfMod_iff in wfAConcatB, wfA'ConcatB'. apply ModularSubstitution; auto. Qed. End ModularSubstitution_new. Section Fold. Variable k: Kind. Variable f: LetExprSyntax type k -> LetExprSyntax type k -> LetExprSyntax type k. Variable fEval: type k -> type k -> type k. Variable fEval_f: forall x y, evalLetExpr (f x y) = fEval (evalLetExpr x) (evalLetExpr y). Lemma evalFoldLeft_Let ls: forall seed, evalLetExpr (fold_left f ls seed) = fold_left fEval (map (@evalLetExpr _) ls) (evalLetExpr seed). Proof. induction ls; simpl; auto; intros. rewrite IHls; simpl. rewrite fEval_f. reflexivity. Qed. Lemma evalFoldRight_Let ls: forall seed, evalLetExpr (fold_right f seed ls) = fold_right fEval (evalLetExpr seed) (map (@evalLetExpr _) ls). Proof. induction ls; simpl; auto; intros. rewrite fEval_f. rewrite IHls; simpl. reflexivity. Qed. Local Ltac name_term n t H := assert (H: exists n', n' = t); try (exists t; reflexivity); destruct H as [n H]. Lemma evalFoldTree_Let ls: forall seed, evalLetExpr (fold_tree f seed ls) = fold_tree fEval (evalLetExpr seed) (map (@evalLetExpr _) ls). Proof. assert (exists l, length ls <= l) as [l K] by (exists (length ls); auto). revert ls K. induction l as [| l]; intros * K. - assert (A1: length ls = 0) by omega. apply length_zero_iff_nil in A1. now subst ls. - destruct ls as [| x1 xs]. now simpl. destruct xs as [| x2 xs]. intros. simpl. rewrite ?fold_tree_equation. auto. intros. rewrite fold_tree_equation. name_term tpl (unapp_half (x1::x2::xs)) Tpl; rewrite <- Tpl; destruct tpl as [m1 m2]. simpl in K. assert (K': S (length xs) <= l) by (rewrite le_S_n; auto); clear K; rename K' into K. assert (length m1 <= length (x2::xs) /\ length m2 <= length (x2::xs)) as [A1 A2]. { symmetry in Tpl. apply unapp_half_nonnil_reduces in Tpl; auto. 2: simpl; omega. simpl in *. omega. } simpl in A1, A2. assert (A3: length m1 <= l) by omega; clear A1. assert (A4: length m2 <= l) by omega; clear A2. remember (f (fold_tree f seed m1) (fold_tree f seed m2)) as sth. rewrite fold_tree_equation. simpl. apply unapp_half_map with (f := (@evalLetExpr _)) in Tpl. simpl in Tpl. rewrite <- Tpl. rewrite Heqsth; clear Heqsth. rewrite <- ?IHl; auto. destruct xs; simpl; auto. Qed. Variable fComm: forall a b, fEval a b = fEval b a. Variable fAssoc: forall a b c, fEval (fEval a b) c = fEval a (fEval b c). Variable unit: LetExprSyntax type k. Variable fUnit: forall x, fEval (evalLetExpr unit) x = x. Lemma evalFoldTree_evalFoldLeft ls: evalLetExpr (fold_tree f unit ls) = evalLetExpr (fold_left f ls unit). Proof. rewrite evalFoldLeft_Let. rewrite evalFoldTree_Let. rewrite fold_left_fold_tree; auto. Qed. Lemma evalFoldTree_evalFoldRight ls: evalLetExpr (fold_tree f unit ls) = evalLetExpr (fold_right f unit ls). Proof. rewrite evalFoldRight_Let. rewrite evalFoldTree_Let. rewrite fold_right_fold_tree; auto. Qed. End Fold. Section FoldExpr. Variable k: Kind. Variable f: Expr type (SyntaxKind k) -> Expr type (SyntaxKind k) -> Expr type (SyntaxKind k). Variable fEval: type k -> type k -> type k. Variable fEval_f: forall x y, evalExpr (f x y) = fEval (evalExpr x) (evalExpr y). Lemma evalFoldLeft_Expr ls: forall seed, evalExpr (fold_left f ls seed) = fold_left fEval (map (@evalExpr _) ls) (evalExpr seed). Proof. induction ls; simpl; auto; intros. rewrite IHls; simpl. rewrite fEval_f. reflexivity. Qed. Lemma evalFoldRight_Expr ls: forall seed, evalExpr (fold_right f seed ls) = fold_right fEval (evalExpr seed) (map (@evalExpr _) ls). Proof. induction ls; simpl; auto; intros. rewrite fEval_f. rewrite IHls; simpl. reflexivity. Qed. Local Ltac name_term n t H := assert (H: exists n', n' = t); try (exists t; reflexivity); destruct H as [n H]. Lemma evalFoldTree_Expr ls: forall seed, evalExpr (fold_tree f seed ls) = fold_tree fEval (evalExpr seed) (map (@evalExpr _) ls). Proof. assert (exists l, length ls <= l) as [l K] by (exists (length ls); auto). revert ls K. induction l as [| l]; intros * K. - assert (A1: length ls = 0) by omega. apply length_zero_iff_nil in A1. now subst ls. - destruct ls as [| x1 xs]. now simpl. destruct xs as [| x2 xs]. intros. simpl. rewrite ?fold_tree_equation. auto. intros. rewrite fold_tree_equation. name_term tpl (unapp_half (x1::x2::xs)) Tpl; rewrite <- Tpl; destruct tpl as [m1 m2]. simpl in K. assert (K': S (length xs) <= l) by (rewrite le_S_n; auto); clear K; rename K' into K. assert (length m1 <= length (x2::xs) /\ length m2 <= length (x2::xs)) as [A1 A2]. { symmetry in Tpl. apply unapp_half_nonnil_reduces in Tpl; auto. 2: simpl; omega. simpl in *. omega. } simpl in A1, A2. assert (A3: length m1 <= l) by omega; clear A1. assert (A4: length m2 <= l) by omega; clear A2. remember (f (fold_tree f seed m1) (fold_tree f seed m2)) as sth. rewrite fold_tree_equation. simpl. apply unapp_half_map with (f := (@evalExpr _)) in Tpl. simpl in Tpl. rewrite <- Tpl. rewrite Heqsth; clear Heqsth. rewrite <- ?IHl; auto. destruct xs; simpl; auto. Qed. Variable fComm: forall a b, fEval a b = fEval b a. Variable fAssoc: forall a b c, fEval (fEval a b) c = fEval a (fEval b c). Variable unit: Expr type (SyntaxKind k). Variable fUnit: forall x, fEval (evalExpr unit) x = x. Lemma evalExprFoldTree_evalExprFoldLeft ls: evalExpr (fold_tree f unit ls) = evalExpr (fold_left f ls unit). Proof. rewrite evalFoldLeft_Expr. rewrite evalFoldTree_Expr. rewrite fold_left_fold_tree; auto. Qed. Lemma evalExprFoldTree_evalExprFoldRight ls: evalExpr (fold_tree f unit ls) = evalExpr (fold_right f unit ls). Proof. rewrite evalFoldRight_Expr. rewrite evalFoldTree_Expr. rewrite fold_right_fold_tree; auto. Qed. End FoldExpr. Section SimulationZeroAct. Variable imp spec: BaseModuleWf type. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable NoMeths: getMethods imp = []. Variable NoMethsSpec: getMethods spec = []. Variable simulation: forall oImp rImp uImp rleImp csImp oImp' aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> UpdRegs [uImp] oImp oImp' -> forall oSpec, simRel oImp oSpec -> ((simRel oImp' oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel oImp' oSpec')). Theorem simulationZeroAct: TraceInclusion (Base imp) (Base spec). Proof. pose proof (wfBaseModule imp) as wfImp. pose proof (wfBaseModule spec) as wfSpec. inv wfImp. inv wfSpec. dest. apply simulationZero with (simRel := simRel); auto; simpl; intros. inv H9; [|discriminate]. inv HLabel. specialize (@simulation oImp reads u rn cs oImp' rb HInRules HAction H10 _ H11). pose proof (simRelGood H11). destruct simulation. - left; auto. - right. dest. exists x2, x, x3. split. + pose proof (WfActionT_ReadsWellDefined _ (H1 _ H12) H13) as sth1. pose proof (WfActionT_WritesWellDefined _ (H1 _ H12) H13) as sth2. repeat econstructor; eauto. + split; assumption. Qed. End SimulationZeroAct. Section SimulationZeroAct_new. Variable imp spec: BaseModuleWf_new type. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable NoMeths: getMethods imp = []. Variable NoMethsSpec: getMethods spec = []. Variable simulation: forall oImp rImp uImp rleImp csImp oImp' aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> UpdRegs [uImp] oImp oImp' -> forall oSpec, simRel oImp oSpec -> ((simRel oImp' oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel oImp' oSpec')). Theorem simulationZeroAct_new : TraceInclusion (Base imp) (Base spec). Proof. destruct imp, spec. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as x. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new0)) as y. eapply (simulationZeroAct x y); eauto. Qed. End SimulationZeroAct_new. Section LemmaNoSelfCall. Variable m: BaseModule. Lemma NoSelfCallAction ls k (a: ActionT type k): NoCallActionT ls a -> forall o reads u cs ret, SemAction o a reads u cs ret -> forall f, In (fst f, projT1 (snd f)) (getKindAttr ls) -> getNumFromCalls f cs = 0%Z. Proof. intro. induction H; simpl; auto; intros; simpl in *. - inv H2. EqDep_subst; simpl. specialize (H1 _ _ _ _ _ _ HSemAction _ H3). rewrite H1 in *. match goal with | |- (if ?P then _ else _) = _ => destruct P end; auto; subst; simpl in *. tauto. - inv H1; EqDep_subst; simpl in *. eapply H0; eauto. - inv H2; EqDep_subst; simpl in *. rewrite getNumFromCalls_app. specialize (H1 _ _ _ _ _ _ HSemActionCont _ H3). specialize (IHNoCallActionT _ _ _ _ _ HSemAction _ H3). rewrite H1, IHNoCallActionT. auto. - inv H1; EqDep_subst; simpl in *. eapply H0; eauto. - inv H1; EqDep_subst; simpl in *. eapply H0; eauto. - inv H0; EqDep_subst; simpl in *. eapply IHNoCallActionT; eauto. - inv H3; EqDep_subst; simpl in *; rewrite getNumFromCalls_app. + specialize (IHNoCallActionT1 _ _ _ _ _ HAction _ H4). specialize (H0 _ _ _ _ _ _ HSemAction _ H4). rewrite H0, IHNoCallActionT1. auto. + specialize (IHNoCallActionT2 _ _ _ _ _ HAction _ H4). specialize (H0 _ _ _ _ _ _ HSemAction _ H4). rewrite H0, IHNoCallActionT2. auto. - inv H0; EqDep_subst; simpl in *. eapply IHNoCallActionT; eauto. - inv H; EqDep_subst; simpl in *. auto. Qed. Lemma LetExprNoCallActionT k (e: LetExprSyntax type k): forall ls, NoCallActionT ls (convertLetExprSyntax_ActionT e). Proof. induction e; simpl; auto; intros; constructor; auto. Qed. Lemma NoSelfCallRule_Impl r: NoSelfCallBaseModule m -> In r (getRules m) -> forall o reads u cs ret, SemAction o (snd r type) reads u cs ret -> forall f, In (fst f, projT1 (snd f)) (getKindAttr (getMethods m)) -> getNumFromCalls f cs = 0%Z. Proof. intros. destruct H. unfold NoSelfCallRulesBaseModule, NoSelfCallMethsBaseModule in *. specialize (H _ type H0); simpl in *. eapply NoSelfCallAction; eauto. Qed. Lemma NoSelfCallMeth_Impl f: NoSelfCallBaseModule m -> In f (getMethods m) -> forall o reads u cs arg ret, SemAction o (projT2 (snd f) type arg) reads u cs ret -> forall g, In (fst g, projT1 (snd g)) (getKindAttr (getMethods m)) -> getNumFromCalls g cs = 0%Z. Proof. intros. destruct H. unfold NoSelfCallRulesBaseModule, NoSelfCallMethsBaseModule in *. specialize (H3 _ type H0 arg); simpl in *. eapply NoSelfCallAction; eauto. Qed. End LemmaNoSelfCall. Section SimulationGen. Variable imp spec: BaseModuleWf type. Variable NoSelfCalls: NoSelfCallBaseModule spec. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable simulationRule: forall oImp rImp uImp rleImp csImp oImp' aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> UpdRegs [uImp] oImp oImp' -> forall oSpec, simRel oImp oSpec -> ((simRel oImp' oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel oImp' oSpec')). Variable simulationMeth: forall oImp rImp uImp meth csImp oImp' sign aImp arg ret, In (meth, existT _ sign aImp) (getMethods imp) -> SemAction oImp (aImp type arg) rImp uImp csImp ret -> UpdRegs [uImp] oImp oImp' -> forall oSpec, simRel oImp oSpec -> exists aSpec rSpec uSpec, In (meth, existT _ sign aSpec) (getMethods spec) /\ SemAction oSpec (aSpec type arg) rSpec uSpec csImp ret /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel oImp' oSpec'. Variable notMethMeth: forall oImp rImpl1 uImpl1 meth1 sign1 aImp1 arg1 ret1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (meth1, existT _ sign1 aImp1) (getMethods imp) -> SemAction oImp (aImp1 type arg1) rImpl1 uImpl1 csImp1 ret1 -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Variable notRuleMeth: forall oImp rImpl1 uImpl1 rleImpl1 aImp1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (rleImpl1, aImp1) (getRules imp) -> SemAction oImp (aImp1 type) rImpl1 uImpl1 csImp1 WO -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Lemma SubstepsSingle o l: Substeps imp o l -> length l <= 1. Proof. induction 1; simpl; auto; intros; subst. - destruct ls; simpl in *; auto; simpl in *. assert (sth1: length ls = 0) by (simpl in *; Omega.omega). rewrite length_zero_iff_nil in sth1; subst; simpl in *. specialize (HNoRle p (or_introl eq_refl)). specialize (HDisjRegs p (or_introl eq_refl)). repeat destruct p; simpl in *. destruct r0; simpl in *; [tauto|]. inv H; [discriminate|]. destruct fb; simpl in *. destruct (@notRuleMeth _ _ _ _ _ _ _ _ _ _ _ _ _ _ HInRules HAction HInMeths HAction0) as [k [in1 in2]]. specialize (HDisjRegs k). inv HLabel. tauto. - destruct ls; simpl in *; auto; simpl in *. assert (sth1: length ls = 0) by (simpl in *; Omega.omega). rewrite length_zero_iff_nil in sth1; subst; simpl in *. specialize (HDisjRegs p (or_introl eq_refl)). repeat destruct p; simpl in *. inv H. + inv HLabel; simpl in *. inv HSubstep; try congruence. destruct fb. destruct (@notRuleMeth _ _ _ _ _ _ _ _ _ _ _ _ _ _ HInRules HAction0 HInMeths HAction) as [k [in1 in2]]. specialize (HDisjRegs k). tauto. + destruct ls; [| discriminate]. inv HLabel. destruct fb. destruct fb0. destruct (@notMethMeth _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ HInMeths HAction HInMeths0 HAction0) as [k [in1 in2]]. specialize (HDisjRegs k). tauto. Qed. Lemma InvertStep o l: l <> nil -> Step imp o l -> (exists r a reads upds calls, l = (upds, (Rle r, calls)) :: nil /\ In (r, a) (getRules imp) /\ SemAction o (a type) reads upds calls WO) \/ (exists f sign arg ret a reads upds calls, l = (upds, (Meth (f, existT SignT sign (arg, ret)), calls)) :: nil /\ In (f, existT MethodT sign a) (getMethods imp) /\ SemAction o (a type arg) reads upds calls ret). Proof. intros ? H. inv H. pose proof (SubstepsSingle HSubsteps). destruct l; simpl. - left; tauto. - simpl in H. assert (sth: Datatypes.length l = 0) by lia. rewrite length_zero_iff_nil in sth; subst; clear H0. destruct p. destruct p. destruct r0. + left. inv HSubsteps; inv HLabel. exists rn0, rb, reads, u, cs. repeat split; auto. + right. inv HSubsteps; inv HLabel. destruct fb. exists fn, x, argV, retV, m, reads, u, cs. repeat split; auto. Qed. Theorem simulationGen: TraceInclusion (Base imp) (Base spec). Proof. pose proof (wfBaseModule imp) as wfImp. pose proof (wfBaseModule spec) as wfSpec. inv wfImp. inv wfSpec. dest. apply StepSimulation with (simRel := simRel); auto; simpl; intros. inv H9. pose proof (SubstepsSingle HSubsteps) as sth. destruct lImp; [tauto| simpl in *]. destruct lImp; simpl in *; [| Omega.omega]. repeat destruct p; simpl in *. inv HSubsteps; inv HLabel; simpl in *. - destruct (@simulationRule _ _ _ _ _ _ _ HInRules HAction H11 _ H12); dest; subst. exists nil, oSpec. split. + constructor; auto; simpl in *. * constructor 1; auto. eapply simRelGood; eauto. * unfold MatchingExecCalls_Base, getNumCalls, getNumExecs; intros; simpl. Omega.omega. + simpl. split. * unfold UpdRegs; repeat split; auto; intros. right; split; try intro; simpl in *; auto. dest; auto. * split; auto. unfold WeakInclusion; simpl; intros. unfold getListFullLabel_diff; simpl. split; intros; dest; auto. tauto. + exists [(x2, (Rle x, cs))], x3; simpl. split. * constructor; auto. -- econstructor 2; eauto. ++ eapply WfActionT_ReadsWellDefined; eauto. ++ eapply WfActionT_WritesWellDefined; eauto. ++ simpl; intros; tauto. ++ constructor 1; auto. eapply simRelGood; eauto. -- unfold MatchingExecCalls_Base; unfold getNumCalls, getNumExecs; simpl; intros. rewrite app_nil_r. assert (th1: forall x, (x = 0)%Z -> (x <= 0)%Z) by (intros; Omega.omega). apply th1; clear th1. eapply NoSelfCallRule_Impl; eauto. * split; auto. split; auto. unfold WeakInclusion; simpl; intros. split; intros; auto. exists rn. left; auto. - destruct fb. destruct (@simulationMeth _ _ _ _ _ _ _ _ _ _ HInMeths HAction H11 _ H12); dest; subst. exists [(x2, (Meth (fn, existT _ x (argV, retV)), cs))], x3; simpl. split. * constructor; auto. -- econstructor 3; eauto. ++ eapply WfActionT_ReadsWellDefined; eauto. ++ eapply WfActionT_WritesWellDefined; eauto. ++ simpl; intros; tauto. ++ constructor 1; auto. eapply simRelGood; eauto. -- unfold MatchingExecCalls_Base; unfold getNumCalls, getNumExecs; simpl; intros. rewrite app_nil_r. assert (th1: forall x, (x = 0)%Z -> (x <= 0)%Z) by (intros; Omega.omega). match goal with | |- (_ <= if ?P then _ else _)%Z => destruct P; subst; simpl in * end. ++ assert (th2: forall x, (x = 0)%Z -> (x <= 1)%Z) by (intros; Omega.omega). apply th2; clear th2. eapply NoSelfCallMeth_Impl; eauto. ++ apply th1; clear th1. eapply NoSelfCallMeth_Impl; eauto. * split; auto. split; auto. unfold WeakInclusion; simpl; intros. split; intros; auto. Qed. End SimulationGen. Section SimulationGen_new. Variable imp spec: BaseModuleWf_new type. Variable NoSelfCalls: NoSelfCallBaseModule spec. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable simulationRule: forall oImp rImp uImp rleImp csImp oImp' aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> UpdRegs [uImp] oImp oImp' -> forall oSpec, simRel oImp oSpec -> ((simRel oImp' oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel oImp' oSpec')). Variable simulationMeth: forall oImp rImp uImp meth csImp oImp' sign aImp arg ret, In (meth, existT _ sign aImp) (getMethods imp) -> SemAction oImp (aImp type arg) rImp uImp csImp ret -> UpdRegs [uImp] oImp oImp' -> forall oSpec, simRel oImp oSpec -> exists aSpec rSpec uSpec, In (meth, existT _ sign aSpec) (getMethods spec) /\ SemAction oSpec (aSpec type arg) rSpec uSpec csImp ret /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel oImp' oSpec'. Variable notMethMeth: forall oImp rImpl1 uImpl1 meth1 sign1 aImp1 arg1 ret1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (meth1, existT _ sign1 aImp1) (getMethods imp) -> SemAction oImp (aImp1 type arg1) rImpl1 uImpl1 csImp1 ret1 -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Variable notRuleMeth: forall oImp rImpl1 uImpl1 rleImpl1 aImp1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (rleImpl1, aImp1) (getRules imp) -> SemAction oImp (aImp1 type) rImpl1 uImpl1 csImp1 WO -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Theorem simulationGen_new : TraceInclusion (Base imp) (Base spec). Proof. destruct imp, spec. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as x. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new0)) as y. eapply (simulationGen x y); eauto. Qed. End SimulationGen_new. Lemma findRegs_Some u: NoDup (map fst u) -> forall s v, In (s, v) u <-> findReg s u = Some v. Proof. induction u; simpl; split; auto; intros; auto; try (tauto || discriminate). - destruct H0; subst; simpl. + rewrite String.eqb_refl; simpl; tauto. + destruct a; simpl in *. inv H. specialize (IHu H4). destruct (String.eqb s s0) eqn:G; [rewrite String.eqb_eq in G|]; subst; simpl; auto; subst. * apply (in_map fst) in H0; simpl in *; tauto. * rewrite <- IHu; auto. - destruct a; simpl in *. destruct (String.eqb s s0) eqn:G; [rewrite String.eqb_eq in G|] ; simpl in *. inv H0; auto. inv H. specialize (IHu H4). rewrite <- IHu in H0. auto. Qed. Lemma InvProp A (P Q: A -> Prop): (forall x, P x <-> Q x) -> (forall x, ~ Q x <-> ~ P x). Proof. intros. firstorder. Qed. Lemma findRegs_None u: forall s, ~ In s (map fst u) <-> findReg s u = None. Proof. induction u; simpl; split; auto; destruct a; simpl; intros. - destruct (string_dec s s0); subst. + firstorder fail. + rewrite <- String.eqb_neq in n; rewrite n. rewrite <- IHu. firstorder fail. - destruct (String.eqb s s0) eqn:G; [rewrite String.eqb_eq in G|]; subst. + discriminate. + rewrite <- IHu in H. intro. rewrite String.eqb_neq in G; firstorder. Qed. Lemma NoDup_app A (l1: list (string * A)): forall l2, DisjKeyWeak l1 l2 -> NoDup (map fst l1) -> NoDup (map fst l2) -> NoDup (map fst (l1 ++ l2)). Proof. induction l1; unfold DisjKeyWeak; simpl; auto; rewrite ?app_nil_l, ?app_nil_r; intros; auto. inv H0. constructor. - intro. rewrite map_app in *. rewrite in_app_iff in H0. specialize (H (fst a) (or_introl eq_refl)). tauto. - eapply IHl1; auto. unfold DisjKeyWeak; firstorder fail. Qed. Lemma SemAction_NoDup_u k o (a: ActionT type k) readRegs u calls retl: SemAction o a readRegs u calls retl -> NoDup (map fst u). Proof. induction 1; simpl; auto; rewrite ?DisjKeyWeak_same in * by (apply string_dec); subst. - apply NoDup_app; auto. - simpl. constructor; auto. unfold key_not_In in *. intro. rewrite in_map_iff in H0; dest. destruct x; simpl in *; subst. firstorder fail. - apply NoDup_app; auto. - apply NoDup_app; auto. - simpl; constructor. Qed. Lemma NoDup_UpdRegs o: NoDup (map fst o) -> forall u o', NoDup (map fst u) -> UpdRegs [u] o o' -> o' = doUpdRegs u o. Proof. induction o; simpl; auto; intros. - inv H1; simpl in *. apply eq_sym in H2. apply map_eq_nil in H2. auto. - inv H1; simpl in *. destruct o'; simpl in *; [discriminate|]. inv H2. f_equal. + specialize (H3 (fst p) (snd p)). destruct p; simpl in *. specialize (H3 (or_introl eq_refl)). rewrite H4 in *. destruct H3. * dest. destruct H1; [subst|tauto]. rewrite findRegs_Some in H2; auto. rewrite H2; auto. * dest. assert (sth2: ~ In s (map fst u)) by firstorder. pose proof sth2 as sth3. rewrite findRegs_None in sth2. rewrite sth2. destruct H2; [congruence|]. inv H. apply (in_map fst) in H2; simpl in *. exfalso; tauto. + inv H. eapply IHo; eauto. constructor; auto; intros; simpl. specialize (H3 s v (or_intror H)). destruct H3; [tauto|]. dest. destruct H2; subst; simpl in *. * apply (in_map fst) in H; simpl in *. apply (f_equal (map fst)) in H6. rewrite ?map_map in *; simpl in *. assert (sth: forall A B, (fun (x: (A * B)) => fst x) = fst) by (intros; extensionality x; intros; reflexivity). rewrite ?sth in H6. rewrite <- H6 in H. tauto. * right; auto. Qed. Lemma findRegs_Some' u: forall s v, findReg s u = Some v -> In (s, v) u. Proof. induction u; simpl; auto; intros; auto; try (tauto || discriminate). destruct (String.eqb s (fst a)) eqn:G; [rewrite String.eqb_eq in G|]; subst; simpl in *. - inv H; auto. destruct a; auto. - specialize (IHu _ _ H). right; auto. Qed. Lemma doUpdRegs_enuf o u: getKindAttr o = getKindAttr (doUpdRegs u o) -> UpdRegs [u] o (doUpdRegs u o). Proof. induction o; simpl; auto; unfold UpdRegs; intros. - repeat split; simpl; auto. - inv H. specialize (IHo H3). simpl in *; intros. repeat split; auto; intros. + rewrite H1 at 1. rewrite H2 at 1. rewrite H3. auto. + unfold UpdRegs in *. dest. destruct H. * case_eq (findReg (fst a) u); intros; rewrite H5 in *; simpl in *. -- apply findRegs_Some' in H5. inv H; simpl in *. left; eexists; eauto. -- rewrite <- findRegs_None in H5 by auto; subst; simpl in *. right. split; try intro; auto; dest. destruct H; subst; auto. * specialize (H4 _ _ H). clear - H4; firstorder fail. Qed. Lemma UpdRegs_nil_nil_upd: forall o, NoDup (map fst o) -> forall o', UpdRegs [[]] o o' -> o = o'. Proof. unfold UpdRegs. intros. dest. simpl in *. assert (sth: forall s v, In (s, v) o' -> In (s, v) o). { intros. specialize (H1 s v H2). destruct H1; dest; try auto. destruct H1; subst; simpl in *; try tauto. } clear H1. generalize o' H H0 sth. clear o' H H0 sth. induction o; destruct o'; simpl; auto; intros. - discriminate. - discriminate. - inv H0. inv H. specialize (IHo _ H6 H4). destruct p, a; simpl in *; subst; auto; repeat f_equal; auto. + specialize (sth s s0 (or_introl eq_refl)). destruct sth. * inv H; subst; auto. * apply (in_map fst) in H; simpl in *; tauto. + eapply IHo; intros. specialize (sth _ _ (or_intror H)). destruct sth; [|auto]. inv H0; subst. apply (f_equal (map fst)) in H4. rewrite ?map_map in *; simpl in *. setoid_rewrite (functional_extensionality (fun x => fst x) fst) in H4; try tauto. apply (in_map fst) in H; simpl in *; congruence. Qed. Lemma getKindAttr_findReg_Some u: forall o: RegsT, (forall s v, In (s, v) u -> In (s, projT1 v) (getKindAttr o)) -> forall s v, findReg s u = Some v -> In (s, projT1 v) (getKindAttr o). Proof. intros. apply findRegs_Some' in H0. specialize (H _ _ H0); simpl in *. auto. Qed. Lemma getKindAttr_doUpdRegs' o: forall u, getKindAttr (doUpdRegs u o) = map (fun x => match findReg (fst x) u with | Some y => (fst x, projT1 y) | None => (fst x, projT1 (snd x)) end) o. Proof. induction o; simpl; auto; intros. case_eq (findReg (fst a) u); simpl; intros; f_equal; auto. Qed. Lemma forall_map A B (f g: A -> B) ls: (map f ls = map g ls) <-> forall x, In x ls -> f x = g x. Proof. induction ls; simpl; split; auto; intros; try tauto. - destruct H0; subst. + inv H. auto. + inv H. rewrite IHls in H3. eapply H3; eauto. - assert (sth1: f a = g a) by firstorder fail. assert (sth2: forall x, In x ls -> f x = g x) by firstorder fail. f_equal; auto. firstorder. Qed. Lemma KeyMatching_gen A B : forall (l : list (A * B)) (a b : A * B), NoDup (map fst l) -> In a l -> In b l -> fst a = fst b -> a = b. Proof. induction l; intros. - inversion H0. - destruct H0; destruct H1. + symmetry; rewrite <- H1; assumption. + rewrite (map_cons fst) in H. inversion H; subst. apply (in_map fst l b) in H1. apply False_ind. apply H5. destruct a0; destruct b; simpl in *. rewrite H2; assumption. + rewrite (map_cons fst) in H. inversion H; subst. apply (in_map fst l a0) in H0. apply False_ind; apply H5. destruct a0, b; simpl in *. rewrite <- H2; assumption. + inversion H; subst. apply IHl; auto. Qed. Lemma NoDup_map_fst {A B} {ls: list (A * B)}: NoDup (map fst ls) -> forall {a b c}, In (a, b) ls -> In (a, c) ls -> b = c. Proof. induction ls; simpl; auto; intros. - tauto. - inv H. specialize (@IHls H5). destruct H0, H1; subst; simpl in *. + inv H0. auto. + rewrite in_map_iff in H4. assert (sth: exists x, fst x = a0 /\ In x ls). { exists (a0, c); split; auto. } tauto. + rewrite in_map_iff in H4. assert (sth: exists x, fst x = a0 /\ In x ls). { exists (a0, b); split; auto. } tauto. + eapply IHls; eauto. Qed. Lemma getKindAttr_doUpdRegs o: NoDup (map fst o) -> forall u, (forall s v, In (s, v) u -> In (s, projT1 v) (getKindAttr o)) -> getKindAttr o = getKindAttr (doUpdRegs u o). Proof. intros. setoid_rewrite getKindAttr_doUpdRegs'. rewrite forall_map; intros. case_eq (findReg (fst x) u); intros; auto. destruct x; simpl in *. f_equal. destruct s1, s; simpl in *. pose proof (findRegs_Some' _ _ H2) as sth. specialize (H0 s0 (existT (fullType type) x0 f0) sth). rewrite in_map_iff in H0; dest. destruct x1; simpl in *. inv H0. pose proof (NoDup_map_fst H H3 H1). subst. auto. Qed. Lemma getKindAttr_doUpdRegs_app: forall regs upds1 upds2, NoDup (map fst regs) -> (forall (s : string) (v : {x : FullKind & fullType type x}), In (s, v) upds1 -> In (s, projT1 v) (getKindAttr regs)) -> (forall (s : string) (v : {x : FullKind & fullType type x}), In (s, v) upds2 -> In (s, projT1 v) (getKindAttr regs)) -> getKindAttr regs = getKindAttr (doUpdRegs (upds1 ++ upds2) regs). Proof. induction upds1; intros; simpl. { eapply getKindAttr_doUpdRegs; auto. } { rewrite getKindAttr_doUpdRegs'. rewrite forall_map; intros. case_eq (findReg (fst x) (a :: upds1 ++ upds2)); intros; auto. epose proof (findRegs_Some' _ _ H3) as inSome. clear H3. destruct x; simpl in *. f_equal. destruct s1, s; simpl in *. destruct inSome. { unshelve epose proof (H0 s0 (existT (fullType type) x0 f0) _) as H0; intuition auto. rewrite in_map_iff in H0; dest. destruct x1; simpl in *. inv H0. pose proof (NoDup_map_fst H H4 H2). subst. auto. } { assert (okApp: forall (s : string) (v : {x : FullKind & fullType type x}), In (s, v) (upds1 ++ upds2) -> In (s, projT1 v) (getKindAttr regs)). intros. edestruct (in_app_or _ _ _ H4). { eapply H0. auto. } { eapply H1. auto. } specialize (okApp s0 (existT (fullType type) x0 f0) H3). rewrite in_map_iff in okApp; dest. simpl in H4. inv H4. destruct x1. epose proof (NoDup_map_fst H H5 H2). subst. auto. } } Qed. Lemma doUpdRegs_UpdRegs' o: NoDup (map fst o) -> forall u, (forall s v, In (s, v) u -> In (s, projT1 v) (getKindAttr o)) -> UpdRegs [u] o (doUpdRegs u o). Proof. intros. eapply doUpdRegs_enuf; eauto. eapply getKindAttr_doUpdRegs; eauto. Qed. Lemma doUpdRegs_UpdRegs o: NoDup (map fst o) -> forall u, SubList (getKindAttr u) (getKindAttr o) -> UpdRegs [u] o (doUpdRegs u o). Proof. intros. eapply doUpdRegs_enuf; eauto. eapply getKindAttr_doUpdRegs; eauto; intros. apply (in_map (fun x => (fst x, projT1 (snd x)))) in H1; simpl in *. eapply H0; eauto. Qed. Section SimulationGeneralEx. Variable imp spec: BaseModuleWf type. Variable NoSelfCalls: NoSelfCallBaseModule spec. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable simulationRule: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel (doUpdRegs uImp oImp) oSpec')). Variable simulationMeth: forall oImp rImp uImp meth csImp sign aImp arg ret, In (meth, existT _ sign aImp) (getMethods imp) -> SemAction oImp (aImp type arg) rImp uImp csImp ret -> forall oSpec, simRel oImp oSpec -> exists aSpec rSpec uSpec, In (meth, existT _ sign aSpec) (getMethods spec) /\ SemAction oSpec (aSpec type arg) rSpec uSpec csImp ret /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel (doUpdRegs uImp oImp) oSpec'. Variable notMethMeth: forall oImp rImpl1 uImpl1 meth1 sign1 aImp1 arg1 ret1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (meth1, existT _ sign1 aImp1) (getMethods imp) -> SemAction oImp (aImp1 type arg1) rImpl1 uImpl1 csImp1 ret1 -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Variable notRuleMeth: forall oImp rImpl1 uImpl1 rleImpl1 aImp1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (rleImpl1, aImp1) (getRules imp) -> SemAction oImp (aImp1 type) rImpl1 uImpl1 csImp1 WO -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Theorem simulationGeneralEx: TraceInclusion (Base imp) (Base spec). Proof. eapply simulationGen; eauto; intros. - pose proof (SemAction_NoDup_u H0) as sth. pose proof (simRelImpGood H2) as sth2. apply (f_equal (map fst)) in sth2. rewrite ?map_map in *; simpl in *. assert (sth3: forall A B, (fun x: (A * B) => fst x) = fst) by (intros; extensionality x; intros; auto). destruct (wfBaseModule imp); dest. rewrite <- sth3 in H6. rewrite <- sth2 in H6. rewrite sth3 in H6. apply NoDup_UpdRegs in H1; subst; auto. eapply simulationRule; eauto. - pose proof (SemAction_NoDup_u H0) as sth. pose proof (simRelImpGood H2) as sth2. apply (f_equal (map fst)) in sth2. rewrite ?map_map in *; simpl in *. assert (sth3: forall A B, (fun x: (A * B) => fst x) = fst) by (intros; extensionality x; intros; auto). destruct (wfBaseModule imp); dest. rewrite <- sth3 in H6. rewrite <- sth2 in H6. rewrite sth3 in H6. apply NoDup_UpdRegs in H1; subst; auto. eapply simulationMeth; eauto. Qed. End SimulationGeneralEx. Section SimulationGeneralEx_new. Variable imp spec: BaseModuleWf_new type. Variable NoSelfCalls: NoSelfCallBaseModule spec. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable simulationRule: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel (doUpdRegs uImp oImp) oSpec')). Variable simulationMeth: forall oImp rImp uImp meth csImp sign aImp arg ret, In (meth, existT _ sign aImp) (getMethods imp) -> SemAction oImp (aImp type arg) rImp uImp csImp ret -> forall oSpec, simRel oImp oSpec -> exists aSpec rSpec uSpec, In (meth, existT _ sign aSpec) (getMethods spec) /\ SemAction oSpec (aSpec type arg) rSpec uSpec csImp ret /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel (doUpdRegs uImp oImp) oSpec'. Variable notMethMeth: forall oImp rImpl1 uImpl1 meth1 sign1 aImp1 arg1 ret1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (meth1, existT _ sign1 aImp1) (getMethods imp) -> SemAction oImp (aImp1 type arg1) rImpl1 uImpl1 csImp1 ret1 -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Variable notRuleMeth: forall oImp rImpl1 uImpl1 rleImpl1 aImp1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (rleImpl1, aImp1) (getRules imp) -> SemAction oImp (aImp1 type) rImpl1 uImpl1 csImp1 WO -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Theorem simulationGeneralEx_new: TraceInclusion (Base imp) (Base spec). Proof. destruct imp, spec. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as x. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new0)) as y. eapply (simulationGeneralEx x y); eauto. Qed. End SimulationGeneralEx_new. Section SimulationZeroA. Variable imp spec: BaseModuleWf type. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable NoMeths: getMethods imp = []. Variable NoMethsSpec: getMethods spec = []. Variable simulation: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel (doUpdRegs uImp oImp) oSpec')). Theorem simulationZeroA: TraceInclusion (Base imp) (Base spec). Proof. eapply simulationZeroAct; eauto; intros. pose proof (SemAction_NoDup_u H0) as sth. pose proof (simRelImpGood H2) as sth2. apply (f_equal (map fst)) in sth2. rewrite ?map_map in *; simpl in *. assert (sth3: forall A B, (fun x: (A * B) => fst x) = fst) by (intros; extensionality x; intros; auto). destruct (wfBaseModule imp); dest. rewrite <- sth3 in H6. rewrite <- sth2 in H6. rewrite sth3 in H6. apply NoDup_UpdRegs in H1; subst; auto. eapply simulation; eauto. Qed. End SimulationZeroA. Section SimulationZeroA_new. Variable imp spec: BaseModuleWf_new type. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable NoMeths: getMethods imp = []. Variable NoMethsSpec: getMethods spec = []. Variable simulation: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ exists oSpec', UpdRegs [uSpec] oSpec oSpec' /\ simRel (doUpdRegs uImp oImp) oSpec')). Theorem simulationZeroA_new: TraceInclusion (Base imp) (Base spec). Proof. destruct imp, spec. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as x. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new0)) as y. eapply (simulationZeroA x y); eauto. Qed. End SimulationZeroA_new. Section SimulationGeneral. Variable imp spec: BaseModuleWf type. Variable NoSelfCalls: NoSelfCallBaseModule spec. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable simulationRule: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec))). Variable simulationMeth: forall oImp rImp uImp meth csImp sign aImp arg ret, In (meth, existT _ sign aImp) (getMethods imp) -> SemAction oImp (aImp type arg) rImp uImp csImp ret -> forall oSpec, simRel oImp oSpec -> exists aSpec rSpec uSpec, In (meth, existT _ sign aSpec) (getMethods spec) /\ SemAction oSpec (aSpec type arg) rSpec uSpec csImp ret /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec). Variable notMethMeth: forall oImp rImpl1 uImpl1 meth1 sign1 aImp1 arg1 ret1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (meth1, existT _ sign1 aImp1) (getMethods imp) -> SemAction oImp (aImp1 type arg1) rImpl1 uImpl1 csImp1 ret1 -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Variable notRuleMeth: forall oImp rImpl1 uImpl1 rleImpl1 aImp1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (rleImpl1, aImp1) (getRules imp) -> SemAction oImp (aImp1 type) rImpl1 uImpl1 csImp1 WO -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Theorem simulationGeneral: TraceInclusion (Base imp) (Base spec). Proof. eapply simulationGeneralEx; eauto; intros. - specialize (@simulationRule _ _ _ _ _ _ H H0 oSpec H1). destruct simulationRule; auto. dest. right. exists x, x0; repeat split; auto. exists x1, x2; repeat split; auto. exists (doUpdRegs x2 oSpec); split; auto. pose proof (SemAction_NoDup_u H3) as sth. destruct (wfBaseModule spec); dest. pose proof (simRelGood H1) as sth2. apply (f_equal (map fst)) in sth2. rewrite ?map_map in *; simpl in *. assert (sth3: forall A B, (fun x: (A * B) => fst x) = fst) by (intros; extensionality y; intros; auto). rewrite <- sth3 in H8. rewrite <- sth2 in H8. rewrite sth3 in H8. pose proof (SemActionUpdSub H3). eapply doUpdRegs_UpdRegs; eauto. - specialize (@simulationMeth _ _ _ _ _ _ _ _ _ H H0 oSpec H1). pose proof simulationMeth as sth; clear simulationMeth. dest. exists x, x0, x1; repeat split; auto. exists (doUpdRegs x1 oSpec); split; auto. pose proof (SemAction_NoDup_u H3) as sth. destruct (wfBaseModule spec); dest. pose proof (simRelGood H1) as sth2. apply (f_equal (map fst)) in sth2. rewrite ?map_map in *; simpl in *. assert (sth3: forall A B, (fun x: (A * B) => fst x) = fst) by (intros; extensionality y; intros; auto). rewrite <- sth3 in H8. rewrite <- sth2 in H8. rewrite sth3 in H8. pose proof (SemActionUpdSub H3). eapply doUpdRegs_UpdRegs; eauto. Qed. End SimulationGeneral. Section SimulationGeneral_new. Variable imp spec: BaseModuleWf_new type. Variable NoSelfCalls: NoSelfCallBaseModule spec. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable simulationRule: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec))). Variable simulationMeth: forall oImp rImp uImp meth csImp sign aImp arg ret, In (meth, existT _ sign aImp) (getMethods imp) -> SemAction oImp (aImp type arg) rImp uImp csImp ret -> forall oSpec, simRel oImp oSpec -> exists aSpec rSpec uSpec, In (meth, existT _ sign aSpec) (getMethods spec) /\ SemAction oSpec (aSpec type arg) rSpec uSpec csImp ret /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec). Variable notMethMeth: forall oImp rImpl1 uImpl1 meth1 sign1 aImp1 arg1 ret1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (meth1, existT _ sign1 aImp1) (getMethods imp) -> SemAction oImp (aImp1 type arg1) rImpl1 uImpl1 csImp1 ret1 -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Variable notRuleMeth: forall oImp rImpl1 uImpl1 rleImpl1 aImp1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (rleImpl1, aImp1) (getRules imp) -> SemAction oImp (aImp1 type) rImpl1 uImpl1 csImp1 WO -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Theorem simulationGeneral_new : TraceInclusion (Base imp) (Base spec). Proof. destruct imp, spec. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as x. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new0)) as y. eapply (simulationGeneral x y); eauto. Qed. End SimulationGeneral_new. Section SimulationZeroAction. Variable imp spec: BaseModuleWf type. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable NoMeths: getMethods imp = []. Variable NoMethsSpec: getMethods spec = []. Variable simulation: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec))). Theorem simulationZeroAction: TraceInclusion (Base imp) (Base spec). Proof. eapply simulationZeroA; eauto; intros. specialize (@simulation _ _ _ _ _ _ H H0 _ H1). destruct simulation; auto. right. dest. exists x, x0; split; auto. exists x1, x2; split; auto. exists (doUpdRegs x2 oSpec); split; auto. pose proof (SemAction_NoDup_u H3) as sth. destruct (wfBaseModule spec); dest. pose proof (simRelGood H1) as sth2. apply (f_equal (map fst)) in sth2. rewrite ?map_map in *; simpl in *. assert (sth3: forall A B, (fun x: (A * B) => fst x) = fst) by (intros; extensionality y; intros; auto). rewrite <- sth3 in H8. rewrite <- sth2 in H8. rewrite sth3 in H8. pose proof (SemActionUpdSub H3). eapply doUpdRegs_UpdRegs; eauto. Qed. End SimulationZeroAction. Section SimulationZeroAction_new. Variable imp spec: BaseModuleWf_new type. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable NoMeths: getMethods imp = []. Variable NoMethsSpec: getMethods spec = []. Variable simulation: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = []) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec))). Theorem simulationZeroAction_new : TraceInclusion (Base imp) (Base spec). Proof. destruct imp, spec. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new)) as x. pose (Build_BaseModuleWf (WfBaseModule_new_WfBaseModule wfBaseModule_new0)) as y. eapply (simulationZeroAction x y); eauto. Qed. End SimulationZeroAction_new. Lemma SemAction_if k1 k (e: Expr type (SyntaxKind Bool)) (a1 a2: ActionT type k1) (a: type k1 -> ActionT type k) o reads u cs v: (if evalExpr e then SemAction o (LetAction a1 a) reads u cs v else SemAction o (LetAction a2 a) reads u cs v) -> SemAction o (IfElse e a1 a2 a) reads u cs v. Proof. case_eq (evalExpr e); intros; inv H0; EqDep_subst. - econstructor 7; eauto. - econstructor 8; eauto. Qed. Lemma SemAction_if_split k1 k (e: Expr type (SyntaxKind Bool)) (a1 a2: ActionT type k1) (a: type k1 -> ActionT type k) o reads1 reads2 u1 u2 cs1 cs2 v1 v2 reads u cs v: (if evalExpr e then SemAction o (LetAction a1 a) reads1 u1 cs1 v1 else SemAction o (LetAction a2 a) reads2 u2 cs2 v2) -> (reads = if evalExpr e then reads1 else reads2) -> (u = if evalExpr e then u1 else u2) -> (cs = if evalExpr e then cs1 else cs2) -> (v = if evalExpr e then v1 else v2) -> SemAction o (IfElse e a1 a2 a) reads u cs v. Proof. intros. eapply SemAction_if. destruct (evalExpr e); subst; auto. Qed. Lemma convertLetExprSyntax_ActionT_same o k (e: LetExprSyntax type k): SemAction o (convertLetExprSyntax_ActionT e) nil nil nil (evalLetExpr e). Proof. induction e; simpl; try constructor; auto. specialize (H (evalLetExpr e)). pose proof (SemLetAction (fun v => convertLetExprSyntax_ActionT (cont v)) (@DisjKey_nil_l string _ nil) IHe H) as sth. rewrite ?(app_nil_l nil) in sth. auto. eapply SemAction_if; eauto; case_eq (evalExpr pred); intros; subst; repeat econstructor; eauto; unfold not; simpl; intros; auto. Qed. Lemma convertLetExprSyntax_ActionT_full k (e: LetExprSyntax type k): forall o reads writes cs ret, SemAction o (convertLetExprSyntax_ActionT e) reads writes cs ret -> reads = nil /\ writes = nil /\ cs = nil /\ ret = (evalLetExpr e). Proof. induction e; simpl; auto; intros; dest; subst. - inv H; dest. EqDep_subst. repeat split; auto. - inv H; dest. EqDep_subst. eapply IHe; eauto. - inv H0. EqDep_subst. apply H in HSemActionCont; dest; subst. apply IHe in HSemAction; dest; subst. repeat split; auto. - apply inversionSemAction in H0; dest. destruct (evalExpr pred); dest. + apply IHe1 in H1; dest; subst. apply H in H2; dest; subst. repeat split; auto. + apply IHe2 in H1; dest; subst. apply H in H2; dest; subst. repeat split; auto. Qed. Section Simulation. Variable imp spec: BaseModule. Variable impWf: WfBaseModule type imp. Variable specWf: WfBaseModule type spec. Variable NoSelfCalls: NoSelfCallBaseModule spec. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable simulationRule: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = nil) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec))). Variable simulationMeth: forall oImp rImp uImp meth csImp sign aImp arg ret, In (meth, existT _ sign aImp) (getMethods imp) -> SemAction oImp (aImp type arg) rImp uImp csImp ret -> forall oSpec, simRel oImp oSpec -> exists aSpec rSpec uSpec, In (meth, existT _ sign aSpec) (getMethods spec) /\ SemAction oSpec (aSpec type arg) rSpec uSpec csImp ret /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec). Variable notMethMeth: forall oImp rImpl1 uImpl1 meth1 sign1 aImp1 arg1 ret1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (meth1, existT _ sign1 aImp1) (getMethods imp) -> SemAction oImp (aImp1 type arg1) rImpl1 uImpl1 csImp1 ret1 -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Variable notRuleMeth: forall oImp rImpl1 uImpl1 rleImpl1 aImp1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (rleImpl1, aImp1) (getRules imp) -> SemAction oImp (aImp1 type) rImpl1 uImpl1 csImp1 WO -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Theorem simulation: TraceInclusion (Base imp) (Base spec). Proof. remember {| baseModule := imp ; wfBaseModule := impWf |} as impMod. remember {| baseModule := spec ; wfBaseModule := specWf |} as specMod. assert (Imp: imp = baseModule impMod) by (rewrite HeqimpMod; auto). assert (Spec: spec = baseModule specMod) by (rewrite HeqspecMod; auto). rewrite Imp, Spec in *. eapply simulationGeneral; eauto; intros. Qed. End Simulation. Section Simulation_new. Variable imp spec: BaseModule. Variable impWf: WfBaseModule_new type imp. Variable specWf: WfBaseModule_new type spec. Variable NoSelfCalls: NoSelfCallBaseModule spec. Variable simRel: RegsT -> RegsT -> Prop. Variable simRelGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oSpec = getKindAttr (getRegisters spec). Variable simRelImpGood: forall oImp oSpec, simRel oImp oSpec -> getKindAttr oImp = getKindAttr (getRegisters imp). Variable initRel: forall rimp, Forall2 regInit rimp (getRegisters imp) -> exists rspec, Forall2 regInit rspec (getRegisters spec) /\ simRel rimp rspec. Variable simulationRule: forall oImp rImp uImp rleImp csImp aImp, In (rleImp, aImp) (getRules imp) -> SemAction oImp (aImp type) rImp uImp csImp WO -> forall oSpec, simRel oImp oSpec -> ((simRel (doUpdRegs uImp oImp) oSpec /\ csImp = nil) \/ (exists rleSpec aSpec, In (rleSpec, aSpec) (getRules spec) /\ exists rSpec uSpec, SemAction oSpec (aSpec type) rSpec uSpec csImp WO /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec))). Variable simulationMeth: forall oImp rImp uImp meth csImp sign aImp arg ret, In (meth, existT _ sign aImp) (getMethods imp) -> SemAction oImp (aImp type arg) rImp uImp csImp ret -> forall oSpec, simRel oImp oSpec -> exists aSpec rSpec uSpec, In (meth, existT _ sign aSpec) (getMethods spec) /\ SemAction oSpec (aSpec type arg) rSpec uSpec csImp ret /\ simRel (doUpdRegs uImp oImp) (doUpdRegs uSpec oSpec). Variable notMethMeth: forall oImp rImpl1 uImpl1 meth1 sign1 aImp1 arg1 ret1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (meth1, existT _ sign1 aImp1) (getMethods imp) -> SemAction oImp (aImp1 type arg1) rImpl1 uImpl1 csImp1 ret1 -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Variable notRuleMeth: forall oImp rImpl1 uImpl1 rleImpl1 aImp1 csImp1 rImpl2 uImpl2 meth2 sign2 aImp2 arg2 ret2 csImp2, In (rleImpl1, aImp1) (getRules imp) -> SemAction oImp (aImp1 type) rImpl1 uImpl1 csImp1 WO -> In (meth2, existT _ sign2 aImp2) (getMethods imp) -> SemAction oImp (aImp2 type arg2) rImpl2 uImpl2 csImp2 ret2 -> exists k, In k (map fst uImpl1) /\ In k (map fst uImpl2). Theorem simulation_new : TraceInclusion (Base imp) (Base spec). Proof. eapply simulation; eauto. - apply WfBaseModule_new_WfBaseModule; auto. - apply WfBaseModule_new_WfBaseModule; auto. Qed. End Simulation_new. Lemma evalExpr_Kor_Default k (e : Expr type (SyntaxKind k)): evalKorOpBin k (evalExpr e) (evalConstT (getDefaultConst k)) = (evalExpr e). Proof. induction k; simpl. - rewrite orb_false_r; reflexivity. - rewrite wzero_wor; reflexivity. - apply functional_extensionality_dep; intros. apply (H x (Var _ (SyntaxKind (k x)) (evalExpr e x))). - simpl. apply functional_extensionality_dep; intros. apply (IHk (Var _ (SyntaxKind k) (evalExpr e x))). Qed. Lemma evalExpr_Kor_comm k (e1 e2 : Expr type (SyntaxKind k)): evalKorOpBin k (evalExpr e1) (evalExpr e2) = evalKorOpBin k (evalExpr e2) (evalExpr e1). Proof. induction k; simpl. - apply orb_comm. - apply wor_comm. - apply functional_extensionality_dep; intros. apply (H x (Var _ (SyntaxKind (k x)) (evalExpr e1 x)) (Var _ (SyntaxKind (k x)) (evalExpr e2 x))). - apply functional_extensionality_dep; intros. apply (IHk (Var _ (SyntaxKind k) (evalExpr e1 x)) (Var _ (SyntaxKind k) (evalExpr e2 x))). Qed. Lemma evalExpr_Kor_idemp k (e1 : Expr type (SyntaxKind k)): evalKorOpBin k (evalExpr e1) (evalExpr e1) = (evalExpr e1). Proof. induction k; simpl. - apply orb_diag. - apply wor_idemp. - apply functional_extensionality_dep; intros. apply (H x (Var _ (SyntaxKind (k x)) (evalExpr e1 x))). - apply functional_extensionality_dep; intros. apply (IHk (Var _ (SyntaxKind k) (evalExpr e1 x))). Qed. Local Lemma Kor_default_rev k (l : list (Expr type (SyntaxKind k))): (forall a, In a (rev l) -> a = Const type Default) -> evalExpr (@Kor _ k (rev l)) = evalExpr (Const type Default). Proof. cbn [evalExpr]. unfold evalKorOp. rewrite <- fold_left_rev_right, map_rev, rev_involutive. induction l; intros; simpl in *; subst; auto. rewrite IHl. - rewrite (H _ (in_or_app _ _ _ (or_intror _ (InSingleton _)))); simpl. assert (evalConstT Default = (evalExpr (@Const type k Default))) as P by reflexivity. repeat rewrite P. apply evalExpr_Kor_idemp. - intros; apply H; rewrite in_app_iff; left; assumption. Qed. Local Lemma Kor_default_rev' k (l : list (Expr type (SyntaxKind k))): (forall a, In (evalExpr a) (map (fun x => evalExpr x) (rev l)) -> (evalExpr a) = (evalExpr (Const type Default))) -> evalExpr (@Kor _ k (rev l)) = evalExpr (Const type Default). Proof. cbn [evalExpr]. unfold evalKorOp. repeat rewrite map_rev. rewrite <- fold_left_rev_right, rev_involutive. induction l; intros; simpl in *; subst; auto. rewrite IHl. - rewrite (H _ (in_or_app _ _ _ (or_intror _ (InSingleton _)))); simpl. assert (evalConstT Default = (evalExpr (@Const type k Default))) as P by reflexivity. repeat rewrite P. apply evalExpr_Kor_idemp. - intros; apply H; rewrite in_app_iff; left; assumption. Qed. Lemma Kor_default k (l : list (Expr type (SyntaxKind k))): (forall a, In a l -> a = Const type Default) -> evalExpr (@Kor _ k l) = evalExpr (Const type Default). Proof. setoid_rewrite <- rev_involutive. apply Kor_default_rev. Qed. Lemma Kor_default' k (l : list (Expr type (SyntaxKind k))): (forall a, In (evalExpr a) (map (fun x => evalExpr x) l) -> (evalExpr a) = (evalExpr (Const type Default))) -> evalExpr (@Kor _ k l) = evalExpr (Const type Default). Proof. setoid_rewrite <- (rev_involutive l). apply Kor_default_rev'. Qed. Local Lemma Kor_sparse_rev k (l : list (Expr type (SyntaxKind k))): forall (val : Expr type (SyntaxKind k)), In (evalExpr val) (map (fun x => evalExpr x) (rev l)) -> (forall a, In (evalExpr a) (map (fun x => evalExpr x) (rev l)) -> (evalExpr a) = (evalExpr val) \/ (evalExpr a) = (evalExpr (Const type Default))) -> evalExpr (@Kor _ k (rev l)) = evalExpr val. Proof. intros. cbn [evalExpr]. unfold evalKorOp. rewrite <- fold_left_rev_right, map_rev, rev_involutive. induction l; intros; simpl in *; dest; subst; [contradiction|rewrite map_app in *]. rewrite in_app_iff in H; destruct H. - rewrite IHl; auto. + destruct (H0 _ (in_or_app _ _ _ (or_intror _ (InSingleton _)))); rewrite H1. * apply evalExpr_Kor_idemp. * apply evalExpr_Kor_Default. + intros. apply H0; rewrite in_app_iff; left; assumption. - inv H; [|contradiction]. destruct (In_dec (isEq k) (evalExpr val) (map (fun x => evalExpr x) (rev l))). + rewrite IHl, H1; auto. * apply evalExpr_Kor_idemp. * intros. apply H0; rewrite in_app_iff; left; assumption. + assert (forall a, In (evalExpr a) (map (fun x => evalExpr x) (rev l)) -> (evalExpr a) = (evalExpr (Const type Default))) as P. { intros. destruct (H0 _ (in_or_app _ _ _ (or_introl _ H))); subst; auto. rewrite H2 in H. exfalso; contradiction. } specialize (Kor_default_rev' l) as P0. cbn [evalExpr] in P0. unfold evalKorOp in P0. repeat rewrite map_rev in P0. rewrite <- fold_left_rev_right, rev_involutive in P0. setoid_rewrite P0; [|rewrite <-map_rev; auto]. rewrite H1. assert (@evalConstT k Default = evalExpr (Const type Default)) as P1 by reflexivity. rewrite P1, evalExpr_Kor_comm. apply evalExpr_Kor_Default. Qed. Lemma Kor_sparse k (l : list (Expr type (SyntaxKind k))): forall val, In (evalExpr val) (map (fun x => evalExpr x) l) -> (forall a, In (evalExpr a) (map (fun x => evalExpr x) l) -> (evalExpr a) = (evalExpr val) \/ (evalExpr a) = (evalExpr (Const type Default))) -> evalExpr (@Kor _ k l) = evalExpr val. Proof. setoid_rewrite <- (rev_involutive l). apply Kor_sparse_rev. Qed. Lemma evalExpr_Kor_Default_l k (e : Expr type (SyntaxKind k)): evalKorOpBin k (evalConstT Default) (evalExpr e) = evalExpr e. Proof. assert (@evalConstT k Default = evalExpr (Const type Default)) as P by reflexivity. rewrite P, evalExpr_Kor_comm. apply evalExpr_Kor_Default. Qed. Lemma evalExpr_Kor_assoc k (e1 e2 e3 : Expr type (SyntaxKind k)): evalKorOpBin k (evalExpr e1) (evalKorOpBin k (evalExpr e2) (evalExpr e3)) = evalKorOpBin k (evalKorOpBin k (evalExpr e1) (evalExpr e2)) (evalExpr e3). Proof. induction k; simpl. - apply orb_assoc. - apply wor_assoc. - apply functional_extensionality_dep; intros. apply (H _ (Var _ (SyntaxKind (k x)) (evalExpr e1 x)) (Var _ (SyntaxKind (k x)) (evalExpr e2 x)) (Var _ (SyntaxKind (k x)) (evalExpr e3 x))). - apply functional_extensionality_dep; intros. apply (IHk (Var _ (SyntaxKind k) (evalExpr e1 x)) (Var _ (SyntaxKind k) (evalExpr e2 x)) (Var _ (SyntaxKind k) (evalExpr e3 x))). Qed. Local Lemma evalExpr_Kor_perm_rev k (l : list (Expr type (SyntaxKind k))) : forall l', l [=] l' -> evalExpr (Kor (rev l)) = evalExpr (Kor (rev l')). Proof. induction 1; auto. - cbn [evalExpr] in *. unfold evalKorOp in *. repeat rewrite <- fold_left_rev_right, map_rev, rev_involutive in *. simpl. setoid_rewrite IHPermutation. reflexivity. - cbn [evalExpr]. unfold evalKorOp. repeat rewrite <- fold_left_rev_right, map_rev, rev_involutive. simpl. assert (evalExpr (Var _ (SyntaxKind k) (fold_right (fun y0 x0 => evalKorOpBin k x0 y0) (evalConstT Default) (map (evalExpr (exprT:=SyntaxKind k)) l))) = (fold_right (fun y0 x0 => evalKorOpBin k x0 y0) (evalConstT Default) (map (evalExpr (exprT:=SyntaxKind k)) l))) as P by reflexivity. setoid_rewrite <- P. rewrite <- evalExpr_Kor_assoc, evalExpr_Kor_comm, evalExpr_Kor_assoc; reflexivity. - rewrite IHPermutation1, IHPermutation2; reflexivity. Qed. Lemma evalExpr_Kor_perm k (l : list (Expr type (SyntaxKind k))) : forall l', l [=] l' -> evalExpr (Kor l) = evalExpr (Kor l'). Proof. intros. rewrite (Permutation.Permutation_rev l), (Permutation.Permutation_rev l') in H. rewrite <- (rev_involutive l), <- (rev_involutive l'). apply evalExpr_Kor_perm_rev; assumption. Qed. Lemma evalExpr_Kor_head k (e : Expr type (SyntaxKind k)) (l : list (Expr type (SyntaxKind k))): evalExpr (Kor (e :: l)) = evalKorOpBin k (evalExpr e) (evalExpr (Kor l)). Proof. rewrite (evalExpr_Kor_perm (Permutation.Permutation_rev (e :: l))), (evalExpr_Kor_perm (Permutation.Permutation_rev l)) at 1. cbn [evalExpr]. unfold evalKorOp. repeat rewrite <- fold_left_rev_right, map_rev, rev_involutive. simpl. assert ((fold_right (fun y x : type k => evalKorOpBin k x y) (evalConstT Default) (map (evalExpr (exprT:=SyntaxKind k)) l)) = evalExpr (Var _ (SyntaxKind k) (fold_right (fun y x : type k => evalKorOpBin k x y) (evalConstT Default) (map (evalExpr (exprT:=SyntaxKind k)) l)))) as P by reflexivity. setoid_rewrite P. rewrite evalExpr_Kor_comm; reflexivity. Qed. Lemma arr_nth_Fin' {A : Type} : forall m (arr : t m -> A), arr = (nth_Fin' _ (list_arr_length arr)). Proof. intros. apply functional_extensionality; intros. rewrite (nth_Fin'_nth (arr x)). rewrite <- nth_default_eq, <- list_arr_correct. destruct lt_dec. - specialize (of_nat_to_nat_inv x) as P. rewrite (of_nat_ext l (proj2_sig (to_nat x))), P; reflexivity. - exfalso. apply n, fin_to_nat_bound. Qed. Lemma evalExpr_Kor_same_eval (k : Kind) (l l' : list (Expr type (SyntaxKind k))) : Forall2 (fun x y => evalExpr x = evalExpr y) l l' -> evalExpr (Kor l) = evalExpr (Kor l'). Proof. induction 1; auto. repeat rewrite evalExpr_Kor_head. rewrite H, IHForall2; reflexivity. Qed. Lemma split_seq : forall start i size, i < size -> seq start size = (seq start i) ++ [start + i] ++ (seq (start + (S i)) (size - (S i))). Proof. intros. rewrite (@seq_app' start size i), (@seq_app' (start + i) (size - i) 1); try lia. cbn. assert (size - i - 1 = size - S i) as P by lia. rewrite Nat.add_1_r, plus_n_Sm, P; reflexivity. Qed. ================================================ FILE: README.adoc ================================================ :toc: = Kami -- A Coq-based DSL for specifying and proving hardware designs == What is Kami? Kami is an umbrella term used to denote the following: . A https://en.wikipedia.org/wiki/Coq[Coq]-based DSL for writing hardware designs . A compiler for translating said hardware designs into Verilog . A simulator for said hardware designs, by generating an executable in Haskell, using user-defined functions to drive inputs and examine outputs for the hardware design . A formal definition of the semantics of the DSL in Coq, including a definition of whether one design _implements_ another simpler design, i.e. whether an _implementation adheres to its specification_ . A set of theorems or properties about said semantics, formally proven in Coq . A set of tactics for formally proving that an implementation adhere to its specification In Kami, one can write generators, i.e. functions that generate hardware when its parameters are specified, and can prove that the generators are correct with respect to their specification. Unlike traditional model-checking based approaches, the ability to prove theorems involving higher-order logic in Coq enables one to easily prove equivalence between a generator and its specification. The semantics of Kami was inspired by http://wiki.bluespec.com/[Bluespec SystemVerilog]. The original version of http://plv.csail.mit.edu/kami/papers/icfp17.pdf[Kami] was developed in MIT. Based on the experience of developing and using Kami at MIT, it was rewritten at SiFive to make it practical to build provably correct chips. == Semantics of Kami: an informal overview Any hardware block or _module_ is written as a set of registers representing the state of the block, and a set of _rules_. The behavior of the module is represented by a sequence of execution of rules. Rules execute by reading and writing the state _atomically_, i.e. when one rule is executing, no other rule executes. During its execution, a rule can also interact with the external world by calling methods, to which the rule supplies arguments (an output from the module), and takes back the result returned by the external world (an input to the module). Once a rule finishes execution, another rule is picked non-deterministically and is executed, and so on. A module _A_ is said to implement a specification module _B_ if, during every rule execution in _A_, if the rule calls any methods, then these methods (along with their arguments and return values) are the same as those called by some rule execution in _B_, and this property holds for every sequence of rule executions in _A_. Note that the return values are functions of the external world; we assume that the same value can be returned by the external world if the same method is called with the same argument in both _A_ and _B_. The methods along with their arguments and return values that are called in a rule's execution are called a label, and the sequence of labels corresponding to the sequence of rule execution is called a trace. The above definition of _A_ implementing _B_ can be rephrased as follows: any trace that can be produced by _A_ can also be produced by _B_. We call this property `TraceInclusion`. While the above semantics cover most of the behavior of Kami modules, it is not complete. We will be discussing the last bit of the semantics towards the end of this article. == Syntax of Kami The syntax of Kami is designed to simply provide a way to represent a set of registers (with optional initial values), and a set of rules. The rules are written as _actions_ which read or write registers, call methods, deal with predicates (i.e. `if then else`), etc. The module `exampleModule` in link:Tutorial/SyntaxEx.v[SyntaxEx.v] shows an example featuring all the syntactic components involved in writing a module, including writing every possible _expression_, _action_, register initialization and rule. The comments in the file give an informal specification of what each syntactic construct does. Notice that actions and let-expressions are essentially are https://en.wikipedia.org/wiki/Abstract_syntax_tree[ASTs] written in Gallina. So, one can construct these actions or let-expressions separately as Gallina terms without having to be inside a Kami module. This way, one can write generators that produce actions or let-expressions that can be composed in multiple ways into a module. link:Tutorial/GallinaActionEx.v[GallinaActionEx.v] shows how to write such Gallina terms. Notice the use of a strange parameter `ty: Kind -> Type`. This is used to get parametric ASTs that allow us to use the same AST for synthesizing circuits as well as for proofs. Read a tiny example, link:Tutorial/PhoasEx.v[PhoasEx.v] and http://adam.chlipala.net/papers/PhoasICFP08/PhoasICFP08.pdf[Parametric Higher Order Abstract Syntax (PHOAS) paper] to understand what PHOAS means. While understanding PHOAS is useful, one need not understand the concepts to build actions and let-expressions in Kami. Instead, one can view supplying `ty: Kind -> Types` as boiler plate code, and write types for expressions as `k @# ty`, let-expressions as `k ## ty` and actions as `ActionT ty k` (`k` represents the Kami type represented by these entities). == Proving implementations using Kami link:Tutorial/TacticsEx.v[TacticsEx.v] showcases how some of the Coq tactics developed in the Kami framework can be used to simplify the proof of `TraceInclusion` between two modules. The documentation for this is work in progress. ================================================ FILE: Rewrites/Notations_rewrites.v ================================================ (* * Notations_rewrites.v * * Rewriting rules useful for Notation definitions *) Require Import Kami.AllNotations. Require Import List. Import ListNotations. Require Import Kami.Notations. Lemma app_rewrite1: forall T (a:T) b c, (a::b)++c=a::(b++c). Proof. simpl. intros. reflexivity. Qed. Lemma Registers1: forall a b, Registers (a::b) = (MERegister a)::(Registers b). Proof. intros. simpl Registers. reflexivity. Qed. Lemma Registers2: Registers []=[]. Proof. simpl. reflexivity. Qed. Lemma Registers_dist_append : forall l1 l2, Registers (l1++l2)=(Registers l1)++(Registers l2). Proof. intros. induction l1. + simpl. reflexivity. + simpl. rewrite IHl1. reflexivity. Qed. Hint Rewrite Registers_dist_append : kami_rewrite_db. Lemma app_rewrite2: forall A (f:A) (r:list A), [f]++r=f::r. Proof. reflexivity. Qed. Hint Rewrite app_rewrite1 app_rewrite2 app_nil_l app_nil_r Registers1 Registers2 : kami_rewrite_db. Hint Rewrite Registers1 Registers2 : kami_rewrite_db. Lemma makeModule_rules_Registers: forall l, makeModule_rules (Registers l)=[]. Proof. intros. induction l. + simpl. reflexivity. + simpl. rewrite IHl. simpl. reflexivity. Qed. Lemma makeModule_rules_append: forall l1 l2, (makeModule_rules (l1++l2))=(makeModule_rules l1)++(makeModule_rules l2). Proof. intros. induction l1. + simpl. reflexivity. + simpl. rewrite IHl1. destruct a; reflexivity. Qed. Lemma makeModule_rules_MERegister: forall a b, makeModule_rules ((MERegister a)::b)=makeModule_rules b. Proof. simpl. reflexivity. Qed. Lemma makeModule_rules_MERule: forall a b, makeModule_rules ((MERule a)::b)=a::(makeModule_rules b). Proof. simpl. reflexivity. Qed. Lemma makeModule_rules_nil: makeModule_rules []=[]. Proof. simpl. reflexivity. Qed. Hint Rewrite makeModule_rules_Registers makeModule_rules_append makeModule_rules_MERegister makeModule_rules_MERule makeModule_rules_nil : kami_rewrite_db. Lemma makeModule_meths_Registers: forall l, makeModule_meths (Registers l)=[]. Proof. intros. induction l. simpl. reflexivity. simpl. rewrite IHl. simpl. reflexivity. Qed. Lemma makeModule_meths_append: forall l1 l2, makeModule_meths (l1++l2)=(makeModule_meths l1)++(makeModule_meths l2). Proof. intros. induction l1. + simpl. reflexivity. + simpl. rewrite IHl1. destruct a; reflexivity. Qed. Lemma makeModule_meths_MERegister: forall a b, makeModule_meths ((MERegister a)::b)=makeModule_meths b. Proof. simpl. reflexivity. Qed. Lemma makeModule_meths_MERule: forall a b, makeModule_meths ((MERule a)::b)=(makeModule_meths b). Proof. simpl. reflexivity. Qed. Lemma makeModule_meths_nil: makeModule_meths []=[]. Proof. simpl. reflexivity. Qed. Hint Rewrite makeModule_meths_Registers makeModule_meths_append makeModule_meths_MERegister makeModule_meths_MERule makeModule_meths_nil : kami_rewrite_db. Lemma makeModule_regs_Registers: forall l, makeModule_regs (Registers l)=l. Proof. intros. induction l. + simpl. reflexivity. + simpl. rewrite IHl. simpl. reflexivity. Qed. Lemma makeModule_regs_append: forall l1 l2, makeModule_regs (l1++l2)=(makeModule_regs l1)++(makeModule_regs l2). Proof. intros. induction l1. + simpl. reflexivity. + simpl. rewrite IHl1. destruct a; reflexivity. Qed. Lemma makeModule_regs_MERegister: forall a b, makeModule_regs ((MERegister a)::b)=a::(makeModule_regs b). Proof. simpl. reflexivity. Qed. Lemma makeModule_regs_MERule: forall a b, makeModule_regs ((MERule a)::b)=makeModule_regs b. Proof. simpl. reflexivity. Qed. Lemma makeModule_regs_nil: makeModule_regs []=[]. Proof. simpl. reflexivity. Qed. Hint Rewrite makeModule_regs_Registers makeModule_regs_append makeModule_regs_MERegister makeModule_regs_MERule makeModule_regs_nil : kami_rewrite_db. Lemma map1: forall T R (f: T -> R) (h:T) t, List.map f (h::t)=(f h)::(List.map f t). Proof. simpl. reflexivity. Qed. Lemma fold_right1: forall A B (f : B -> A -> A) (a0 : A) (h : B) (t : list B), List.fold_right f a0 (h::t)=f h (List.fold_right f a0 t). Proof. intros. simpl. reflexivity. Qed. Lemma getAllRegisters_fold_right_ConcatMod : forall (b: Mod) (l:list Mod), getAllRegisters (List.fold_right ConcatMod b l)=(concat (List.map getAllRegisters l))++(getAllRegisters b). Proof. induction l. + simpl. reflexivity. + simpl. rewrite IHl. rewrite app_assoc. reflexivity. Qed. Lemma getAllMethods_fold_right_ConcatMod : forall (b: Mod) (l:list Mod), getAllMethods (List.fold_right ConcatMod b l)=(concat (List.map getAllMethods l))++(getAllMethods b). Proof. induction l. + simpl. reflexivity. + simpl. rewrite IHl. rewrite app_assoc. reflexivity. Qed. Lemma getAllRules_fold_right_ConcatMod : forall (b: Mod) (l:list Mod), getAllRules (List.fold_right ConcatMod b l)=(concat (List.map getAllRules l))++(getAllRules b). Proof. induction l. + simpl. reflexivity. + simpl. rewrite IHl. rewrite app_assoc. reflexivity. Qed. Lemma getAllRules_ConcatMod : forall a b, getAllRules (ConcatMod a b)=getAllRules a++getAllRules b. Proof. intros. simpl. reflexivity. Qed. Lemma getAllMethods_ConcatMod : forall a b, getAllMethods (ConcatMod a b)=getAllMethods a++getAllMethods b. Proof. intros. simpl. reflexivity. Qed. (* Lemma getCallsWithSignPerRule_append: forall T a b, getCallsWithSignPerRule (a++b)=getCallsWithSignPerRule a++getCallsWithSignPerRule b. Proof.*) Lemma getCallsPerMod_ConcatMod : forall a b, getCallsPerMod (ConcatMod a b)=(getCallsPerMod a)++(getCallsPerMod b). Proof. unfold getCallsPerMod. simpl. intros. rewrite map_app. reflexivity. Qed. Lemma getCallsPerMod_BaseRegFile: forall m, getCallsPerMod (Base (BaseRegFile m)) = []. Proof. intros. unfold getCallsPerMod. unfold getCallsWithSignPerMod. simpl. unfold getRegFileMethods. destruct m. destruct rfRead. + simpl. unfold getCallsWithSignPerMeth. destruct rfIsWrMask. - simpl. unfold readRegFile. induction reads. * reflexivity. * simpl. rewrite IHreads. reflexivity. - simpl. unfold readRegFile. induction reads. * reflexivity. * simpl. rewrite IHreads. reflexivity. + simpl. unfold getCallsWithSignPerMeth. simpl. unfold readSyncRegFile. destruct rfIsWrMask. simpl. destruct isAddr. * simpl. induction reads. -- reflexivity. -- simpl. rewrite map_app in IHreads. rewrite map_app. rewrite map_cons. simpl. rewrite concat_app in IHreads. rewrite concat_app. rewrite concat_cons. rewrite app_nil_l. rewrite IHreads. reflexivity. * simpl. induction reads. -- reflexivity. -- simpl. rewrite map_app in IHreads. rewrite map_app. rewrite map_cons. simpl. rewrite concat_app in IHreads. rewrite concat_app. rewrite concat_cons. rewrite app_nil_l. rewrite IHreads. reflexivity. * simpl. destruct isAddr. -- simpl. induction reads. ++ reflexivity. ++ simpl. rewrite map_app in IHreads. rewrite map_app. rewrite map_cons. simpl. rewrite concat_app in IHreads. rewrite concat_app. rewrite concat_cons. rewrite app_nil_l. rewrite IHreads. reflexivity. -- simpl. induction reads. ++ reflexivity. ++ simpl. rewrite map_app in IHreads. rewrite map_app. rewrite map_cons. simpl. rewrite concat_app in IHreads. rewrite concat_app. rewrite concat_cons. rewrite app_nil_l. rewrite IHreads. reflexivity. Qed. Lemma getCallsPerMod_Base: forall (m : BaseModule), getCallsPerMod (Base m)=List.map fst (getCallsWithSignPerMod m). Proof. unfold getCallsPerMod. reflexivity. Qed. Lemma map_getCallsPerMod_map_BaseRegFile: forall l, (concat (List.map getCallsPerMod (List.map (fun m : RegFileBase => (Base (BaseRegFile m))) l)))=[]. Proof. intros. induction l. + reflexivity. + simpl. rewrite IHl. rewrite app_nil_r. rewrite getCallsPerMod_BaseRegFile. reflexivity. Qed. Lemma getCallsPerMod_fold_right_ConcatMod: forall (a:Mod) (l:list Mod), getCallsPerMod (List.fold_right ConcatMod a l)=concat (List.map getCallsPerMod l)++(getCallsPerMod a). Proof. intros. induction l. + reflexivity. + simpl. rewrite <- app_assoc. rewrite <- IHl. rewrite getCallsPerMod_ConcatMod. reflexivity. Qed. Hint Rewrite map1 fold_right1 getAllRules_ConcatMod getAllMethods_ConcatMod getCallsPerMod_ConcatMod map_getCallsPerMod_map_BaseRegFile : kami_rewrite_db. Hint Rewrite getCallsPerMod_fold_right_ConcatMod getCallsPerMod_BaseRegFile : kami_rewrite_db. Theorem getAllRegisters_ConcatMod: forall a b, getAllRegisters (ConcatMod a b)=getAllRegisters(a)++getAllRegisters(b). Proof. reflexivity. Qed. (*Axiom EquivThenEqual: prop_extensionality. Theorem equiv_rewrite: forall x y, (x=y)=(x<->y). Proof. intros. apply EquivThenEqual. split. + intros. subst. split. - intros. apply H. - intros. apply H. + intros. inversion H; subst; clear H. apply EquivThenEqual. split. - apply H0. - apply H1. Qed.*) Theorem DisjKey_Cons1: forall T Q (a:(T*Q)) x z (W:forall (a1:T) (a2:T), {a1=a2}+{a1<>a2}), DisjKey (a::x) z <-> ((~(List.In (fst a) (List.map fst z))) /\ DisjKey x z). Proof. intros. rewrite ?DisjKeyWeak_same. split. + intros. split. - unfold DisjKeyWeak in H. assert (List.In (fst a) (List.map fst (a::x)) -> List.In (fst a) (List.map fst z) -> False). apply H. intro X. apply H0. simpl. left. reflexivity. apply X. - simpl. intros. unfold DisjKeyWeak in H. unfold DisjKeyWeak. intros. assert (List.In k (List.map fst (a::x)) -> List.In k (List.map fst z) -> False). apply H. apply H2. simpl. right. apply H0. apply H1. + intros. inversion H; subst; clear H. unfold DisjKeyWeak. unfold DisjKeyWeak in H1. intros. assert (List.In k (List.map fst x) -> List.In k (List.map fst z) -> False). apply H1. simpl in H. inversion H;subst;clear H. - apply H0. apply H2. - apply H3. apply H4. apply H2. + apply W. + apply W. Qed. Theorem DisjKey_Cons2: forall T Q (a:(T*Q)) x z (W:forall (a1:T) (a2:T), {a1=a2}+{a1<>a2}), DisjKey x (a::z) <-> ((~(List.In (fst a) (List.map fst x))) /\ DisjKey x z). Proof. intros. rewrite ?DisjKeyWeak_same. split. + intros. split. - intros. unfold DisjKeyWeak in H. assert (List.In (fst a) (List.map fst x) -> List.In (fst a) (List.map fst (a::z)) -> False). apply H. intro X. apply H0. apply X. simpl. left. reflexivity. - simpl. intros. unfold DisjKeyWeak in H. unfold DisjKeyWeak. intros. assert (List.In k (List.map fst x) -> List.In k (List.map fst (a::z)) -> False). apply H. apply H2. apply H0. simpl. right. apply H1. + intros. inversion H; subst; clear H. unfold DisjKeyWeak. unfold DisjKeyWeak in H1. intros. inversion H2;subst;clear H2. - apply H0 in H. inversion H. - assert (List.In k (List.map fst x) -> List.In k (List.map fst z) -> False). apply H1. apply H2. apply H. apply H3. + apply W. + apply W. Qed. Theorem DisjKey_Append1: forall T Q (x:list (T*Q)) y z (W:forall (a1:T) (a2:T), {a1=a2}+{a1<>a2}), DisjKey (x++y) z<->(DisjKey x z /\ DisjKey y z). Proof. intros. rewrite ?DisjKeyWeak_same. induction x. + simpl. unfold DisjKeyWeak. simpl. split. - intros. * split. tauto. apply H. - intros. inversion H. subst. clear H. eapply H3. apply H0. apply H1. + simpl. repeat (rewrite <- DisjKeyWeak_same). rewrite ?DisjKey_Cons1. rewrite ?DisjKeyWeak_same. split. - intros. inversion H; subst; clear H. split. * split. ++ apply H0. ++ rewrite IHx in H1. inversion H1; subst; clear H1. apply H. * rewrite IHx in H1. inversion H1; subst; clear H1. apply H2. - simpl. intros. inversion H; subst; clear H. split. * inversion H0; subst; clear H0. apply H. * simpl. rewrite IHx. split. ++ inversion H0; subst; clear H0. apply H2. ++ simpl. apply H1. - apply W. - apply W. - apply W. - apply W. - apply W. - apply W. - apply W. - apply W. + apply W. + apply W. + apply W. Qed. Theorem DisjKey_Append2: forall T Q (x:list (T*Q)) y z (W:forall (a1:T) (a2:T), {a1=a2}+{a1<>a2}), DisjKey x (y++z)<->(DisjKey x y /\ DisjKey x z). Proof. intros. rewrite ?DisjKeyWeak_same. induction y. + simpl. unfold DisjKeyWeak. split. - intros. tauto. - simpl. intros. inversion H; subst; clear H. assert (List.In k (List.map fst x) -> List.In k (List.map fst z) -> False). apply H3. apply H. apply H0. apply H1. + simpl. repeat (rewrite <- DisjKeyWeak_same). rewrite ?DisjKey_Cons2. rewrite ?DisjKeyWeak_same. split. - intros. inversion H; subst; clear H. * split. ++ split. -- apply H0. -- apply IHy in H1. inversion H1; subst; clear H1. apply H. ++ apply IHy in H1. inversion H1; subst; clear H1. apply H2. - intros. inversion H; subst; clear H. inversion H0; subst; clear H0. split. * apply H. * apply IHy. split. ++ apply H2. ++ apply H1. - apply W. - apply W. - apply W. - apply W. - apply W. - apply W. - apply W. - apply W. + apply W. + apply W. + apply W. Qed. Theorem DisjKey_In_map2: forall A B a (k:A) r l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}), @DisjKey A B a ((k,r)::l)<->(~List.In k (List.map fst a) /\ (DisjKey a l)). Proof. intros. rewrite DisjKey_Cons2. simpl. reflexivity. apply W. Qed. Theorem DisjKey_In_map1: forall A B b (k:A) r l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}), @DisjKey A B ((k,r)::l) b<->(~List.In k (List.map fst b) /\ (DisjKey l b)). Proof. intros. rewrite DisjKey_Cons1. simpl. reflexivity. apply W. Qed. Theorem DisjKey_In_map_fst2: forall A B a (f:(A*B)) l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}), @DisjKey A B a (f::l)<->(~List.In (fst f) (List.map fst a) /\ (DisjKey a l)). Proof. intros. rewrite DisjKey_Cons2. reflexivity. apply W. Qed. Theorem DisjKey_In_map_fst1: forall A B b (f:(A*B)) l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}), @DisjKey A B (f::l) b<->(~List.In (fst f) (List.map fst b) /\ (DisjKey l b)). Proof. intros. rewrite DisjKey_Cons1. reflexivity. apply W. Qed. Theorem map_getAllRegisters_map_RegFileBase: forall m, (List.map getAllRegisters (List.map (fun mm: RegFileBase => (Base (BaseRegFile mm))) m))= (List.map (fun mm: RegFileBase => getRegFileRegisters mm) m). Proof. induction m. + reflexivity. + simpl. rewrite IHm. reflexivity. Qed. Theorem map_getAllMethods_map_RegFileBase: forall m, (List.map getAllMethods (List.map (fun mm: RegFileBase => (Base (BaseRegFile mm))) m))= (List.map (fun mm: RegFileBase => getRegFileMethods mm) m). Proof. induction m. + reflexivity. + simpl. rewrite IHm. reflexivity. Qed. Theorem concat_map_getAllRules_map_RegFileBase: forall m, (concat (List.map getAllRules (List.map (fun mm: RegFileBase => (Base (BaseRegFile mm))) m))) = List.nil. Proof. induction m. + reflexivity. + simpl. rewrite IHm. reflexivity. Qed. Hint Rewrite getAllRegisters_fold_right_ConcatMod getAllMethods_fold_right_ConcatMod getAllRules_fold_right_ConcatMod concat_map_getAllRules_map_RegFileBase map_getAllMethods_map_RegFileBase map_getAllRegisters_map_RegFileBase : kami_rewrite_db. Hint Rewrite getAllRegisters_ConcatMod DisjKey_Append1 DisjKey_Append2 DisjKey_In_map2 DisjKey_In_map1 : kami_rewrite_db. Hint Rewrite DisjKey_In_map_fst2 DisjKey_In_map_fst1: kami_rewrite_db. Theorem getAllRegisters_BaseMod: forall regs rules dms, getAllRegisters (BaseMod regs rules dms)=regs. Proof. simpl. reflexivity. Qed. Theorem append_equal_prefix: forall T (a: list T) (b: list T) (c: list T), (a++b=a++c)->(b=c). Proof. intros. induction a. + rewrite ?app_nil_l. apply H. + inversion H; subst; clear H. apply IHa. apply H1. Qed. (*Theorem append_nequal_prefix: forall T (a: list T) (b: list T) (c: list T), (List.app a b<>List.app a c)<>(b=c). Proof. induction a. + reflexivity. + intros. simpl. destruct eq. Admitted.*) Hint Rewrite getAllRegisters_BaseMod append_equal_prefix : kami_rewrite_db. Theorem getAllRegisters_makeModule_MERegister: forall a b, getAllRegisters (makeModule ((MERegister a)::b))=a::getAllRegisters (makeModule b). Proof. simpl. intros. reflexivity. Qed. Theorem getAllRegisters_makeModule_MERule: forall a b, getAllRegisters (makeModule ((MERule a)::b))=getAllRegisters (makeModule b). Proof. simpl. intros. reflexivity. Qed. Theorem getAllRegisters_makeModule_Registers: forall a b, getAllRegisters (makeModule ((Registers a)++b))=a++getAllRegisters (makeModule b). Proof. simpl. intros. induction a. + simpl. reflexivity. + simpl. rewrite IHa. reflexivity. Qed. Hint Rewrite getAllRegisters_makeModule_MERegister getAllRegisters_makeModule_Registers getAllRegisters_makeModule_MERule : kami_rewrite_db. Theorem in_app: forall T (x:T) (a:List.list T) (b:List.list T), (List.In x (a++b)) <-> (List.In x a)\/(List.In x b). Proof. intros. split. + intros. induction a. - simpl in H. right. apply H. - simpl in H. simpl. inversion H; subst; clear H. * left. left. reflexivity. * apply <- or_assoc. right. apply IHa. apply H0. + intros. inversion H; subst; clear H. - induction a. * unfold List.In in H0. inversion H0. * simpl. simpl in H0. inversion H0; subst; clear H0. ++ left. reflexivity. ++ right. apply IHa. apply H. - induction a. * simpl. apply H0. * simpl. right. apply IHa. Qed. Hint Rewrite in_app : kami_rewrite_db. Lemma getAllMethods_makeModule_append: forall a b, getAllMethods (makeModule (a++b))=getAllMethods (makeModule a)++getAllMethods (makeModule b). Proof. induction a. + reflexivity. + intros. destruct a. - apply IHa. - apply IHa. - unfold makeModule. simpl. simpl in IHa. rewrite IHa. reflexivity. Qed. Hint Rewrite getAllMethods_makeModule_append : kami_rewrite_db. Lemma getAllMethods_makeModule_MERegister: forall a b, getAllMethods (makeModule ((MERegister a)::b))=getAllMethods (makeModule b). Proof. simpl. reflexivity. Qed. Hint Rewrite getAllMethods_makeModule_MERegister : kami_rewrite_db. Lemma getAllMethods_makeModule_MERule: forall a b, getAllMethods (makeModule ((MERule a)::b))=getAllMethods (makeModule b). Proof. simpl. reflexivity. Qed. Hint Rewrite getAllMethods_makeModule_MERule : kami_rewrite_db. Lemma getAllMethods_makeModule_Registers: forall a, getAllMethods (makeModule (Registers a))=[]. Proof. induction a. + reflexivity. + simpl. apply IHa. Qed. Hint Rewrite getAllMethods_makeModule_Registers : kami_rewrite_db. Lemma getAllRules_makeModule_append: forall a b, getAllRules (makeModule (a++b))=getAllRules (makeModule a)++getAllRules (makeModule b). Proof. induction a. + reflexivity. + intros. destruct a. - apply IHa. - unfold makeModule. simpl. simpl in IHa. rewrite IHa. reflexivity. - apply IHa. Qed. Hint Rewrite getAllRules_makeModule_append : kami_rewrite_db. Lemma getAllRules_makeModule_MERegister: forall a b, getAllRules (makeModule ((MERegister a)::b))=getAllRules (makeModule b). Proof. simpl. reflexivity. Qed. Hint Rewrite getAllRules_makeModule_MERegister : kami_rewrite_db. Lemma getAllRules_makeModule_MERule: forall a b, getAllRules (makeModule ((MERule a)::b))=a::(getAllRules (makeModule b)). Proof. simpl. reflexivity. Qed. Hint Rewrite getAllRules_makeModule_MERule : kami_rewrite_db. Lemma getAllRules_makeModule_Registers: forall a, getAllRules (makeModule (Registers a))=[]. Proof. induction a. + reflexivity. + simpl. apply IHa. Qed. Hint Rewrite getAllRules_makeModule_Registers : kami_rewrite_db. Hint Rewrite map_app : kami_rewrite_db. Lemma getAllMethods_createHideMod: forall m h, getAllMethods (createHideMod m h)=getAllMethods m. Proof. intros. induction h. - reflexivity. - simpl. apply IHh. Qed. Hint Rewrite getAllMethods_createHideMod : kami_rewrite_db. ================================================ FILE: Rewrites/ReflectionImpl.v ================================================ Require Import Kami.Notations. Require Import Kami.Syntax. Require Import List. Require Import Kami.Rewrites.Notations_rewrites. Require Import Program.Equality. Require Import Kami.Rewrites.ReflectionPre. Require Import Kami.Rewrites.ReflectionSoundTopTheorems. Require Import Kami.Rewrites.ReflectionSoundTheorems1. Require Import Kami.Rewrites.ReflectionSoundTheorems2. Require Import Kami.WfMod_Helper. Definition KRSimplifyTop_ImplProp (e: KRExpr_Prop) : KRExpr_Prop := match e with | KRDisjKey_RegInitT a b => match a with | KRApp_list_RegInitT x y => KRAnd_Prop (KRDisjKey_RegInitT x b) (KRDisjKey_RegInitT y b) | KRCons_list_RegInitT x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_RegInitT_string x) (KRmap_RegInitT_string KRfst_RegInitT_string_Func b))) (KRDisjKey_RegInitT y b) | KRNil_list_RegInitT => KRTrue_Prop | _ => match b with | KRApp_list_RegInitT x y => KRAnd_Prop (KRDisjKey_RegInitT a x) (KRDisjKey_RegInitT a y) | KRCons_list_RegInitT x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_RegInitT_string x) (KRmap_RegInitT_string KRfst_RegInitT_string_Func a))) (KRDisjKey_RegInitT a y) | KRNil_list_RegInitT => KRTrue_Prop | _ => KRDisjKey_RegInitT a b end end | KRDisjKey_DefMethT a b => match a with | KRApp_list_DefMethT x y => KRAnd_Prop (KRDisjKey_DefMethT x b) (KRDisjKey_DefMethT y b) | KRCons_list_DefMethT x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_DefMethT_string x) (KRmap_DefMethT_string KRfst_DefMethT_string_Func b))) (KRDisjKey_DefMethT y b) | KRNil_list_DefMethT => KRTrue_Prop | _ => match b with | KRApp_list_DefMethT x y => KRAnd_Prop (KRDisjKey_DefMethT a x) (KRDisjKey_DefMethT a y) | KRCons_list_DefMethT x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_DefMethT_string x) (KRmap_DefMethT_string KRfst_DefMethT_string_Func a))) (KRDisjKey_DefMethT a y) | KRNil_list_DefMethT => KRTrue_Prop | _ => KRDisjKey_DefMethT a b end end | KRDisjKey_Rule a b => match a with | KRApp_list_Rule x y => KRAnd_Prop (KRDisjKey_Rule x b) (KRDisjKey_Rule y b) | KRCons_list_Rule x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_Rule_string x) (KRmap_Rule_string KRfst_Rule_string_Func b))) (KRDisjKey_Rule y b) | KRNil_list_Rule => KRTrue_Prop | _ => match b with | KRApp_list_Rule x y => KRAnd_Prop (KRDisjKey_Rule a x) (KRDisjKey_Rule a y) | KRCons_list_Rule x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_Rule_string x) (KRmap_Rule_string KRfst_Rule_string_Func a))) (KRDisjKey_Rule a y) | KRNil_list_Rule => KRTrue_Prop | _ => KRDisjKey_Rule a b end end | KRAnd_Prop a KRTrue_Prop => a | KRAnd_Prop a KRFalse_Prop => KRFalse_Prop | KRAnd_Prop KRTrue_Prop a => a | KRAnd_Prop KRFalse_Prop a => KRFalse_Prop | KROr_Prop a KRTrue_Prop => KRTrue_Prop | KROr_Prop a KRFalse_Prop => a | KROr_Prop KRTrue_Prop a => KRTrue_Prop | KROr_Prop KRFalse_Prop a => a | KRNot_Prop (KRTrue_Prop) => KRFalse_Prop | KRNot_Prop (KRFalse_Prop) => KRTrue_Prop (*| KRNot_Prop (KRNot_Prop a) => a*) (*| KRNot_Prop (KRAnd_Prop a b) => (KROr_Prop (KRNot_Prop a) (KRNot_Prop b)) | KRNot_Prop (KROr_Prop a b) => (KRAnd_Prop (KRNot_Prop a) (KRNot_Prop b))*) | KRIn_string_Prop x (KRApp_list_string a b) => (KROr_Prop (KRIn_string_Prop x a) (KRIn_string_Prop x b)) | KRIn_string_Prop x (KRCons_list_string a b) => (KROr_Prop (KREq_string_Prop x a) (KRIn_string_Prop x b)) | KRIn_string_Prop x (KRNil_list_string) => KRFalse_Prop | KRIn_RegInitT_Prop x (KRApp_list_RegInitT a b) => (KROr_Prop (KRIn_RegInitT_Prop x a) (KRIn_RegInitT_Prop x b)) | KRIn_RegInitT_Prop x (KRCons_list_RegInitT a b) => (KROr_Prop (KREq_RegInitT_Prop x a) (KRIn_RegInitT_Prop x b)) | KRIn_RegInitT_Prop x (KRNil_list_RegInitT) => KRFalse_Prop | KRIn_Rule_Prop x (KRApp_list_Rule a b) => (KROr_Prop (KRIn_Rule_Prop x a) (KRIn_Rule_Prop x b)) | KRIn_Rule_Prop x (KRCons_list_Rule a b) => (KROr_Prop (KREq_Rule_Prop x a) (KRIn_Rule_Prop x b)) | KRIn_Rule_Prop x (KRNil_list_Rule) => KRFalse_Prop | KRIn_DefMethT_Prop x (KRApp_list_DefMethT a b) => (KROr_Prop (KRIn_DefMethT_Prop x a) (KRIn_DefMethT_Prop x b)) | KRIn_DefMethT_Prop x (KRCons_list_DefMethT a b) => (KROr_Prop (KREq_DefMethT_Prop x a) (KRIn_DefMethT_Prop x b)) | KRIn_DefMethT_Prop x (KRNil_list_DefMethT) => KRFalse_Prop | KREq_string_Prop (KRstring_append p (KRConst_string a)) (KRstring_append q (KRConst_string b)) => if sdisjPrefix (srev a) (srev b) then KRFalse_Prop else e (*| KREq_string_Prop (KRstring_append (KRVar_string p) a) (KRstring_append (KRVar_string q) b) => if String.eqb p q then (KREq_string_Prop a b) else KREq_string_Prop (KRstring_append (KRVar_string p) a) (KRstring_append (KRVar_string q) b) | KREq_string_Prop (KRVar_string a) (KRVar_string b) => if String.eqb a b then KRTrue_Prop else (KREq_string_Prop (KRVar_string a) (KRVar_string b))*) | e => e end. Fixpoint KRSimplify_ImplProp(p:KRExpr_Prop) := KRSimplifyTop_ImplProp (match p with | KRAnd_Prop a b => KRAnd_Prop (KRSimplify_ImplProp a) (KRSimplify_ImplProp b) | KROr_Prop a b => KROr_Prop (KRSimplify_ImplProp a) (KRSimplify_ImplProp b) | KRNot_Prop a => KRNot_Prop (KRSimplify_ImplProp a) | KRIn_string_Prop a b => KRIn_string_Prop (KRSimplify_string a) (KRSimplify_list_string b) | KRIn_RegInitT_Prop a b => KRIn_RegInitT_Prop (KRSimplify_RegInitT a) (KRSimplify_list_RegInitT b) | KRIn_DefMethT_Prop a b => KRIn_DefMethT_Prop (KRSimplify_DefMethT a) (KRSimplify_list_DefMethT b) | KRIn_Rule_Prop a b => KRIn_Rule_Prop (KRSimplify_Rule a) (KRSimplify_list_Rule b) | KRDisjKey_RegInitT a b => KRDisjKey_RegInitT (KRSimplify_list_RegInitT a) (KRSimplify_list_RegInitT b) | KRDisjKey_DefMethT a b => KRDisjKey_DefMethT (KRSimplify_list_DefMethT a) (KRSimplify_list_DefMethT b) | KRDisjKey_Rule a b => KRDisjKey_Rule (KRSimplify_list_Rule a) (KRSimplify_list_Rule b) | KREq_string_Prop a b => KREq_string_Prop (KRSimplify_string a) (KRSimplify_string b) | KREq_RegInitT_Prop a b => KREq_RegInitT_Prop (KRSimplify_RegInitT a) (KRSimplify_RegInitT b) | KREq_Rule_Prop a b => KREq_Rule_Prop (KRSimplify_Rule a) (KRSimplify_Rule b) | KREq_DefMethT_Prop a b => KREq_DefMethT_Prop (KRSimplify_DefMethT a) (KRSimplify_DefMethT b) | p => p end). Theorem KRSimplify_ImplProp_KRAnd_Prop: forall a b, KRSimplify_ImplProp (KRAnd_Prop a b)= KRSimplifyTop_ImplProp (KRAnd_Prop (KRSimplify_ImplProp a) (KRSimplify_ImplProp b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRAnd_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KROr_Prop: forall a b, KRSimplify_ImplProp (KROr_Prop a b)= KRSimplifyTop_ImplProp (KROr_Prop (KRSimplify_ImplProp a) (KRSimplify_ImplProp b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KROr_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KRNot_Prop: forall a, KRSimplify_ImplProp (KRNot_Prop a)= KRSimplifyTop_ImplProp (KRNot_Prop (KRSimplify_ImplProp a)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRNot_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KRIn_string_Prop: forall a b, KRSimplify_ImplProp (KRIn_string_Prop a b)= KRSimplifyTop_ImplProp (KRIn_string_Prop (KRSimplify_string a) (KRSimplify_list_string b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRIn_string_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KRIn_RegInitT_Prop: forall a b, KRSimplify_ImplProp (KRIn_RegInitT_Prop a b)= KRSimplifyTop_ImplProp (KRIn_RegInitT_Prop (KRSimplify_RegInitT a) (KRSimplify_list_RegInitT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRIn_RegInitT_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KRIn_DefMethT_Prop: forall a b, KRSimplify_ImplProp (KRIn_DefMethT_Prop a b)= KRSimplifyTop_ImplProp (KRIn_DefMethT_Prop (KRSimplify_DefMethT a) (KRSimplify_list_DefMethT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRIn_DefMethT_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KRIn_Rule_Prop: forall a b, KRSimplify_ImplProp (KRIn_Rule_Prop a b)= KRSimplifyTop_ImplProp (KRIn_Rule_Prop (KRSimplify_Rule a) (KRSimplify_list_Rule b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRIn_Rule_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KRDisjKey_RegInitT_Prop: forall a b, KRSimplify_ImplProp (KRDisjKey_RegInitT a b)= KRSimplifyTop_ImplProp (KRDisjKey_RegInitT (KRSimplify_list_RegInitT a) (KRSimplify_list_RegInitT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRDisjKey_RegInitT_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KRDisjKey_DefMethT_Prop: forall a b, KRSimplify_ImplProp (KRDisjKey_DefMethT a b)= KRSimplifyTop_ImplProp (KRDisjKey_DefMethT (KRSimplify_list_DefMethT a) (KRSimplify_list_DefMethT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRDisjKey_DefMethT_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KRDisjKey_Rule_Prop: forall a b, KRSimplify_ImplProp (KRDisjKey_Rule a b)= KRSimplifyTop_ImplProp (KRDisjKey_Rule (KRSimplify_list_Rule a) (KRSimplify_list_Rule b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KRDisjKey_Rule_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KREq_string_Prop: forall a b, KRSimplify_ImplProp (KREq_string_Prop a b)= KRSimplifyTop_ImplProp (KREq_string_Prop (KRSimplify_string a) (KRSimplify_string b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KREq_string_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KREq_RegInitT_Prop: forall a b, KRSimplify_ImplProp (KREq_RegInitT_Prop a b)= KRSimplifyTop_ImplProp (KREq_RegInitT_Prop (KRSimplify_RegInitT a) (KRSimplify_RegInitT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KREq_RegInitT_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KREq_DefMethT_Prop: forall a b, KRSimplify_ImplProp (KREq_DefMethT_Prop a b)= KRSimplifyTop_ImplProp (KREq_DefMethT_Prop (KRSimplify_DefMethT a) (KRSimplify_DefMethT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KREq_DefMethT_Prop : KRSimplify. Theorem KRSimplify_ImplProp_KREq_Rule_Prop: forall a b, KRSimplify_ImplProp (KREq_Rule_Prop a b)= KRSimplifyTop_ImplProp (KREq_Rule_Prop (KRSimplify_Rule a) (KRSimplify_Rule b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ImplProp_KREq_Rule_Prop : KRSimplify. Theorem sdisjPrefix_false': forall p1 p2 s1 s2, sdisjPrefix (srev s1) (srev s2)=true -> (p1++s1=p2++s2)%string -> False. Proof. intros p1 p2 s1 s2. repeat (rewrite <- sappend_append). assert ((p2++s2)%string=sappend p2 s2). - rewrite <- sappend_append. reflexivity. - rewrite H. intros. eapply sdisjPrefix_sappend_false. + apply H0. + apply H1. Qed. Ltac unitSolve := simpl in *; simpl; match goal with | H: ?X |- ?X => apply H | |- True => apply I | H: False |- _ => inversion H | H: _ /\ _ |- _ => inversion H; subst; clear H; unitSolve | H: _ \/ _ |- _ => inversion H; subst; clear H; unitSolve | |- _ \/ _ => left; solve [unitSolve] | |- _ \/ _ => right; solve [unitSolve] | |- _ /\ _ => split; unitSolve | |- DisjKey _ [] => apply DisjKey_nil2 | |- DisjKey [] _ => apply DisjKey_nil1 | |- DisjKey (_::_) _ => apply DisjKey_Cons1; unitSolve | |- DisjKey _ (_::_) => apply DisjKey_Cons2; unitSolve | |- DisjKey (_++_) _ => apply DisjKey_Append1; unitSolve | |- DisjKey _ (_++_) => apply DisjKey_Append2; unitSolve (*| H: DisjKey _ [] |- _ => inversion H; subst; clear H; unitSolve | H: DisjKey [] _ |- _ => inversion H; subst; clear H; unitSolve | H: DisjKey (_::_) _ |- _ => rewrite DisjKey_Cons1 in H; unitSolve | H: DisjKey _ (_::_) |- _ => rewrite DisjKey_Cons2 in H; unitSolve | H: DisjKey (_++_) _ |- _ => inversion H; subst; clear H; unitSolve | H: DisjKey _ (_++_) |- _ => inversion H; subst; clear H; unitSolve*) | |- { _=_ }+{ _<>_ } => repeat (decide equality) | |- forall _,_ => intros; unitSolve end. Theorem KRSimplifyTopSound_ImplProp: forall e, KRExprDenote_Prop (KRSimplifyTop_ImplProp e) -> KRExprDenote_Prop e. Proof. intros. destruct e; try unitSolve. - destruct e1; destruct e2; split; try (unitSolve). - destruct e1; destruct e2; try (unitSolve). - destruct e; try (unitSolve). + simpl. intro X. apply X. - destruct k0; try unitSolve. + simpl in H. simpl. inversion H; subst; clear H. * left. rewrite H0. reflexivity. * right. apply H0. + simpl in H. simpl. rewrite in_app. try unitSolve. - destruct k; destruct k0; try unitSolve; try (destruct k2; unitSolve). destruct k2; try unitSolve. destruct k0_2; try unitSolve. simpl in H. simpl. remember (sdisjPrefix (srev s) (srev s0)). destruct b. * simpl in H. inversion H. * simpl in H. apply H. - destruct k0; try unitSolve. + simpl in H. simpl. inversion H; subst; clear H. * left. rewrite H0. reflexivity. * right. apply H0. + simpl in H. simpl. rewrite in_app. try unitSolve. - destruct k0; try unitSolve. + simpl in H. simpl. inversion H; subst; clear H. * left. rewrite H0. reflexivity. * right. apply H0. + simpl in H. simpl. rewrite in_app. try unitSolve. - destruct k0; try unitSolve. + simpl in H. simpl. inversion H; subst; clear H. * left. rewrite H0. reflexivity. * right. apply H0. + simpl in H. simpl. rewrite in_app. try unitSolve. - destruct k; destruct k0; try unitSolve. - destruct k; destruct k0; try unitSolve. - destruct k; destruct k0; try unitSolve. Qed. Theorem KRSimplifyTopSound_RevImplProp: forall e, KRExprDenote_Prop e -> KRExprDenote_Prop (KRSimplifyTop_ImplProp e). Proof. intros. destruct e; try unitSolve. - destruct e1; destruct e2; try (unitSolve). - destruct e1; destruct e2; try (unitSolve). - destruct e; try (unitSolve). + simpl in H. simpl. apply H. apply I. - destruct k0; try unitSolve. + simpl in H. simpl. inversion H; subst; clear H. * left. rewrite H0. reflexivity. * right. apply H0. + simpl in H. simpl. rewrite in_app in H. try unitSolve. - destruct k; destruct k0; try unitSolve; try (destruct k2; unitSolve). destruct k2; try unitSolve. destruct k0_2; try unitSolve. simpl in H. simpl. remember (sdisjPrefix (srev s) (srev s0)). destruct b. * apply sdisjPrefix_false' in H. simpl in H. ++ inversion H. ++ rewrite Heqb. reflexivity. * simpl. apply H. - destruct k0; try unitSolve. + simpl in H. simpl. inversion H; subst; clear H. * left. rewrite H0. reflexivity. * right. apply H0. + simpl in H. simpl. rewrite in_app in H. try unitSolve. - destruct k0; try unitSolve. + simpl in H. simpl. inversion H; subst; clear H. * left. rewrite H0. reflexivity. * right. apply H0. + simpl in H. simpl. rewrite in_app in H. try unitSolve. - destruct k0; try unitSolve. + simpl in H. simpl. inversion H; subst; clear H. * left. rewrite H0. reflexivity. * right. apply H0. + simpl in H. simpl. rewrite in_app in H. try unitSolve. - destruct k; destruct k0; try unitSolve. + simpl in H; rewrite DisjKey_Cons2 in H; [simpl; apply H | repeat (decide equality)]. + simpl in H; rewrite DisjKey_Append2 in H; [simpl; apply H | repeat (decide equality)]. + simpl in H; rewrite DisjKey_Cons1 in H; [simpl; apply H | repeat (decide equality)]. + simpl in H. simpl. split. * intro X. inversion X. * apply DisjKey_Cons1 in H. inversion H; subst; clear H. apply H1. repeat (decide equality). + simpl. rewrite DisjKey_Cons2. simpl in H. rewrite DisjKey_Cons2 in H. rewrite DisjKey_Cons1 in H. inversion H; subst; clear H. simpl in H0. inversion H1; subst; clear H1. split. * intro X. inversion X; subst; clear X. ++ rewrite H1 in H0. simpl in H0. apply H0. left. reflexivity. ++ apply H. apply H1. * split. ++ intro X. apply H0. right. apply X. ++ apply H2. * repeat (decide equality). * intros. repeat (decide equality). * intros. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. inversion H; subst; clear H. split. * apply H0. * apply H1. * intros. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. inversion H; subst; clear H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. inversion H; subst; clear H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. inversion H; subst; clear H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. inversion H; subst; clear H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. - destruct k; destruct k0; try unitSolve. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. split. * intro X. inversion X. * apply DisjKey_nil2. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). simpl in H. inversion H; subst; clear H. rewrite DisjKey_Cons1 in H1;try (repeat (decide equality)). inversion H1; subst; clear H1. split. * intro X. inversion X; subst; clear X. ++ rewrite H1 in H0. simpl in H0. apply H0. left. reflexivity. ++ apply H. apply H1. * rewrite DisjKey_Cons2; try (repeat (decide equality)). split. ++ intro X. apply H0. right. apply X. ++ apply H2. + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. - destruct k; destruct k0; try unitSolve. + simpl in H; rewrite DisjKey_Cons2 in H; [simpl; apply H | repeat (decide equality)]. + simpl in H; rewrite DisjKey_Append2 in H; [simpl; apply H | repeat (decide equality)]. + simpl in H; rewrite DisjKey_Cons1 in H; [simpl; apply H | repeat (decide equality)]. + simpl in H. simpl. split. * intro X. inversion X. * apply DisjKey_Cons1 in H. inversion H; subst; clear H. apply H1. repeat (decide equality). + simpl. rewrite DisjKey_Cons2. simpl in H. rewrite DisjKey_Cons2 in H. rewrite DisjKey_Cons1 in H. inversion H; subst; clear H. simpl in H0. inversion H1; subst; clear H1. split. * intro X. inversion X; subst; clear X. ++ rewrite H1 in H0. simpl in H0. apply H0. left. reflexivity. ++ apply H. apply H1. * split. ++ intro X. apply H0. right. apply X. ++ apply H2. * repeat (decide equality). * intros. repeat (decide equality). * intros. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Append1 in H. unitSolve. repeat (decide equality). + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Cons2 in H;try (repeat (decide equality)). apply H. + simpl. simpl in H. rewrite DisjKey_Append2 in H;try (repeat (decide equality)). apply H. Qed. Theorem KRSimplifySound_ImplProp: forall e, KRExprDenote_Prop (KRSimplify_ImplProp e) <-> KRExprDenote_Prop e. Proof. induction e; try (simpl; split; unitSolve). - split. * intros. simpl. autorewrite with KRSimplify in H. apply KRSimplifyTopSound_ImplProp in H. simpl in H. inversion H; subst; clear H. apply IHe1 in H0. apply IHe2 in H1. split. ++ apply H0. ++ apply H1. * intros. simpl in H. autorewrite with KRSimplify. apply KRSimplifyTopSound_RevImplProp. simpl. inversion H; subst; clear H. split. ++ apply IHe1. apply H0. ++ apply IHe2. apply H1. - split. * intros. simpl. autorewrite with KRSimplify in H. apply KRSimplifyTopSound_ImplProp in H. simpl in H. inversion H; subst; clear H. + left. apply IHe1. apply H0. + right. apply IHe2. apply H0. * intros. simpl in H. autorewrite with KRSimplify. apply KRSimplifyTopSound_RevImplProp. simpl. inversion H; subst; clear H. + left. apply IHe1. apply H0. + right. apply IHe2. apply H0. - split. * intros. simpl. autorewrite with KRSimplify in H. apply KRSimplifyTopSound_ImplProp in H. simpl in H. intro X. apply IHe in X. apply H in X. inversion X. * intros. simpl in H. autorewrite with KRSimplify. apply KRSimplifyTopSound_RevImplProp. simpl. intro X. apply IHe in X. apply H in X. inversion X. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. - autorewrite with KRSimplify. split. * intros. simpl. apply KRSimplifyTopSound_ImplProp in H. simpl in H. autorewrite with KRSimplify in H. apply H. * intros. simpl in H. apply KRSimplifyTopSound_RevImplProp. simpl. autorewrite with KRSimplify. apply H. Qed. Hint Rewrite KRSimplifySound_ImplProp : KRSimplify. (*Goal forall (a:ModuleElt) (b:list ModuleElt) c, app (cons a b) c=cons a (app b c). intros. match goal with | |- ?A = ?B => let x := (ltac:(KRExprReify A (KRTypeList (KRTypeElem KRElemModuleElt)))) in change A with (KRExprDenote_list_ModuleElt x); rewrite KRSimplifySound_list_ModuleElt; cbv [KRSimplify_list_ModuleElt KRSimplifyTop_list_ModuleElt KRExprDenote_list_ModuleElt KRExprDenote_ModuleElt KRSimplifyTop_ModuleElt KRSimplify_ModuleElt] end. Abort.*) Ltac KRSimplifyTac e tp := let x := (ltac:(KRExprReify e tp)) in let denote := match tp with | (KRTypeElem KRElemRegInitT) => KRExprDenote_RegInitT | (KRTypeElem KRElemRule) => KRExprDenote_Rule | (KRTypeElem KRElemDefMethT) => KRExprDenote_DefMethT | (KRTypeElem KRElemModuleElt) => KRExprDenote_ModuleElt | (KRTypeList (KRTypeElem KRElemRegInitT)) => KRExprDenote_list_RegInitT | (KRTypeList (KRTypeElem KRElemRule)) => KRExprDenote_list_Rule | (KRTypeList (KRTypeElem KRElemDefMethT)) => KRExprDenote_list_DefMethT | (KRTypeList (KRTypeElem KRElemModuleElt)) => KRExprDenote_list_ModuleElt | (KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT))) => KRExprDenote_list_list_RegInitT | (KRTypeList (KRTypeList (KRTypeElem KRElemRule))) => KRExprDenote_list_list_Rule | (KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT))) => KRExprDenote_list_list_DefMethT | (KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt))) => KRExprDenote_list_list_ModuleElt | (KRTypeElem KRElemBaseModule) => KRExprDenote_BaseModule | (KRTypeElem KRElemMod) => KRExprDenote_Mod | (KRTypeList (KRTypeElem KRElemMod)) => KRExprDenote_list_Mod | (KRTypeElem KRElemString) => KRExprDenote_string | (KRTypeList (KRTypeElem KRElemString)) => KRExprDenote_list_string | (KRTypeList (KRTypeList (KRTypeElem KRElemString))) => KRExprDenote_list_list_string | (KRTypeElem KRElemRegFileBase) => KRExprDenote_RegFileBase | (KRTypeList (KRTypeElem KRElemRegFileBase)) => KRExprDenote_list_RegFileBase | (KRTypeElem KRElemCallWithSign) => KRExprDenote_CallWithSign | (KRTypeList (KRTypeElem KRElemCallWithSign)) => KRExprDenote_list_CallWithSign | (KRTypeList (KRTypeList (KRTypeElem KRElemCallWithSign))) => KRExprDenote_list_list_CallWithSign | (KRTypeElem KRElemProp) => KRExprDenote_Prop end in let simplifySound := match tp with | (KRTypeElem KRElemRegInitT) => KRSimplifySound_RegInitT | (KRTypeElem KRElemRule) => KRSimplifySound_Rule | (KRTypeElem KRElemDefMethT) => KRSimplifySound_DefMethT | (KRTypeElem KRElemModuleElt) => KRSimplifySound_ModuleElt | (KRTypeList (KRTypeElem KRElemRegInitT)) => KRSimplifySound_list_RegInitT | (KRTypeList (KRTypeElem KRElemRule)) => KRSimplifySound_list_Rule | (KRTypeList (KRTypeElem KRElemDefMethT)) => KRSimplifySound_list_DefMethT | (KRTypeList (KRTypeElem KRElemModuleElt)) => KRSimplifySound_list_ModuleElt | (KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT))) => KRSimplifySound_list_RegInitT | (KRTypeList (KRTypeList (KRTypeElem KRElemRule))) => KRSimplifySound_list_Rule | (KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT))) => KRSimplifySound_list_DefMethT | (KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt))) => KRSimplifySound_list_list_ModuleElt | (KRTypeElem KRElemString) => KRSimplifySound_string | (KRTypeList (KRTypeElem KRElemString)) => KRSimplifySound_list_string | (KRTypeList (KRTypeList (KRTypeElem KRElemString))) => KRSimplifySound_list_list_string | (KRTypeElem KRElemRegFileBase) => KRSimplifySound_RegFileBase | (KRTypeList (KRTypeElem KRElemRegFileBase)) => KRSimplify_list_RegFileBase | (KRTypeElem KRElemCallWithSign) => KRSimplifySound_CallWithSign | (KRTypeList (KRTypeElem KRElemCallWithSign)) => KRSimplify_list_CallWithSign | (KRTypeElem KRElemBaseModule) => KRSimplifySound_BaseModule | (KRTypeElem KRElemMod) => KRSimplifySound_Mod | (KRTypeList (KRTypeElem KRElemMod)) => KRSimplifySound_list_Mod | (KRTypeElem KRElemProp) => KRSimplifySound_ImplProp end in change e with (denote x);repeat (rewrite <- simplifySound;try (repeat (decide equality));cbv [ sappend srev sdisjPrefix String.eqb Ascii.eqb Bool.eqb KRSimplify_RegInitT KRSimplifyTop_RegInitT KRSimplify_RegInitValT KRSimplifyTop_RegInitValT KRSimplify_Rule KRSimplifyTop_Rule KRSimplify_DefMethT KRSimplifyTop_DefMethT KRSimplify_ModuleElt KRSimplifyTop_ModuleElt KRSimplify_list_RegInitT KRSimplifyTop_list_RegInitT KRSimplify_list_Rule KRSimplifyTop_list_Rule KRSimplify_list_DefMethT KRSimplifyTop_list_DefMethT KRSimplify_list_ModuleElt KRSimplifyTop_list_ModuleElt KRSimplify_list_list_RegInitT KRSimplifyTop_list_list_RegInitT KRSimplify_list_list_Rule KRSimplifyTop_list_list_Rule KRSimplify_list_list_DefMethT KRSimplifyTop_list_list_DefMethT KRSimplify_list_list_ModuleElt KRSimplifyTop_list_list_ModuleElt KRSimplify_BaseModule KRSimplifyTop_BaseModule KRSimplify_RegFileBase KRSimplifyTop_RegFileBase KRSimplify_list_RegFileBase KRSimplifyTop_list_RegFileBase KRSimplify_string KRSimplifyTop_string KRSimplify_list_string KRSimplifyTop_list_string KRSimplify_list_list_string KRSimplifyTop_list_list_string KRSimplify_Mod KRSimplifyTop_Mod KRSimplify_Mod KRSimplifyTop_list_Mod KRSimplify_ImplProp KRSimplifyTop_ImplProp ]); cbv [ sappend srev sdisjPrefix String.eqb Ascii.eqb Bool.eqb KRExprDenote_RegInitT KRExprDenote_RegInitValT KRExprDenote_Rule KRExprDenote_DefMethT KRExprDenote_ModuleElt KRExprDenote_list_RegInitT KRExprDenote_list_Rule KRExprDenote_list_DefMethT KRExprDenote_ActionVoid KRExprDenote_MethodT KRExprDenote_list_ModuleElt KRExprDenote_list_list_RegInitT KRExprDenote_list_list_Rule KRExprDenote_list_list_DefMethT KRExprDenote_list_list_ModuleElt KRExprDenote_BaseModule KRExprDenote_Mod KRExprDenote_list_Mod KRExprDenote_RegFileBase KRExprDenote_list_RegFileBase KRExprDenote_string KRExprDenote_list_string KRExprDenote_list_list_string KRExprDenote_Prop]. (*Ltac KRPrintReify e := let x := (ltac:(KRExprReify e t)) in let t := eval compute in (KRTypeDenote x) in let xx := (ltac:(KRExprReify e t)) in idtac t;idtac x. *) Goal forall a b c d e, Registers ([a;b]++[c;d])=e. intros. match goal with | |- ?A = ?B => KRSimplifyTac A (KRTypeList (KRTypeElem KRElemModuleElt)) end. Abort. Goal forall a b c d e, makeModule_regs [MERegister a;MERule b;MEMeth c;MERegister d]=e. intros. match goal with | |- ?A = ?B => (*let x := (ltac:(KRExprReify A (KRTypeList (KRTypeElem KRElemRegInitT)))) in idtac x*) KRSimplifyTac A (KRTypeList (KRTypeElem KRElemRegInitT)) end. Abort. Goal forall a b c d e, makeModule_rules [MERegister a;MERule b;MEMeth c;MERegister d]=e. intros. match goal with | |- ?A = ?B => KRSimplifyTac A (KRTypeList (KRTypeElem KRElemRule)) end. Abort. Goal forall a b c d e, makeModule_meths [MEMeth a;MERule b;MERegister c;MERegister d]=e. intros. match goal with | |- ?A = ?B => KRSimplifyTac A (KRTypeList (KRTypeElem KRElemDefMethT)) end. Abort. Goal forall e, makeModule_regs []=e. intros. match goal with | |- ?A = ?B => KRSimplifyTac A (KRTypeList (KRTypeElem KRElemRegInitT)) end. Abort. Goal forall x, x \/ True. intros. match goal with | |- ?X => KRSimplifyTac X (KRTypeElem KRElemProp) end. Abort. Goal forall proc_name, ~(( proc_name ++ "_" ++ "a")%string = (proc_name ++ "_" ++ "b")%string). intros. match goal with | |- ~ ?A => let x := (ltac:(KRExprReify (~A) (KRTypeElem KRElemProp))) in change (~A) with (KRExprDenote_Prop x) end. rewrite <- KRSimplifySound_ImplProp. cbv [ KRSimplify_RegInitT KRSimplifyTop_RegInitT KRSimplify_RegInitValT KRSimplifyTop_RegInitValT KRSimplify_Rule KRSimplifyTop_Rule KRSimplify_DefMethT KRSimplifyTop_DefMethT KRSimplify_ModuleElt KRSimplifyTop_ModuleElt KRSimplify_list_RegInitT KRSimplifyTop_list_RegInitT KRSimplify_list_Rule KRSimplifyTop_list_Rule KRSimplify_list_DefMethT KRSimplifyTop_list_DefMethT KRSimplify_list_ModuleElt KRSimplifyTop_list_ModuleElt KRSimplify_list_list_RegInitT KRSimplifyTop_list_list_RegInitT KRSimplify_list_list_Rule KRSimplifyTop_list_list_Rule KRSimplify_list_list_DefMethT KRSimplifyTop_list_list_DefMethT KRSimplify_list_list_ModuleElt KRSimplifyTop_list_list_ModuleElt KRSimplify_BaseModule KRSimplifyTop_BaseModule KRSimplify_RegFileBase KRSimplifyTop_RegFileBase KRSimplify_list_RegFileBase KRSimplifyTop_list_RegFileBase KRSimplify_string KRSimplifyTop_string KRSimplify_list_string KRSimplifyTop_list_string KRSimplify_list_list_string KRSimplifyTop_list_list_string KRSimplify_Mod KRSimplifyTop_Mod KRSimplify_Mod KRSimplifyTop_list_Mod KRSimplify_ImplProp KRSimplifyTop_ImplProp ]. cbv [ sappend srev sdisjPrefix KRExprDenote_RegInitT KRExprDenote_Rule KRExprDenote_DefMethT KRExprDenote_ModuleElt KRExprDenote_list_RegInitT KRExprDenote_list_Rule KRExprDenote_list_DefMethT KRExprDenote_list_ModuleElt KRExprDenote_list_list_RegInitT KRExprDenote_list_list_Rule KRExprDenote_list_list_DefMethT KRExprDenote_list_list_ModuleElt KRExprDenote_BaseModule KRExprDenote_Mod KRExprDenote_list_Mod KRExprDenote_RegFileBase KRExprDenote_list_RegFileBase KRExprDenote_string KRExprDenote_list_string KRExprDenote_list_list_string KRExprDenote_Prop]. Abort. ================================================ FILE: Rewrites/ReflectionOrig.v ================================================ Require Import Kami.Notations. Require Import Kami.Syntax. Require Import List. Require Import Kami.Rewrites.Notations_rewrites. Require Import Program.Equality. Require Import Kami.Rewrites.ReflectionPre. Require Import Kami.Rewrites.ReflectionSoundTopTheorems. Require Import Kami.Rewrites.ReflectionSoundTheorems1. Require Import Kami.Rewrites.ReflectionSoundTheorems2. Definition KRSimplifyTop_Prop (e: KRExpr_Prop) : KRExpr_Prop := match e with | KRDisjKey_RegInitT a b => match a with | KRApp_list_RegInitT x y => KRAnd_Prop (KRDisjKey_RegInitT x b) (KRDisjKey_RegInitT y b) | KRCons_list_RegInitT x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_RegInitT_string x) (KRmap_RegInitT_string KRfst_RegInitT_string_Func b))) (KRDisjKey_RegInitT y b) | KRNil_list_RegInitT => KRTrue_Prop | _ => match b with | KRApp_list_RegInitT x y => KRAnd_Prop (KRDisjKey_RegInitT a x) (KRDisjKey_RegInitT a y) | KRCons_list_RegInitT x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_RegInitT_string x) (KRmap_RegInitT_string KRfst_RegInitT_string_Func a))) (KRDisjKey_RegInitT a y) | KRNil_list_RegInitT => KRTrue_Prop | _ => KRDisjKey_RegInitT a b end end | KRDisjKey_DefMethT a b => match a with | KRApp_list_DefMethT x y => KRAnd_Prop (KRDisjKey_DefMethT x b) (KRDisjKey_DefMethT y b) | KRCons_list_DefMethT x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_DefMethT_string x) (KRmap_DefMethT_string KRfst_DefMethT_string_Func b))) (KRDisjKey_DefMethT y b) | KRNil_list_DefMethT => KRTrue_Prop | _ => match b with | KRApp_list_DefMethT x y => KRAnd_Prop (KRDisjKey_DefMethT a x) (KRDisjKey_DefMethT a y) | KRCons_list_DefMethT x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_DefMethT_string x) (KRmap_DefMethT_string KRfst_DefMethT_string_Func a))) (KRDisjKey_DefMethT a y) | KRNil_list_DefMethT => KRTrue_Prop | _ => KRDisjKey_DefMethT a b end end | KRDisjKey_Rule a b => match a with | KRApp_list_Rule x y => KRAnd_Prop (KRDisjKey_Rule x b) (KRDisjKey_Rule y b) | KRCons_list_Rule x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_Rule_string x) (KRmap_Rule_string KRfst_Rule_string_Func b))) (KRDisjKey_Rule y b) | KRNil_list_Rule => KRTrue_Prop | _ => match b with | KRApp_list_Rule x y => KRAnd_Prop (KRDisjKey_Rule a x) (KRDisjKey_Rule a y) | KRCons_list_Rule x y => KRAnd_Prop (KRNot_Prop (KRIn_string_Prop (KRfst_Rule_string x) (KRmap_Rule_string KRfst_Rule_string_Func a))) (KRDisjKey_Rule a y) | KRNil_list_Rule => KRTrue_Prop | _ => KRDisjKey_Rule a b end end | KRAnd_Prop a KRTrue_Prop => a | KRAnd_Prop a KRFalse_Prop => KRFalse_Prop | KRAnd_Prop KRTrue_Prop a => a | KRAnd_Prop KRFalse_Prop a => KRFalse_Prop | KROr_Prop a KRTrue_Prop => KRTrue_Prop | KROr_Prop a KRFalse_Prop => a | KROr_Prop KRTrue_Prop a => KRTrue_Prop | KROr_Prop KRFalse_Prop a => a | KRNot_Prop (KRTrue_Prop) => KRFalse_Prop | KRNot_Prop (KRFalse_Prop) => KRTrue_Prop | KRNot_Prop (KRNot_Prop a) => a | KRNot_Prop (KRAnd_Prop a b) => (KROr_Prop (KRNot_Prop a) (KRNot_Prop b)) | KRNot_Prop (KROr_Prop a b) => (KRAnd_Prop (KRNot_Prop a) (KRNot_Prop b)) | KRIn_string_Prop x (KRApp_list_string a b) => (KROr_Prop (KRIn_string_Prop x a) (KRIn_string_Prop x b)) | KRIn_string_Prop x (KRCons_list_string a b) => (KROr_Prop (KREq_string_Prop x a) (KRIn_string_Prop x b)) | KRIn_string_Prop x (KRNil_list_string) => KRFalse_Prop | KRIn_RegInitT_Prop x (KRApp_list_RegInitT a b) => (KROr_Prop (KRIn_RegInitT_Prop x a) (KRIn_RegInitT_Prop x b)) | KRIn_RegInitT_Prop x (KRCons_list_RegInitT a b) => (KROr_Prop (KREq_RegInitT_Prop x a) (KRIn_RegInitT_Prop x b)) | KRIn_RegInitT_Prop x (KRNil_list_RegInitT) => KRFalse_Prop | KRIn_Rule_Prop x (KRApp_list_Rule a b) => (KROr_Prop (KRIn_Rule_Prop x a) (KRIn_Rule_Prop x b)) | KRIn_Rule_Prop x (KRCons_list_Rule a b) => (KROr_Prop (KREq_Rule_Prop x a) (KRIn_Rule_Prop x b)) | KRIn_Rule_Prop x (KRNil_list_Rule) => KRFalse_Prop | KRIn_DefMethT_Prop x (KRApp_list_DefMethT a b) => (KROr_Prop (KRIn_DefMethT_Prop x a) (KRIn_DefMethT_Prop x b)) | KRIn_DefMethT_Prop x (KRCons_list_DefMethT a b) => (KROr_Prop (KREq_DefMethT_Prop x a) (KRIn_DefMethT_Prop x b)) | KRIn_DefMethT_Prop x (KRNil_list_DefMethT) => KRFalse_Prop | KREq_string_Prop (KRstring_append p (KRConst_string a)) (KRstring_append q (KRConst_string b)) => if sdisjPrefix (srev a) (srev b) then KRFalse_Prop else e (*| KREq_string_Prop (KRstring_append (KRVar_string p) a) (KRstring_append (KRVar_string q) b) => if String.eqb p q then (KREq_string_Prop a b) else KREq_string_Prop (KRstring_append (KRVar_string p) a) (KRstring_append (KRVar_string q) b) | KREq_string_Prop (KRVar_string a) (KRVar_string b) => if String.eqb a b then KRTrue_Prop else (KREq_string_Prop (KRVar_string a) (KRVar_string b))*) | e => e end. Fixpoint KRSimplify_Prop(p:KRExpr_Prop) := KRSimplifyTop_Prop (match p with | KRAnd_Prop a b => KRAnd_Prop (KRSimplify_Prop a) (KRSimplify_Prop b) | KROr_Prop a b => KROr_Prop (KRSimplify_Prop a) (KRSimplify_Prop b) | KRNot_Prop a => KRNot_Prop (KRSimplify_Prop a) | KRIn_string_Prop a b => KRIn_string_Prop (KRSimplify_string a) (KRSimplify_list_string b) | KRIn_RegInitT_Prop a b => KRIn_RegInitT_Prop (KRSimplify_RegInitT a) (KRSimplify_list_RegInitT b) | KRIn_DefMethT_Prop a b => KRIn_DefMethT_Prop (KRSimplify_DefMethT a) (KRSimplify_list_DefMethT b) | KRIn_Rule_Prop a b => KRIn_Rule_Prop (KRSimplify_Rule a) (KRSimplify_list_Rule b) | KRDisjKey_RegInitT a b => KRDisjKey_RegInitT (KRSimplify_list_RegInitT a) (KRSimplify_list_RegInitT b) | KRDisjKey_DefMethT a b => KRDisjKey_DefMethT (KRSimplify_list_DefMethT a) (KRSimplify_list_DefMethT b) | KRDisjKey_Rule a b => KRDisjKey_Rule (KRSimplify_list_Rule a) (KRSimplify_list_Rule b) | KREq_string_Prop a b => KREq_string_Prop (KRSimplify_string a) (KRSimplify_string b) | KREq_RegInitT_Prop a b => KREq_RegInitT_Prop (KRSimplify_RegInitT a) (KRSimplify_RegInitT b) | KREq_Rule_Prop a b => KREq_Rule_Prop (KRSimplify_Rule a) (KRSimplify_Rule b) | KREq_DefMethT_Prop a b => KREq_DefMethT_Prop (KRSimplify_DefMethT a) (KRSimplify_DefMethT b) | p => p end). Theorem KRSimplify_Prop_KRAnd_Prop: forall a b, KRSimplify_Prop (KRAnd_Prop a b)= KRSimplifyTop_Prop (KRAnd_Prop (KRSimplify_Prop a) (KRSimplify_Prop b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRAnd_Prop : KRSimplify. Theorem KRSimplify_Prop_KROr_Prop: forall a b, KRSimplify_Prop (KROr_Prop a b)= KRSimplifyTop_Prop (KROr_Prop (KRSimplify_Prop a) (KRSimplify_Prop b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KROr_Prop : KRSimplify. Theorem KRSimplify_Prop_KRNot_Prop: forall a, KRSimplify_Prop (KRNot_Prop a)= KRSimplifyTop_Prop (KRNot_Prop (KRSimplify_Prop a)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRNot_Prop : KRSimplify. Theorem KRSimplify_Prop_KRIn_string_Prop: forall a b, KRSimplify_Prop (KRIn_string_Prop a b)= KRSimplifyTop_Prop (KRIn_string_Prop (KRSimplify_string a) (KRSimplify_list_string b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRIn_string_Prop : KRSimplify. Theorem KRSimplify_Prop_KRIn_RegInitT_Prop: forall a b, KRSimplify_Prop (KRIn_RegInitT_Prop a b)= KRSimplifyTop_Prop (KRIn_RegInitT_Prop (KRSimplify_RegInitT a) (KRSimplify_list_RegInitT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRIn_RegInitT_Prop : KRSimplify. Theorem KRSimplify_Prop_KRIn_DefMethT_Prop: forall a b, KRSimplify_Prop (KRIn_DefMethT_Prop a b)= KRSimplifyTop_Prop (KRIn_DefMethT_Prop (KRSimplify_DefMethT a) (KRSimplify_list_DefMethT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRIn_DefMethT_Prop : KRSimplify. Theorem KRSimplify_Prop_KRIn_Rule_Prop: forall a b, KRSimplify_Prop (KRIn_Rule_Prop a b)= KRSimplifyTop_Prop (KRIn_Rule_Prop (KRSimplify_Rule a) (KRSimplify_list_Rule b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRIn_Rule_Prop : KRSimplify. Theorem KRSimplify_Prop_KRDisjKey_RegInitT_Prop: forall a b, KRSimplify_Prop (KRDisjKey_RegInitT a b)= KRSimplifyTop_Prop (KRDisjKey_RegInitT (KRSimplify_list_RegInitT a) (KRSimplify_list_RegInitT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRDisjKey_RegInitT_Prop : KRSimplify. Theorem KRSimplify_Prop_KRDisjKey_DefMethT_Prop: forall a b, KRSimplify_Prop (KRDisjKey_DefMethT a b)= KRSimplifyTop_Prop (KRDisjKey_DefMethT (KRSimplify_list_DefMethT a) (KRSimplify_list_DefMethT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRDisjKey_DefMethT_Prop : KRSimplify. Theorem KRSimplify_Prop_KRDisjKey_Rule_Prop: forall a b, KRSimplify_Prop (KRDisjKey_Rule a b)= KRSimplifyTop_Prop (KRDisjKey_Rule (KRSimplify_list_Rule a) (KRSimplify_list_Rule b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KRDisjKey_Rule_Prop : KRSimplify. Theorem KRSimplify_Prop_KREq_string_Prop: forall a b, KRSimplify_Prop (KREq_string_Prop a b)= KRSimplifyTop_Prop (KREq_string_Prop (KRSimplify_string a) (KRSimplify_string b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KREq_string_Prop : KRSimplify. Theorem KRSimplify_Prop_KREq_RegInitT_Prop: forall a b, KRSimplify_Prop (KREq_RegInitT_Prop a b)= KRSimplifyTop_Prop (KREq_RegInitT_Prop (KRSimplify_RegInitT a) (KRSimplify_RegInitT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KREq_RegInitT_Prop : KRSimplify. Theorem KRSimplify_Prop_KREq_DefMethT_Prop: forall a b, KRSimplify_Prop (KREq_DefMethT_Prop a b)= KRSimplifyTop_Prop (KREq_DefMethT_Prop (KRSimplify_DefMethT a) (KRSimplify_DefMethT b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KREq_DefMethT_Prop : KRSimplify. Theorem KRSimplify_Prop_KREq_Rule_Prop: forall a b, KRSimplify_Prop (KREq_Rule_Prop a b)= KRSimplifyTop_Prop (KREq_Rule_Prop (KRSimplify_Rule a) (KRSimplify_Rule b)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Prop_KREq_Rule_Prop : KRSimplify. Theorem sdisjPrefix_false: forall p1 p2 s1 s2, sdisjPrefix (srev s1) (srev s2)=true -> False=(p1++s1=p2++s2)%string. Admitted. Theorem my_in_app_iff: forall A (a:A) (l1:list A) (l2:list A), (@In A a (l1++l2)) = (@In A a l1 \/ @In A a l2). Admitted. Hint Rewrite my_in_app_iff : kami_rewrite_db. Theorem my_DisjKey_Append1: forall T Q (x:list (T*Q)) y z, (DisjKey (x++y) z)=(DisjKey x z /\ DisjKey y z). Admitted. Hint Rewrite my_DisjKey_Append1 : kami_rewrite_db. Theorem my_DisjKey_Append2: forall T Q (x:list (T*Q)) y z, (DisjKey x (y++z))=(DisjKey x y /\ DisjKey x z). Admitted. Hint Rewrite my_DisjKey_Append2 : kami_rewrite_db. Theorem my_DisjKey_In_map2: forall A B a (k:A) r l, @DisjKey A B a ((k,r)::l)=(~List.In k (List.map fst a) /\ (DisjKey a l)). Admitted. Hint Rewrite my_DisjKey_In_map2 : kami_rewrite_db. Theorem my_DisjKey_In_map1: forall A B b (k:A) r l, (@DisjKey A B ((k,r)::l) b)=(~List.In k (List.map fst b) /\ (DisjKey l b)). Admitted. Hint Rewrite my_DisjKey_In_map1 : kami_rewrite_db. Theorem my_DisjKey_In_map_fst2: forall A B a (f:(A*B)) l, @DisjKey A B a (f::l)=(~List.In (fst f) (List.map fst a) /\ (DisjKey a l)). Admitted. Hint Rewrite my_DisjKey_In_map_fst2 : kami_rewrite_db. Theorem my_DisjKey_In_map_fst1: forall A B b (f:(A*B)) l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}), @DisjKey A B (f::l) b=(~List.In (fst f) (List.map fst b) /\ (DisjKey l b)). Admitted. Hint Rewrite my_DisjKey_In_map_fst1 : kami_rewrite_db. Theorem my_and_true1: forall p, (p /\ True)=p. Admitted. Hint Rewrite my_and_true1 : kami_rewrite_db. Theorem my_and_false1: forall p, (p /\ False)=False. Admitted. Hint Rewrite my_and_false1 : kami_rewrite_db. Theorem my_and_true2: forall p, (True /\ p )=p. Admitted. Hint Rewrite my_and_true2 : kami_rewrite_db. Theorem my_and_false2: forall p, (False /\ p)=False. Admitted. Hint Rewrite my_and_false2 : kami_rewrite_db. Theorem my_or_true1: forall p, (p \/ True)=True. Admitted. Hint Rewrite my_or_true1 : kami_rewrite_db. Theorem my_or_false1: forall p, (p \/ False)=p. Admitted. Hint Rewrite my_or_false1 : kami_rewrite_db. Theorem my_or_true2: forall p, (True \/ p )=True. Admitted. Hint Rewrite my_or_true2 : kami_rewrite_db. Theorem my_or_false2: forall p, (False \/ p)=p. Admitted. Hint Rewrite my_or_false2 : kami_rewrite_db. Theorem my_not_not: forall p, (~ (~ p))=p. Admitted. Hint Rewrite my_not_not : kami_rewrite_db. Theorem my_not_and_or: forall p q, (~ (p /\ q)) = ((~p) \/ (~q)). Admitted. Hint Rewrite my_not_and_or : kami_rewrite_db. Theorem my_not_or_and: forall p q, (~ (p \/ q)) = ((~p) /\ (~q)). Admitted. Hint Rewrite my_not_or_and : kami_rewrite_db. Theorem my_DisjKey_nil1 : forall A B (x:list (A*B)), DisjKey [] x=True. Admitted. Hint Rewrite my_DisjKey_nil1 : kami_rewrite_db. Theorem my_DisjKey_nil2 : forall A B (x:list (A*B)), DisjKey x []=True. Admitted. Hint Rewrite my_DisjKey_nil2 : kami_rewrite_db. Theorem my_not_true_false : (~ True) = False. Admitted. Hint Rewrite my_not_true_false : kami_rewrite_db. Theorem my_not_false_true : (~ False) = True. Admitted. Hint Rewrite my_not_false_true : kami_rewrite_db. Theorem my_eq_refl : forall A (a:A) (b:A), (a=b)=(b=a). Admitted. Theorem KRSimplifyTopSound_Prop: forall e, KRExprDenote_Prop (KRSimplifyTop_Prop e)=KRExprDenote_Prop e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. - replace (KRExprDenote_string k=KRExprDenote_string k0) with (KRExprDenote_string k0=KRExprDenote_string k). reflexivity. apply my_eq_refl. - remember (sdisjPrefix (srev s) (srev s0)). destruct b. + simpl. apply sdisjPrefix_false. rewrite Heqb. reflexivity. + reflexivity. - replace (KRExprDenote_RegInitT k=KRExprDenote_RegInitT k0) with (KRExprDenote_RegInitT k0=KRExprDenote_RegInitT k). reflexivity. apply my_eq_refl. - replace (KRExprDenote_Rule k=KRExprDenote_Rule k0) with (KRExprDenote_Rule k0=KRExprDenote_Rule k). reflexivity. apply my_eq_refl. - replace (KRExprDenote_DefMethT k=KRExprDenote_DefMethT k0) with (KRExprDenote_DefMethT k0=KRExprDenote_DefMethT k). reflexivity. apply my_eq_refl. Qed. Hint Rewrite KRSimplifyTopSound_Prop : KRSimplify. Theorem KRSimplifySound_Prop: forall e, KRExprDenote_Prop (KRSimplify_Prop e) = KRExprDenote_Prop e. Proof. induction e; try (autorewrite with KRSimplify); try (simpl); try (rewrite IHe1); try (rewrite IHe2); try (rewrite IHe); try (autorewrite with KRSimplify); try (reflexivity). Qed. Hint Rewrite KRSimplifySound_Prop : KRSimplify. (*Goal forall (a:ModuleElt) (b:list ModuleElt) c, app (cons a b) c=cons a (app b c). intros. match goal with | |- ?A = ?B => let x := (ltac:(KRExprReify A (KRTypeList (KRTypeElem KRElemModuleElt)))) in change A with (KRExprDenote_list_ModuleElt x); rewrite KRSimplifySound_list_ModuleElt; cbv [KRSimplify_list_ModuleElt KRSimplifyTop_list_ModuleElt KRExprDenote_list_ModuleElt KRExprDenote_ModuleElt KRSimplifyTop_ModuleElt KRSimplify_ModuleElt] end. Abort.*) Ltac KRSimplifyTac e tp := let x := (ltac:(KRExprReify e tp)) in let denote := match tp with | (KRTypeElem KRElemRegInitT) => KRExprDenote_RegInitT | (KRTypeElem KRElemRule) => KRExprDenote_Rule | (KRTypeElem KRElemDefMethT) => KRExprDenote_DefMethT | (KRTypeElem KRElemModuleElt) => KRExprDenote_ModuleElt | (KRTypeList (KRTypeElem KRElemRegInitT)) => KRExprDenote_list_RegInitT | (KRTypeList (KRTypeElem KRElemRule)) => KRExprDenote_list_Rule | (KRTypeList (KRTypeElem KRElemDefMethT)) => KRExprDenote_list_DefMethT | (KRTypeList (KRTypeElem KRElemModuleElt)) => KRExprDenote_list_ModuleElt | (KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT))) => KRExprDenote_list_list_RegInitT | (KRTypeList (KRTypeList (KRTypeElem KRElemRule))) => KRExprDenote_list_list_Rule | (KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT))) => KRExprDenote_list_list_DefMethT | (KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt))) => KRExprDenote_list_list_ModuleElt | (KRTypeElem KRElemBaseModule) => KRExprDenote_BaseModule | (KRTypeElem KRElemMod) => KRExprDenote_Mod | (KRTypeList (KRTypeElem KRElemMod)) => KRExprDenote_list_Mod | (KRTypeElem KRElemString) => KRExprDenote_string | (KRTypeList (KRTypeElem KRElemString)) => KRExprDenote_list_string | (KRTypeList (KRTypeList (KRTypeElem KRElemString))) => KRExprDenote_list_list_string | (KRTypeElem KRElemRegFileBase) => KRExprDenote_RegFileBase | (KRTypeList (KRTypeElem KRElemRegFileBase)) => KRExprDenote_list_RegFileBase | (KRTypeElem KRElemCallWithSign) => KRExprDenote_CallWithSign | (KRTypeList (KRTypeElem KRElemCallWithSign)) => KRExprDenote_list_CallWithSign | (KRTypeList (KRTypeList (KRTypeElem KRElemCallWithSign))) => KRExprDenote_list_list_CallWithSign | (KRTypeElem KRElemProp) => KRExprDenote_Prop end in let simplifySound := match tp with | (KRTypeElem KRElemRegInitT) => KRSimplifySound_RegInitT | (KRTypeElem KRElemRule) => KRSimplifySound_Rule | (KRTypeElem KRElemDefMethT) => KRSimplifySound_DefMethT | (KRTypeElem KRElemModuleElt) => KRSimplifySound_ModuleElt | (KRTypeList (KRTypeElem KRElemRegInitT)) => KRSimplifySound_list_RegInitT | (KRTypeList (KRTypeElem KRElemRule)) => KRSimplifySound_list_Rule | (KRTypeList (KRTypeElem KRElemDefMethT)) => KRSimplifySound_list_DefMethT | (KRTypeList (KRTypeElem KRElemModuleElt)) => KRSimplifySound_list_ModuleElt | (KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT))) => KRSimplifySound_list_RegInitT | (KRTypeList (KRTypeList (KRTypeElem KRElemRule))) => KRSimplifySound_list_Rule | (KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT))) => KRSimplifySound_list_DefMethT | (KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt))) => KRSimplifySound_list_list_ModuleElt | (KRTypeElem KRElemString) => KRSimplifySound_string | (KRTypeList (KRTypeElem KRElemString)) => KRSimplifySound_list_string | (KRTypeList (KRTypeList (KRTypeElem KRElemString))) => KRSimplifySound_list_list_string | (KRTypeElem KRElemRegFileBase) => KRSimplifySound_RegFileBase | (KRTypeList (KRTypeElem KRElemRegFileBase)) => KRSimplify_list_RegFileBase | (KRTypeElem KRElemCallWithSign) => KRSimplifySound_CallWithSign | (KRTypeList (KRTypeElem KRElemCallWithSign)) => KRSimplify_list_CallWithSign | (KRTypeElem KRElemBaseModule) => KRSimplifySound_BaseModule | (KRTypeElem KRElemMod) => KRSimplifySound_Mod | (KRTypeList (KRTypeElem KRElemMod)) => KRSimplifySound_list_Mod | (KRTypeElem KRElemProp) => KRSimplifySound_Prop end in change e with (denote x);repeat (rewrite <- simplifySound;cbv [ sappend srev sdisjPrefix String.eqb Ascii.eqb Bool.eqb KRSimplify_RegInitT KRSimplifyTop_RegInitT KRSimplify_RegInitValT KRSimplifyTop_RegInitValT KRSimplify_Rule KRSimplifyTop_Rule KRSimplify_DefMethT KRSimplifyTop_DefMethT KRSimplify_ModuleElt KRSimplifyTop_ModuleElt KRSimplify_list_RegInitT KRSimplifyTop_list_RegInitT KRSimplify_list_Rule KRSimplifyTop_list_Rule KRSimplify_list_DefMethT KRSimplifyTop_list_DefMethT KRSimplify_list_ModuleElt KRSimplifyTop_list_ModuleElt KRSimplify_list_list_RegInitT KRSimplifyTop_list_list_RegInitT KRSimplify_list_list_Rule KRSimplifyTop_list_list_Rule KRSimplify_list_list_DefMethT KRSimplifyTop_list_list_DefMethT KRSimplify_list_list_ModuleElt KRSimplifyTop_list_list_ModuleElt KRSimplify_BaseModule KRSimplifyTop_BaseModule KRSimplify_RegFileBase KRSimplifyTop_RegFileBase KRSimplify_list_RegFileBase KRSimplifyTop_list_RegFileBase KRSimplify_string KRSimplifyTop_string KRSimplify_list_string KRSimplifyTop_list_string KRSimplify_list_list_string KRSimplifyTop_list_list_string KRSimplify_Mod KRSimplifyTop_Mod KRSimplify_Mod KRSimplifyTop_list_Mod KRSimplify_Prop KRSimplifyTop_Prop ]); cbv [ sappend srev sdisjPrefix String.eqb Ascii.eqb Bool.eqb KRExprDenote_RegInitT KRExprDenote_RegInitValT KRExprDenote_Rule KRExprDenote_DefMethT KRExprDenote_ModuleElt KRExprDenote_list_RegInitT KRExprDenote_list_Rule KRExprDenote_list_DefMethT KRExprDenote_ActionVoid KRExprDenote_MethodT KRExprDenote_list_ModuleElt KRExprDenote_list_list_RegInitT KRExprDenote_list_list_Rule KRExprDenote_list_list_DefMethT KRExprDenote_list_list_ModuleElt KRExprDenote_BaseModule KRExprDenote_Mod KRExprDenote_list_Mod KRExprDenote_RegFileBase KRExprDenote_list_RegFileBase KRExprDenote_string KRExprDenote_list_string KRExprDenote_list_list_string KRExprDenote_Prop]. (*Ltac KRPrintReify e := let x := (ltac:(KRExprReify e t)) in let t := eval compute in (KRTypeDenote x) in let xx := (ltac:(KRExprReify e t)) in idtac t;idtac x. *) Goal forall a b c d e, Registers ([a;b]++[c;d])=e. intros. match goal with | |- ?A = ?B => KRSimplifyTac A (KRTypeList (KRTypeElem KRElemModuleElt)) end. Abort. Goal forall a b c d e, makeModule_regs [MERegister a;MERule b;MEMeth c;MERegister d]=e. intros. match goal with | |- ?A = ?B => (*let x := (ltac:(KRExprReify A (KRTypeList (KRTypeElem KRElemRegInitT)))) in idtac x*) KRSimplifyTac A (KRTypeList (KRTypeElem KRElemRegInitT)) end. Abort. Goal forall a b c d e, makeModule_rules [MERegister a;MERule b;MEMeth c;MERegister d]=e. intros. match goal with | |- ?A = ?B => KRSimplifyTac A (KRTypeList (KRTypeElem KRElemRule)) end. Abort. Goal forall a b c d e, makeModule_meths [MEMeth a;MERule b;MERegister c;MERegister d]=e. intros. match goal with | |- ?A = ?B => KRSimplifyTac A (KRTypeList (KRTypeElem KRElemDefMethT)) end. Abort. Goal forall e, makeModule_regs []=e. intros. match goal with | |- ?A = ?B => KRSimplifyTac A (KRTypeList (KRTypeElem KRElemRegInitT)) end. Abort. Goal forall proc_name, ~(( proc_name ++ "_" ++ "a")%string = (proc_name ++ "_" ++ "b")%string). intros. match goal with | |- ~ ?A => let x := (ltac:(KRExprReify (~A) (KRTypeElem KRElemProp))) in change (~A) with (KRExprDenote_Prop x) end. rewrite <- KRSimplifySound_Prop. cbv [ KRSimplify_RegInitT KRSimplifyTop_RegInitT KRSimplify_RegInitValT KRSimplifyTop_RegInitValT KRSimplify_Rule KRSimplifyTop_Rule KRSimplify_DefMethT KRSimplifyTop_DefMethT KRSimplify_ModuleElt KRSimplifyTop_ModuleElt KRSimplify_list_RegInitT KRSimplifyTop_list_RegInitT KRSimplify_list_Rule KRSimplifyTop_list_Rule KRSimplify_list_DefMethT KRSimplifyTop_list_DefMethT KRSimplify_list_ModuleElt KRSimplifyTop_list_ModuleElt KRSimplify_list_list_RegInitT KRSimplifyTop_list_list_RegInitT KRSimplify_list_list_Rule KRSimplifyTop_list_list_Rule KRSimplify_list_list_DefMethT KRSimplifyTop_list_list_DefMethT KRSimplify_list_list_ModuleElt KRSimplifyTop_list_list_ModuleElt KRSimplify_BaseModule KRSimplifyTop_BaseModule KRSimplify_RegFileBase KRSimplifyTop_RegFileBase KRSimplify_list_RegFileBase KRSimplifyTop_list_RegFileBase KRSimplify_string KRSimplifyTop_string KRSimplify_list_string KRSimplifyTop_list_string KRSimplify_list_list_string KRSimplifyTop_list_list_string KRSimplify_Mod KRSimplifyTop_Mod KRSimplify_Mod KRSimplifyTop_list_Mod KRSimplify_Prop KRSimplifyTop_Prop ]. cbv [ sappend srev sdisjPrefix KRExprDenote_RegInitT KRExprDenote_Rule KRExprDenote_DefMethT KRExprDenote_ModuleElt KRExprDenote_list_RegInitT KRExprDenote_list_Rule KRExprDenote_list_DefMethT KRExprDenote_list_ModuleElt KRExprDenote_list_list_RegInitT KRExprDenote_list_list_Rule KRExprDenote_list_list_DefMethT KRExprDenote_list_list_ModuleElt KRExprDenote_BaseModule KRExprDenote_Mod KRExprDenote_list_Mod KRExprDenote_RegFileBase KRExprDenote_list_RegFileBase KRExprDenote_string KRExprDenote_list_string KRExprDenote_list_list_string KRExprDenote_Prop]. Abort. ================================================ FILE: Rewrites/ReflectionPre.v ================================================ Require Import Kami.Notations. Require Import Kami.Syntax. Require Import List. Require Import Kami.Rewrites.Notations_rewrites. Require Import Program.Equality. Inductive KRExpr_RegInitT: Type := | KRVar_RegInitT : RegInitT -> KRExpr_RegInitT | KRPair_RegInitT : KRExpr_string -> KRExpr_RegInitValT -> KRExpr_RegInitT with KRExpr_RegInitValT: Type := | KRVar_RegInitValT: sigT RegInitValT -> KRExpr_RegInitValT with KRExpr_Rule: Type := | KRVar_Rule : Attribute (Action Void) -> KRExpr_Rule | KRPair_Rule: KRExpr_string -> KRExpr_ActionVoid -> KRExpr_Rule with KRExpr_ActionVoid: Type := | KRVar_ActionVoid: Action Void -> KRExpr_ActionVoid with KRExpr_MethodT: Type := | KRVar_MethodT: sigT MethodT -> KRExpr_MethodT with KRExpr_DefMethT: Type := | KRVar_DefMethT : DefMethT -> KRExpr_DefMethT | KRPair_DefMethT : KRExpr_string -> KRExpr_MethodT -> KRExpr_DefMethT with KRExpr_ModuleElt: Type := | KRVar_ModuleElt : ModuleElt -> KRExpr_ModuleElt | KRMERegister : KRExpr_RegInitT -> KRExpr_ModuleElt | KRMERule : KRExpr_Rule -> KRExpr_ModuleElt | KRMEMeth : KRExpr_DefMethT -> KRExpr_ModuleElt with KRExpr_list_RegInitT: Type := | KRVar_list_RegInitT : list RegInitT -> KRExpr_list_RegInitT | KRNil_list_RegInitT : KRExpr_list_RegInitT | KRCons_list_RegInitT : KRExpr_RegInitT -> KRExpr_list_RegInitT -> KRExpr_list_RegInitT | KRApp_list_RegInitT : KRExpr_list_RegInitT -> KRExpr_list_RegInitT -> KRExpr_list_RegInitT | KRgetRegisters : KRExpr_BaseModule -> KRExpr_list_RegInitT | KRgetAllRegisters : KRExpr_Mod -> KRExpr_list_RegInitT | KRMakeModule_regs : KRExpr_list_ModuleElt -> KRExpr_list_RegInitT | KRConcat_RegInitT : KRExpr_list_list_RegInitT -> KRExpr_list_RegInitT with KRExpr_list_list_RegInitT: Type := | KRVar_list_list_RegInitT : list (list RegInitT) -> KRExpr_list_list_RegInitT | KRNil_list_list_RegInitT : KRExpr_list_list_RegInitT | KRCons_list_list_RegInitT : KRExpr_list_RegInitT -> KRExpr_list_list_RegInitT -> KRExpr_list_list_RegInitT | KRApp_list_list_RegInitT : KRExpr_list_list_RegInitT -> KRExpr_list_list_RegInitT -> KRExpr_list_list_RegInitT | KRMap_list_Mod_list_list_RegInitT : KRExpr_Mod_list_RegInitT_Func -> KRExpr_list_Mod -> KRExpr_list_list_RegInitT | KRMap_list_RegFileBase_list_list_RegInitT : KRExpr_RegFileBase_list_RegInitT_Func -> KRExpr_list_RegFileBase -> KRExpr_list_list_RegInitT with KRExpr_RegFileBase_list_RegInitT_Func := | KRVar_RegFileBase_list_RegInitT_Func : (RegFileBase -> list (RegInitT)) -> KRExpr_RegFileBase_list_RegInitT_Func | KRgetRegFileRegistersFunc : KRExpr_RegFileBase_list_RegInitT_Func with KRExpr_Mod_list_RegInitT_Func := | KRVar_Mod_list_RegInitT_Func : (Mod -> list (RegInitT)) -> KRExpr_Mod_list_RegInitT_Func | KRgetAllRegistersFunc : KRExpr_Mod_list_RegInitT_Func with KRExpr_list_Rule: Type := | KRVar_list_Rule : list (Attribute (Action Void)) -> KRExpr_list_Rule | KRNil_list_Rule : KRExpr_list_Rule | KRCons_list_Rule : KRExpr_Rule -> KRExpr_list_Rule -> KRExpr_list_Rule | KRApp_list_Rule : KRExpr_list_Rule -> KRExpr_list_Rule -> KRExpr_list_Rule | KRgetRules : KRExpr_BaseModule -> KRExpr_list_Rule | KRgetAllRules : KRExpr_Mod -> KRExpr_list_Rule | KRMakeModule_rules : KRExpr_list_ModuleElt -> KRExpr_list_Rule | KRConcat_Rule : KRExpr_list_list_Rule -> KRExpr_list_Rule with KRExpr_list_list_Rule: Type := | KRVar_list_list_Rule : list (list (Attribute (Action Void))) -> KRExpr_list_list_Rule | KRNil_list_list_Rule : KRExpr_list_list_Rule | KRCons_list_list_Rule : KRExpr_list_Rule -> KRExpr_list_list_Rule -> KRExpr_list_list_Rule | KRApp_list_list_Rule : KRExpr_list_list_Rule -> KRExpr_list_list_Rule -> KRExpr_list_list_Rule | KRMap_list_Mod_list_list_Rule : KRExpr_Mod_list_Rule_Func -> KRExpr_list_Mod -> KRExpr_list_list_Rule with KRExpr_Mod_list_Rule_Func := | KRVar_Mod_list_Rule_Func : (Mod-> list (Attribute (Action Void))) -> KRExpr_Mod_list_Rule_Func | KRgetAllRulesFunc : KRExpr_Mod_list_Rule_Func with KRExpr_list_DefMethT: Type := | KRVar_list_DefMethT : list DefMethT -> KRExpr_list_DefMethT | KRNil_list_DefMethT : KRExpr_list_DefMethT | KRCons_list_DefMethT : KRExpr_DefMethT -> KRExpr_list_DefMethT -> KRExpr_list_DefMethT | KRApp_list_DefMethT : KRExpr_list_DefMethT -> KRExpr_list_DefMethT -> KRExpr_list_DefMethT | KRgetMethods : KRExpr_BaseModule -> KRExpr_list_DefMethT | KRgetAllMethods : KRExpr_Mod -> KRExpr_list_DefMethT | KRMakeModule_meths : KRExpr_list_ModuleElt -> KRExpr_list_DefMethT | KRConcat_DefMethT : KRExpr_list_list_DefMethT -> KRExpr_list_DefMethT with KRExpr_list_list_DefMethT: Type := | KRVar_list_list_DefMethT : list (list DefMethT) -> KRExpr_list_list_DefMethT | KRNil_list_list_DefMethT : KRExpr_list_list_DefMethT | KRCons_list_list_DefMethT : KRExpr_list_DefMethT -> KRExpr_list_list_DefMethT -> KRExpr_list_list_DefMethT | KRApp_list_list_DefMethT : KRExpr_list_list_DefMethT -> KRExpr_list_list_DefMethT -> KRExpr_list_list_DefMethT | KRMap_list_Mod_list_list_DefMethT : KRExpr_Mod_list_DefMethT_Func -> KRExpr_list_Mod -> KRExpr_list_list_DefMethT | KRMap_list_RegFileBase_list_list_DefMethT : KRExpr_RegFileBase_list_DefMethT_Func -> KRExpr_list_RegFileBase -> KRExpr_list_list_DefMethT with KRExpr_Mod_list_DefMethT_Func := | KRVar_Mod_list_DefMethT_Func : (Mod-> list (DefMethT)) -> KRExpr_Mod_list_DefMethT_Func | KRgetAllMethodsFunc : KRExpr_Mod_list_DefMethT_Func with KRExpr_RegFileBase_list_DefMethT_Func := | KRVar_RegFileBase_list_DefMethT_Func : (RegFileBase -> list (DefMethT)) -> KRExpr_RegFileBase_list_DefMethT_Func | KRgetRegFileMethodsFunc : KRExpr_RegFileBase_list_DefMethT_Func with KRExpr_list_ModuleElt: Type := | KRVar_list_ModuleElt : list ModuleElt -> KRExpr_list_ModuleElt | KRNil_list_ModuleElt : KRExpr_list_ModuleElt | KRCons_list_ModuleElt : KRExpr_ModuleElt -> KRExpr_list_ModuleElt -> KRExpr_list_ModuleElt | KRApp_list_ModuleElt : KRExpr_list_ModuleElt -> KRExpr_list_ModuleElt -> KRExpr_list_ModuleElt | KRRegisters : KRExpr_list_RegInitT -> KRExpr_list_ModuleElt | KRRules : KRExpr_list_Rule -> KRExpr_list_ModuleElt | KRMethods : KRExpr_list_DefMethT -> KRExpr_list_ModuleElt with KRExpr_list_list_ModuleElt: Type := | KRVar_list_list_ModuleElt : list (list ModuleElt) -> KRExpr_list_list_ModuleElt | KRNil_list_list_ModuleElt : KRExpr_list_list_ModuleElt | KRCons_list_list_ModuleElt : KRExpr_list_ModuleElt -> KRExpr_list_list_ModuleElt -> KRExpr_list_list_ModuleElt | KRApp_list_list_ModuleElt : KRExpr_list_list_ModuleElt -> KRExpr_list_list_ModuleElt -> KRExpr_list_list_ModuleElt with KRExpr_CallWithSign: Type := | KRVar_CallWithSign: (string * (Kind * Kind)) -> KRExpr_CallWithSign with KRExpr_list_CallWithSign: Type := | KRVar_list_CallWithSign : list (string * (Kind * Kind)) -> KRExpr_list_CallWithSign | KRNil_list_CallWithSign : KRExpr_list_CallWithSign | KRCons_list_CallWithSign : KRExpr_CallWithSign -> KRExpr_list_CallWithSign -> KRExpr_list_CallWithSign | KRApp_list_CallWithSign : KRExpr_list_CallWithSign -> KRExpr_list_CallWithSign -> KRExpr_list_CallWithSign | KRConcat_CallWithSign : KRExpr_list_list_CallWithSign -> KRExpr_list_CallWithSign with KRExpr_list_list_CallWithSign: Type := | KRVar_list_list_CallWithSign : list (list (string * (Kind * Kind))) -> KRExpr_list_list_CallWithSign | KRNil_list_list_CallWithSign : KRExpr_list_list_CallWithSign | KRCons_list_list_CallWithSign : KRExpr_list_CallWithSign -> KRExpr_list_list_CallWithSign -> KRExpr_list_list_CallWithSign | KRApp_list_list_CallWithSign : KRExpr_list_list_CallWithSign -> KRExpr_list_list_CallWithSign -> KRExpr_list_list_CallWithSign (*| KRMap_list_Mod_list_list_CallWithSign : KRExpr_Mod_list_CallWithSign_Func -> KRExpr_list_Mod -> KRExpr_list_list_CallWithSign*) with KRExpr_Mod_list_string_Func := | KRVar_Mod_list_string_Func : (Mod-> list string) -> KRExpr_Mod_list_string_Func | KRgetCallsPerModFunc : KRExpr_Mod_list_string_Func with KRExpr_BaseModule: Type := | KRVar_BaseModule : BaseModule -> KRExpr_BaseModule | KRMakeModule : KRExpr_list_ModuleElt -> KRExpr_BaseModule | KRBaseMod : KRExpr_list_RegInitT -> KRExpr_list_Rule -> KRExpr_list_DefMethT -> KRExpr_BaseModule | KRBaseRegFile : KRExpr_RegFileBase -> KRExpr_BaseModule with KRExpr_list_BaseModule: Type := | KRVar_list_BaseModule : list BaseModule -> KRExpr_list_BaseModule | KRNil_list_BaseModule : KRExpr_list_BaseModule | KRCons_list_BaseModule : KRExpr_BaseModule -> KRExpr_list_BaseModule -> KRExpr_list_BaseModule | KRApp_list_BaseModule : KRExpr_list_BaseModule -> KRExpr_list_BaseModule -> KRExpr_list_BaseModule with KRExpr_RegFileBase: Type := | KRVar_RegFileBase: RegFileBase -> KRExpr_RegFileBase with KRExpr_list_RegFileBase: Type := | KRVar_list_RegFileBase : list RegFileBase -> KRExpr_list_RegFileBase | KRNil_list_RegFileBase : KRExpr_list_RegFileBase | KRCons_list_RegFileBase : KRExpr_RegFileBase -> KRExpr_list_RegFileBase -> KRExpr_list_RegFileBase | KRApp_list_RegFileBase : KRExpr_list_RegFileBase -> KRExpr_list_RegFileBase -> KRExpr_list_RegFileBase with KRExpr_Mod: Type := | KRVar_Mod : Mod -> KRExpr_Mod | KRBase : KRExpr_BaseModule -> KRExpr_Mod | KRConcatMod : KRExpr_Mod -> KRExpr_Mod -> KRExpr_Mod | KRFold_right_Mod : KRExpr_Mod_Mod_PairFunc -> KRExpr_Mod -> KRExpr_list_Mod -> KRExpr_Mod with KRExpr_Mod_Mod_PairFunc := | KRVar_Mod_Mod_PairFunc : (Mod -> Mod -> Mod) -> KRExpr_Mod_Mod_PairFunc | KRConcatMod_Func : KRExpr_Mod_Mod_PairFunc with KRExpr_list_Mod: Type := | KRVar_list_Mod : (list Mod) -> KRExpr_list_Mod | KRNil_list_Mod : KRExpr_list_Mod | KRCons_list_Mod : KRExpr_Mod -> KRExpr_list_Mod -> KRExpr_list_Mod | KRApp_list_Mod : KRExpr_list_Mod -> KRExpr_list_Mod -> KRExpr_list_Mod with KRExpr_RegFileBase_Mod_Func := | KRVar_RegFileBase_Mod_Func : (RegFileBase -> Mod) -> KRExpr_RegFileBase_Mod_Func | KRCastFunc: KRExpr_RegFileBase_Mod_Func with KRExpr_RegInitT_string_Func := | KRVar_RegInitT_string_Func : (RegInitT -> string) -> KRExpr_RegInitT_string_Func | KRfst_RegInitT_string_Func: KRExpr_RegInitT_string_Func with KRExpr_DefMethT_string_Func := | KRVar_DefMethT_string_Func : (DefMethT -> string) -> KRExpr_DefMethT_string_Func | KRfst_DefMethT_string_Func: KRExpr_DefMethT_string_Func with KRExpr_Rule_string_Func := | KRVar_Rule_string_Func : (Attribute (Action Void) -> string) -> KRExpr_Rule_string_Func | KRfst_Rule_string_Func: KRExpr_Rule_string_Func with KRExpr_string: Type := | KRVar_string : string -> KRExpr_string | KRConst_string : string -> KRExpr_string | KRstring_append : KRExpr_string -> KRExpr_string -> KRExpr_string | KRfst_RegInitT_string : KRExpr_RegInitT -> KRExpr_string | KRfst_DefMethT_string : KRExpr_DefMethT -> KRExpr_string | KRfst_Rule_string : KRExpr_Rule -> KRExpr_string with KRExpr_list_string: Type := | KRVar_list_string : list string -> KRExpr_list_string | KRNil_list_string : KRExpr_list_string | KRCons_list_string : KRExpr_string -> KRExpr_list_string -> KRExpr_list_string | KRApp_list_string : KRExpr_list_string -> KRExpr_list_string -> KRExpr_list_string | KRConcat_string : KRExpr_list_list_string -> KRExpr_list_string | KRgetCallsPerMod : KRExpr_Mod -> KRExpr_list_string | KRmap_RegInitT_string : KRExpr_RegInitT_string_Func -> KRExpr_list_RegInitT -> KRExpr_list_string | KRmap_DefMethT_string : KRExpr_DefMethT_string_Func -> KRExpr_list_DefMethT -> KRExpr_list_string | KRmap_Rule_string : KRExpr_Rule_string_Func -> KRExpr_list_Rule -> KRExpr_list_string with KRExpr_list_list_string: Type := | KRVar_list_list_string : list (list string) -> KRExpr_list_list_string | KRNil_list_list_string : KRExpr_list_list_string | KRCons_list_list_string : KRExpr_list_string -> KRExpr_list_list_string -> KRExpr_list_list_string | KRApp_list_list_string : KRExpr_list_list_string -> KRExpr_list_list_string -> KRExpr_list_list_string with KRExpr_Prop: Type := | KRVar_Prop : Prop -> KRExpr_Prop | KRTrue_Prop : KRExpr_Prop | KRFalse_Prop : KRExpr_Prop | KRAnd_Prop : KRExpr_Prop -> KRExpr_Prop -> KRExpr_Prop | KROr_Prop : KRExpr_Prop -> KRExpr_Prop -> KRExpr_Prop | KRNot_Prop : KRExpr_Prop -> KRExpr_Prop | KRIn_string_Prop : KRExpr_string -> KRExpr_list_string -> KRExpr_Prop | KREq_string_Prop : KRExpr_string -> KRExpr_string -> KRExpr_Prop | KRIn_RegInitT_Prop : KRExpr_RegInitT -> KRExpr_list_RegInitT -> KRExpr_Prop | KREq_RegInitT_Prop : KRExpr_RegInitT -> KRExpr_RegInitT -> KRExpr_Prop | KRIn_Rule_Prop : KRExpr_Rule -> KRExpr_list_Rule -> KRExpr_Prop | KREq_Rule_Prop : KRExpr_Rule -> KRExpr_Rule -> KRExpr_Prop | KRIn_DefMethT_Prop : KRExpr_DefMethT -> KRExpr_list_DefMethT -> KRExpr_Prop | KREq_DefMethT_Prop : KRExpr_DefMethT -> KRExpr_DefMethT -> KRExpr_Prop | KRDisjKey_RegInitT : KRExpr_list_RegInitT -> KRExpr_list_RegInitT -> KRExpr_Prop | KRDisjKey_DefMethT : KRExpr_list_DefMethT -> KRExpr_list_DefMethT -> KRExpr_Prop | KRDisjKey_Rule : KRExpr_list_Rule -> KRExpr_list_Rule -> KRExpr_Prop. (******************************************************************************************) Fixpoint KRExprDenote_RegInitValT(e: KRExpr_RegInitValT) : sigT RegInitValT := match e with | KRVar_RegInitValT x => x end. Fixpoint KRExprDenote_ActionVoid (e: KRExpr_ActionVoid) : Action Void := match e with | KRVar_ActionVoid v => v end. Fixpoint KRExprDenote_MethodT (e: KRExpr_MethodT) : sigT MethodT := match e with | KRVar_MethodT v => v end. (******************************************************************************************) Fixpoint KRExprDenote_RegFileBase_Mod_Func(f: KRExpr_RegFileBase_Mod_Func) := match f with | KRCastFunc => (fun m : RegFileBase => Base (BaseRegFile m)) | KRVar_RegFileBase_Mod_Func f => f end. Fixpoint KRExprDenote_RegInitT_string_Func(f: KRExpr_RegInitT_string_Func) : (RegInitT -> string) := match f with | KRVar_RegInitT_string_Func v => v | KRfst_RegInitT_string_Func => fst end. Fixpoint KRExprDenote_DefMethT_string_Func(f: KRExpr_DefMethT_string_Func) : (DefMethT -> string) := match f with | KRVar_DefMethT_string_Func v => v | KRfst_DefMethT_string_Func => fst end. Fixpoint KRExprDenote_RegFileBase_list_RegInitT_Func (f: KRExpr_RegFileBase_list_RegInitT_Func) := match f with | KRVar_RegFileBase_list_RegInitT_Func f => f | KRgetRegFileRegistersFunc => getRegFileRegisters end. Fixpoint KRExprDenote_Mod_list_RegInitT_Func (f: KRExpr_Mod_list_RegInitT_Func) := match f with | KRVar_Mod_list_RegInitT_Func f => f | KRgetAllRegistersFunc => getAllRegisters end. Fixpoint KRExprDenote_Mod_list_Rule_Func(f: KRExpr_Mod_list_Rule_Func) := match f with | KRVar_Mod_list_Rule_Func f' => f' | KRgetAllRulesFunc => getAllRules end. Fixpoint KRExprDenote_Mod_list_DefMethT_Func(f: KRExpr_Mod_list_DefMethT_Func) : (Mod -> list DefMethT) := match f with | KRVar_Mod_list_DefMethT_Func f => f | KRgetAllMethodsFunc => getAllMethods end. Fixpoint KRExprDenote_RegFileBase_list_DefMethT_Func(f: KRExpr_RegFileBase_list_DefMethT_Func) := match f with | KRVar_RegFileBase_list_DefMethT_Func f => f | KRgetRegFileMethodsFunc => getRegFileMethods end. Fixpoint KRExprDenote_Mod_list_string_Func(f: KRExpr_Mod_list_string_Func) : (Mod -> (list string)) := match f with | KRVar_Mod_list_string_Func f => f | KRgetCallsPerModFunc => getCallsPerMod end. Fixpoint KRExprDenote_Mod_Mod_PairFunc(f: KRExpr_Mod_Mod_PairFunc) := match f with | KRVar_Mod_Mod_PairFunc f => f | KRConcatMod_Func => ConcatMod end. Fixpoint KRExprDenote_Rule_string_Func(f: KRExpr_Rule_string_Func) : (Attribute (Action Void) -> string) := match f with | KRVar_Rule_string_Func v => v | KRfst_Rule_string_Func => fst end. (******************************************************************************************) Fixpoint KRExprDenote_RegInitT (e:KRExpr_RegInitT) : RegInitT := match e with | KRVar_RegInitT v => v | KRPair_RegInitT s v => (KRExprDenote_string s, KRExprDenote_RegInitValT v) end with KRExprDenote_DefMethT (e:KRExpr_DefMethT) : DefMethT := match e with | KRVar_DefMethT v => v | KRPair_DefMethT s v => (KRExprDenote_string s,KRExprDenote_MethodT v) end with KRExprDenote_string(s:KRExpr_string) := match s with | KRVar_string s => s | KRConst_string s => s | KRstring_append a b => ((KRExprDenote_string a)++(KRExprDenote_string b))%string | KRfst_RegInitT_string r => fst (KRExprDenote_RegInitT r) | KRfst_DefMethT_string r => fst (KRExprDenote_DefMethT r) | KRfst_Rule_string r => fst (KRExprDenote_Rule r) end with KRExprDenote_Rule (e:KRExpr_Rule) : Attribute (Action Void) := match e with | KRVar_Rule v => v | KRPair_Rule s v => (KRExprDenote_string s, KRExprDenote_ActionVoid v) end. (******************************************************************************************) Fixpoint KRExprDenote_ModuleElt (e:KRExpr_ModuleElt) : ModuleElt := match e with | KRVar_ModuleElt v => v | KRMERegister r => MERegister (KRExprDenote_RegInitT r) | KRMERule r => MERule (KRExprDenote_Rule r) | KRMEMeth m => MEMeth (KRExprDenote_DefMethT m) end. (******************************************************************************************) Fixpoint KRExprDenote_RegFileBase(m: KRExpr_RegFileBase) := match m with | KRVar_RegFileBase m => m end. (******************************************************************************************) Fixpoint KRExprDenote_list_RegFileBase(l: KRExpr_list_RegFileBase) := match l with | KRVar_list_RegFileBase l => l | KRNil_list_RegFileBase => nil | KRCons_list_RegFileBase f r => cons (KRExprDenote_RegFileBase f) (KRExprDenote_list_RegFileBase r) | KRApp_list_RegFileBase a b => app (KRExprDenote_list_RegFileBase a) (KRExprDenote_list_RegFileBase b) end. (******************************************************************************************) Fixpoint KRExprDenote_list_RegInitT (e:KRExpr_list_RegInitT) : list RegInitT := match e with | KRVar_list_RegInitT v => v | KRNil_list_RegInitT => nil | KRCons_list_RegInitT f r => cons (KRExprDenote_RegInitT f) (KRExprDenote_list_RegInitT r) | KRApp_list_RegInitT f r => app (KRExprDenote_list_RegInitT f) (KRExprDenote_list_RegInitT r) | KRgetRegisters m => getRegisters (KRExprDenote_BaseModule m) | KRgetAllRegisters m => getAllRegisters (KRExprDenote_Mod m) | KRMakeModule_regs r => makeModule_regs (KRExprDenote_list_ModuleElt r) | KRConcat_RegInitT r => concat (KRExprDenote_list_list_RegInitT r) end with KRExprDenote_BaseModule (e:KRExpr_BaseModule) : BaseModule := match e with | KRVar_BaseModule v => v | KRMakeModule e => makeModule (KRExprDenote_list_ModuleElt e) | KRBaseMod regs rules meths => BaseMod (KRExprDenote_list_RegInitT regs) (KRExprDenote_list_Rule rules) (KRExprDenote_list_DefMethT meths) | KRBaseRegFile b => BaseRegFile (KRExprDenote_RegFileBase b) end with KRExprDenote_Mod (e:KRExpr_Mod) : Mod := match e with | KRVar_Mod v => v | KRBase b => Base (KRExprDenote_BaseModule b) | KRConcatMod a b => ConcatMod (KRExprDenote_Mod a) (KRExprDenote_Mod b) | KRFold_right_Mod f a b => fold_right (KRExprDenote_Mod_Mod_PairFunc f) (KRExprDenote_Mod a) (KRExprDenote_list_Mod b) end with KRExprDenote_list_ModuleElt (e:KRExpr_list_ModuleElt) : list ModuleElt := match e with | KRVar_list_ModuleElt v => v | KRNil_list_ModuleElt => nil | KRCons_list_ModuleElt f r => cons (KRExprDenote_ModuleElt f) (KRExprDenote_list_ModuleElt r) | KRApp_list_ModuleElt f r => app (KRExprDenote_list_ModuleElt f) (KRExprDenote_list_ModuleElt r) | KRRegisters r => Registers (KRExprDenote_list_RegInitT r) | KRRules r => Rules (KRExprDenote_list_Rule r) | KRMethods m => Methods (KRExprDenote_list_DefMethT m) end with KRExprDenote_list_list_RegInitT (e:KRExpr_list_list_RegInitT) : list (list RegInitT) := match e with | KRVar_list_list_RegInitT v => v | KRNil_list_list_RegInitT => nil | KRCons_list_list_RegInitT f r => cons (KRExprDenote_list_RegInitT f) (KRExprDenote_list_list_RegInitT r) | KRApp_list_list_RegInitT f r => app (KRExprDenote_list_list_RegInitT f) (KRExprDenote_list_list_RegInitT r) | KRMap_list_Mod_list_list_RegInitT f l => map (KRExprDenote_Mod_list_RegInitT_Func f) (KRExprDenote_list_Mod l) | KRMap_list_RegFileBase_list_list_RegInitT f l => map (KRExprDenote_RegFileBase_list_RegInitT_Func f) (KRExprDenote_list_RegFileBase l) end with KRExprDenote_list_DefMethT (e:KRExpr_list_DefMethT) : list DefMethT := match e with | KRVar_list_DefMethT v => v | KRNil_list_DefMethT => nil | KRCons_list_DefMethT f r => cons (KRExprDenote_DefMethT f) (KRExprDenote_list_DefMethT r) | KRApp_list_DefMethT f r => app (KRExprDenote_list_DefMethT f) (KRExprDenote_list_DefMethT r) | KRConcat_DefMethT r => concat (KRExprDenote_list_list_DefMethT r) | KRgetMethods m => getMethods (KRExprDenote_BaseModule m) | KRgetAllMethods m => getAllMethods (KRExprDenote_Mod m) | KRMakeModule_meths r => makeModule_meths (KRExprDenote_list_ModuleElt r) end with KRExprDenote_list_Rule (e:KRExpr_list_Rule) : list (Attribute (Action Void)) := match e with | KRVar_list_Rule v => v | KRNil_list_Rule => nil | KRCons_list_Rule f r => cons (KRExprDenote_Rule f) (KRExprDenote_list_Rule r) | KRApp_list_Rule f r => app (KRExprDenote_list_Rule f) (KRExprDenote_list_Rule r) | KRgetRules m => getRules (KRExprDenote_BaseModule m) | KRgetAllRules m => getAllRules (KRExprDenote_Mod m) | KRMakeModule_rules r => makeModule_rules (KRExprDenote_list_ModuleElt r) | KRConcat_Rule r => concat (KRExprDenote_list_list_Rule r) end with KRExprDenote_list_Mod(m: KRExpr_list_Mod) : list Mod := match m with | KRVar_list_Mod v => v | KRNil_list_Mod => nil | KRCons_list_Mod f r => cons (KRExprDenote_Mod f) (KRExprDenote_list_Mod r) | KRApp_list_Mod f r => app (KRExprDenote_list_Mod f) (KRExprDenote_list_Mod r) end with KRExprDenote_list_list_DefMethT (e:KRExpr_list_list_DefMethT) : list (list DefMethT) := match e with | KRVar_list_list_DefMethT v => v | KRNil_list_list_DefMethT => nil | KRCons_list_list_DefMethT f r => cons (KRExprDenote_list_DefMethT f) (KRExprDenote_list_list_DefMethT r) | KRApp_list_list_DefMethT f r => app (KRExprDenote_list_list_DefMethT f) (KRExprDenote_list_list_DefMethT r) | KRMap_list_Mod_list_list_DefMethT f l => map (KRExprDenote_Mod_list_DefMethT_Func f) (KRExprDenote_list_Mod l) | KRMap_list_RegFileBase_list_list_DefMethT f l => map (KRExprDenote_RegFileBase_list_DefMethT_Func f) (KRExprDenote_list_RegFileBase l) end with KRExprDenote_list_list_Rule (e:KRExpr_list_list_Rule) : list (list (Attribute (Action Void))) := match e with | KRVar_list_list_Rule v => v | KRNil_list_list_Rule => nil | KRCons_list_list_Rule f r => cons (KRExprDenote_list_Rule f) (KRExprDenote_list_list_Rule r) | KRApp_list_list_Rule f r => app (KRExprDenote_list_list_Rule f) (KRExprDenote_list_list_Rule r) | KRMap_list_Mod_list_list_Rule f l => map (KRExprDenote_Mod_list_Rule_Func f) (KRExprDenote_list_Mod l) end. (******************************************************************************************) Fixpoint KRExprDenote_CallWithSign(c: KRExpr_CallWithSign) := match c with | KRVar_CallWithSign v => v end. (******************************************************************************************) Fixpoint KRExprDenote_list_CallWithSign(c: KRExpr_list_CallWithSign) := match c with | KRVar_list_CallWithSign c => c | KRNil_list_CallWithSign => nil | KRCons_list_CallWithSign f r => cons (KRExprDenote_CallWithSign f) (KRExprDenote_list_CallWithSign r) | KRApp_list_CallWithSign f r => app (KRExprDenote_list_CallWithSign f) (KRExprDenote_list_CallWithSign r) | KRConcat_CallWithSign l => concat (KRExprDenote_list_list_CallWithSign l) end with KRExprDenote_list_list_CallWithSign(c: KRExpr_list_list_CallWithSign) := match c with | KRVar_list_list_CallWithSign c => c | KRNil_list_list_CallWithSign => nil | KRCons_list_list_CallWithSign f r => cons (KRExprDenote_list_CallWithSign f) (KRExprDenote_list_list_CallWithSign r) | KRApp_list_list_CallWithSign f r => app (KRExprDenote_list_list_CallWithSign f) (KRExprDenote_list_list_CallWithSign r) (*| KRMap_list_Mod_list_list_CallWithSign f l => (KRExprDenote_Mod_list_CallWithSign_Func f) (KRExprDenote_list_Mod l)*) end. (******************************************************************************************) Fixpoint KRExprDenote_list_list_ModuleElt (e:KRExpr_list_list_ModuleElt) : list (list ModuleElt) := match e with | KRVar_list_list_ModuleElt v => v | KRNil_list_list_ModuleElt => nil | KRCons_list_list_ModuleElt f r => cons (KRExprDenote_list_ModuleElt f) (KRExprDenote_list_list_ModuleElt r) | KRApp_list_list_ModuleElt f r => app (KRExprDenote_list_list_ModuleElt f) (KRExprDenote_list_list_ModuleElt r) end. (******************************************************************************************) Fixpoint KRExprDenote_list_BaseModule(e:KRExpr_list_BaseModule): list BaseModule := match e with | KRVar_list_BaseModule v => v | KRNil_list_BaseModule => nil | KRCons_list_BaseModule f r => cons (KRExprDenote_BaseModule f) (KRExprDenote_list_BaseModule r) | KRApp_list_BaseModule f r => app (KRExprDenote_list_BaseModule f) (KRExprDenote_list_BaseModule r) end. (******************************************************************************************) Fixpoint KRExprDenote_list_string(l: KRExpr_list_string) : list string := match l with | KRVar_list_string v => v | KRNil_list_string => nil | KRCons_list_string a b => cons (KRExprDenote_string a) (KRExprDenote_list_string b) | KRApp_list_string a b => app (KRExprDenote_list_string a) (KRExprDenote_list_string b) | KRgetCallsPerMod m => getCallsPerMod (KRExprDenote_Mod m) | KRConcat_string l => concat (KRExprDenote_list_list_string l) | KRmap_RegInitT_string f l => map (KRExprDenote_RegInitT_string_Func f) (KRExprDenote_list_RegInitT l) | KRmap_DefMethT_string f l => map (KRExprDenote_DefMethT_string_Func f) (KRExprDenote_list_DefMethT l) | KRmap_Rule_string f l => map (KRExprDenote_Rule_string_Func f) (KRExprDenote_list_Rule l) end with KRExprDenote_list_list_string(l : KRExpr_list_list_string) : list (list string) := match l with | KRVar_list_list_string v => v | KRNil_list_list_string => nil | KRCons_list_list_string a b => cons (KRExprDenote_list_string a) (KRExprDenote_list_list_string b) | KRApp_list_list_string a b => app (KRExprDenote_list_list_string a) (KRExprDenote_list_list_string b) end. Fixpoint KRExprDenote_Prop(p: KRExpr_Prop) := match p with | KRVar_Prop p => p | KRTrue_Prop => True | KRFalse_Prop => False | KRAnd_Prop a b => (KRExprDenote_Prop a) /\ (KRExprDenote_Prop b) | KROr_Prop a b => (KRExprDenote_Prop a) \/ (KRExprDenote_Prop b) | KRNot_Prop a => ~(KRExprDenote_Prop a) | KRIn_string_Prop a b => In (KRExprDenote_string a) (KRExprDenote_list_string b) | KREq_string_Prop a b => ((KRExprDenote_string a)=(KRExprDenote_string b)) | KRIn_RegInitT_Prop a b => In (KRExprDenote_RegInitT a) (KRExprDenote_list_RegInitT b) | KREq_RegInitT_Prop a b => ((KRExprDenote_RegInitT a)=(KRExprDenote_RegInitT b)) | KRIn_Rule_Prop a b => In (KRExprDenote_Rule a) (KRExprDenote_list_Rule b) | KREq_Rule_Prop a b => ((KRExprDenote_Rule a)=(KRExprDenote_Rule b)) | KRIn_DefMethT_Prop a b => In (KRExprDenote_DefMethT a) (KRExprDenote_list_DefMethT b) | KREq_DefMethT_Prop a b => ((KRExprDenote_DefMethT a)=(KRExprDenote_DefMethT b)) | KRDisjKey_RegInitT a b => DisjKey (KRExprDenote_list_RegInitT a) (KRExprDenote_list_RegInitT b) | KRDisjKey_DefMethT a b => DisjKey (KRExprDenote_list_DefMethT a) (KRExprDenote_list_DefMethT b) | KRDisjKey_Rule a b => DisjKey (KRExprDenote_list_Rule a) (KRExprDenote_list_Rule b) end. (******************************************************************************************) Inductive KRElem: Type := | KRElemRegInitT : KRElem | KRElemRegInitValT : KRElem | KRElemRule : KRElem | KRElemActionVoid : KRElem | KRElemMethodT : KRElem | KRElemDefMethT : KRElem | KRElemModuleElt: KRElem | KRElemMod : KRElem | KRElemBaseModule : KRElem | KRElemString : KRElem | KRElemProp : KRElem | KRElemRegFileBase : KRElem | KRElemCallWithSign : KRElem | KRElemMod_Mod_PairFunc : KRElem | KRElemRegFileBase_list_RegInitT_Func : KRElem | KRElemRegFileBase_Mod_Func : KRElem | KRElemMod_list_string_Func : KRElem | KRElemMod_list_DefMethT_Func : KRElem | KRElemRegFileBase_list_DefMethT_Func : KRElem | KRElemMod_list_Rule_Func : KRElem | KRElemMod_list_RegInitT_Func : KRElem | KRElemRegInitT_string_Func : KRElem | KRElemDefMethT_string_Func : KRElem | KRElemRule_string_Func : KRElem. Inductive KRType : Type := | KRTypeElem: KRElem -> KRType | KRTypeList: KRType -> KRType. Ltac isBoolConstant x := match x with | true => idtac | false => idtac end. Ltac isAsciiConstant x := match x with | Ascii ?A ?B ?C ?D ?E ?F ?G ?H => isBoolConstant A;isBoolConstant B;isBoolConstant C;isBoolConstant D; isBoolConstant E;isBoolConstant F;isBoolConstant G;isBoolConstant H end. Ltac isStringConstant s := match s with | EmptyString => idtac | String.String ?A ?R => isAsciiConstant A;isStringConstant R end. Ltac KRExprReify e t := match e with | nil => match t with | KRTypeList (KRTypeElem KRElemRegInitT) => constr:(@KRNil_list_RegInitT) | KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT)) => constr:(@KRNil_list_list_RegInitT) | KRTypeList (KRTypeElem KRElemRule) => constr:(@KRNil_list_Rule) | KRTypeList (KRTypeList (KRTypeElem KRElemRule)) => constr:(@KRNil_list_list_Rule) | KRTypeList (KRTypeElem KRElemDefMethT) => constr:(@KRNil_list_DefMethT) | KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT)) => constr:(@KRNil_list_list_DefMethT) | KRTypeList (KRTypeElem KRElemModuleElt) => constr:(@KRNil_list_ModuleElt) | KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt)) => constr:(@KRNil_list_list_ModuleElt) | KRTypeList (KRTypeElem KRElemMod) => constr:(@KRNil_list_Mod) | KRTypeList (KRTypeElem KRElemCallWithSign) => constr:(@KRNil_list_CallWithSign) | KRTypeList (KRTypeList (KRTypeElem KRElemCallWithSign)) => constr:(@KRNil_list_list_CallWithSign) | KRTypeList (KRTypeElem KRElemString) => constr:(@KRNil_list_string) | KRTypeList (KRTypeList (KRTypeElem KRElemString)) => constr:(@KRNil_list_list_string) | KRTypeList (KRTypeElem KRElemRegFileBase) => constr:(@KRNil_list_RegFileBase) end | cons ?F ?R => match t with | KRTypeList (KRTypeElem KRElemRegInitT) => let fr :=ltac:(KRExprReify F (KRTypeElem KRElemRegInitT)) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemRegInitT))) in constr:(KRCons_list_RegInitT fr re) | KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT)) => let fr :=ltac:(KRExprReify F (KRTypeList (KRTypeElem KRElemRegInitT))) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT)))) in constr:(KRCons_list_list_RegInitT fr re) | KRTypeList (KRTypeElem KRElemRule) => let fr :=ltac:(KRExprReify F (KRTypeElem KRElemRule)) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemRule))) in constr:(KRCons_list_Rule fr re) | KRTypeList (KRTypeList (KRTypeElem KRElemRule)) => let fr :=ltac:(KRExprReify F (KRTypeList (KRTypeElem KRElemRule))) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeList (KRTypeElem KRElemRule)))) in constr:(KRCons_list_list_Rule fr re) | KRTypeList (KRTypeElem KRElemDefMethT) => let fr :=ltac:(KRExprReify F (KRTypeElem KRElemDefMethT)) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemDefMethT))) in constr:(KRCons_list_DefMethT fr re) | KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT)) => let fr :=ltac:(KRExprReify F (KRTypeList (KRTypeElem KRElemDefMethT))) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT)))) in constr:(KRCons_list_list_DefMethT fr re) | KRTypeList (KRTypeElem KRElemModuleElt) => let fr :=ltac:(KRExprReify F (KRTypeElem KRElemModuleElt)) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemModuleElt))) in constr:(KRCons_list_ModuleElt fr re) | KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt)) => let fr :=ltac:(KRExprReify F (KRTypeList (KRTypeElem KRElemModuleElt))) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt)))) in constr:(KRCons_list_list_ModuleElt fr re) | KRTypeList (KRTypeElem KRElemMod) => let fr :=ltac:(KRExprReify F (KRTypeElem KRElemMod)) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemMod))) in constr:(KRCons_list_Mod fr re) | KRTypeList (KRTypeElem KRElemCallWithSign) => let fr :=ltac:(KRExprReify F (KRTypeElem KRElemCallWithSign)) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemCallWithSign))) in constr:(KRCons_list_CallWithSign fr re) | KRTypeList (KRTypeList (KRTypeElem KRElemCallWithSign)) => let fr :=ltac:(KRExprReify F (KRTypeList (KRTypeElem KRElemCallWithSign))) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeList (KRTypeElem KRElemCallWithSign)))) in constr:(KRCons_list_list_CallWithSign fr re) | KRTypeList (KRTypeElem KRElemString) => let fr :=ltac:(KRExprReify F (KRTypeElem KRElemString)) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemString))) in constr:(KRCons_list_string fr re) | KRTypeList (KRTypeList (KRTypeElem KRElemString)) => let fr :=ltac:(KRExprReify F (KRTypeList (KRTypeElem KRElemString))) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeList (KRTypeElem KRElemString)))) in constr:(KRCons_list_list_string fr re) | KRTypeList (KRTypeElem KRElemRegFileBase) => let fr :=ltac:(KRExprReify F (KRTypeElem KRElemRegFileBase)) in let re:=ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemRegFileBase))) in constr:(KRCons_list_RegFileBase fr re) end | (?A ++ ?B)%string => let a := ltac:(KRExprReify A (KRTypeElem KRElemString)) in let b := ltac:(KRExprReify B (KRTypeElem KRElemString)) in match t with | (KRTypeElem KRElemString) => constr:(KRstring_append a b) end | app ?F ?R => let x1 := ltac:(KRExprReify F t) in let x2 := ltac:(KRExprReify R t) in match t with | KRTypeList (KRTypeElem KRElemRegInitT) => constr:(KRApp_list_RegInitT x1 x2) | KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT)) => constr:(KRApp_list_list_RegInitT x1 x2) | KRTypeList (KRTypeElem KRElemRule) => constr:(KRApp_list_Rule x1 x2) | KRTypeList (KRTypeList (KRTypeElem KRElemRule)) => constr:(KRApp_list_list_Rule x1 x2) | KRTypeList (KRTypeElem KRElemDefMethT) => constr:(KRApp_list_DefMethT x1 x2) | KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT)) => constr:(KRApp_list_list_DefMethT x1 x2) | KRTypeList (KRTypeElem KRElemModuleElt) => constr:(KRApp_list_ModuleElt x1 x2) | KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt)) => constr:(KRApp_list_list_ModuleElt x1 x2) | KRTypeList (KRTypeElem KRElemMod) => constr:(KRApp_list_Mod x1 x2) | KRTypeList (KRTypeElem KRElemCallWithSign) => constr:(KRApp_list_CallWithSign x1 x2) | KRTypeList (KRTypeElem KRElemString) => constr:(KRApp_list_string x1 x2) | KRTypeList (KRTypeList (KRTypeElem KRElemString)) => constr:(KRApp_list_list_string x1 x2) | KRTypeList (KRTypeElem KRElemRegFileBase) => constr:(KRApp_list_RegFileBase x1 x2) | KRTypeElem KRElemString => constr:(KRstring_append x1 x2) end | concat ?F => let x := ltac:(KRExprReify F (KRTypeList t)) in match t with | KRTypeList (KRTypeElem KRElemRegInitT) => constr:(KRConcat_RegInitT x) | KRTypeList (KRTypeElem KRElemRule) => constr:(KRConcat_Rule x) | KRTypeList (KRTypeElem KRElemDefMethT) => constr:(KRConcat_DefMethT x) | KRTypeList (KRTypeElem KRElemString) => constr:(KRConcat_string x) end | map ?F ?L => match F with | getAllRegisters => let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemMod))) in constr:(KRMap_list_Mod_list_list_RegInitT KRgetAllRegistersFunc l) | getRegFileRegisters => let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemRegFileBase))) in constr:(KRMap_list_RegFileBase_list_list_RegInitT KRgetRegFileRegistersFunc l) | getAllRules => let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemMod))) in constr:(KRMap_list_Mod_list_list_Rule KRgetAllRulesFunc l) | getAllMethods => let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemMod))) in constr:(KRMap_list_Mod_list_list_DefMethT KRgetAllMethodsFunc l) | getRegFileMethods => let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemRegFileBase))) in constr:(KRMap_list_Mod_list_list_DefMethT KRgetRegFileMethodsFunc l) | fst => let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemRegInitT))) in constr:(KRmap_RegInitT_string KRfst_RegInitT_string l) | fst => let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemDefMethT))) in constr:(KRmap_DefMethT_string KRfst_DefMethT_string l) | fst => let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemRule))) in constr:(KRmap_Rule_string KRfst_Rule_string l) end | MERegister ?E => let x := ltac:(KRExprReify E (KRTypeElem KRElemRegInitT)) in constr:(KRMERegister x) | Registers ?E => let x := ltac:(KRExprReify E (KRTypeList (KRTypeElem KRElemRegInitT))) in constr:(KRRegisters x) | getRegisters ?E => let x := ltac:(KRExprReify E (KRTypeList (KRTypeElem KRElemBaseModule))) in constr:(KRgetRegisters x) | getAllRegisters ?E => match t with (KRTypeList (KRTypeElem KRElemRegInitT)) => let x := ltac:(KRExprReify E (KRTypeElem KRElemMod)) in constr:(KRgetAllRegisters x) end | getAllRegisters ?E => match t with (KRTypeList (KRTypeElem KRElemRegInitT)) => let x := ltac:(KRExprReify E (KRTypeElem KRElemMod)) in constr:(KRgetAllRegisters (@KRBase x)) end | getAllRegisters ?E => match t with (KRTypeList (KRTypeElem KRElemRegInitT)) => let x := ltac:(KRExprReify E (KRTypeElem KRElemBaseModule)) in constr:(KRgetAllRegisters x) | _ => fail 1 end | getAllRegisters ?E => match t with (KRTypeList (KRTypeElem KRElemRegInitT)) => let x := ltac:(KRExprReify E (KRTypeElem KRElemBaseModule)) in constr:(KRgetAllRegisters (@KRBase x)) | _ => fail 1 end | MERule ?E => let x := ltac:(KRExprReify E (KRTypeElem KRElemRule)) in constr:(KRMERule x) | Rules ?E => match t with (KRTypeList (KRTypeElem KRElemRule)) => let x := ltac:(KRExprReify E (KRTypeList (KRTypeElem KRElemRule))) in constr:(KRRules x) end | getRules ?E => match t with (KRTypeList (KRTypeElem KRElemRule)) => let x := ltac:(KRExprReify E (KRTypeElem KRElemBaseModule)) in constr:(KRgetRules x) | _ => fail 1 end | getAllRules ?E => match t with (KRTypeList (KRTypeElem KRElemRule)) => let x := ltac:(KRExprReify E (KRTypeElem KRElemMod)) in constr:(KRgetAllRules x) | _ => fail 1 end | MEMeth ?E => match t with (KRTypeElem KRElemModuleElt) => let x := ltac:(KRExprReify E (KRTypeElem KRElemDefMethT)) in constr:(KRMEMeth x) end | Methods ?E => match t with (KRTypeList (KRTypeElem KRElemModuleElt)) => let x := ltac:(KRExprReify E (KRTypeList (KRTypeElem KRElemDefMethT))) in constr:(KRMethods x) end | getMethods ?E => match t with (KRTypeList (KRTypeElem KRElemDefMethT)) => let x := ltac:(KRExprReify E (KRTypeElem KRElemBaseModule)) in constr:(KRgetMethods x) | _ => fail 1 end | getAllMethods ?E => match t with (KRTypeList (KRTypeElem KRElemDefMethT)) => let x := ltac:(KRExprReify E (KRTypeElem KRElemMod)) in constr:(KRgetAllMethods x) | _ => fail 1 end | makeModule_regs ?X => let x := ltac:(KRExprReify X (KRTypeList (KRTypeElem KRElemModuleElt))) in constr:(KRMakeModule_regs x) | makeModule_rules ?E => let x := ltac:(KRExprReify E (KRTypeList (KRTypeElem KRElemModuleElt))) in constr:(KRMakeModule_rules x) | makeModule_meths ?E => let x := ltac:(KRExprReify E (KRTypeList (KRTypeElem KRElemModuleElt))) in constr:(KRMakeModule_meths x) | makeModule ?E => let x := ltac:(KRExprReify E (KRTypeList (KRTypeElem KRElemModuleElt))) in constr:(KRMakeModule x) | BaseRegFile ?E => let x := ltac:(KRExprReify E (KRTypeList (KRTypeElem KRElemRegFileBase))) in constr:(KRBaseRegFile x) | BaseMod ?R ?U ?M => let regs := ltac:(KRExprReify R (KRTypeList (KRTypeElem KRElemRegInitT))) in let rules := ltac:(KRExprReify U (KRTypeList (KRTypeElem KRElemRule))) in let meths := ltac:(KRExprReify M (KRTypeList (KRTypeElem KRElemDefMethT))) in constr:(KRBaseMod regs rules meths) | Base ?B => let m := ltac:(KRExprReify B (KRTypeElem KRElemBaseModule)) in constr:(KRBase m) | ConcatMod ?A ?B => match t with | (KRTypeElem KRElemMod) => let a := ltac:(KRExprReify A (KRTypeElem KRElemMod)) in let b := ltac:(KRExprReify B (KRTypeElem KRElemMod)) in constr:(KRConcatMod a b) | _ => fail 1 end | True => constr:(KRTrue_Prop) | False => constr:(KRFalse_Prop) | ?A /\ ?B => let a := ltac:(KRExprReify A (KRTypeElem KRElemProp)) in let b := ltac:(KRExprReify B (KRTypeElem KRElemProp)) in constr:(KRAnd_Prop a b) | ?A \/ ?B => let a := ltac:(KRExprReify A (KRTypeElem KRElemProp)) in let b := ltac:(KRExprReify B (KRTypeElem KRElemProp)) in constr:(KROr_Prop a b) | ~ ?A => let a := ltac:(KRExprReify A (KRTypeElem KRElemProp)) in constr:(KRNot_Prop a) | ( ?A , ?B ) => match t with | (KRTypeElem KRElemRegInitT) => let a := ltac:(KRExprReify A (KRTypeElem KRElemString)) in let b := ltac:(KRExprReify B (KRTypeElem KRElemRegInitValT)) in constr:(KRPair_RegInitT A B) | (KRTypeElem KRElemDefMethT) => let a := ltac:(KRExprReify A (KRTypeElem KRElemString)) in let b := ltac:(KRExprReify B (KRTypeElem KRElemMethodT)) in constr:(KRPair_RegInitT A B) end | In ?A ?B => let a := ltac:(KRExprReify A (KRTypeElem KRElemString)) in let b := ltac:(KRExprReify B (KRTypeList (KRTypeElem KRElemString))) in constr:(KRIn_string_Prop a b) | In ?A ?B => let a := ltac:(KRExprReify A (KRTypeElem KRElemRegInitT)) in let b := ltac:(KRExprReify B (KRTypeList (KRTypeElem KRElemRegInitT))) in constr:(KRIn_RegInitT_Prop a b) | In ?A ?B => let a := ltac:(KRExprReify A (KRTypeElem KRElemRule)) in let b := ltac:(KRExprReify B (KRTypeList (KRTypeElem KRElemRule))) in constr:(KRIn_Rule_Prop a b) | In ?A ?B => let a := ltac:(KRExprReify A (KRTypeElem KRElemDefMethT)) in let b := ltac:(KRExprReify B (KRTypeList (KRTypeElem KRElemDefMethT))) in constr:(KRIn_DefMethT_Prop a b) | DisjKey ?A ?B => let a := ltac:(KRExprReify A (KRTypeList (KRTypeElem KRElemRegInitT))) in let b := ltac:(KRExprReify B (KRTypeList (KRTypeElem KRElemRegInitT))) in constr:(KRDisjKey_RegInitT a b) | DisjKey ?A ?B => let a := ltac:(KRExprReify A (KRTypeList (KRTypeElem KRElemDefMethT))) in let b := ltac:(KRExprReify B (KRTypeList (KRTypeElem KRElemDefMethT))) in constr:(KRDisjKey_DefMethT a b) | DisjKey ?A ?B => let a := ltac:(KRExprReify A (KRTypeList (KRTypeElem KRElemRule))) in let b := ltac:(KRExprReify B (KRTypeList (KRTypeElem KRElemRule))) in constr:(KRDisjKey_Rule a b) | fst ?A => match t with (KRTypeElem KRElemString) => let a := ltac:(KRExprReify A (KRTypeElem KRElemRegInitT)) in constr:(KRfst_RegInitT_string a) end | fst ?A => match t with (KRTypeElem KRElemString) => let a := ltac:(KRExprReify A (KRTypeElem KRElemDefMethT)) in constr:(KRfst_RegInitT_string a) end | ?A = ?B => match t with | (KRTypeElem KRElemProp) => let a := ltac:(KRExprReify A (KRTypeElem KRElemString)) in let b := ltac:(KRExprReify B (KRTypeElem KRElemString)) in constr:(KREq_string_Prop a b) end | fold_right ConcatMod ?M ?L => match t with | (KRTypeElem KRElemMod) => let m := ltac:(KRExprReify M (KRTypeElem KRElemMod)) in let l := ltac:(KRExprReify L (KRTypeList (KRTypeElem KRElemMod))) in constr:(KRFold_right_Mod KRConcatMod_Func m l) | _ => fail 1 end | ?X => match t with | (KRTypeElem KRElemString) => let q := isStringConstant X in constr:(KRConst_string X) | _ => fail 1 end | ?X => match t with | (KRTypeElem KRElemRegInitT) => constr:(KRVar_RegInitT X) | (KRTypeElem KRElemRegInitValT) => constr:(KRVar_RegInitValT X) | (KRTypeElem KRElemRule) => constr:(KRVar_Rule X) | (KRTypeElem KRElemActionVoid) => constr:(KRVar_ActionVoid X) | (KRTypeElem KRElemDefMethT) => constr:(KRVar_DefMethT X) | (KRTypeElem KRElemMethodT) => constr:(KRVar_MethodT X) | (KRTypeElem KRElemModuleElt) => constr:(KRVar_ModuleElt X) | (KRTypeList (KRTypeElem KRElemRegInitT)) => constr:(KRVar_list_RegInitT X) | (KRTypeList (KRTypeList (KRTypeElem KRElemRegInitT))) => constr:(KRVar_list_list_RegInitT X) | (KRTypeList (KRTypeElem KRElemRule)) => constr:(KRVar_list_Rule X) | (KRTypeList (KRTypeList (KRTypeElem KRElemRule))) => constr:(KRVar_list_list_Rule X) | (KRTypeList (KRTypeElem KRElemDefMethT)) => constr:(KRVar_list_DefMethT X) | (KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT))) => constr:(KRVar_list_list_DefMethT X) | (KRTypeList (KRTypeElem KRElemModuleElt)) => constr:(KRVar_list_ModuleElt X) | (KRTypeList (KRTypeList (KRTypeElem KRElemModuleElt))) => constr:(KRVar_list_list_ModuleElt X) | (KRTypeElem KRElemBaseModule) => constr:(KRVar_BaseModule X) | (KRTypeList (KRTypeElem KRElemBaseModule)) => constr:(KRVar_list_BaseModule X) | (KRTypeElem KRElemMod) => constr:(KRVar_Mod X) | (KRTypeList (KRTypeElem KRElemMod)) => constr:(KRVar_list_Mod X) | (KRTypeElem KRElemString) => constr:(KRVar_string X) | (KRTypeList (KRTypeElem KRElemString)) => constr:(KRVar_list_string X) | (KRTypeList (KRTypeList (KRTypeElem KRElemString))) => constr:(KRVar_list_list_string X) | (KRTypeElem KRElemProp) => constr:(KRVar_Prop X) | (KRTypeElem KRElemRegFileBase) => constr:(KRVar_RegFileBase X) | (KRTypeList (KRTypeElem KRElemRegFileBase)) => constr:(KRVar_list_RegFileBase X) | (KRTypeElem KRElemCallWithSign) => constr:(KRVar_CallWithSign X) | (KRTypeList (KRTypeElem KRElemCallWithSign)) => constr:(KRVar_list_CallWithSign X) | (KRTypeList (KRTypeList (KRTypeElem KRElemCallWithSign))) => constr:(KRVar_list_list_CallWithSign X) | (KRTypeElem KRElemMod_Mod_PairFunc) => constr:(KRVar_Mod_Mod_PairFunc) | (KRTypeElem KRElemRegFileBase_list_RegInitT_Func) => constr:(KRVar_RegFileBase_list_RegInitT_Func) | (KRTypeElem KRElemRegFileBase_Mod_Func) => constr:(KRVar_RegFileBase_Mod_Func) | (KRTypeElem KRElemMod_list_string_Func) => constr:(KRVar_Mod_list_string_Func) | (KRTypeElem KRElemMod_list_DefMethT_Func) => constr:(KRVar_Mod_list_DefMethT_Func) | (KRTypeElem KRElemRegFileBase_list_DefMethT_Func) => constr:(KRVar_RegFileBase_list_DefMethT_Func) | (KRTypeElem KRElemMod_list_Rule_Func) => constr:(KRVar_Mod_list_Rule_Func) | (KRTypeElem KRElemMod_list_RegInitT_Func) => constr:(KRVar_Mod_list_RegInitT_Func) | (KRTypeElem KRElemRegInitT_string_Func) => constr:(KRVar_RegInitT_string_Func) end end. Set Printing Implicit. (*Goal forall meth mdev, In meth (concat (map getAllMethods (map (fun m : RegFileBase => Base (BaseRegFile m)) mdev))). intros. match goal with | |- ?X => let r := (ltac:(KRExprReify X (KRTypeElem KRElemProp))) in idtac r end. match goal with | |- In _ (concat (map getAllMethods ?X)) => let r := (ltac:(KRExprReify (map getAllMethods X) (KRTypeList (KRTypeList (KRTypeElem KRElemDefMethT))))) in idtac r end. Abort.*) Axiom cheat: forall x, x. Definition KRSimplifyTop_RegInitT (e : KRExpr_RegInitT) := e. Definition KRSimplifyTop_RegInitValT (e : KRExpr_RegInitValT) := e. Definition KRSimplifyTop_Rule (e : KRExpr_Rule) := e. Definition KRSimplifyTop_ActionVoid (e : KRExpr_ActionVoid) := e. Definition KRSimplifyTop_MethodT (e : KRExpr_MethodT) := e. Definition KRSimplifyTop_DefMethT (e : KRExpr_DefMethT) := e. Definition KRSimplifyTop_ModuleElt (e : KRExpr_ModuleElt) := e. Definition KRSimplifyTop_list_RegInitT (e : KRExpr_list_RegInitT) : KRExpr_list_RegInitT := match e with | KRApp_list_RegInitT f c => match f with | KRCons_list_RegInitT ff rr => KRCons_list_RegInitT ff (KRApp_list_RegInitT rr c) | KRNil_list_RegInitT => c | x => match c with | KRNil_list_RegInitT => f | y => KRApp_list_RegInitT f c end end | KRgetAllRegisters (KRBase (KRMakeModule l)) => match l with | KRApp_list_ModuleElt a b => KRApp_list_RegInitT (KRgetAllRegisters (KRBase (KRMakeModule a))) (KRgetAllRegisters (KRBase (KRMakeModule b))) | KRCons_list_ModuleElt (KRMERegister f) r => KRCons_list_RegInitT f (KRgetAllRegisters (KRBase (KRMakeModule r))) | KRCons_list_ModuleElt (KRMERule f) r => KRgetAllRegisters (KRBase (KRMakeModule r)) | KRCons_list_ModuleElt (KRMEMeth f) r => KRgetAllRegisters (KRBase (KRMakeModule r)) | KRNil_list_ModuleElt => KRNil_list_RegInitT | _ => e end | KRgetAllRegisters (KRFold_right_Mod KRConcatMod_Func a b) => KRApp_list_RegInitT (KRConcat_RegInitT (KRMap_list_Mod_list_list_RegInitT KRgetAllRegistersFunc b)) (KRgetAllRegisters a) | KRgetAllRegisters (KRConcatMod a b) => KRApp_list_RegInitT (KRgetAllRegisters a) (KRgetAllRegisters b) | KRMakeModule_regs x => match x with | KRApp_list_ModuleElt a b => KRApp_list_RegInitT (KRMakeModule_regs a) (KRMakeModule_regs b) | KRCons_list_ModuleElt aa b => match aa with | KRMERule a => KRMakeModule_regs b | KRMEMeth a => KRMakeModule_regs b | KRMERegister a => KRCons_list_RegInitT a (KRMakeModule_regs b) | _ => KRMakeModule_regs x end | KRRegisters r => r | KRNil_list_ModuleElt => KRNil_list_RegInitT | _ => KRMakeModule_regs x end | e => e end. Definition KRSimplifyTop_list_list_RegInitT (e : KRExpr_list_list_RegInitT) : KRExpr_list_list_RegInitT := match e with | KRApp_list_list_RegInitT f c => match f with | KRCons_list_list_RegInitT ff rr => KRCons_list_list_RegInitT ff (KRApp_list_list_RegInitT rr c) | KRNil_list_list_RegInitT => c | x => match c with | KRNil_list_list_RegInitT => f | y => KRApp_list_list_RegInitT f c end end | e => e end. Definition KRSimplifyTop_list_Rule (e : KRExpr_list_Rule) : KRExpr_list_Rule := match e with | KRApp_list_Rule f c => match f with | KRCons_list_Rule ff rr => KRCons_list_Rule ff (KRApp_list_Rule rr c) | KRNil_list_Rule => c | x => match c with | KRNil_list_Rule => f | y => KRApp_list_Rule f c end end | KRgetAllRules (KRConcatMod a b) => KRApp_list_Rule (KRgetAllRules a) (KRgetAllRules b) | KRgetAllRules (KRFold_right_Mod KRConcatMod_Func a b) => KRApp_list_Rule (KRConcat_Rule (KRMap_list_Mod_list_list_Rule KRgetAllRulesFunc b)) (KRgetAllRules a) | KRMakeModule_rules x => match x with | KRApp_list_ModuleElt a b => KRApp_list_Rule (KRMakeModule_rules a) (KRMakeModule_rules b) | KRCons_list_ModuleElt aa b => match aa with | KRMERegister a => KRMakeModule_rules b | KRMEMeth a => KRMakeModule_rules b | KRMERule a => KRCons_list_Rule a (KRMakeModule_rules b) | _ => KRMakeModule_rules x end | KRRegisters r => KRNil_list_Rule | KRNil_list_ModuleElt => KRNil_list_Rule | _ => KRMakeModule_rules x end | e => e end. Definition KRSimplifyTop_list_list_Rule (e : KRExpr_list_list_Rule) : KRExpr_list_list_Rule := match e with | KRApp_list_list_Rule f c => match f with | KRCons_list_list_Rule ff rr => KRCons_list_list_Rule ff (KRApp_list_list_Rule rr c) | KRNil_list_list_Rule => c | x => match c with | KRNil_list_list_Rule => f | y => KRApp_list_list_Rule f c end end | e => e end. Definition KRSimplifyTop_list_DefMethT (e : KRExpr_list_DefMethT) : KRExpr_list_DefMethT := match e with | KRApp_list_DefMethT f c => match f with | KRCons_list_DefMethT ff rr => KRCons_list_DefMethT ff (KRApp_list_DefMethT rr c) | KRNil_list_DefMethT => c | x => match c with | KRNil_list_DefMethT => f | y => KRApp_list_DefMethT f c end end | KRgetAllMethods (KRBase (KRMakeModule l)) => match l with | KRApp_list_ModuleElt a b => KRApp_list_DefMethT (KRgetAllMethods (KRBase (KRMakeModule a))) (KRgetAllMethods (KRBase (KRMakeModule b))) | KRCons_list_ModuleElt (KRMERegister f) r => KRgetAllMethods (KRBase (KRMakeModule r)) | KRCons_list_ModuleElt (KRMERule f) r => KRgetAllMethods (KRBase (KRMakeModule r)) | KRCons_list_ModuleElt (KRMEMeth f) r => (KRCons_list_DefMethT f (KRgetAllMethods (KRBase (KRMakeModule r)))) | KRNil_list_ModuleElt => KRNil_list_DefMethT | KRRegisters _ => KRNil_list_DefMethT | _ => e end | KRgetAllMethods (KRConcatMod a b) => KRApp_list_DefMethT (KRgetAllMethods a) (KRgetAllMethods b) | KRgetAllMethods (KRFold_right_Mod KRConcatMod_Func a b) => KRApp_list_DefMethT (KRConcat_DefMethT (KRMap_list_Mod_list_list_DefMethT KRgetAllMethodsFunc b)) (KRgetAllMethods a) | KRMakeModule_meths x => match x with | KRApp_list_ModuleElt a b => KRApp_list_DefMethT (KRMakeModule_meths a) (KRMakeModule_meths b) | KRCons_list_ModuleElt aa b => match aa with | KRMERegister a => KRMakeModule_meths b | KRMERule a => KRMakeModule_meths b | KRMEMeth a => KRCons_list_DefMethT a (KRMakeModule_meths b) | _ => KRMakeModule_meths x end | KRNil_list_ModuleElt => KRNil_list_DefMethT | KRRegisters r => KRNil_list_DefMethT | _ => KRMakeModule_meths x end | e => e end. Definition KRSimplifyTop_list_list_DefMethT (e : KRExpr_list_list_DefMethT) : KRExpr_list_list_DefMethT := match e with | KRApp_list_list_DefMethT f c => match f with | KRCons_list_list_DefMethT ff rr => KRCons_list_list_DefMethT ff (KRApp_list_list_DefMethT rr c) | KRNil_list_list_DefMethT => c | x => match c with | KRNil_list_list_DefMethT => f | y => KRApp_list_list_DefMethT f c end end | e => e end. Definition KRSimplifyTop_list_ModuleElt (e : KRExpr_list_ModuleElt) : KRExpr_list_ModuleElt := match e with | KRApp_list_ModuleElt f c => match f with | KRCons_list_ModuleElt ff rr => KRCons_list_ModuleElt ff (KRApp_list_ModuleElt rr c) | KRNil_list_ModuleElt => c | x => match c with | KRNil_list_ModuleElt => f | y => KRApp_list_ModuleElt f c end end | KRRegisters (KRCons_list_RegInitT f r) => (KRCons_list_ModuleElt (KRMERegister f) (KRRegisters r)) | KRRegisters (KRApp_list_RegInitT f r) => (KRApp_list_ModuleElt (KRRegisters f) (KRRegisters r)) | KRRegisters (KRNil_list_RegInitT) => KRNil_list_ModuleElt | e => e end. Definition KRSimplifyTop_list_list_ModuleElt (e : KRExpr_list_list_ModuleElt) : KRExpr_list_list_ModuleElt := match e with | KRApp_list_list_ModuleElt f c => match f with | KRCons_list_list_ModuleElt ff rr => KRCons_list_list_ModuleElt ff (KRApp_list_list_ModuleElt rr c) | KRNil_list_list_ModuleElt => c | x => match c with | KRNil_list_list_ModuleElt => f | y => KRApp_list_list_ModuleElt f c end end | e => e end. Fixpoint sappend (s1 s2 : string) : string := match s1 with | EmptyString => s2 | String c s1' => String c (sappend s1' s2) end. Fixpoint srev (s : string) : string := match s with | EmptyString => EmptyString | (String f r) => sappend (srev r) (String f EmptyString) end. Theorem sappendEmpty: forall s, sappend s ""=s. Proof. intros. induction s. - reflexivity. - simpl. rewrite IHs. reflexivity. Qed. Theorem sappendNotEmpty: forall s c s', sappend s (String c s')<>"". Proof. intros. induction s. - simpl. intro X. inversion X. - simpl. intro X. inversion X. Qed. Theorem sappendNotEmpty': forall s c s', sappend s (String c s') =? ""=false. Proof. intros. induction s. - simpl. reflexivity. - simpl. reflexivity. Qed. Theorem sappend_String_assoc: forall s c s', sappend s (String c s')=sappend (sappend s (String c "")) s'. Proof. intro s. induction s. - simpl. reflexivity. - intros. simpl. f_equal. rewrite IHs. reflexivity. Qed. (*Theorem sappend_eq: forall a s b, ((sappend a s) =? (sappend b s))= (a =? b). Proof. intro a. induction a. - intros. destruct b. + simpl. rewrite String.eqb_refl. reflexivity. + intros. rewrite ?sappendEmpty. reflexivity. - intros. destruct b. + simpl. rewrite sappend_String_assoc. rewrite IHs. rewrite String.eqb_refl. reflexivity. + -*) Theorem sappend_empty_eq: forall a s, (sappend s a =? a) = (s =? ""). Proof. intro a. induction a. - simpl. intros. rewrite sappendEmpty. reflexivity. - intros. rewrite sappend_String_assoc. destruct s. + simpl. rewrite ?String.eqb_refl. rewrite Ascii.eqb_refl. reflexivity. + simpl. remember (a1 =? a)%char. destruct b. * rewrite IHa. simpl. destruct s. -- reflexivity. -- reflexivity. * reflexivity. Qed. Theorem sappend_empty_equal: forall a s, (sappend s a=a) <-> (s=""). Proof. intros. split. - intros. rewrite <- String.eqb_eq in H. rewrite sappend_empty_eq in H. rewrite String.eqb_eq in H. apply H. - intros. subst. reflexivity. Qed. Theorem sappend_assoc: forall a b c, sappend a (sappend b c)=sappend (sappend a b) c. Proof. intro a. induction a. - simpl. reflexivity. - intros. simpl. rewrite IHa. reflexivity. Qed. Theorem sappend_eq_reduce: forall a s b, (sappend a s =? sappend b s)=(a =? b). Proof. intro a. induction a. - intros. simpl. destruct b. + simpl. rewrite String.eqb_refl. reflexivity. + rewrite String.eqb_sym. rewrite sappend_empty_eq. simpl. reflexivity. - intros. destruct b. + simpl. destruct s. * reflexivity. * remember (a =? a1)%char. destruct b. -- rewrite sappend_String_assoc. rewrite sappend_empty_eq. destruct a0. ** reflexivity. ** reflexivity. -- reflexivity. + simpl. remember (a =? a1)%char. destruct b0. * rewrite IHa. reflexivity. * reflexivity. Qed. Theorem sappend_tail_diff: forall s1 a b s2, ((a =? b)%char = false) -> ((sappend s1 (String a "") =? sappend s2 (String b ""))=false). Proof. intro s1. induction s1. - intros. simpl. destruct s2. + simpl. rewrite H. reflexivity. + simpl. destruct (a =? a0)%char. * destruct s2. -- reflexivity. -- reflexivity. * reflexivity. - intros. destruct s2. + simpl. remember (a =? b)%char. destruct b0. * destruct s1. ++ reflexivity. ++ reflexivity. * reflexivity. + simpl. remember (a =? a1)%char. destruct b0. * apply IHs1. apply H. * reflexivity. Qed. Theorem srev_eqb_gen: forall s1 s2 a, String.eqb (sappend s1 a) (sappend s2 a)=String.eqb (sappend (srev s1) a) (sappend (srev s2) a). Proof. intros s1. induction s1. - intros. simpl. rewrite String.eqb_sym. rewrite sappend_empty_eq. assert (forall a b c, (a =? sappend b c)=(sappend b c =? a)). intros. rewrite String.eqb_sym. reflexivity. rewrite H. rewrite sappend_empty_eq. destruct s2. + reflexivity. + simpl. destruct (srev s2). * simpl. reflexivity. * simpl. reflexivity. - intros. destruct s2. + simpl. destruct a0. * simpl. rewrite sappendEmpty. rewrite sappendNotEmpty'. reflexivity. * remember (a=?a0)%char. destruct b. ++ rewrite sappend_empty_eq. rewrite sappend_String_assoc. rewrite sappend_empty_eq. rewrite ?sappendNotEmpty'. reflexivity. ++ rewrite sappend_empty_eq. rewrite sappendNotEmpty'. reflexivity. + simpl. remember (a=?a1)%char. destruct b. * rewrite <- sappend_assoc. rewrite <- sappend_assoc. remember (a=?a1)%char. destruct b. ++ symmetry in Heqb0. rewrite Ascii.eqb_eq in Heqb0. subst. rewrite <- IHs1. rewrite ?sappend_eq_reduce. reflexivity. ++ inversion Heqb. * rewrite sappend_eq_reduce. symmetry. apply sappend_tail_diff. rewrite <- Heqb. reflexivity. Qed. Theorem srev_eqb : forall s1 s2, String.eqb s1 s2=String.eqb (srev s1) (srev s2). Proof. intros. erewrite <- sappend_eq_reduce. instantiate (1 := ""). assert ((srev s1 =? srev s2) = (sappend (srev s1) "" =? sappend (srev s2) "")). rewrite sappend_eq_reduce. reflexivity. rewrite H. apply srev_eqb_gen. Qed. Fixpoint sdisjPrefix (s1: string) (s2: string) := match s1,s2 with | (String c1 s1'),(String c2 s2') => if (c1 =? c2)%char then sdisjPrefix s1' s2' else true | _,_ => false end. (*Goal sdisjPrefix (srev "_mode") (srev "_int_data_reg")=true. simpl.*) Theorem srev_sappend: forall a b, srev (sappend a b)=sappend (srev b) (srev a). Proof. intro a. induction a. - simpl. intros. rewrite sappendEmpty. reflexivity. - intros. simpl. rewrite IHa. rewrite sappend_assoc. reflexivity. Qed. Theorem String_same_false: forall b a, String a b=b -> False. Proof. intro b. induction b. - simpl. intros. inversion H. - intros. remember (Ascii.eqb a a0) in H. destruct b0. + symmetry in Heqb0. rewrite Ascii.eqb_eq in Heqb0. subst. inversion H; subst; clear H. apply IHb in H1. inversion H1. + symmetry in Heqb0. apply Ascii.eqb_neq in Heqb0. inversion H;subst;clear H. apply Heqb0. reflexivity. Qed. Theorem sappend_String_equal: forall a b c, sappend a (String c "")=sappend b (String c "") -> a = b. Proof. intro a. induction a. - intros. destruct b. + reflexivity. + simpl in H. inversion H; subst; clear H. destruct b. * inversion H2. * inversion H2. - intros. destruct b. + simpl in H. inversion H; subst; clear H. destruct a0. * inversion H2. * inversion H2. + simpl in H. inversion H; subst; clear H. f_equal. eapply IHa. apply H2. Qed. Theorem sappend_equal_tail: forall c b a, a=b <-> sappend a c=sappend b c. Proof. split. - intros. subst. reflexivity. - generalize a. generalize b. induction c. + simpl. intros. rewrite sappendEmpty in H. rewrite sappendEmpty in H. subst. reflexivity. + simpl. intros. rewrite sappend_String_assoc in H. assert (sappend b0 (String a0 c)=(sappend (sappend b0 (String a0 "")) c)). rewrite <- sappend_String_assoc. reflexivity. rewrite H0 in H. apply IHc in H. apply sappend_String_equal in H. apply H. Qed. Theorem sappend_different_last: forall a b c d, sappend a (String b "")=sappend c (String d "") -> b<>d -> False. Proof. intro a. induction a. - intros. simpl in H. destruct c. + simpl in H. inversion H; subst; clear H. apply H0. reflexivity. + simpl in H. inversion H; subst; clear H. destruct c. * inversion H3. * inversion H3. - intros. simpl in H. destruct c. + simpl in H. inversion H. destruct a0. * inversion H3. * inversion H3. + simpl in H. inversion H; subst; clear H. eapply IHa. apply H3. apply H0. Qed. Theorem equal_srev_sappend: forall a b c, a=b <-> sappend (srev a) c=sappend (srev b) c. Proof. intro a. induction a. - simpl. intros. destruct b. + simpl. split. * reflexivity. * reflexivity. + simpl. split. * intros. inversion H. * intros. remember (srev b). destruct s. -- simpl in H. symmetry in H. apply String_same_false in H. inversion H. -- symmetry in H. rewrite sappend_empty_equal in H. inversion H. - split. + intros. subst. reflexivity. + intros. destruct b. * simpl in H. rewrite sappend_empty_equal in H. remember (srev a0). destruct s. -- inversion H. -- inversion H. * simpl in H. rewrite <- sappend_assoc in H. rewrite <- sappend_assoc in H. remember (Ascii.eqb a a1). destruct b0. -- symmetry in Heqb0. apply Ascii.eqb_eq in Heqb0. subst. apply <- IHa in H. subst. reflexivity. -- symmetry in Heqb0. apply Ascii.eqb_neq in Heqb0. rewrite sappend_assoc in H. rewrite sappend_assoc in H. apply sappend_equal_tail in H. apply sappend_different_last in H. ++ inversion H. ++ apply Heqb0. Qed. Theorem equal_srev: forall a b, a=b <-> srev a=srev b. Proof. intros. split. - intros. subst. reflexivity. - intros. assert (sappend (srev a) ""=sappend (srev b) ""). + rewrite H. reflexivity. + apply <- equal_srev_sappend in H0. apply H0. Qed. Theorem sdisjPrefix_sappend_not_equal: forall s1 s2 p1 p2, sdisjPrefix s1 s2=true -> (sappend s1 p1=sappend s2 p2)%string -> False. Proof. intro s1. induction s1. - intros. inversion H. - destruct s2. + intros. inversion H. + intros. simpl in H. remember (Ascii.eqb a a0). destruct b. * symmetry in Heqb. rewrite Ascii.eqb_eq in Heqb. subst. simpl. simpl in H0. inversion H0; subst; clear H0. eapply IHs1. ++ apply H. ++ apply H2. * inversion H0; subst; clear H0. symmetry in Heqb. rewrite Ascii.eqb_neq in Heqb. apply Heqb. reflexivity. Qed. Theorem sdisjPrefix_sappend_false: forall p1 p2 s1 s2, sdisjPrefix (srev s1) (srev s2)=true -> sappend p1 s1=sappend p2 s2 -> False. Proof. intros. eapply sdisjPrefix_sappend_not_equal in H. - inversion H. - instantiate (1 := (srev p2)). instantiate (1 := (srev p1)). rewrite <- srev_sappend. rewrite <- srev_sappend. rewrite H0. reflexivity. Qed. Theorem sappend_append: forall s1 s2, sappend s1 s2=String.append s1 s2. Proof. intros. induction s1. - reflexivity. - simpl. rewrite IHs1. reflexivity. Qed. Hint Rewrite sappend_append : kami_rewrite_db. (*Theorem sdisjPrefix_false': forall p1 p2 s1 s2, sdisjPrefix (srev s1) (srev s2)=true -> (p1++s1=p2++s2)%string -> False. Proof. intros p1 p2 s1 s2. repeat (rewrite <- sappend_append). assert ((p2++s2)%string=sappend p2 s2). - rewrite <- sappend_append. reflexivity. - rewrite H. intros. eapply sdisjPrefix_sappend_false. + apply H0. + apply H1. Qed.*) Theorem sdisjPrefix_false: forall p1 p2 s1 s2, sdisjPrefix (srev s1) (srev s2)=true -> (False <-> (p1++s1=p2++s2)%string). Proof. intros p1 p2 s1 s2. repeat (rewrite <- sappend_append). assert ((p2++s2)%string=sappend p2 s2). - rewrite <- sappend_append. reflexivity. - rewrite H. intros. split. + intro X. inversion X. + eapply sdisjPrefix_sappend_false. * apply H0. Qed. Definition KRSimplifyTop_string (e: KRExpr_string) : KRExpr_string := match e with | KRstring_append (KRConst_string a) (KRConst_string b) => KRConst_string ((sappend a b)%string) | KRfst_RegInitT_string (KRPair_RegInitT s v) => s | KRfst_DefMethT_string (KRPair_DefMethT s v) => s | KRfst_Rule_string (KRPair_Rule s v) => s | x => x end. Definition KRSimplifyTop_list_string (e: KRExpr_list_string) : KRExpr_list_string := match e with | KRApp_list_string f c => match f with | KRCons_list_string ff rr => KRCons_list_string ff (KRApp_list_string rr c) | KRNil_list_string => c | x => match c with | KRNil_list_string => f | y => KRApp_list_string f c end end | KRgetCallsPerMod (KRConcatMod a b) => KRApp_list_string (KRgetCallsPerMod a) (KRgetCallsPerMod b) | KRgetCallsPerMod (KRBase (KRBaseRegFile m)) => KRNil_list_string | KRmap_RegInitT_string f (KRApp_list_RegInitT a b) => KRApp_list_string (KRmap_RegInitT_string f a) (KRmap_RegInitT_string f b) | KRmap_RegInitT_string KRfst_RegInitT_string_Func (KRCons_list_RegInitT f r) => KRCons_list_string (KRfst_RegInitT_string f) (KRmap_RegInitT_string KRfst_RegInitT_string_Func r) | KRmap_DefMethT_string f (KRApp_list_DefMethT a b) => KRApp_list_string (KRmap_DefMethT_string f a) (KRmap_DefMethT_string f b) | KRmap_DefMethT_string KRfst_DefMethT_string_Func (KRCons_list_DefMethT f r) => KRCons_list_string (KRfst_DefMethT_string f) (KRmap_DefMethT_string KRfst_DefMethT_string_Func r) | KRmap_Rule_string f (KRApp_list_Rule a b) => KRApp_list_string (KRmap_Rule_string f a) (KRmap_Rule_string f b) | KRmap_Rule_string KRfst_Rule_string_Func (KRCons_list_Rule f r) => KRCons_list_string (KRfst_Rule_string f) (KRmap_Rule_string KRfst_Rule_string_Func r) | e => e end. Definition KRSimplifyTop_list_list_string (e: KRExpr_list_list_string) : KRExpr_list_list_string := match e with | KRApp_list_list_string f c => match f with | KRCons_list_list_string ff rr => KRCons_list_list_string ff (KRApp_list_list_string rr c) | KRNil_list_list_string => c | x => match c with | KRNil_list_list_string => f | y => KRApp_list_list_string f c end end | e => e end. Definition KRSimplifyTop_RegFileBase (e: KRExpr_RegFileBase) : KRExpr_RegFileBase := e. Definition KRSimplifyTop_list_RegFileBase (e: KRExpr_list_RegFileBase) : KRExpr_list_RegFileBase := match e with | KRApp_list_RegFileBase f c => match f with | KRCons_list_RegFileBase ff rr => KRCons_list_RegFileBase ff (KRApp_list_RegFileBase rr c) | KRNil_list_RegFileBase => c | x => match c with | KRNil_list_RegFileBase => f | y => KRApp_list_RegFileBase f c end end | e => e end. Definition KRSimplifyTop_CallWithSign (e: KRExpr_CallWithSign) : KRExpr_CallWithSign := e. Definition KRSimplifyTop_list_CallWithSign (e: KRExpr_list_CallWithSign) : KRExpr_list_CallWithSign := match e with | KRApp_list_CallWithSign f c => match f with | KRCons_list_CallWithSign ff rr => KRCons_list_CallWithSign ff (KRApp_list_CallWithSign rr c) | KRNil_list_CallWithSign => c | x => match c with | KRNil_list_CallWithSign => f | y => KRApp_list_CallWithSign f c end end | e => e end. Definition KRSimplifyTop_list_list_CallWithSign (e: KRExpr_list_list_CallWithSign) : KRExpr_list_list_CallWithSign := match e with | KRApp_list_list_CallWithSign f c => match f with | KRCons_list_list_CallWithSign ff rr => KRCons_list_list_CallWithSign ff (KRApp_list_list_CallWithSign rr c) | KRNil_list_list_CallWithSign => c | x => match c with | KRNil_list_list_CallWithSign => f | y => KRApp_list_list_CallWithSign f c end end | e => e end. Definition KRSimplifyTop_Mod_Mod_PairFunc(f: KRExpr_Mod_Mod_PairFunc) := f. Definition KRSimplifyTop_RegFileBase_list_RegInitT_Func(f: KRExpr_RegFileBase_list_RegInitT_Func) := f. Definition KRSimplifyTop_RegFileBase_list_DefMethT_Func(f: KRExpr_RegFileBase_list_DefMethT_Func) := f. Definition KRSimplifyTop_Mod_list_string_Func(f: KRExpr_Mod_list_string_Func) := f. Definition KRSimlpifyTop_RegFileBase_Mod_Func(f: KRExpr_RegFileBase_Mod_Func) := f. Definition KRSimplifyTop_Mod_list_DefMethT_Func(f: KRExpr_Mod_list_DefMethT_Func) := f. Definition KRSimplifyTop_Mod_list_Rule_Func(f:KRExpr_Mod_list_Rule_Func) := f. Definition KRSimplifyTop_Mod_list_RegInitT_Func(f:KRExpr_Mod_list_RegInitT_Func) := f. Definition KRSimplifyTop_BaseModule (e : KRExpr_BaseModule) := e. Definition KRSimplifyTop_Mod (e : KRExpr_Mod) := e. Definition KRSimplifyTop_list_Mod (e: KRExpr_list_Mod) : KRExpr_list_Mod := match e with | KRApp_list_Mod f c => match f with | KRCons_list_Mod ff rr => KRCons_list_Mod ff (KRApp_list_Mod rr c) | KRNil_list_Mod => c | x => match c with | KRNil_list_Mod => f | y => KRApp_list_Mod f c end end | e => e end. (*********************************************************************************************************) Definition KRSimplify_RegInitValT (e : KRExpr_RegInitValT) : KRExpr_RegInitValT := KRSimplifyTop_RegInitValT e. Definition KRSimplify_ActionVoid(e : KRExpr_ActionVoid) : KRExpr_ActionVoid := KRSimplifyTop_ActionVoid e. Definition KRSimplify_MethodT(e: KRExpr_MethodT) : KRExpr_MethodT := KRSimplifyTop_MethodT e. Fixpoint KRSimplify_RegInitT (e : KRExpr_RegInitT) : KRExpr_RegInitT := KRSimplifyTop_RegInitT (match e with | KRPair_RegInitT f s => KRPair_RegInitT (KRSimplify_string f) (KRSimplify_RegInitValT s) | _ => e end) with KRSimplify_Rule (e : KRExpr_Rule) : KRExpr_Rule := KRSimplifyTop_Rule (match e with | KRPair_Rule f s => KRPair_Rule (KRSimplify_string f) (KRSimplify_ActionVoid s) | _ => e end) with KRSimplify_DefMethT (e : KRExpr_DefMethT) : KRExpr_DefMethT := KRSimplifyTop_DefMethT (match e with | KRPair_DefMethT f s => KRPair_DefMethT (KRSimplify_string f) (KRSimplify_MethodT s) | _ => e end) with KRSimplify_string(s:KRExpr_string) := KRSimplifyTop_string (match s with | KRstring_append a b => KRstring_append (KRSimplify_string a) (KRSimplify_string b) | KRfst_RegInitT_string r => KRfst_RegInitT_string (KRSimplify_RegInitT r) | KRfst_DefMethT_string r => KRfst_DefMethT_string (KRSimplify_DefMethT r) | KRfst_Rule_string r => KRfst_Rule_string (KRSimplify_Rule r) | s => s end). Fixpoint KRSimplify_ModuleElt (e : KRExpr_ModuleElt) : KRExpr_ModuleElt := KRSimplifyTop_ModuleElt (match e with | KRMERegister r => KRMERegister (KRSimplify_RegInitT r) | KRMERule r => KRMERule (KRSimplify_Rule r) | KRMEMeth m => KRMEMeth (KRSimplify_DefMethT m) | e => e end). Definition KRSimplify_RegFileBase_Mod_Func(f: KRExpr_RegFileBase_Mod_Func) := f. Definition KRSimplify_RegInitT_string_Func(f: KRExpr_RegInitT_string_Func) := f. Definition KRSimplify_DefMethT_string_Func(f: KRExpr_DefMethT_string_Func) := f. Definition KRSimplify_Rule_string_Func(f: KRExpr_Rule_string_Func) := f. Definition KRSimplify_Mod_Mod_PairFunc(f: KRExpr_Mod_Mod_PairFunc) := f. Definition KRSimplify_Mod_list_DefMethT_Func(f: KRExpr_Mod_list_DefMethT_Func) := f. Definition KRSimplify_RegFileBase_list_DefMethT_Func(f: KRExpr_RegFileBase_list_DefMethT_Func) := f. Definition KRSimplify_RegFileBase_list_RegInitT_Func (f: KRExpr_RegFileBase_list_RegInitT_Func) := f. Definition KRSimplify_Mod_list_RegInitT_Func (f: KRExpr_Mod_list_RegInitT_Func) := f. Definition KRSimplify_Mod_list_Rule_Func(f: KRExpr_Mod_list_Rule_Func) := f. Definition KRSimplify_Mod_list_string_Func(f: KRExpr_Mod_list_string_Func) := f. Definition KRSimplify_CallWithSign(c: KRExpr_CallWithSign) := c. Fixpoint KRSimplify_list_CallWithSign(e: KRExpr_list_CallWithSign) := KRSimplifyTop_list_CallWithSign (match e with | KRCons_list_CallWithSign f r => KRCons_list_CallWithSign (KRSimplify_CallWithSign f) (KRSimplify_list_CallWithSign r) | KRApp_list_CallWithSign f r => KRApp_list_CallWithSign (KRSimplify_list_CallWithSign f) (KRSimplify_list_CallWithSign r) | KRConcat_CallWithSign l => KRConcat_CallWithSign (KRSimplify_list_list_CallWithSign l) | e => e end) with KRSimplify_list_list_CallWithSign(e: KRExpr_list_list_CallWithSign) := KRSimplifyTop_list_list_CallWithSign (match e with | KRCons_list_list_CallWithSign f r => KRCons_list_list_CallWithSign (KRSimplify_list_CallWithSign f) (KRSimplify_list_list_CallWithSign r) | KRApp_list_list_CallWithSign f r => KRApp_list_list_CallWithSign (KRSimplify_list_list_CallWithSign f) (KRSimplify_list_list_CallWithSign r) | e => e end). Definition KRSimplify_RegFileBase(m: KRExpr_RegFileBase) := m. Fixpoint KRSimplify_list_RegFileBase(e: KRExpr_list_RegFileBase) := KRSimplifyTop_list_RegFileBase (match e with | KRCons_list_RegFileBase f r => KRCons_list_RegFileBase (KRSimplify_RegFileBase f) (KRSimplify_list_RegFileBase r) | KRApp_list_RegFileBase f r => KRApp_list_RegFileBase (KRSimplify_list_RegFileBase f) (KRSimplify_list_RegFileBase r) | e => e end). Fixpoint KRSimplify_list_RegInitT (e : KRExpr_list_RegInitT) : KRExpr_list_RegInitT := KRSimplifyTop_list_RegInitT (match e with | KRCons_list_RegInitT f r => KRCons_list_RegInitT (KRSimplify_RegInitT f) (KRSimplify_list_RegInitT r) | KRApp_list_RegInitT f r => KRApp_list_RegInitT (KRSimplify_list_RegInitT f) (KRSimplify_list_RegInitT r) | KRgetRegisters m => KRgetRegisters (KRSimplify_BaseModule m) | KRgetAllRegisters m => KRgetAllRegisters (KRSimplify_Mod m) | KRMakeModule_regs r => KRMakeModule_regs (KRSimplify_list_ModuleElt r) | KRConcat_RegInitT r => KRConcat_RegInitT (KRSimplify_list_list_RegInitT r) | e => e end) with KRSimplify_list_list_RegInitT (e: KRExpr_list_list_RegInitT) : KRExpr_list_list_RegInitT := KRSimplifyTop_list_list_RegInitT (match e with | KRCons_list_list_RegInitT f r => KRCons_list_list_RegInitT (KRSimplify_list_RegInitT f) (KRSimplify_list_list_RegInitT r) | KRApp_list_list_RegInitT f r => KRApp_list_list_RegInitT (KRSimplify_list_list_RegInitT f) (KRSimplify_list_list_RegInitT r) | KRMap_list_Mod_list_list_RegInitT f l => KRMap_list_Mod_list_list_RegInitT (KRSimplify_Mod_list_RegInitT_Func f) (KRSimplify_list_Mod l) | KRMap_list_RegFileBase_list_list_RegInitT f l => KRMap_list_RegFileBase_list_list_RegInitT (KRSimplify_RegFileBase_list_RegInitT_Func f) (KRSimplify_list_RegFileBase l) | e => e end) with KRSimplify_BaseModule (e : KRExpr_BaseModule) : KRExpr_BaseModule := KRSimplifyTop_BaseModule (match e with | KRMakeModule e => KRMakeModule (KRSimplify_list_ModuleElt e) | KRBaseMod regs rules meths => KRBaseMod (KRSimplify_list_RegInitT regs) (KRSimplify_list_Rule rules) (KRSimplify_list_DefMethT meths) | KRBaseRegFile b => KRBaseRegFile (KRSimplify_RegFileBase b) | e => e end) with KRSimplify_Mod (e : KRExpr_Mod) : KRExpr_Mod := KRSimplifyTop_Mod (match e with | KRBase b => KRBase (KRSimplify_BaseModule b) | KRConcatMod a b => KRConcatMod (KRSimplify_Mod a) (KRSimplify_Mod b) | KRFold_right_Mod f a b => KRFold_right_Mod (KRSimplify_Mod_Mod_PairFunc f) (KRSimplify_Mod a) (KRSimplify_list_Mod b) | e => e end) with KRSimplify_list_ModuleElt (e: KRExpr_list_ModuleElt) : KRExpr_list_ModuleElt := KRSimplifyTop_list_ModuleElt (match e with | KRCons_list_ModuleElt f r => KRCons_list_ModuleElt (KRSimplify_ModuleElt f) (KRSimplify_list_ModuleElt r) | KRApp_list_ModuleElt f r => KRApp_list_ModuleElt (KRSimplify_list_ModuleElt f) (KRSimplify_list_ModuleElt r) | KRRegisters r => KRRegisters (KRSimplify_list_RegInitT r) | KRRules r => KRRules (KRSimplify_list_Rule r) | KRMethods m => KRMethods (KRSimplify_list_DefMethT m) | e => e end) with KRSimplify_list_Mod(e: KRExpr_list_Mod) := KRSimplifyTop_list_Mod (match e with | KRCons_list_Mod f r => KRCons_list_Mod (KRSimplify_Mod f) (KRSimplify_list_Mod r) | KRApp_list_Mod f r => KRApp_list_Mod (KRSimplify_list_Mod f) (KRSimplify_list_Mod r) | e => e end) with KRSimplify_list_DefMethT (e: KRExpr_list_DefMethT) : KRExpr_list_DefMethT := KRSimplifyTop_list_DefMethT (match e with | KRCons_list_DefMethT f r => KRCons_list_DefMethT (KRSimplify_DefMethT f) (KRSimplify_list_DefMethT r) | KRApp_list_DefMethT f r => KRApp_list_DefMethT (KRSimplify_list_DefMethT f) (KRSimplify_list_DefMethT r) | KRConcat_DefMethT r => KRConcat_DefMethT (KRSimplify_list_list_DefMethT r) | KRgetMethods m => KRgetMethods (KRSimplify_BaseModule m) | KRgetAllMethods m => KRgetAllMethods (KRSimplify_Mod m) | KRMakeModule_meths r => KRMakeModule_meths (KRSimplify_list_ModuleElt r) | e => e end) with KRSimplify_list_Rule (e: KRExpr_list_Rule) : KRExpr_list_Rule := KRSimplifyTop_list_Rule (match e with | KRCons_list_Rule f r => KRCons_list_Rule (KRSimplify_Rule f) (KRSimplify_list_Rule r) | KRApp_list_Rule f r => KRApp_list_Rule (KRSimplify_list_Rule f) (KRSimplify_list_Rule r) | KRgetRules m => KRgetRules (KRSimplify_BaseModule m) | KRgetAllRules m => KRgetAllRules (KRSimplify_Mod m) | KRMakeModule_rules r => KRMakeModule_rules (KRSimplify_list_ModuleElt r) | KRConcat_Rule r => KRConcat_Rule (KRSimplify_list_list_Rule r) | e => e end) with KRSimplify_list_list_Rule (e: KRExpr_list_list_Rule) : KRExpr_list_list_Rule := KRSimplifyTop_list_list_Rule (match e with | KRCons_list_list_Rule f r => KRCons_list_list_Rule (KRSimplify_list_Rule f) (KRSimplify_list_list_Rule r) | KRApp_list_list_Rule f r => KRApp_list_list_Rule (KRSimplify_list_list_Rule f) (KRSimplify_list_list_Rule r) | KRMap_list_Mod_list_list_Rule f l => KRMap_list_Mod_list_list_Rule (KRSimplify_Mod_list_Rule_Func f) (KRSimplify_list_Mod l) | e => e end) with KRSimplify_list_list_DefMethT (e: KRExpr_list_list_DefMethT) : KRExpr_list_list_DefMethT := KRSimplifyTop_list_list_DefMethT (match e with | KRCons_list_list_DefMethT f r => KRCons_list_list_DefMethT (KRSimplify_list_DefMethT f) (KRSimplify_list_list_DefMethT r) | KRApp_list_list_DefMethT f r => KRApp_list_list_DefMethT (KRSimplify_list_list_DefMethT f) (KRSimplify_list_list_DefMethT r) | KRMap_list_Mod_list_list_DefMethT f l => KRMap_list_Mod_list_list_DefMethT (KRSimplify_Mod_list_DefMethT_Func f) (KRSimplify_list_Mod l) | KRMap_list_RegFileBase_list_list_DefMethT f l => KRMap_list_RegFileBase_list_list_DefMethT (KRSimplify_RegFileBase_list_DefMethT_Func f) (KRSimplify_list_RegFileBase l) | e => e end). Fixpoint KRSimplify_list_list_ModuleElt (e: KRExpr_list_list_ModuleElt) : KRExpr_list_list_ModuleElt := KRSimplifyTop_list_list_ModuleElt (match e with | KRCons_list_list_ModuleElt f r => KRCons_list_list_ModuleElt (KRSimplify_list_ModuleElt f) (KRSimplify_list_list_ModuleElt r) | KRApp_list_list_ModuleElt f r => KRApp_list_list_ModuleElt (KRSimplify_list_list_ModuleElt f) (KRSimplify_list_list_ModuleElt r) | e => e end). Fixpoint KRSimplify_list_string(e: KRExpr_list_string) := KRSimplifyTop_list_string (match e with | KRCons_list_string f r => KRCons_list_string (KRSimplify_string f) (KRSimplify_list_string r) | KRApp_list_string f r => KRApp_list_string (KRSimplify_list_string f) (KRSimplify_list_string r) | KRgetCallsPerMod m => KRgetCallsPerMod (KRSimplify_Mod m) | KRConcat_string l => KRConcat_string (KRSimplify_list_list_string l) | KRmap_RegInitT_string f l => KRmap_RegInitT_string (KRSimplify_RegInitT_string_Func f) (KRSimplify_list_RegInitT l) | KRmap_DefMethT_string f l => KRmap_DefMethT_string (KRSimplify_DefMethT_string_Func f) (KRSimplify_list_DefMethT l) | KRmap_Rule_string f l => KRmap_Rule_string (KRSimplify_Rule_string_Func f) (KRSimplify_list_Rule l) | e => e end) with KRSimplify_list_list_string(e: KRExpr_list_list_string) := KRSimplifyTop_list_list_string (match e with | KRCons_list_list_string f r => KRCons_list_list_string (KRSimplify_list_string f) (KRSimplify_list_list_string r) | KRApp_list_list_string f r => KRApp_list_list_string (KRSimplify_list_list_string f) (KRSimplify_list_list_string r) | e => e end). (*********************************************************************************************************) Ltac match_KRExprType t := match t with | KRExpr_RegInitT => idtac | KRExpr_list_RegInitT => idtac | KRExpr_list_list_RegInitT => idtac | KRExpr_RegInitValT => idtac | KRExpr_DefMethT => idtac | KRExpr_ActionVoid => idtac | KRExpr_Rule => idtac | KRExpr_list_Rule => idtac | KRExpr_list_list_Rule => idtac | KRExpr_DefMethT => idtac | KRExpr_list_DefMethT => idtac | KRExpr_list_list_DefMethT => idtac | KRExpr_ModuleElt => idtac | KRExpr_list_ModuleElt => idtac | KRExpr_list_list_ModuleElt => idtac | KRExpr_string => idtac | KRExpr_Prop => idtac | KRExpr_list_string => idtac | KRExpr_list_list_string => idtac | KRExpr_Mod => idtac | KRExpr_list_Mod => idtac | KRExpr_RegFileBase => idtac | KRExpr_list_RegFileBase => idtac | KRExpr_string => idtac | KRExpr_list_string => idtac | KRExpr_list_list_string => idtac end. Ltac match_KRExprDenote d := match d with | KRExprDenote_RegInitT => idtac | KRExprDenote_RegInitValT => idtac | KRExprDenote_DefMethT => idtac | KRExprDenote_ActionVoid => idtac | KRExprDenote_list_RegInitT => idtac | KRExprDenote_list_list_RegInitT => idtac | KRExprDenote_Rule => idtac | KRExprDenote_list_Rule => idtac | KRExprDenote_list_list_Rule => idtac | KRExprDenote_DefMethT => idtac | KRExprDenote_list_DefMethT => idtac | KRExprDenote_list_list_DefMethT => idtac | KRExprDenote_ModuleElt => idtac | KRExprDenote_list_ModuleElt => idtac | KRExprDenote_list_list_ModuleElt => idtac | KRExprDenote_Prop => idtac | KRExprDenote_string => idtac | KRExprDenote_list_string => idtac | KRExprDenote_list_list_string => idtac | KRExprDenote_Mod => idtac | KRExprDenote_list_Mod => idtac | KRExprDenote_RegFileBase => idtac | KRExprDenote_list_RegFileBase => idtac | KRExprDenote_string => idtac | KRExprDenote_list_string => idtac | KRExprDenote_list_list_string => idtac end. Ltac isVar x := match x with | ?A ?B => fail 1 | _ => idtac end. Ltac step_KRSimplifyTopSound := match goal with | _ => progress intros | _ => progress simpl | _ => progress (autorewrite with kami_rewrite_db) | _ => progress (autorewrite with KRSimplify) | _ => progress reflexivity | |- (_,_)=(_,_) => progress f_equal end. Ltac solve_contKRSimplifyTopSound := try (intros;reflexivity); match goal with | _ => progress (repeat step_KRSimplifyTopSound) | |- context [ (?D (match ?E with _ => _ end)) ] => match_KRExprDenote D;isVar E;induction E;try reflexivity | |- {?A = ?B}+{?A <> ?B} => repeat (decide equality) end. Ltac solve_KRSimplifyTopSound := try (intros;reflexivity); match goal with | _ => progress (repeat step_KRSimplifyTopSound) | V: ?T |- _ => match_KRExprType T;induction V;try reflexivity end. Scheme KRExpr_RegInitT_mut := Induction for KRExpr_RegInitT Sort Prop with KRExpr_Rule_mut := Induction for KRExpr_Rule Sort Prop with KRExpr_DefMethT_mut := Induction for KRExpr_DefMethT Sort Prop with KRExpr_ModuleElt_mut := Induction for KRExpr_ModuleElt Sort Prop with KRExpr_list_RegInitT_mut := Induction for KRExpr_list_RegInitT Sort Prop with KRExpr_list_Rule_mut := Induction for KRExpr_list_Rule Sort Prop with KRExpr_list_DefMethT_mut := Induction for KRExpr_list_DefMethT Sort Prop with KRExpr_list_ModuleElt_mut := Induction for KRExpr_list_ModuleElt Sort Prop with KRExpr_list_list_RegInitT_mut := Induction for KRExpr_list_list_RegInitT Sort Prop with KRExpr_list_list_Rule_mut := Induction for KRExpr_list_list_Rule Sort Prop with KRExpr_list_list_DefMethT_mut := Induction for KRExpr_list_list_DefMethT Sort Prop with KRExpr_list_list_ModuleElt_mut := Induction for KRExpr_list_list_ModuleElt Sort Prop with KRExpr_RegFileBase_mut := Induction for KRExpr_RegFileBase Sort Prop with KRExpr_list_RegFileBase_mut := Induction for KRExpr_list_RegFileBase Sort Prop with KRExpr_BaseModule_mut := Induction for KRExpr_BaseModule Sort Prop with KRExpr_Mod_mut := Induction for KRExpr_Mod Sort Prop with KRExpr_list_Mod_mut := Induction for KRExpr_list_Mod Sort Prop with KRExpr_CallWithSign_mut := Induction for KRExpr_CallWithSign Sort Prop with KRExpr_list_CallWithSign_mut := Induction for KRExpr_list_CallWithSign Sort Prop with KRExpr_list_list_CallWithSign_mut := Induction for KRExpr_list_list_CallWithSign Sort Prop with KRExpr_string_mut := Induction for KRExpr_string Sort Prop with KRExpr_list_string_mut := Induction for KRExpr_list_string Sort Prop with KRExpr_list_list_string_mut := Induction for KRExpr_list_list_string Sort Prop with KRExpr_Prop_mut := Induction for KRExpr_Prop Sort Prop. (*Combined Scheme KRExpr_mutind from KRExpr_RegInitT_mut, KRExpr_Rule_mut, KRExpr_DefMethT_mut, KRExpr_ModuleElt_mut, KRExpr_list_RegInitT_mut, KRExpr_list_Rule_mut, KRExpr_list_DefMethT_mut, KRExpr_list_ModuleElt_mut, KRExpr_list_list_ModuleElt_mut, KRExpr_BaseModule_mut, KRExpr_Mod_mut.*) Ltac noDenote x := match x with | context [ ?D _ ] => match_KRExprDenote D;fail 1 | _ => idtac end. Ltac KRSimplifySound_unit := match goal with | |- (_,_)=(_,_) => f_equal | _ => reflexivity | _ => progress simpl (*| |- _ = KRExprDenote_Mod (match KRSimplify_Mod ?V with _ => _ end) => let Q := fresh in remember V as Q;destruct Q | |- _ = KRExprDenote_list_DefMethT (match KRSimplify_Mod ?V with _ => _ end) => let Q := fresh in remember V as Q;destruct Q*) | H: _ = _ |- _ => progress (simpl in H) | H: Base _ = Base _ |- _ => inversion H;subst;clear H | H: KRVar_RegInitT_string_Func _ = KRVar_RegInitT_string_Func _ |- _ => inversion H;subst;clear H | _ => progress subst | _ => progress (autorewrite with kami_rewrite_db) | _ => progress (autorewrite with KRSimplify) | H: KRExprDenote_BaseModule _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_string _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_string _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_list_string _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_Mod _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_Mod _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_RegInitT _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_RegInitValT _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_DefMethT _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_ActionVoid _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_RegInitT _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_list_RegInitT _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_Rule _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_Rule _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_list_Rule _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_DefMethT _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_DefMethT _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_list_DefMethT _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_RegFileBase _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_RegFileBase _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_CallWithSign _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_CallWithSign _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_list_list_CallWithSign _ = ?R |- _ => noDenote R;rewrite H | H: KRExprDenote_Prop _ = ?R |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_BaseModule _ |- _ => noDenote R;rewrite <- H | H: ?R = KRExprDenote_string _ |- _ => noDenote R;rewrite <- H | H: ?R = KRExprDenote_list_string _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_list_string _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_Mod _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_Mod _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_RegInitT _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_RegInitValT _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_DefMethT _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_ActionVoid _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_RegInitT _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_list_RegInitT _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_Rule _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_Rule _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_list_Rule _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_DefMethT _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_DefMethT _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_list_DefMethT _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_RegFileBase _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_RegFileBase _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_CallWithSign _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_CallWithSign _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_list_list_CallWithSign _ |- _ => noDenote R;rewrite H | H: ?R = KRExprDenote_Prop _ |- _ => noDenote R;rewrite H | H: _ = True |- _ => rewrite H | H: _ = False |- _ => rewrite H | H: True = _ |- _ => rewrite <- H | H: False = _ |- _ => rewrite <- H (*| H: ?A = (?A /\ ?B) |- _ => rewrite <- H | H: ?B = (?A /\ ?B) |- _ => rewrite <- H | H: ?A = ?B |- (?Q /\ ?A)= (?Q /\ ?B) => rewrite H | H: ?A = ?B |- (?A /\ ?Q)= (?B /\ ?Q) => rewrite H | H1: ?A = ?B, H2: ?C = ?D |- (?A /\ ?C)= (?B /\ ?D) => rewrite H1;rewrite H2 | H: ?A = ?B |- (?Q \/ ?A)= (?Q \/ ?B) => rewrite H | H: ?A = ?B |- (?A \/ ?Q)= (?B \/ ?Q) => rewrite H | H1: ?A = ?B, H2: ?C = ?D |- (?A \/ ?C)= (?B \/ ?D) => rewrite H1;rewrite H2 | H: ?A |- ?A => apply H*) (*| |- context [match ?Q with _ => _ end ] => let R := fresh in (remember Q as R;destruct R; try reflexivity)*) end. Ltac KRSimplifySound_crunch := match goal with | |- context [ KRExprDenote_Mod (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_string (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_RegInitT (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_Rule (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_DefMethT (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_string (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_list_string (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_Mod (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_BaseModule (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_RegInitT (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_list_RegInitT (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_DefMethT (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_list_DefMethT (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_Rule (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_list_Rule (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_CallWithSign (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_list_CallWithSign (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_ModuleElt (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_list_RegFileBase (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_Prop (match ?Q with _ => _ end) ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_Mod_list_RegInitT_Func ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_Mod_list_DefMethT_Func ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_Mod_list_Rule_Func ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_RegFileBase_list_RegInitT_Func ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_RegFileBase_list_DefMethT_Func ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_RegInitT_string_Func ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_DefMethT_string_Func ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_Rule_string_Func ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | |- context [ KRExprDenote_Mod_Mod_PairFunc ?Q ] => let R := fresh in (remember Q as R;destruct R;repeat KRSimplifySound_unit) | _ => KRSimplifySound_unit;repeat KRSimplifySound_unit | |- { ?A = ?B } + { ?A <> ?B } => intros;repeat (decide equality) | |- forall _, _ => intros | H: KRVar_RegInitT_string_Func _ = KRfst_RegInitT_string_Func |- _ => inversion H | H: KRfst_RegInitT_string_Func = KRVar_RegInitT_string_Func _ |- _ => inversion H | H: KRVar_RegInitT_string_Func _ = KRVar_RegInitT_string_Func _ |- _ => inversion H | H: KRVar_DefMethT_string_Func _ = KRfst_DefMethT_string_Func |- _ => inversion H | H: KRfst_DefMethT_string_Func = KRVar_DefMethT_string_Func _ |- _ => inversion H | H: KRVar_DefMethT_string_Func _ = KRVar_DefMethT_string_Func _ |- _ => inversion H | H: KRVar_Rule_string_Func _ = KRfst_Rule_string_Func |- _ => inversion H | H: KRfst_Rule_string_Func = KRVar_Rule_string_Func _ |- _ => inversion H | H: KRVar_Rule_string_Func _ = KRVar_Rule_string_Func _ |- _ => inversion H end. Theorem KRSimplify_RegInitValT_trivial: forall x, (KRSimplify_RegInitValT x)=x. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_RegInitValT_trivial : KRSimplify. Theorem KRSimplify_MethodT_trivial: forall x, (KRSimplify_MethodT x)=x. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_MethodT_trivial : KRSimplify. Theorem KRSimplify_ActionVoid_trivial: forall x, (KRSimplify_ActionVoid x)=x. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_ActionVoid_trivial : KRSimplify. Theorem KRSimplify_RegFileBase_trivial: forall x, (KRSimplify_RegFileBase x)=x. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_RegFileBase_trivial : KRSimplify. Theorem KRSimplify_RegFileBase_Mod_Func_trivial: forall x, KRSimplify_RegFileBase_Mod_Func x = x. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_RegFileBase_Mod_Func_trivial : KRSimplify. Theorem KRSimplify_RegInitT_string_Func_trivial: forall f, KRSimplify_RegInitT_string_Func f = f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_RegInitT_string_Func_trivial : KRSimplify. Theorem KRSimplify_DefMethT_string_Func_trivial: forall f, KRSimplify_DefMethT_string_Func f=f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_DefMethT_string_Func_trivial : KRSimplify. Theorem KRSimplify_Rule_string_Func_trivial: forall f, KRSimplify_Rule_string_Func f=f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Rule_string_Func_trivial : KRSimplify. Theorem KRSimplify_Mod_Mod_PairFunc_trivial: forall f, KRSimplify_Mod_Mod_PairFunc f = f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Mod_Mod_PairFunc_trivial : KRSimplify. Theorem KRSimplify_Mod_list_DefMethT_Func_trivial: forall f, KRSimplify_Mod_list_DefMethT_Func f = f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Mod_list_DefMethT_Func_trivial : KRSimplify. Theorem KRSimplify_RegFileBase_list_DefMethT_Func_trivial: forall f, KRSimplify_RegFileBase_list_DefMethT_Func f = f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_RegFileBase_list_DefMethT_Func_trivial : KRSimplify. Theorem KRSimplify_RegFileBase_list_RegInitT_Func_trivial: forall f, KRSimplify_RegFileBase_list_RegInitT_Func f = f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_RegFileBase_list_RegInitT_Func_trivial : KRSimplify. Theorem KRSimplify_Mod_list_RegInitT_Func_trivial: forall f, KRSimplify_Mod_list_RegInitT_Func f = f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Mod_list_RegInitT_Func_trivial : KRSimplify. Theorem KRSimplify_Mod_list_Rule_Func_trivial: forall f, KRSimplify_Mod_list_Rule_Func f = f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Mod_list_Rule_Func_trivial : KRSimplify. Theorem KRSimplify_Mod_list_string_Func_trivial: forall f, KRSimplify_Mod_list_string_Func f = f. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_Mod_list_string_Func_trivial : KRSimplify. Theorem KRSimplify_CallWithSign_trivial: forall c, KRSimplify_CallWithSign c = c. Proof. reflexivity. Qed. Hint Rewrite KRSimplify_CallWithSign_trivial : KRSimplify. Theorem KRSimplify_list_RegInitT_KRApp_list_RegInitT : forall k k0, KRSimplify_list_RegInitT (KRApp_list_RegInitT k k0)=KRSimplifyTop_list_RegInitT (KRApp_list_RegInitT (KRSimplify_list_RegInitT k) (KRSimplify_list_RegInitT k0)). Proof. reflexivity. Qed. (*Theorem KRSimplify_list_RegInitT_KRgetAllRegisters: forall k, KRSimplify_list_RegInitT (KRgetAllRegisters k)=KRgetAllRegisters (KRSimplify_Mod k). Proof. intros. simpl. destruct k;simpl;try reflexivity. destruct k;try reflexivity. simpl. destruct k;try reflexivity;simpl. destruct k; reflexivity. Qed.*) Hint Rewrite KRSimplify_list_RegInitT_KRApp_list_RegInitT : KRSimplify. Theorem KRSimplify_list_RegInitT_KRMakeModule_regs: forall k, KRSimplify_list_RegInitT (KRMakeModule_regs k)=KRSimplifyTop_list_RegInitT (KRMakeModule_regs (KRSimplify_list_ModuleElt k)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_RegInitT_KRMakeModule_regs : KRSimplify. Theorem KRSimplify_list_Rule_KRApp_list_Rule : forall k k0, KRSimplify_list_Rule (KRApp_list_Rule k k0)=KRSimplifyTop_list_Rule (KRApp_list_Rule (KRSimplify_list_Rule k) (KRSimplify_list_Rule k0)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_Rule_KRApp_list_Rule : KRSimplify. Theorem KRSimplify_list_Rule_KRMakeModule_rules: forall k, KRSimplify_list_Rule (KRMakeModule_rules k)=KRSimplifyTop_list_Rule (KRMakeModule_rules (KRSimplify_list_ModuleElt k)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_Rule_KRMakeModule_rules : KRSimplify. Theorem KRSimplify_list_DefMethT_KRApp_list_DefMethT : forall k k0, KRSimplify_list_DefMethT (KRApp_list_DefMethT k k0)=KRSimplifyTop_list_DefMethT (KRApp_list_DefMethT (KRSimplify_list_DefMethT k) (KRSimplify_list_DefMethT k0)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_DefMethT_KRApp_list_DefMethT : KRSimplify. Theorem KRSimplify_list_DefMethT_KRMakeModule_meths: forall k, KRSimplify_list_DefMethT (KRMakeModule_meths k)=KRSimplifyTop_list_DefMethT (KRMakeModule_meths (KRSimplify_list_ModuleElt k)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_DefMethT_KRMakeModule_meths : KRSimplify. Theorem KRSimplify_list_ModuleElt_KRApp_list_ModuleElt: forall k k0, KRSimplify_list_ModuleElt (KRApp_list_ModuleElt k k0)=KRSimplifyTop_list_ModuleElt (KRApp_list_ModuleElt (KRSimplify_list_ModuleElt k) (KRSimplify_list_ModuleElt k0)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_ModuleElt_KRApp_list_ModuleElt : KRSimplify. Theorem KRSimplify_list_list_ModuleElt_KRApp_list_list_ModuleElt: forall k k0, KRSimplify_list_list_ModuleElt (KRApp_list_list_ModuleElt k k0)=KRSimplifyTop_list_list_ModuleElt (KRApp_list_list_ModuleElt (KRSimplify_list_list_ModuleElt k) (KRSimplify_list_list_ModuleElt k0)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_list_ModuleElt_KRApp_list_list_ModuleElt : KRSimplify. Theorem KRSimplify_BaseModule_KRBaseMod: forall k k0 k1, KRSimplify_BaseModule (KRBaseMod k k0 k1)=KRSimplifyTop_BaseModule (KRBaseMod (KRSimplify_list_RegInitT k) (KRSimplify_list_Rule k0) (KRSimplify_list_DefMethT k1)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_BaseModule_KRBaseMod: KRSimplify. ================================================ FILE: Rewrites/ReflectionSoundTheorems1.v ================================================ Require Import Kami.Notations. Require Import Kami.Syntax. Require Import List. Require Import Kami.Rewrites.Notations_rewrites. Require Import Program.Equality. Require Import Kami.Rewrites.ReflectionPre. Require Import Kami.Rewrites.ReflectionSoundTopTheorems. (************************************************************************************************************) Scheme KRExpr_RegInitT_mut := Induction for KRExpr_RegInitT Sort Prop with KRExpr_Rule_mut := Induction for KRExpr_Rule Sort Prop with KRExpr_DefMethT_mut := Induction for KRExpr_DefMethT Sort Prop with KRExpr_string_mut := Induction for KRExpr_string Sort Prop. Ltac KRSimplifySound_setup1 mut H H0 H1 := intros; eapply (mut (fun e : KRExpr_RegInitT => KRExprDenote_RegInitT (KRSimplify_RegInitT e) = KRExprDenote_RegInitT e) (fun e : KRExpr_Rule => KRExprDenote_Rule (KRSimplify_Rule e) = KRExprDenote_Rule e) (fun e : KRExpr_DefMethT => KRExprDenote_DefMethT (KRSimplify_DefMethT e) = KRExprDenote_DefMethT e) (fun e : KRExpr_string => KRExprDenote_string (KRSimplify_string e) = KRExprDenote_string e) ); try (intros);try(autorewrite with KRSimplify); try(autorewrite with KRSimplifyTopSound); try(simpl); try (rewrite H); try (rewrite H0); try (rewrite H1); try(reflexivity);intros. (************************************************************************************************************) Theorem KRSimplifySound_RegInitT: forall e, KRExprDenote_RegInitT (KRSimplify_RegInitT e) = KRExprDenote_RegInitT e. Proof. KRSimplifySound_setup1 KRExpr_RegInitT_mut H H0 H1; repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite H); try (rewrite H0); try(reflexivity). - rewrite <- H. reflexivity. - rewrite <- H. reflexivity. - rewrite <- H. reflexivity. Qed. Hint Rewrite KRSimplifySound_RegInitT : KRSimplify. Theorem KRSimplifySound_Rule: forall e, KRExprDenote_Rule (KRSimplify_Rule e) = KRExprDenote_Rule e. Proof. KRSimplifySound_setup1 KRExpr_Rule_mut H H0 H1; repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite H); try (rewrite H0); try(reflexivity). - rewrite <- H. reflexivity. - rewrite <- H. reflexivity. - rewrite <- H. reflexivity. Qed. Hint Rewrite KRSimplifySound_Rule : KRSimplify. Theorem KRSimplifySound_DefMethT: forall e, KRExprDenote_DefMethT (KRSimplify_DefMethT e) = KRExprDenote_DefMethT e. Proof. KRSimplifySound_setup1 KRExpr_DefMethT_mut H H0 H1; repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite H); try (rewrite H0); try(reflexivity). - rewrite <- H. reflexivity. - rewrite <- H. reflexivity. - rewrite <- H. reflexivity. Qed. Hint Rewrite KRSimplifySound_DefMethT : KRSimplify. Theorem KRSimplifySound_string: forall e, KRExprDenote_string (KRSimplify_string e) = KRExprDenote_string e. Proof. KRSimplifySound_setup1 KRExpr_string_mut H H0 H1; repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite H0); try (rewrite H); try reflexivity. - rewrite <- H; reflexivity. - rewrite <- H; reflexivity. - rewrite <- H; reflexivity. Qed. Hint Rewrite KRSimplifySound_string : KRSimplify. (************************************************************************************************************) Theorem KRSimplifySound_ModuleElt: forall e, KRExprDenote_ModuleElt (KRSimplify_ModuleElt e) = KRExprDenote_ModuleElt e. Proof. induction e. - reflexivity. - simpl. autorewrite with KRSimplify. reflexivity. - simpl. autorewrite with KRSimplify. reflexivity. - simpl. autorewrite with KRSimplify. reflexivity. Qed. Hint Rewrite KRSimplifySound_ModuleElt : KRSimplify. (************************************************************************************************************) Theorem KRSimplifySound_CallWithSign: forall e, KRExprDenote_CallWithSign (KRSimplify_CallWithSign e) = KRExprDenote_CallWithSign e. Proof. intros. destruct e. reflexivity. Qed. Hint Rewrite KRSimplifySound_CallWithSign : KRSimplify. (************************************************************************************************************) Scheme KRExpr_list_CallWithSign_mut := Induction for KRExpr_list_CallWithSign Sort Prop with KRExpr_list_list_CallWithSign_mut := Induction for KRExpr_list_list_CallWithSign Sort Prop. Ltac KRSimplifySound_setup2 mut H H0 H1 := intros; eapply (mut (fun e : KRExpr_list_CallWithSign => KRExprDenote_list_CallWithSign (KRSimplify_list_CallWithSign e) = KRExprDenote_list_CallWithSign e) (fun e : KRExpr_list_list_CallWithSign => KRExprDenote_list_list_CallWithSign (KRSimplify_list_list_CallWithSign e) = KRExprDenote_list_list_CallWithSign e) ); try (intros);try(autorewrite with KRSimplify); try(autorewrite with KRSimplifyTopSound); try(simpl); try (rewrite H); try (rewrite H0); try (rewrite H1); try(reflexivity);intros. (************************************************************************************************************) Theorem KRSimplifySound_list_CallWithSign: forall e, KRExprDenote_list_CallWithSign (KRSimplify_list_CallWithSign e) = KRExprDenote_list_CallWithSign e. Proof. KRSimplifySound_setup2 KRExpr_list_CallWithSign_mut H H0 H1; repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (autorewrite with KRSimplify); try (rewrite H); try (rewrite H0); try (rewrite H1);try (reflexivity). - rewrite <- H0. repeat KRSimplifySound_unit. - rewrite <- H. repeat KRSimplifySound_unit. - rewrite app_comm_cons. rewrite H. reflexivity. - rewrite <- H0. rewrite app_nil_r. reflexivity. - rewrite <- H0. rewrite app_nil_r. reflexivity. - rewrite <- H0. rewrite app_nil_r. reflexivity. - rewrite <- H. rewrite app_nil_l. reflexivity. - rewrite app_comm_cons. rewrite H. reflexivity. - rewrite <- H0. rewrite app_nil_r. reflexivity. Qed. Hint Rewrite KRSimplifySound_list_CallWithSign : KRSimplify. Theorem KRSimplifySound_list_list_CallWithSign: forall e, KRExprDenote_list_list_CallWithSign (KRSimplify_list_list_CallWithSign e) = KRExprDenote_list_list_CallWithSign e. Proof. KRSimplifySound_setup2 KRExpr_list_list_CallWithSign_mut H H0 H1; repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (autorewrite with KRSimplify); try (rewrite H); try (rewrite H0); try (rewrite H1);try (reflexivity). - rewrite <- H0. repeat KRSimplifySound_unit. - rewrite <- H. repeat KRSimplifySound_unit. - rewrite app_comm_cons. rewrite H. reflexivity. - rewrite <- H0. rewrite app_nil_r. reflexivity. Qed. Hint Rewrite KRSimplifySound_list_list_CallWithSign : KRSimplify. (************************************************************************************************************) Theorem KRSimplifySound_list_RegFileBase: forall e, KRExprDenote_list_RegFileBase (KRSimplify_list_RegFileBase e) = KRExprDenote_list_RegFileBase e. Proof. induction e; try (reflexivity). - simpl. autorewrite with KRSimplify. rewrite IHe. reflexivity. - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch. + rewrite <- IHe2. rewrite app_nil_r. reflexivity. + rewrite IHe2. reflexivity. + rewrite IHe2. reflexivity. + rewrite <- IHe1. rewrite app_nil_l. apply IHe2. + rewrite app_comm_cons. rewrite IHe1. rewrite IHe2. reflexivity. + rewrite IHe1. reflexivity. + rewrite <- IHe2. rewrite IHe1. rewrite app_nil_r. reflexivity. + rewrite IHe1. rewrite IHe2. reflexivity. + rewrite IHe2. rewrite IHe1. reflexivity. Qed. Hint Rewrite KRSimplifySound_list_RegFileBase : KRSimplify. (************************************************************************************************************) Scheme KRExpr_list_RegInitT_mut := Induction for KRExpr_list_RegInitT Sort Prop with KRExpr_list_list_RegInitT_mut := Induction for KRExpr_list_list_RegInitT Sort Prop with KRExpr_BaseModule_mut := Induction for KRExpr_BaseModule Sort Prop with KRExpr_Mod_mut := Induction for KRExpr_Mod Sort Prop with KRExpr_list_ModuleElt_mut := Induction for KRExpr_list_ModuleElt Sort Prop with KRExpr_list_list_ModuleElt_mut := Induction for KRExpr_list_list_ModuleElt Sort Prop with KRExpr_list_Mod_mut := Induction for KRExpr_list_Mod Sort Prop with KRExpr_list_DefMethT_mut := Induction for KRExpr_list_DefMethT Sort Prop with KRExpr_list_list_DefMethT_mut := Induction for KRExpr_list_list_DefMethT Sort Prop with KRExpr_list_Rule_mut := Induction for KRExpr_list_Rule Sort Prop with KRExpr_list_list_Rule_mut := Induction for KRExpr_list_list_Rule Sort Prop. Ltac KRSimplifySound_setup3 mut H H0 H1 := intros; eapply (mut (fun e : KRExpr_list_RegInitT => KRExprDenote_list_RegInitT (KRSimplify_list_RegInitT e) = KRExprDenote_list_RegInitT e) (fun e : KRExpr_list_list_RegInitT => KRExprDenote_list_list_RegInitT (KRSimplify_list_list_RegInitT e) = KRExprDenote_list_list_RegInitT e) (fun e : KRExpr_BaseModule => KRExprDenote_BaseModule (KRSimplify_BaseModule e) = KRExprDenote_BaseModule e) (fun e : KRExpr_Mod => KRExprDenote_Mod (KRSimplify_Mod e) = KRExprDenote_Mod e) (fun e : KRExpr_list_ModuleElt => KRExprDenote_list_ModuleElt (KRSimplify_list_ModuleElt e) = KRExprDenote_list_ModuleElt e) (fun e : KRExpr_list_list_ModuleElt => KRExprDenote_list_list_ModuleElt (KRSimplify_list_list_ModuleElt e) = KRExprDenote_list_list_ModuleElt e) (fun e : KRExpr_list_Mod => KRExprDenote_list_Mod (KRSimplify_list_Mod e) = KRExprDenote_list_Mod e) (fun e : KRExpr_list_DefMethT => KRExprDenote_list_DefMethT (KRSimplify_list_DefMethT e) = KRExprDenote_list_DefMethT e) (fun e : KRExpr_list_list_DefMethT => KRExprDenote_list_list_DefMethT (KRSimplify_list_list_DefMethT e) = KRExprDenote_list_list_DefMethT e) (fun e : KRExpr_list_Rule => KRExprDenote_list_Rule (KRSimplify_list_Rule e) = KRExprDenote_list_Rule e) (fun e : KRExpr_list_list_Rule => KRExprDenote_list_list_Rule (KRSimplify_list_list_Rule e) = KRExprDenote_list_list_Rule e) ); try (intros);try(autorewrite with KRSimplify); try(autorewrite with KRSimplifyTopSound); try(simpl); try (rewrite H); try (rewrite H0); try (rewrite H1); try(reflexivity);intros. (************************************************************************************************************) Theorem KRSimplifySound_list_RegInitT: forall e, KRExprDenote_list_RegInitT (KRSimplify_list_RegInitT e) = KRExprDenote_list_RegInitT e. Proof. KRSimplifySound_setup3 KRExpr_list_RegInitT_mut H H0 H1; repeat KRSimplifySound_unit. - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H); try (simpl); try (autorewrite with kami_rewrite_db); try (reflexivity). - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H0); try (rewrite <- H); try (autorewrite with kami_rewrite_db); try (reflexivity). - repeat KRSimplifySound_crunch; try (rewrite <- H); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. Qed. Hint Rewrite KRSimplifySound_list_RegInitT : KRSimplify. Theorem KRSimplifySound_list_list_RegInitT: forall e, KRExprDenote_list_list_RegInitT (KRSimplify_list_list_RegInitT e) = KRExprDenote_list_list_RegInitT e. Proof. KRSimplifySound_setup3 KRExpr_list_list_RegInitT_mut H H0 H1. repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. reflexivity. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. reflexivity. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. Qed. Hint Rewrite KRSimplifySound_list_list_RegInitT : KRSimplify. Theorem KRSimplifySound_list_Rule: forall e, KRExprDenote_list_Rule (KRSimplify_list_Rule e) = KRExprDenote_list_Rule e. Proof. KRSimplifySound_setup3 KRExpr_list_Rule_mut H H0 H1; repeat KRSimplifySound_unit. - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H); try (simpl); try (autorewrite with kami_rewrite_db); try (reflexivity). - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H0); try (rewrite <- H); try (autorewrite with kami_rewrite_db); try (reflexivity). - repeat KRSimplifySound_crunch; try (rewrite <- H); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. Qed. Hint Rewrite KRSimplifySound_list_Rule : KRSimplify. Theorem KRSimplifySound_list_list_Rule: forall e, KRExprDenote_list_list_Rule (KRSimplify_list_list_Rule e) = KRExprDenote_list_list_Rule e. Proof. KRSimplifySound_setup3 KRExpr_list_list_Rule_mut H H0 H1. repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. reflexivity. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. Qed. Hint Rewrite KRSimplifySound_list_list_Rule : KRSimplify. Theorem KRSimplifySound_list_list_DefMethT: forall e, KRExprDenote_list_list_DefMethT (KRSimplify_list_list_DefMethT e) = KRExprDenote_list_list_DefMethT e. Proof. KRSimplifySound_setup3 KRExpr_list_list_DefMethT_mut H H0 H1. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. reflexivity. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. + autorewrite with KRSimplify in HeqH. inversion HeqH; subst; clear HeqH. Qed. Hint Rewrite KRSimplifySound_list_list_DefMethT : KRSimplify. Theorem KRSimplifySound_list_DefMethT: forall e, KRExprDenote_list_DefMethT (KRSimplify_list_DefMethT e) = KRExprDenote_list_DefMethT e. Proof. KRSimplifySound_setup3 KRExpr_list_DefMethT_mut H H0 H1; repeat KRSimplifySound_unit. - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H); try (simpl); try (autorewrite with kami_rewrite_db); try (reflexivity). - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H0); try (rewrite <- H); try (autorewrite with kami_rewrite_db); try (reflexivity). - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H0); try (rewrite <- H); try (autorewrite with kami_rewrite_db); try (reflexivity). Qed. Hint Rewrite KRSimplifySound_list_DefMethT : KRSimplify. Theorem KRSimplifySound_list_ModuleElt: forall e, KRExprDenote_list_ModuleElt (KRSimplify_list_ModuleElt e) = KRExprDenote_list_ModuleElt e. Proof. KRSimplifySound_setup3 KRExpr_list_ModuleElt_mut H H0 H1; repeat KRSimplifySound_unit. - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H); try (simpl); try (autorewrite with kami_rewrite_db); try (reflexivity). - repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H0); try (rewrite <- H); try (autorewrite with kami_rewrite_db); try (reflexivity). Qed. Hint Rewrite KRSimplifySound_list_ModuleElt : KRSimplify. Theorem KRSimplifySound_list_list_ModuleElt: forall e, KRExprDenote_list_list_ModuleElt (KRSimplify_list_list_ModuleElt e) = KRExprDenote_list_list_ModuleElt e. Proof. KRSimplifySound_setup3 KRExpr_list_list_ModuleElt_mut H H0 H1. - repeat KRSimplifySound_crunch; try (rewrite <- H); try (rewrite <- H0); repeat KRSimplifySound_unit. Qed. Hint Rewrite KRSimplifySound_list_list_ModuleElt : KRSimplify. Theorem KRSimplifySound_BaseModule: forall e, KRExprDenote_BaseModule (KRSimplify_BaseModule e) = KRExprDenote_BaseModule e. Proof. KRSimplifySound_setup3 KRExpr_BaseModule_mut H H0 H1; repeat KRSimplifySound_unit. repeat KRSimplifySound_crunch; try (rewrite <- H0); try (rewrite <- H); try (autorewrite with kami_rewrite_db); try (reflexivity). Qed. Hint Rewrite KRSimplifySound_BaseModule : KRSimplify. Theorem KRSimplifySound_Mod: forall e, KRExprDenote_Mod (KRSimplify_Mod e) = KRExprDenote_Mod e. Proof. KRSimplifySound_setup3 KRExpr_Mod_mut H H0 H1; repeat KRSimplifySound_unit; repeat KRSimplifySound_crunch; try (rewrite <- H0); try (rewrite <- H); try (autorewrite with kami_rewrite_db); try (reflexivity). Qed. Hint Rewrite KRSimplifySound_Mod : KRSimplify. Theorem KRSimplifySound_list_Mod: forall e, KRExprDenote_list_Mod (KRSimplify_list_Mod e) = KRExprDenote_list_Mod e. Proof. KRSimplifySound_setup3 KRExpr_list_Mod_mut H H0 H1; repeat KRSimplifySound_unit. repeat KRSimplifySound_crunch; try (rewrite <- H0); try (rewrite <- H); try (autorewrite with kami_rewrite_db); try (reflexivity). Qed. Hint Rewrite KRSimplifySound_list_Mod : KRSimplify. Theorem KRSimplifySound_RegFileBase: forall e, KRExprDenote_RegFileBase (KRSimplify_RegFileBase e) = KRExprDenote_RegFileBase e. Proof. intros. destruct e. reflexivity. Qed. Hint Rewrite KRSimplifySound_RegFileBase : KRSimplify. ================================================ FILE: Rewrites/ReflectionSoundTheorems2.v ================================================ Require Import Kami.Notations. Require Import Kami.Syntax. Require Import List. Require Import Kami.Rewrites.Notations_rewrites. Require Import Program.Equality. Require Import Kami.Rewrites.ReflectionPre. Require Import Kami.Rewrites.ReflectionSoundTopTheorems. Require Import Kami.Rewrites.ReflectionSoundTheorems1. (************************************************************************************************************) Scheme KRExpr_list_string_mut := Induction for KRExpr_list_string Sort Prop with KRExpr_list_list_string_mut := Induction for KRExpr_list_list_string Sort Prop. Ltac KRSimplifySound_setup3 mut H H0 H1 := intros; eapply (mut (fun e : KRExpr_list_string => KRExprDenote_list_string (KRSimplify_list_string e) = KRExprDenote_list_string e) (fun e : KRExpr_list_list_string => KRExprDenote_list_list_string (KRSimplify_list_list_string e) = KRExprDenote_list_list_string e) ); try (try (intros);try(autorewrite with KRSimplify); try(autorewrite with KRSimplifyTopSound); try(simpl); try (rewrite H); try (rewrite H0); try (rewrite H1); reflexivity). (************************************************************************************************************) Theorem KRSimplify_list_string_KRApp_list_string: forall f r, KRSimplify_list_string (KRApp_list_string f r)= KRSimplifyTop_list_string (KRApp_list_string (KRSimplify_list_string f) (KRSimplify_list_string r)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_string_KRApp_list_string : KRSimplify. Theorem KRSimplify_list_string_KRgetCallsPerMod: forall m, KRSimplify_list_string(KRgetCallsPerMod m)= KRSimplifyTop_list_string(KRgetCallsPerMod (KRSimplify_Mod m)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_string_KRgetCallsPerMod : KRSimplify. Theorem KRSimplify_list_string_KRmap_RegInitT_string: forall f l, KRSimplify_list_string (KRmap_RegInitT_string f l)= KRSimplifyTop_list_string (KRmap_RegInitT_string (KRSimplify_RegInitT_string_Func f) (KRSimplify_list_RegInitT l)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_string_KRmap_RegInitT_string : KRSimplify. Theorem KRSimplify_list_string_KRmap_Rule_string: forall f l, KRSimplify_list_string (KRmap_Rule_string f l)= KRSimplifyTop_list_string (KRmap_Rule_string (KRSimplify_Rule_string_Func f) (KRSimplify_list_Rule l)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_string_KRmap_Rule_string : KRSimplify. Theorem KRSimplify_list_string_KRmap_DefMethT_string: forall f l, KRSimplify_list_string (KRmap_DefMethT_string f l)= KRSimplifyTop_list_string (KRmap_DefMethT_string (KRSimplify_DefMethT_string_Func f) (KRSimplify_list_DefMethT l)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_string_KRmap_DefMethT_string : KRSimplify. Theorem KRSimplify_list_list_string_KRCons_list_list_string: forall f r, KRSimplify_list_list_string (KRCons_list_list_string f r)= KRSimplifyTop_list_list_string (KRCons_list_list_string (KRSimplify_list_string f) (KRSimplify_list_list_string r)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_list_string_KRCons_list_list_string : KRSimplify. Theorem KRSimplify_list_list_string_KRApp_list_list_string: forall f r, KRSimplify_list_list_string (KRApp_list_list_string f r)= KRSimplifyTop_list_list_string (KRApp_list_list_string (KRSimplify_list_list_string f) (KRSimplify_list_list_string r)). Proof. reflexivity. Qed. Hint Rewrite KRSimplify_list_list_string_KRApp_list_list_string : KRSimplify. Theorem KRSimplifySound_list_string: forall e, KRExprDenote_list_string (KRSimplify_list_string e) = KRExprDenote_list_string e. Proof. eapply (KRExpr_list_string_mut (fun e : KRExpr_list_string => KRExprDenote_list_string (KRSimplify_list_string e) = KRExprDenote_list_string e) (fun e : KRExpr_list_list_string => KRExprDenote_list_list_string (KRSimplify_list_list_string e) = KRExprDenote_list_list_string e) ); try (intros; autorewrite with KRSimplify;simpl;try(f_equal);autorewrite with KRSimplify;try (apply H);try (apply H0);reflexivity). Qed. Hint Rewrite KRSimplifySound_list_string : KRSimplify. Theorem KRSimplifySound_list_list_string: forall e, KRExprDenote_list_list_string (KRSimplify_list_list_string e) = KRExprDenote_list_list_string e. Proof. eapply (KRExpr_list_list_string_mut (fun e : KRExpr_list_string => KRExprDenote_list_string (KRSimplify_list_string e) = KRExprDenote_list_string e) (fun e : KRExpr_list_list_string => KRExprDenote_list_list_string (KRSimplify_list_list_string e) = KRExprDenote_list_list_string e) ); try (intros; autorewrite with KRSimplify;simpl;try(f_equal);autorewrite with KRSimplify;try (apply H);try (apply H0);reflexivity). Qed. Hint Rewrite KRSimplifySound_list_list_string : KRSimplify. ================================================ FILE: Rewrites/ReflectionSoundTopTheorems.v ================================================ Require Import Kami.Notations. Require Import Kami.Syntax. Require Import List. Require Import Kami.Rewrites.Notations_rewrites. Require Import Program.Equality. Require Import Kami.Rewrites.ReflectionPre. Theorem KRSimplifyTopSound_RegInitT: forall e, KRExprDenote_RegInitT (KRSimplifyTop_RegInitT e)=KRExprDenote_RegInitT e. Proof. solve_KRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_RegInitT : KRSimplify. Theorem KRSimplifyTopSound_Rule: forall e, KRExprDenote_Rule (KRSimplifyTop_Rule e)=KRExprDenote_Rule e. Proof. solve_KRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_Rule : KRSimplify. Theorem KRSimplifyTopSound_DefMethT: forall e, KRExprDenote_DefMethT (KRSimplifyTop_DefMethT e)=KRExprDenote_DefMethT e. Proof. solve_KRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_DefMethT : KRSimplify. Theorem KRSimplifyTopSound_ModuleElt: forall e, KRExprDenote_ModuleElt (KRSimplifyTop_ModuleElt e)=KRExprDenote_ModuleElt e. Proof. solve_KRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_ModuleElt : KRSimplify. Theorem KRSimplifyTopSound_list_RegInitT: forall e, KRExprDenote_list_RegInitT (KRSimplifyTop_list_RegInitT e)=KRExprDenote_list_RegInitT e. Proof. solve_KRSimplifyTopSound;solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_RegInitT : KRSimplify. Theorem KRSimplifyTopSound_list_list_RegInitT: forall e, KRExprDenote_list_list_RegInitT (KRSimplifyTop_list_list_RegInitT e)=KRExprDenote_list_list_RegInitT e. Proof. solve_KRSimplifyTopSound;solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_list_RegInitT : KRSimplify. Theorem KRSimplifyTopSound_list_Rule: forall e, KRExprDenote_list_Rule (KRSimplifyTop_list_Rule e)=KRExprDenote_list_Rule e. Proof. solve_KRSimplifyTopSound;solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_Rule : KRSimplify. Theorem KRSimplifyTopSound_list_list_Rule: forall e, KRExprDenote_list_list_Rule (KRSimplifyTop_list_list_Rule e)=KRExprDenote_list_list_Rule e. Proof. solve_KRSimplifyTopSound;solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_list_Rule : KRSimplify. Theorem KRSimplifyTopSound_list_DefMethT: forall e, KRExprDenote_list_DefMethT (KRSimplifyTop_list_DefMethT e)=KRExprDenote_list_DefMethT e. Proof. solve_KRSimplifyTopSound;solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_DefMethT : KRSimplify. Theorem KRSimplifyTopSound_list_ModuleElt: forall e, KRExprDenote_list_ModuleElt (KRSimplifyTop_list_ModuleElt e)=KRExprDenote_list_ModuleElt e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_ModuleElt : KRSimplify. Theorem KRSimplifyTopSound_list_list_ModuleElt: forall e, KRExprDenote_list_list_ModuleElt (KRSimplifyTop_list_list_ModuleElt e)=KRExprDenote_list_list_ModuleElt e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_list_ModuleElt : KRSimplify. Theorem KRSimplifyTopSound_string: forall e, KRExprDenote_string (KRSimplifyTop_string e)=KRExprDenote_string e. Proof. solve_KRSimplifyTopSound;solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_string : KRSimplify. Theorem KRSimplifyTopSound_list_string: forall e, KRExprDenote_list_string (KRSimplifyTop_list_string e)=KRExprDenote_list_string e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_string : KRSimplify. Theorem KRSimplifyTopSound_list_list_string: forall e, KRExprDenote_list_list_string (KRSimplifyTop_list_list_string e)=KRExprDenote_list_list_string e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_list_string : KRSimplify. Theorem KRSimplifyTopSound_BaseModule: forall e, KRExprDenote_BaseModule (KRSimplifyTop_BaseModule e)=KRExprDenote_BaseModule e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_BaseModule : KRSimplify. Theorem KRSimplifyTopSound_Mod: forall e, KRExprDenote_Mod (KRSimplifyTop_Mod e)=KRExprDenote_Mod e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_Mod : KRSimplify. Theorem KRSimplifyTopSound_list_Mod: forall e, KRExprDenote_list_Mod (KRSimplifyTop_list_Mod e)=KRExprDenote_list_Mod e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_Mod : KRSimplify. Theorem KRSimplifyTopSound_RegFileBase: forall e, KRExprDenote_RegFileBase (KRSimplifyTop_RegFileBase e)=KRExprDenote_RegFileBase e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_RegFileBase : KRSimplify. Theorem KRSimplifyTopSound_list_RegFileBase: forall e, KRExprDenote_list_RegFileBase (KRSimplifyTop_list_RegFileBase e)=KRExprDenote_list_RegFileBase e. Proof. solve_KRSimplifyTopSound; solve_KRSimplifyTopSound; repeat solve_contKRSimplifyTopSound. Qed. Hint Rewrite KRSimplifyTopSound_list_RegFileBase : KRSimplify. ================================================ FILE: SignatureMatch.v ================================================ Require Import Kami.Syntax. Require Import Kami.WfActionT. Inductive SigFailure := | NativeMismatch : SigFailure | SignatureMismatch : string -> SigFailure. Fixpoint SigMatch_ActionT {k} (meths : list DefMethT) (a : ActionT (fun _ => unit) k) : list SigFailure := match a with | MCall meth s e cont => match lookup String.eqb meth meths with | Some (existT s' _) => if Signature_dec s s' then [] else [SignatureMismatch meth] | None => [] end ++ SigMatch_ActionT meths (cont tt) | LetExpr (SyntaxKind k') e cont => SigMatch_ActionT meths (cont tt) | LetExpr (NativeKind k' c) e cont => NativeMismatch :: SigMatch_ActionT meths (cont c) | LetAction k' a cont => SigMatch_ActionT meths a ++ SigMatch_ActionT meths (cont tt) | ReadNondet (SyntaxKind k') cont => SigMatch_ActionT meths (cont tt) | ReadNondet (NativeKind k' c) cont => NativeMismatch :: SigMatch_ActionT meths (cont c) | ReadReg r (SyntaxKind k') cont => SigMatch_ActionT meths (cont tt) | ReadReg r (NativeKind k' c) cont => NativeMismatch :: SigMatch_ActionT meths (cont c) | WriteReg r k' e cont => SigMatch_ActionT meths cont | IfElse b k' atrue afalse cont => SigMatch_ActionT meths atrue ++ SigMatch_ActionT meths afalse ++ SigMatch_ActionT meths (cont tt) | Sys l cont => SigMatch_ActionT meths cont | Return e => [] end. Definition SigMatch_rules (m : Mod) := fold_right (fun rule sigfs => SigMatch_ActionT (getAllMethods m) rule ++ sigfs) nil (map (fun r => snd r _) (getAllRules m)). Definition SigMatch_methods (m : Mod) := fold_right (fun meth sigfs => SigMatch_ActionT (getAllMethods m) (projT2 (action_from_MethodT meth)) ++ sigfs) nil (getAllMethods m). Definition SigMatch_Mod (m : Mod) := SigMatch_rules m ++ SigMatch_methods m. Section Proofs. Section SFDefs. Variable ty : Kind -> Type. Section SFInd. Variable meths : list DefMethT. Inductive SFActionT : forall lret : Kind, ActionT ty lret -> Prop := | SFMCall meth s e lret c : (forall v, SFActionT (c v)) -> (In meth (map fst meths) -> In (meth, s) (getKindAttr meths)) -> @SFActionT lret (MCall meth s e c) | SFLetExpr k (e : Expr ty k) lret c : (forall v, SFActionT (c v)) -> @SFActionT lret (LetExpr e c) | SFLetAction k (a : ActionT ty k) lret c : SFActionT a -> (forall v, SFActionT (c v)) -> @SFActionT lret (LetAction a c) | SFReadNondet k lret c : (forall v, SFActionT (c v)) -> @SFActionT lret (ReadNondet k c) | SFReadReg r k lret c : (forall v, SFActionT (c v)) -> @SFActionT lret (ReadReg r k c) | SFWriteReg r k (e : Expr ty k) lret c : SFActionT c -> @SFActionT lret (WriteReg r e c) | SFIfElse p k (atrue : ActionT ty k) afalse lret c: (forall v, SFActionT (c v)) -> SFActionT atrue -> SFActionT afalse -> @SFActionT lret (IfElse p atrue afalse c) | SFSys ls lret c : SFActionT c -> @SFActionT lret (Sys ls c) | SFReturn lret e : @SFActionT lret (Return e). End SFInd. Definition SFMod (m : Mod) := (forall rule, In rule (getAllRules m) -> SFActionT (getAllMethods m) (snd rule ty)) /\ (forall meth, In meth (getAllMethods m) -> forall v, SFActionT (getAllMethods m) (projT2 (snd meth) ty v)). End SFDefs. Lemma lookup_In' {A : Type}: forall (r : string) (ls : list (string * A)) (a : A), lookup String.eqb r ls = Some a -> In (r, a) ls. Proof. induction ls; intros; unfold lookup in H. - destruct find eqn:G; [|discriminate]. apply find_some in G; dest; inv H0. - destruct find eqn:G; [|discriminate]. apply find_some in G; dest. rewrite String.eqb_eq in H1; subst. inv H; destruct p. destruct H0; subst. + left; reflexivity. + right; simpl; assumption. Qed. Lemma lookup_None {A : Type}: forall (r : string) (ls : list (string * A)), lookup String.eqb r ls = None -> ~In r (map fst ls). Proof. induction ls; intros; unfold lookup in H. - intro P; inv P. - intro P; destruct P. + destruct find eqn:G; [discriminate|]. cbn [find] in G. destruct String.eqb eqn:G0;[discriminate|]. rewrite String.eqb_neq in G0. apply G0; rewrite H0; reflexivity. + cbn [find] in H. destruct String.eqb eqn:G0;[discriminate|]. apply IHls; auto. Qed. Lemma SFActionT_correct : forall lret l (a : ActionT _ lret), SigMatch_ActionT l a = [] -> SFActionT l a. Proof. induction a; intros. - econstructor; intros. + destruct v. inv H0. apply app_eq_nil in H2; dest. apply (H _ H1). + apply app_eq_nil in H0; dest. destruct lookup eqn:G. * destruct s0. destruct Signature_dec; [|discriminate]; subst. apply lookup_In', (in_map (fun x => (fst x, projT1 (snd x)))) in G. assumption. * exfalso. apply lookup_None in G. contradiction. - destruct k; inv H0; econstructor; intros. simpl in v; destruct v; eauto. - inv H0. apply app_eq_nil in H2; dest. econstructor; intros; eauto. destruct v. apply H; assumption. - destruct k; inv H0; econstructor; intros. simpl in v; destruct v; eauto. - destruct k; inv H0; econstructor; intros. simpl in v; destruct v; eauto. - inv H; econstructor; eauto. - inv H0. apply app_eq_nil in H2; dest. apply app_eq_nil in H1; dest. econstructor; intros; eauto. destruct v; eauto. - inv H. econstructor; eauto. - econstructor. Qed. Lemma SFMod_correct m : SigMatch_Mod m = [] -> SFMod (fun _ => unit ) m. Proof. unfold SigMatch_Mod, SigMatch_rules, SigMatch_methods, SFMod; intros. apply app_eq_nil in H; dest. split; intros. + clear H0. induction (getAllRules m);[inv H1|]. simpl in H. apply app_eq_nil in H; dest. destruct H1; subst. * apply SFActionT_correct; assumption. * apply IHl; assumption. + clear H. enough (forall l l', fold_right (fun meth sigfs => SigMatch_ActionT l' (projT2 (action_from_MethodT meth)) ++ sigfs) nil l = nil -> (forall meth, In meth l -> forall v, SFActionT l' (projT2 (snd meth) (fun _ => unit) v))) as P. { apply (P (getAllMethods m) (getAllMethods m)); assumption. } clear; intros. induction l; [inv H0|]. simpl in H. apply app_eq_nil in H; dest. destruct H0; subst. * unfold action_from_MethodT in H. destruct meth, s0; simpl in *. destruct v. apply SFActionT_correct. apply H. * apply IHl; assumption. Qed. End Proofs. ================================================ FILE: Simulator/CoqSim/Eval.v ================================================ Require Import Compare_dec List String Streams FinFun. Import ListNotations Fin2Restrict. Require Import Kami.AllNotations. Require Import Kami.Simulator.CoqSim.Misc. Require Import Kami.Simulator.CoqSim.TransparentProofs. Require Import Kami.Simulator.CoqSim.HaskellTypes. Import Kami.Simulator.CoqSim.HaskellTypes.Notations. Require Import Program. Section Eval. Fixpoint eval_Kind(k : Kind) : Type := match k with | Bool => bool | Bit n => BV n | Struct n ks fs => Tuple (fun i => eval_Kind (ks i)) | Array n k' => Vector n (eval_Kind k') end. Fixpoint eval_KindToType {k : Kind} : eval_Kind k -> type k := match k return (eval_Kind k -> type k) with | Bool => (fun x => x) | Bit n => (fun x => (natToWord n (bv_to_nat x))) | Struct n km sm => (fun x i => eval_KindToType (tup_index i (fun j => eval_Kind (km j)) x)) | Array n k' => (fun x i => eval_KindToType (vector_index i x)) end. Fixpoint eval_KindFromType {k : Kind} : type k -> eval_Kind k := match k return (type k -> eval_Kind k) with | Bool => (fun x => x) | Bit n => (fun x => nat_to_bv (wordToNat x)) | Struct n km sm => (fun x => mkTup (fun i => eval_Kind (km i)) (fun j => eval_KindFromType (x j))) | Array n k' => (fun x => make_vector (fun i => eval_KindFromType (x i))) end. Definition print_BF(bf : BitFormat){n} : BV n -> string := match bf with | Binary => print_bv_bin | Decimal => print_bv_dec | Hex => print_bv_hex end. Fixpoint print_Val(k : Kind)(ff : FullFormat k) : eval_Kind k -> string := match ff with | FBool n _ => fun x => pad_with " " n (if x then "1" else "0") | FBit n m bf => fun x => pad_with "0" m (print_BF bf x) | FStruct n fk fs ffs => fun x => ("{ " ++ String.concat "; " (v_to_list (vmap (fun '(str1,str2) => str1 ++ ":" ++ str2) (add_strings fs (tup_to_vec _ (fun i => print_Val (ffs i)) x)))) ++ "; }")%string | FArray n k' ff' => fun x => ("[" ++ String.concat "; " (List.map (fun i => natToDecStr (f2n i) ++ "=" ++ print_Val ff' (vector_index i x)) (getFins n)) ++ "; ]")%string end. (* for checkpointing *) Fixpoint print_Val2(k : Kind)(ff : FullFormat k) : eval_Kind k -> string := match ff with | FBool n _ => fun x => pad_with " " n (if x then "tt" else "ff") | FBit n m bf => fun x => pad_with "0" m (print_BF bf x) | FStruct n fk fs ffs => fun x => (("{ " ++ String.concat " ; " (v_to_list ((tup_to_vec _ (fun i => print_Val2 (ffs i)) x)))) ++ " }")%string | FArray n k' ff' => fun x => ("[ " ++ String.concat " ; " (List.map (fun i => print_Val2 ff' (vector_index i x)) (getFins n)) ++ " ]")%string end. Fixpoint Kind_eq{k} : eval_Kind k -> eval_Kind k -> bool := match k return eval_Kind k -> eval_Kind k -> bool with | Bool => Bool.eqb | Bit n => bv_eq | Struct n ks fs => TupEq (fun i => eval_Kind (ks i)) (fun i => @Kind_eq (ks i)) | Array n k' => vector_eq (@Kind_eq k') end. Definition eval_FK(k : FullKind) := match k with | SyntaxKind k' => eval_Kind k' | NativeKind t _ => t end. Fixpoint default_val(k : Kind) : eval_Kind k := match k return eval_Kind k with | Bool => false | Bit n => nat_to_bv 0 | Struct n ks fs => mkTup (fun i => eval_Kind (ks i)) (fun i => default_val (ks i)) | Array n k' => make_vector (fun _ => default_val k') end. Definition default_val_FK(k : FullKind) : eval_FK k := match k with | SyntaxKind k' => default_val k' | NativeKind T t => t end. Fixpoint rand_tuple{n} : forall ts : Fin.t n -> Type, (forall i, IO (ts i)) -> IO (Tuple ts) := match n with | 0 => fun _ _ => ret tt | S m => fun ts mxs => ( do x <- mxs Fin.F1; do xs <- rand_tuple (fun j => ts (Fin.FS j)) (fun j => mxs (Fin.FS j)); ret (x,xs) ) end. Fixpoint rand_val(k : Kind) : IO (eval_Kind k) := match k return IO (eval_Kind k) with | Bool => rand_bool | Bit n => rand_bv n | Struct n ks fs => rand_tuple (fun i => eval_Kind (ks i)) (fun i => rand_val (ks i)) | Array n k' => rand_vector (rand_val k') end. Fixpoint rand_val_FK(k : FullKind) : IO (eval_FK k) := match k with | SyntaxKind k' => rand_val k' | NativeKind k' c => ret c end. Definition eval_UniBool(op : UniBoolOp) : bool -> bool := match op with | Neg => negb end. Definition eval_CABool(op : CABoolOp) : list bool -> bool := match op with | And => fun xs => fold_left andb xs true | Xor => fun xs => fold_left xorb xs false end. Definition eval_UniBit{m n}(op : UniBitOp m n) : BV m -> BV n := match op with | Inv n => bv_inv | TruncLsb lsb msb => bv_trunc_lsb | TruncMsb lsb msb => bv_trunc_msb | UAnd n => bv_uand | UOr n => bv_uor | UXor n => bv_uxor end. Definition eval_BinBit{m n p}(op : BinBitOp m n p) : BV m -> BV n -> BV p := match op with | Sub n => bv_sub | Div n => bv_div | Rem n => bv_rem | Sll n m => bv_sll | Srl n m => bv_srl | Sra n m => bv_sra | Concat msb lsb => bv_concat end. Definition eval_CABit{n}(op : CABitOp) : list (BV n) -> BV n := match op with | Add => bv_add | Mul => bv_mul | Band => bv_band | Bxor => bv_bxor end. Definition eval_BinBitBool{m n}(op : BinBitBoolOp m n) : BV m -> BV n -> bool := match op with | LessThan n => bv_lt end. Fixpoint eval_ConstT{k}(e : ConstT k) : eval_Kind k := match e with | ConstBool b => b | ConstBit n w => nat_to_bv (wordToNat w) | ConstStruct n ks ss es => mkTup (fun i => eval_Kind (ks i)) (fun i => eval_ConstT (es i)) | ConstArray n k' es => make_vector (fun i => eval_ConstT (es i)) end. Definition eval_ConstFullT{k} (e : ConstFullT k) : eval_FK k := match e with | SyntaxConst k' c' => eval_ConstT c' | NativeConst t c' => c' end. Fixpoint val_or (k : Kind) : eval_Kind k -> eval_Kind k -> eval_Kind k := match k in Kind return (eval_Kind k -> eval_Kind k -> eval_Kind k) with | Bool => orb | Bit n => fun b1 b2 => bv_bor [b1 ; b2] | Array n k' => fun a1 a2 => make_vector (fun i => val_or k' (vector_index i a1) (vector_index i a2)) | Struct n ks _ => fun t1 t2 => mkTup _ (fun i => val_or (ks i) (tup_index i _ t1) (tup_index i _ t2)) end. Fixpoint eval_Expr{k}(e : Expr eval_Kind k) : eval_FK k := match e with | Var _ v => v | Const _ v => eval_ConstT v | UniBool op e => eval_UniBool op (eval_Expr e) | CABool op es => eval_CABool op (List.map eval_Expr es) | UniBit m n op e => eval_UniBit op (eval_Expr e) | BinBit m n p op e1 e2 => eval_BinBit op (eval_Expr e1) (eval_Expr e2) | CABit n op es => eval_CABit op (List.map eval_Expr es) | BinBitBool m n op e1 e2 => eval_BinBitBool op (eval_Expr e1) (eval_Expr e2) | ITE _ p e1 e2 => eval_Expr (if eval_Expr p then e1 else e2) | Eq _ e1 e2 => Kind_eq (eval_Expr e1) (eval_Expr e2) | ReadStruct n ks ss e i => tup_index i _ (eval_Expr e) | BuildStruct n ks ss es => mkTup _ (fun i => eval_Expr (es i)) | ReadArray n m k v i => match lt_dec (bv_to_nat (eval_Expr i)) n with | left pf => vector_index (Fin.of_nat_lt pf) (eval_Expr v) | right _ => eval_ConstT (getDefaultConst k) end | ReadArrayConst n k v i => vector_index i (eval_Expr v) | BuildArray n k v => make_vector (fun i => eval_Expr (v i)) | Kor k es => fold_right (val_or k) (default_val k) (map eval_Expr es) | @ToNative _ k' e' => eval_KindToType (eval_Expr e') | @FromNative _ k' e' => eval_KindFromType (eval_Expr e') end. Fixpoint get_chunk_struct{n} : forall (f : Fin.t n -> nat)(v : BV (sumSizes f))(i : Fin.t n), BV (f i) := match n with | 0 => fun f _ i => case0 (fun j => BV (f j)) i | _ => fun f v i => fin_case _ (fun j => BV (f j)) (bv_trunc_msb v) (fun j => get_chunk_struct (fun k => f (FS k)) (bv_trunc_lsb v) j) end. Fixpoint get_chunk_array{n} : forall (k : nat)(v : BV (n * k))(i : Fin.t n), BV k. refine match n with | 0 => fun _ _ i => case0 _ i | S m => fun k v i => _ end. Proof. dependent destruction i. - exact (bv_trunc_lsb v). - exact (get_chunk_array _ _ (bv_trunc_msb v) i). Defined. Fixpoint val_unpack(k : Kind) : BV (size k) -> eval_Kind k := match k return BV (size k) -> eval_Kind k with | Bool => fun e => bv_eq e (nat_to_bv 1) | Bit n => fun e => e | Struct n ks fs => fun e => Tup_map _ _ (fun i => val_unpack (ks i)) (mkTup (fun i => BV (size (ks i))) (get_chunk_struct (fun i => size (ks i)) e)) | Array n k => fun e => vector_map (val_unpack k) (make_vector (get_chunk_array _ e)) end. (* Definition val_unpack(k : Kind) : BV (size k) -> eval_Kind k := fun w => eval_Expr (unpack _ (Const _ (ConstBit (natToWord _ (bv_to_nat w))))). *) Definition eval_SysT(s : SysT eval_Kind) : IO unit := match s with | DispString s => print s | DispExpr k e ff => print (print_Val ff (eval_Expr e)) | Finish => exit end. Fixpoint eval_list_SysT(xs : list (SysT eval_Kind)) : IO unit := match xs with | [] => ret tt | s::ys => ( do _ <- eval_SysT s; eval_list_SysT ys ) end. End Eval. ================================================ FILE: Simulator/CoqSim/HaskellTypes.v ================================================ Require Extraction. Require Import String Fin. Require Import Kami.All. Require Import Kami.Simulator.CoqSim.Misc. Extraction Language Haskell. (* We postulate Haskell's more efficient datatypes and extract them *) (* Maps with string keys *) Parameter Map : Type -> Type. Parameter empty : forall {V}, Map V. Parameter map_lookup : forall {V}, string -> Map V -> option V. Parameter insert : forall {V}, string -> V -> Map V -> Map V. Parameter map_of_list : forall {V}, list (string * V) -> Map V. Axiom empty_lookup : forall V x, map_lookup x (empty : Map V) = None. Axiom map_of_list_lookup : forall V x (ps : list (string * V)), map_lookup x (map_of_list ps) = lookup String.eqb x ps. Axiom insert_lookup_hit : forall V x (v : V) m, map_lookup x (insert x v m) = Some v. Axiom insert_lookup_miss : forall V x x' (v : V) m, x <> x' -> map_lookup x' (insert x v m) = map_lookup x' m. Extract Constant Map "v" => "Data.Map.Strict.Map Prelude.String v". Extract Constant empty => "Data.Map.Strict.empty". Extract Constant map_lookup => "Data.Map.Strict.lookup". Extract Constant insert => "Data.Map.Strict.insert". Extract Constant map_of_list => "Data.Map.Strict.fromList". (* Vectors *) Parameter Vector : nat -> Type -> Type. Parameter vector_index : forall {X n}, Fin.t n -> Vector n X -> X. Parameter vector_map : forall {X Y n}, (X -> Y) -> Vector n X -> Vector n Y. Parameter vector_eq : forall {X n}, (X -> X -> bool) -> Vector n X -> Vector n X -> bool. Parameter vector_to_list : forall {X n}, Vector n X -> list X. Parameter make_vector : forall {X n}, (Fin.t n -> X) -> Vector n X. Parameter vector_slice : forall {X n} (i m : nat), Vector n X -> Vector m X. Parameter vector_updates : forall {X n}, Vector n X -> list (nat * X) -> Vector n X. Fixpoint Fin_to_list{X n} : (Fin.t n -> X) -> list X := match n with | 0 => fun _ => nil | S m => fun f => cons (f Fin.F1) (Fin_to_list (fun i => f (Fin.FS i))) end. Extract Constant Vector "a" => "Data.Vector.Vector a". Extract Constant vector_index => "(\_ (n,i) v -> v Data.Vector.! i)". Extract Constant vector_map => "(\_ -> Data.Vector.map)". Extract Constant vector_eq => "(\_ eqb v1 v2 -> Data.Vector.foldr (Prelude.&&) Prelude.True (Data.Vector.zipWith eqb v1 v2))". Extract Constant vector_to_list => "(\ _ -> Data.Vector.toList)". Extract Constant make_vector => "(\n f -> Data.Vector.fromList (coq_Fin_to_list n f))". Extract Constant vector_slice => "(\_ i m v -> Data.Vector.slice i m v)". Extract Constant vector_updates => "(\_ -> (Data.Vector.//))". (* BVs *) Parameter BV : nat -> Type. Parameter bv_inv : forall {m}, BV m -> BV m. Parameter bv_trunc_lsb : forall {m n}, BV (m + n) -> BV m. Parameter bv_trunc_msb : forall {m n}, BV (m + n) -> BV n. Parameter bv_uand : forall {m}, BV m -> BV 1. Parameter bv_uor : forall {m}, BV m -> BV 1. Parameter bv_uxor : forall {m}, BV m -> BV 1. Parameter bv_sub : forall {m}, BV m -> BV m -> BV m. Parameter bv_div : forall {m}, BV m -> BV m -> BV m. Parameter bv_rem : forall {m}, BV m -> BV m -> BV m. Parameter bv_sll : forall {m n}, BV m -> BV n -> BV m. Parameter bv_srl : forall {m n}, BV m -> BV n -> BV m. Parameter bv_sra : forall {m n}, BV m -> BV n -> BV m. Parameter bv_concat : forall {m n}, BV m -> BV n -> BV (n + m). Parameter bv_add : forall {m}, list (BV m) -> BV m. Parameter bv_mul : forall {m}, list (BV m) -> BV m. Parameter bv_band : forall {m}, list (BV m) -> BV m. Parameter bv_bor : forall {m}, list (BV m) -> BV m. Parameter bv_bxor : forall {m}, list (BV m) -> BV m. Parameter bv_lt : forall {m}, BV m -> BV m -> bool. Parameter bv_eq : forall {m}, BV m -> BV m -> bool. Parameter bv_to_nat : forall {m}, BV m -> nat. Parameter nat_to_bv : forall {m}, nat -> BV m. Parameter print_bv_bin : forall {m}, BV m -> string. Parameter print_bv_dec : forall {m}, BV m -> string. Parameter print_bv_hex : forall {m}, BV m -> string. Extract Constant BV => "Data.BitVector.BV". Extract Constant bv_inv => "(\_ -> Data.BitVector.not)". Extract Constant bv_trunc_lsb => "(\m _ -> if m Prelude.== 0 then Prelude.const Data.BitVector.nil else Data.BitVector.least m)". Extract Constant bv_trunc_msb => "(\_ n -> if n Prelude.== 0 then Prelude.const Data.BitVector.nil else Data.BitVector.most n)". Extract Constant bv_uand => "(\_ v -> Data.BitVector.fromBool (Data.BitVector.foldr (Prelude.&&) Prelude.True v))". Extract Constant bv_uor => "(\_ v -> Data.BitVector.fromBool (Data.BitVector.foldr (Prelude.||) Prelude.False v))". Extract Constant bv_uxor => "(\_ v -> Data.BitVector.fromBool (Data.BitVector.foldr (Prelude./=) Prelude.False v))". Extract Constant bv_sub => "(\_ -> (Prelude.-))". Extract Constant bv_div => "(\_ -> Prelude.div)". Extract Constant bv_rem => "(\_ -> Prelude.rem)". Extract Constant bv_sll => "(\_ _ -> Data.BitVector.shl)". Extract Constant bv_srl => "(\_ _ -> Data.BitVector.shr)". Extract Constant bv_sra => "(\_ _ -> Data.BitVector.ashr)". Extract Constant bv_concat => "(\_ _ -> (Data.BitVector.#))". Extract Constant bv_add => "(\_ -> Prelude.foldr (Prelude.+) 0)". Extract Constant bv_mul => "(\_ -> Prelude.foldr (Prelude.*) 1)". Extract Constant bv_band => "(\n -> Prelude.foldr (Data.Bits..&.) (Data.BitVector.ones n))". Extract Constant bv_bor => "(\n -> Prelude.foldr (Data.Bits..|.) (Data.BitVector.zeros n))". Extract Constant bv_bxor => "(\n -> Prelude.foldr Data.Bits.xor (Data.BitVector.zeros n))". Extract Constant bv_lt => "(\_ -> (Data.BitVector.<.))". Extract Constant bv_eq => "(\_ -> (Data.BitVector.==.))". Extract Constant bv_to_nat => "(\_ x -> Prelude.fromIntegral (Data.BitVector.nat x))". Extract Inlined Constant nat_to_bv => "Data.BitVector.bitVec". Extract Constant print_bv_bin => "(\_ -> CustomExtract.bv_bin)". Extract Constant print_bv_dec => "(\_ -> CustomExtract.bv_dec)". Extract Constant print_bv_hex => "(\_ -> CustomExtract.bv_hex)". (* IO *) Require Import String. Parameter IO : Type -> Type. Parameter ret : forall {X}, X -> IO X. Parameter bind : forall {X Y}, IO X -> (X -> IO Y) -> IO Y. Parameter error : forall {X}, string -> IO X. Parameter print : string -> IO unit. Parameter rand_bool : IO bool. Parameter rand_bv : forall n, IO (BV n). Parameter rand_vector : forall {X n}, IO X -> IO (Vector n X). Parameter exit : forall {X}, IO X. Extract Constant IO "a" => "Prelude.IO a". Extract Inlined Constant ret => "Prelude.return". Extract Inlined Constant bind => "(GHC.Base.>>=)". Extract Inlined Constant error => "Prelude.error". (*Extract Constant Hprint => "(\str -> (GHC.Base.>>) (Prelude.putStrLn str) (System.IO.hFlush System.IO.stdout))". *) Extract Inlined Constant print => "Prelude.putStr". Extract Constant rand_bool => "Prelude.return Prelude.False". (*FIXME*) Extract Constant rand_bv => "Prelude.undefined". (*FIXME*) Extract Constant rand_vector => "Prelude.undefined". (*FIXME*) Extract Constant exit => "System.Exit.exitSuccess". Module Notations. Notation "'do' x <- y ; cont" := (bind y (fun x => cont)) (at level 20). End Notations. (* Arrays *) Parameter Arr : Type -> Type. Parameter arr_repl : forall {X}, nat -> X -> IO (Arr X). Parameter arr_slice : forall {X} (i m : nat), Arr X -> IO (Vector m X). Parameter arr_updates : forall {X}, Arr X -> list (nat * X) -> IO unit. (* Parameter arr_new : forall {X}, nat -> IO (Array X). *) (** does not work at the moment **) (*Extract Constant HArray "a" => "Data.Array.IO.IOArray Prelude.Int a". Extract Constant Harr_repl => "(\n x -> Data.Array.MArray.newArray (0, n Prelude.- 1) x)". Extract Constant Harr_slice => "(\i m a -> Control.Monad.liftM Data.Vector.fromList (Prelude.sequence (Prelude.map (\j -> Data.Array.MArray.readArray a (j Prelude.+ i)) [0..(m Prelude.- 1)])))". Extract Constant Harr_updates => "(\a ps -> Control.Monad.foldM (\_ (i,e) -> Data.Array.MArray.writeArray a i e) () ps)".*) Extract Constant Arr "a" => "Data.Vector.Mutable.MVector (Control.Monad.Primitive.PrimState Prelude.IO) a". Extract Constant arr_repl => "Data.Vector.Mutable.replicate". Extract Constant arr_slice => "(\i m a -> Data.Vector.Generic.freeze (Data.Vector.Mutable.slice i m a))". Extract Constant arr_updates => "(\a ps -> Control.Monad.foldM (\_ (i,x) -> Data.Vector.Mutable.write a i x) () ps)". ================================================ FILE: Simulator/CoqSim/Misc.v ================================================ Require Import Fin Bool Kami.Lib.EclecticLib String Ascii List Streams. Import ListNotations. Fixpoint Fin n := match n with | 0 => Empty_set | S m => (unit + Fin m)%type end. Section Vector. Fixpoint Vec X n : Type := match n with | 0 => unit | S m => (X * Vec X m)%type end. Fixpoint vec_index{n X} : Fin.t n -> Vec X n -> X := match n with | 0 => case0 _ | S m => fun i v => fin_case i _ (fst v) (fun j => vec_index j (snd v)) end. Fixpoint mkVec{n X} : (Fin.t n -> X) -> Vec X n := match n with | 0 => fun _ => tt | S m => fun f => (f Fin.F1, mkVec (fun j => f (Fin.FS j))) end. Fixpoint VecEq{n X} : (X -> X -> bool) -> Vec X n -> Vec X n -> bool := match n with | 0 => fun _ _ _ => true | S m => fun eq v1 v2 => eq (fst v1) (fst v2) && VecEq eq (snd v1) (snd v2) end. Fixpoint vmap{n X Y}(f : X -> Y) : Vec X n -> Vec Y n := match n with | 0 => fun _ => tt | S m => fun '(x,xs) => (f x, vmap f xs) end. Fixpoint v_to_list{n X} : Vec X n -> list X := match n with | 0 => fun _ => [] | S m => fun '(x,xs) => x::v_to_list xs end. Fixpoint add_indices_aux{n X} : nat -> Vec X n -> Vec (nat * X) n := match n return nat -> Vec X n -> Vec (nat * X) n with | 0 => fun _ _ => tt | S m => fun acc '(x,xs) => ((acc,x), add_indices_aux (S acc) xs) end. Definition add_indices{n X} : Vec X n -> Vec (nat * X) n := add_indices_aux 0. Fixpoint add_strings{n X} : (Fin.t n -> string) -> Vec X n -> Vec (string * X) n := match n return (Fin.t n -> string) -> Vec X n -> Vec (string * X) n with | 0 => fun _ _ => tt | S m => fun strs '(x,xs) => ((strs Fin.F1,x),add_strings (fun j => strs (Fin.FS j)) xs) end. End Vector. Section Tuple. Fixpoint Tuple{n} : (Fin.t n -> Type) -> Type := match n with | 0 => fun _ => unit | S m => fun ts => ((ts Fin.F1) * (Tuple (fun j => ts (Fin.FS j))))%type end. Fixpoint Tup_map{n} : forall (ts1 ts2 : Fin.t n -> Type)(fs : forall i, ts1 i -> ts2 i)(t : Tuple ts1), Tuple ts2 := match n with | 0 => fun _ _ _ _ => tt | S m => fun ts1 ts2 fs t => (fs F1 (fst t), Tup_map (fun i => ts1 (FS i)) (fun i => ts2 (FS i)) (fun i => fs (FS i)) (snd t)) end. Fixpoint tup_index{n} : forall (i : Fin.t n) ts, Tuple ts -> ts i := match n with | 0 => case0 _ | S m => fun i ts t => fin_case i _ (fst t) (fun j => tup_index j (fun j => ts (Fin.FS j)) (snd t)) end. Fixpoint mkTup{n} : forall ts : Fin.t n -> Type, (forall i, ts i) -> Tuple ts := match n with | 0 => fun _ _ => tt | S m => fun ts es => (es Fin.F1, mkTup (fun j => ts (Fin.FS j)) (fun j => es (Fin.FS j))) end. Fixpoint TupEq{n} : forall ts : Fin.t n -> Type, (forall i, ts i -> ts i -> bool) -> Tuple ts -> Tuple ts -> bool := match n with | 0 => fun _ _ _ _ => true | S m => fun ts eqs t1 t2 => eqs Fin.F1 (fst t1) (fst t2) && TupEq (fun j => ts (Fin.FS j)) (fun j => eqs (Fin.FS j)) (snd t1) (snd t2) end. Fixpoint tup_to_vec{n X} : forall (ts : Fin.t n -> Type)(to_X : forall i, ts i -> X), Tuple ts -> Vec X n := match n with | 0 => fun _ _ _ => tt | S m => fun ts to_X '(x,t) => (to_X Fin.F1 x, tup_to_vec (fun j => ts (Fin.FS j)) (fun j => to_X (Fin.FS j)) t) end. End Tuple. Section Lookup. Fixpoint Fin_lookup{X}(pred : X -> bool){n} : (Fin.t n -> X) -> option (Fin.t n) := match n return (Fin.t n -> X) -> option (Fin.t n) with | 0 => fun _ => None | S m => fun f => if pred (f F1) then Some F1 else match Fin_lookup pred (fun j => f (FS j)) with | None => None | Some i => Some (FS i) end end. (* Check lookup. Definition lookup{K X} : (K -> K -> bool) -> K -> list (K * X) -> option X := fun eqbk key pairs => match List.find (fun p => eqbk key (fst p)) pairs with | Some p => Some (snd p) | None => None end. *) End Lookup. Section PrintUtil. Open Scope char_scope. Fixpoint char_replicate(c : ascii)(n : nat) : string := match n with | 0 => EmptyString | S m => String c (char_replicate c m) end. Fixpoint string_drop(n : nat)(str : string) : string := match n with | 0 => str | S m => match str with | EmptyString => EmptyString | String c str' => string_drop m str' end end. Definition pad_with(c : ascii)(n : nat)(str : string) : string := if Nat.ltb (String.length str) n then char_replicate c (n - String.length str) ++ str else string_drop (String.length str - n) str. (* Fixpoint intersperse(x : string)(xs : list string) : list string := match xs with | [] => [] | y::ys => match ys with | [] => xs | z::zs => y::x::intersperse x ys end end. *) End PrintUtil. Section Streams. CoFixpoint unwind_list_aux{X}(xs ys : list X) : ys <> [] -> Stream X := match ys return ys <> [] -> Stream X with | [] => fun pf => match pf eq_refl with end | y::zs => fun pf => match xs with | x::xs' => Cons x (unwind_list_aux xs' (y::zs) pf) | [] => Cons y (unwind_list_aux zs (y::zs) pf) end end. Definition unwind_list{X}(xs : list X) : xs <> [] -> Stream X := unwind_list_aux xs xs. Fixpoint take{X}(n : nat)(xs : Stream X) : list X := match n with | 0 => [] | S m => match xs with | Cons x xs' => x :: take m xs' end end. End Streams. Section Option. Definition o_bind{X Y}(o : option X)(cont : X -> option Y) : option Y := match o with | Some x => cont x | None => None end. Definition o_ret{X}(x : X) : option X := Some x. End Option. Notation "'o_do' x <- y ; cont" := (o_bind y (fun x => cont)) (at level 20). ================================================ FILE: Simulator/CoqSim/RegisterFile.v ================================================ Require Import String. Require Import FinFun. Require Import Kami.AllNotations. Require Import Kami.Syntax. Require Import Kami.Simulator.CoqSim.Misc. Require Import Kami.Simulator.CoqSim.Eval. Require Import Kami.Simulator.CoqSim.HaskellTypes. Import Kami.Simulator.CoqSim.HaskellTypes.Notations. Section RegFile. Definition Val k := eval_Kind k. Definition ValFK k := eval_FK k. Inductive FileCall := | AsyncRead : FileCall | ReadReq : string -> FileCall | ReadResp : string -> FileCall | WriteFC : FileCall. Inductive FileUpd := | IntRegWrite : string -> {k : Kind & Val k} -> FileUpd | ArrWrite : string -> forall k, list (nat * Val k) -> FileUpd. Record RegFile := { file_name : string; is_wr_mask : bool; chunk_size : nat; readers : RegFileReaders; write : string; size : nat; kind : Kind; arr : Arr (Val kind) }. Record FileState := { methods : Map (FileCall * string); int_regs : Map {k : Kind & Val k}; files : Map RegFile; }. Definition empty_state : FileState := {| methods := empty; int_regs := empty; files := empty |}. Definition file_async_read(file : RegFile)(i : nat) : IO (Val (Array (chunk_size file) (kind file))) := arr_slice i _ (arr file). Definition isAddr(file : RegFile) : bool := match readers file with | Sync isAddr _ => isAddr | _ => false end. Definition file_sync_readreq(val : {k : Kind & Val k})(file : RegFile)(regName : string) : IO {k : Kind & Val k}. refine match readers file with | Async _ => error "Async file encountered while Sync file expected." | Sync true _ => if Kind_decb (projT1 val) (Bit (Nat.log2_up (size file))) then ret val else error "Kind mismatch." | Sync false _ => _ end. Proof. (* isAddr = false *) destruct val as [k v]. destruct (Kind_decb k (Bit (Nat.log2_up (size file)))) eqn:Keq. - rewrite Kind_decb_eq in Keq. rewrite Keq in v. exact (do x <- arr_slice (bv_to_nat v) (chunk_size file) (arr file); ret (existT _ (Array (chunk_size file) (kind file)) x)). - exact (error "Kind mismatch"). Defined. Definition file_sync_readresp(state : FileState)(file : RegFile)(regName : string) : IO (Val (Array (chunk_size file) (kind file))). refine match map_lookup regName (int_regs state) with | None => error "register not found." | Some (existT k v) => match readers file with | Async _ => error "Async file encountered while Sync file expected." | Sync true _ => _ | Sync false _ => _ end end. Proof. (* isAddr = true *) - destruct (Kind_decb k (Bit (Nat.log2_up (size file)))) eqn:Keq. * rewrite Kind_decb_eq in Keq. rewrite Keq in v. exact ((arr_slice (bv_to_nat v) (chunk_size file) (arr file))). * exact (error "Kind mismatch."). (* isAddr = false *) - destruct (Kind_decb k (Array (chunk_size file) (kind file))) eqn:Keq. * rewrite Kind_decb_eq in Keq. rewrite Keq in v. exact (ret v). * exact (error "Kind mismatch."). Defined. Definition file_writes_mask(file : RegFile)(i : nat)(mask : Val (Array (chunk_size file) Bool))(vals : Val (Array (chunk_size file) (kind file))) : list (nat * Val (kind file)) := let mask_indices := filter (fun i => vector_index i mask) (getFins _) in map (fun j => (i + Fin2Restrict.f2n j, vector_index j vals)) mask_indices. Definition file_writes_no_mask(file : RegFile)(i : nat)(vals : Val (Array (chunk_size file) (kind file))) : list (nat * Val (kind file)) := map (fun j => (i + Fin2Restrict.f2n j, vector_index j vals)) (getFins _). Definition void_nil : {k : Kind & Val k} := existT _ (Bit 0) (nat_to_bv 0). Definition coerce(v : {k : Kind & Val k})(k : Kind) : IO (Val k). refine match v with | existT k' v' => _ end. Proof. destruct (Kind_dec k k'). * rewrite e. exact (ret v'). * exact (error "Kind mismatch."). Defined. Fixpoint Tup_lookup{n} : forall (i : Fin.t n)(ks : Fin.t n -> Kind), Tuple (fun i => Val (ks i)) -> {k : Kind & Val k} := match n return forall (i : Fin.t n)(ks : Fin.t n -> Kind), Tuple (fun i => Val (ks i)) -> {k : Kind & Val k} with | 0 => fun i => case0 _ i | S m => fun i ks X => fin_case i _ (existT _ (ks F1) (fst X)) (fun j => (Tup_lookup j _ (snd X))) end. Definition rf_methcall(state : FileState)(methName : string)(val : {k : Kind & Val k}) : IO (option (option FileUpd * {k : Kind & Val k})). refine match map_lookup methName (methods state) with | None => ret None | Some (fc, fileName) => match map_lookup fileName (files state) with | None => ret None | Some file => match fc with | AsyncRead => _ | ReadReq regName => (do p <- file_sync_readreq val file regName; ret (Some (Some (IntRegWrite regName p), void_nil))) | ReadResp regName => (do v <- file_sync_readresp state file regName; ret (Some (None, existT _ _ v))) | WriteFC => match is_wr_mask file with | true => _ | false => _ end end end end. Proof. (* AsyncRead *) - destruct val as [k v]. destruct k eqn:G. + exact (ret None). + pose (i := bv_to_nat v). exact (do v <- file_async_read file i; ret (Some (None, existT _ _ v))). + exact (ret None). + exact (ret None). (* WriteFC is_wr_mask = true *) - destruct val as [k v]. destruct k eqn:G. + exact (ret None). + exact (ret None). + destruct n as [|[|[|]]]; [ exact (error "Kind mismatch.") | exact (error "Kind mismatch.") | exact (error "Kind mismatch.") | idtac ]. (* n should be 3 *) exact (let addr := Tup_lookup F1 k0 v in let data_k := Tup_lookup (FS F1) k0 v in let mask := Tup_lookup (FS (FS F1)) k0 v in do addr' <- coerce addr (Bit (Nat.log2_up (size file))); do data' <- coerce data_k (Array (chunk_size file) (kind file)); do mask' <- coerce mask (Array (chunk_size file) Bool); ret (Some (Some (ArrWrite fileName _ (file_writes_mask file (bv_to_nat addr') mask' data')), void_nil))). + exact (ret None). (* WriteFC is_wr_mask = false *) - destruct val as [k v]. destruct k eqn:G. + exact (error "Kind mismatch."). + exact (error "Kind mismatch."). + destruct n as [|[|]]; [ exact (error "Kind mismatch.") | exact (error "Kind mismatch.") | idtac ]. (* n should be 2 *) exact (let addr := Tup_lookup F1 k0 v in let data_k := Tup_lookup (FS F1) k0 v in do addr' <- coerce addr (Bit (Nat.log2_up (size file))); do data' <- coerce data_k (Array (chunk_size file) (kind file)); ret (Some (Some (ArrWrite fileName _ (file_writes_no_mask file (bv_to_nat addr') data')), void_nil))). + exact (error "Kind mismatch."). Defined. Definition exec_file_update(u : FileUpd)(state : FileState) : IO FileState. refine match u with | IntRegWrite regName v => ret {| methods := methods state; int_regs := insert regName v (int_regs state); files := files state |} | ArrWrite fileName k upds => match map_lookup fileName (files state) with | None => error "File not found." | Some file => match Kind_dec k (kind file) with | left pf => do _ <- arr_updates (arr file) _; ret state | _ => error "Kind mismatch." end end end. Proof. rewrite pf in upds. exact upds. Defined. Fixpoint fold_right_m{A B}(f : B -> A -> IO A)(a : A)(bs : list B) : IO A := match bs with | [] => ret a | b::bs' => do x <- f b a; fold_right_m f x bs' end. Definition exec_file_updates := fold_right_m exec_file_update. Axiom parseFile : forall (size idxNum : nat)(filepath : string), IO (list (nat * BV size)). Definition initialize_file(args : list (string * string))(rfb : RegFileBase)(state : FileState) : IO FileState := let array := match rfInit rfb with | RFNonFile None => arr_repl (rfIdxNum rfb) (default_val (rfData rfb)) | RFNonFile (Some c) => arr_repl (rfIdxNum rfb) (eval_ConstT c) | RFFile isAscii isArg file _ _ _ => let filepath := if isArg then match lookup String.eqb file args with | Some fp => ret fp | None => error ("File " ++ file ++ " not found!") end else ret file in (do path <- filepath; do pairs <- parseFile (Syntax.size (rfData rfb)) (rfIdxNum rfb) path; do arr <- arr_repl (rfIdxNum rfb) (default_val (rfData rfb)); do _ <- arr_updates arr (List.map (fun '(i,w) => (i, val_unpack _ w)) pairs); ret arr) end in do new_arr <- array; let rf := {| file_name := rfDataArray rfb; is_wr_mask := rfIsWrMask rfb; chunk_size := rfNum rfb; readers := rfRead rfb; write := rfWrite rfb; size := rfIdxNum rfb; kind := rfData rfb; arr := new_arr |} in let reads := match rfRead rfb with | Async rs => map (fun r => (r, (AsyncRead, rfDataArray rfb))) rs | Sync b rs => map (fun r => (readReqName r, (ReadReq (readRegName r), rfDataArray rfb))) rs ++ map (fun r => (readResName r, (ReadResp (readRegName r), rfDataArray rfb))) rs end in let newmeths := (rfWrite rfb, (WriteFC, rfDataArray rfb)) :: reads in let newvals := match rfRead rfb with | Async _ => [] | Sync b rs => let k := if b then Bit (Nat.log2_up (rfIdxNum rfb)) else rfData rfb in map (fun r => (readRegName r, existT _ k (default_val k))) rs end in ret {| methods := fold_right (fun '(x,y) st => insert x y st) (methods state) newmeths; int_regs := fold_right (fun '(x,y) st => insert x y st) (int_regs state) newvals; files := insert (rfDataArray rfb) rf (files state) |} . Fixpoint initialize_files(args : list (string * string))(rfbs : list RegFileBase) : IO FileState := match rfbs with | [] => ret empty_state | (file::files) => ( do st <- initialize_files args files; initialize_file args file st) end. Definition initialize_file_zero(rfb : RegFileBase)(state : FileState) : IO FileState := let array := match rfInit rfb with | RFNonFile None => arr_repl (rfIdxNum rfb) (default_val (rfData rfb)) | RFNonFile (Some c) => arr_repl (rfIdxNum rfb) (eval_ConstT c) | RFFile isAscii isArg file _ _ _ => arr_repl (rfIdxNum rfb) (default_val (rfData rfb)) end in do new_arr <- array; let rf := {| file_name := rfDataArray rfb; is_wr_mask := rfIsWrMask rfb; chunk_size := rfNum rfb; readers := rfRead rfb; write := rfWrite rfb; size := rfIdxNum rfb; kind := rfData rfb; arr := new_arr |} in let reads := match rfRead rfb with | Async rs => map (fun r => (r, (AsyncRead, rfDataArray rfb))) rs | Sync b rs => map (fun r => (readReqName r, (ReadReq (readRegName r), rfDataArray rfb))) rs ++ map (fun r => (readResName r, (ReadResp (readRegName r), rfDataArray rfb))) rs end in let newmeths := (rfWrite rfb, (WriteFC, rfDataArray rfb)) :: reads in let newvals := match rfRead rfb with | Async _ => [] | Sync b rs => let k := if b then Bit (Nat.log2_up (rfIdxNum rfb)) else rfData rfb in map (fun r => (readRegName r, existT _ k (default_val k))) rs end in ret {| methods := fold_right (fun '(x,y) st => insert x y st) (methods state) newmeths; int_regs := fold_right (fun '(x,y) st => insert x y st) (int_regs state) newvals; files := insert (rfDataArray rfb) rf (files state) |} . Fixpoint initialize_files_zero(rfbs : list RegFileBase) : IO FileState := match rfbs with | [] => ret empty_state | (file::files) => ( do st <- initialize_files_zero files; initialize_file_zero file st) end. End RegFile. Extract Constant parseFile => "ParseExtract.parseFile". ================================================ FILE: Simulator/CoqSim/Simulator.v ================================================ Require Import Streams. Require Import Kami.Simulator.CoqSim.Misc. Require Import Kami.Simulator.CoqSim.TransparentProofs. Require Import Kami.Simulator.CoqSim.HaskellTypes. Require Import Kami.Simulator.CoqSim.RegisterFile. Require Import Kami.Simulator.CoqSim.Eval. Require Import Kami.AllNotations. Import Kami.Simulator.CoqSim.HaskellTypes.Notations. Section EvalAction. Definition SimRegs := Map {x : _ & fullType eval_Kind x}. Definition KamiState := (SimRegs * FileState)%type. Section Regs. Variable init_regs : list (string * {x : FullKind & RegInitValT x}). Variable regs : SimRegs. Definition kind_consistent := forall r k, (exists v, lookup String.eqb r init_regs = Some (existT _ k v)) <-> (exists v', map_lookup r regs = Some (existT _ k v')). Variable kc : kind_consistent. (* helper lemmas *) Lemma kc_init_sim : forall r k v, lookup String.eqb r init_regs = Some (existT _ k v) -> exists v', map_lookup r regs = Some (existT _ k v'). Proof. intros. apply kc. exists v; auto. Qed. Lemma kc_sim_init : forall r k v, map_lookup r regs = Some (existT _ k v) -> exists v', lookup String.eqb r init_regs = Some (existT _ k v'). Proof. intros. apply kc. exists v; auto. Qed. Record Update := { reg_name : string; kind : FullKind; new_val : fullType eval_Kind kind; lookup_match : exists v, lookup String.eqb reg_name init_regs = Some (existT _ kind v) }. Definition Updates := list Update. Definition FileUpdates := list FileUpd. (* Fixpoint mkProd(ts : list Type) : Type := match ts with | [] => unit | T::ts' => (T * mkProd ts')%type end. *) Definition meth_sig(sig : Signature) : Type := eval_Kind (fst sig) -> KamiState -> IO (eval_Kind (snd sig)). Definition return_meth(meth_name : string)(sig : Signature)(meths : Map {sig : Signature & meth_sig sig}) : option (meth_sig sig). refine match map_lookup meth_name meths with | Some (existT sig' meth) => _ | None => None end. Proof. destruct (Signature_decb sig sig') eqn:G. - rewrite Signature_decb_eq in G. rewrite G; exact (Some meth). - exact None. Defined. Definition reg_not_found{X} : string -> IO X := fun reg => error ("register " ++ reg ++ " not found."). Lemma dep_pair_rewrite{X}{Y : X -> Type} : forall {x x'} (pf : x = x')(y : Y x), existT Y x y = existT Y x' (@eq_rect X x Y y x' pf). Proof. intros. destruct pf. reflexivity. Qed. Fixpoint eval_ActionT{k}(state : FileState)(updates : Updates)(fupdates : FileUpdates)(a : ActionT eval_Kind k)(a_wf : WfActionT_new init_regs a)(ms : Map {sig : Signature & meth_sig sig}){struct a} : IO (Updates * FileUpdates * eval_Kind k). refine (match a return WfActionT_new init_regs a -> _ with | MCall meth s e cont => fun pf => do x <- rf_methcall state meth (existT _ (fst s) (eval_Expr e)); match x with | Some (o, existT k v) => match Kind_dec k (snd s) with | left _ => _ | right _ => error ("Type mismatch") end | None => match return_meth meth s ms with | None => error ("Method " ++ meth ++ " not found") | Some f => ( do p <- f (eval_Expr e) (regs,state); eval_ActionT _ state updates fupdates (cont p) _ ms ) end end | LetExpr k e cont => fun pf => eval_ActionT _ state updates fupdates (cont (eval_Expr e)) _ ms | LetAction k a cont => fun pf => ( do p <- eval_ActionT _ state updates fupdates a _ ms; eval_ActionT _ state (fst (fst p)) (snd (fst p)) (cont (snd p)) _ ms ) | ReadNondet k cont => fun pf => ( do v <- rand_val_FK k; eval_ActionT _ state updates fupdates (cont v) _ ms ) | ReadReg r k cont => fun pf => _ | WriteReg r k e a => fun pf => (* match lookup String.eqb r regs with | None => reg_not_found r | Some p => _ end *) _ | IfElse e k a1 a2 cont => fun pf => let a := if (eval_Expr e) then a1 else a2 in ( do p <- eval_ActionT _ state updates fupdates a _ ms; eval_ActionT _ state (fst (fst p)) (snd (fst p)) (cont ((snd p))) _ ms ) | Sys ss a => fun pf => ( do _ <- eval_list_SysT ss; eval_ActionT _ state updates fupdates a _ ms ) | Return e => fun pf => ret (updates, fupdates, eval_Expr e) end a_wf). Proof. (* MCall *) - rewrite e0 in v. destruct o as [fupd|]. + exact (eval_ActionT _ state updates (fupd::fupdates) (cont v) (pf _) ms). + exact (eval_ActionT _ state updates fupdates (cont v) (pf _) ms). - apply pf. - apply pf. - apply pf. - apply pf. - apply pf. (* ReadReg *) - destruct (map_lookup r regs) eqn:G. + pose (@eq_rect FullKind (projT1 s) (fullType eval_Kind) (projT2 s) k). assert (projT1 s = k). * simpl in pf. destruct s. simpl. destruct (@kc_sim_init _ _ _ G). rewrite H in pf. destruct pf. congruence. * refine (eval_ActionT _ state updates fupdates (cont (f H)) _ ms). simpl in pf. destruct lookup in pf. ** destruct s0. destruct pf. apply H1. ** destruct pf. + simpl in pf. destruct lookup eqn:G0 in pf. * absurd (map_lookup r regs = None). ** destruct s. destruct (@kc_init_sim _ _ _ G0). rewrite H; discriminate. ** exact G. * destruct pf. (* WriteReg *) - destruct (map_lookup r regs) eqn:G. + assert (projT1 s = k). * simpl in pf. destruct s. simpl. destruct (@kc_sim_init _ _ _ G). rewrite H in pf. destruct pf. congruence. * assert (exists v, lookup String.eqb r init_regs = Some (existT _ k v)). ** simpl in pf. destruct s; destruct (@kc_sim_init _ _ _ G). rewrite H0 in pf; destruct pf. rewrite (dep_pair_rewrite (eq_sym H1)) in H0. eexists; exact H0. ** pose (upd := {| reg_name := r; kind := k; new_val := eval_Expr e; lookup_match := H0 |}). refine (eval_ActionT _ state (upd::updates) fupdates a _ ms). simpl in pf. destruct lookup in pf. *** destruct s0. destruct pf. exact H2. *** destruct pf. + simpl in pf. destruct lookup eqn:G0 in pf. * absurd (map_lookup r regs = None). ** destruct s. destruct (@kc_init_sim _ _ _ G0). rewrite H; discriminate. ** exact G. * destruct pf. - simpl in pf; destruct (eval_Expr e); tauto. - apply pf. - exact pf. Defined. (* Fixpoint curried(X : Type)(ts : list Type) : Type := match ts with | [] => X | T::ts' => T -> curried X ts' end. Fixpoint curry(X : Type)(ts : list Type) : (mkProd ts -> X) -> curried X ts := match ts return (mkProd ts -> X) -> curried X ts with | [] => fun f => f tt | T::ts' => fun f t => curry ts' (fun xs => f (t,xs)) end. *) Definition eval_RuleT(state : FileState)(r : RuleT)(r_wf : WfActionT_new init_regs (snd r eval_Kind))(ms : Map {sig : Signature & meth_sig sig}) : IO (Updates * FileUpdates * eval_Kind Void) := eval_ActionT state [] [] ((snd r) eval_Kind) r_wf ms. Definition do_single_update(upd : Update)(regs : SimRegs) : SimRegs := insert (reg_name upd) (existT _ (kind upd) (new_val upd)) regs. Definition do_updates(upds : Updates)(regs : SimRegs) : SimRegs := fold_right do_single_update regs upds. End Regs. Section Regs2. Lemma update_hit : forall init_regs regs k v (upd : Update init_regs), map_lookup (reg_name upd) regs = Some (existT _ k v) -> map_lookup (reg_name upd) (do_single_update upd regs) = Some (existT _ (kind upd) (new_val upd)). Proof. intros. unfold do_single_update. rewrite insert_lookup_hit; auto. Qed. Lemma update_miss : forall r init_regs regs (upd : Update init_regs), r <> reg_name upd -> map_lookup r (do_single_update upd regs) = map_lookup r regs. Proof. intros. unfold do_single_update. rewrite insert_lookup_miss; auto. Qed. (* Lemma lookup_update : forall init_regs regs k x (upd : Update init_regs) r, map_lookup r (do_single_update upd regs) = Some (existT (fun x : FullKind => fullType eval_Kind x) k x) -> exists k' y, map_lookup r regs = Some (existT _ k' y). Proof. intros. pose (lookup_match upd). - discriminate H. - simpl do_single_update in H. destruct a. destruct (reg_name upd =? s). + rewrite lookup_cons in H. rewrite lookup_cons. destruct (r =? s). * destruct s0; repeat eexists; reflexivity. * repeat eexists; exact H. + rewrite lookup_cons in H. rewrite lookup_cons. destruct (r =? s). * destruct s0; repeat eexists; reflexivity. * eapply IHregs. exact H. Qed. Lemma lookup_update : forall init_regs regs k x (upd : Update init_regs) r, map_lookup r (do_single_update upd regs) = Some (existT (fun x : FullKind => fullType eval_Kind x) k x) -> exists k' y, map_lookup r regs = Some (existT _ k' y). Proof. intros. destruct upd. *) Lemma update_consistent : forall (curr_regs : SimRegs)(init_regs : list RegInitT)(upd : Update init_regs), kind_consistent init_regs curr_regs -> kind_consistent init_regs (do_single_update upd curr_regs). Proof. intros curr_regs init_regs upd kc r k. split; intros []. - destruct (String.eqb r (reg_name upd)) eqn:G. + rewrite String.eqb_eq in G. rewrite G. destruct (kc_init_sim kc _ H). erewrite update_hit. * destruct (lookup_match upd) as [v lk]. rewrite <- G in lk. rewrite H in lk. inversion lk. rewrite H2 in *. eexists; auto. * rewrite <- G. destruct (kc_init_sim kc _ H). exact H0. + rewrite String.eqb_neq in G. erewrite update_miss; auto. apply kc. eexists; exact H. - destruct (String.eqb r (reg_name upd)) eqn:G. + rewrite String.eqb_eq in G. rewrite G in H. destruct (lookup_match upd). destruct (@kc_init_sim _ _ kc _ _ _ H0). erewrite update_hit in H. * destruct (lookup_match upd) as [v lk]. rewrite G. inversion H. eexists; exact lk. * exact H1. + rewrite String.eqb_neq in G. erewrite update_miss in H; auto. destruct (kc_sim_init kc H). eexists; exact H0. Qed. Lemma updates_consistent : forall (init_regs : list RegInitT)(curr_regs : SimRegs)(upds : list (Update init_regs)), kind_consistent init_regs curr_regs -> kind_consistent init_regs (do_updates upds curr_regs). Proof. induction upds; intro. - exact H. - apply update_consistent; auto. Qed. Definition evaluated_Rule init_regs := forall (st : KamiState), kind_consistent init_regs (fst st) -> Map {sig : Signature & meth_sig sig} -> IO KamiState. Definition eval_Rule : forall init_regs (r : RuleT), WfActionT_new init_regs (snd r eval_Kind) -> evaluated_Rule init_regs := fun init_regs r wf st kc methods => ( do p <- @eval_RuleT init_regs (fst st) kc (snd st) r wf methods; let regs := @do_updates _ (fst (fst p)) (fst st) in do state <- exec_file_updates (snd st) (snd (fst p)); ret (regs, state) ). Definition eval_RegInitValT : {k : FullKind & RegInitValT k} -> {k : FullKind & fullType eval_Kind k} := fun '(existT k o) => match o with | None => existT _ k (eval_ConstFullT (getDefaultConstFullKind k)) | Some c => existT _ k (eval_ConstFullT c) end. Definition initialize_SimRegs(regs : list RegInitT) : SimRegs := map_of_list ( List.map (fun '(r,p) => (r, eval_RegInitValT p)) regs). Lemma lookup_map : forall {V V'}(f : V -> V')(ps : list (string * V)) x v, lookup String.eqb x ps = Some v -> lookup String.eqb x (map (fun '(r,v') => (r, f v')) ps) = Some (f v). Proof. induction ps; intros. - discriminate. - simpl. destruct a. rewrite lookup_cons in *. destruct (x =? s). + inversion H; auto. + apply IHps; auto. Qed. Lemma lookup_map_back : forall {V V'}(f : V -> V')(ps : list (string * V)) x v', lookup String.eqb x (map (fun '(r,v) => (r, f v)) ps) = Some v' -> exists v, f v = v' /\ lookup String.eqb x ps = Some v. Proof. induction ps; intros. - discriminate. - destruct a. simpl in H. rewrite lookup_cons in *. destruct (x =? s). + exists v; inversion H; auto. + apply IHps; auto. Qed. Lemma cons_neq{X}(x : X)(xs : list X) : x::xs <> []. Proof. discriminate. Qed. Definition get_wf_rules{ty} : forall init_regs rules, WfRules ty init_regs rules -> list {r : RuleT & WfActionT_new init_regs (snd r ty)}. Proof. intros. induction rules. - exact []. - simpl in H; destruct H. exact ((existT _ a H) :: (IHrules H0)). Defined. Lemma init_regs_kc : forall init_regs, kind_consistent init_regs (initialize_SimRegs init_regs). Proof. intros; intros r k; split. - intros [v Hv]. unfold initialize_SimRegs. rewrite map_of_list_lookup. rewrite (lookup_map eval_RegInitValT init_regs r Hv). unfold eval_RegInitValT. destruct v. simpl. + exists (eval_ConstFullT c); reflexivity. + exists (eval_ConstFullT (getDefaultConstFullKind k)); reflexivity. - intros [v Hv]. unfold initialize_SimRegs in Hv. rewrite map_of_list_lookup in Hv. destruct (lookup_map_back eval_RegInitValT init_regs r Hv) as [[k' x] [Hx1 Hx2]]. unfold eval_RegInitValT in Hx1. destruct x. + inversion Hx1. eexists. rewrite Hx2. reflexivity. + inversion Hx1. eexists. rewrite Hx2. rewrite <- H0. reflexivity. Qed. End Regs2. End EvalAction. Section SimAPI. Definition init_state(m : Mod)(args : list (string * string)) : IO KamiState := let init_regs := getAllRegisters m in let '(_,(rfs,_)) := separateModRemove m in let regs := initialize_SimRegs init_regs in do s <- initialize_files args rfs; ret (regs,s). Print evaluated_Rule. Definition sim_step{init_regs}(r : evaluated_Rule init_regs) : forall st : KamiState, kind_consistent init_regs (fst st) -> Map {sig : Signature & meth_sig sig} -> IO KamiState := r. End SimAPI. ================================================ FILE: Simulator/CoqSim/TransparentProofs.v ================================================ Require Import Kami.AllNotations. Lemma Bool_eqb_refl2 : forall b, Bool.eqb b b = true. Proof. destruct b; simpl; auto. Defined. Lemma Ascii_eqb_refl2 : forall c, (c =? c)%char = true. Proof. intros []; simpl. repeat rewrite (Bool_eqb_refl2); auto. Defined. Lemma Ascii_eqb_eq2 : forall n m : ascii, (n =? m)%char = true <-> n = m. Proof. intros. split; intro. apply Ascii.eqb_eq in H. exact (match ascii_dec n m with | left p => p | right ne => match (ne H) with end end). rewrite H. apply Ascii_eqb_refl2. Defined. Lemma Nat_eqb_refl2 : forall n, (n =? n)%nat = true. Proof. induction n; auto. Defined. Lemma Nat_eqb_eq2 : forall n m : nat, (n =? m)%nat = true <-> n = m. Proof. split; intro. apply Nat.eqb_eq in H. exact (match Nat.eq_dec n m with | left p => p | right ne => match (ne H) with end end). rewrite H. apply Nat_eqb_refl2. Defined. Lemma String_eqb_eq2 : forall s1 s2 : string, String.eqb s1 s2 = true <-> s1 = s2. Proof. induction s1; destruct s2; simpl; split; intro; try reflexivity; try discriminate. - destruct (a =? a0)%char eqn:G. + apply Ascii_eqb_eq2 in G. apply IHs1 in H. congruence. + discriminate. - inversion H. rewrite Ascii.eqb_refl. rewrite <- H2. apply IHs1; reflexivity. Defined. Lemma Kind_decb_eq2 : forall k1 k2, Kind_decb k1 k2 = true <-> k1 = k2. Proof. induction k1; intros; destruct k2; split; intro; try (reflexivity || discriminate). - simpl in H; apply Nat_eqb_eq2 in H; congruence. - inversion H; simpl; apply Nat_eqb_refl2. - destruct (n =? n0)%nat eqn:G. + simpl in H0. rewrite (@silly_lemma_true bool (n =? n0)%nat _ _ G) in H0 by auto. pose proof G. apply Nat_eqb_eq2 in H1. destruct H1. f_equal; extensionality i. apply H. apply andb_true_iff in H0; destruct H0. pose (proj1 (Fin_forallb_correct _) H0). rewrite (hedberg Nat.eq_dec _ eq_refl) in e. simpl in e. apply e. apply String_eqb_eq2. apply andb_true_iff in H0; destruct H0. pose (proj1 (Fin_forallb_correct _) H1). rewrite (hedberg Nat.eq_dec _ eq_refl) in e. simpl in e. apply e. + simpl in H0. rewrite (@silly_lemma_false) in H0 by auto; discriminate. - rewrite H0; apply Kind_decb_refl. - simpl in H; apply andb_true_iff in H. destruct H as [H1 H2]. apply Nat_eqb_eq2 in H1. destruct (IHk1 k2). pose (H H2); congruence. - simpl. apply andb_true_iff; inversion H; split. + apply Nat_eqb_refl2. + rewrite <- H2, IHk1; reflexivity. Defined. Definition string_dec2 : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}. Proof. intros. destruct (String.eqb s1 s2) eqn:G. - left; apply String_eqb_eq2; auto. - right; abstract (intro; rewrite <- String_eqb_eq2 in H; rewrite H in G; discriminate). Defined. Definition Kind_dec2 : forall k1 k2 : Kind, {k1 = k2} + {k1 <> k2}. Proof. intros. destruct (Kind_decb k1 k2) eqn: G. - left; apply Kind_decb_eq2 in G; congruence. - right. abstract (intro; subst; rewrite Kind_decb_refl in G; discriminate). Defined. Definition Signature_dec2 (s1 s2 : Signature) : {s1 = s2} + {s1 <> s2}. Proof. destruct s1,s2. destruct (Kind_dec2 k k1). destruct (Kind_dec2 k0 k2). left; congruence. right; congruence. right; congruence. Defined. Definition string_sigb : forall x y : (string * Signature), {x = y} + {x <> y}. Proof. intros [] []. destruct (string_dec2 s s1); destruct (Signature_dec2 s0 s2). - left; congruence. - right; congruence. - right; congruence. - right; congruence. Defined. ================================================ FILE: Simulator/NativeTest.v ================================================ Require Import Kami.All. Require Import String. Section TestNative. Local Open Scope kami_expr. Local Open Scope kami_action. Inductive Foo := A | B | C. Definition showFoo x := match x with | A => "A" | B => "B" | C => "C" end. Definition showListFoo xs := ("[" ++ concat ";" (map showFoo xs) ++ "]")%string. Definition int := NativeKind 0. Definition listfoo := NativeKind ([] : list Foo). Definition testNativeModule := MODULE { RegisterN "list" : listfoo <- [] with RegisterN "count" : int <- 0 (* increments counter *) with Rule "incr" := ( ReadN x : int <- "count"; WriteN "count" : int <- Var _ int (S x); Retv) (* prints counter *) with Rule "count" := ( ReadN x : int <- "count"; System [DispString _ ("Count: " ++ (natToHexStr x) ++ "\n")%string]; Retv) (* appends A if count is even, else B*) with Rule "app_count" := ( ReadN x : int <- "count"; ReadN xs : listfoo <- "list"; WriteN "list" : listfoo <- Var _ listfoo ((if Nat.even x then A else B)::xs); Retv) (* appends C *) with Rule "app_c" := ( ReadN xs : listfoo <- "list"; WriteN "list" : listfoo <- Var _ listfoo (C::xs); Retv) (* prints list *) with Rule "list" := ( ReadN xs : listfoo <- "list"; System [DispString _ ("List: " ++ (showListFoo xs) ++ "\n")%string]; Retv) }. End TestNative. Definition mkMod(bm : BaseModule)(rfs : list RegFileBase) := let md := (fold_right ConcatMod bm (map (fun m => Base (BaseRegFile m)) rfs)) in createHideMod md (map fst (getAllMethods md)). Definition testNative := mkMod testNativeModule []. Extract Inductive nat => "Prelude.Int" [ "0" "(Prelude.succ :: Prelude.Int -> Prelude.Int)" ] "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". ================================================ FILE: Simulator/README.adoc ================================================ == How to use the Haskell Simulator [arabic] . Make sure you have Haskell and GHC installed. You will need the following package versions: * `base >=4.12 && <4.13` * `hashmap >=1.3 && <1.4` * `random >=1.1 && <1.2` * `bv >=0.5 && <0.6` * `vector >=0.12 && <0.13` * `text >=1.2 && <1.3` * `split >=0.2 && <0.3` * `hashable >=1.2 && <1.3` . In Coq, extract your module and everything else you want using the `Separate Extraction` command, extracting the following Kami terms as well: * `getFins` * `Fin.to_nat` * `fullFormatHex` * `fullFormatBinary` * `fullFormatDecimal` * `readReqName` * `readResName` * `readRegName` * `rfIsWrMask` * `rfNum` * `rfDataArray` * `rfRead` * `rfWrite` * `rfIdxNum` * `rfData` * `rfInit` * `pack` * `unpack` See the file `Kami/Tutorial/ExtractEx.v` or `ProcKami/Instance.v` for examples. [arabic, start=3] . Create a file called `HaskellTarget.hs` which exports every module created by the extraction as well as everything you extracted. See `RiscvSpecFormal/HaskellTarget.raw` for an example. . Create another file with a module called `Main` which imports your `HaskellTarget` module along with `Simulator.All`. [arabic] .. For every external method called in your module, write a function in Haskell of type `Val -> IO Val` which corresponds to how you would like this method to accept and return a value (possibly with side-effects like changing state or logging messages). Package the names of these methods with their Haskell implementations into an association list of type `[(String, Val -> IO Val)]`. .. Provide a list of the names of the rules you would like to simulate in some privileged order (if you use the round robin scheduling, they will execute in this order). To get a default list of rules from a module named `mod`, you can use the expression `map fst $ getRules mod`. .. The function needed to simulate a module is `simulate_module :: Int -> ([RuleT] -> Str (IO RuleT)) -> [String] -> [(String, Val -> IO Val)] -> [RegFileBase] -> BaseModule -> IO (Map String Val)`, defined in `Simulator/Simulator.hs`. * The first argument is a seed for a random number generator * The second argument is a function which provides a strategy for determining the next rule to execute * The third argument is a list of rule names, which should be supplied from ii) * The fourth argument is the association list of method implementations, which should be supplied from i) * The fifth argument is a list of register files, which should be extracted from Coq * The sixth argument is the module you wish to simulate, which should be extracted from Coq + Write `main :: IO()`, invoking `simulate_module`. .. Compile your `Main` module, making sure that GHC can find your `HaskellTarget.hs` as well as all the files in `Kami/Simulator`. .. Supply the following arguments when applicable to run your executable: * `file_ident=file_path`, where `file_ident` is the name of a `RFFile` with `isArg=true` and `file_path` is the path to the hex file which this `RFFile` references * `file_path`, where `file_path` is the path to a hex file which an `RFFile` with `isArg=false` references * `pass:addr`, where addr is a hexadecimal value corresponding to a pass address * `fail:addr`, where addr is a hexadecimal value corresponding to a fail address + See `Kami/SimulatorExample.hs` or `RiscvSpecFormal/Main.raw` for examples. ================================================ FILE: StateMonad.v ================================================ Require Import List. Set Implicit Arguments. Set Asymmetric Patterns. Definition State (s a: Type) := s -> (a * s). Definition get {s: Type} : State s s := fun i => (i, i). Definition gets {s a: Type} f : State s a := fun s => (f s, s). Definition put {s: Type} x : State s unit := fun _ => (tt, x). Definition modify {s: Type} (f: s -> s): State s unit := fun i => (tt, f i). Definition bind s a b (f: State s a) (g: a -> State s b) : State s b := fun i => let (x, y) := f i in g x y. Definition ret s a (v: a) : State s a := fun i => (v, i). Definition run s a (m: State s a) init : (a * s) := m init. Notation "'do' x <- y ; cont" := (bind y (fun x => cont)) (at level 20). Section test. Let MyS := State (list nat) nat. Let ADef := 0. Let mon := (do test <- get ; do _ <- put (tail test) ; do test2 <- get ; ret (hd 0 test2) ). Let montest := eq_refl: (run mon (34 :: 673 :: 3 :: 84 :: nil) = (673, 673 :: 3 :: 84 :: nil)). End test. ================================================ FILE: Syntax.v ================================================ Require Export Bool Ascii String Fin List FunctionalExtensionality Psatz PeanoNat. Require Export Kami.Lib.VectorFacts Kami.Lib.EclecticLib. Require Export Kami.Lib.Word Kami.Lib.WordProperties. Export ListNotations. Require Import Permutation. Require Import ZArith. Global Set Implicit Arguments. Global Set Asymmetric Patterns. Global Open Scope word_scope. Global Open Scope nat_scope. Global Open Scope string_scope. Global Open Scope vector_scope. Global Open Scope list_scope. Inductive Kind := | Bool : Kind | Bit : nat -> Kind | Struct : forall n, (Fin.t n -> Kind) -> (Fin.t n -> string) -> Kind | Array : nat -> Kind -> Kind. Inductive FullKind: Type := | SyntaxKind: Kind -> FullKind | NativeKind (t: Type) (c : t) : FullKind. Inductive ConstT: Kind -> Type := | ConstBool: bool -> ConstT Bool | ConstBit n: word n -> ConstT (Bit n) | ConstStruct n fk fs (fv: forall i, ConstT (fk i)): ConstT (@Struct n fk fs) | ConstArray n k (fk: Fin.t n -> ConstT k): ConstT (Array n k). Inductive ConstFullT: FullKind -> Type := | SyntaxConst k: ConstT k -> ConstFullT (SyntaxKind k) | NativeConst t (c' : t) : ConstFullT (NativeKind c'). Coercion ConstBool : bool >-> ConstT. Coercion ConstBit : word >-> ConstT. Fixpoint getDefaultConst (k: Kind): ConstT k := match k with | Bool => ConstBool false | Bit n => ConstBit (wzero n) | Struct n fk fs => ConstStruct fk fs (fun i => getDefaultConst (fk i)) | Array n k => ConstArray (fun _ => getDefaultConst k) end. Notation Default := (getDefaultConst _). Fixpoint getDefaultConstFullKind (k : FullKind) : ConstFullT k := match k with | SyntaxKind k' => SyntaxConst (getDefaultConst k') | NativeKind t c' => NativeConst c' end. Inductive UniBoolOp: Set := | Neg: UniBoolOp. Inductive CABoolOp: Set := | And: CABoolOp (* | Or: CABoolOp *) | Xor: CABoolOp. Inductive UniBitOp: nat -> nat -> Set := | Inv n: UniBitOp n n | TruncLsb lsb msb: UniBitOp (lsb + msb) lsb | TruncMsb lsb msb: UniBitOp (lsb + msb) msb | UAnd n: UniBitOp n 1 | UOr n: UniBitOp n 1 | UXor n: UniBitOp n 1. Inductive BinSign := SignSS | SignSU | SignUU. Inductive BinBitOp: nat -> nat -> nat -> Set := | Sub n: BinBitOp n n n | Div n: BinBitOp n n n | Rem n: BinBitOp n n n | Sll n m: BinBitOp n m n | Srl n m: BinBitOp n m n | Sra n m: BinBitOp n m n | Concat msb lsb: BinBitOp msb lsb (lsb + msb) (* MSB : n1, LSB : n2 *). Inductive CABitOp: Set := | Add: CABitOp | Mul: CABitOp | Band: CABitOp (* | Bor: CABitOp *) | Bxor: CABitOp. Inductive BinBitBoolOp: nat -> nat -> Set := | LessThan n: BinBitBoolOp n n. Fixpoint type (k: Kind): Type := match k with | Bool => bool | Bit n => word n | Struct n fk fs => forall i, type (fk i) | Array n k' => Fin.t n -> type k' end. Fixpoint evalConstT k (e: ConstT k): type k := match e in ConstT k return type k with | ConstBool b => b | ConstBit n w => w | ConstStruct n fk fs fv => fun i => evalConstT (fv i) | ConstArray n k' fv => fun i => evalConstT (fv i) end. Section Phoas. Variable ty: Kind -> Type. Definition fullType k := match k with | SyntaxKind k' => ty k' | NativeKind k' c' => k' end. Inductive Expr: FullKind -> Type := | Var k: fullType k -> Expr k | Const k: ConstT k -> Expr (SyntaxKind k) | UniBool: UniBoolOp -> Expr (SyntaxKind Bool) -> Expr (SyntaxKind Bool) | CABool: CABoolOp -> list (Expr (SyntaxKind Bool)) -> Expr (SyntaxKind Bool) | UniBit n1 n2: UniBitOp n1 n2 -> Expr (SyntaxKind (Bit n1)) -> Expr (SyntaxKind (Bit n2)) | CABit n: CABitOp -> list (Expr (SyntaxKind (Bit n))) -> Expr (SyntaxKind (Bit n)) | BinBit n1 n2 n3: BinBitOp n1 n2 n3 -> Expr (SyntaxKind (Bit n1)) -> Expr (SyntaxKind (Bit n2)) -> Expr (SyntaxKind (Bit n3)) | BinBitBool n1 n2: BinBitBoolOp n1 n2 -> Expr (SyntaxKind (Bit n1)) -> Expr (SyntaxKind (Bit n2)) -> Expr (SyntaxKind Bool) | ITE k: Expr (SyntaxKind Bool) -> Expr k -> Expr k -> Expr k | Eq k: Expr (SyntaxKind k) -> Expr (SyntaxKind k) -> Expr (SyntaxKind Bool) | ReadStruct n (fk: Fin.t n -> Kind) (fs: Fin.t n -> string) (e: Expr (SyntaxKind (Struct fk fs))) i: Expr (SyntaxKind (fk i)) | BuildStruct n (fk: Fin.t n -> Kind) (fs: Fin.t n -> string) (fv: forall i, Expr (SyntaxKind (fk i))): Expr (SyntaxKind (Struct fk fs)) | ReadArray n m k: Expr (SyntaxKind (Array n k)) -> Expr (SyntaxKind (Bit m)) -> Expr (SyntaxKind k) | ReadArrayConst n k: Expr (SyntaxKind (Array n k)) -> Fin.t n -> Expr (SyntaxKind k) | BuildArray n k: (Fin.t n -> Expr (SyntaxKind k)) -> Expr (SyntaxKind (Array n k)) | Kor k: list (Expr (SyntaxKind k)) -> Expr (SyntaxKind k) | ToNative k: Expr (SyntaxKind k) -> Expr (@NativeKind (type k) (evalConstT (getDefaultConst k))) | FromNative k: Expr (@NativeKind (type k) (evalConstT (getDefaultConst k))) -> Expr (SyntaxKind k). Definition UpdateArray n m k (e: Expr (SyntaxKind (Array n k))) (i: Expr (SyntaxKind (Bit m))) (v: Expr (SyntaxKind k)) := BuildArray (fun i' : Fin.t n => ITE (Eq i (Const (natToWord _ (proj1_sig (Fin.to_nat i'))))) v (ReadArrayConst e i')). Definition UpdateArrayConst n k (e: Expr (SyntaxKind (Array n k))) (i: Fin.t n) (v: Expr (SyntaxKind k)) := BuildArray (fun i' : Fin.t n => match Fin.eq_dec i i' with | left _ => v | right _ => ReadArrayConst e i' end). Definition UpdateStruct n (fk: Fin.t n -> Kind) (fs: Fin.t n -> string) (e: Expr (SyntaxKind (Struct fk fs))) i (v: Expr (SyntaxKind (fk i))) := BuildStruct fk fs (fun i' => match Fin_eq_dec i i' with | left pf => match pf in _ = Y return Expr (SyntaxKind (fk Y)) with | eq_refl => v end | right _ => ReadStruct e i' end). Section BitOps. Definition castBits ni no (pf: ni = no) (e: Expr (SyntaxKind (Bit ni))) := nat_cast (fun n => Expr (SyntaxKind (Bit n))) pf e. Definition Slt n (e1 e2: Expr (SyntaxKind (Bit (n + 1)))) := Eq (Eq (UniBit (TruncMsb n 1) e1) (UniBit (TruncMsb n 1) e2)) (BinBitBool (LessThan _) e1 e2). Definition ConstExtract lsb n msb (e: Expr (SyntaxKind (Bit (lsb + n + msb)))): Expr (SyntaxKind (Bit n)) := UniBit (TruncMsb lsb n) (UniBit (TruncLsb (lsb + n) msb) e). Definition OneExtend msb lsb (e: Expr (SyntaxKind (Bit lsb))): Expr (SyntaxKind (Bit (lsb + msb))) := (BinBit (Concat msb lsb) (Const (wones msb))) e. Definition ZeroExtend msb lsb (e: Expr (SyntaxKind (Bit lsb))): Expr (SyntaxKind (Bit (lsb + msb))) := (BinBit (Concat msb lsb) (Const (wzero msb))) e. Definition SignExtend lsb msb: Expr (SyntaxKind (Bit lsb)) -> Expr (SyntaxKind (Bit (lsb + msb))). refine match lsb return Expr (SyntaxKind (Bit lsb)) -> Expr (SyntaxKind (Bit (lsb + msb))) with | 0 => fun _ => Const (wzero msb) | S m => fun e => BinBit (Concat msb (S m)) (ITE (Eq (UniBit (TruncMsb m 1) (castBits _ e)) (Const (WO~0)%word)) (Const (wzero msb)) (Const (wones msb))) e end; abstract lia. Defined. Fixpoint replicate sz (e: Expr (SyntaxKind (Bit sz))) n : Expr (SyntaxKind (Bit (n * sz))) := match n with | 0 => Const WO | S m => BinBit (Concat (m * sz) sz) (replicate e m) e end. Definition OneExtendTruncLsb ni no (e: Expr (SyntaxKind (Bit ni))): Expr (SyntaxKind (Bit no)). refine match Compare_dec.lt_dec ni no with | left isLt => castBits _ (@OneExtend (no - ni) ni e) | right isGe => UniBit (TruncLsb no (ni - no)) (castBits _ e) end; abstract lia. Defined. Definition ZeroExtendTruncLsb ni no (e: Expr (SyntaxKind (Bit ni))): Expr (SyntaxKind (Bit no)). refine match Compare_dec.lt_dec ni no with | left isLt => castBits _ (@ZeroExtend (no - ni) ni e) | right isGe => UniBit (TruncLsb no (ni - no)) (castBits _ e) end; abstract lia. Defined. Definition SignExtendTruncLsb ni no (e: Expr (SyntaxKind (Bit ni))): Expr (SyntaxKind (Bit no)). refine match Compare_dec.lt_dec ni no with | left isLt => castBits _ (@SignExtend ni (no - ni) e) | right isGe => UniBit (TruncLsb no (ni - no)) (castBits _ e) end; abstract Omega.omega. Defined. Definition ZeroExtendTruncMsb ni no (e: Expr (SyntaxKind (Bit ni))): Expr (SyntaxKind (Bit no)). refine match Compare_dec.lt_dec ni no with | left isLt => castBits _ (@ZeroExtend (no - ni) ni e) | right isGe => UniBit (TruncMsb (ni - no) no) (castBits _ e) end; abstract lia. Defined. Definition SignExtendTruncMsb ni no (e: Expr (SyntaxKind (Bit ni))): Expr (SyntaxKind (Bit no)). refine match Compare_dec.lt_dec ni no with | left isLt => castBits _ (@SignExtend ni (no - ni) e) | right isGe => UniBit (TruncMsb (ni - no) no) (castBits _ e) end; abstract Omega.omega. Defined. Fixpoint countLeadingZeros ni no: Expr (SyntaxKind (Bit ni)) -> Expr (SyntaxKind (Bit no)). refine match ni return Expr (SyntaxKind (Bit ni)) -> Expr (SyntaxKind (Bit no)) with | 0 => fun _ => Const (wzero _) | S m => fun e => ITE (Eq (UniBit (TruncMsb m 1) (castBits (eq_sym (Nat.add_1_r m)) e)) (Const WO~0)) (CABit Add [Const (natToWord _ 1); countLeadingZeros m _ (UniBit (TruncLsb m 1) (castBits (eq_sym (Nat.add_1_r m)) e))]) (Const (wzero _)) end. Defined. Fixpoint sumSizes n: (Fin.t n -> nat) -> nat := match n return (Fin.t n -> nat) -> nat with | 0 => fun _ => 0 | S m => fun sizes => sumSizes (fun x => sizes (Fin.FS x)) + sizes Fin.F1 end. Fixpoint size (k: Kind) {struct k} := match k with | Bool => 1 | Bit n => n | Struct n fk fs => sumSizes (fun i => size (fk i)) | Array n k => n * size k end. (* ConstExtract: LSB, MIDDLE, MSB *) (* Concat: MSB, LSB *) Fixpoint concatStructExpr n {struct n}: forall (sizes: Fin.t n -> nat) (f: forall i, Expr (SyntaxKind (Bit (sizes i)))), Expr (SyntaxKind (Bit (sumSizes sizes))) := match n return forall (sizes: Fin.t n -> nat) (f: forall i, Expr (SyntaxKind (Bit (sizes i)))), Expr (SyntaxKind (Bit (sumSizes sizes))) with | 0 => fun _ _ => Const WO | S m => fun sizes f => BinBit (Concat _ _) (f Fin.F1) (@concatStructExpr m (fun x => (sizes (Fin.FS x))) (fun x => f (Fin.FS x))) end. Fixpoint pack (k: Kind): Expr (SyntaxKind k) -> Expr (SyntaxKind (Bit (size k))). refine match k return Expr (SyntaxKind k) -> Expr (SyntaxKind (Bit (size k))) with | Bool => fun e => (ITE e (Const (WO~1)%word) (Const (WO~0)%word)) | Bit n => fun e => e | Struct n fk fs => fun e => concatStructExpr (fun i => size (fk i)) (fun i => @pack (fk i) (ReadStruct e i)) | Array n k => fun e => (fix help i := match i return Expr (SyntaxKind (Bit (i * size k))) with | 0 => Const WO | S m => castBits _ (BinBit (Concat (size k) (m * size k)) (@pack k (ReadArray e (Const (natToWord (Nat.log2_up n) m)))) (help m)) end) n end; abstract lia. Defined. Fixpoint sumSizesMsbs n (i: Fin.t n) {struct i}: (Fin.t n -> nat) -> nat := match i in Fin.t n return (Fin.t n -> nat) -> nat with | Fin.F1 _ => fun _ => 0 | Fin.FS m f => fun sizes => sumSizesMsbs f (fun j => sizes (Fin.FS j)) + sizes Fin.F1 end. Lemma helper_sumSizes n (i: Fin.t n): forall (sizes: Fin.t n -> nat), sumSizes sizes = (sumSizes sizes - (sumSizesMsbs i sizes + sizes i)) + sizes i + sumSizesMsbs i sizes. Proof. induction i; simpl; intros; auto. - lia. - specialize (IHi (fun x => sizes (Fin.FS x))). lia. Qed. Lemma helper_array n (i: Fin.t n): forall size_k, n * size_k = (proj1_sig (Fin.to_nat i) * size_k) + size_k + (n * size_k - ((proj1_sig (Fin.to_nat i) * size_k) + size_k)) . Proof. induction i; simpl; intros; auto. - lia. - case_eq (Fin.to_nat i); simpl; intros. rewrite H in *; simpl in *. rewrite IHi at 1. lia. Qed. Fixpoint unpack (k: Kind): Expr (SyntaxKind (Bit (size k))) -> Expr (SyntaxKind k) := match k return Expr (SyntaxKind (Bit (size k))) -> Expr (SyntaxKind k) with | Bool => fun e => Eq e (Const (WO~1)%word) | Bit _ => fun e => e | Struct n fk fs => fun e => BuildStruct _ _ (fun i => unpack _ (ConstExtract _ _ (sumSizesMsbs i (fun j => size (fk j))) (@castBits _ _ (helper_sumSizes i (fun j => size (fk j))) e))) | Array n k => fun e => BuildArray (fun i => unpack _ (ConstExtract (proj1_sig (Fin.to_nat i) * size k) _ _ (@castBits _ _ (helper_array _ _) e))) end. End BitOps. Inductive BitFormat := | Binary | Decimal | Hex. Definition FullBitFormat := (nat * BitFormat)%type. Inductive FullFormat: Kind -> Type := | FBool: nat -> BitFormat -> FullFormat Bool | FBit n: nat -> BitFormat -> FullFormat (Bit n) | FStruct n fk fs: (forall i, FullFormat (fk i)) -> FullFormat (@Struct n fk fs) | FArray n k: FullFormat k -> FullFormat (@Array n k). Fixpoint fullFormatHex k : FullFormat k := match k return FullFormat k with | Bool => FBool 1 Hex | Bit n => FBit n ((n+3)/4) Hex | Struct n fk fs => FStruct fk fs (fun i => fullFormatHex (fk i)) | Array n k => FArray n (fullFormatHex k) end. Fixpoint fullFormatBinary k : FullFormat k := match k return FullFormat k with | Bool => FBool 1 Binary | Bit n => FBit n n Binary | Struct n fk fs => FStruct fk fs (fun i => fullFormatBinary (fk i)) | Array n k => FArray n (fullFormatBinary k) end. Fixpoint fullFormatDecimal k : FullFormat k := match k return FullFormat k with | Bool => FBool 1 Decimal | Bit n => FBit n 0 Decimal | Struct n fk fs => FStruct fk fs (fun i => fullFormatDecimal (fk i)) | Array n k => FArray n (fullFormatDecimal k) end. Inductive SysT: Type := | DispString (s: string): SysT | DispExpr k (e: Expr (SyntaxKind k)) (ff: FullFormat k): SysT | Finish: SysT. Definition DispHex k (e: Expr (SyntaxKind k)) := DispExpr e (fullFormatHex k). Definition DispBinary k (e: Expr (SyntaxKind k)) := DispExpr e (fullFormatBinary k). Definition DispDecimal k (e: Expr (SyntaxKind k)) := DispExpr e (fullFormatDecimal k). Inductive LetExprSyntax k := | NormExpr (e: Expr (SyntaxKind k)): LetExprSyntax k | SysE (ls: list SysT) (e: LetExprSyntax k): LetExprSyntax k | LetE k' (e: LetExprSyntax k') (cont: ty k' -> LetExprSyntax k): LetExprSyntax k | IfElseE (pred: Expr (SyntaxKind Bool)) k' (t f: LetExprSyntax k') (cont: ty k' -> LetExprSyntax k): LetExprSyntax k. Inductive ActionT (lretT: Kind) : Type := | MCall (meth: string) s: Expr (SyntaxKind (fst s)) -> (ty (snd s) -> ActionT lretT) -> ActionT lretT | LetExpr k: Expr k -> (fullType k -> ActionT lretT) -> ActionT lretT | LetAction k: ActionT k -> (ty k -> ActionT lretT) -> ActionT lretT | ReadNondet k: (fullType k -> ActionT lretT) -> ActionT lretT | ReadReg (r: string) k: (fullType k -> ActionT lretT) -> ActionT lretT | WriteReg (r: string) k: Expr k -> ActionT lretT -> ActionT lretT | IfElse: Expr (SyntaxKind Bool) -> forall k, ActionT k -> ActionT k -> (ty k -> ActionT lretT) -> ActionT lretT | Sys: list SysT -> ActionT lretT -> ActionT lretT | Return: Expr (SyntaxKind lretT) -> ActionT lretT. Fixpoint convertLetExprSyntax_ActionT k (e: LetExprSyntax k) := match e in LetExprSyntax _ return ActionT k with | NormExpr e' => Return e' | LetE _ e' cont => LetAction (convertLetExprSyntax_ActionT e') (fun v => convertLetExprSyntax_ActionT (cont v)) | SysE ls cont => Sys ls (convertLetExprSyntax_ActionT cont) | IfElseE pred k' t f cont => IfElse pred (convertLetExprSyntax_ActionT t) (convertLetExprSyntax_ActionT f) (fun v => convertLetExprSyntax_ActionT (cont v)) end. End Phoas. Definition Action (retTy : Kind) := forall ty, ActionT ty retTy. Definition Signature := (Kind * Kind)%type. Definition MethodT (sig : Signature) := forall ty, ty (fst sig) -> ActionT ty (snd sig). Notation Void := (Bit 0). Notation Attribute A := (string * A)%type (only parsing). Section RegInitValT. Variable x: FullKind. Definition RegInitValT := option (ConstFullT x). End RegInitValT. Definition RegInitT := Attribute (sigT RegInitValT). Definition DefMethT := Attribute (sigT MethodT). Definition RuleT := Attribute (Action Void). Inductive RegFileInitT (IdxNum: nat) (Data: Kind) := | RFNonFile (init: option (ConstT Data)) | RFFile (isAscii: bool) (isArg: bool) (file: string) (offset size: nat) (init: Fin.t IdxNum -> ConstT Data). Record SyncRead := { readReqName : string ; readResName : string ; readRegName : string }. Inductive RegFileReaders := | Async (reads: list string) | Sync (isAddr: bool) (reads: list SyncRead). Record RegFileBase := { rfIsWrMask : bool ; rfNum: nat ; rfDataArray: string ; rfRead: RegFileReaders ; rfWrite: string ; rfIdxNum: nat ; rfData: Kind ; rfInit: RegFileInitT rfIdxNum rfData }. Inductive BaseModule: Type := | BaseRegFile (rf: RegFileBase) | BaseMod (regs: list RegInitT) (rules: list RuleT) (dms: list DefMethT). Inductive Mod: Type := | Base (m: BaseModule): Mod | HideMeth (m: Mod) (meth: string): Mod | ConcatMod (m1 m2: Mod): Mod. Coercion Base: BaseModule >-> Mod. Notation getKindAttr ls := (map (fun x => (fst x, projT1 (snd x))) ls). Definition getRegFileRegisters m := match m with | @Build_RegFileBase isWrMask num dataArray readers write IdxNum Data init => (dataArray, existT RegInitValT (SyntaxKind (Array IdxNum Data)) match init with | RFNonFile x => match x with | None => None | Some init' => Some (SyntaxConst (ConstArray (fun _ => init'))) end | RFFile isAscii isArg file offset size init => Some (SyntaxConst (ConstArray init)) end) :: match readers with | Async _ => nil | Sync isAddr read => if isAddr then map (fun x => (readRegName x, existT RegInitValT (SyntaxKind (Bit (Nat.log2_up IdxNum))) None)) read else map (fun x => (readRegName x, existT RegInitValT (SyntaxKind (Array num Data)) None)) read end end. Definition getRegisters m := match m with | BaseRegFile rf => getRegFileRegisters rf | BaseMod regs rules dms => regs end. Fixpoint getRules m := match m with | BaseRegFile rf => nil | BaseMod regs rules dms => rules end. Definition getStruct ls := (Struct (fun i => snd (nth_Fin ls i)) (fun j => fst (nth_Fin ls j))). Arguments getStruct : simpl never. Definition getStructVal ty ls := (BuildStruct (fun i => snd (nth_Fin (map (@projT1 _ _) ls) i)) (fun j => fst (nth_Fin (map (@projT1 _ _) ls) j)) (fun k => nth_Fin_map2 (@projT1 _ _) (fun x => Expr ty (SyntaxKind (snd x))) ls k (projT2 (nth_Fin ls (Fin.cast k (map_length_red (@projT1 _ _) ls)))))). Arguments getStructVal : simpl never. Definition getStructConst ls := (ConstStruct (fun i => snd (nth_Fin (map (@projT1 _ _) ls) i)) (fun j => fst (nth_Fin (map (@projT1 _ _) ls) j)) (fun k => nth_Fin_map2 (@projT1 _ _) (fun x => ConstT (snd x)) ls k (projT2 (nth_Fin ls (Fin.cast k (map_length_red (@projT1 _ _) ls)))))). Arguments getStructConst : simpl never. Definition WriteRq lgIdxNum Data := (getStruct (cons ("addr", Bit lgIdxNum) (cons ("data", Data) nil))). (* STRUCT_TYPE { "addr" :: Bit lgIdxNum ; *) (* "data" :: Data }. *) Definition WriteRqMask lgIdxNum num Data := (getStruct (cons ("addr", Bit lgIdxNum) (cons ("data", Array num Data) (cons ("mask", Array num Bool) nil)))). (* Definition WriteRqMask lgIdxNum num Data := STRUCT_TYPE { "addr" :: Bit lgIdxNum ; *) (* "data" :: Array num Data ; *) (* "mask" :: Array num Bool }. *) Definition buildNumDataArray num dataArray IdxNum Data ty (idx: ty (Bit (Nat.log2_up IdxNum))) := ReadReg dataArray (SyntaxKind (Array IdxNum Data)) (fun val => Return (BuildArray (fun i: Fin.t num => ReadArray (Var ty _ val) (CABit Add (Var ty (SyntaxKind _) idx :: Const ty (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil))))). Definition updateNumDataArray num dataArray IdxNum Data ty (idxData: ty (WriteRq (Nat.log2_up IdxNum) (Array num Data))): ActionT ty Void := ReadReg dataArray (SyntaxKind (Array IdxNum Data)) (fun val => WriteReg dataArray (fold_left (fun newArr i => (UpdateArray newArr (CABit Add (ReadStruct (Var ty (SyntaxKind _) idxData) Fin.F1 :: Const ty (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil)) (ReadArrayConst (ReadStruct (Var ty (SyntaxKind _) idxData) (Fin.FS Fin.F1)) i))) (getFins num) (Var ty (SyntaxKind (Array IdxNum Data)) val)) (Return (Const _ WO))). Definition updateNumDataArrayMask num dataArray IdxNum Data ty (idxData: ty (WriteRqMask (Nat.log2_up IdxNum) num Data)): ActionT ty Void := ReadReg dataArray (SyntaxKind (Array IdxNum Data)) (fun val => WriteReg dataArray (fold_left (fun newArr i => ITE (ReadArrayConst (ReadStruct (Var ty (SyntaxKind _) idxData) (Fin.FS (Fin.FS Fin.F1))) i) (UpdateArray newArr (CABit Add (ReadStruct (Var ty (SyntaxKind _) idxData) Fin.F1 :: Const ty (natToWord _ (proj1_sig (Fin.to_nat i))) :: nil)) (ReadArrayConst (ReadStruct (Var ty (SyntaxKind _) idxData) (Fin.FS Fin.F1)) i)) newArr ) (getFins num) (Var ty (SyntaxKind (Array IdxNum Data)) val)) (Return (Const _ WO))). Definition readRegFile num dataArray (read: list string) IdxNum Data := (map (fun x => (x, existT MethodT (Bit (Nat.log2_up IdxNum), Array num Data) (buildNumDataArray num dataArray IdxNum Data))) read). Definition writeRegFileFn (isWrMask: bool) num dataArray (write: string) IdxNum Data := (write, if isWrMask then existT MethodT (WriteRqMask (Nat.log2_up IdxNum) num Data, Void) (updateNumDataArrayMask num dataArray IdxNum Data) else existT MethodT (WriteRq (Nat.log2_up IdxNum) (Array num Data), Void) (updateNumDataArray num dataArray IdxNum Data)). Definition readSyncRegFile (isAddr: bool) num dataArray (read: list SyncRead) IdxNum Data := if isAddr then ((map (fun r => (readReqName r, existT MethodT (Bit (Nat.log2_up IdxNum), Void) (fun ty idx => WriteReg (readRegName r) (Var ty (SyntaxKind _) idx) (Return (Const _ WO)))))) read) ++ (map (fun r => (readResName r, existT MethodT (Void, Array num Data) (fun ty _ => ReadReg (readRegName r) (SyntaxKind (Bit (Nat.log2_up IdxNum))) (buildNumDataArray num dataArray IdxNum Data ty)))) read) else ((map (fun r => (readReqName r, existT MethodT (Bit (Nat.log2_up IdxNum), Void) (fun ty idx => LetAction (buildNumDataArray num dataArray IdxNum Data ty idx) (fun vals => WriteReg (readRegName r) (Var ty (SyntaxKind _) vals) (Return (Const _ WO)))))) read) ++ (map (fun r => (readResName r, existT MethodT (Void, Array num Data) (fun ty x => ReadReg (readRegName r) (SyntaxKind (Array num Data)) (fun data => Return (Var ty (SyntaxKind (Array num Data)) data))))) read)). Definition getRegFileMethods m := match m with | @Build_RegFileBase isWrMask num dataArray readers write IdxNum Data init => writeRegFileFn isWrMask num dataArray write IdxNum Data :: match readers with | Async read => readRegFile num dataArray read IdxNum Data | Sync isAddr read => readSyncRegFile isAddr num dataArray read IdxNum Data end end. Fixpoint getMethods m := match m with | BaseRegFile rf => getRegFileMethods rf | BaseMod regs rules dms => dms end. Fixpoint getAllRegisters m := match m with | Base m' => getRegisters m' | HideMeth m' s => getAllRegisters m' | ConcatMod m1 m2 => getAllRegisters m1 ++ getAllRegisters m2 end. Fixpoint getAllRules m := match m with | Base m' => getRules m' | HideMeth m' s => getAllRules m' | ConcatMod m1 m2 => getAllRules m1 ++ getAllRules m2 end. Fixpoint getAllMethods m := match m with | Base m' => getMethods m' | HideMeth m' s => getAllMethods m' | ConcatMod m1 m2 => getAllMethods m1 ++ getAllMethods m2 end. Fixpoint getHidden m := match m with | Base _ => [] | ConcatMod m1 m2 => getHidden m1 ++ getHidden m2 | HideMeth m' s => s :: getHidden m' end. Section WfBaseMod. Variable ty : Kind -> Type. Section WfActionT. Variable regs : list (string * {x : FullKind & RegInitValT x}). Inductive WfActionT: forall lretT, ActionT ty lretT -> Prop := | WfMCall meth s e lretT c: (forall v, WfActionT (c v)) -> @WfActionT lretT (MCall meth s e c) | WfLetExpr k (e: Expr ty k) lretT c: (forall v, WfActionT (c v)) -> @WfActionT lretT (LetExpr e c) | WfLetAction k (a: ActionT ty k) lretT c: WfActionT a -> (forall v, WfActionT (c v)) -> @WfActionT lretT (LetAction a c) | WfReadNondet k lretT c: (forall v, WfActionT (c v)) -> @WfActionT lretT (ReadNondet k c) | WfReadReg r k lretT c: (forall v, WfActionT (c v)) -> In (r, k) (getKindAttr regs) -> @WfActionT lretT (ReadReg r k c) | WfWriteReg r k (e: Expr ty k) lretT c: WfActionT c -> In (r, k) (getKindAttr regs) -> @WfActionT lretT (WriteReg r e c) | WfIfElse p k (atrue: ActionT ty k) afalse lretT c: (forall v, WfActionT (c v)) -> WfActionT atrue -> WfActionT afalse -> @WfActionT lretT (IfElse p atrue afalse c) | WfSys ls lretT c: WfActionT c -> @WfActionT lretT (Sys ls c) | WfReturn lretT e: @WfActionT lretT (Return e). Definition lookup{K X} : (K -> K -> bool) -> K -> list (K * X) -> option X := fun eqbk key pairs => match List.find (fun p => eqbk key (fst p)) pairs with | Some p => Some (snd p) | None => None end. Lemma lookup_cons : forall K V (eqb : K -> K -> bool) k k' v (ps : list (K*V)), lookup eqb k ((k',v)::ps) = if eqb k k' then Some v else lookup eqb k ps. Proof. intros. unfold lookup. unfold find. simpl. destruct (eqb k k'); auto. Qed. Fixpoint WfActionT_new{k}(a : ActionT ty k) : Prop := match a with | MCall meth s e cont => forall x, WfActionT_new (cont x) | LetExpr k e cont => forall x, WfActionT_new (cont x) | LetAction k a cont => (WfActionT_new a /\ forall x, WfActionT_new (cont x)) | ReadNondet k cont => forall x, WfActionT_new (cont x) | ReadReg r k' cont => match lookup String.eqb r regs with | None => False | Some (existT k'' _) => k' = k'' /\ forall x, WfActionT_new (cont x) end | WriteReg r k' e a => match lookup String.eqb r regs with | None => False | Some (existT k'' _) => k' = k'' /\ WfActionT_new a end | IfElse e k1 a1 a2 cont => (WfActionT_new a1 /\ WfActionT_new a2 /\ forall x, WfActionT_new (cont x)) | Sys _ a => WfActionT_new a | Return _ => True end. Fixpoint WfRules(rules : list RuleT) := match rules with | [] => True | r::rs => WfActionT_new (snd r ty) /\ WfRules rs end. Fixpoint WfMeths(meths : list (string * {x : Signature & MethodT x})) := match meths with | [] => True | m::ms => (forall v, WfActionT_new (projT2 (snd m) ty v)) /\ WfMeths ms end. End WfActionT. Definition WfBaseModule (m : BaseModule) := (forall rule, In rule (getRules m) -> WfActionT (getRegisters m) (snd rule ty)) /\ (forall meth, In meth (getMethods m) -> forall v, WfActionT (getRegisters m) (projT2 (snd meth) ty v)) /\ NoDup (map fst (getMethods m)) /\ NoDup (map fst (getRegisters m)) /\ NoDup (map fst (getRules m)). Definition WfBaseModule_new(m : BaseModule) := (WfRules (getRegisters m) (getRules m)) /\ (WfMeths (getRegisters m) (getMethods m)) /\ (NoDup (map fst (getMethods m))) /\ (NoDup (map fst (getRegisters m))) /\ (NoDup (map fst (getRules m))). Section WfActionT'. Variable m : BaseModule. Inductive WfActionT': forall lretT, ActionT type lretT -> Prop := | WfMCall' meth s e lretT c v: (WfActionT' (c v)) -> @WfActionT' lretT (MCall meth s e c) | WfLetExpr' k (e: Expr type k) lretT c v: (WfActionT' (c v)) -> @WfActionT' lretT (LetExpr e c) | WfLetAction' k (a: ActionT type k) lretT c v: WfActionT' a -> (WfActionT' (c v)) -> @WfActionT' lretT (LetAction a c) | WfReadNondet' k lretT c v: (WfActionT' (c v)) -> @WfActionT' lretT (ReadNondet k c) | WfReadReg' r k lretT c v: (WfActionT' (c v)) -> In (r, k) (getKindAttr (getRegisters m)) -> @WfActionT' lretT (ReadReg r k c) | WfWriteReg' r k (e: Expr type k) lretT c: WfActionT' c -> In (r, k) (getKindAttr (getRegisters m)) -> @WfActionT' lretT (WriteReg r e c) | WfIfElse' p k (atrue: ActionT type k) afalse lretT c v: (WfActionT' (c v)) -> WfActionT' atrue -> WfActionT' afalse -> @WfActionT' lretT (IfElse p atrue afalse c) | WfSys' ls lretT c: WfActionT' c -> @WfActionT' lretT (Sys ls c) | WfReturn' lretT e: @WfActionT' lretT (Return e). End WfActionT'. End WfBaseMod. Lemma WfLetExprSyntax k m (e: LetExprSyntax type k): WfActionT (getRegisters m) (convertLetExprSyntax_ActionT e). Proof. induction e; constructor; auto. Qed. Lemma WfLetExprSyntax_new k m (e: LetExprSyntax type k): WfActionT_new (getRegisters m) (convertLetExprSyntax_ActionT e). Proof. induction e; simpl; repeat split; auto. Qed. Section WfBaseModProofs. Lemma In_getKindAttr : forall r k (regs : list (string * {x : FullKind & RegInitValT x})), In (r,k) (getKindAttr regs) -> In r (map fst regs). Proof. intros. rewrite in_map_iff in H. dest. inv H. apply in_map; auto. Qed. Lemma In_lookup : forall r k (regs : list (string * {x : FullKind & RegInitValT x})), NoDup (map fst regs) -> In (r,k) (getKindAttr regs) -> exists k' v, k = k' /\ lookup String.eqb r regs = Some (existT _ k' v). Proof. induction regs; intros. - destruct H0. - destruct H0. + destruct a. destruct s0. destruct r0. * inversion H0. exists x; eexists. split. ** auto. ** unfold lookup; simpl. rewrite String.eqb_refl. reflexivity. * inversion H0. exists k; eexists. split. ** auto. ** unfold lookup; simpl. rewrite String.eqb_refl. simpl. reflexivity. + assert (NoDup (map fst regs)). inversion H; auto. destruct (IHregs H1 H0) as [k' [v [Hk' Hv]]]. exists k', v. split. * auto. * destruct a. destruct s0. destruct r0. ** rewrite lookup_cons. destruct (r =? s) eqn:G. *** rewrite String.eqb_eq in G. rewrite <- G in H. inversion H. elim H4. eapply In_getKindAttr. exact H0. *** auto. ** rewrite lookup_cons. destruct (r =? s) eqn:G. *** rewrite String.eqb_eq in G. rewrite <- G in H. inversion H. elim H4. eapply In_getKindAttr. exact H0. *** auto. Qed. Lemma lookup_In : forall r k v regs, lookup String.eqb r (regs) = Some (existT RegInitValT k v) -> In (r,k) (getKindAttr regs). Proof. induction regs; intros. - discriminate H. - destruct a. destruct s0. rewrite lookup_cons in H. + destruct (r =? s) eqn:G. * rewrite String.eqb_eq in G. inversion H. left; simpl; congruence. * right. apply IHregs. auto. Qed. Lemma WfActionT_WfActionT_new{ty lret} : forall regs (a : ActionT ty lret), NoDup (map fst regs) -> WfActionT regs a -> WfActionT_new regs a. Proof. intros. induction a; simpl; intros. - apply H1. inversion H0. EqDep_subst. apply H4. - apply H1. inversion H0. EqDep_subst. apply H4. - inversion H0. split. + apply IHa. EqDep_subst. auto. + EqDep_subst. intro. auto. - inversion H0. apply H1. EqDep_subst. auto. - inversion H0. unfold getRegisters in H7. destruct (In_lookup _ _ _ H H7) as [k' [v [Hk Hv]]]. rewrite Hv. split. + auto. + intro. apply H1. EqDep_subst. apply H5. - inversion H0. unfold getRegisters in H7. destruct (In_lookup _ _ _ H H7) as [k' [v [Hk Hv]]]. rewrite Hv. split. + auto. + apply IHa. EqDep_subst; auto. - inversion H0. repeat split. + apply IHa1. EqDep_subst. auto. + apply IHa2. EqDep_subst. auto. + intro; apply H1. EqDep_subst. apply H6. - apply IHa. inversion H0. EqDep_subst. auto. - auto. Qed. Lemma wf_rules_In : forall ty regs rules, NoDup (map fst regs) -> (forall rule : RuleT, In rule rules -> WfActionT regs (snd rule ty)) -> WfRules ty regs rules. Proof. induction rules; intros. - simpl; auto. - simpl. split. + eapply WfActionT_WfActionT_new. * auto. * apply H0; left; auto. + eapply IHrules. * auto. * intros. apply H0. right; auto. Qed. Lemma wf_meths_In : forall ty regs dms, NoDup (map fst regs) -> (forall (meth : string * {x : Signature & MethodT x}), In meth dms -> forall v : ty (fst (projT1 (snd meth))), WfActionT regs (projT2 (snd meth) ty v)) -> WfMeths ty regs dms. Proof. induction dms; intros. - simpl; auto. - simpl. split. + intro; eapply WfActionT_WfActionT_new; auto. apply H0. left; auto. + eapply IHdms. * auto. * intros. apply H0. right; auto. Qed. (* Lemma wf_meths_In_BaseRegFile : forall ty rfs (ms : list (string * {x : Signature & MethodT x})), NoDup (map fst (getRegisters (BaseRegFile rfs))) -> (forall meth, In meth ms -> forall v : ty (fst (projT1 (snd meth))) , WfActionT (BaseRegFile rfs) (projT2 (snd meth) ty v)) -> WfMeths (BaseRegFile rfs) ty ms. Proof. induction ms; intros. - simpl; auto. - simpl; split. + intro; eapply WfActionT_WfActionT_new. * auto. * apply H0. left; auto. + apply IHms; auto. intros; apply H0; right; auto. Qed. *) Lemma WfBaseModule_WfBaseModule_new : forall ty bm, WfBaseModule ty bm -> WfBaseModule_new ty bm. Proof. intros ty bm [wf_actions [wf_meths [nodup_meths [nodup_regs nodup_rules]]]]. unfold WfBaseModule_new. repeat split; auto. - destruct bm. + exact I. + simpl; eapply wf_rules_In; auto. - eapply wf_meths_In; auto. Qed. Lemma WfActionT_new_WfActionT{ty lret} : forall (a : ActionT ty lret) m, WfActionT_new m a -> WfActionT m a. Proof. intros. induction a; simpl in *. - apply WfMCall. intro; apply H0; apply H. - apply WfLetExpr. intro; apply H0; apply H. - apply WfLetAction. + apply IHa; tauto. + intro; apply H0; apply H. - apply WfReadNondet. intro; apply H0; apply H. - apply WfReadReg. + intro; apply H0. destruct lookup. * destruct s; apply H. * destruct H. + destruct lookup eqn:G. * destruct s. destruct H. rewrite H. unfold getRegisters. eapply lookup_In. exact G. * destruct H. - apply WfWriteReg. + apply IHa. destruct lookup. * destruct s; apply H. * destruct H. + destruct lookup eqn:G. * destruct s. destruct H. rewrite H. unfold getRegisters. eapply lookup_In. exact G. * destruct H. - apply WfIfElse. + intro; apply H0; apply H. + tauto. + tauto. - apply WfSys; tauto. - apply WfReturn. Qed. Lemma WfActionT_new_WfActionT_iff{ty lret} : forall (a : ActionT ty lret) m, NoDup (map fst m) -> WfActionT_new m a <-> WfActionT m a. Proof. intros; split; intro. - apply WfActionT_new_WfActionT; auto. - apply WfActionT_WfActionT_new; auto. Qed. Lemma In_wf_rules : forall ty regs rules, NoDup (map fst regs) -> WfRules ty regs rules -> (forall rule : RuleT, In rule rules -> WfActionT regs (snd rule ty)). Proof. induction rules; intros. - destruct H1. - simpl in H0; destruct H0. destruct H1. + eapply WfActionT_new_WfActionT; congruence. + apply IHrules; auto. Qed. Lemma In_wf_meths : forall ty regs dms, NoDup (map fst regs) -> WfMeths ty regs dms -> forall meth : string * {x : Signature & MethodT x}, In meth dms -> forall v : ty (fst (projT1 (snd meth))), WfActionT regs (projT2 (snd meth) ty v). Proof. induction dms; intros. - destruct H1. - simpl in H0; destruct H0. destruct H1. + eapply WfActionT_new_WfActionT. rewrite H1 in H0. apply H0. + apply IHdms; auto. Qed. Lemma WfBaseModule_new_WfBaseModule : forall ty bm, WfBaseModule_new ty bm -> WfBaseModule ty bm. Proof. intros ty bm [wf_actions [wf_meths [nodup_meths [nodup_regs nodup_rules]]]]. unfold WfBaseModule. repeat split; auto. - intros. + eapply In_wf_rules; eauto. - intros. + eapply In_wf_meths; eauto. Qed. Lemma WfBaseModule_WfBaseModule_new_iff : forall ty bm, WfBaseModule ty bm <-> WfBaseModule_new ty bm. Proof. intros ty bm; split; intro. - apply WfBaseModule_WfBaseModule_new; auto. - apply WfBaseModule_new_WfBaseModule; auto. Qed. End WfBaseModProofs. Inductive WfConcatActionT{ty} : forall lretT, ActionT ty lretT -> Mod -> Prop := | WfConcatMCall meth s e lretT c m' :(forall v, WfConcatActionT (c v) m') -> ~In meth (getHidden m') -> @WfConcatActionT ty lretT (MCall meth s e c) m' | WfConcatLetExpr k (e : Expr ty k) lretT c m' : (forall v, WfConcatActionT (c v) m') -> @WfConcatActionT ty lretT (LetExpr e c) m' | WfConcatLetAction k (a : ActionT ty k) lretT c m' : WfConcatActionT a m' -> (forall v, WfConcatActionT (c v) m') -> @WfConcatActionT ty lretT (LetAction a c) m' | WfConcatReadNondet k lretT c m': (forall v, WfConcatActionT (c v) m') -> @WfConcatActionT ty lretT (ReadNondet k c) m' | WfConcatReadReg r k lretT c m': (forall v, WfConcatActionT (c v) m') -> @WfConcatActionT ty lretT (ReadReg r k c) m' | WfConcatWriteReg r k (e: Expr ty k) lretT c m': WfConcatActionT c m' -> @WfConcatActionT ty lretT (WriteReg r e c) m' | WfConcatIfElse p k (atrue: ActionT ty k) afalse lretT c m': (forall v, WfConcatActionT (c v) m') -> WfConcatActionT atrue m' -> WfConcatActionT afalse m' -> @WfConcatActionT ty lretT (IfElse p atrue afalse c) m' | WfConcatSys ls lretT c m': WfConcatActionT c m' -> @WfConcatActionT ty lretT (Sys ls c) m' | WfConcatReturn lretT e m': @WfConcatActionT ty lretT (Return e) m'. Fixpoint WfConcatActionT_new{ty lret}(a : ActionT ty lret)(m : Mod) : Prop := match a with | MCall meth s e cont => (~In meth (getHidden m)) /\ forall x, WfConcatActionT_new (cont x) m | LetExpr k e cont => forall x, WfConcatActionT_new (cont x) m | LetAction k a cont => WfConcatActionT_new a m /\ forall x, WfConcatActionT_new (cont x) m | ReadNondet k cont => forall x, WfConcatActionT_new (cont x) m | ReadReg r k cont => forall x, WfConcatActionT_new (cont x) m | WriteReg r k e a => WfConcatActionT_new a m | IfElse e k a1 a2 cont => WfConcatActionT_new a1 m /\ WfConcatActionT_new a2 m /\ forall x, WfConcatActionT_new (cont x) m | Sys _ a => WfConcatActionT_new a m | Return _ => True end. Lemma WfConcatActionT_WfConcatActionT_new : forall ty lret m (a : ActionT ty lret), WfConcatActionT a m -> WfConcatActionT_new a m. Proof. intros ty lret m a wf_a. induction a; inversion wf_a; simpl; EqDep_subst; auto. Qed. Lemma WfConcatActionT_new_WfConcatActionT : forall ty lret m (a : ActionT ty lret), WfConcatActionT_new a m -> WfConcatActionT a m. Proof. intros ty lret m a wf_a. induction a; simpl in wf_a; econstructor; auto; try tauto. - intro; apply H; apply wf_a. - intro; apply H; apply wf_a. - intro; apply H; apply wf_a; auto. Qed. Lemma WfConcatActionT_WfConcatActionT_new_iff : forall ty lret m (a : ActionT ty lret), WfConcatActionT a m <-> WfConcatActionT_new a m. Proof. intros ty lret m a; split; intro. - apply WfConcatActionT_WfConcatActionT_new; auto. - apply WfConcatActionT_new_WfConcatActionT; auto. Qed. Definition WfConcat ty m m' := (forall rule, In rule (getAllRules m) -> WfConcatActionT (snd rule ty) m') /\ (forall meth, In meth (getAllMethods m) -> forall v, WfConcatActionT (projT2 (snd meth) ty v) m'). Definition WfConcat_new ty m m' := (forall rule, In rule (getAllRules m) -> WfConcatActionT_new (snd rule ty) m') /\ (forall meth, In meth (getAllMethods m) -> forall v, WfConcatActionT_new (projT2 (snd meth) ty v) m'). Lemma WfConcat_WfConcat_new_iff : forall ty m m', WfConcat ty m m' <-> WfConcat_new ty m m'. Proof. unfold WfConcat, WfConcat_new; intros; repeat split; intros; destruct H. - rewrite <- WfConcatActionT_WfConcatActionT_new_iff; auto. - rewrite <- WfConcatActionT_WfConcatActionT_new_iff; auto. - rewrite WfConcatActionT_WfConcatActionT_new_iff; auto. - rewrite WfConcatActionT_WfConcatActionT_new_iff; auto. Qed. Section WfMod. Variable ty : Kind -> Type. Inductive WfMod : Mod -> Prop := | BaseWf m (HWfBaseModule: WfBaseModule ty m): WfMod (Base m) | HideMethWf m s (HHideWf: In s (map fst (getAllMethods m))) (HWf: WfMod m): WfMod (HideMeth m s) | ConcatModWf m1 m2 (HDisjRegs: DisjKey (getAllRegisters m1) (getAllRegisters m2)) (HDisjRules: DisjKey (getAllRules m1) (getAllRules m2)) (HDisjMeths: DisjKey (getAllMethods m1) (getAllMethods m2)) (HWf1: WfMod m1) (HWf2: WfMod m2)(WfConcat1: WfConcat ty m1 m2) (WfConcat2 : WfConcat ty m2 m1): WfMod (ConcatMod m1 m2). Fixpoint WfMod_new(m : Mod) : Prop := match m with | Base m => WfBaseModule_new ty m | HideMeth m s => In s (map fst (getAllMethods m)) /\ WfMod_new m | ConcatMod m1 m2 => DisjKey (getAllRegisters m1) (getAllRegisters m2) /\ DisjKey (getAllRules m1) (getAllRules m2) /\ DisjKey (getAllMethods m1) (getAllMethods m2) /\ WfMod_new m1 /\ WfMod_new m2 /\ WfConcat_new ty m1 m2 /\ WfConcat_new ty m2 m1 end. End WfMod. Lemma WfMod_WfMod_new : forall ty m, WfMod ty m -> WfMod_new ty m. Proof. intros ty m wf_m; induction m; inversion wf_m; simpl. - rewrite <- WfBaseModule_WfBaseModule_new_iff; auto. - auto. - repeat rewrite <- WfConcat_WfConcat_new_iff; tauto. Qed. Lemma WfMod_new_WfMod : forall ty m, WfMod_new ty m -> WfMod ty m. Proof. intros ty m wf_m; induction m; inversion wf_m; simpl. - econstructor; auto; simpl in wf_m. unfold WfBaseModule. unfold WfBaseModule_new in wf_m; dest. repeat split; try auto. + intro; apply In_wf_rules; auto. + intro; apply In_wf_meths; auto. - econstructor; auto. - repeat rewrite <- WfConcat_WfConcat_new_iff in H0; econstructor; try tauto. Qed. Lemma WfMod_new_WfMod_iff : forall ty m, WfMod_new ty m <-> WfMod ty m. Proof. intros ty m; split; eauto using WfMod_new_WfMod, WfMod_WfMod_new. Qed. Record ModWf ty : Type := { module :> Mod; wfMod : WfMod ty module }. Record ModWf_new ty : Type := { module_new :> Mod; wfMod_new : WfMod_new ty module_new }. Record ModWfOrd ty := { modWf :> ModWf ty; modOrd : list string }. Record ModWfOrd_new ty := { modWf_new :> ModWf_new ty; modOrd_new : list string }. Record BaseModuleWf ty := { baseModule :> BaseModule ; wfBaseModule : WfBaseModule ty baseModule }. Record BaseModuleWf_new ty := { baseModule_new :> BaseModule ; wfBaseModule_new : WfBaseModule_new ty baseModule_new }. Record BaseModuleWfOrd ty := { baseModuleWf :> BaseModuleWf ty; baseModuleOrd : list string }. Record BaseModuleWfOrd_new ty := { baseModuleWf_new :> BaseModuleWf_new ty ; baseModuleOrd_new : list string }. Definition getModWf ty (m: BaseModuleWf ty) := {| module := m; wfMod := BaseWf (wfBaseModule m) |}. Definition getModWfOrd ty (m: BaseModuleWfOrd ty) := {| modWf := getModWf m; modOrd := baseModuleOrd m |}. Coercion getModWf: BaseModuleWf >-> ModWf. Coercion getModWfOrd: BaseModuleWfOrd >-> ModWfOrd. Section NoCallActionT. Variable ls: list DefMethT. Variable ty : Kind -> Type. Inductive NoCallActionT: forall k , ActionT ty k -> Prop := | NoCallMCall meth s e lretT c: ~ In (meth, s) (getKindAttr ls) -> (forall v, NoCallActionT (c v)) -> @NoCallActionT lretT (MCall meth s e c) | NoCallLetExpr k (e: Expr ty k) lretT c: (forall v, NoCallActionT (c v)) -> @NoCallActionT lretT (LetExpr e c) | NoCallLetAction k (a: ActionT ty k) lretT c: NoCallActionT a -> (forall v, NoCallActionT (c v)) -> @NoCallActionT lretT (LetAction a c) | NoCallReadNondet k lretT c: (forall v, NoCallActionT (c v)) -> @NoCallActionT lretT (ReadNondet k c) | NoCallReadReg r k lretT c: (forall v, NoCallActionT (c v)) -> @NoCallActionT lretT (ReadReg r k c) | NoCallWriteReg r k (e: Expr ty k) lretT c: NoCallActionT c -> @NoCallActionT lretT (WriteReg r e c) | NoCallIfElse p k (atrue: ActionT ty k) afalse lretT c: (forall v, NoCallActionT (c v)) -> NoCallActionT atrue -> NoCallActionT afalse -> @NoCallActionT lretT (IfElse p atrue afalse c) | NoCallSys ls lretT c: NoCallActionT c -> @NoCallActionT lretT (Sys ls c) | NoCallReturn lretT e: @NoCallActionT lretT (Return e). End NoCallActionT. Section NoSelfCallBaseModule. Variable m: BaseModule. Definition NoSelfCallRuleBaseModule (rule : Attribute (Action Void)) := forall ty, NoCallActionT (getMethods m) (snd rule ty). Definition NoSelfCallRulesBaseModule := forall rule ty, In rule (getRules m) -> NoCallActionT (getMethods m) (snd rule ty). Definition NoSelfCallMethsBaseModule := forall meth ty, In meth (getMethods m) -> forall (arg: ty (fst (projT1 (snd meth)))), NoCallActionT (getMethods m) (projT2 (snd meth) ty arg). Definition NoSelfCallBaseModule := NoSelfCallRulesBaseModule /\ NoSelfCallMethsBaseModule. End NoSelfCallBaseModule. (* Semantics *) Definition mk_eq : forall m n, (m =? n)%nat = true -> m = n. Proof. induction m. - destruct n. + auto. + intro; discriminate. - destruct n. + intro; discriminate. + simpl. intro. f_equal. apply IHm. exact H. Defined. Fixpoint Kind_decb(k1 k2 : Kind) : bool. Proof. refine ( match k1,k2 with | Bool, Bool => true | Bit n, Bit m => Nat.eqb n m | Array n k, Array m k' => Nat.eqb n m && Kind_decb k k' | Struct n ks fs, Struct m ks' fs' => _ | _,_ => false end). destruct (Nat.eqb n m) eqn:G. exact (Fin_forallb (fun i => Kind_decb (ks i) (ks' (Fin_cast i (mk_eq _ _ G)))) && Fin_forallb (fun i => String.eqb (fs i) (fs' (Fin_cast i (mk_eq _ _ G))))). exact false. Defined. Lemma Kind_decb_refl : forall k, Kind_decb k k = true. Proof. induction k; simpl; auto. - apply Nat.eqb_refl. - rewrite silly_lemma_true with (pf := (Nat.eqb_refl _)) by apply Nat.eqb_refl. rewrite andb_true_iff; split; rewrite Fin_forallb_correct; intros. + rewrite (hedberg Nat.eq_dec _ eq_refl); simpl; apply H. + rewrite (hedberg Nat.eq_dec _ eq_refl); simpl; apply String.eqb_refl. - rewrite andb_true_iff; split; auto. apply Nat.eqb_refl. Qed. Lemma Kind_decb_eq : forall k1 k2, Kind_decb k1 k2 = true <-> k1 = k2. Proof. induction k1; intros; destruct k2; split; intro; try (reflexivity || discriminate). - simpl in H; rewrite Nat.eqb_eq in H; congruence. - inversion H; simpl; apply Nat.eqb_refl. - destruct (n =? n0)%nat eqn:G. + simpl in H0. rewrite (@silly_lemma_true bool (n =? n0)%nat _ _ G) in H0 by auto. pose proof G. rewrite Nat.eqb_eq in H1 by auto. rewrite andb_true_iff in H0; destruct H0 as [G1 G2]; rewrite Fin_forallb_correct in G1,G2; subst. rewrite (hedberg Nat.eq_dec _ eq_refl) in G1,G2; simpl in *. setoid_rewrite H in G1. setoid_rewrite String.eqb_eq in G2. f_equal; extensionality i; auto. + simpl in H0. rewrite silly_lemma_false in H0; try discriminate; auto. - rewrite H0; apply Kind_decb_refl. - simpl in H; rewrite andb_true_iff in H. destruct H as [H1 H2]; rewrite Nat.eqb_eq in H1; rewrite IHk1 in H2; congruence. - simpl. rewrite andb_true_iff; inversion H; split. + apply Nat.eqb_refl. + rewrite <- H2, IHk1; reflexivity. Qed. Lemma Kind_dec (k1 k2 : Kind): {k1 = k2} + {k1 <> k2}. Proof. destruct (Kind_decb k1 k2) eqn:G. left; abstract (rewrite Kind_decb_eq in G; auto). right; abstract (intro; rewrite <- Kind_decb_eq in H; rewrite H in G; discriminate). Defined. Definition Signature_decb : Signature -> Signature -> bool := fun '(k,l) '(k',l') => Kind_decb k k' && Kind_decb l l'. Lemma Signature_decb_eq : forall s1 s2, Signature_decb s1 s2 = true <-> s1 = s2. Proof. intros [] []; simpl; rewrite andb_true_iff; repeat rewrite Kind_decb_eq; firstorder congruence. Qed. Definition Signature_dec (s1 s2 : Signature) : {s1 = s2} + {s1 <> s2}. Proof. destruct (Signature_decb s1 s2) eqn:G. left; abstract (rewrite <- Signature_decb_eq; auto). right; (intro; rewrite <- Signature_decb_eq in H; rewrite H in G; discriminate). Defined. Lemma isEq k: forall (e1: type k) (e2: type k), {e1 = e2} + {e1 <> e2}. Proof. induction k; intros. - apply bool_dec. - apply weq. - induction n. + left. extensionality x. apply Fin.case0. apply x. + destruct (IHn (fun i => k (Fin.FS i)) (fun i => X (Fin.FS i)) (fun i => s (Fin.FS i)) (fun i => e1 (Fin.FS i)) (fun i => e2 (Fin.FS i))). * destruct (X Fin.F1 (e1 Fin.F1) (e2 Fin.F1)). -- left. extensionality x. apply (Fin.caseS' x); try assumption; apply equal_f_dep; assumption. -- right; intro; subst. apply (n0 eq_refl). * right; intro; subst. apply (n0 eq_refl). - induction n. + left. extensionality x. apply Fin.case0. apply x. + simpl in *. destruct (IHn (fun i => e1 (Fin.FS i)) (fun i => e2 (Fin.FS i))). * destruct (IHk (e1 Fin.F1) (e2 Fin.F1)). -- left. extensionality x. apply (Fin.caseS' x); try assumption; apply equal_f; assumption. -- right; intro; subst. apply (n0 eq_refl). * right; intro; subst. apply (n0 eq_refl). Defined. Definition evalUniBool (op: UniBoolOp) : bool -> bool := match op with | Neg => negb end. Definition evalCABool (op: CABoolOp) (ws : list bool) : bool := match op with | And => fold_left andb ws true (* | Or => fold_left orb ws false *) | Xor => fold_left xorb ws false end. Definition evalUniBit n1 n2 (op: UniBitOp n1 n2): word n1 -> word n2 := match op with | Inv n => (@wnot n) | TruncLsb lsb msb => truncLsb | TruncMsb lsb msb => truncMsb | UAnd n => fun w => boolToWord 1 (@wuand n w) | UOr n => fun w => boolToWord 1 (@wuor n w) | UXor n => fun w => boolToWord 1 (@wuxor n w) end. Definition wneg_simple sz (x: word sz) := wnot x ^+ (natToWord _ 1). Definition wminus_simple sz (x y: word sz) := x ^+ (wneg_simple y). Lemma wneg_simple_wneg sz: forall (x: word sz), wneg_simple x = wneg x. Proof. unfold wneg_simple. intros. rewrite wneg_wnot. rewrite wminus_wplus_undo. reflexivity. Qed. Lemma wminus_simple_wminus sz: forall (x y: word sz), wminus_simple x y = wsub x y. Proof. unfold wminus_simple. intros. rewrite wneg_simple_wneg. rewrite wminus_def. reflexivity. Qed. Definition evalBinBit n1 n2 n3 (op: BinBitOp n1 n2 n3) : word n1 -> word n2 -> word n3 := match op with | Sub n => @wsub n | Div n => @wdiv n | Rem n => @wmod n | Sll n m => (fun x y => wslu x (ZToWord _ (wordVal _ y))) | Srl n m => (fun x y => wsru x (ZToWord _ (wordVal _ y))) | Sra n m => wsra | Concat n1 n2 => wconcat end. Definition evalCABit n (op: CABitOp) (ls: list (word n)): word n := match op with | Add => fold_left (@wadd n) ls (ZToWord n 0) | Mul => fold_left (@wmul n) ls (ZToWord n 1) | Band => fold_left (@wand n) ls (ZToWord n ((2 ^ (Z.of_nat n)) - 1)) (* | Bor => fold_left (@wor n) ls (ZToWord n 0) *) | Bxor => fold_left (@wxor n) ls (ZToWord n 0) end. Definition evalBinBitBool n1 n2 (op: BinBitBoolOp n1 n2) : word n1 -> word n2 -> bool := match op with | LessThan n => fun a b => @wltu n a b end. Definition evalConstFullT k (e: ConstFullT k) := match e in ConstFullT k return fullType type k with | SyntaxConst k' c' => evalConstT c' | NativeConst t c' => c' end. Fixpoint evalKorOpBin (k : Kind) : type k -> type k -> type k := match k in Kind return (type k -> type k -> type k) with | Bool => orb | Bit n => @wor n | Array n k' => fun a1 a2 => (fun i => (evalKorOpBin k' (a1 i) (a2 i))) | Struct n fv _ => fun (s1 s2 : forall i, type (fv i)) => (fun i => (evalKorOpBin (fv i) (s1 i) (s2 i))) end. Definition evalKorOp (k : Kind) : list (type k) -> type k -> type k := fold_left (evalKorOpBin k). (* maps register names to the values which they currently hold *) Notation RegT := (Attribute (sigT (fullType type))). Definition RegsT := (list RegT). (* a pair of the value sent to a method call and the value it returned *) Definition SignT k := (type (fst k) * type (snd k))%type. (* a list of simulatenous method call actions made during a single step *) Notation MethT := (Attribute (sigT SignT)). Definition MethsT := (list MethT). Section Semantics. Fixpoint evalExpr exprT (e: Expr type exprT): fullType type exprT := match e in Expr _ exprT return fullType type exprT with | Var _ v => v | Const _ v => evalConstT v | UniBool op e1 => (evalUniBool op) (@evalExpr _ e1) | CABool op es => evalCABool op (map (@evalExpr _) es) | UniBit n1 n2 op e1 => (evalUniBit op) (@evalExpr _ e1) | BinBit n1 n2 n3 op e1 e2 => (evalBinBit op) (@evalExpr _ e1) (@evalExpr _ e2) | CABit n op es => evalCABit op (map (@evalExpr _) es) | BinBitBool n1 n2 op e1 e2 => (evalBinBitBool op) (@evalExpr _ e1) (@evalExpr _ e2) | ITE _ p e1 e2 => if @evalExpr _ p then @evalExpr _ e1 else @evalExpr _ e2 | Eq _ e1 e2 => getBool (isEq _ (@evalExpr _ e1) (@evalExpr _ e2)) | ReadStruct n fk fs e i => (@evalExpr _ e) i | BuildStruct n fk fs fv => fun i => @evalExpr _ (fv i) | ReadArray n m k fv i => match lt_dec (Z.to_nat (wordVal _ (@evalExpr _ i))) n with | left pf => fun fv => fv (Fin.of_nat_lt pf) | right _ => fun _ => evalConstT (getDefaultConst k) end (@evalExpr _ fv) | ReadArrayConst n k fv i => (@evalExpr _ fv) i | BuildArray n k fv => fun i => @evalExpr _ (fv i) | Kor k e => evalKorOp k (map (@evalExpr _) e) (evalConstT (getDefaultConst k)) | ToNative _ e => evalExpr e | FromNative _ e => evalExpr e end. Arguments evalExpr : simpl nomatch. Fixpoint evalLetExpr k (e: LetExprSyntax type k) := match e in LetExprSyntax _ _ return type k with | NormExpr e' => evalExpr e' | SysE ls cont => evalLetExpr cont | LetE _ e' cont => evalLetExpr (cont (evalLetExpr e')) | IfElseE pred _ t f cont => evalLetExpr (cont (if evalExpr pred then evalLetExpr t else evalLetExpr f)) end. Variable o: RegsT. Inductive SemAction: forall k, ActionT type k -> RegsT -> RegsT -> MethsT -> type k -> Prop := | SemMCall meth s (marg: Expr type (SyntaxKind (fst s))) (mret: type (snd s)) retK (fret: type retK) (cont: type (snd s) -> ActionT type retK) readRegs newRegs (calls: MethsT) acalls (HAcalls: acalls = (meth, (existT _ _ (evalExpr marg, mret))) :: calls) (HSemAction: SemAction (cont mret) readRegs newRegs calls fret): SemAction (MCall meth s marg cont) readRegs newRegs acalls fret | SemLetExpr k (e: Expr type k) retK (fret: type retK) (cont: fullType type k -> ActionT type retK) readRegs newRegs calls (HSemAction: SemAction (cont (evalExpr e)) readRegs newRegs calls fret): SemAction (LetExpr e cont) readRegs newRegs calls fret | SemLetAction k (a: ActionT type k) (v: type k) retK (fret: type retK) (cont: type k -> ActionT type retK) readRegs newRegs readRegsCont newRegsCont calls callsCont (HDisjRegs: DisjKey newRegs newRegsCont) (HSemAction: SemAction a readRegs newRegs calls v) (HSemActionCont: SemAction (cont v) readRegsCont newRegsCont callsCont fret) uReadRegs uNewRegs uCalls (HReadRegs: uReadRegs = readRegs ++ readRegsCont) (HNewRegs: uNewRegs = newRegs ++ newRegsCont) (HCalls: uCalls = calls ++ callsCont): SemAction (LetAction a cont) uReadRegs uNewRegs uCalls fret | SemReadNondet valueT (valueV: fullType type valueT) retK (fret: type retK) (cont: fullType type valueT -> ActionT type retK) readRegs newRegs calls (HSemAction: SemAction (cont valueV) readRegs newRegs calls fret): SemAction (ReadNondet _ cont) readRegs newRegs calls fret | SemReadReg (r: string) regT (regV: fullType type regT) retK (fret: type retK) (cont: fullType type regT -> ActionT type retK) readRegs newRegs calls areadRegs (HRegVal: In (r, existT _ regT regV) o) (HSemAction: SemAction (cont regV) readRegs newRegs calls fret) (HNewReads: areadRegs = (r, existT _ regT regV) :: readRegs): SemAction (ReadReg r _ cont) areadRegs newRegs calls fret | SemWriteReg (r: string) k (e: Expr type k) retK (fret: type retK) (cont: ActionT type retK) readRegs newRegs calls anewRegs (HRegVal: In (r, k) (getKindAttr o)) (HDisjRegs: key_not_In r newRegs) (HANewRegs: anewRegs = (r, (existT _ _ (evalExpr e))) :: newRegs) (HSemAction: SemAction cont readRegs newRegs calls fret): SemAction (WriteReg r e cont) readRegs anewRegs calls fret | SemIfElseTrue (p: Expr type (SyntaxKind Bool)) k1 (a: ActionT type k1) (a': ActionT type k1) (r1: type k1) k2 (cont: type k1 -> ActionT type k2) readRegs1 readRegs2 newRegs1 newRegs2 calls1 calls2 (r2: type k2) (HDisjRegs: DisjKey newRegs1 newRegs2) (HTrue: evalExpr p = true) (HAction: SemAction a readRegs1 newRegs1 calls1 r1) (HSemAction: SemAction (cont r1) readRegs2 newRegs2 calls2 r2) ureadRegs unewRegs ucalls (HUReadRegs: ureadRegs = readRegs1 ++ readRegs2) (HUNewRegs: unewRegs = newRegs1 ++ newRegs2) (HUCalls: ucalls = calls1 ++ calls2) : SemAction (IfElse p a a' cont) ureadRegs unewRegs ucalls r2 | SemIfElseFalse (p: Expr type (SyntaxKind Bool)) k1 (a: ActionT type k1) (a': ActionT type k1) (r1: type k1) k2 (cont: type k1 -> ActionT type k2) readRegs1 readRegs2 newRegs1 newRegs2 calls1 calls2 (r2: type k2) (HDisjRegs: DisjKey newRegs1 newRegs2) (HFalse: evalExpr p = false) (HAction: SemAction a' readRegs1 newRegs1 calls1 r1) (HSemAction: SemAction (cont r1) readRegs2 newRegs2 calls2 r2) ureadRegs unewRegs ucalls (HUReadRegs: ureadRegs = readRegs1 ++ readRegs2) (HUNewRegs: unewRegs = newRegs1 ++ newRegs2) (HUCalls: ucalls = calls1 ++ calls2): SemAction (IfElse p a a' cont) ureadRegs unewRegs ucalls r2 | SemSys (ls: list (SysT type)) k (cont: ActionT type k) r readRegs newRegs calls (HSemAction: SemAction cont readRegs newRegs calls r): SemAction (Sys ls cont) readRegs newRegs calls r | SemReturn k (e: Expr type (SyntaxKind k)) evale (HEvalE: evale = evalExpr e) readRegs newRegs calls (HReadRegs: readRegs = nil) (HNewRegs: newRegs = nil) (HCalls: calls = nil) : SemAction (Return e) readRegs newRegs calls evale. End Semantics. Inductive RuleOrMeth := | Rle (rn: string) | Meth (f: MethT). Notation getRleOrMeth := (fun x => fst (snd x)). Notation FullLabel := (RegsT * (RuleOrMeth * MethsT))%type. Lemma SignT_dec: forall k1 k2 (s1 s2: SignT (k1, k2)), {s1 = s2} + {s1 <> s2}. Proof. intros. destruct s1, s2. simpl in *. apply prod_dec; simpl; auto; apply isEq. Defined. Section MethT_dec. (* Asserts that, if the values passed to, and returned by, a method are equal, the Gallina values passed to, and returned by, a method are also equal. *) Lemma method_values_eq : forall (s : Signature) (x y : SignT s), existT SignT s x = existT SignT s y -> x = y. Proof. intros. inv H. apply (Eqdep_dec.inj_pair2_eq_dec Signature Signature_dec SignT) in H1. auto. Qed. (* Asserts that the values passed to and returned by two method calls differ if their signatures differ. *) Lemma method_values_neq : forall (s r : Signature) (x : SignT s) (y : SignT r), s <> r -> existT SignT s x <> existT SignT r y. Proof. intros. unfold not. intros. inv H0. apply H; reflexivity. Qed. (*Proof (fun s r x y H H0 => H (projT1_eq H0)).*) (* Determines whether or not the Gallina terms passed to, and returned by, two method calls are equal. *) Definition method_denotation_values_dec : forall (s : Signature) (x y : SignT s), {x = y} + {x <> y} := fun s => prod_dec (isEq (fst s)) (isEq (snd s)). (* Determines whether or not the values passed to, and returned by, two method calls that have the same Kami signature are equal. *) Definition method_values_dec : forall (s : Signature) (x y : SignT s), {existT SignT s x = existT SignT s y} + {existT SignT s x <> existT SignT s y} := fun s x y => sumbool_rec (fun _ => {existT SignT s x = existT SignT s y} + {existT SignT s x <> existT SignT s y}) (fun H : x = y => left (eq_ind x (fun z => existT SignT s x = existT SignT s z) (eq_refl (existT SignT s x)) y H)) (fun H : x <> y => right (fun H0 : existT SignT s x = existT SignT s y => H (method_values_eq H0))) (method_denotation_values_dec x y). (* Determines whether or not the values passed to, and returned by, two method calls are equal. *) Definition sigT_SignT_dec : forall x y: (sigT SignT), {x = y} + {x <> y} := sigT_rect _ (fun (s : Signature) (x : SignT s) => sigT_rect _ (fun (r : Signature) => sumbool_rect _ (fun H : s = r => eq_rect s (fun t => forall y : SignT t, {existT SignT s x = existT SignT t y} + {existT SignT s x <> existT SignT t y}) (fun y : SignT s => method_values_dec x y) r H) (fun (H : s <> r) (_ : SignT r) => right (method_values_neq H)) (Signature_dec s r))). Lemma MethT_dec: forall s1 s2: MethT, {s1 = s2} + {s1 <> s2}. Proof. intros. destruct s1, s2. apply prod_dec. - apply string_dec. - apply sigT_SignT_dec. Defined. End MethT_dec. Fixpoint getNumFromCalls (f : MethT) (l : MethsT) : Z := match l with |g::l' => match MethT_dec f g with | left _ => 1%Z + (getNumFromCalls f l') | right _ => (getNumFromCalls f l') end |nil => 0 end. Definition getNumCalls (f : MethT) (l : list FullLabel) := getNumFromCalls f (concat (map (fun x => (snd (snd x))) l)). Fixpoint getNumFromExecs (f : MethT) (l : list RuleOrMeth) : Z := match l with |rm::l' => match rm with |Rle _ => (getNumFromExecs f l') |Meth g => match MethT_dec f g with |left _ => 1%Z + (getNumFromExecs f l') |right _ => (getNumFromExecs f l') end end |nil => 0 end. Definition getNumExecs (f : MethT) (l : list FullLabel) := getNumFromExecs f (map (fun x => fst (snd x)) l). Definition getListFullLabel_diff (f : MethT) (l : list FullLabel) := ((getNumExecs f l) - (getNumCalls f l))%Z. Definition MatchingExecCalls_Base (l : list FullLabel) m := forall f, In (fst f, projT1 (snd f)) (getKindAttr (getMethods m)) -> (getNumCalls f l <= getNumExecs f l)%Z. Definition MatchingExecCalls_Concat (lcall lexec : list FullLabel) mexec := forall f, (getNumCalls f lcall <> 0%Z) -> In (fst f, projT1 (snd f)) (getKindAttr (getAllMethods mexec)) -> ~In (fst f) (getHidden mexec) /\ (getNumCalls f lcall + getNumCalls f lexec <= getNumExecs f lexec)%Z. Section BaseModule. Variable m: BaseModule. Variable o: RegsT. Inductive Substeps: list FullLabel -> Prop := | NilSubstep (HRegs: getKindAttr o = getKindAttr (getRegisters m)) : Substeps nil | AddRule (HRegs: getKindAttr o = getKindAttr (getRegisters m)) rn rb (HInRules: In (rn, rb) (getRules m)) reads u cs (HAction: SemAction o (rb type) reads u cs WO) (HReadsGood: SubList (getKindAttr reads) (getKindAttr (getRegisters m))) (HUpdGood: SubList (getKindAttr u) (getKindAttr (getRegisters m))) l ls (HLabel: l = (u, (Rle rn, cs)) :: ls) (HDisjRegs: forall x, In x ls -> DisjKey (fst x) u) (HNoRle: forall x, In x ls -> match fst (snd x) with | Rle _ => False | _ => True end) (HSubstep: Substeps ls): Substeps l | AddMeth (HRegs: getKindAttr o = getKindAttr (getRegisters m)) fn fb (HInMeths: In (fn, fb) (getMethods m)) reads u cs argV retV (HAction: SemAction o ((projT2 fb) type argV) reads u cs retV) (HReadsGood: SubList (getKindAttr reads) (getKindAttr (getRegisters m))) (HUpdGood: SubList (getKindAttr u) (getKindAttr (getRegisters m))) l ls (HLabel: l = (u, (Meth (fn, existT _ _ (argV, retV)), cs)) :: ls ) (HDisjRegs: forall x, In x ls -> DisjKey (fst x) u) (HSubsteps: Substeps ls): Substeps l. End BaseModule. Inductive Step: Mod -> RegsT -> list FullLabel -> Prop := | BaseStep m o l (HSubsteps: Substeps m o l) (HMatching: MatchingExecCalls_Base l m): Step (Base m) o l | HideMethStep m s o l (HStep: Step m o l) (HHidden : forall v, In (s, projT1 v) (getKindAttr (getAllMethods m)) -> getListFullLabel_diff (s, v) l = 0%Z): Step (HideMeth m s) o l | ConcatModStep m1 m2 o1 o2 l1 l2 (HStep1: Step m1 o1 l1) (HStep2: Step m2 o2 l2) (HMatching1: MatchingExecCalls_Concat l1 l2 m2) (HMatching2: MatchingExecCalls_Concat l2 l1 m1) (HNoRle: forall x y, In x l1 -> In y l2 -> match fst (snd x), fst (snd y) with | Rle _, Rle _ => False | _, _ => True end) o l (HRegs: o = o1 ++ o2) (HLabels: l = l1 ++ l2): Step (ConcatMod m1 m2) o l. Definition UpdRegs (u: list RegsT) (o o': RegsT) := getKindAttr o = getKindAttr o' /\ (forall s v, In (s, v) o' -> ((exists x, In x u /\ In (s, v) x) \/ ((~ exists x, In x u /\ In s (map fst x)) /\ In (s, v) o))). Notation regInit := (fun (o': RegT) (r: RegInitT) => fst o' = fst r /\ exists (pf: projT1 (snd o') = projT1 (snd r)), match projT2 (snd r) with | None => True | Some x => match pf in _ = Y return _ Y with | eq_refl => projT2 (snd o') end = evalConstFullT x end). Fixpoint findReg (s: string) (u: RegsT) := match u with | x :: xs => if String.eqb s (fst x) then Some (snd x) else findReg s xs | nil => None end. Fixpoint doUpdRegs (u: RegsT) (o: RegsT) := match o with | x :: o' => match findReg (fst x) u with | Some y => (fst x, y) | None => x end :: doUpdRegs u o' | nil => nil end. Section Trace. Variable m: Mod. Inductive Trace: RegsT -> list (list FullLabel) -> Prop := | InitTrace (o': RegsT) ls' (HUpdRegs: (Forall2 regInit o' (getAllRegisters m))) (HTrace: ls' = nil): Trace o' ls' | ContinueTrace o ls l o' ls' (HOldTrace: Trace o ls) (HStep: Step m o l) (HUpdRegs: UpdRegs (map fst l) o o') (HTrace: ls' = l :: ls): Trace o' ls'. End Trace. Definition WeakInclusion (l1 : list FullLabel) (l2 : list FullLabel) : Prop := (forall f, getListFullLabel_diff f l1 = getListFullLabel_diff f l2) /\ ((exists rle, In (Rle rle) (map (fun x => fst (snd x)) l2)) -> (exists rle, In (Rle rle) (map (fun x => fst (snd x)) l1))). Definition TraceInclusion m1 m2 := forall o1 ls1, Trace m1 o1 ls1 -> exists o2 ls2, Trace m2 o2 ls2 /\ length ls1 = length ls2 /\ (nthProp2 WeakInclusion ls1 ls2). Definition TraceEquiv m1 m2 := TraceInclusion m1 m2 /\ TraceInclusion m2 m1. (* Useful functions *) Fixpoint getCallsWithSign k (a: ActionT (fun _ => unit) k) := match a in ActionT _ _ with | MCall meth k argExpr cont => (meth, k) :: getCallsWithSign (cont tt) | Return x => nil | LetExpr k' expr cont => match k' return (fullType (fun _ => unit) k' -> ActionT (fun _ => unit) k) -> list (string * (Kind * Kind)) with | SyntaxKind k => fun cont => getCallsWithSign (cont tt) | _ => fun _ => nil end cont | LetAction k' a' cont => getCallsWithSign a' ++ getCallsWithSign (cont tt) | ReadNondet k' cont => match k' return (fullType (fun _ => unit) k' -> ActionT (fun _ => unit) k) -> list (string * (Kind * Kind)) with | SyntaxKind k => fun cont => getCallsWithSign (cont tt) | _ => fun _ => nil end cont | ReadReg r k' cont => match k' return (fullType (fun _ => unit) k' -> ActionT (fun _ => unit) k) -> list (string * (Kind * Kind)) with | SyntaxKind k => fun cont => getCallsWithSign (cont tt) | _ => fun _ => nil end cont | WriteReg r k' expr cont => getCallsWithSign cont | Sys ls cont => getCallsWithSign cont | IfElse pred ktf t f cont => getCallsWithSign t ++ getCallsWithSign f ++ getCallsWithSign (cont tt) end. Definition getCallsWithSignPerRule (rule: Attribute (Action Void)) := getCallsWithSign (snd rule _). Definition getCallsWithSignPerMeth (meth: DefMethT) := getCallsWithSign (projT2 (snd meth) _ tt). Fixpoint getCallsWithSignPerMod (mm: Mod) := match mm with | Base m => concat (map getCallsWithSignPerRule (getRules m))++ concat (map getCallsWithSignPerMeth (getMethods m)) | HideMeth m _ => getCallsWithSignPerMod m | ConcatMod m1 m2 => getCallsWithSignPerMod m1 ++ getCallsWithSignPerMod m2 end. Definition getCallsPerMod (m: Mod) := map fst (getCallsWithSignPerMod m). Fixpoint getRegWrites k (a: ActionT (fun _ => unit) k) := match a in ActionT _ _ with | MCall meth k argExpr cont => getRegWrites (cont tt) | Return x => nil | LetExpr k' expr cont => match k' return (fullType (fun _ => unit) k' -> ActionT (fun _ => unit) k) -> list (string * FullKind) with | SyntaxKind k => fun cont => getRegWrites (cont tt) | _ => fun _ => nil end cont | LetAction k' a' cont => getRegWrites a' ++ getRegWrites (cont tt) | ReadNondet k' cont => match k' return (fullType (fun _ => unit) k' -> ActionT (fun _ => unit) k) -> list (string * FullKind) with | SyntaxKind k => fun cont => getRegWrites (cont tt) | _ => fun _ => nil end cont | ReadReg r k' cont => match k' return (fullType (fun _ => unit) k' -> ActionT (fun _ => unit) k) -> list (string * FullKind) with | SyntaxKind k => fun cont => getRegWrites (cont tt) | _ => fun _ => nil end cont | WriteReg r k' expr cont => (r, k') :: getRegWrites cont | Sys ls cont => getRegWrites cont | IfElse pred ktf t f cont => getRegWrites t ++ getRegWrites f ++ getRegWrites (cont tt) end. (* Utility functions *) Fixpoint createHide (m: BaseModule) (hides: list string) := match hides with | nil => Base m | x :: xs => HideMeth (createHide m xs) x end. Fixpoint createHideMod (m : Mod) (hides : list string) : Mod := match hides with | nil => m | h::hides' => HideMeth (createHideMod m hides') h end. Definition getFlat m := BaseMod (getAllRegisters m) (getAllRules m) (getAllMethods m). Definition flatten m := createHide (getFlat m) (getHidden m). Definition autoHide (m: Mod) := createHideMod m (filter (fun i => existsb (String.eqb i) (getCallsPerMod m)) (map fst (getAllMethods m))). Fixpoint separateBaseMod (m: Mod): (list RegFileBase * list BaseModule) := match m with | Base m' => match m' with | BaseMod regs rules meths => (nil, BaseMod regs rules meths :: nil) | BaseRegFile rf => (rf :: nil, nil) end | HideMeth m' meth => separateBaseMod m' | ConcatMod m1 m2 => let '(rfs1, ms1) := separateBaseMod m1 in let '(rfs2, ms2) := separateBaseMod m2 in (rfs1 ++ rfs2, ms1 ++ ms2) end. Definition separateMod (m: Mod) := (getHidden m, separateBaseMod m). Fixpoint mergeSeparatedBaseMod (bl : list BaseModule) : Mod := match bl with | b::bl' => ConcatMod (Base b) (mergeSeparatedBaseMod bl') | nil => Base (BaseMod nil nil nil) end. Fixpoint mergeSeparatedBaseFile (rfl : list RegFileBase) : Mod := match rfl with | rf::rfl' => ConcatMod (Base (BaseRegFile rf))(mergeSeparatedBaseFile rfl') | nil => Base (BaseMod nil nil nil) end. Definition mergeSeparatedMod (tup: list string * (list RegFileBase * list BaseModule)) := createHideMod (ConcatMod (mergeSeparatedBaseFile (fst (snd tup))) (mergeSeparatedBaseMod (snd (snd tup)))) (fst tup). Definition concatFlat m1 m2 := BaseMod (getRegisters m1 ++ getRegisters m2) (getRules m1 ++ getRules m2) (getMethods m1 ++ getMethods m2). (* Inlining *) Section inlineSingle. Variable ty: Kind -> Type. Fixpoint inlineSingle k (a: ActionT ty k) (f: DefMethT): ActionT ty k := match a with | MCall g sign arg cont => match String.eqb (fst f) g with | true => match Signature_dec sign (projT1 (snd f)) with | left isEq => LetAction (LetExpr match isEq in _ = Y return Expr ty (SyntaxKind (fst Y)) with | eq_refl => arg end (projT2 (snd f) ty)) (fun ret => inlineSingle (match isEq in _ = Y return ty (snd Y) -> ActionT ty k with | eq_refl => cont end ret) f) | right _ => MCall g sign arg (fun ret => inlineSingle (cont ret) f) end | false => MCall g sign arg (fun ret => inlineSingle (cont ret) f) end | LetExpr _ e cont => LetExpr e (fun ret => inlineSingle (cont ret) f) | LetAction _ a cont => LetAction (inlineSingle a f) (fun ret => inlineSingle (cont ret) f) | ReadNondet k c => ReadNondet k (fun ret => inlineSingle (c ret) f) | ReadReg r k c => ReadReg r k (fun ret => inlineSingle (c ret) f) | WriteReg r k e a => WriteReg r e (inlineSingle a f) | IfElse p _ aT aF c => IfElse p (inlineSingle aT f) (inlineSingle aF f) (fun ret => inlineSingle (c ret) f) | Sys ls c => Sys ls (inlineSingle c f) | Return e => Return e end. End inlineSingle. Definition inlineSingle_Rule (f : DefMethT) (rle : RuleT): RuleT := let (s, a) := rle in (s, fun ty => inlineSingle (a ty) f). Definition inlineSingle_Rule_map_BaseModule (f : DefMethT) (m : BaseModule) := BaseMod (getRegisters m) (map (inlineSingle_Rule f) (getRules m)) (getMethods m). Fixpoint inlineSingle_Rule_in_list (f : DefMethT) (rn : string) (lr : list RuleT) : list RuleT := match lr with | rle'::lr' => match String.eqb rn (fst rle') with | false => rle' | true => inlineSingle_Rule f rle' end ::(inlineSingle_Rule_in_list f rn lr') | nil => nil end. Definition inlineSingle_Rule_BaseModule (f : DefMethT) (rn : string) (m : BaseModule) := BaseMod (getRegisters m) (inlineSingle_Rule_in_list f rn (getRules m)) (getMethods m). Definition inlineSingle_Meth (f : DefMethT) (meth : DefMethT): DefMethT := let (name, sig_body) := meth in (name, if String.eqb (fst f) name then sig_body else let (sig, body) := sig_body in existT _ sig (fun ty arg => inlineSingle (body ty arg) f)). Definition inlineSingle_Meth_map_BaseModule (f : DefMethT) (m : BaseModule) := BaseMod (getRegisters m) (getRules m) (map (inlineSingle_Meth f) (getMethods m)). Fixpoint inlineSingle_Meth_in_list (f : DefMethT) (gn : string) (lm : list DefMethT) : list DefMethT := match lm with | meth'::lm' => match String.eqb gn (fst meth') with | false => meth' | true => (inlineSingle_Meth f meth') end ::(inlineSingle_Meth_in_list f gn lm') | nil => nil end. Definition inlineSingle_Meth_BaseModule (f : DefMethT) (fn : string) (m : BaseModule) := BaseMod (getRegisters m) (getRules m) (inlineSingle_Meth_in_list f fn (getMethods m)). Section inlineSingle_nth. Variable (f : DefMethT). Variable (regs: list RegInitT) (rules: list RuleT) (meths: list DefMethT). Definition inlineSingle_BaseModule : BaseModule := BaseMod regs (map (inlineSingle_Rule f) rules) (map (inlineSingle_Meth f) meths). Definition inlineSingle_BaseModule_nth_Meth xs : BaseModule := BaseMod regs rules (fold_right (transform_nth_right (inlineSingle_Meth f)) meths xs). Definition inlineSingle_BaseModule_nth_Rule xs : BaseModule := BaseMod regs (fold_right (transform_nth_right (inlineSingle_Rule f)) rules xs) meths. End inlineSingle_nth. Definition inlineSingle_Rules_pos meths n rules := match nth_error meths n with | Some f => map (inlineSingle_Rule f) rules | None => rules end. Definition inlineAll_Rules meths rules := fold_left (fun newRules n => inlineSingle_Rules_pos meths n newRules) (seq 0 (length meths)) rules. Definition inlineAll_Rules_mod m := (BaseMod (getRegisters m) (inlineAll_Rules (getMethods m) (getRules m)) (getMethods m)). Definition inlineSingle_Meths_pos newMeths n := match nth_error newMeths n with | Some f => map (inlineSingle_Meth f) newMeths | None => newMeths end. Definition inlineAll_Meths meths := fold_left inlineSingle_Meths_pos (seq 0 (length meths)) meths. Definition inlineAll_Meths_mod m := (BaseMod (getRegisters m) (getRules m) (inlineAll_Meths (getMethods m))). Definition inlineAll_All regs rules meths := (BaseMod regs (inlineAll_Rules (inlineAll_Meths meths) rules) (inlineAll_Meths meths)). Definition inlineAll_All_mod m := inlineAll_All (getAllRegisters m) (getAllRules m) (getAllMethods m). Definition flatten_inline_everything m := createHide (inlineAll_All_mod m) (getHidden m). Definition removeHides (m: BaseModule) s := BaseMod (getRegisters m) (getRules m) (filter (fun df => negb (existsb (String.eqb (fst df)) s)) (getMethods m)). Definition flatten_inline_remove m := removeHides (inlineAll_All_mod m) (getHidden m). (* Last Set of Utility Functions *) Definition hiddenBy (meths : list DefMethT) (h : string) : bool := (existsb (String.eqb h) (map fst meths)). Definition getAllBaseMethods (lb : list BaseModule) : (list DefMethT) := (concat (map getMethods lb)). Definition hiddenByBase (lb : list BaseModule) (h : string) : bool := (hiddenBy (getAllBaseMethods lb) h). Local Notation complement f := (fun x => negb (f x)). Definition separateHides (tl : list string * (list RegFileBase * list BaseModule)) : (list string * list string) := (filter (hiddenByBase (map BaseRegFile (fst (snd tl)))) (fst tl), filter (complement (hiddenByBase (map BaseRegFile (fst (snd tl))))) (fst tl)). Definition separateModHides (m: Mod) := let '(hides, (rfs, mods)) := separateMod m in let '(hidesRf, hidesBm) := separateHides (hides, (rfs, mods)) in (hidesRf, (rfs, createHide (inlineAll_All_mod (mergeSeparatedBaseMod mods)) hidesBm)). Definition separateModRemove (m : Mod) := let '(hides, (rfs, mods)) := separateMod m in let '(hidesRf, hidesBm) := separateHides (hides, (rfs, mods)) in (hidesRf, (rfs, removeHides (inlineAll_All_mod (mergeSeparatedBaseMod mods)) hidesBm)). Definition baseNoSelfCalls (m : Mod) := let '(hides, (rfs, mods)) := separateMod m in NoSelfCallBaseModule (inlineAll_All_mod (mergeSeparatedBaseMod mods)). Definition separateModHidesNoInline (m : Mod) := let '(hides, (rfs, mods)) := separateMod m in (hides, (rfs, getFlat (mergeSeparatedBaseMod mods))). (* Helper functions for struct - Gallina versions of getters and setters *) Local Definition option_bind (T U : Type) (x : option T) (f : T -> option U) : option U := match x with | Some y => f y | None => None end. Local Notation "X >>- F" := (option_bind X F) (at level 85, only parsing). Fixpoint struct_get_field_index' (name: string) n := match n return forall (get_name : Fin.t n -> string), option (Fin.t n) with | 0 => fun _ => None | S m => fun get_name => if String.eqb (get_name Fin.F1) name then Some Fin.F1 else match struct_get_field_index' name _ (fun i => get_name (Fin.FS i)) with | Some i => Some (Fin.FS i) | None => None end end. Definition struct_get_field_index n (kinds: Fin.t n -> Kind) (names: Fin.t n -> string) ty (e: Expr ty (SyntaxKind (Struct kinds names))) name := struct_get_field_index' name names. Local Definition struct_get_field_aux (ty: Kind -> Type) (n : nat) (get_kind : Fin.t n -> Kind) (get_name : Fin.t n -> string) (packet : Expr ty (SyntaxKind (Struct get_kind get_name))) (name : string) : option ({kind : Kind & Expr ty (SyntaxKind kind)}) := struct_get_field_index packet name >>- fun index => Some (existT (fun kind : Kind => Expr ty (SyntaxKind kind)) (get_kind index) (ReadStruct packet index)). Definition struct_get_field (ty: Kind -> Type) (n : nat) (get_value : Fin.t n -> Kind) (get_name : Fin.t n -> string) (packet : Expr ty (SyntaxKind (Struct get_value get_name))) (name : string) (k : Kind) : option (Expr ty (SyntaxKind k)). Proof. refine (let y := @struct_get_field_aux ty n get_value get_name packet name in match y with | None => None | Some (existT x y) => _ end). destruct (Kind_decb x k) eqn:G. - apply Kind_decb_eq in G. subst. exact (Some y). - exact None. Defined. Definition struct_get_field_default (ty: Kind -> Type) (n : nat) (get_value : Fin.t n -> Kind) (get_name : Fin.t n -> string) (packet : Expr ty (SyntaxKind (Struct get_value get_name))) (name : string) (kind : Kind) (default : Expr ty (SyntaxKind kind)) : Expr ty (SyntaxKind kind) := match struct_get_field packet name kind with | Some field_value => field_value | None => default end. Definition struct_set_field (ty: Kind -> Type) (n : nat) (get_kind : Fin.t n -> Kind) (get_name : Fin.t n -> string) (packet : Expr ty (SyntaxKind (Struct get_kind get_name))) (name : string) (kind : Kind) (value : Expr ty (SyntaxKind kind)) : option (Expr ty (SyntaxKind (Struct get_kind get_name))). Proof. refine (let y := struct_get_field_index packet name in match y with | None => None | Some i => _ end). destruct (Kind_dec (get_kind i) kind). - subst. exact (Some (UpdateStruct packet i value)). - exact None. Defined. Definition struct_set_field_default (ty: Kind -> Type) (n : nat) (get_kind : Fin.t n -> Kind) (get_name : Fin.t n -> string) (packet : Expr ty (SyntaxKind (Struct get_kind get_name))) (name : string) (kind : Kind) (value : Expr ty (SyntaxKind kind)) : Expr ty (SyntaxKind (Struct get_kind get_name)). Proof. refine (let y := struct_get_field_index packet name in match y with | None => packet | Some i => _ end). destruct (Kind_dec (get_kind i) kind). - subst. exact (UpdateStruct packet i value). - exact packet. Defined. Create HintDb KamiDb. Hint Unfold inlineSingle_Meths_pos flatten_inline_remove getHidden getAllRegisters getAllMethods getAllRules inlineAll_All_mod inlineAll_All writeRegFileFn readRegFile createHideMod List.find List.fold_right List.fold_left List.filter List.length List.app List.seq List.nth_error List.map List.concat List.existsb List.nth Datatypes.length Ascii.eqb String.eqb Bool.eqb Datatypes.negb Datatypes.andb Datatypes.orb Datatypes.fst Datatypes.snd String.append EclecticLib.nth_Fin : KamiDb. (* TODO + PUAR: Linux/Certikos *) ================================================ FILE: SyntaxDoubleWrites.v ================================================ Require Export Bool Ascii String List FunctionalExtensionality Psatz PeanoNat. Require Export Kami.Lib.Word Kami.Lib.VectorFacts Kami.Lib.EclecticLib Kami.AllNotations. Export Word.Notations. Require Import Permutation RecordUpdate.RecordSet. Require Import ZArith. Import ListNotations. Global Set Implicit Arguments. Global Set Asymmetric Patterns. Global Open Scope word_scope. Global Open Scope nat_scope. Global Open Scope string_scope. Global Open Scope vector_scope. Global Open Scope list_scope. Section DoubleWrites. Variable o: RegsT. Inductive SemActionDoubleWrites: forall k, ActionT type k -> RegsT -> RegsT -> MethsT -> type k -> Prop := | SemMCallDoubleWrites meth s (marg: Expr type (SyntaxKind (fst s))) (mret: type (snd s)) retK (fret: type retK) (cont: type (snd s) -> ActionT type retK) readRegs newRegs (calls: MethsT) acalls (HAcalls: acalls = (meth, (existT _ _ (evalExpr marg, mret))) :: calls) (HSemAction: SemActionDoubleWrites (cont mret) readRegs newRegs calls fret): SemActionDoubleWrites (MCall meth s marg cont) readRegs newRegs acalls fret | SemLetExprDoubleWrites k (e: Expr type k) retK (fret: type retK) (cont: fullType type k -> ActionT type retK) readRegs newRegs calls (HSemAction: SemActionDoubleWrites (cont (evalExpr e)) readRegs newRegs calls fret): SemActionDoubleWrites (LetExpr e cont) readRegs newRegs calls fret | SemLetActionDoubleWrites k (a: ActionT type k) (v: type k) retK (fret: type retK) (cont: type k -> ActionT type retK) readRegs newRegs readRegsCont newRegsCont calls callsCont (HSemAction: SemActionDoubleWrites a readRegs newRegs calls v) (HSemActionCont: SemActionDoubleWrites (cont v) readRegsCont newRegsCont callsCont fret) uReadRegs uNewRegs uCalls (HReadRegs: uReadRegs = readRegs ++ readRegsCont) (HNewRegs: uNewRegs = newRegs ++ newRegsCont) (HCalls: uCalls = calls ++ callsCont): SemActionDoubleWrites (LetAction a cont) uReadRegs uNewRegs uCalls fret | SemReadNondetDoubleWrites valueT (valueV: fullType type valueT) retK (fret: type retK) (cont: fullType type valueT -> ActionT type retK) readRegs newRegs calls (HSemAction: SemActionDoubleWrites (cont valueV) readRegs newRegs calls fret): SemActionDoubleWrites (ReadNondet _ cont) readRegs newRegs calls fret | SemReadRegDoubleWrites (r: string) regT (regV: fullType type regT) retK (fret: type retK) (cont: fullType type regT -> ActionT type retK) readRegs newRegs calls areadRegs (HRegVal: In (r, existT _ regT regV) o) (HSemAction: SemActionDoubleWrites (cont regV) readRegs newRegs calls fret) (HNewReads: areadRegs = (r, existT _ regT regV) :: readRegs): SemActionDoubleWrites (ReadReg r _ cont) areadRegs newRegs calls fret | SemWriteRegDoubleWrites (r: string) k (e: Expr type k) retK (fret: type retK) (cont: ActionT type retK) readRegs newRegs calls anewRegs (HRegVal: In (r, k) (getKindAttr o)) (HANewRegs: anewRegs = (r, (existT _ _ (evalExpr e))) :: newRegs) (HSemAction: SemActionDoubleWrites cont readRegs newRegs calls fret): SemActionDoubleWrites (WriteReg r e cont) readRegs anewRegs calls fret | SemIfElseTrueDoubleWrites (p: Expr type (SyntaxKind Bool)) k1 (a: ActionT type k1) (a': ActionT type k1) (r1: type k1) k2 (cont: type k1 -> ActionT type k2) readRegs1 readRegs2 newRegs1 newRegs2 calls1 calls2 (r2: type k2) (HTrue: evalExpr p = true) (HAction: SemActionDoubleWrites a readRegs1 newRegs1 calls1 r1) (HSemAction: SemActionDoubleWrites (cont r1) readRegs2 newRegs2 calls2 r2) ureadRegs unewRegs ucalls (HUReadRegs: ureadRegs = readRegs1 ++ readRegs2) (HUNewRegs: unewRegs = newRegs1 ++ newRegs2) (HUCalls: ucalls = calls1 ++ calls2) : SemActionDoubleWrites (IfElse p a a' cont) ureadRegs unewRegs ucalls r2 | SemIfElseFalseDoubleWrites (p: Expr type (SyntaxKind Bool)) k1 (a: ActionT type k1) (a': ActionT type k1) (r1: type k1) k2 (cont: type k1 -> ActionT type k2) readRegs1 readRegs2 newRegs1 newRegs2 calls1 calls2 (r2: type k2) (HFalse: evalExpr p = false) (HAction: SemActionDoubleWrites a' readRegs1 newRegs1 calls1 r1) (HSemAction: SemActionDoubleWrites (cont r1) readRegs2 newRegs2 calls2 r2) ureadRegs unewRegs ucalls (HUReadRegs: ureadRegs = readRegs1 ++ readRegs2) (HUNewRegs: unewRegs = newRegs1 ++ newRegs2) (HUCalls: ucalls = calls1 ++ calls2): SemActionDoubleWrites (IfElse p a a' cont) ureadRegs unewRegs ucalls r2 | SemSysDoubleWrites (ls: list (SysT type)) k (cont: ActionT type k) r readRegs newRegs calls (HSemAction: SemActionDoubleWrites cont readRegs newRegs calls r): SemActionDoubleWrites (Sys ls cont) readRegs newRegs calls r | SemReturnDoubleWrites k (e: Expr type (SyntaxKind k)) evale (HEvalE: evale = evalExpr e) readRegs newRegs calls (HReadRegs: readRegs = nil) (HNewRegs: newRegs = nil) (HCalls: calls = nil) : SemActionDoubleWrites (Return e) readRegs newRegs calls evale. End DoubleWrites. ================================================ FILE: Tactics.v ================================================ Require Import Kami.Lib.EclecticLib Kami.Syntax Kami.Properties. Ltac struct_get_field_ltac packet name := let val := eval cbv in (struct_get_field_index packet name) in match val with | Some ?x => exact (ReadStruct packet x) | None => let newstr := constr:(("get field not found in struct" ++ name)%string) in fail 0 newstr | _ => let newstr := constr:(("major error - struct_get_field_index not reducing " ++ name)%string) in fail 0 newstr end. Ltac struct_set_field_ltac packet name newval := let val := eval cbv in (struct_get_field_index packet name) in match val with | Some ?x => exact (UpdateStruct packet x newval) | None => let newstr := constr:(("set field not found in struct " ++ name)%string) in fail 0 newstr | _ => let newstr := constr:(("major error - struct_set_field_index not reducing " ++ name)%string) in fail 0 newstr end. Local Ltac constructor_simpl := econstructor; eauto; simpl; unfold not; intros. Ltac destruct_string_dec := repeat match goal with | H: context[string_dec ?P%string ?Q%string] |- _ => destruct (string_dec P Q) | |- context[string_dec ?P%string ?Q%string] => destruct (string_dec P Q) end. Local Ltac process_append := repeat match goal with | H: (_ ++ _)%string = (_ ++ _)%string |- _ => rewrite <- ?append_assoc in H; cbn [append] in H | |- (_ ++ _)%string = (_ ++ _)%string => rewrite <- ?append_assoc; cbn [append] end; repeat match goal with | H: (?a ++ ?b)%string = (?a ++ ?c)%string |- _ => apply append_remove_prefix in H; subst | H: (?a ++ ?b)%string = (?c ++ ?b)%string |- _ => apply append_remove_suffix in H; subst | |- (?a ++ ?b)%string = (?a ++ ?c)%string => apply append_remove_prefix | |- (?a ++ ?b)%string = (?c ++ ?b)%string => apply append_remove_suffix | H: (?a ++ (String ?x ?b))%string = (?c ++ (String ?y ?d))%string |- _ => apply (f_equal string_rev) in H; rewrite (string_rev_append a (String x b)), (string_rev_append c (String y d)) in H; cbn [string_rev] in H; rewrite <- ?append_assoc in H; cbn [append] in H end. Local Ltac finish_append := auto; try (apply InSingleton || discriminate || tauto || congruence). Ltac discharge_append := simpl; unfold getBool in *; process_append; finish_append. Goal forall (a b c: string), (a ++ "a" <> a ++ "b" /\ a ++ "a" ++ b <> c ++ "b" ++ b /\ a ++ "a" ++ "b" <> a ++ "a" ++ "c" /\ "a" ++ a <> "b" ++ b /\ (a ++ "a") ++ b <> a ++ "b" ++ a /\ (a ++ (b ++ "b")) ++ "c" <> (a ++ b) ++ "d")%string. Proof. intuition idtac; discharge_append. Qed. Ltac discharge_DisjKey := repeat match goal with | |- DisjKey _ _ => rewrite (DisjKeyWeak_same string_dec); unfold DisjKeyWeak; simpl; intros | H: _ \/ _ |- _ => destruct H; subst end; discharge_append. Ltac discharge_wf := repeat match goal with | |- @WfMod _ _ => constructor_simpl | |- @WfConcat _ _ => constructor_simpl | |- _ /\ _ => constructor_simpl | |- @WfConcatActionT _ _ _ _ _ => constructor_simpl | |- @WfBaseModule _ _ => constructor_simpl | |- @WfActionT _ _ _ (convertLetExprSyntax_ActionT ?e) => apply WfLetExprSyntax | |- @WfActionT _ _ _ _ => constructor_simpl | |- NoDup _ => constructor_simpl | H: _ \/ _ |- _ => destruct H; subst; simpl | |- forall _, _ => intros | |- _ -> _ => intros | H: In _ (getAllMethods _) |- _ => simpl in H;inversion H;subst;clear H;simpl end; discharge_DisjKey. Ltac discharge_wf_new := repeat match goal with | |- @WfBaseModule_new _ _ => unfold WfBaseModule_new | |- @WfMod_new _ _ => constructor_simpl | |- _ /\ _ => constructor_simpl | |- @WfActionT_new _ _ _ (convertLetExprSyntax_ActionT ?e) => apply WfLetExprSyntax | |- @WfActionT _ _ _ (convertLetExprSyntax_ActionT ?e) => apply WfLetExprSyntax | |- NoDup _ => constructor_simpl | H: _ \/ _ |- _ => destruct H; subst; simpl | |- forall _, _ => intros | |- _ -> _ => intros | H: In _ (getAllMethods _) |- _ => simpl in H;inversion H;subst;clear H;simpl | |- _ => unfold lookup; simpl; repeat rewrite strip_pref end; discharge_DisjKey. Lemma string_dec_refl {A} : forall (s: string) (T E: A), (if String.eqb s s then T else E) = T. Proof. intros; rewrite String.eqb_refl; auto. Qed. Lemma string_dec_neq {A} : forall (s1 s2: string) (T E: A), s1 <> s2 -> (if String.eqb s1 s2 then T else E) = E. Proof. intros. rewrite <- String.eqb_neq in H; rewrite H; auto. Qed. Ltac discharge_string_dec := repeat (rewrite string_dec_refl || rewrite string_dec_neq by (intros ?; discharge_append)). Ltac discharge_NoSelfCall := unfold NoSelfCallBaseModule, NoSelfCallRulesBaseModule, NoSelfCallMethsBaseModule; split; auto; simpl; intros; repeat match goal with | H: _ \/ _ |- _ => destruct H; subst | H: False |- _ => exfalso; apply H | |- NoCallActionT _ (convertLetExprSyntax_ActionT _) => apply LetExprNoCallActionT | _ => constructor; auto; simpl; try intro; discharge_DisjKey end. Ltac unfold_beta_head a := let new := lazymatch a with | ?h _ _ _ _ _ _ _ _ _ _ => eval cbv beta delta [h] in a | ?h _ _ _ _ _ _ _ _ _ => eval cbv beta delta [h] in a | ?h _ _ _ _ _ _ _ _ => eval cbv beta delta [h] in a | ?h _ _ _ _ _ _ _ => eval cbv beta delta [h] in a | ?h _ _ _ _ _ _ => eval cbv beta delta [h] in a | ?h _ _ _ _ _ => eval cbv beta delta [h] in a | ?h _ _ _ _ => eval cbv beta delta [h] in a | ?h _ _ _ => eval cbv beta delta [h] in a | ?h _ _ => eval cbv beta delta [h] in a | ?h _ => eval cbv beta delta [h] in a end in exact new. Ltac discharge_SemAction := match goal with | |- SemAction _ _ _ _ ?meths _ => repeat match goal with | |- SemAction ?o ?act ?reads ?news ?calls ?retv => let act' := constr:(ltac:(unfold_beta_head act)) in change (SemAction o act' reads news calls retv) | |- SemAction _ (@IfElse _ _ ?p _ _ _ _) _ _ _ _ => eapply SemAction_if_split | |- if ?P then SemAction _ _ _ _ _ _ else SemAction _ _ _ _ _ _ => case_eq P; let H := fresh in intros H; rewrite ?H in *; cbn [evalExpr] in *; try discriminate | |- SemAction _ (convertLetExprSyntax_ActionT _) _ _ _ _ => eapply convertLetExprSyntax_ActionT_same | |- SemAction _ _ _ _ _ _ => econstructor end; rewrite ?key_not_In_fst; unfold not; intros; cbn [evalExpr evalConstT] in *; repeat match goal with | |- In _ _ => simpl; auto | |- ?a = ?a => reflexivity | |- meths = _ => eauto end; simpl in *; try (discriminate || congruence); eauto; simpl in *; discharge_DisjKey end. Ltac simplify_simulatingRule name := right; exists name; eexists; split; [eauto| do 2 eexists; split; [discharge_SemAction|]]. Ltac simplify_nilStep := left; split; auto; simpl in *; discharge_string_dec. Local Ltac discharge_init := repeat econstructor; try match goal with | |- match ?P in _ = Y return _ with | eq_refl => _ end = _ => is_evar P; match type of P with | ?tp = _ => unify P (@eq_refl _ tp) end end; simpl; eauto. Ltac clean_hyp_step := match goal with | |- NoSelfCallBaseModule _ => discharge_NoSelfCall | H: DisjKey _ _ |- _ => clear H | H: key_not_In _ _ |- _ => clear H | H: ?a = ?a |- _ => clear H | H: False |- _ => exfalso; apply H | H: ?a <> ?a |- _ => exfalso; apply (H eq_refl) | H: _ \/ _ |- _ => destruct H; subst | H: _ /\ _ |- _ => destruct H; subst | H: exists x, _ |- _ => let y := fresh x in destruct H as [y ?] | H: (?A, ?B) = (?P, ?Q) |- _ => apply inversionPair in H; destruct H as [? ?]; subst | H: existT ?a ?b ?c1 = existT ?a ?b ?c2 |- _ => apply Eqdep.EqdepTheory.inj_pair2 in H; subst | H: existT ?a ?b1 ?c1 = existT ?a ?b2 ?c2 |- _ => apply inversionExistT in H; destruct H as [? ?]; subst | H: (?a ++ ?b)%string = (?a ++ ?c)%string |- _ => apply append_remove_prefix in H; subst | H: ?a = ?b |- _ => discriminate | H: SemAction _ (convertLetExprSyntax_ActionT ?e) _ _ _ _ |- _ => apply convertLetExprSyntax_ActionT_full in H | H: SemAction _ _ _ _ _ _ |- _ => apply inversionSemAction in H | H: if ?P then _ else _ |- _ => case_eq P; let i := fresh in intros i; rewrite ?i in * | H: Forall2 _ _ _ |- _ => inv H; dest | H: RegT |- _ => destruct H as [? [? ?]]; repeat (unfold fst, snd, projT1, projT2 in *; subst) | H: In _ _ |- _ => simpl in H | |- exists rspec : list RegT, Forall2 _ _ _ /\ _ _ _ => discharge_init end. Ltac clean_hyp := simpl in *; repeat clean_hyp_step. Ltac discharge_CommonRegister disjReg := match goal with | |- exists k: string, _ /\ _ => exists disjReg; simpl; auto; tauto | _ => idtac end. Ltac discharge_CommonRegisterAuto := match goal with | |- exists k: string, _ /\ _ => eexists; simpl; eauto; tauto | _ => idtac end. Ltac discharge_simulationWf mySimRel := apply simulationGeneral with (simRel := mySimRel); auto; simpl; intros; try match goal with | H: mySimRel _ _ |- _ => inv H end; clean_hyp; auto; clean_hyp. Ltac discharge_simulation mySimRel := apply simulation with (simRel := mySimRel); auto; simpl; intros; try match goal with | |- WfBaseModule _ _ => discharge_wf | H: mySimRel _ _ |- _ => inv H end; clean_hyp; auto; clean_hyp. ================================================ FILE: Tutorial/ExtractEx.v ================================================ Require Import Kami.All. Require Import Kami.Tutorial.TacticsEx. (* Example of how to extract a module to be used by the Haskell simulator *) Definition IncrMod : BaseModule := IncrementerImpl 5 "test". Separate Extraction getFins Fin.to_nat fullFormatHex fullFormatBinary fullFormatDecimal readReqName readResName readRegName rfIsWrMask rfNum rfDataArray rfRead rfWrite rfIdxNum rfData rfInit pack unpack IncrMod. ================================================ FILE: Tutorial/GallinaActionEx.v ================================================ Require Import Kami.AllNotations. Section Ex. (* The usual boiler plate *) Local Open Scope kami_expr. Local Open Scope kami_action. Variable name: string. Local Notation "@^ x" := (name ++ "_" ++ x)%string (at level 0). (* The parametricity argument, as described in the README. See PhoasEx.v for understanding the underlying concepts *) Variable ty: Kind -> Type. (* "k @# ty" is a way to specify an expression of kami of type k (indexed by ty, the parametricity index). "k ## ty" is a way to specify a let-expression of kami of type k (again indexed by ty). The following action takes an input expression of Bit 10 and a let-expression of Bit 5, and performs a few operations on registers and makes an explicit call. Note that one can read any register and write any register. This is possible because registers are simply accessed using names and there's no scope for accessing them. There's an explicit check, called Wf, that ensures that a module never accesses a register that it does not define. Nevertheless, having name-based access allows us to write actions that access these register outside the context of a module. *) Definition exampleAction (e: Bit 10 @# ty) (le: Bit 5 ## ty): ActionT ty (Bit 10) := ( Read x: Bit 10 <- @^"reg1"; (* Note that we need to use convertLetExprSyntax_ActionT to convert any let-expression into an action *) LETA y <- convertLetExprSyntax_ActionT le; Write @^"reg2" <- {<#x + e, #y>}; Call "extCall"(#x: _); Ret (#x + #x + e) ). (* Example of an Expr; One cannot read/write registers or call methods. *) Definition exampleExpr (e: Bit 4 @# ty) (f: Bit 6 @# ty): Bit 10 @# ty := $3 + $4 + {< e, f >}. (* Example of a LetExprSyntax *) Definition exampleLetExpr (e: Bit 4 ## ty) (f: Bit 6 ## ty): Bit 10 ## ty := ( (* Note that we need to use LETE to bind a let-expression directly *) LETE e' <- e; LETE f' <- f; (* But we use a LETC to bind a normal expression into a let-binding of a let-expression *) LETC x <- {< #e', #f' >}; RetE #x ). End Ex. ================================================ FILE: Tutorial/PhoasEx.v ================================================ Require Import String List. Set Implicit Arguments. Set Asymmetric Patterns. (* A simple language to write a sequence of let bindings and finally return a value. The values are all of type bools. We define primitive operations to and/or two booleans and negation operator *) Section Lambda. Variable ty: Type. (* ty is parameterizing the below inductive type Expr *) Inductive Expr: Type := | Const (n: bool) | Andb (a b: Expr) | Orb (a b: Expr) | Negb (a: Expr) | Var (v: ty) (* The above construct enables injecting a term of type ty (the parameter for Expr) into an Expr. Depending on how ty is instantiated, we can get the denotional semantics for Expr as well as compile it into a string using fresh names for each let binding. We will see the two use cases below *) | LetExpr (x: Expr) (cont: ty -> Expr) (* The above construct creates a let-binding followed by a continuation that uses the let-binding. This is essentially an "application" of an "abstraction" (cont) to an Expr *) | Ret (x: Expr). (* The above construct closes a term in the Expr language *) End Lambda. (* The following function gives the denotional semantics of Expr. Note first that ty is instantiated to Bool. So every variable that we inject into the Expr is a boolean. This makes sense, since we want values of this language to be booleans and hence the denotation of a variable must be a boolean *) Fixpoint evalExpr (e: Expr bool) := match e with | Const n => n | Andb a b => andb (evalExpr a) (evalExpr b) | Orb a b => orb (evalExpr a) (evalExpr b) | Negb a => negb (evalExpr a) | Var v => v (* Notice above that the denotation of a variable is simply its value *) | LetExpr x cont => evalExpr (cont (evalExpr x)) (* In the above, we pass the expression used in the let-binding to its continuation so that the bound variable is replaced by its binding everywhere it is used *) | Ret x => evalExpr x end. Local Open Scope string. Fixpoint natStr (n: nat) := match n with | 0 => "O" | S m => "S" ++ natStr m end. (* This is a compiler that translates the above AST into concrete strings, creating a new temporary name for each let-binding. The idea is to have a counter (curr) that keeps incrementing each time a new let-binding is made. The current value of the counter essentially creates a reference to the expression that is let-bound. Whenever a "Var" is used, it in turn emits the counter value that was passed to it. The counter state is being threaded (i.e. the current value of the counter is the input, and the updated value of the counter is the output, along with the string. Only let-bindings increment the counter. *) Fixpoint toString (e: Expr nat) curr: (nat * string) := match e with | Const n => (curr, if n then "true" else "false") | Andb a b => let '(next, str) := toString a curr in let '(final, strF) := toString b curr in (final, "(" ++ str ++ " && " ++ strF ++ ")") | Orb a b => let '(next, str) := toString a curr in let '(final, strF) := toString b curr in (final, "(" ++ str ++ " || " ++ strF ++ ")") | Negb a => let '(final, str) := toString a curr in (final, "(!" ++ str ++ ")") | Var v => (curr, "x" ++ natStr v) (* The above uses the value of the counter that was passed to it *) | LetExpr x cont => let '(next, str) := toString x curr in (* This evaluates the let-binding expression. If the let-binding expressiong in turn has other let-bindings, then the counter will be incremented by it. Finally, the last value of the counter is returned. *) let '(final, strF) := toString (cont next) (S next) in (* We assign the last value of the counter returned by the let-binding expression (next) as the reference to that expression. We then construct the string for the continuation, instantiating cont with the let-binding reference (next), while incrementing the counter that is passed to it, so that it does not reuse "next" *) (final, "let x" ++ natStr next ++ " := " ++ str ++ " in " ++ strF) (* Finally, we pretty print all the collected string. We prepend "x" to the name of the references for aesthetic purposes *) | Ret x => toString x curr end. (* This is just a helper function that initializes the counter to 0 and ignores the updated counter value *) Definition pretty (e: Expr nat) := snd (toString e 0). Definition expr ty := LetExpr (Orb (Const ty true) (Const _ false)) (fun x => LetExpr (Const _ true) (fun y => Andb (Var x) (Var y))). (* This shows how the expression is pretty printed *) Compute pretty (expr _). ================================================ FILE: Tutorial/SyntaxEx.v ================================================ Require Import Kami.AllNotations. (* In order to write a Kami module, one first opens a section using the same name as the module, and writes the following five lines of boiler plate code. *) (* Notation "'IfE' cexpr 'then' tact 'else' fact 'as' name ; cont " := *) (* (IfElseE cexpr%kami_expr tact fact (fun name => cont)) *) (* (at level 14, right associativity) : kami_expr_scope. *) (* Notation "'IfE' cexpr 'then' tact 'else' fact ; cont " := *) (* (IfElse cexpr%kami_expr tact fact (fun _ => cont)) *) (* (at level 14, right associativity) : kami_expr_scope. *) (* Notation "'IfE' cexpr 'then' tact ; cont" := *) (* (IfElse cexpr%kami_expr tact (RetE (Const _ Default))%kami_expr (fun _ => cont)) *) (* (at level 14, right associativity) : kami_expr_scope. *) Section exampleModule. Variable name : string. Local Notation "@^ x" := (name ++ "_" ++ x)%string (at level 0). Local Open Scope kami_expr. Local Open Scope kami_action. (* All names in this module will be prepended by a unique name to avoid duplication of names. In Kami, all names should be globally unique, and therefore requires this to be done explicitly. Inside a module, any @^"newName" will be automatically converted into name ++ "_" ++ "newName". The next two lines are added because the Notations in Coq are broken. *) Definition exampleModule := MODULE { Register @^"reg1": Bool <- false (* register named reg1 of type Bool, initialized to false *) with Register @^"reg2": Bit 20 <- (20'h"7abcd") (* 20'h"7abcd" initializes reg2 to 20 bits represented by the hex 0x7abcd *) with Register @^"reg3": Array 5 (Bit 8) <- (ARRAY_CONST { 8'h"a4"; 8'h"b3"; 8'h"5e"; 8'h"34"; 8'h"45" }) (* reg3 is initialized to an array containing 5 (Bit 8) elements *) with Register @^"reg4": STRUCT_TYPE { "field1" :: Bit 4 ; "someOtherField" :: Bool } <- STRUCT_CONST { "field1" ::= natToWord _ 13 ; "someOtherField" ::= true } (* reg4 is initialized to a "structure" containing fields "field1" and "someOtherField". "field1" is initialized to (natToWord _ 13), which is converting a nat 13 into a bit-vector (i.e. [word]) of length 4 (the number of bits is automatically inferred by Coq's type checker based on the type of "field1" being Bit 4), and "someOtherField" to true *) with RegisterU @^"reg5" : Bool (* Uninitialized register reg5 *) with RegisterU @^"reg6" : Bool (* Uninitialized register reg6, for use later *) with Rule @^"rule1" := ( LET x1 : Bit 20 <- $3 + $4; (* Define a new temporary variable x1 of type Bit 10, whose value is computed by adding 3 with 4 Note that 3 and 4 are converted into bit-vectors of width 10 using the "$" operator. The bit-width of 20 is automatically computed for the $ operator using the type information for x1. It is an error to add differently sized bit vectors *) LET x2 : Bool <- $$ false ; (* Another temporary variable x2, which is set to false. Notice the two $$ in case of creating a non-nat constant *) LET x3 : Array 2 Bool <- $$ ARRAY_CONST {false ; true} ; (* x3 is set to a 2-element array with boolean values. Notice agian that we use $$ for creating a non-not constant *) LET x4 : Array 2 (Bit 4) <- $$ ARRAY_CONST { $5 ; (natToWord 4 12)} ; (* yet another example of a constant array built using bit-vectors. The Coq's type checker fails to infer the width of the bit-vector this time, forcing us to specify the size as 4 *) LET x5 : STRUCT_TYPE { "sth1" :: Bool ; "sth2" :: Bit 20 } <- $$ STRUCT_CONST { "sth1" ::= false ; "sth2" ::= natToWord 20 4 }; (* One can also have constant structures assigned to a local variable *) LET x6 <- $$ STRUCT_CONST { "sth1" ::= false ; "sth2" ::= natToWord 20 4 }; (* One can omit the type of the expression if it is easy for Coq to infer it *) LET x7 <- #x1 + #x6@%"sth2"; (* This construct covers several syntactic concepts explained as follows: 1. Locally bound variables can be used in constructing expressions (which can, for instance, be assigned to other variables) 2. To use a variable bound earlier, we use #variable-name, as in, #x1 and #x6 3. We can get a field of a struct using @% notation, as in, (#x6)@%"sth2". The parenthesis around #x6 can be omitted because # binds more tightly than @% *) Read x8: Bool <- @^"reg1"; (* Reading reg1 and binding it to variable x8. The type is not mandatory but cannot be inferred by Coq unless there is a use of x8 that determines the type of x8. In particular, even though reg1 is declared to be a Bool, Coq cannot infer it when it is read (or written) in an action. It's a good idea to always specify the type for register reads (and writes) *) Write @^"reg1" : Bool <- !(#x8); (* Writing back the negation of x8 (which contained the value read from register reg1) into reg1. Note that !e gives the negation of boolean expression e *) (* Now, we will look at a LETA block below. It is different from the LET block -- one can perform various actions like reading an writing registers, etc, whereas a LET is simply binding an expression to a name *) LETA x9: Bool <- ( Read x10 <- @^"reg2"; LET pred : Bit 20 <- #x10 - #x1; Write @^"reg2" <- #x10 - #x1; (* This performs 2s complement subtraction and sets the value to reg2 *) Ret (#pred == $2) (* This returns a value evaluated from the LETA block. All actions must end with a return statement. The == is an operation of expressions that checks if the two sides of the == are equal *) ); LET x10 <- !(#x9); (* The bound variable x9 can be used just like any other LET-bounded or Register Read variable *) (* Next, we will look at if-then-else actions. The following code either writes true to reg5 or to reg6 depending on x10 *) If (#x10) then ( Write @^"reg5" <- $$ true; (* if and else part of the if-then-else statement should also end with a return statement *) (* Retv is a syntactic sugar for returning a value of type Bit 0, which contains no information *) Retv ) else ( Write @^"reg6" <- $$ true; Retv); (* Unlike conventional if-then-else, in Kami, they can also return a value which can be bound to a variable to be used later *) If (!#x10) then ( Write @^"reg5" <- $$ false; LET x: Bit 5 <- $3; Ret #x ) else ( Write @^"reg6" <- $$ true; LET y: Bit 5 <- $8; Ret #y) as z; (* We bind the return of if-then-else to z *) (* We use the return of if-then-else in the rest of the actions, i.e. we use z *) LET x11 <- #z; (* It is also legal to omit the else part. But then, the if part cannot return any value that can be bound *) If (!#x10) then ( Read x1 : Bool <- @^"reg1"; (* Note that you can rebind the names - the most recent binding is the one that will be used when the name is referred *) Retv ); Call x12 : Bool <- "extMeth1"(#x7: Bit 20); (* This construct creates an external method call *) Call "extMeth2"(#x7: Bit 20); (* If the method returns a Bit 0, then the return can be omitted *) Call x13: Bit 4 <- "extMeth3"(); (* Similarly, if the method's argument is a Bit 0, then the argument can be omitted *) Call "extMeth4"(); (* If the return value and argument are both of type Bit 0, both of them can be omitted *) (* Methods cannot take multiple arguments. If multiple values have to be passed, create a struct and pass it *) (* The return values of the methods are bound to the names before <- as appropriate. For instance, we can refer to x12 and x13 *) LET x14 <- #x13; LET x15: Bool <- !#x12; (* We can write display statements in Kami, which gets printed whenever the rule is executed *) (* We supply a list of entities to be printed to the System command *) System ( DispString _ "Hello World\n" :: DispString _ "Val1 Hex: " :: (* To display a kami expression all in hex: *) DispHex #x13 :: DispString _ "Val1 Binary: " :: (* To display a kami expression all in binary *) DispBinary #x13 :: DispString _ "Val1 Decimal: " :: (* To display a kami expression all in decimal *) DispDecimal #x13 :: (* We can also display structs and arrays in hex, binary or decimal *) DispHex #x6 :: (* Structs are displayed as { fieldName1: val1; fieldName2: val2; ... }, where the values are in binary, decimal or hex *) DispHex #x3 :: (* Arrays are displayed as { 0: val1; fieldName2: 1; ...; fieldNameNMinus1: valNMinus1 }, where the values are in binary, decimal or hex *) (* One can also finish execution in a System statment *) Finish _ :: (* This is useful when the System action is sitting in an if-then-else predicate, to finish simulation when the predicate is true *) nil); LET x100: Void <- $$ (ZToWord 0 0); (* Void is literally Bit 0, and WO is the only way to create a value of type Bit 0 *) (* Finally, we end any action by a return statement *) Retv ) (* One can write multiple rules, which may update the same register, but must call different methods *) with Rule @^"rule2" := ( Write @^"reg1" : Bool <- $$ true ; Read x : Bit 20 <- @^"reg2"; Call "extMeth2_2"(#x: _); Retv ) (* This rule showcases all the expressions one can write in Kami, unlike rule1, which showcased all the actions *) with Rule @^"rule3" := ( LET x1: Bool <- $$ true ; LET x2: Bool <- $$ false ; (* Boolean Not *) LET x3 <- !#x1; (* Boolean And *) LET x4 <- #x1 && #x2 ; (* Boolean Or *) LET x5 <- #x1 || #x2 ; (* Boolean Xor *) LET x6 <- #x1 ^^ #x2 ; LET x7: Bit 10 <- $3; LET x8: Bit 10 <- $4; LET x9: Bit 20 <- $5; (* Bitwise inversion *) LET x10 <- ~#x7; (* And reduction, that is And all the bits in the bit vector *) LET x100 <- UniBit (UAnd _) #x10; (* Or reduction, that is Or all the bits in the bit vector *) LET x101 <- UniBit (UOr _) #x10; (* Or reduction, that is XZor all the bits in the bit vector *) LET x102 <- UniBit (UXor _) #x10; (* Bitwise subtraction, unsigned 2's complement *) LET x14 <- #x7 - #x8; (* Shift left logical *) LET x15 <- #x9 << #x8; (* Shift right logical *) LET x16 <- #x9 >> #x8; (* Shift right arithmetic *) LET x17 <- #x9 >>> #x8; (* Concatenate *) LET x18 <- {< #x14, #x9, #x17 >}; (* Bitwise Add, unsigned *) LET x19 <- #x7 + #x8; (* Bitwise Mul, unsigned *) LET x20 <- #x7 * #x8; (* Bitwise And *) LET x11 <- #x7 .& #x8; (* Bitwise Or *) LET x12 <- #x7 .| #x8; (* Bitwise Xor *) LET x13 <- #x7 .^ #x8; (* Extract a bit-range *) LET x141 <- #x13$[3:4]; (* Extract the LSBits after truncating. Note that the argument to TruncLsb has the LSB size first followed by MSB size *) LET x142: Bit 8 <- UniBit (TruncLsb 8 2) #x13; (* Extract the MSBits after truncating. Note that the argument to TruncLsb has the LSB size first followed by MSB size *) LET x143: Bit 2 <- UniBit (TruncMsb 8 2) #x13; (* Expression if-then-else *) LET x21 <- IF !#x3 then #x12 else #x13; (* Maybe is a STRUCT with 2 values: valid: Bool and data: of a given kind. You can build a struct expression as follows *) LET x22 : Maybe (Bit 10) <- STRUCT { "valid" ::= #x6 ; "data" ::= #x10 } ; LET x23 <- STRUCT { "valid" ::= (!#x6) ; "data" ::= (#x10 + #x8) } ; (* One can have an if-then-else over STRUCTs (and Arrays) *) LET x24 <- IF #x3 then #x22 else #x23 ; (* You can build Arrays *) LET x25 : Array 2 Bool <- ARRAY {#x6; #x6 && #x2}; (* Read a field in a struct using @% *) LET x26 <- #x23@%"data"; (* Read an element in an array using @[]. The index should have bit width of exactly ceiling (log2 size of the array) *) LET x27 <- #x25@[#x14$[3:3]]; (* Read an element in an array using constant index. The index is formed using Fin.t values Fin.F1, Fin.FS Fin.F1, etc *) LET x28 <- ReadArrayConst #x25 (Fin.F1); LET x29 <- ReadArrayConst #x25 (Fin.FS Fin.F1); (* An array element can be updated using the following. Here, index x14[2:2] is updated to !x3 *) LET x30 <- #x25@[#x14$[3:3] <- !#x3]; (* An struct field can be updated using the following. Here, "valid" is updated to !x3 *) LET x31 <- #x23@%["valid" <- !#x3]; (* SignExtend a bit vector *) LET _ : Bit 20 <- SignExtend _ #x13; (* ZeroExtend a bit vector *) LET _ : Bit 20 <- ZeroExtend _ #x13; (* OneExtend a bit vector *) LET _ : Bit 20 <- OneExtend _ #x13; (* SignExtend or Truncate depending on the sizes *) LET _ : Bit 20 <- SignExtendTruncLsb _ #x13; (* ZeroExtend or Truncate depending on the sizes *) LET _ : Bit 20 <- ZeroExtendTruncLsb _ #x13; (* OneExtend or Truncate depending on the sizes *) LET _ : Bit 20 <- OneExtendTruncLsb _ #x13; (* To convert a complex type into a bit vector, we can use the pack function *) LET x: Bit 11 <- pack #x23 ; (* Note that since x23 is a value of type Maybe (Bit 10), the packed value has 11 bits - the 10 bits of data + a valid bit *) (* To create a value of a complex type back from a bitvector, we can use the unpack function *) LET y1: Bit 11 <- $4; LET y <- unpack (Maybe (Bit 10)) #y1; (* One can create a non-deterministic value of any type. But this can be used only in specification. Such a construct cannot generate any circuit *) Nondet r1: Bit 11; (* Sometimes it is useful to write expressions using let-constructs. The core Kami does not support let-expressions. Instead it requires you to write actions if let-blocks are needed. Actions, however, are non-deterministic. So, if we want to write a simple expression using let-blocks, we use a "LetExprSyntax" and convert it to actions using "convertLetExprSyntax_ActionT" as follows: *) LETA r2: Bit 10 <- convertLetExprSyntax_ActionT ( LETC k1: Bit 10 <- #x13 .| #x7; LETC k2 <- (#x8 .| #k1); (* We can have if-then-else inside let-expressions. The predicate is a simple expression, *not* a let-expression *) IfE (#k2 == $3) then ( SystemE ( DispString _ "Hello World\n" :: DispString _ "Val1 Hex: " :: DispHex #x13 :: nil ); RetE #k1 ) else ( RetE (#k1 + $4)) as k3; (* We can omit the else clause and/or the return value in an if-then-else just like for actions *) IfE (#k2 == #k3) then ( SystemE ( DispString _ "Bye\n" :: nil ); RetE ($$ (ZToWord 0 0))); IfE (#k2 == (#k3 + $1)) then ( SystemE ( DispString _ "Bye\n" :: nil ) ; RetE ($$ (ZToWord 0 0))) else ( SystemE ( DispString _ "Good Bye\n" :: nil ) ; RetE ($$ (ZToWord 0 0))); RetE (#k2 + #k3) ) ; (* Inside let expressions, you can have let bindings of expressions, system calls (i.e. display statements or finish statements), and if-then-else statements *) Retv) }. (* One can also write modules parameterized by various gallina terms, eg bit-widths etc. Sometimes, Coq cannot prove equivalence of various gallina terms, in which case you construct the module using the refine tactic as follows. In the example below, we have two parameters m and n of type nat. We define two registers of type Bit (n+m) and Bit (m+n) and we try to assign from one to the other. Since Coq cannot prove (m+n) = (n+m), we use "castBits" to convert the bit vector from one to another. The proof itself can be finished using lia. *) Variable n m : nat. Definition exampleModule2: Mod. refine ( MODULE { Register @^"reg10": Bit (n + m) <- ($0)%word with Register @^"reg11": Bit (m + n) <- ($1)%word with Rule @^"test" := ( Read x : Bit (n + m) <- @^"reg10"; Write @^"reg11" : Bit (m + n) <- castBits _ #x; Retv ) }); abstract lia. Defined. End exampleModule. (* Writing ActionT ty *) (* Tactics *) ================================================ FILE: Tutorial/TacticsEx.v ================================================ Require Import Kami.AllNotations. Section Named. Variable sz: nat. Variable name: string. Local Notation "@^ x" := (name ++ "_" ++ x)%string (at level 0). (* The implementation which keeps incrementing a counter in one step and sends the value of the counter in the other *) Definition IncrementerImpl := MODULE { Register @^"counter" : Bit sz <- Default with Register @^"counter1" : Bit sz <- Default with Register @^"isSending" : Bool <- true with Rule @^"send_and_inc" := ( Read isSending: Bool <- @^"isSending" ; If #isSending then ( Read counter: Bit sz <- @^"counter" ; Call "counterVal"(#counter: _); Write @^"isSending" <- !#isSending ; Retv) else ( Read counter: Bit sz <- @^"counter" ; Write @^"counter" <- #counter + $1; Write @^"isSending" <- !#isSending ; Retv ); Retv) }. (* The specification which combines the two actions in one rule *) Definition IncrementerSpec := MODULE { Register @^"counter" : Bit sz <- Default with Register @^"counter1" : Bit sz <- Default with Rule @^"send_and_inc" := ( Read counter: Bit sz <- @^"counter" ; Call "counterVal"(#counter: _); Write @^"counter" <- #counter + $1; Retv ) }. (* The invariant connecting the state of the implementation with the state of the spec, including specifying the list of register register names, their types and values *) Record Incrementer_invariant (impl spec: RegsT) : Prop := { counterImpl: word sz ; isSending: bool ; implEq : impl = (@^"counter", existT _ (SyntaxKind (Bit sz)) counterImpl) :: (@^"counter1", existT _ (SyntaxKind (Bit sz)) $0) :: (@^"isSending", existT _ (SyntaxKind Bool) isSending) :: nil ; specEq : spec = (@^"counter", existT _ (SyntaxKind (Bit sz)) (if isSending then counterImpl else counterImpl ^+ $1)) :: (@^"counter1", existT _ (SyntaxKind (Bit sz)) $0) :: nil }. Ltac bsimplify_simulatingRule name := right; exists name; eexists; split; [eauto| do 2 eexists; split; [discharge_SemAction|]]. (* Proving the trace inclusion of the implementation with respect to the spec *) Theorem Incrementer_TraceInclusion: TraceInclusion (Base IncrementerImpl) (Base IncrementerSpec). Proof. (* discharge_simulation with the name of the record holding the invariant will discharge most of the trivial goals and requires the user to specify, for each implementation rule or method, either a specification rule or method that produces the same method calls while maintaining the state invariant or a nil step in the specification. The former is simplified using simplify_simulatingRule, with the rule name. The latter is simplified using simplify_nilStep. discharge_CommonRegisterAuto discharges the goals that require that two methods or a method and rule of the implementation are not combinable by automatically searching for at least one register with the two actions write to *) discharge_simulation Incrementer_invariant; discharge_CommonRegisterAuto. - bsimplify_simulatingRule @^"send_and_inc"; subst. + auto. + simpl. discharge_string_dec. repeat (econstructor; eauto; simpl; subst). rewrite wzero_wplus; auto. - simplify_nilStep. econstructor; simpl; eauto; subst. rewrite ?negb_true_iff in *; subst. rewrite wzero_wplus; simpl; auto. (* Note that while this example does not create spurious existentials, usually, there is a plethora of existentials created that can be instantiated with arbitrary values as they do not affect the proof. These goals are discharged with the following two commands*) Unshelve. all: repeat constructor. Qed. End Named. ================================================ FILE: Utila.v ================================================ (* This library contains useful functions for generating Kami expressions. *) Require Import Kami.Syntax Kami.Notations Kami.LibStruct. Require Import List. Import Word.Notations. Require Import Kami.Lib.EclecticLib. Import ListNotations. Module EqIndNotations. Notation "A || B @ X 'by' E" := (eq_ind_r (fun X => B) A E) (at level 40, left associativity). Notation "A || B @ X 'by' <- H" := (eq_ind_r (fun X => B) A (eq_sym H)) (at level 40, left associativity). End EqIndNotations. Section utila. Open Scope kami_expr. Section defs. Variable ty : Kind -> Type. Fixpoint tagFrom val T (xs : list T) := match xs with | nil => nil | y :: ys => (val, y) :: tagFrom (S val) ys end. Definition tag := @tagFrom 0. (* I. Kami Expression Definitions *) Definition msb (n m : nat) (width : Bit n @# ty) (x : Bit m @# ty) : Bit m @# ty := x >> ($m - width). Definition lsb (n m : nat) (width : Bit n @# ty) (x : Bit m @# ty) : Bit m @# ty := (x .& ~($$(wones m) << width)). Definition slice (n m k : nat) (offset : Bit n @# ty) (width : Bit m @# ty) (x : Bit k @# ty) : Bit k @# ty := ((x >> offset) .& ~($$(wones k) << width)). Definition utila_opt_pkt (k : Kind) (x : k @# ty) (valid : Bool @# ty) : Maybe k @# ty := STRUCT { "valid" ::= valid; "data" ::= x }. Definition utila_opt_default (k : Kind) (default : k @# ty) (x : Maybe k @# ty) : k @# ty := ITE (x @% "valid") (x @% "data") default. Definition utila_opt_bind (j k : Kind) (x : Maybe j @# ty) (f : j @# ty -> Maybe k @# ty) : Maybe k @# ty := ITE (x @% "valid") (f (x @% "data")) (@Invalid ty k). Definition utila_all : list (Bool @# ty) -> Bool @# ty (* := fold_right (fun x acc => x && acc) ($$true). *) := CABool And. Definition utila_any : list (Bool @# ty) -> Bool @# ty (* := fold_right (fun x acc => x || acc) ($$false). *) := (@Kor _ Bool). (* Note: [f] must only return true for exactly one value in [xs]. *) Definition utila_find (k : Kind) (f : k @# ty -> Bool @# ty) (xs : list (k @# ty)) : k @# ty := unpack k (Kor (map (fun x => IF f x then pack x else $0) xs)). (* Note: exactly one of the packets must be valid. *) Definition utila_find_pkt : forall k : Kind, list (Maybe k @# ty) -> Maybe k @# ty := fun k => utila_find (fun x : Maybe k @# ty => x @% "valid"). (* Note: the key match predicate must never return true for more than one entry in [entries]. *) Definition utila_lookup_table (entry_type : Type) (entries : list entry_type) (result_kind : Kind) (entry_match : entry_type -> Bool @# ty) (entry_result : entry_type -> result_kind @# ty) : Maybe result_kind @# ty := utila_find_pkt (map (fun entry => utila_opt_pkt (entry_result entry) (entry_match entry)) entries). (* Note: the key match predicate must never return true for more than one entry in [entries]. *) Definition utila_lookup_table_default (entry_type : Type) (entries : list entry_type) (result_kind : Kind) (entry_match : entry_type -> Bool @# ty) (entry_result : entry_type -> result_kind @# ty) (default : result_kind @# ty) : result_kind @# ty := utila_opt_default default (utila_lookup_table entries entry_match entry_result). (* II. Kami Monadic Definitions *) Structure utila_monad_type := utila_monad { utila_m : Kind -> Type; utila_mbind : forall (j k : Kind), utila_m j -> (ty j -> utila_m k) -> utila_m k; utila_munit : forall k : Kind, k @# ty -> utila_m k; utila_mite : forall k : Kind, Bool @# ty -> utila_m k -> utila_m k -> utila_m k }. Arguments utila_mbind {u} j k x f. Arguments utila_munit {u} k x. Arguments utila_mite {u} k b x y. Section monad_functions. Variable monad : utila_monad_type. Let m := utila_m monad. Let mbind := @utila_mbind monad. Let munit := @utila_munit monad. Let mite := @utila_mite monad. Definition utila_mopt_pkt (k : Kind) (x : k @# ty) (valid : Bool @# ty) : m (Maybe k) := munit (utila_opt_pkt x valid). Definition utila_mopt_default (k : Kind) (default : k @# ty) (x_expr : m (Maybe k)) : m k := mbind k x_expr (fun x : ty (Maybe k) => mite k ((Var ty (SyntaxKind (Maybe k)) x) @% "valid" : Bool @# ty) (munit ((Var ty (SyntaxKind (Maybe k)) x) @% "data" : k @# ty)) (munit default)). Definition utila_mopt_bind (j k : Kind) (x_expr : m (Maybe j)) (f : j @# ty -> m (Maybe k)) : m (Maybe k) := mbind (Maybe k) x_expr (fun x : ty (Maybe j) => mite (Maybe k) ((Var ty (SyntaxKind (Maybe j)) x) @% "valid" : Bool @# ty) (f ((Var ty (SyntaxKind (Maybe j)) x) @% "data")) (munit (@Invalid ty k))). Definition utila_mfoldr (j k : Kind) (f : j @# ty -> k @# ty -> k @# ty) (init : k @# ty) : list (m j) -> (m k) := fold_right (fun (x_expr : m j) (acc_expr : m k) => mbind k x_expr (fun x : ty j => mbind k acc_expr (fun acc : ty k => munit (f (Var ty (SyntaxKind j) x) (Var ty (SyntaxKind k) acc))))) (munit init). Definition utila_mall : list (m Bool) -> m Bool := utila_mfoldr (fun x acc => x && acc) (Const ty true). Definition utila_many : list (m Bool) -> m Bool := utila_mfoldr (fun x acc => x || acc) (Const ty false). Definition utila_mfind (k : Kind) (f : k @# ty -> Bool @# ty) (x_exprs : list (m k)) : m k := mbind k (utila_mfoldr (fun (x : k @# ty) (acc : Bit (size k) @# ty) => ((ITE (f x) (pack x) ($0)) .| acc)) ($0) x_exprs) (fun (y : ty (Bit (size k))) => munit (unpack k (Var ty (SyntaxKind (Bit (size k))) y))). Definition utila_mfind_pkt (k : Kind) : list (m (Maybe k)) -> m (Maybe k) := utila_mfind (fun (pkt : Maybe k @# ty) => pkt @% "valid"). End monad_functions. Arguments utila_mopt_pkt {monad}. Arguments utila_mopt_default {monad}. Arguments utila_mopt_bind {monad}. Arguments utila_mfoldr {monad}. Arguments utila_mall {monad}. Arguments utila_many {monad}. Arguments utila_mfind {monad}. Arguments utila_mfind_pkt {monad}. (* III. Kami Let Expression Definitions *) Definition utila_expr_monad : utila_monad_type := utila_monad (LetExprSyntax ty) (fun j k => @LetE ty k j) (@NormExpr ty) (fun (k : Kind) (b : Bool @# ty) (x_expr y_expr : k ## ty) => LETE x : k <- x_expr; LETE y : k <- y_expr; RetE (ITE b (#x) (#y))). Definition utila_expr_opt_pkt := @utila_mopt_pkt utila_expr_monad. Definition utila_expr_opt_default := @utila_mopt_default utila_expr_monad. Definition utila_expr_opt_bind := @utila_mopt_bind utila_expr_monad. Definition utila_expr_foldr := @utila_mfoldr utila_expr_monad. Definition utila_expr_all := @utila_mall utila_expr_monad. Definition utila_expr_any := @utila_many utila_expr_monad. (* Accepts a Kami predicate [f] and a list of Kami let expressions that represent values, and returns a Kami let expression that outputs the value that satisfies f. Note: [f] must only return true for exactly one value in [xs_exprs]. *) Definition utila_expr_find (k : Kind) (f : k @# ty -> Bool @# ty) (xs_exprs : list (k ## ty)) : k ## ty := LETE y : Bit (size k) <- (utila_expr_foldr (fun x acc => ((ITE (f x) (pack x) ($0)) .| acc)) ($0) xs_exprs); RetE (unpack k (#y)). Arguments utila_expr_find {k} f xs_exprs. (* Accepts a list of Maybe packets and returns the packet whose valid flag equals true. Note: exactly one of the packets must be valid. *) Definition utila_expr_find_pkt (k : Kind) (pkt_exprs : list (Maybe k ## ty)) : Maybe k ## ty := utila_expr_find (fun (pkt : Maybe k @# ty) => pkt @% "valid") pkt_exprs. (* Generates a lookup table containing entries of type [result_kind]. Note: the key match predicate must never return true for more than one entry in [entries]. *) Definition utila_expr_lookup_table (entry_type : Type) (entries : list entry_type) (result_kind : Kind) (entry_match : entry_type -> Bool ## ty) (entry_result : entry_type -> result_kind ## ty) : Maybe result_kind ## ty := utila_expr_find_pkt (map (fun entry : entry_type => LETE result : result_kind <- entry_result entry; LETE matched : Bool <- entry_match entry; utila_expr_opt_pkt #result #matched) entries). (* Generates a lookup table containing entries of type [result_kind]. Returns a default value for entries that do not exist. Note: the key match predicate must never return true for more than one entry in [entries]. *) Definition utila_expr_lookup_table_default (entry_type : Type) (entries : list entry_type) (result_kind : Kind) (entry_match : entry_type -> Bool ## ty) (entry_result : entry_type -> result_kind ## ty) (default : result_kind @# ty) : result_kind ## ty := utila_expr_opt_default default (utila_expr_lookup_table entries entry_match entry_result). (* IV. Kami Action Definitions *) Open Scope kami_action. Definition utila_act_monad : utila_monad_type := utila_monad (@ActionT ty) (fun j k => @LetAction ty k j) (@Return ty) (fun k b (x y : ActionT ty k) => If b then x else y as result; Ret #result). Definition utila_acts_opt_pkt := @utila_mopt_pkt utila_act_monad. Definition utila_acts_opt_default := @utila_mopt_default utila_act_monad. Definition utila_acts_opt_bind := @utila_mopt_bind utila_act_monad. Definition utila_acts_foldr := @utila_mfoldr utila_act_monad. Definition utila_acts_all (xs : list (ActionT ty Bool)) : ActionT ty Bool := GatherActions xs as ys; Ret (CABool And ys). Definition utila_acts_any (xs : list (ActionT ty Bool)) : ActionT ty Bool := GatherActions xs as ys; Ret ((@Kor _ Bool) ys). Definition utila_acts_find (k : Kind) (f : k @# ty -> Bool @# ty) (xs : list (ActionT ty k)) : ActionT ty k := GatherActions xs as ys; Ret (utila_find f ys). Definition utila_acts_find_pkt (k : Kind) (xs : list (ActionT ty (Maybe k))) : ActionT ty (Maybe k) := GatherActions xs as ys; Ret (utila_find_pkt ys). Close Scope kami_action. End defs. Arguments utila_mopt_pkt {ty} {monad} {k}. Arguments utila_mopt_default {ty} {monad} {k}. Arguments utila_mopt_bind {ty} {monad} {j} {k}. Arguments utila_mfoldr {ty} {monad} {j} {k}. Arguments utila_mall {ty} {monad}. Arguments utila_many {ty} {monad}. Arguments utila_mfind {ty} {monad} {k}. Arguments utila_mfind_pkt {ty} {monad} {k}. (* V. Correctness Proofs *) Section ver. Local Notation "{{ X }}" := (evalExpr X). Local Notation "X ==> Y" := (evalExpr X = Y) (at level 75). Local Notation "==> Y" := (fun x => evalExpr x = Y) (at level 75). Let utila_is_true (x : Bool @# type) := x ==> true. Lemma fold_left_andb_forall' : forall (xs : list (Bool @# type)) a, fold_left andb (map (@evalExpr _) xs) a = true <-> Forall utila_is_true xs /\ a = true. Proof. induction xs; simpl; auto; split; intros; auto. - tauto. - rewrite IHxs in H. rewrite andb_true_iff in H. split; try tauto. constructor; simpl; tauto. - dest. inv H. unfold utila_is_true in *; simpl in *. pose proof (conj H4 H3). rewrite <- IHxs in H. auto. Qed. Theorem fold_left_andb_forall : forall xs : list (Bool @# type), fold_left andb (map (@evalExpr _) xs) true = true <-> Forall utila_is_true xs. Proof. intros. rewrite fold_left_andb_forall'. tauto. Qed. Theorem utila_all_correct : forall xs : list (Bool @# type), utila_all xs ==> true <-> Forall utila_is_true xs. Proof. apply fold_left_andb_forall. Qed. Theorem fold_left_andb_forall_false' : forall (xs : list (Bool @# type)) a, fold_left andb (map (@evalExpr _) xs) a = false <-> Exists (fun x : Expr type (SyntaxKind Bool) => evalExpr x = false) xs \/ a = false. Proof. induction xs; simpl; auto; intros; split; try tauto. - intros; auto. destruct H; auto. inv H. - rewrite IHxs. intros. rewrite andb_false_iff in H. destruct H. + left. right; auto. + destruct H. * auto. * left. left. auto. - intros. rewrite IHxs. rewrite andb_false_iff. destruct H. + inv H; auto. + auto. Qed. Theorem fold_left_andb_forall_false : forall xs : list (Bool @# type), fold_left andb (map (@evalExpr _) xs) true = false <-> Exists (fun x : Expr type (SyntaxKind Bool) => evalExpr x = false) xs. Proof. intros. rewrite fold_left_andb_forall_false'. split; intros. - destruct H; congruence. - auto. Qed. Theorem utila_all_correct_false : forall xs : list (Bool @# type), utila_all xs ==> false <-> Exists (fun x : Expr type (SyntaxKind Bool) => evalExpr x = false) xs. Proof. apply fold_left_andb_forall_false. Qed. Theorem fold_left_orb_exists' : forall (xs : list (Bool @# type)) a, fold_left orb (map (@evalExpr _) xs) a = true <-> Exists utila_is_true xs \/ a = true. Proof. induction xs; simpl; auto; split; intros; try discriminate. - auto. - destruct H; auto. inv H. - rewrite IHxs in H. rewrite orb_true_iff in H. destruct H. + left. right. auto. + destruct H; auto. - assert (sth: Exists utila_is_true xs \/ (a0||evalExpr a)%bool = true). { destruct H. - inv H. + right. rewrite orb_true_iff. auto. + auto. - right. rewrite orb_true_iff. auto. } rewrite <- IHxs in sth. auto. Qed. Theorem fold_left_orb_exists : forall xs : list (Bool @# type), fold_left orb (map (@evalExpr _) xs) false = true <-> Exists utila_is_true xs. Proof. intros. rewrite fold_left_orb_exists'. split; intros; auto. destruct H; congruence. Qed. Theorem utila_any_correct : forall xs : list (Bool @# type), utila_any xs ==> true <-> Exists utila_is_true xs. Proof. apply fold_left_orb_exists. Qed. Theorem fold_left_orb_exists_false' : forall (xs : list (Bool @# type)) a, fold_left orb (map (@evalExpr _) xs) a = false <-> Forall (fun x : Expr type (SyntaxKind Bool) => evalExpr x = false) xs /\ a = false. Proof. induction xs; simpl; split; auto; intros. - inv H; auto. - rewrite IHxs in H. rewrite orb_false_iff in H. split; try tauto. constructor; tauto. - dest. inv H. rewrite IHxs. rewrite orb_false_iff. repeat split; auto. Qed. Theorem fold_left_orb_exists_false : forall xs : list (Bool @# type), fold_left orb (map (@evalExpr _) xs) false = false <-> Forall (fun x : Expr type (SyntaxKind Bool) => evalExpr x = false) xs. Proof. intros. rewrite fold_left_orb_exists_false'. split; intros; dest; auto. Qed. Lemma utila_any_correct_false: forall xs : list (Expr type (SyntaxKind Bool)), evalExpr (utila_any xs) = false <-> Forall (fun x : Expr type (SyntaxKind Bool) => evalExpr x = false) xs. Proof. apply fold_left_orb_exists_false. Qed. End ver. (* VI. Denotational semantics for monadic expressions. *) Structure utila_sem_type := utila_sem { utila_sem_m : utila_monad_type type; utila_sem_interp : forall k : Kind, utila_m utila_sem_m k -> type k; (* [[mbind x f]] = [[ f [[x]] ]] *) utila_sem_bind_correct : forall (j k : Kind) (x : utila_m utila_sem_m j) (f : type j -> utila_m utila_sem_m k), (utila_sem_interp k (utila_mbind utila_sem_m j k x f)) = (utila_sem_interp k (f (utila_sem_interp j x))); (* [[munit x]] = {{x}} *) utila_sem_unit_correct : forall (k : Kind) (x : k @# type), utila_sem_interp k (utila_munit (utila_sem_m) x) = evalExpr x; (* [[ mfoldr f init [] ]] = {{init}} *) utila_sem_foldr_nil_correct : forall (j k : Kind) (f : j @# type -> k @# type -> k @# type) (init : k @# type), (utila_sem_interp k (utila_mfoldr f init nil) = evalExpr init); (* [[ mfoldr f init (x0 :: xs) ]] = {{ f #[[x0]] #[[mfoldr f init xs]] }} *) utila_sem_foldr_cons_correct : forall (j k : Kind) (f : j @# type -> k @# type -> k @# type) (init : k @# type) (x0 : utila_m utila_sem_m j) (xs : list (utila_m utila_sem_m j)), (utila_sem_interp k (utila_mfoldr f init (x0 :: xs)) = (evalExpr (f (Var type (SyntaxKind j) (utila_sem_interp j x0)) (Var type (SyntaxKind k) (utila_sem_interp k (utila_mfoldr f init xs)))))) }. Arguments utila_sem_interp {u} {k} x. Arguments utila_sem_bind_correct {u} {j} {k} x f. Arguments utila_sem_unit_correct {u} {k} x. Arguments utila_sem_foldr_nil_correct {u} {j} {k}. Arguments utila_sem_foldr_cons_correct {u} {j} {k}. Section monad_ver. Import EqIndNotations. Variable sem : utila_sem_type. Let monad : utila_monad_type type := utila_sem_m sem. Let m := utila_m monad. Let mbind := utila_mbind monad. Let munit := utila_munit monad. Local Notation "{{ X }}" := (evalExpr X). Local Notation "[[ X ]]" := (@utila_sem_interp sem _ X). Local Notation "#{{ X }}" := (Var type (SyntaxKind _) {{X}}). Local Notation "#[[ X ]]" := (Var type (SyntaxKind _) [[X]]). Hint Rewrite (@utila_sem_bind_correct sem) (@utila_sem_unit_correct sem) (@utila_sem_foldr_cons_correct sem) (@utila_sem_unit_correct sem) : utila_sem_rewrite_db. Let utila_is_true (x : m Bool) : Prop := [[x]] = true. Lemma utila_mall_nil : [[utila_mall ([] : list (m Bool))]] = true. Proof utila_sem_foldr_nil_correct (fun x acc => x && acc) (Const type true). Lemma utila_mall_cons : forall (x0 : m Bool) (xs : list (m Bool)), [[utila_mall (x0 :: xs)]] = andb [[x0]] [[utila_mall xs]]. Proof utila_sem_foldr_cons_correct (fun x acc => x && acc) (Const type true). Theorem utila_mall_correct : forall xs : list (m Bool), [[utila_mall xs]] = true <-> Forall utila_is_true xs. Proof. intro. split. - induction xs. + intro; exact (Forall_nil utila_is_true). + intro H; assert (H0 : [[a]] = true /\ [[utila_mall xs]] = true). apply (@andb_prop [[a]] [[utila_mall xs]]). rewrite <- (utila_mall_cons a xs). assumption. apply (Forall_cons a). apply H0. apply IHxs; apply H0. - apply (Forall_ind (fun ys => [[utila_mall ys]] = true)). + apply utila_mall_nil. + intros y0 ys H H0 F. rewrite utila_mall_cons. apply andb_true_intro. auto. Qed. Lemma utila_many_nil : [[utila_many ([] : list (m Bool)) ]] = false. Proof utila_sem_foldr_nil_correct (fun x acc => (@Kor _ Bool) [x; acc]) (Const type false). Lemma utila_many_cons : forall (x0 : m Bool) (xs : list (m Bool)), [[utila_many (x0 :: xs)]] = orb [[x0]] [[utila_many xs]]. Proof utila_sem_foldr_cons_correct (fun x acc => (@Kor _ Bool) [x; acc]) (Const type false). Theorem utila_many_correct : forall xs : list (m Bool), [[utila_many xs]] = true <-> Exists utila_is_true xs. Proof fun xs => conj (list_ind (fun ys => [[utila_many ys]] = true -> Exists utila_is_true ys) (fun H : [[utila_many [] ]] = true => let H0 : false = true := H || X = true @X by <- utila_many_nil in False_ind _ (diff_false_true H0)) (fun y0 ys (F : [[utila_many ys]] = true -> Exists utila_is_true ys) (H : [[utila_many (y0 :: ys)]] = true) => let H0 : [[y0]] = true \/ [[utila_many ys]] = true := orb_prop [[y0]] [[utila_many ys]] (eq_sym (utila_many_cons y0 ys || X = _ @X by <- H)) in match H0 with | or_introl H1 => Exists_cons_hd utila_is_true y0 ys H1 | or_intror H1 => Exists_cons_tl y0 (F H1) end) xs) (@Exists_ind (m Bool) utila_is_true (fun ys => [[utila_many ys]] = true) (fun y0 ys (H : [[y0]] = true) => orb_true_l [[utila_many ys]] || orb X [[utila_many ys]] = true @X by H || X = true @X by utila_many_cons y0 ys) (fun y0 ys (H : Exists utila_is_true ys) (F : [[utila_many ys]] = true) => orb_true_r [[y0]] || orb [[y0]] X = true @X by F || X = true @X by utila_many_cons y0 ys) xs). Definition utila_null (k : Kind) : k @# type := unpack k (Var type (SyntaxKind (Bit (size k))) (natToWord (size k) 0)). Lemma utila_mfind_nil : forall (k : Kind) (f : k @# type -> Bool @# type), [[utila_mfind f ([] : list (m k))]] = {{utila_null k}}. Proof fun k f => eq_refl {{utila_null k}} || X = {{utila_null k}} @X by utila_sem_unit_correct (unpack k (Var type (SyntaxKind (Bit (size k))) (natToWord (size k) 0))) || [[munit (unpack k (Var type (SyntaxKind (Bit (size k))) X))]] = {{utila_null k}} @X by utila_sem_foldr_nil_correct (fun x acc => (ITE (f x) (pack x) ($0) .| acc)) ($0) || X = {{utila_null k}} @X by utila_sem_bind_correct (utila_mfoldr (fun x acc => (ITE (f x) (pack x) ($0) .| acc)) ($0) []) (fun y => munit (unpack k (Var type (SyntaxKind (Bit (size k))) y))). Lemma utila_mfind_tl : forall (k : Kind) (f : k @# type -> Bool @# type) (x0 : m k) (xs : list (m k)), {{f #[[x0]]}} = false -> [[utila_mfind f (x0 :: xs)]] = [[utila_mfind f xs]]. Proof. intros. unfold utila_mfind. autorewrite with utila_sem_rewrite_db. simpl. rewrite H. simpl. repeat (rewrite wor_wzero). reflexivity. Qed. End monad_ver. Section expr_ver. Import EqIndNotations. Local Notation "{{ X }}" := (evalExpr X). Local Notation "[[ X ]]" := (evalLetExpr X). Local Notation "#[[ X ]]" := (Var type (SyntaxKind _) [[X]]) (only parsing) : kami_expr_scope. Local Notation "X ==> Y" := (evalLetExpr X = Y) (at level 75). Local Notation "==> Y" := (fun x => evalLetExpr x = Y) (at level 75). Let utila_is_true (x : Bool ## type) := x ==> true. Let utila_expr_bind (j k : Kind) (x : j ## type) (f : type j -> k ## type) : k ## type := @LetE type k j x f. Lemma utila_expr_bind_correct : forall (j k : Kind) (x : j ## type) (f : type j -> k ## type), [[utila_expr_bind x f]] = [[f [[x]] ]]. Proof fun j k x f => (eq_refl [[utila_expr_bind x f]]). Lemma utila_expr_unit_correct : forall (k : Kind) (x : k @# type), [[RetE x]] = {{x}}. Proof fun k x => eq_refl. Theorem utila_expr_foldr_correct_nil : forall (j k : Kind) (f : j @# type -> k @# type -> k @# type) (init : k @# type), utila_expr_foldr f init nil ==> {{init}}. Proof fun j k f init => eq_refl ({{init}}). Theorem utila_expr_foldr_correct_cons : forall (j k : Kind) (f : j @# type -> k @# type -> k @# type) (init : k @# type) (x0 : j ## type) (xs : list (j ## type)), [[utila_expr_foldr f init (x0 :: xs)]] = {{ f (Var type (SyntaxKind j) [[x0]]) (Var type (SyntaxKind k) [[utila_expr_foldr f init xs]]) }}. Proof fun (j k : Kind) (f : j @# type -> k @# type -> k @# type) (init : k @# type) (x0 : j ## type) (xs : list (j ## type)) => eq_refl. Definition utila_expr_sem : utila_sem_type := utila_sem (utila_expr_monad type) evalLetExpr utila_expr_bind_correct utila_expr_unit_correct utila_expr_foldr_correct_nil utila_expr_foldr_correct_cons. Theorem utila_expr_all_correct : forall xs : list (Bool ## type), utila_expr_all xs ==> true <-> Forall utila_is_true xs. Proof utila_mall_correct utila_expr_sem. Theorem utila_expr_any_correct : forall xs : list (Bool ## type), utila_expr_any xs ==> true <-> Exists utila_is_true xs. Proof utila_many_correct utila_expr_sem. Lemma utila_ite_l : forall (k : Kind) (x y : k @# type) (p : Bool @# type), {{p}} = true -> {{ITE p x y}} = {{x}}. Proof fun k x y p H => eq_ind true (fun q : bool => (if q then {{x}} else {{y}}) = {{x}}) (eq_refl {{x}}) {{p}} (eq_sym H). Lemma utila_ite_r : forall (k : Kind) (x y : k @# type) (p : Bool @# type), {{p}} = false -> {{ITE p x y}} = {{y}}. Proof fun k x y p H => eq_ind false (fun q : bool => (if q then {{x}} else {{y}}) = {{y}}) (eq_refl {{y}}) {{p}} (eq_sym H). (* The following section proves that the utila_expr_find function is correct. To prove, this result we make three four intuitive conjectures and prove two lemmas about the expressions produced by partially reducing utila_expr_find. *) Section utila_expr_find. (* The clauses used in Kami switch expressions. *) Let case (k : Kind) (f : k @# type -> Bool @# type) (x : k @# type) (acc : Bit (size k) @# type) : Bit (size k) @# type := (ITE (f x) (pack x) ($ 0) .| acc). Conjecture unpack_pack : forall (k : Kind) (x : k ## type), {{unpack k (Var type (SyntaxKind (Bit (size k))) {{pack (Var type (SyntaxKind k) [[x]])}})}} = [[x]]. Conjecture kami_exprs_eq_dec : forall (k : Kind) (x y : k ## type), {x = y} + {x <> y}. Lemma kami_in_dec : forall (k : Kind) (x : k ## type) (xs : list (k ## type)), {In x xs} + {~ In x xs}. Proof fun k x xs => in_dec (@kami_exprs_eq_dec k) x xs. (* Note: submitted a pull request to the bbv repo to include this lemma in Word.v *) Lemma utila_expr_find_lm0 : forall (k : Kind) (f : k @# type -> Bool @# type) (init : Bit (size k) @# type) (x0 : k ## type) (xs : list (k ## type)), {{f (Var type (SyntaxKind k) [[x0]])}} = false -> [[utila_expr_foldr (case f) init (x0 :: xs)]] = [[utila_expr_foldr (case f) init xs]]. Proof. (intros). (unfold evalLetExpr at 1). (unfold utila_expr_foldr at 1). (unfold utila_mfoldr). (intros). (simpl). (rewrite wor_wzero). (fold evalLetExpr). (fold utila_expr_foldr). (rewrite H). (rewrite wor_wzero). (unfold utila_expr_foldr). (unfold utila_mfoldr). (unfold utila_mbind). (simpl). reflexivity. Qed. Lemma utila_expr_find_lm1 : forall (k : Kind) (f : k @# type -> Bool @# type) (init : Bit (size k) @# type) (xs : list (k ## type)), (forall x, In x xs -> {{f #[[x]]}} = false) -> [[utila_expr_foldr (case f) init xs]] = {{init}}. Proof fun (k : Kind) (f : k @# type -> Bool @# type) (init : Bit (size k) @# type) => list_ind (fun xs => (forall x, In x xs -> {{f #[[x]]}} = false) -> [[utila_expr_foldr (case f) init xs]] = {{init}}) (fun _ => utila_expr_foldr_correct_nil (case f) init) (fun x0 xs (F : (forall x, In x xs -> {{f #[[x]]}} = false) -> [[utila_expr_foldr (case f) init xs]] = {{init}}) (H : forall x, In x (x0 :: xs) -> {{f #[[x]]}} = false) => let H0 : forall x, In x xs -> {{f #[[x]]}} = false := fun x H0 => H x (or_intror (x0 = x) H0) in let H1 : [[utila_expr_foldr (case f) init xs]] = {{init}} := F H0 in let H2 : {{f #[[x0]]}} = false := H x0 (or_introl (In x0 xs) (eq_refl x0)) in utila_expr_find_lm0 f init x0 xs H2 || [[utila_expr_foldr (case f) init (x0 :: xs)]] = a @a by <- H1). (* This proof proceeds using proof by cases when [xs = y0 :: ys]. There are four cases, either [x = y0] or [x <> y0] and either [In x ys] or [~ In x ys]. If [x = y0] then [{{case f y0}} = {{pack x0}}]. Otherwise [{{case f y0}} = {{$0}}]. Similarly, when [x] is in [ys], [[[utila_expr_fold _ _ ys]] = {{pack x}}]. Otherwise, it equals [{{$0}}]. The only case where the result would not equal [{{pack x}}] is when [y0 <> x] and [~ In x ys]. But this contradicts the assumption that [x] is in [(y0::ys)]. Hence, we conclude that [[[utila_expr_foldr _ _ (y0 :: ys)]] = {{pack x}}]. *) Lemma utila_expr_find_lm2 : forall (k : Kind) (f : k @# type -> Bool @# type) (x : k ## type) (xs : list (k ## type)), (unique (fun x => In x xs /\ {{f #[[x]]}} = true) x) -> [[utila_expr_foldr (case f) ($0) xs]] = {{pack #[[x]]}}. Proof. exact (fun (k : Kind) (f : k @# type -> Bool @# type) (x : k ## type) => list_ind (fun xs => unique (fun x => In x xs /\ {{f #[[x]]}} = true) x -> [[utila_expr_foldr (case f) ($0)%kami_expr xs]] = {{pack #[[x]]}}) (* I. contradictory case. *) (fun H => False_ind _ (proj1 (proj1 H))) (* II. *) (fun x0 xs (F : unique (fun x => In x xs /\ {{f #[[x]]}} = true) x -> [[utila_expr_foldr (case f) ($0) xs]] = {{pack #[[x]]}}) (H : unique (fun x => In x (x0 :: xs) /\ {{f #[[x]]}} = true) x) => let fx_true : {{f #[[x]]}} = true := proj2 (proj1 H) in let eq_x : forall y, (In y (x0 ::xs) /\ {{f #[[y]]}} = true) -> x = y := proj2 H in let eq_pack_x : In x xs -> [[utila_expr_foldr (case f) ($0)%kami_expr xs]] = {{pack #[[x]]}} := fun in_x_xs => F (conj (conj in_x_xs fx_true) (fun y (H0 : In y xs /\ {{f #[[y]]}} = true) => eq_x y (conj (or_intror (x0 = y) (proj1 H0)) (proj2 H0)))) in sumbool_ind (fun _ => [[utila_expr_foldr (case f) ($0) (x0 :: xs)]] = {{pack #[[x]]}}) (* II.A *) (fun eq_x0_x : x0 = x => let fx0_true : {{f #[[x0]]}} = true := fx_true || {{f #[[a]]}} = true @a by eq_x0_x in let red0 : [[utila_expr_foldr (case f) ($0)%kami_expr (x0 :: xs)]] = {{pack #[[x]]}} ^| [[utila_expr_foldr (case f) _ xs]] := utila_expr_foldr_correct_cons (case f) ($0)%kami_expr x0 xs || _ = a ^| [[utila_expr_foldr (case f) _ xs]] @a by <- wor_wzero _ (if {{f #[[x0]]}} then {{pack #[[x0]]}} else (ZToWord _ 0)) || _ = (if a : bool then _ else _) ^| _ @a by <- fx0_true || _ = {{pack #[[a]]}} ^| _ @a by <- eq_x0_x in sumbool_ind (fun _ => [[utila_expr_foldr (case f) ($0)%kami_expr (x0 :: xs)]] = {{pack #[[x]]}}) (* II.A.1 *) (fun in_x_xs : In x xs => red0 || _ = _ ^| a @a by <- eq_pack_x in_x_xs || _ = a @a by <- wor_idemp _ {{pack #[[x]]}}) (* II.A.2 *) (fun not_in_x_xs : ~ In x xs => let eq_0 : [[utila_expr_foldr (case f) ($0)%kami_expr xs]] = {{$0}} := utila_expr_find_lm1 f ($0)%kami_expr xs (fun y (in_y_xs : In y xs) => not_true_is_false {{f #[[y]]}} (fun fy_true : {{f #[[y]]}} = true => not_in_x_xs (in_y_xs || In a xs @a by eq_x y (conj (or_intror _ in_y_xs) fy_true)))) in red0 || _ = _ ^| a @a by <- eq_0 || _ = a @a by <- wzero_wor _ {{pack #[[x]]}}) (kami_in_dec x xs)) (* II.B *) (fun not_eq_x0_x : x0 <> x => let fx0_false : {{f #[[x0]]}} = false := not_true_is_false {{f #[[x0]]}} (fun fx0_true : {{f #[[x0]]}} = true => not_eq_x0_x (eq_sym (eq_x x0 (conj (or_introl _ eq_refl) fx0_true)))) in (* prove partial reduction - assume that x0 <> x *) sumbool_ind (fun _ => [[utila_expr_foldr (case f) ($0) (x0 :: xs)]] = {{pack #[[x]]}}) (* II.B.1 *) (fun in_x_xs : In x xs => utila_expr_find_lm0 f ($0) x0 xs fx0_false || _ = a @a by <- eq_pack_x in_x_xs) (* II.B.2 contradictory case - x must be in x0 :: xs. *) (fun not_in_x_xs : ~ In x xs => False_ind _ (or_ind not_eq_x0_x not_in_x_xs (proj1 (proj1 H)))) (kami_in_dec x xs)) (kami_exprs_eq_dec x0 x))). Qed. Theorem utila_expr_find_correct : forall (k : Kind) (f : k @# type -> Bool @# type) (xs : list (k ## type)) (x : k ## type), (unique (fun y => In y xs /\ {{f #[[y]]}} = true) x) -> [[utila_expr_find f xs]] = [[x]]. Proof. (intros). (unfold utila_expr_find). (unfold evalLetExpr at 1). (fold evalLetExpr). replace (fun (x0 : Expr type (SyntaxKind k)) (acc : Expr type (SyntaxKind (Bit (size k)))) => (Kor ((IF f x0 then pack x0 else (Const type (natToWord _ 0))) :: acc :: nil))) with (case f). (rewrite (utila_expr_find_lm2 f xs H)). (apply unpack_pack). (unfold case). reflexivity. Qed. End utila_expr_find. Theorem utila_expr_find_pkt_correct : forall (k : Kind) (xs : list (Maybe k ## type)) (x : Maybe k ## type), (unique (fun y => In y xs /\ {{#[[y]] @% "valid"}} = true) x) -> [[utila_expr_find_pkt xs]] = [[x]]. Proof. exact (fun k xs => utila_expr_find_correct (fun y : Maybe k @# type => y @% "valid") xs). Qed. Close Scope kami_expr. End expr_ver. (* Conversions between list and Array *) Section ArrayList. Variable A: Kind. Notation ArrTy ty n := (Array n A @# ty). Local Open Scope kami_expr. Definition array_to_list' {ty n} (xs: ArrTy ty n) idxs : list (A @# ty) := map (fun i => ReadArrayConst xs i) idxs. Definition array_to_list {ty n} (xs: ArrTy ty n) : list (A @#ty) := array_to_list' xs (getFins n). Definition list_to_array {ty} (xs: list (A @# ty)) : ArrTy ty (length xs) := BuildArray (fun i => nth_Fin xs i). Lemma array_to_list_len {ty} : forall n (xs: ArrTy ty n), n = length (array_to_list xs). Proof. intros; unfold array_to_list, array_to_list'. rewrite map_length, getFins_length; auto. Qed. Lemma array_to_list_id : forall (xs: list (A @# type)), map (@evalExpr _) (array_to_list (list_to_array xs)) = map (@evalExpr _) xs. Proof. unfold array_to_list, array_to_list'; intros. rewrite map_map; cbn. induction xs; cbn; auto. rewrite map_map, <- IHxs; auto. Qed. Lemma list_to_array_id : forall n (xs: ArrTy type n) (i: Fin.t n), let i' := Fin.cast i (array_to_list_len xs) in (evalExpr (list_to_array (array_to_list xs))) i' = (evalExpr xs) i. Proof. intros; cbn; subst i'. unfold array_to_list, array_to_list'. erewrite nth_Fin_nth. rewrite map_nth; cbn. rewrite fin_to_nat_cast, getFins_nth; auto. Unshelve. auto. Qed. Lemma array_to_list'_forall {ty} : forall n idxs (xs: ArrTy ty n), Forall2 (fun i v => v = ReadArrayConst xs i) idxs (array_to_list' xs idxs). Proof. induction idxs; cbn; intros *; constructor; eauto. Qed. Lemma array_to_list_forall {ty} : forall n (xs: ArrTy ty n), Forall2 (fun i v => v = ReadArrayConst xs i) (getFins n) (array_to_list xs). Proof. unfold array_to_list; intros; apply array_to_list'_forall. Qed. Lemma array_to_list_nth {ty} : forall n (xs: ArrTy ty n) (i: Fin.t n) i', i' = proj1_sig (Fin.to_nat i) -> nth_error (array_to_list xs) i' = Some (ReadArrayConst xs i). Proof. intros. assert (Hi': (i' < n)%nat). { destruct (Fin.to_nat i); subst; cbn; auto. } rewrite <- getFins_length in Hi'. pose proof (array_to_list_forall xs) as Hall. assert (Hlen: length (array_to_list xs) = n). { apply Forall2_length in Hall. rewrite getFins_length in Hall; auto. } assert (exists x, nth_error (array_to_list xs) i' = Some x) as (? & Hnth). { eapply nth_error_not_None. rewrite nth_error_Some. rewrite Hlen, <- getFins_length; auto. } pose proof (getFins_nth_error i) as Hnth'; cbn in Hnth'; subst. eapply Forall2_nth_error in Hall; eauto; subst; auto. Qed. Corollary in_array_to_list {ty} : forall n (arr : ArrTy ty n) i, In (ReadArrayConst arr i) (array_to_list arr). Proof. intros; eauto using nth_error_In, array_to_list_nth. Qed. Definition array_forall {ty n} (f: A @# ty -> Bool @# ty) (xs: ArrTy ty n) : Bool @# ty := utila_all (map f (array_to_list xs)). Lemma array_forall_correct : forall f n (xs: ArrTy _ n), evalExpr (array_forall f xs) = true <-> Forall (fun v => evalExpr (f v) = true) (array_to_list xs). Proof. unfold array_forall; intros. set (ys := array_to_list xs) in *; clearbody ys. rewrite utila_all_correct; split; intros Hall. - induction ys; constructor; inv Hall; auto. - induction ys; constructor; inv Hall; auto. Qed. Definition fin_to_bit {ty n} (i: Fin.t n) : Bit (Nat.log2_up n) @# ty := Const _ (natToWord _ (proj1_sig (Fin.to_nat i))). Definition array_forall_except {ty n} (f: A @# ty -> Bool @# ty) (xs: ArrTy ty n) (j: Bit (Nat.log2_up n) @# ty) : Bool @# ty := utila_all (map (fun vi => let '(v, i) := vi in (j == fin_to_bit i) || f v) (List.combine (array_to_list xs) (getFins n)))%kami_expr. Lemma array_forall_except_correct : forall f n (xs: ArrTy _ n) j, evalExpr (array_forall_except f xs j) = true <-> Forall2 (fun v i => evalExpr (j == fin_to_bit i) = false -> evalExpr (f v) = true) (array_to_list xs) (getFins n). Proof. unfold array_forall_except; intros. assert (Hlen: length (getFins n) = length (array_to_list xs)) by (eauto using Forall2_length, array_to_list_forall). rewrite getFins_length in Hlen. set (ys := array_to_list xs) in *; clearbody ys. rewrite utila_all_correct; split; intros Hall; subst. - rewrite Forall_map in Hall. rewrite <- Forall_combine by (rewrite getFins_length; auto). set (zs := List.combine _ _) in *; clearbody zs. induction zs as [| (? & ?) zs]; constructor; inv Hall; auto; cbn in *. rewrite orb_true_iff in *; intuition congruence. - rewrite Forall_map. rewrite <- Forall_combine in Hall by (rewrite getFins_length; auto). set (zs := List.combine _ _) in *; clearbody zs. induction zs as [| (? & ?) zs]; constructor; inv Hall; auto; cbn in *. rewrite orb_true_iff in *. destruct (getBool _); intuition. Qed. End ArrayList. Local Open Scope kami_action. (* Accepts a list of register names [ls] that contains [len] register names, and an index [idx] that references one of these registers and returns the value of type [k] stored in the referenced register. *) Definition readReg ty (ls: list string) len (idx: Bit (Nat.log2_up len) @# ty) k := GatherActions (map (fun '(i, reg) => Read val: k <- reg; Ret (IF $i == idx then pack #val else $0)) (tag ls)) as vals; Ret (unpack k (Kor vals)). Definition writeReg ty (ls: list string) len (idx: Bit (Nat.log2_up len) @# ty) k (newval: k @# ty) := GatherActions (map (fun '(i, reg) => Read val: k <- reg; Write reg: k <- (IF $i == idx then newval else #val); Retv) (tag ls)) as _; Retv. Local Close Scope kami_action. End utila. Lemma snd_tagFrom {A : Type} (l : list A): forall n, map snd (tagFrom n l) = l. Proof. induction l; simpl; auto; intros. f_equal; apply IHl. Qed. Lemma fst_tagFrom {A : Type} (l : list A): forall n, map fst (tagFrom n l) = seq n (length l). Proof. induction l; simpl; auto; intros. f_equal; apply IHl. Qed. Corollary length_tagFrom {A : Type} (l : list A): forall n, length (tagFrom n l) = length l. Proof. intros. rewrite <- (snd_tagFrom l n) at 2. rewrite map_length; reflexivity. Qed. Lemma tagFrom_n {A : Type} (l : list A): forall n t, In t (tagFrom n l) -> n <= fst t < (n + length l). Proof. induction l; simpl; intros; [contradiction|]. destruct H; subst; simpl; [|specialize (IHl _ _ H)]; lia. Qed. Lemma tagFromO_Correct {A : Type} (l : list A): forall t n, In t (tagFrom n l) -> nth_error l ((fst t) - n) = Some (snd t). Proof. induction l; simpl; intros; [contradiction|]. destruct H; subst; simpl. - rewrite Nat.sub_diag; simpl; reflexivity. - specialize (IHl _ _ H). specialize (tagFrom_n _ _ _ H) as P0. assert (a :: l = [a] ++ l) as P by auto. rewrite P, nth_error_app2; simpl; try lia. rewrite <- IHl. f_equal; lia. Qed. Lemma tagApp {A : Type} (l1 l2 : list A): forall m, tagFrom m (l1 ++ l2) = tagFrom m l1 ++ tagFrom (length l1 + m) l2. Proof. induction l1; simpl; auto; intros. f_equal. rewrite <- Nat.add_succ_r. apply IHl1. Qed. ================================================ FILE: WfActionT.v ================================================ Require Export Bool Ascii String Fin List FunctionalExtensionality Psatz PeanoNat. Require Export Kami.Syntax. Inductive Failure := | NativeReg : string -> Failure | NativeLetExpr : Failure | NativeReadNondet : Failure | RegNotFound : string -> Failure | HideMethodNotFound : string -> Failure | RegKindMismatch : string -> FullKind -> FullKind -> Failure | DuplicateMethod : string -> (* Signature -> Signature -> *) Failure | DuplicateRegister : string -> FullKind -> FullKind -> Failure | DuplicateRule : string -> Failure. Fixpoint WfActionT_unit {k} (regs : list (string * {x : FullKind & RegInitValT x})) (a : ActionT (fun _ => unit) k) : list Failure := match a with | MCall meth s e cont => WfActionT_unit regs (cont tt) | LetExpr (SyntaxKind k'') e cont => WfActionT_unit regs (cont tt) | LetExpr (NativeKind t c) e cont => NativeLetExpr :: WfActionT_unit regs (cont c) | LetAction k a cont => WfActionT_unit regs a ++ WfActionT_unit regs (cont tt) | ReadNondet (SyntaxKind k') cont => WfActionT_unit regs (cont tt) | ReadNondet (NativeKind t c) cont => NativeReadNondet :: WfActionT_unit regs (cont c) | ReadReg r (SyntaxKind k') cont => match lookup String.eqb r regs with | Some (existT (SyntaxKind k'') _) => (if Kind_decb k' k'' then [] else [RegKindMismatch r (SyntaxKind k') (SyntaxKind k'')]) ++ WfActionT_unit regs (cont tt) | Some (existT (NativeKind t c) _) => [RegKindMismatch r (SyntaxKind k') (NativeKind c)] | None => [RegNotFound r] end | ReadReg r (NativeKind t c) cont => [NativeReg r] | WriteReg r (SyntaxKind k') e cont => match lookup String.eqb r regs with | Some (existT (SyntaxKind k'') _) => if Kind_decb k' k'' then WfActionT_unit regs cont else RegKindMismatch r (SyntaxKind k') (SyntaxKind k'') :: WfActionT_unit regs cont | Some (existT (NativeKind t c) _) => [RegKindMismatch r (SyntaxKind k') (NativeKind c)] | None => [RegNotFound r] end | WriteReg r (NativeKind t c) e cont => NativeReg r :: WfActionT_unit regs cont | IfElse cond k' atrue afalse cont => WfActionT_unit regs atrue ++ WfActionT_unit regs afalse ++ WfActionT_unit regs (cont tt) | Sys l cont => WfActionT_unit regs cont | Return e => [] end. Definition WfBaseModule_rules_unit(m : BaseModule) := List.fold_right (fun rule fs => WfActionT_unit (getRegisters m) rule ++ fs) [] (map (fun r => snd r _) (getRules m)). Definition action_from_MethodT : (string * {x : Signature & MethodT x}) -> {k : _ & ActionT (fun _ => unit) k}. Proof. intros. destruct X. destruct s0. unfold MethodT in m. pose (m (fun _ => unit)). exists (snd x). exact (a tt). Defined. Definition WfBaseModule_methods_unit(m : BaseModule) := List.fold_right (fun meth fs => WfActionT_unit (getRegisters m) (projT2 (action_from_MethodT meth)) ++ fs) [] (getMethods m). Fixpoint find_dups_aux{X}(acc ps : list (string * X)) : list (string * X * X) := match ps with | [] => [] | p::qs => match lookup String.eqb (fst p) acc with | Some x => (fst p, snd p, x) :: find_dups_aux acc qs | None => find_dups_aux (p::acc) qs end end. Definition find_dups{X} : list (string * X) -> list (string * X * X) := find_dups_aux []. Definition WfBaseModule_unit(m : BaseModule) := map (fun '(s,x1,x2) => DuplicateMethod s (* (projT1 x1) (projT1 x2) *)) (find_dups (getMethods m)) ++ map (fun '(s,x1,x2) => DuplicateRegister s (projT1 x1) (projT1 x2)) (find_dups (getRegisters m)) ++ map (fun '(s,x1,x2) => DuplicateRule s) (find_dups (getRules m)) ++ WfBaseModule_rules_unit m ++ WfBaseModule_methods_unit m. Fixpoint find_overlaps{X}(ps qs : list (string * X)) : list (string * X * X) := match ps with | [] => [] | p::ps' => match lookup String.eqb (fst p) qs with | Some x => (fst p,snd p,x) :: find_overlaps ps' qs | None => find_overlaps ps' qs end end. Fixpoint WfConcatActionT_unit{k}(a : ActionT (fun _ => unit) k)(m : Mod) : list Failure := match a with | MCall meth s e cont => (if existsb (String.eqb meth) (getHidden m) then [HideMethodNotFound meth] else []) ++ WfConcatActionT_unit (cont tt) m | LetExpr (SyntaxKind k') e cont => WfConcatActionT_unit (cont tt) m | LetExpr (NativeKind t c) e cont => NativeLetExpr :: WfConcatActionT_unit (cont c) m | LetAction k a cont => WfConcatActionT_unit a m ++ WfConcatActionT_unit (cont tt) m | ReadNondet (SyntaxKind k') cont => WfConcatActionT_unit (cont tt) m | ReadNondet (NativeKind t c) cont => NativeReadNondet :: WfConcatActionT_unit (cont c) m | ReadReg r (SyntaxKind k') cont => WfConcatActionT_unit (cont tt) m | ReadReg r (NativeKind t c) cont => NativeReg r :: WfConcatActionT_unit (cont c) m | WriteReg r k e a => WfConcatActionT_unit a m | IfElse e k a1 a2 cont => WfConcatActionT_unit a1 m ++ WfConcatActionT_unit a2 m ++ WfConcatActionT_unit (cont tt) m | Sys _ a => WfConcatActionT_unit a m | Return _ => [] end. Definition WfConcat_unit m1 m2 := List.fold_right (fun rule fs => WfConcatActionT_unit rule m2 ++ fs) [] (map (fun r => snd r _) (getAllRules m1)) ++ List.fold_right (fun meth fs => WfConcatActionT_unit (projT2 meth) m2 ++ fs) [] (map action_from_MethodT (getAllMethods m1)). Fixpoint WfMod_unit(m : Mod) := match m with | Base m => WfBaseModule_unit m | HideMeth m s => match lookup String.eqb s (getAllMethods m) with | Some _ => WfMod_unit m | None => HideMethodNotFound s :: WfMod_unit m end | ConcatMod m1 m2 => WfMod_unit m1 ++ WfMod_unit m2 ++ map (fun '(s,x1,x2) => DuplicateRegister s (projT1 x1) (projT1 x2)) (find_overlaps (getAllRegisters m1) (getAllRegisters m2)) ++ map (fun '(s,x1,x2) => DuplicateRule s) (find_overlaps (getAllRules m1) (getAllRules m2)) ++ map (fun '(s,x1,x2) => DuplicateMethod s (* (projT1 x1) (projT1 x2) *)) (find_overlaps (getAllMethods m1) (getAllMethods m2)) ++ WfConcat_unit m1 m2 ++ WfConcat_unit m2 m1 end. Section Proofs. Lemma In_map_fst : forall {X Y}(x : X) ps, In x (map fst ps) -> exists y : Y, In (x,y) ps. Proof. induction ps; intros. - destruct H. - destruct H. exists (snd a). left. destruct a. simpl in *; congruence. destruct (IHps H) as [y Hy]. exists y. right; exact Hy. Qed. Lemma In_lookup : forall {X} str (ps : list (string * X)), In str (map fst ps) -> exists x, lookup String.eqb str ps = Some x. Proof. induction ps; intros. - destruct H. - destruct H. + exists (snd a). unfold lookup. simpl. rewrite H. rewrite String.eqb_refl. reflexivity. + destruct a. rewrite lookup_cons. destruct String.eqb eqn:G. * exists x; auto. * auto. Qed. Lemma lookup_In : forall {X} str (ps : list (string * X)) x, lookup String.eqb str ps = Some x -> In str (map fst ps). Proof. induction ps. - intros; discriminate. - intros. destruct a. rewrite lookup_cons in H. destruct String.eqb eqn:G. + left. rewrite String.eqb_eq in G; simpl; congruence. + right. apply (IHps x); auto. Qed. Lemma find_dups_aux_NoDup : forall {X}(ps acc : list (string * X)), find_dups_aux acc ps = [] -> NoDup (map fst ps) /\ forall str, In str (map fst ps) -> ~ In str (map fst acc). Proof. induction ps; intros. - split. + constructor. + intros. destruct H0. - split. + simpl in H. destruct lookup eqn:G in H. * discriminate. * destruct (IHps _ H). constructor. ** intro. apply (H1 (fst a)). exact H2. left; auto. ** exact H0. + simpl in H. destruct lookup eqn:G in H. * discriminate. * intros. destruct (IHps _ H). intro. destruct H0. ** destruct (In_lookup str acc H3) as [x Hx]. rewrite H0 in G. rewrite Hx in G. discriminate. ** apply (H2 str); auto. right; auto. Qed. Lemma find_dups_NoDups : forall {X}(ps : list (string * X)), find_dups ps = [] -> NoDup (map fst ps). Proof. intros. eapply find_dups_aux_NoDup. exact H. Qed. Lemma WfActionT_unit_correct : forall lret m (a : ActionT _ lret), WfActionT_unit (getRegisters m) a = [] -> WfActionT_new (getRegisters m) a. Proof. induction a; simpl; intros. - apply H; destruct x; auto. - apply H. destruct k. + destruct x; auto. + discriminate H0. - split. + apply IHa. destruct (app_eq_nil _ _ H0); auto. + intro; apply H. destruct (app_eq_nil _ _ H0); destruct x; auto. - apply H. destruct k. + destruct x; auto. + discriminate. - destruct k. + destruct lookup eqn:G. * destruct s. destruct x. ** destruct Kind_decb eqn:G0. *** split. **** rewrite Kind_decb_eq in G0; congruence. **** intros []; apply H; auto. *** discriminate. ** discriminate. * discriminate. + discriminate. - destruct k. + destruct lookup eqn:G. * destruct s. destruct x. ** destruct Kind_decb eqn:G0. *** split. **** rewrite Kind_decb_eq in G0; congruence. **** auto. *** discriminate. ** discriminate. * discriminate. + discriminate. - destruct (app_eq_nil _ _ H0); clear H0. destruct (app_eq_nil _ _ H2); clear H2. repeat split; auto. intros []; auto. - auto. - exact I. Qed. Lemma fold_right_empty_lemma : forall {X Y}(f : X -> list Y)(xs : list X), fold_right (fun x ys => f x ++ ys) [] xs = [] -> forall x, In x xs -> f x = []. Proof. induction xs; intros. - destruct H0. - simpl in H. destruct (app_eq_nil _ _ H). destruct H0. + congruence. + auto. Qed. Lemma WfBaseModule_rules_unit_In : forall m, WfBaseModule_rules_unit m = [] -> forall rule, In rule (getRules m) -> WfActionT_unit (getRegisters m) (snd rule _) = []. Proof. intros. apply (fold_right_empty_lemma _ _ H). apply (@in_map _ _ (fun r : string * (forall x : Kind -> Type, ActionT x Void) => snd r (fun _ => unit))); auto. Qed. Lemma WfBaseModule_rules_unit_correct : forall m, WfBaseModule_rules_unit m = [] -> forall rule, In rule (getRules m) -> WfActionT_new (getRegisters m) (snd rule (fun _ => unit)). Proof. intros. apply WfActionT_unit_correct. apply WfBaseModule_rules_unit_In; auto. Qed. Lemma In_WfRules : forall ty regs rules, (forall rule, In rule rules -> WfActionT_new regs (snd rule ty)) -> WfRules ty regs rules. Proof. induction rules; intros; simpl. - exact I. - split. + apply H. left; auto. + apply IHrules. intros. apply H. right; auto. Qed. Lemma WfBaseModule_methods_unit_In : forall m, WfBaseModule_methods_unit m = [] -> forall meth, In meth (getMethods m) -> WfActionT_unit (getRegisters m) (projT2 (snd meth) _ tt) = []. Proof. intros. unfold WfBaseModule_methods_unit in H. pose @fold_right_empty_lemma. pose (@fold_right_empty_lemma _ _ _ _ H). unfold action_from_MethodT in e0. pose (e0 meth). destruct meth. destruct s0. simpl in e1. apply e1. exact H0. Qed. Lemma WfBaseModule_methods_unit_correct : forall m, WfBaseModule_methods_unit m = [] -> forall meth, In meth (getMethods m) -> WfActionT_new (getRegisters m) (projT2 (snd meth) (fun _ => unit) tt). Proof. intros. apply WfActionT_unit_correct. apply WfBaseModule_methods_unit_In; auto. Qed. Lemma In_WfMethods : forall ty regs meths, (forall (meth : string * {x : Signature & MethodT x}) v, In meth meths -> @WfActionT_new ty regs _ (projT2 (snd meth) _ v)) -> WfMeths ty regs meths. Proof. induction meths; intros; simpl. - exact I. - split. + intro; apply H. left; auto. + apply IHmeths. intros. apply H. right; auto. Qed. Lemma WfBaseModule_unit_correct : forall m, WfBaseModule_unit m = [] -> WfBaseModule_new (fun _ => unit) m. Proof. unfold WfBaseModule_unit, WfBaseModule_new. intros. destruct (app_eq_nil _ _ H); clear H. destruct (app_eq_nil _ _ H1); clear H1. destruct (app_eq_nil _ _ H2); clear H2. destruct (app_eq_nil _ _ H3); clear H3. repeat split. - apply In_WfRules. intros. apply WfBaseModule_rules_unit_correct; auto. - apply In_WfMethods. intros meth []. apply WfBaseModule_methods_unit_correct; auto. - apply find_dups_NoDups. eapply map_eq_nil. exact H0. - apply find_dups_NoDups. eapply map_eq_nil. exact H. - apply find_dups_NoDups. eapply map_eq_nil. exact H1. Qed. Lemma find_overlaps_DisjKey : forall {X}(ps qs : list (string * X)), find_overlaps ps qs = [] -> DisjKey ps qs. Proof. induction ps; intros qs Hoverlaps str. - left; simpl; auto. - simpl in Hoverlaps. destruct lookup eqn:G. + discriminate. + destruct (IHps qs Hoverlaps str). * destruct (fst a =? str) eqn:G0. ** right. intro. destruct (In_lookup _ _ H0). rewrite String.eqb_eq in G0. rewrite G0 in G. rewrite H1 in G. discriminate. ** left. intros [|]. *** rewrite H0 in G0. rewrite String.eqb_refl in G0. discriminate. *** auto. * tauto. Qed. Lemma WfConcatActionT_unit_correct : forall {lret} m (a : ActionT (fun _ => unit) lret), WfConcatActionT_unit a m = [] -> WfConcatActionT_new a m. Proof. induction a; simpl; intros. - split. + destruct existsb eqn:G. * discriminate. * Search existsb In. intro. assert (existsb (String.eqb meth) (getHidden m) = true). ** apply existsb_exists. exists meth; split. *** auto. *** apply String.eqb_refl. ** rewrite H2 in G; discriminate. + destruct x. apply H. destruct (app_eq_nil _ _ H0); auto. - destruct k. + destruct x; auto. + discriminate. - destruct (app_eq_nil _ _ H0); clear H0. split. + auto. + destruct x; auto. - destruct k. + destruct x; auto. + discriminate. - destruct k. + destruct x; auto. + discriminate. - auto. - destruct (app_eq_nil _ _ H0); clear H0. destruct (app_eq_nil _ _ H2); clear H2. repeat split. + auto. + auto. + destruct x; auto. - auto. - exact I. Qed. Lemma in_map2 : forall (A B : Type)(f : A -> B)(l : list A)(x : A)(y : B), y = f x -> In x l -> In y (map f l). Proof. intros. rewrite H. apply in_map; auto. Qed. Theorem WfMod_unit_correct : forall m, WfMod_unit m = [] -> WfMod_new (fun _ => unit) m. Proof. induction m; simpl; intro. - apply WfBaseModule_unit_correct; auto. - destruct lookup eqn:G in H. + split. * eapply lookup_In. exact G. * auto. + discriminate. - destruct (app_eq_nil _ _ H); clear H. destruct (app_eq_nil _ _ H1); clear H1. destruct (app_eq_nil _ _ H2); clear H2. destruct (app_eq_nil _ _ H3); clear H3. destruct (app_eq_nil _ _ H4); clear H4. destruct (app_eq_nil _ _ H5); clear H5. destruct (app_eq_nil _ _ H4); clear H4. destruct (app_eq_nil _ _ H6); clear H6. repeat split. + apply find_overlaps_DisjKey. eapply map_eq_nil. exact H1. + apply find_overlaps_DisjKey. eapply map_eq_nil. exact H2. + apply find_overlaps_DisjKey. eapply map_eq_nil. exact H3. + auto. + auto. + intros; apply WfConcatActionT_unit_correct. apply (@fold_right_empty_lemma _ _ _ _ H5). apply (@in_map _ _ (fun r : string * (forall x : Kind -> Type, ActionT x Void) => snd r (fun _ => unit))); auto. + intros; apply WfConcatActionT_unit_correct. unfold action_from_MethodT in H7. destruct v. pose (@fold_right_empty_lemma _ _ _ _ H7). pose (e (action_from_MethodT meth)). destruct meth. destruct s0. simpl. unfold action_from_MethodT in e0. simpl in e0. apply e0. apply (@in_map2 _ _ _ _ ((s, existT MethodT x m))). reflexivity. exact H6. + intros; apply WfConcatActionT_unit_correct. apply (@fold_right_empty_lemma _ _ _ _ H4). apply (@in_map _ _ (fun r : string * (forall x : Kind -> Type, ActionT x Void) => snd r (fun _ => unit))); auto. + intros; apply WfConcatActionT_unit_correct. unfold action_from_MethodT in H8. destruct v. pose (@fold_right_empty_lemma _ _ _ _ H8). pose (e (action_from_MethodT meth)). destruct meth. destruct s0. simpl. unfold action_from_MethodT in e0. simpl in e0. apply e0. apply (@in_map2 _ _ _ _ ((s, existT MethodT x m))). reflexivity. exact H6. Qed. End Proofs. Section ParametricTheorems. Lemma WfActionT_unit_new : forall {k}(regs : list RegInitT)(a : forall ty, ActionT ty k), WfActionT_unit regs (a _) = [] -> forall ty, WfActionT_new regs (a ty). Proof. Admitted. Lemma WfBaseModule_unit_new : forall b : BaseModule, WfBaseModule_unit b = [] -> forall ty, WfBaseModule_new ty b. Proof. Admitted. Lemma WfConcatActionT_unit_new : forall {k}(a : forall ty, ActionT ty k)(m : Mod), WfConcatActionT_unit (a _) m = [] -> forall ty, WfConcatActionT_new (a ty) m. Proof. Admitted. Lemma WfConcat_unit_new : forall m1 m2, WfConcat_unit m1 m2 = [] -> forall ty, WfConcat_new ty m1 m2. Proof. Admitted. Lemma WfMod_unit_new : forall m, WfMod_unit m = [] -> forall ty, WfMod_new ty m. Proof. Admitted. End ParametricTheorems. ================================================ FILE: WfMod_Helper.v ================================================ (* * Helper theorems and tactics for verifying WfMod properties *) Require Import Kami.AllNotations. Require Import Kami.Notations. Require Import Kami.Rewrites.Notations_rewrites. Require Import Kami.Properties. Require Import Kami.PProperties. Require Import Kami.Syntax. Require Import Vector. Require Import List. Require Import Coq.Strings.String. Local Open Scope kami_action. Local Open Scope kami_expr. Theorem string_equal_prefix: forall (a: string) (b: string) (c: string), (a++b=a++c)%string<->(b=c)%string. Proof. split. - intros. induction a. + simpl in H. apply H. + inversion H; subst; clear H. apply IHa. apply H1. - intros. subst. reflexivity. Qed. Theorem DisjKey_nil2: forall A B (l: list (A*B)), DisjKey l List.nil. Proof. intros. unfold DisjKey. intros. right. simpl. intro X. elim X. Qed. Theorem DisjKey_nil1: forall A B (l: list (A*B)), DisjKey List.nil l. Proof. intros. unfold DisjKey. intros. left. simpl. intro X. elim X. Qed. (*Theorem or_diff: forall p a b, a<> b -> forall k : string, ~ ((p ++ a)%string = k \/ False) \/ ~ ((p ++ b)%string = k \/ False). Proof. intros. classical_left. apply NNPP in H0. inversion H0;subst;clear H0. + intro X. inversion X;subst;clear X. - apply string_equal_prefix in H0. apply H in H0. elim H0. - elim H0. + elim H1. Qed.*) Ltac trivialSolve := match goal with | |- forall _, In _ (getAllRules (Base (BaseRegFile _))) -> _ => simpl;intros;trivialSolve | H: False |- _ => elim H | |- DisjKey _ List.nil => apply DisjKey_nil2 | |- DisjKey List.nil _ => apply DisjKey_nil1 | |- DisjKeyWeak _ List.nil => rewrite <- DisjKeyWeak_same;[apply DisjKey_nil2 | repeat (decide equality)] | |- DisjKeyWeak List.nil _ => rewrite <- DisjKeyWeak_same;[apply DisjKey_nil1 | repeat (decide equality)] | |- ~ (List.In _ _) => simpl;trivialSolve | |- ~ (_ \/ _) => let X := fresh in intro X;inversion X;subst;clear X;trivialSolve | |- _ /\ _ => split;trivialSolve | |- ~False => let X := fresh in intro X;inversion X | |- (_++_)%string <> (_++_)%string => let X := fresh in try (intro X;apply string_equal_prefix in X; inversion X) (*| |- ~((?P++_)%string = _ \/ False) \/ ~((?P++_)%string = _ \/ False) => let X := fresh in try (apply or_diff;intro X;inversion X)*) | |- NoDup (_::_) => econstructor; simpl; trivialSolve | |- NoDup [] => econstructor | H: _ \/ _ |- _ => inversion H;subst;clear H;trivialSolve | H: (?P++_)%string=(?P++_)%string |- _ => apply string_equal_prefix in H;inversion H;subst;clear H;trivialSolve | H: In _ (map fst _) |- _ => simpl in H;trivialSolve | |- (?P = ?P) => reflexivity | _ => idtac end. Theorem ne_disjunction_break1: forall a b c, (~(a \/ False) \/ ~(b \/ False)) /\ (~(a \/ False) \/ ~c) -> ~(a \/ False) \/ ~(b \/ c). Proof. tauto. Qed. Theorem ne_disjunction_break2: forall a b c, (~(a \/ False) \/ ~c) /\ (~b \/ ~c) -> ~(a \/ b) \/ ~ c. Proof. tauto. Qed. (*Ltac DisjKey_solve := match goal with (*| |- ~((?P++_)%string = _ \/ False) \/ ~((?P++_)%string = _ \/ False) => let X := fresh in try (apply or_diff;intro X;inversion X)*) | |- ~(_ \/ False) \/ ~(_ \/ _) => apply ne_disjunction_break1;split;DisjKey_solve | |- ~(_ \/ _ \/ _) \/ ~_ => apply ne_disjunction_break2;split;DisjKey_solve (*| |- DisjKey _ _ => unfold DisjKey; simpl; intros;DisjKey_solve*) | |- DisjKey _ _ => rewrite DisjKeyWeak_same;[ DisjKey_solve | repeat (decide equality) ] | |- DisjKeyWeak _ _ => unfold DisjKeyWeak;intros;DisjKey_solve | H: In _ (map fst ((_,_)::_)) |- _ => simpl in H;DisjKey_solve | |- _ => trivialSolve end.*) Theorem DisjKey_NubBy1: forall T (x: list (string * T)) (y: list (string * T)), DisjKey x y -> DisjKey (nubBy (fun '(a,_) '(b,_) => String.eqb a b) x) y. Proof. intros T x y. generalize y. induction x. + simpl. intros. apply H. + simpl. remember ( existsb (let '(a0, _) := a in fun '(b, _) => a0 =? b) (nubBy (fun '(a0, _) '(b, _) => a0 =? b) x)). destruct b. - simpl. intros. apply IHx. unfold DisjKey in H. simpl in H. unfold DisjKey. intros. assert( ~ (fst a = k \/ In k (map fst x)) \/ ~ In k (map fst y0) ). ++ apply H. ++ inversion H0;subst;clear H0. -- left. intro X. apply H1. right. apply X. -- right. apply H1. - intros. rewrite DisjKey_Cons1. rewrite DisjKey_Cons1 in H. inversion H;subst;clear H. split. ++ apply H0. ++ apply IHx. apply H1. ++ repeat (decide equality). ++ repeat (decide equality). Qed. Theorem DisjKey_NubBy2: forall T (x: list (string * T)) (y: list (string * T)), DisjKey x y -> DisjKey x (nubBy (fun '(a,_) '(b,_) => String.eqb a b) y). Proof. intros T x y. generalize x. induction y. + simpl. intros. apply H. + simpl. remember ( existsb (let '(a0, _) := a in fun '(b, _) => a0 =? b) (nubBy (fun '(a0, _) '(b, _) => a0 =? b) y)). destruct b. - simpl. intros. apply IHy. unfold DisjKey in H. simpl in H. unfold DisjKey. intros. assert( ~ In k (map fst x0) \/ ~ (fst a = k \/ In k (map fst y)) ). ++ apply H. ++ inversion H0; subst; clear H0. -- left. apply H1. -- right. intro X. apply H1. right. apply X. - intros. rewrite DisjKey_Cons2. rewrite DisjKey_Cons2 in H. inversion H;subst;clear H. split. ++ apply H0. ++ apply IHy. apply H1. ++ repeat (decide equality). ++ repeat (decide equality). Qed. Theorem NoDup_NubBy_helper: forall T (a:(string * T)) (l:list (string *T)), false = existsb (let '(a0, _) := a in fun '(b, _) => a0 =? b) l -> ~ In (fst a) (map fst l). Proof. induction l. + simpl. intros. intro X. elim X. + simpl. intros. intro X. inversion X;subst;clear X. destruct a0. destruct a. simpl in H0. subst. remember (s0=?s0). destruct b. - simpl in H. inversion H. - rewrite eqb_refl in Heqb. inversion Heqb. - destruct a. destruct a0. simpl in H0. simpl in IHl. remember (s =? s0). destruct b. * simpl in H. inversion H. * simpl in H. apply IHl. ** apply H. ** apply H0. Qed. Theorem NoDup_NubBy: forall T (x: list (string * T)), NoDup (map fst (nubBy (fun '(a,_) '(b,_) => String.eqb a b) x)). Proof. intros. induction x. + simpl. apply NoDup_nil. + simpl. remember ( existsb (let '(a0, _) := a in fun '(b, _) => a0 =? b) (nubBy (fun '(a0, _) '(b, _) => a0 =? b) x) ). destruct b. - apply IHx. - simpl. apply NoDup_cons. apply NoDup_NubBy_helper. apply Heqb. apply IHx. Qed. Ltac ltac_wfMod_ConcatMod := apply ConcatModWf;autorewrite with kami_rewrite_db;repeat split;try assumption;auto with wfMod_ConcatMod_Helper;trivialSolve. (*Ltac WfMod_Solve := match goal with | |- _ => (progress discharge_wf);WfMod_Solve | |- forall _, _ => intros;WfMod_Solve | |- _ -> _ => intros;WfMod_Solve | |- _ /\ _ => split;WfMod_Solve | |- In _ _ => simpl;WfMod_Solve | |- (_ \/ False) => left;WfMod_Solve | |- _ => trivialSolve end. Ltac WfConcatAction_Solve := match goal with | |- _ => progress discharge_wf;WfConcatAction_Solve | |- forall _, _ => intros;simpl;WfConcatAction_Solve | H: In _ (getAllMethods _) |- _ => simpl in H;inversion H;subst;clear H;simpl;WfConcatAction_Solve | H: _ \/ _ |- _ => simpl in H;inversion H;subst;clear H;simpl;WfConcatAction_Solve | H: False |- _ => inversion H | |- _ => idtac end.*) ================================================ FILE: _CoqProject ================================================ -Q . Kami -Q ../coq-record-update/src RecordUpdate ================================================ FILE: fixHaskell.sh ================================================ #!/usr/bin/env bash mkdir -p $1 cmd="ghc $GHCFLAGS -j -O1 --make ./FixLits.hs" echo $cmd $cmd echo "Fixing Literals" for file in $(find $2 -maxdepth 1 -name "*.hs") do baseval=`basename $file` ./FixLits $file mv $file $1 echo "$file fixed." done echo "Adding missing imports" unameOut="$(uname -s)" case "${unameOut}" in Darwin*) SED=gsed;; *) SED=sed esac for file in $(grep -l "CustomExtract" $1/*.hs) do grep -q "import qualified CustomExtract" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified CustomExtract\nimport/}' $file fi done for file in $(grep -l "Data\.Char" $1/*.hs) do grep -q "import qualified Data\.Char" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.Char\nimport/}' $file fi done for file in $(grep -l "Data\.Bits" $1/*.hs) do grep -q "import qualified Data\.Bits" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.Bits\nimport/}' $file fi done for file in $(grep -l "Data\.List" $1/*.hs) do grep -q "import qualified Data\.List" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.List\nimport/}' $file fi done for file in $(grep -l "Data\.BitVector" $1/*.hs) do grep -q "import qualified Data\.BitVector" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.BitVector\nimport/}' $file fi done for file in $(grep -l "Data\.Vector" $1/*.hs) do grep -q "import qualified Data\.Vector" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.Vector\nimport/}' $file fi done for file in $(grep -l "System\.Exit" $1/*.hs) do grep -q "import qualified System\.Exit" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified System.Exit\nimport/}' $file fi done for file in $(grep -l "System\.IO" $1/*.hs) do grep -q "import qualified System\.IO" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified System.IO\nimport/}' $file fi done for file in $(grep -l "Data\.Map\.Strict" $1/*.hs) do grep -q "import qualified Data\.Map\.Strict" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.Map.Strict\nimport/}' $file fi done for file in $(grep -l "ParseExtract" $1/*.hs) do grep -q "import qualified ParseExtract" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified ParseExtract\nimport/}' $file fi done for file in $(grep -l "Data\.Array.IO" $1/*.hs) do grep -q "import qualified Data\.Array.IO" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.Array.IO\nimport/}' $file fi done for file in $(grep -l "Data\.Array\.MArray" $1/*.hs) do grep -q "import qualified Data\.Array\.MArray" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.Array.MArray\nimport/}' $file fi done for file in $(grep -l "Control\.Monad" $1/*.hs) do grep -q "import qualified Control\.Monad" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Control.Monad\nimport/}' $file fi done for file in $(grep -l "Control\.Monad\.Primitive" $1/*.hs) do grep -q "import qualified Control\.Monad\.Primitive" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Control.Monad.Primitive\nimport/}' $file fi done for file in $(grep -l "Data\.Vector\.Mutable" $1/*.hs) do grep -q "import qualified Data\.Vector\.Mutable" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.Vector.Mutable\nimport/}' $file fi done for file in $(grep -l "Data\.Vector\.Generic" $1/*.hs) do grep -q "import qualified Data\.Vector\.Generic" $file if [ $? -ne 0 ] then $SED -i -e '0,/^import/{s/^import/import qualified Data.Vector.Generic\nimport/}' $file fi done ================================================ FILE: kami.el ================================================ ;; Syntax hightlighting and indentation for Kami code. ;; Author : Murali Vijayaraghavan ;; Organization : SiFive (setq kami-keywords '( "MODULE" "MOD" "Register" "Rule" "Method" "Call" "LET" "LETA" "LETE" "LETC" "RetE" "Read" "Write" "Assert" "NonDet" "IF" "If" "then" "else" "Retv" "Ret" "with" "MODULE_WF" "MOD_WF" ) ) (setq kami-types-and-vals '( "Bool" "Bit" "STRUCT" "STRUCT_TYPE" "STRUCT_CONST" "Array" "ARRAY" "ARRAY_CONST" "Default" "WO" ) ) (setq kami-keywords-regex (regexp-opt kami-keywords 'words)) (setq kami-types-and-vals-regex (regexp-opt kami-types-and-vals 'words)) (defun diff-parens-times-space (space) "Calculates the number of open parentheses minus closed parentheses in previous line, multiplies by space" (save-excursion (beginning-of-line) (let ((end (point))) (previous-line) (beginning-of-line) (let ((start (point)) (currind (current-indentation))) (+ (* space (- (how-many "[[({]" start end) (how-many "[])}]" start end) )) currind) ) ) ) ) (defun indent-region-parens-times-space (space start end) (save-excursion (goto-char start) (while (< (point) end) (indent-line-to (diff-parens-times-space space)) (forward-line 1)))) (defun indent-region-parens-times-2 (start end) (interactive "r") (let ((space 2)) (if (use-region-p) (indent-region-parens-times-space space start end) (indent-line-to (diff-parens-times-space space)) ))) (global-set-key (kbd "") 'indent-region-parens-times-2) (font-lock-add-keywords nil `( (,kami-keywords-regex . font-lock-keyword-face) (,kami-types-and-vals-regex . font-lock-builtin-face) ) 't)