├── first_attempt ├── prototype │ ├── Example3.v │ ├── Example4.v │ ├── Min.v │ ├── Example.v │ └── Example2.v ├── Common.v ├── Assembly.v ├── Language.v ├── Simulation.v ├── Compiler.v └── Verification.v ├── _CoqProject ├── Makefile ├── .gitignore ├── src ├── Common.v ├── prototype │ └── Example.v ├── Assembly.v ├── Language.v ├── Simulation.v ├── Compiler.v └── Verification.v ├── LICENSE └── README.md /first_attempt/prototype/Example3.v: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R src Top 2 | src/Common.v 3 | src/Simulation.v 4 | src/Language.v 5 | src/Assembly.v 6 | src/Compiler.v 7 | src/Verification.v 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | coq_makefile -f _CoqProject -o coq_makefile 3 | make -f coq_makefile 4 | clean: 5 | make -f coq_makefile clean 6 | rm coq_makefile coq_makefile.conf 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.aux 2 | .*.d 3 | *.a 4 | *.cma 5 | *.cmi 6 | *.cmo 7 | *.cmx 8 | *.cmxa 9 | *.cmxs 10 | *.glob 11 | *.ml.d 12 | *.ml4.d 13 | *.mlg.d 14 | *.mli.d 15 | *.mllib.d 16 | *.mlpack.d 17 | *.native 18 | *.o 19 | *.v.d 20 | *.vio 21 | *.vo 22 | *.vok 23 | *.vos 24 | .coq-native 25 | .csdp.cache 26 | .lia.cache 27 | .nia.cache 28 | .nlia.cache 29 | .nra.cache 30 | csdp.cache 31 | lia.cache 32 | nia.cache 33 | nlia.cache 34 | nra.cache 35 | native_compute_profile_*.data 36 | 37 | # generated timing files 38 | *.timing.diff 39 | *.v.after-timing 40 | *.v.before-timing 41 | *.v.timing 42 | time-of-build-after.log 43 | time-of-build-before.log 44 | time-of-build-both.log 45 | time-of-build-pretty.log 46 | *#* 47 | coq_makefile 48 | coq_makefile.conf 49 | -------------------------------------------------------------------------------- /first_attempt/prototype/Example4.v: -------------------------------------------------------------------------------- 1 | Require Import Vector. 2 | Import Vector.VectorNotations. 3 | 4 | Inductive instr := 5 | | A : instr 6 | | B : instr 7 | | C : instr. 8 | 9 | 10 | Definition vector_zip {A B : Type} {n : nat} (v1 : Vector.t A n) 11 | (v2 : Vector.t B n) : Vector.t (A * B) n := 12 | Vector.map2 (fun x y => (x, y)) v1 v2. 13 | 14 | Check (5,5). 15 | 16 | Fixpoint f' {n} (L : Vector.t (instr*instr) n) : Vector.t instr n := 17 | match L with 18 | | [] => [] 19 | | (A,h)::L' => h :: f' L' 20 | | (a,_)::L' => a :: f' L' 21 | end. 22 | 23 | Definition f {n} (l : Vector.t instr n) (m : Vector.t instr n) : 24 | Vector.t instr n := f' (vector_zip l m). 25 | 26 | 27 | 28 | Theorem th : forall p ind, p[@ind] <> A -> 29 | f p -------------------------------------------------------------------------------- /src/Common.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Import List.ListNotations. 3 | 4 | Require Import Coq.Program.Equality. 5 | Require Import Lia. 6 | 7 | Module Common. 8 | 9 | Definition embed {A : Type} {B : Type} (f : A -> B) := 10 | fun x y => y = f x. 11 | 12 | Inductive star {A : Type} (R : A -> A -> Prop) : A -> A -> Prop := 13 | | rt_refl : forall x, star R x x 14 | | rt_trans : forall x y z, R x y -> star R y z -> star R x z. 15 | 16 | Theorem rt_step {A} (R : A -> A -> Prop) : 17 | forall x y, R x y -> (star R) x y. 18 | Proof. 19 | intros x y H. 20 | apply rt_trans with (x := x) (y := y) (z := y). 21 | assumption. 22 | apply rt_refl. 23 | Qed. 24 | 25 | Inductive plus {A : Type} (R : A -> A -> Prop) : A -> A -> Prop := 26 | | t_base : forall x y, R x y -> plus R x y 27 | | t_trans : forall x y z, R x y -> plus R y z -> plus R x z. 28 | 29 | Inductive lookup {A : Type} : list A -> nat -> A -> Prop := 30 | | lu1 : forall x xs, lookup (x :: xs) 0 x 31 | | lu2 : forall x xs i y, lookup xs i y -> lookup (x :: xs) (S i) y. 32 | 33 | Inductive list_eq_except {A} (m1 m2 : list A) (indexes : list nat) : Prop := 34 | | md : (forall i e, ~ (In i indexes) -> lookup m1 i e -> lookup m2 i e) -> 35 | list_eq_except m1 m2 indexes. 36 | 37 | 38 | End Common. 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2023, aramya 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 16 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 17 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 19 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 21 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 22 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 23 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 24 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /first_attempt/prototype/Min.v: -------------------------------------------------------------------------------- 1 | Require Import Vector. 2 | Import Vector.VectorNotations. 3 | Require Import Program.Equality. 4 | Require Import Coq.Program.Wf. 5 | From Hammer Require Import Tactics. 6 | From Hammer Require Import Hammer. 7 | Require Import Lia. 8 | Inductive instr1 : Type := | A : instr1 | B : instr1. 9 | Inductive instr2 : Type := | A' : instr2 | B' : instr2 | C' : instr2. 10 | Fixpoint comp_len {n} (p : t instr1 n) : nat := 11 | match p with 12 | | [] => 0 13 | | A :: xs => 1 + comp_len xs 14 | | B :: xs => 3 + comp_len xs 15 | end. 16 | Fixpoint compile {n} (p : Vector.t instr1 n) : Vector.t instr2 (comp_len p) := 17 | match p with 18 | | [] => [] 19 | | A :: p' => A' :: compile p' 20 | | B :: p' => C' :: B' :: A' :: compile p' 21 | end. 22 | Fixpoint compile_index {n} (p : t instr1 n) (x : Fin.t n) : Fin.t (comp_len p). 23 | Proof. 24 | destruct x eqn:H1; rewrite (eta p); destruct hd eqn:H2. 25 | - apply Fin.F1. 26 | - apply Fin.F1. 27 | - do 1 apply Fin.FS. apply compile_index. exact t. 28 | - do 3 apply Fin.FS. apply compile_index. exact t. 29 | Defined. 30 | Fixpoint to_nat {n} (x : Fin.t n) : nat := 31 | match x with 32 | | Fin.F1 => 0 33 | | Fin.FS t => 1 + (to_nat t) 34 | end. 35 | 36 | Theorem th {n} : forall p x x' (off : Fin.t (comp_len [p[@x]])), 37 | to_nat x' = to_nat (@compile_index n p x) + to_nat off -> 38 | (compile p)[@x'] = (compile [p[@x]])[@off]. 39 | 40 | 41 | -------------------------------------------------------------------------------- /first_attempt/Common.v: -------------------------------------------------------------------------------- 1 | Require Import Vector. 2 | Import Vector.VectorNotations. 3 | 4 | Require Import Coq.Program.Equality. 5 | Require Import Lia. 6 | 7 | Module Common. 8 | 9 | Definition embed {A : Type} {B : Type} (f : A -> B) := 10 | fun x y => y = f x. 11 | 12 | Inductive star {A : Type} (R : A -> A -> Prop) : A -> A -> Prop := 13 | | rt_refl : forall x, star R x x 14 | | rt_trans : forall x y z, R x y -> star R y z -> star R x z. 15 | 16 | Theorem rt_step {A} (R : A -> A -> Prop) : 17 | forall x y, R x y -> (star R) x y. 18 | Proof. 19 | intros x y H. 20 | apply rt_trans with (x := x) (y := y) (z := y). 21 | assumption. 22 | apply rt_refl. 23 | Qed. 24 | 25 | Inductive plus {A : Type} (R : A -> A -> Prop) : A -> A -> Prop := 26 | | t_base : forall x y, R x y -> plus R x y 27 | | t_trans : forall x y z, R x y -> plus R y z -> plus R x z. 28 | 29 | Fixpoint to_nat {n} (x : Fin.t n) : nat := 30 | match x with 31 | | Fin.F1 => 0 32 | | Fin.FS t => 1 + (to_nat t) 33 | end. 34 | 35 | Definition make_f1 (n : nat) (H : n <> 0) : Fin.t n. 36 | Proof. 37 | destruct n eqn:H1. 38 | - unfold not in H. assert (0 = 0). reflexivity. contradiction. 39 | - exact Fin.F1. 40 | Defined. 41 | 42 | Definition make_fn (n : nat) (x : nat) (H : n <> 0) : Fin.t n := 43 | match Fin.of_nat x n with 44 | | inleft p => p 45 | | inright _ => make_f1 n H 46 | end. 47 | 48 | Definition strengthen {n} (x : Fin.t (S n)) (H : Common.to_nat x <> n) : Fin.t n. 49 | Proof. 50 | destruct n. 51 | assert (x = Fin.F1). 52 | dependent destruction x. 53 | contradiction. 54 | inversion x. 55 | rewrite H0 in H. 56 | contradiction. 57 | apply Common.make_fn. 58 | exact (Common.to_nat x). 59 | lia. 60 | Defined. 61 | 62 | Definition minus {n} (x : Fin.t (S n)) (H : n <> 0) : Fin.t n. 63 | Proof. 64 | destruct n eqn:H0. 65 | - contradiction. 66 | - destruct x eqn:H1. 67 | + exact Fin.F1. 68 | + apply Common.make_fn. 69 | exact (Common.to_nat t). 70 | unfold not. contradiction. 71 | Defined. 72 | 73 | End Common. 74 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # semantic-preservation 2 | ## Introduction 3 | 4 | The purpose of this repo is to give a minimal example of a compiler for which the forward simulation property is verified. The proof is located in [src/Verification.v](src/Verification.v). 5 | 6 | I considered an abstract machine using absolute addresses for ``Jump`` as a target, and one using a BF-like ``Jump`` / ``Ret``, both jumping one instruction after the associated instruction, as a source. The small compiler used is defined in [src/Compiler.v](src/Compiler.v). 7 | 8 | The proof of some lemmas is still missing, and those are admitted for the moment. This was my first real contact with Coq and dependent types, and it allowed me to make progress on the basics. Also, it makes extensive use of CoqHammer, which makes some proofs quite incomprehensible. 9 | 10 | The ``first_attempt`` folder contains previous attempts to prove the property, in particular through an approach using vectors, in the belief that this would simplify the proof of certain lemmas. This was quite true, but it made it too complex to state certain theorems, and I preferred to give up on it. 11 | 12 | It is globally a matter of proving that given two source states p and p' and a target state q, if 13 | 14 | - p compiles into q 15 | - p evaluates into p' 16 | 17 | then there exist q' such as: 18 | 19 | - p' compiles into q' 20 | - q evaluates+ into q' 21 | 22 | where "+" is the transitive closure. 23 | 24 | Main reference: https://xavierleroy.org/publi/compcert-backend.pdf 25 | 26 | ## Semantics 27 | 28 | - Small-step semantics for the two abstract machines are defined in [src/Language.v](src/Language.v) and [src/Assembly.v](src/Assembly.v) 29 | 30 | ## Simulation property 31 | 32 | - The aim of [Leroy's paper](https://xavierleroy.org/publi/compcert-backend.pdf) is to describe how a source program S and a target program C retain the same semantics if the compilation process succeeds. 33 | - Several relations are defined to express semantic preservation. In [src/Simulation.v](src/Simulation.v) are included the definitions to construct the lockstep, "plus", "option" and "star" simulation relations described in p. 16. 34 | -------------------------------------------------------------------------------- /src/prototype/Example.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Nat. 3 | Require Import Lia. 4 | Import ListNotations. 5 | 6 | From Hammer Require Import Tactics. 7 | 8 | Inductive lookup {A : Type} : list A -> nat -> A -> Prop := 9 | | lu1 : forall x xs, lookup (x :: xs) 0 x 10 | | lu2 : forall x xs i y, lookup xs i y -> lookup (x :: xs) (S i) y. 11 | Inductive instr1 : Type := | Load : instr1 | Halt : instr1. 12 | Inductive instr2 : Type := | Load' : instr2 | Halt' : instr2. 13 | Fixpoint compile (p : list instr1) : list instr2 := 14 | match p with 15 | | [] => [] 16 | | Load :: h => Load'::Load'::compile h 17 | | Halt :: h => Halt'::compile h 18 | end. 19 | Definition comp_first (i : instr1) : instr2 := 20 | match i with | Halt => Halt' | Load => Load' end. 21 | Fixpoint compile_index (p : list instr1) (x : nat) : nat := 22 | match x with 23 | | 0 => 0 24 | | _ => match p with 25 | | [] => 0 26 | | Load :: h => 2 + compile_index h (x-1) 27 | | Halt :: h => 1 + compile_index h (x-1) 28 | end 29 | end. 30 | 31 | Lemma lm6 : forall a p, compile (a :: p) = [] -> False. 32 | Proof. 33 | intros. 34 | induction p; 35 | destruct a; simpl; 36 | discriminate. 37 | Qed. 38 | 39 | Lemma trv : forall n, n - 0 = n. 40 | Proof. lia. Qed. 41 | 42 | Theorem th : 43 | forall p q i x, compile p = q -> lookup p x i -> 44 | lookup q (compile_index p x) (comp_first i). 45 | Proof. 46 | induction p; destruct q; destruct i; intros; try inversion H. 47 | - inversion H0. 48 | - inversion H0. 49 | - exfalso. 50 | apply lm6 with (a := a) (p := p). 51 | assumption. 52 | - exfalso. 53 | apply lm6 with (a := a) (p := p). 54 | assumption. 55 | - ssimpl; apply lu2. 56 | rewrite trv. 57 | inversion H. apply lu2. apply lu1. 58 | apply lu2. apply lu2. assumption. 59 | - ssimpl; apply lu2. 60 | rewrite trv. 61 | apply IHp. 62 | reflexivity. 63 | assumption. 64 | Qed. 65 | 66 | Theorem comp_instr : forall prog pc i, lookup prog pc i -> 67 | lookup (compile prog) (compile_index prog pc) (comp_first i). 68 | Proof. 69 | intros. 70 | assert (forall p q i x, compile p = q -> lookup p x i -> 71 | lookup q (compile_index p x) (comp_first i)). 72 | apply th. 73 | apply H0. 74 | reflexivity. 75 | assumption. 76 | Qed. -------------------------------------------------------------------------------- /src/Assembly.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Import List.ListNotations. 3 | Require Import Program.Equality. 4 | Require Import Common. 5 | Module Assembly. 6 | 7 | Inductive instr : Type := 8 | | AddPtr : nat -> instr 9 | | SubPtr : nat -> instr 10 | | Add : nat -> instr 11 | | Sub : nat -> instr 12 | | Jump : nat -> instr 13 | | Skip : instr 14 | | Halt : instr 15 | | UJUMP : instr (* unlinked *) 16 | | URET : instr (* unlinked *). 17 | 18 | Definition program := list instr. 19 | Record state: Type := mkState 20 | { 21 | prog : program; 22 | mem : list nat; 23 | pc : nat; 24 | ac : nat; 25 | }. 26 | 27 | Definition read_instr (p : state) (i : instr) := 28 | Common.lookup (prog p) (pc p) i. 29 | 30 | (* Small-step operational semantics for our target language.*) 31 | (*list_eq_except*) 32 | Inductive semantics (p p' : state) : Prop := 33 | | add_ptr : forall imm, read_instr p (AddPtr imm) -> 34 | pc p + 1 = pc p' -> prog p = prog p' -> ac p = ac p' -> 35 | Common.list_eq_except (mem p) (mem p') [ac p] -> (forall x, 36 | Common.lookup (mem p) (ac p) x -> Common.lookup (mem p') (ac p') (x+imm)) -> 37 | semantics p p' 38 | | sub_ptr : forall imm, read_instr p (SubPtr imm) -> 39 | pc p + 1 = pc p' -> prog p = prog p' -> ac p = ac p' -> 40 | Common.list_eq_except (mem p) (mem p') [ac p] -> (forall x, 41 | Common.lookup (mem p) (ac p) x -> Common.lookup (mem p') (ac p') (x-imm)) -> 42 | semantics p p' 43 | | add : forall imm, read_instr p (Add imm) -> 44 | pc p + 1 = pc p' -> prog p = prog p' -> mem p = mem p' -> 45 | ac p' = ac p + imm -> semantics p p' 46 | | sub : forall imm, read_instr p (Sub imm) -> 47 | pc p + 1 = pc p' -> prog p = prog p' -> mem p = mem p' -> 48 | ac p' = ac p - imm -> semantics p p' 49 | | jump: forall addr, read_instr p (Jump addr) -> 50 | prog p = prog p' -> mem p = mem p' -> ac p = ac p' -> 51 | pc p' = addr -> semantics p p' 52 | | skipnz:read_instr p Skip -> prog p = prog p' -> mem p = mem p' -> 53 | ac p = ac p' -> ~ Common.lookup (mem p') (ac p') 0 -> pc p' = pc p + 2 -> semantics p p' 54 | | skipz: read_instr p Skip -> prog p = prog p' -> mem p = mem p' -> 55 | ac p = ac p' -> Common.lookup (mem p') (ac p') 0 -> pc p' = pc p + 1 -> semantics p p'. 56 | End Assembly. -------------------------------------------------------------------------------- /first_attempt/prototype/Example.v: -------------------------------------------------------------------------------- 1 | Require Import Vector. 2 | Import Vector.VectorNotations. 3 | Require Import Program.Equality. 4 | 5 | Inductive instr1 : Type := 6 | | Load : instr1 7 | | Halt : instr1. 8 | 9 | Inductive instr2 {n} : Type := 10 | | Load' : instr2 11 | | Halt' : Fin.t n -> instr2. 12 | 13 | Definition make_f1 (x : nat) (H : x <> 0) : Fin.t x. 14 | Proof. 15 | destruct x eqn:H1. 16 | - auto with *. 17 | - exact Fin.F1. 18 | Defined. 19 | 20 | Definition comp_instr {n : nat} (HA : n <> 0) x := 21 | match x with 22 | | Load => Load' 23 | | Halt => Halt' (make_f1 n HA) 24 | end. 25 | 26 | Fixpoint comp_len {n} (p : t instr1 n) : nat := 27 | match p with 28 | | Vector.nil _ => 0 29 | | Halt :: xs => 1 + comp_len xs 30 | | Load :: xs => 2 + comp_len xs 31 | end. 32 | 33 | Fixpoint compile' {n n'} (HA : n' <> 0) (p : t instr1 n) : t (@instr2 n') (comp_len p). 34 | Proof. 35 | destruct p. 36 | - exact []. 37 | - destruct h. 38 | + cbn. 39 | exact ((Load' :: Load' :: (compile' n n' HA p))). 40 | + cbn. 41 | exact ((Halt' (make_f1 n' HA)) :: (compile' n n' HA p)). 42 | Defined. 43 | 44 | Fixpoint to_nat {n} (x : Fin.t n) : nat. 45 | Proof. 46 | destruct x eqn:H. 47 | - exact 0. 48 | - apply plus. 49 | + exact 1. 50 | + apply to_nat with (n := n). 51 | exact t. 52 | Defined. 53 | 54 | Fixpoint weaken_fin_t {n : nat} (f : Fin.t n) : Fin.t (S n) := 55 | match f in Fin.t n return Fin.t (S n) with 56 | | Fin.F1 => Fin.F1 57 | | Fin.FS f' => Fin.FS (weaken_fin_t f') 58 | end. 59 | Require Import Coq.Program.Wf. 60 | From Hammer Require Import Tactics. 61 | Require Import Lia. 62 | Program Fixpoint fin_t_fact {n} (i : Fin.t n) {measure (to_nat i)} : nat := 63 | match i with 64 | | Fin.F1 => 1 65 | | Fin.FS t => (to_nat i) * (fin_t_fact (weaken_fin_t t)) 66 | end. 67 | Next Obligation. 68 | dependent destruction t. 69 | - ssimpl. 70 | - ssimpl. 71 | assert (to_nat (weaken_fin_t t) = to_nat t). 72 | + dependent induction t. ssimpl. 73 | ssimpl. 74 | + rewrite H. lia. 75 | Qed. 76 | Check (nat, bool). 77 | 78 | Fixpoint make_indexes (n : nat) : Vector.t (Fin.t n) n := 79 | match n with 80 | | 0 => [] 81 | | S i => Fin.F1 :: map Fin.FS (make_indexes i) 82 | end. 83 | 84 | Compute (make_indexes 8). 85 | 86 | Lemma lm1 : forall n p, n <> 0 -> @comp_len n p <> 0. 87 | Proof. 88 | intros. destruct p. auto with *. destruct h; cbn; auto with *. 89 | Qed. 90 | Definition compile {n : nat} (p : t instr1 n) (HA : n <> 0) : t (@instr2 (comp_len p)) (comp_len p) := 91 | @compile' n (comp_len p) (lm1 n p HA) p. 92 | 93 | Fixpoint compile_index {n} (p : t instr1 n) (x : Fin.t n) : Fin.t (comp_len p). 94 | Proof. 95 | destruct x eqn:H1; rewrite (eta p); destruct hd eqn:H2. 96 | - apply Fin.F1. 97 | - apply Fin.F1. 98 | - do 2 apply Fin.FS. apply compile_index. exact t. 99 | - do 1 apply Fin.FS, compile_index. exact t. 100 | Defined. 101 | 102 | Theorem th : forall {n} (x : Fin.t n) (p : Vector.t instr1 n) (HA : n <> 0), 103 | @comp_instr (comp_len p) (lm1 n p HA) p[@x] = (@compile n p HA)[@compile_index p x]. 104 | Admitted. 105 | 106 | 107 | 108 | -------------------------------------------------------------------------------- /first_attempt/prototype/Example2.v: -------------------------------------------------------------------------------- 1 | Require Import Vector. 2 | Import Vector.VectorNotations. 3 | Require Import Program.Equality. 4 | Require Import Coq.Program.Wf. 5 | From Hammer Require Import Tactics. 6 | From Hammer Require Import Hammer. 7 | Require Import Lia. 8 | Require Import Classical. 9 | 10 | Inductive instr1 : Type := 11 | | A : instr1 12 | | B : instr1. 13 | 14 | Inductive instr2 : Type := 15 | | A' : instr2 16 | | B' : instr2 17 | | C' : instr2. 18 | 19 | Fixpoint comp_len {n} (p : t instr1 n) : nat := 20 | match p with 21 | | [] => 0 22 | | A :: xs => 1 + comp_len xs 23 | | B :: xs => 3 + comp_len xs 24 | end. 25 | 26 | Fixpoint compile {n} (p : Vector.t instr1 n) : Vector.t instr2 (comp_len p). 27 | Proof. 28 | destruct p. 29 | exact []. 30 | destruct h. 31 | - exact (A' :: compile n p). 32 | - exact (C' :: B' :: A' :: compile n p). 33 | Defined. 34 | 35 | Fixpoint compile_index {n} (p : t instr1 n) (x : Fin.t n) : Fin.t (comp_len p). 36 | Proof. 37 | destruct x eqn:H1; rewrite (eta p); destruct hd eqn:H2. 38 | - apply Fin.F1. 39 | - apply Fin.F1. 40 | - do 1 apply Fin.FS. apply compile_index. exact t. 41 | - do 3 apply Fin.FS. apply compile_index. exact t. 42 | Defined. 43 | 44 | Fixpoint to_nat {n} (x : Fin.t n) : nat := 45 | match x with 46 | | Fin.F1 => 0 47 | | Fin.FS t => 1 + (to_nat t) 48 | end. 49 | 50 | 51 | Definition vec_len {A n} (v : Vector.t A n) : nat := n. 52 | 53 | Definition compile_first (i : instr1) : instr2 := 54 | match i with 55 | | A => A' 56 | | B => C' 57 | end. 58 | 59 | Lemma read_instr_eq {n} : forall p x, 60 | (compile p)[@@compile_index n p x] = @compile_first p[@x]. 61 | Proof. 62 | intros. 63 | induction x; dependent destruction p; 64 | destruct h; simpl; 65 | try (now reflexivity); 66 | try (apply IHx). 67 | Qed. 68 | 69 | Lemma to_nat_st {n} : forall a b, @to_nat n a = to_nat b -> a = b. 70 | Proof. 71 | intros. 72 | dependent induction a; dependent destruction b. 73 | reflexivity. 74 | assert (n = 0). ssimpl. exfalso. ssimpl. 75 | assert (n = 0). ssimpl. exfalso. ssimpl. 76 | f_equal. 77 | apply IHa. 78 | inversion H. 79 | reflexivity. 80 | Qed. 81 | Require Import Coq.Arith.Arith_base. 82 | 83 | Definition fint_plus {n m} (a : Fin.t n) (b : Fin.t m) : Fin.t (n + m). 84 | Proof. 85 | induction a. 86 | * induction b. 87 | ** exact Fin.F1. 88 | ** rewrite Nat.add_comm. cbn. apply Fin.FS. rewrite Nat.add_comm. assumption. 89 | * cbn. apply Fin.FS. assumption. 90 | Defined. 91 | 92 | Lemma ci_le {n} : forall p x, to_nat (@compile_index n p x) < 93 | comp_len p - vec_len (compile [p[@x]]) + 1. 94 | Admitted. 95 | 96 | Definition safe_plus {n m} (a : Fin.t n) (b : Fin.t m) 97 | (H : (to_nat a) + (to_nat b) < n) : Fin.t n. 98 | Admitted. 99 | 100 | Lemma safe_plus_is_plus {n m} : forall a b H, 101 | @to_nat n (safe_plus a b H) = 102 | (to_nat a) + (@to_nat m b). 103 | Admitted. 104 | 105 | Require Import Coq.Vectors.VectorDef. 106 | 107 | Fixpoint drop_fill {n a} (p : t a n) (f : a) (i : nat) : t a n. 108 | Admitted. 109 | 110 | Theorem th {n} : forall p x x' (off : Fin.t (comp_len [p[@x]])), 111 | to_nat x' = to_nat (@compile_index n p x) + to_nat off -> 112 | (compile p)[@x'] = (compile [p[@x]])[@off]. 113 | Proof. 114 | intros. 115 | -------------------------------------------------------------------------------- /src/Language.v: -------------------------------------------------------------------------------- 1 | Require Import Program.Equality. 2 | Require Import PeanoNat. 3 | Require Import Common. 4 | Require Import Lia. 5 | Require Import List. 6 | Import List.ListNotations. 7 | Module Language. 8 | Inductive instr : Type := 9 | | PtrInc : instr 10 | | PtrDec : instr 11 | | Inc : instr 12 | | Dec : instr 13 | | Jump : instr 14 | | Ret : instr 15 | | Halt : instr. 16 | Definition program := list instr. 17 | 18 | Record state : Type := mkState 19 | { 20 | prog : program; 21 | mem : list nat; 22 | pc : nat; 23 | ptr : nat; 24 | }. 25 | 26 | 27 | Definition option_inc (i : option nat) : option nat := 28 | match i with 29 | | None => None 30 | | Some a => Some (a + 1) 31 | end. 32 | 33 | 34 | Fixpoint matching_jump' (l : list instr) (idx : nat) (c : nat) 35 | (c' : option nat) : option nat := 36 | match l with 37 | | [] => None 38 | | Jump :: h => if c =? idx then None else matching_jump' h idx (c+1) (Some c) 39 | | Ret :: h => if c =? idx then (option_inc c') else None 40 | | _ :: h => if c =? idx then None else matching_jump' h idx (c+1) c' 41 | end. 42 | 43 | Fixpoint matching_ret' (l : list instr) (idx : nat) (c c' : nat) : 44 | option nat := 45 | match l with 46 | | [] => None 47 | | i :: h => if c' <=? idx then matching_ret' h idx c (c'+1) else 48 | match i with 49 | | Jump => matching_ret' h idx (c+1) (c'+1) 50 | | Ret => if c =? 0 then (Some (c' + 1)) else matching_ret' h idx 51 | (c-1) (c'+1) 52 | | _ => matching_ret' h idx c (c'+1) 53 | end 54 | end. 55 | 56 | Inductive matching_jump (p : program) (x x' : nat) : Prop := 57 | | mj : matching_jump' p x 0 None = Some x' -> matching_jump p x x'. 58 | Inductive matching_ret (p : program) (x x' : nat) : Prop := 59 | | mr : matching_ret' p x 0 0 = Some x' -> matching_ret p x x'. 60 | 61 | (* Small-step operational semantics for our source language.*) 62 | 63 | Definition read_instr (p : state) (i : instr) := 64 | Common.lookup (prog p) (pc p) i. 65 | 66 | Inductive semantics (p p' : state) : Prop := 67 | | ptr_inc : read_instr p PtrInc -> prog p = prog p' -> pc p + 1 = pc p' -> 68 | ptr p + 1 = ptr p' -> mem p = mem p' -> semantics p p' 69 | | ptr_dec : read_instr p PtrDec -> prog p = prog p' -> pc p + 1 = pc p' -> 70 | ptr p - 1 = ptr p' -> mem p = mem p' -> semantics p p' 71 | | inc : read_instr p Inc -> prog p = prog p' -> pc p + 1 = pc p' -> 72 | ptr p = ptr p' -> 73 | Common.list_eq_except (mem p) (mem p') [ptr p] -> 74 | (forall M, (Common.lookup (mem p) (ptr p) M -> 75 | Common.lookup (mem p') (ptr p') (M+1))) -> semantics p p' 76 | | dec : read_instr p Dec -> prog p = prog p' -> pc p + 1 = pc p' -> 77 | ptr p = ptr p' -> 78 | Common.list_eq_except (mem p) (mem p') [ptr p] -> 79 | (forall M, (Common.lookup (mem p) (ptr p) M -> 80 | Common.lookup (mem p') (ptr p') (M-1))) -> semantics p p' 81 | | jump_z : read_instr p Jump -> ptr p = ptr p' -> prog p = prog p' -> mem p = mem p' -> 82 | Common.lookup (mem p) (ptr p) 0 -> matching_ret (prog p) (pc p) (pc p') -> 83 | semantics p p' 84 | | jump_nz : read_instr p Jump -> ptr p = ptr p' -> prog p = prog p' -> mem p = mem p' -> 85 | ~(Common.lookup (mem p) (ptr p) 0) -> pc p + 1 = pc p' -> 86 | semantics p p' 87 | | ret_z : read_instr p Ret -> ptr p = ptr p' -> prog p = prog p' -> mem p = mem p' -> 88 | Common.lookup (mem p) (ptr p) 0 -> matching_jump (prog p) (pc p) (pc p') -> 89 | semantics p p' 90 | | ret_nz : read_instr p Ret -> ptr p = ptr p' -> prog p = prog p' -> mem p = mem p' -> 91 | ~(Common.lookup (mem p) (ptr p) 0) -> pc p + 1 = pc p' -> 92 | semantics p p'. 93 | End Language. -------------------------------------------------------------------------------- /first_attempt/Assembly.v: -------------------------------------------------------------------------------- 1 | Require Import Vector. 2 | Import Vector.VectorNotations. 3 | Require Import Program.Equality. 4 | Require Import Common. 5 | Module Assembly. 6 | 7 | Inductive instr : Type := 8 | | Load : instr 9 | | Store : instr 10 | | Add : nat -> instr 11 | | Sub : nat -> instr 12 | | Jump : nat -> instr 13 | | Skip : instr 14 | | Swap : instr 15 | | Zero : instr 16 | | Halt : instr 17 | | UJUMP : instr (* unlinked *) 18 | | URET : instr (* unlinked *). 19 | 20 | Definition program (n : nat) := t instr n. 21 | Record state {n m : nat} : Type := mkState 22 | { 23 | prog : @program n; 24 | mem : t nat m; 25 | pc : Fin.t n; 26 | ac : Fin.t m; 27 | b : Fin.t m; 28 | }. 29 | 30 | Definition read_instr' {n} (prog : @program n) (pc : Fin.t n) : instr := 31 | prog[@pc]. 32 | 33 | Inductive read_instr {n m} (p : state) (i : instr) : Prop := 34 | | ri : read_instr' p.(prog n m) p.(pc) = i -> read_instr p i. 35 | 36 | Definition read_mem' {m} (mem : t nat m) (ptr : Fin.t m) : nat := mem[@ptr]. 37 | 38 | Inductive read_mem {n m} (p : state) (e : nat) : Prop := 39 | | mi : read_mem' p.(mem n m) p.(ac) = e -> read_mem p e. 40 | 41 | Inductive mem_diff {m} (m1 : t nat m) (m2 : t nat m) (x : Fin.t m) : Prop := 42 | | md : (forall i, i <> x -> m2[@i] = m1[@i]) -> mem_diff m1 m2 x. 43 | 44 | 45 | Fixpoint weaken_fin_t {n : nat} (f : Fin.t n) : Fin.t (S n) := 46 | match f in Fin.t n return Fin.t (S n) with 47 | | Fin.F1 => Fin.F1 48 | | Fin.FS f' => Fin.FS (weaken_fin_t f') 49 | end. 50 | 51 | (* Small-step operational semantics for our target language.*) 52 | 53 | Inductive semantics {n m} (p : state) (p' : state) : Prop := 54 | | load : read_instr p (Load) -> Common.to_nat p.(pc n m) + 1 = Common.to_nat p'.(pc)-> 55 | p.(prog) = p'.(prog) -> p.(mem) = p'.(mem) -> p.(b) = p'.(b) -> 56 | Common.to_nat p'.(ac) = (read_mem' p.(mem) p.(b)) -> semantics p p' 57 | | store: read_instr p (Store) -> Common.to_nat p.(pc) + 1 = Common.to_nat p'.(pc) -> 58 | p.(prog) = p'.(prog) -> p.(ac) = p'.(ac) -> 59 | Common.to_nat p.(ac) = read_mem' p'.(mem) p.(ac) -> p.(b) = p'.(b) -> 60 | mem_diff p.(mem) p'.(mem) p.(b) -> semantics p p' 61 | | add : forall n', read_instr p (Add n') -> Common.to_nat p.(pc) + 1 = 62 | Common.to_nat p'.(pc) -> p.(prog) = p'.(prog) -> p.(mem) = p'.(mem) -> 63 | p.(b) = p'.(b) -> Common.to_nat p'.(ac) = Common.to_nat (p.(ac)) + n' -> 64 | semantics p p' 65 | | sub : forall n', read_instr p (Sub n') -> Common.to_nat p.(pc) + 1 = 66 | Common.to_nat p'.(pc) -> p.(prog) = p'.(prog) -> p.(mem) = p'.(mem) -> 67 | p.(b) = p'.(b) -> Common.to_nat p'.(ac) = (Common.to_nat p.(ac)) - n' -> 68 | semantics p p' 69 | | jump : forall n', read_instr p (Jump n') -> p.(prog) = p'.(prog) -> 70 | p.(ac) = p'.(ac) -> p.(mem) = p'.(mem) -> Common.to_nat (p'.(pc)) = 71 | n' -> p.(b) = p'.(b) -> semantics p p' 72 | | skipz: read_instr p (Skip) -> p.(prog) = p'.(prog) -> 73 | p.(mem) = p'.(mem) -> p.(ac) = p'.(ac) -> p.(b) = p'.(b) -> 74 | read_mem p 0 -> Common.to_nat (p'.(pc)) = Common.to_nat (p.(pc)) + 2 -> 75 | semantics p p' 76 | | skipnz: read_instr p (Skip) -> p.(prog) = p'.(prog) -> 77 | p.(mem) = p'.(mem) -> p.(ac) = p'.(ac) -> p.(b) = p'.(b) -> 78 | ~ (read_mem p 0) -> Common.to_nat p'.(pc) = (Common.to_nat p.(pc)) + 1 -> 79 | semantics p p' 80 | | swap : read_instr p (Swap) -> p.(prog) = 81 | p'.(prog) -> p.(mem) = p'.(mem) -> 82 | p.(ac) = p'.(b) -> p.(b) = p'.(ac) -> Common.to_nat p'.(pc) = 83 | (Common.to_nat p.(pc)) + 1 -> 84 | semantics p p' 85 | | zero : read_instr p (Zero) -> p.(prog) = 86 | p'.(prog) -> p.(mem) = p'.(mem) -> 87 | p'.(b) = p.(b) -> 0 = Common.to_nat p'.(ac) -> Common.to_nat p'.(pc) = 88 | (Common.to_nat p.(pc)) + 1 -> 89 | semantics p p'. 90 | End Assembly. -------------------------------------------------------------------------------- /first_attempt/Language.v: -------------------------------------------------------------------------------- 1 | Require Import Vector. 2 | Import Vector.VectorNotations. 3 | Require Import Program.Equality. 4 | Require Import PeanoNat. 5 | Require Import Common. 6 | Require Import Lia. 7 | Module Language. 8 | Inductive instr : Type := 9 | | PtrInc : instr 10 | | PtrDec : instr 11 | | Inc : instr 12 | | Dec : instr 13 | | Jump : instr 14 | | Ret : instr 15 | | Halt : instr. 16 | Definition program (n : nat) := t instr n. 17 | 18 | Record state {n m : nat} : Type := mkState 19 | { 20 | prog : program n; 21 | mem : t nat m; 22 | pc : Fin.t n; 23 | ptr : Fin.t m; 24 | }. 25 | 26 | Definition read_instr' {n} (prog : program n) (pc : Fin.t n) : instr := 27 | prog[@pc]. 28 | 29 | Inductive read_instr {n m} (p : state) (i : instr) : Prop := 30 | | ri : read_instr' p.(prog n m) p.(pc n m) = i -> read_instr p i. 31 | 32 | Definition read_mem' {m} (mem : t nat m) (ptr : Fin.t m) : nat := mem[@ptr]. 33 | 34 | Inductive read_mem {n m} (p : state) (e : nat) : Prop := 35 | | mi : read_mem' p.(mem n m) p.(ptr n m) = e -> read_mem p e. 36 | 37 | 38 | Inductive mem_diff {m} (m1 : t nat m) (m2 : t nat m) (x : Fin.t m) : Prop := 39 | | md : (forall i, i <> x -> m2[@i] = m1[@i]) -> mem_diff m1 m2 x. 40 | 41 | 42 | Definition option_inc (i : option nat) : option nat := 43 | match i with 44 | | None => None 45 | | Some a => Some (a + 1) 46 | end. 47 | 48 | Fixpoint matching_ret' {n} (l : t instr n) (idx : nat) (c c' : nat) : 49 | option nat := 50 | match l with 51 | | [] => None 52 | | i :: h => if c' <=? idx then matching_ret' h idx c (c'+1) else 53 | match i with 54 | | Jump => matching_ret' h idx (c+1) (c'+1) 55 | | Ret => if c =? 0 then (Some (c' + 1)) else matching_ret' h idx 56 | (c-1) (c'+1) 57 | | _ => matching_ret' h idx c (c'+1) 58 | end 59 | end. 60 | 61 | Fixpoint matching_jump' {n} (l : t instr n) (idx : nat) (c : nat) 62 | (c' : option nat) : option nat := 63 | match l with 64 | | [] => None 65 | | Jump :: h => if c =? idx then None else matching_jump' h idx (c+1) (Some c) 66 | | Ret :: h => if c =? idx then (option_inc c') else None 67 | | _ :: h => if c =? idx then None else matching_jump' h idx (c+1) c' 68 | end. 69 | 70 | Inductive matching_jump {n} (p : program n) (x : Fin.t n) (x' : Fin.t n) : Prop := 71 | | mj : matching_jump' p (Common.to_nat x) 0 None = Some (Common.to_nat x') -> matching_jump p x x'. 72 | Inductive matching_ret {n} (p : program n) (x : Fin.t n) (x' : Fin.t n): Prop := 73 | | mr : matching_ret' p (Common.to_nat x) 0 0 = Some (Common.to_nat x') -> matching_ret p x x'. 74 | 75 | (*Some cases will not be accepted for compilation anyway, like unmatched jumps.*) 76 | (* Small-step operational semantics for our source language.*) 77 | 78 | Inductive semantics {n m} (p : state) (p' : state) : Prop := 79 | | ptr_inc : read_instr p PtrInc -> Common.to_nat p.(ptr) + 1 = Common.to_nat p'.(ptr) -> 80 | Common.to_nat p.(pc n m) + 1 = Common.to_nat p'.(pc)-> p.(prog) = p'.(prog) -> 81 | p.(mem) = p'.(mem) -> semantics p p' 82 | | ptr_dec : read_instr p PtrDec -> Common.to_nat p.(ptr) - 1 = Common.to_nat p'.(ptr) -> 83 | Common.to_nat p.(pc) +1 = Common.to_nat p'.(pc)-> p.(prog) = p'.(prog) -> 84 | p.(mem) = p'.(mem) -> semantics p p' 85 | | inc : read_instr p Inc -> p.(ptr) = p'.(ptr) -> 86 | Common.to_nat p.(pc) +1 = Common.to_nat p'.(pc)-> p.(prog) = p'.(prog) -> 87 | mem_diff p.(mem) p'.(mem) p.(ptr) -> 88 | p.(mem)[@p.(ptr)] + 1 = p'.(mem)[@p.(ptr)] -> 89 | semantics p p' 90 | | dec : read_instr p Dec -> p.(ptr) = p'.(ptr) -> 91 | Common.to_nat p.(pc) +1 = Common.to_nat p'.(pc)-> p.(prog) = p'.(prog) -> 92 | mem_diff p.(mem) p'.(mem) p.(ptr) -> 93 | p.(mem)[@p.(ptr)] - 1 = p'.(mem)[@p.(ptr)] -> 94 | semantics p p' 95 | | jump_z : read_instr p Jump -> p.(ptr) = p'.(ptr) -> 96 | p.(prog) = p'.(prog) -> p.(mem) = p'.(mem) -> 97 | read_mem p 0 -> matching_ret p.(prog) p.(pc) p'.(pc) -> 98 | semantics p p' 99 | | jump_nz : read_instr p Jump -> p.(ptr) = p'.(ptr) -> 100 | p.(prog) = p'.(prog) -> p.(mem) = p'.(mem) -> 101 | ~ (read_mem p 0) -> 102 | Common.to_nat p.(pc) + 1 = Common.to_nat p'.(pc)-> semantics p p' 103 | | ret_z : read_instr p Ret -> p.(ptr) = p'.(ptr) -> 104 | p.(prog) = p'.(prog) -> p.(mem) = p'.(mem) -> 105 | matching_jump p.(prog) p.(pc) p'.(pc) -> read_mem p 0 -> 106 | semantics p p' 107 | | ret_nz : read_instr p Ret -> p.(ptr) = p'.(ptr) -> 108 | p.(prog) = p'.(prog) -> p.(mem) = p'.(mem) -> 109 | ~ (read_mem p 0) -> 110 | Common.to_nat p.(pc) + 1 = Common.to_nat p'.(pc) -> semantics p p'. 111 | End Language. -------------------------------------------------------------------------------- /src/Simulation.v: -------------------------------------------------------------------------------- 1 | Require Import Common. 2 | Module Simulation. 3 | 4 | Definition lockstep_forward_sim {A : Type} {B : Type} 5 | (compile : A -> B -> Prop) 6 | (eval : A -> A -> Prop) 7 | (eval': B -> B -> Prop) := 8 | forall p q, compile p q -> 9 | forall p', eval p p' -> 10 | exists q', compile p' q' /\ eval' q q'. 11 | 12 | Definition lockstep_backward_sim {A : Type} {B : Type} 13 | (compile : A -> B -> Prop) 14 | (eval : A -> A -> Prop) 15 | (eval': B -> B -> Prop) := 16 | forall p q, compile p q -> 17 | forall q', eval' q q' -> 18 | exists p', compile p' q' /\ eval p p'. 19 | 20 | Definition lockstep_bisim {A : Type} {B : Type} 21 | (compile : A -> B -> Prop) 22 | (eval : A -> A -> Prop) 23 | (eval': B -> B -> Prop) := 24 | forall p q, compile p q -> 25 | (forall p', eval p p' -> 26 | exists q', eval' q q' /\ compile p' q') /\ 27 | (forall q', eval' q q' -> 28 | exists p', eval p p' /\ compile p' q'). 29 | 30 | Definition plus_forward_sim {A : Type} {B : Type} 31 | (compile : A -> B -> Prop) 32 | (eval : A -> A -> Prop) 33 | (eval': B -> B -> Prop) := 34 | forall p q, compile p q -> 35 | forall p', eval p p' -> 36 | exists q', compile p' q' /\ (Common.plus eval') q q'. 37 | 38 | Definition plus_backward_sim {A : Type} {B : Type} 39 | (compile : A -> B -> Prop) 40 | (eval : A -> A -> Prop) 41 | (eval': B -> B -> Prop) := 42 | forall p q, compile p q -> 43 | forall q', eval' q q' -> 44 | exists p', (Common.plus eval) p p' /\ compile p' q'. 45 | 46 | Definition plus_bisim {A : Type} {B : Type} 47 | (compile : A -> B -> Prop) 48 | (eval : A -> A -> Prop) 49 | (eval': B -> B -> Prop) := 50 | forall p q, compile p q -> 51 | (forall p', eval p p' -> 52 | exists q', (Common.plus eval') q q' /\ compile p' q') /\ 53 | (forall q', eval' q q' -> 54 | exists p', (Common.plus eval) p p' /\ compile p' q'). 55 | 56 | Definition star_forward_sim {A : Type} {B : Type} {Ord : Type} 57 | (measure : A -> Ord) 58 | (order_R : Ord -> Ord -> Prop) 59 | (compile : A -> B -> Prop) 60 | (eval : A -> A -> Prop) 61 | (eval': B -> B -> Prop) := 62 | forall p q, compile p q -> 63 | (forall p', eval p p' -> 64 | exists q', (Common.plus eval') q q' /\ compile p' q') \/ 65 | (forall p', eval p p' /\ order_R (measure p') (measure p) -> 66 | exists q', (Common.star eval') q q' /\ compile p' q'). 67 | 68 | Definition star_backward_sim {A : Type} {B : Type} {Ord : Type} 69 | (measure : B -> Ord) 70 | (order_R : Ord -> Ord -> Prop) 71 | (compile : A -> B -> Prop) 72 | (eval : A -> A -> Prop) 73 | (eval': B -> B -> Prop) := 74 | forall p q, compile p q -> 75 | (forall q', eval' q q' -> 76 | exists p', (Common.plus eval) p p' /\ compile p' q') \/ 77 | (forall q', eval' q q' /\ order_R (measure q') (measure q) -> 78 | exists p', (Common.star eval) p p' /\ compile p' q'). 79 | 80 | Definition star_bisim {A : Type} {B : Type} {Ord : Type} {Ord' : Type} 81 | (measure : A -> Ord) 82 | (measure' : B -> Ord') 83 | (order_R : Ord -> Ord -> Prop) 84 | (order_R' : Ord' -> Ord' -> Prop) 85 | (compile : A -> B -> Prop) 86 | (eval : A -> A -> Prop) 87 | (eval': B -> B -> Prop) := 88 | forall p q, compile p q -> 89 | ((forall p', eval p p' -> 90 | exists q', (Common.plus eval') q q' /\ compile p' q') \/ 91 | (forall p', eval p p' /\ order_R (measure p') (measure p) -> 92 | exists q', (Common.star eval') q q' /\ compile p' q')) /\ 93 | ((forall q', eval' q q' -> 94 | exists p', (Common.plus eval) p p' /\ compile p' q') \/ 95 | (forall q', eval' q q' /\ order_R' (measure' q') (measure' q) -> 96 | exists p', (Common.star eval) p p' /\ compile p' q')). 97 | 98 | Definition option_forward_sim {A : Type} {B : Type} {Ord : Type} 99 | (empty : (A -> A -> Prop) -> (A -> A -> Prop)) 100 | (measure : A -> Ord) 101 | (order_R : Ord -> Ord -> Prop) 102 | (compile : A -> B -> Prop) 103 | (eval : A -> A -> Prop) 104 | (eval': B -> B -> Prop) := 105 | forall p q, compile p q -> 106 | (forall p', eval p p' -> 107 | exists q', eval' q q' /\ compile p' q') \/ 108 | (forall p', (empty eval) p p' /\ order_R (measure p') (measure p) -> 109 | compile p' q). 110 | 111 | Definition option_backward_sim {A : Type} {B : Type} {Ord : Type} 112 | (empty : (B -> B -> Prop) -> (B -> B -> Prop)) 113 | (measure : B -> Ord) 114 | (order_R : Ord -> Ord -> Prop) 115 | (compile : A -> B -> Prop) 116 | (eval : A -> A -> Prop) 117 | (eval': B -> B -> Prop) := 118 | forall p q, compile p q -> 119 | (forall q', eval' q q' -> 120 | exists p', eval p p' /\ compile p' q') \/ 121 | (forall q', (empty eval') q q' /\ order_R (measure q') (measure q) -> 122 | compile p q'). 123 | 124 | Definition option_bisim {A : Type} {B : Type} {Ord : Type} {Ord' : Type} 125 | (empty : (A -> A -> Prop) -> (A -> A -> Prop)) 126 | (empty': (B -> B -> Prop) -> (B -> B -> Prop)) 127 | (measure : A -> Ord) 128 | (measure' : B -> Ord') 129 | (order_R : Ord -> Ord -> Prop) 130 | (order_R' : Ord' -> Ord' -> Prop) 131 | (compile : A -> B -> Prop) 132 | (eval : A -> A -> Prop) 133 | (eval': B -> B -> Prop) := 134 | forall p q, compile p q -> 135 | ((forall p', eval p p' -> 136 | exists q', eval' q q' /\ compile p' q') \/ 137 | (forall p', (empty eval) p p' /\ order_R (measure p') (measure p) -> 138 | compile p' q)) /\ 139 | ((forall q', eval' q q' -> 140 | exists p', eval p p' /\ compile p' q') \/ 141 | (forall q', (empty' eval') q q' /\ order_R' (measure' q') (measure' q) -> 142 | compile p q')). 143 | 144 | End Simulation. 145 | -------------------------------------------------------------------------------- /first_attempt/Simulation.v: -------------------------------------------------------------------------------- 1 | Require Import Common. 2 | Module Simulation. 3 | 4 | Definition lockstep_forward_sim {A : Type} {B : Type} 5 | (compile : A -> B -> Prop) 6 | (eval : A -> A -> Prop) 7 | (eval': B -> B -> Prop) := 8 | forall p q, compile p q -> 9 | forall p', eval p p' -> 10 | exists q', compile p' q' /\ eval' q q'. 11 | 12 | Definition lockstep_backward_sim {A : Type} {B : Type} 13 | (compile : A -> B -> Prop) 14 | (eval : A -> A -> Prop) 15 | (eval': B -> B -> Prop) := 16 | forall p q, compile p q -> 17 | forall q', eval' q q' -> 18 | exists p', compile p' q' /\ eval p p'. 19 | 20 | Definition lockstep_bisim {A : Type} {B : Type} 21 | (compile : A -> B -> Prop) 22 | (eval : A -> A -> Prop) 23 | (eval': B -> B -> Prop) := 24 | forall p q, compile p q -> 25 | (forall p', eval p p' -> 26 | exists q', eval' q q' /\ compile p' q') /\ 27 | (forall q', eval' q q' -> 28 | exists p', eval p p' /\ compile p' q'). 29 | 30 | Definition plus_forward_sim {A : Type} {B : Type} 31 | (compile : A -> B -> Prop) 32 | (eval : A -> A -> Prop) 33 | (eval': B -> B -> Prop) := 34 | forall p q, compile p q -> 35 | forall p', eval p p' -> 36 | exists q', compile p' q' /\ (Common.plus eval') q q'. 37 | 38 | Definition plus_backward_sim {A : Type} {B : Type} 39 | (compile : A -> B -> Prop) 40 | (eval : A -> A -> Prop) 41 | (eval': B -> B -> Prop) := 42 | forall p q, compile p q -> 43 | forall q', eval' q q' -> 44 | exists p', (Common.plus eval) p p' /\ compile p' q'. 45 | 46 | Definition plus_bisim {A : Type} {B : Type} 47 | (compile : A -> B -> Prop) 48 | (eval : A -> A -> Prop) 49 | (eval': B -> B -> Prop) := 50 | forall p q, compile p q -> 51 | (forall p', eval p p' -> 52 | exists q', (Common.plus eval') q q' /\ compile p' q') /\ 53 | (forall q', eval' q q' -> 54 | exists p', (Common.plus eval) p p' /\ compile p' q'). 55 | 56 | Definition star_forward_sim {A : Type} {B : Type} {Ord : Type} 57 | (measure : A -> Ord) 58 | (order_R : Ord -> Ord -> Prop) 59 | (compile : A -> B -> Prop) 60 | (eval : A -> A -> Prop) 61 | (eval': B -> B -> Prop) := 62 | forall p q, compile p q -> 63 | (forall p', eval p p' -> 64 | exists q', (Common.plus eval') q q' /\ compile p' q') \/ 65 | (forall p', eval p p' /\ order_R (measure p') (measure p) -> 66 | exists q', (Common.star eval') q q' /\ compile p' q'). 67 | 68 | Definition star_backward_sim {A : Type} {B : Type} {Ord : Type} 69 | (measure : B -> Ord) 70 | (order_R : Ord -> Ord -> Prop) 71 | (compile : A -> B -> Prop) 72 | (eval : A -> A -> Prop) 73 | (eval': B -> B -> Prop) := 74 | forall p q, compile p q -> 75 | (forall q', eval' q q' -> 76 | exists p', (Common.plus eval) p p' /\ compile p' q') \/ 77 | (forall q', eval' q q' /\ order_R (measure q') (measure q) -> 78 | exists p', (Common.star eval) p p' /\ compile p' q'). 79 | 80 | Definition star_bisim {A : Type} {B : Type} {Ord : Type} {Ord' : Type} 81 | (measure : A -> Ord) 82 | (measure' : B -> Ord') 83 | (order_R : Ord -> Ord -> Prop) 84 | (order_R' : Ord' -> Ord' -> Prop) 85 | (compile : A -> B -> Prop) 86 | (eval : A -> A -> Prop) 87 | (eval': B -> B -> Prop) := 88 | forall p q, compile p q -> 89 | ((forall p', eval p p' -> 90 | exists q', (Common.plus eval') q q' /\ compile p' q') \/ 91 | (forall p', eval p p' /\ order_R (measure p') (measure p) -> 92 | exists q', (Common.star eval') q q' /\ compile p' q')) /\ 93 | ((forall q', eval' q q' -> 94 | exists p', (Common.plus eval) p p' /\ compile p' q') \/ 95 | (forall q', eval' q q' /\ order_R' (measure' q') (measure' q) -> 96 | exists p', (Common.star eval) p p' /\ compile p' q')). 97 | 98 | Definition option_forward_sim {A : Type} {B : Type} {Ord : Type} 99 | (empty : (A -> A -> Prop) -> (A -> A -> Prop)) 100 | (measure : A -> Ord) 101 | (order_R : Ord -> Ord -> Prop) 102 | (compile : A -> B -> Prop) 103 | (eval : A -> A -> Prop) 104 | (eval': B -> B -> Prop) := 105 | forall p q, compile p q -> 106 | (forall p', eval p p' -> 107 | exists q', eval' q q' /\ compile p' q') \/ 108 | (forall p', (empty eval) p p' /\ order_R (measure p') (measure p) -> 109 | compile p' q). 110 | 111 | Definition option_backward_sim {A : Type} {B : Type} {Ord : Type} 112 | (empty : (B -> B -> Prop) -> (B -> B -> Prop)) 113 | (measure : B -> Ord) 114 | (order_R : Ord -> Ord -> Prop) 115 | (compile : A -> B -> Prop) 116 | (eval : A -> A -> Prop) 117 | (eval': B -> B -> Prop) := 118 | forall p q, compile p q -> 119 | (forall q', eval' q q' -> 120 | exists p', eval p p' /\ compile p' q') \/ 121 | (forall q', (empty eval') q q' /\ order_R (measure q') (measure q) -> 122 | compile p q'). 123 | 124 | Definition option_bisim {A : Type} {B : Type} {Ord : Type} {Ord' : Type} 125 | (empty : (A -> A -> Prop) -> (A -> A -> Prop)) 126 | (empty': (B -> B -> Prop) -> (B -> B -> Prop)) 127 | (measure : A -> Ord) 128 | (measure' : B -> Ord') 129 | (order_R : Ord -> Ord -> Prop) 130 | (order_R' : Ord' -> Ord' -> Prop) 131 | (compile : A -> B -> Prop) 132 | (eval : A -> A -> Prop) 133 | (eval': B -> B -> Prop) := 134 | forall p q, compile p q -> 135 | ((forall p', eval p p' -> 136 | exists q', eval' q q' /\ compile p' q') \/ 137 | (forall p', (empty eval) p p' /\ order_R (measure p') (measure p) -> 138 | compile p' q)) /\ 139 | ((forall q', eval' q q' -> 140 | exists p', eval p p' /\ compile p' q') \/ 141 | (forall q', (empty' eval') q q' /\ order_R' (measure' q') (measure' q) -> 142 | compile p q')). 143 | 144 | End Simulation. 145 | -------------------------------------------------------------------------------- /src/Compiler.v: -------------------------------------------------------------------------------- 1 | Require Import Common. 2 | Require Import Language. 3 | Require Import Assembly. 4 | 5 | Require Import List. 6 | Import List.ListNotations. 7 | From Hammer Require Import Tactics. 8 | Module Compiler. 9 | 10 | Fixpoint compile'' (p : Language.program) : Assembly.program := 11 | match p with 12 | | [] => [] 13 | | Language.PtrInc :: h => Assembly.Add 1 :: compile'' h 14 | | Language.PtrDec :: h => Assembly.Sub 1 :: compile'' h 15 | | Language.Inc :: h => Assembly.AddPtr 1 :: compile'' h 16 | | Language.Dec :: h => Assembly.SubPtr 1 :: compile'' h 17 | | Language.Jump :: h => Assembly.Skip :: Assembly.UJUMP :: compile'' h 18 | | Language.Ret :: h => Assembly.Skip :: Assembly.URET :: compile'' h 19 | | Language.Halt :: h => Assembly.Halt :: compile'' h 20 | end. 21 | 22 | Definition comp_first (x : Language.instr) : Assembly.instr := 23 | match x with 24 | | Language.PtrInc => Assembly.Add 1 25 | | Language.PtrDec => Assembly.Sub 1 26 | | Language.Inc => Assembly.AddPtr 1 27 | | Language.Dec => Assembly.SubPtr 1 28 | | Language.Jump => Assembly.Skip 29 | | Language.Ret => Assembly.Skip 30 | | Language.Halt => Assembly.Halt 31 | end. 32 | 33 | Fixpoint compile_index (p : Language.program) (x : nat) : nat := 34 | match x with 35 | | 0 => 0 36 | | _ => match p with 37 | | [] => 0 38 | | Language.Jump :: h => 2 + compile_index h (x-1) 39 | | Language.Ret :: h => 2 + compile_index h (x-1) 40 | | _ :: h => 1 + compile_index h (x-1) 41 | end 42 | end. 43 | 44 | Fixpoint nb_jump (p : Assembly.program) : nat := 45 | match p with 46 | | [] => 0 47 | | Assembly.UJUMP :: t => 1 + nb_jump t 48 | | _ :: t => nb_jump t 49 | end. 50 | 51 | Fixpoint nb_ret (p : Assembly.program) : nat := 52 | match p with 53 | | [] => 0 54 | | Assembly.URET :: t => 1 + nb_ret t 55 | | _ :: t => nb_ret t 56 | end. 57 | 58 | Fixpoint j_indexes (p : Assembly.program) : list nat := 59 | match p with 60 | | [] => [] 61 | | Assembly.UJUMP :: t => 0 :: map S (j_indexes t) 62 | | _ :: t => map S (j_indexes t) 63 | end. 64 | 65 | Fixpoint r_indexes (p : Assembly.program) : list nat := 66 | match p with 67 | | [] => [] 68 | | Assembly.URET :: t => 0 :: map S (r_indexes t) 69 | | _ :: t => map S (r_indexes t) 70 | end. 71 | 72 | Fixpoint replace (v : list Assembly.instr) (p : nat) (a : Assembly.instr) : list Assembly.instr := 73 | match v with 74 | | [] => v 75 | | h :: l => match p with 76 | | 0 => a :: l 77 | | S n => h :: replace l n a 78 | end 79 | end. 80 | 81 | Fixpoint link_jump' (p : Assembly.program) (jumps rets : list nat) : 82 | Assembly.program := 83 | match jumps with 84 | | [] => p 85 | | a :: jumps' => match rets with 86 | | [] => p 87 | | r :: rets' => link_jump' (replace p a (Assembly.Jump r)) jumps' rets' 88 | end 89 | end. 90 | 91 | Fixpoint link_ret' (p : Assembly.program) (jumps rets : list nat) : Assembly.program := 92 | match rets with 93 | | [] => p 94 | | a :: rets' => match jumps with 95 | | [] => p 96 | | r :: jumps' => link_ret' (replace p a (Assembly.Jump r)) jumps' rets' 97 | end 98 | end. 99 | 100 | 101 | Definition link_jump (p : Assembly.program) : (Assembly.program) := 102 | link_jump' p (j_indexes p) (r_indexes p). 103 | 104 | 105 | Fixpoint lj_indexes (p : Assembly.program) : list nat := 106 | match p with 107 | | [] => [] 108 | | Assembly.Jump _ :: t => 0 :: map S (lj_indexes t) 109 | | _ :: t => map S (lj_indexes t) 110 | end. 111 | 112 | Definition link_ret (p : Assembly.program) : (Assembly.program) := 113 | (link_ret' p (lj_indexes p) (r_indexes p)). 114 | 115 | Definition inc_jump (i : Assembly.instr) : Assembly.instr := 116 | match i with 117 | | Assembly.Jump n0 => Assembly.Jump (n0 + 1) 118 | | a => a 119 | end. 120 | 121 | Fixpoint link_aux (l : Assembly.program) : Assembly.program := 122 | match l with 123 | | [] => [] 124 | | Assembly.UJUMP :: t => map (inc_jump) (link_ret (link_jump l)) 125 | | Assembly.URET :: t => map (inc_jump) (link_ret (link_jump l)) 126 | | Assembly.Jump n:: t => (Assembly.Jump (n+1)) :: map inc_jump (link_aux t) 127 | | a :: t => a :: map inc_jump (link_aux t) 128 | end. 129 | 130 | Definition link (l : Assembly.program) : Assembly.program := 131 | map (inc_jump) (link_ret (link_jump l)). 132 | 133 | 134 | Theorem lookup_link_stable : 135 | forall x xs i y, 136 | (forall n, y <> Assembly.Jump n) -> y <> Assembly.URET -> 137 | y <> Assembly.UJUMP -> 138 | Common.lookup (Compiler.link_aux xs) i y -> 139 | Common.lookup (Compiler.link_aux (x::xs)) (S i) y. 140 | Proof. 141 | Admitted. 142 | 143 | Fixpoint map_aux (l : Assembly.program) : Assembly.program := 144 | match l with 145 | | [] => [] 146 | | Assembly.Jump n :: l' => Assembly.Jump (n+1) :: map_aux l' 147 | | a :: l' => a :: map_aux l' 148 | end. 149 | 150 | Lemma map_len {A B} : forall f x, @length B (map f x) = @length A x. 151 | Proof. 152 | intros. 153 | induction x; hauto. 154 | Qed. 155 | 156 | Lemma ljlr_len : forall x, length (link_ret (link_jump x)) = length x. 157 | Admitted. 158 | 159 | Lemma link_len : forall x, length (link x) = length x. 160 | Proof. 161 | intros. 162 | unfold link. 163 | cut (length (map inc_jump (link_ret (link_jump x))) = 164 | length (link_ret (link_jump x))). 165 | intros. 166 | rewrite H. 167 | apply ljlr_len. 168 | apply map_len. 169 | Qed. 170 | 171 | Theorem map_eq : forall l, map_aux l = map (inc_jump) l. 172 | Proof. 173 | intros. 174 | induction l;ssimpl. 175 | Qed. 176 | 177 | Theorem link_eq : forall l, link l = link_aux l. 178 | Proof. 179 | Admitted. 180 | 181 | Definition compile' (p : Language.state) : Assembly.state := 182 | Assembly.mkState (link (compile'' (Language.prog p))) 183 | (Language.mem p) 184 | (compile_index (Language.prog p) (Language.pc p)) 185 | (Language.ptr p). 186 | 187 | Inductive compile (p : Language.state) (q : Assembly.state) : Prop := 188 | | comp : q = compile' p -> compile p q. 189 | 190 | 191 | End Compiler. 192 | 193 | Require Import ExtrOcamlBasic. 194 | Require Import ExtrOcamlNatInt. 195 | Extraction Language OCaml. 196 | Recursive Extraction Compiler.compile'. 197 | -------------------------------------------------------------------------------- /first_attempt/Compiler.v: -------------------------------------------------------------------------------- 1 | Require Import Common. 2 | Require Import Language. 3 | Require Import Assembly. 4 | From Hammer Require Import Hammer. 5 | From Hammer Require Import Tactics. 6 | Require Import Vector. 7 | Import Vector.VectorNotations. 8 | Require Import Program.Equality. 9 | Require Import PeanoNat. 10 | Require Import Lia. 11 | Import Nat. 12 | Require Import Coq.Vectors.VectorEq. 13 | Require Coq.Program.Wf. 14 | 15 | Module Compiler. 16 | 17 | Definition lenvec {A n} (v : Vector.t A n) : nat := n. 18 | Fixpoint matched' {n} (p : Language.program n) (c : nat) : bool := 19 | match c with 20 | | 0 => false 21 | | _ => match p with 22 | | [] => c =? 1 23 | | Language.Jump :: l => matched' l (c+1) 24 | | Language.Ret :: l => matched' l (c-1) 25 | | _ :: l => matched' l c 26 | end 27 | end. 28 | 29 | 30 | Inductive matched {n} (p : Language.program n) : Prop := 31 | | match_r : matched' p 1 = true -> matched p. 32 | Fixpoint comp_len {n} (p : Language.program n) : nat := 33 | match p with 34 | | Vector.nil _ => 0 35 | | Language.PtrInc :: xs => 1 + comp_len xs 36 | | Language.PtrDec :: xs => 1 + comp_len xs 37 | | Language.Inc :: xs => 6 + comp_len xs 38 | | Language.Dec :: xs => 6 + comp_len xs 39 | | Language.Jump :: xs => 2 + comp_len xs 40 | | Language.Ret :: xs => 2 + comp_len xs 41 | | Language.Halt :: xs => 1 + comp_len xs 42 | end. 43 | 44 | Fixpoint compile'' {n} (p : Language.program n) : 45 | (Assembly.program (comp_len p)) := 46 | match p with 47 | | [] => [] 48 | | Language.PtrInc :: h => (Assembly.Add 1) :: compile'' h 49 | | Language.PtrDec :: h => (Assembly.Sub 1) :: compile'' h 50 | | Language.Inc :: h => Assembly.Swap :: 51 | Assembly.Load :: 52 | Assembly.Add 1 :: 53 | Assembly.Store :: 54 | Assembly.Zero :: 55 | Assembly.Swap :: compile'' h 56 | | Language.Dec :: h => Assembly.Swap :: 57 | Assembly.Load :: 58 | Assembly.Sub 1 :: 59 | Assembly.Store :: 60 | Assembly.Zero :: 61 | Assembly.Swap :: compile'' h 62 | 63 | | Language.Jump :: h => Assembly.Skip :: 64 | Assembly.UJUMP :: compile'' h 65 | | Language.Ret :: h => Assembly.Skip :: 66 | Assembly.URET :: compile'' h 67 | | Language.Halt :: h => Assembly.Halt :: compile'' h 68 | end. 69 | 70 | Definition compile_first {n : nat} (i : Language.instr) : Assembly.instr := 71 | match i with 72 | | Language.PtrInc => Assembly.Add 1 73 | | Language.PtrDec => Assembly.Sub 1 74 | | Language.Inc => Assembly.Swap 75 | | Language.Dec => Assembly.Swap 76 | | Language.Jump => Assembly.Skip 77 | | Language.Ret => Assembly.Skip 78 | | Language.Halt => Assembly.Halt 79 | end. 80 | 81 | Fixpoint compile_index {n} (p : Language.program n) (x : Fin.t n) 82 | : Fin.t (comp_len p). 83 | Proof. 84 | destruct x eqn:H1; rewrite (eta p). 85 | - destruct hd; apply Fin.F1. 86 | - destruct hd. 87 | + do 1 apply Fin.FS. apply compile_index. exact t0. 88 | + do 1 apply Fin.FS. apply compile_index. exact t0. 89 | + do 6 apply Fin.FS. apply compile_index. exact t0. 90 | + do 6 apply Fin.FS. apply compile_index. exact t0. 91 | + do 2 apply Fin.FS. apply compile_index. exact t0. 92 | + do 2 apply Fin.FS. apply compile_index. exact t0. 93 | + do 1 apply Fin.FS. apply compile_index. exact t0. 94 | Defined. 95 | 96 | Fixpoint nb_jump {n} (p : Assembly.program n) : nat := 97 | match p with 98 | | [] => 0 99 | | Assembly.UJUMP :: t => 1 + nb_jump t 100 | | _ :: t => nb_jump t 101 | end. 102 | 103 | Fixpoint nb_ret {n} (p : Assembly.program n) : nat := 104 | match p with 105 | | [] => 0 106 | | Assembly.URET :: t => 1 + nb_ret t 107 | | _ :: t => nb_ret t 108 | end. 109 | 110 | Fixpoint j_indexes {n} (p : Assembly.program n) 111 | : (Vector.t (Fin.t n) (nb_jump p)) := 112 | match p with 113 | | [] => [] 114 | | Assembly.UJUMP :: t => Fin.F1 :: map Fin.FS (j_indexes t) 115 | | _ :: t => map Fin.FS (j_indexes t) 116 | end. 117 | 118 | Fixpoint r_indexes {n} (p : Assembly.program n) 119 | : (Vector.t (Fin.t n) (nb_ret p)) := 120 | match p with 121 | | [] => [] 122 | | Assembly.URET :: t => Fin.F1 :: map Fin.FS (r_indexes t) 123 | | _ :: t => map Fin.FS (r_indexes t) 124 | end. 125 | 126 | 127 | 128 | Fixpoint link_jump' {n ln ln'} (p : Assembly.program n) 129 | (jumps : Vector.t (Fin.t n) ln) 130 | (rets : Vector.t (Fin.t n) ln') : 131 | Assembly.program n := 132 | match jumps with 133 | | [] => p 134 | | a :: jumps' => match rets with 135 | | [] => p 136 | | r :: rets' => link_jump' 137 | (replace p a (Assembly.Jump 138 | (Common.to_nat r))) 139 | jumps' rets' 140 | end 141 | end. 142 | 143 | 144 | Definition link_jump {n} (p : Assembly.program n) : (Assembly.program n) := 145 | link_jump' p (j_indexes p) (r_indexes p). 146 | 147 | Fixpoint nb_ljump {n} (p : Assembly.program n) : nat := 148 | match p with 149 | | [] => 0 150 | | Assembly.Jump _ :: t => 1 + nb_ljump t 151 | | _ :: t => nb_ljump t 152 | end. 153 | 154 | 155 | Fixpoint lj_indexes {n} (p : Assembly.program n) 156 | : (Vector.t (Fin.t n) (nb_ljump p)) := 157 | match p with 158 | | [] => [] 159 | | Assembly.Jump _ :: t => Fin.F1 :: map Fin.FS (lj_indexes t) 160 | | _ :: t => map Fin.FS (lj_indexes t) 161 | end. 162 | 163 | 164 | Definition make_f1 (x : nat) (H : x <> 0) : Fin.t x. 165 | Proof. 166 | destruct x eqn:H1. 167 | - auto with *. 168 | - exact Fin.F1. 169 | Defined. 170 | 171 | Fixpoint weaken_fin_t {n : nat} (f : Fin.t n) : Fin.t (S n) := 172 | match f in Fin.t n return Fin.t (S n) with 173 | | Fin.F1 => Fin.F1 174 | | Fin.FS f' => Fin.FS (weaken_fin_t f') 175 | end. 176 | 177 | Fixpoint make_indexes (n : nat) : Vector.t (Fin.t n) n := 178 | match n with 179 | | 0 => [] 180 | | S i => Fin.F1 :: map Fin.FS (make_indexes i) 181 | end. 182 | 183 | Fixpoint link_ret' {n ln ln'} (p : Assembly.program n) 184 | (jumps : Vector.t (Fin.t n) ln) 185 | (rets : Vector.t (Fin.t n) ln') : 186 | Assembly.program n := 187 | match rets with 188 | | [] => p 189 | | a :: rets' => match jumps with 190 | | [] => p 191 | | r :: jumps' => link_ret' (replace p a 192 | (Assembly.Jump (Common.to_nat r))) 193 | jumps' rets' 194 | end 195 | end. 196 | 197 | Definition inc_jump (i : Assembly.instr) : Assembly.instr := 198 | match i with 199 | | Assembly.Jump n0 => Assembly.Jump (n0 + 1) 200 | | a => a 201 | end. 202 | 203 | Definition link_ret {n} (p : Assembly.program n) : (Assembly.program n) := 204 | (link_ret' p (lj_indexes p) (r_indexes p)). 205 | 206 | Definition link {n} (l : Assembly.program n) : (Assembly.program n) := 207 | map (inc_jump) (link_ret (link_jump l)). 208 | 209 | Definition make_vector (A : Type) (x : A) (n : nat) : Vector.t A n. 210 | Proof. 211 | induction n. 212 | - apply Vector.nil. 213 | - apply Vector.cons. 214 | + exact x. 215 | + exact IHn. 216 | Defined. 217 | 218 | Lemma lm1 {n m} : forall p, n <> 0 -> comp_len (@Language.prog n m p) <> 0. 219 | Proof. 220 | intros. 221 | destruct p. 222 | cbn. 223 | destruct prog. 224 | inversion pc. 225 | unfold not. intros. 226 | destruct h; inversion H0. 227 | Qed. 228 | 229 | Definition compile' {n m} 230 | (p : Language.state (n := n)) (HA: n <> 0) (HA2 : m <> 0) : 231 | (Assembly.state (n := comp_len p.(Language.prog)) (m := m)) := 232 | let newlen := comp_len p.(Language.prog) in 233 | let newpc := compile_index p.(Language.prog) p.(Language.pc) in 234 | let f1_index := make_f1 (comp_len p.(Language.prog)) (lm1 p HA) in 235 | let f1_mem := make_f1 m HA2 in 236 | @Assembly.mkState newlen m (compile'' p.(Language.prog)) p.(Language.mem) 237 | newpc p.(Language.ptr) f1_mem. 238 | 239 | Definition compile_link {n m} (p : Language.state (n := n)) (HA : n <> 0) 240 | (HA2 : m <> 0) : 241 | (Assembly.state (n := comp_len p.(Language.prog)) (m := m)) := 242 | let cpl := compile' p HA HA2 in 243 | Assembly.mkState (comp_len (Language.prog p)) m (link cpl.(Assembly.prog)) 244 | cpl.(Assembly.mem) 245 | cpl.(Assembly.pc) cpl.(Assembly.ac) cpl.(Assembly.b). 246 | 247 | Inductive compile {n m} 248 | (p : Language.state (n := n)) 249 | (q : Assembly.state (n := comp_len p.(Language.prog)) (m := m)) : Prop := 250 | | comp_r : forall H H1, matched (p.(Language.prog)) -> q 251 | = compile_link p H H1 -> compile p q. 252 | End Compiler. 253 | 254 | Require Import ExtrOcamlBasic. 255 | Require Import ExtrOcamlNatInt. 256 | Extraction Language OCaml. 257 | Recursive Extraction Compiler.compile_link. -------------------------------------------------------------------------------- /src/Verification.v: -------------------------------------------------------------------------------- 1 | Require Import Common. 2 | Require Import Language. 3 | Require Import Assembly. 4 | Require Import Simulation. 5 | Require Import Compiler. 6 | Require Import Lia. 7 | Require Import List. 8 | Import ListNotations. 9 | 10 | From Hammer Require Import Hammer. 11 | From Hammer Require Import Tactics. 12 | 13 | Import Nat. 14 | Module Verification. 15 | 16 | Lemma lm1 : forall a p, Compiler.compile'' (a :: p) = [] -> False. 17 | Proof. 18 | intros. 19 | destruct p; 20 | destruct a; simpl; 21 | discriminate. 22 | Qed. 23 | 24 | Lemma trv : forall n, n - 0 = n. 25 | Proof. lia. Qed. 26 | 27 | Lemma comp_instr_lm : forall p q pc i, 28 | Compiler.compile'' p = q -> 29 | Common.lookup p pc i -> 30 | Common.lookup q (Compiler.compile_index p pc) 31 | (Compiler.comp_first i). 32 | Proof. 33 | induction p; destruct q; destruct i; intros; try inversion H; inversion H0; 34 | (assert (Compiler.compile'' (a :: p) = [] -> False) by apply lm1); 35 | try (exfalso; apply H6; assumption); ssimpl; 36 | try (repeat apply Common.lu2; rewrite trv; now apply IHp). 37 | Qed. 38 | 39 | Lemma comp_instr : forall prog pc i, 40 | Common.lookup prog pc i -> 41 | Common.lookup (Compiler.compile'' prog) 42 | (Compiler.compile_index prog pc) 43 | (Compiler.comp_first i). 44 | Proof. 45 | assert (forall p q pc i, 46 | Compiler.compile'' p = q -> 47 | Common.lookup p pc i -> 48 | Common.lookup q (Compiler.compile_index p pc) 49 | (Compiler.comp_first i)). 50 | apply comp_instr_lm. 51 | auto. 52 | Qed. 53 | 54 | Lemma link_stable : 55 | forall p ind i, 56 | (forall n, i <> Assembly.Jump n /\ i <> Assembly.UJUMP /\ i <> Assembly.URET) -> 57 | Common.lookup p ind i -> 58 | Common.lookup (Compiler.link p) ind i. 59 | Proof. 60 | intros. 61 | rewrite Compiler.link_eq. 62 | induction H0. 63 | - ssimpl. 64 | + exfalso. apply H1. exact 0. reflexivity. 65 | + exfalso. apply H0. exact 0. reflexivity. 66 | - assert (Common.lookup (Compiler.link_aux xs) i y). 67 | apply IHlookup. 68 | sfirstorder. 69 | apply Compiler.lookup_link_stable; try apply H; try exact 0. 70 | assumption. 71 | Qed. 72 | 73 | Lemma lm2 : forall p, Compiler.compile_index p 0 = 0. 74 | Proof. 75 | destruct p; 76 | now reflexivity. 77 | Qed. 78 | 79 | Lemma lm3 : forall p i ins, 80 | (ins <> Language.Jump /\ ins <> Language.Ret) -> 81 | Common.lookup p i ins -> 82 | Compiler.compile_index p i + 1 = 83 | Compiler.compile_index p (i + 1). 84 | Proof. 85 | intros; destruct ins; ssimpl; 86 | induction H0; ssimpl; f_equal; 87 | assert (forall p, Compiler.compile_index p 0 = 0) by apply lm2; ssimpl; 88 | rewrite trv; rewrite trv; repeat f_equal; try assumption. 89 | Qed. 90 | 91 | Theorem jump_ret_lm1 : 92 | forall p p' q_inter, Language.semantics p p' -> 93 | Language.read_instr p Language.Jump \/ 94 | Language.read_instr p Language.Ret -> 95 | Common.lookup (Language.mem p) (Language.ptr p) 0 -> 96 | q_inter = 97 | {| Assembly.prog := 98 | Assembly.prog (Compiler.compile' p); 99 | Assembly.mem := Assembly.mem (Compiler.compile' p); 100 | Assembly.pc := Assembly.pc (Compiler.compile' p) + 1; 101 | Assembly.ac := Assembly.ac (Compiler.compile' p);|} -> 102 | (Assembly.read_instr q_inter 103 | (Assembly.Jump (Compiler.compile_index (Language.prog p') 104 | (Language.pc p')))). 105 | Proof. 106 | Admitted. 107 | 108 | Lemma lm4 : forall p i ins, 109 | (ins = Language.Jump \/ ins = Language.Ret) -> 110 | Common.lookup p i ins -> 111 | Compiler.compile_index p i + 2 = 112 | Compiler.compile_index p (i + 1). 113 | Admitted. 114 | 115 | Theorem jump_ret_lm2 : 116 | forall p, Language.read_instr p Language.Jump \/ 117 | Language.read_instr p Language.Ret -> 118 | Compiler.compile_index (Language.prog p) (Language.pc p + 1) = 119 | Compiler.compile_index (Language.prog p) (Language.pc p) + 2. 120 | Admitted. 121 | 122 | Theorem th : Simulation.plus_forward_sim Compiler.compile 123 | Language.semantics Assembly.semantics. 124 | Proof. 125 | unfold Simulation.plus_forward_sim. 126 | intros. 127 | inversion H. 128 | assert (forall q2, Assembly.semantics q q2 -> Assembly.prog q2 = Assembly.prog q). 129 | sauto. 130 | destruct H0 eqn:T; exists (Assembly.mkState 131 | (Assembly.prog q) 132 | (Assembly.mem (Compiler.compile' p')) 133 | (Assembly.pc (Compiler.compile' p')) 134 | (Assembly.ac (Compiler.compile' p'))); split; qsimpl; 135 | try (apply Compiler.comp; 136 | unfold Compiler.compile'; rewrite e; reflexivity); clear H2. 137 | - apply Common.t_base. 138 | apply Assembly.add with (imm := 1). 139 | + unfold Language.read_instr, Assembly.read_instr in *. 140 | qsimpl. 141 | assert (Assembly.Add 1 = Compiler.comp_first Language.PtrInc). 142 | now reflexivity. 143 | apply link_stable. auto with *. 144 | rewrite H. 145 | apply comp_instr. 146 | assumption. 147 | + simpl. 148 | unfold Language.read_instr in r. 149 | inversion r. 150 | * destruct p'; ssimpl. 151 | destruct p; ssimpl. 152 | assert (Compiler.compile_index xs 0 = 0). 153 | apply lm2. 154 | rewrite H. 155 | reflexivity. 156 | * rewrite H; 157 | rewrite <- e; 158 | rewrite <- e0; 159 | rewrite H0; 160 | destruct p; ssimpl; f_equal; rewrite trv; rewrite trv; f_equal; 161 | (apply lm3 with (ins := Language.PtrInc)); try (split; discriminate); 162 | assumption. 163 | + simpl; reflexivity. 164 | + simpl; assumption. 165 | + simpl; inversion e1; reflexivity. 166 | - apply Common.t_base. 167 | apply Assembly.sub with (imm := 1). 168 | + unfold Language.read_instr, Assembly.read_instr in *. 169 | qsimpl. 170 | assert (Assembly.Sub 1 = Compiler.comp_first Language.PtrDec). 171 | now reflexivity. 172 | apply link_stable. auto with *. 173 | rewrite H. 174 | apply comp_instr. 175 | assumption. 176 | + simpl. 177 | unfold Language.read_instr in r. 178 | inversion r. 179 | * destruct p'; ssimpl. 180 | destruct p; ssimpl. 181 | assert (Compiler.compile_index xs 0 = 0). 182 | apply lm2. 183 | rewrite H. 184 | reflexivity. 185 | * rewrite H; 186 | rewrite <- e; 187 | rewrite <- e0; 188 | rewrite H0; 189 | destruct p; ssimpl; f_equal; rewrite trv; rewrite trv; f_equal; 190 | (apply lm3 with (ins := Language.PtrDec)); try (split; discriminate); 191 | assumption. 192 | + simpl; reflexivity. 193 | + simpl; assumption. 194 | + simpl; inversion e1; reflexivity. 195 | - apply Common.t_base. 196 | apply Assembly.add_ptr with (imm := 1). 197 | + unfold Language.read_instr, Assembly.read_instr in *. 198 | assert (Assembly.AddPtr 1 = Compiler.comp_first Language.Inc). 199 | now reflexivity. 200 | apply link_stable. auto with *. 201 | rewrite H. 202 | apply comp_instr. 203 | assumption. 204 | + simpl. 205 | unfold Language.read_instr in r. 206 | inversion r. 207 | * destruct p'; ssimpl. 208 | destruct p; ssimpl. 209 | assert (Compiler.compile_index xs 0 = 0). 210 | apply lm2. 211 | rewrite H. 212 | reflexivity. 213 | * rewrite H. 214 | rewrite <- e. 215 | rewrite <- e0. 216 | rewrite H1; destruct p; ssimpl; f_equal; rewrite trv; rewrite trv; f_equal; 217 | (apply lm3 with (ins := Language.Inc)); try (split; discriminate); 218 | assumption. 219 | + now reflexivity. 220 | + simpl. 221 | destruct p, p'; ssimpl. 222 | + ssimpl. 223 | + rewrite <- e1 in *. ssimpl. 224 | - apply Common.t_base. 225 | apply Assembly.sub_ptr with (imm := 1). 226 | + unfold Language.read_instr, Assembly.read_instr in *. 227 | assert (Assembly.SubPtr 1 = Compiler.comp_first Language.Dec). 228 | now reflexivity. 229 | apply link_stable. auto with *. 230 | rewrite H. 231 | apply comp_instr. 232 | assumption. 233 | + simpl. 234 | unfold Language.read_instr in r. 235 | inversion r. 236 | * destruct p'; ssimpl. 237 | destruct p; ssimpl. 238 | assert (Compiler.compile_index xs 0 = 0). 239 | apply lm2. 240 | rewrite H. 241 | reflexivity. 242 | * rewrite H. 243 | rewrite <- e. 244 | rewrite <- e0. 245 | rewrite H1; destruct p; ssimpl; f_equal; rewrite trv; rewrite trv; f_equal; 246 | (apply lm3 with (ins := Language.Dec)); try (split; discriminate); 247 | assumption. 248 | + now reflexivity. 249 | + simpl. 250 | destruct p, p'; ssimpl. 251 | + ssimpl. 252 | + rewrite <- e1 in *. ssimpl. 253 | - destruct p'; ssimpl. 254 | - remember ( 255 | {| Assembly.prog := Compiler.link (Compiler.compile'' (Language.prog p)); 256 | Assembly.mem := Language.mem p'; 257 | Assembly.pc := Compiler.compile_index (Language.prog p') 258 | (Language.pc p'); 259 | Assembly.ac := Language.ptr p' |}) as q'. 260 | assert (Assembly.read_instr (Compiler.compile' p) Assembly.Skip) as H1. 261 | unfold Language.read_instr in r. 262 | unfold Assembly.read_instr. 263 | unfold Compiler.compile'. ssimpl. 264 | apply link_stable. auto with *. 265 | assert (Assembly.Skip = Compiler.comp_first Language.Jump). 266 | auto. 267 | rewrite H. 268 | apply comp_instr; assumption. 269 | (* skip not taken: q_inter points to Assembly.Jump n *) 270 | pose (q_inter := 271 | {| Assembly.prog := Assembly.prog (Compiler.compile' p); 272 | Assembly.mem := Assembly.mem (Compiler.compile' p); 273 | Assembly.pc := Assembly.pc (Compiler.compile' p) + 1; 274 | Assembly.ac := Assembly.ac (Compiler.compile' p);|}). 275 | assert (Assembly.semantics (Compiler.compile' p) q_inter). 276 | apply Assembly.skipz; simpl; try assumption; try reflexivity. 277 | assert (Assembly.read_instr q_inter 278 | (Assembly.Jump (Compiler.compile_index (Language.prog p') 279 | (Language.pc p')))). 280 | apply jump_ret_lm1 with (p := p); auto with *; sfirstorder. 281 | remember (Compiler.compile_index (Language.prog p') 282 | (Language.pc p')) as n. 283 | apply Common.t_trans with (y := q_inter). 284 | sfirstorder. 285 | apply Common.t_base. 286 | apply Assembly.jump with (addr := n); sauto. 287 | - destruct p'; sauto. 288 | (* skip taken: q_inter isn't relevant:*) 289 | - apply Common.t_base. 290 | apply Assembly.skipnz; auto. 291 | assert (Assembly.Skip = Compiler.comp_first Language.Jump). 292 | auto. 293 | rewrite H. 294 | unfold Compiler.compile'. 295 | apply link_stable. sfirstorder. 296 | apply comp_instr; try auto; ssimpl. 297 | ssimpl. ssimpl. 298 | rewrite <- e2. 299 | rewrite <- e0. 300 | apply jump_ret_lm2. auto. 301 | - destruct p'; sauto. 302 | - remember ( 303 | {| Assembly.prog := Compiler.link (Compiler.compile'' (Language.prog p)); 304 | Assembly.mem := Language.mem p'; 305 | Assembly.pc := Compiler.compile_index (Language.prog p') 306 | (Language.pc p'); 307 | Assembly.ac := Language.ptr p' |}) as q'. 308 | assert (Assembly.read_instr (Compiler.compile' p) Assembly.Skip) as H1. 309 | unfold Language.read_instr in r. 310 | unfold Assembly.read_instr. 311 | unfold Compiler.compile'. ssimpl. 312 | apply link_stable. auto with *. 313 | assert (Assembly.Skip = Compiler.comp_first Language.Ret). 314 | auto. 315 | rewrite H. 316 | apply comp_instr; assumption. 317 | (* skip not taken: q_inter points to Assembly.Jump n *) 318 | pose (q_inter := 319 | {| Assembly.prog := Assembly.prog (Compiler.compile' p); 320 | Assembly.mem := Assembly.mem (Compiler.compile' p); 321 | Assembly.pc := Assembly.pc (Compiler.compile' p) + 1; 322 | Assembly.ac := Assembly.ac (Compiler.compile' p);|}). 323 | assert (Assembly.semantics (Compiler.compile' p) q_inter). 324 | apply Assembly.skipz; simpl; try assumption; try reflexivity. 325 | assert (Assembly.read_instr q_inter 326 | (Assembly.Jump (Compiler.compile_index (Language.prog p') 327 | (Language.pc p')))). 328 | apply jump_ret_lm1 with (p := p); auto with *; sfirstorder. 329 | remember (Compiler.compile_index (Language.prog p') 330 | (Language.pc p')) as n. 331 | apply Common.t_trans with (y := q_inter). 332 | sfirstorder. 333 | apply Common.t_base. 334 | apply Assembly.jump with (addr := n); sauto. 335 | - destruct p'. sauto. 336 | - apply Common.t_base. 337 | apply Assembly.skipnz; auto. 338 | assert (Assembly.Skip = Compiler.comp_first Language.Ret). 339 | auto. 340 | rewrite H. 341 | unfold Compiler.compile'. 342 | apply link_stable. sfirstorder. 343 | apply comp_instr; try auto; ssimpl. 344 | ssimpl. ssimpl. 345 | rewrite <- e2. 346 | rewrite <- e0. 347 | apply jump_ret_lm2. auto. 348 | Qed. 349 | 350 | End Verification. -------------------------------------------------------------------------------- /first_attempt/Verification.v: -------------------------------------------------------------------------------- 1 | Require Import Common. 2 | Require Import Language. 3 | Require Import Assembly. 4 | Require Import Simulation. 5 | Require Import Compiler. 6 | Require Import Lia. 7 | Require Import Vector. 8 | Import Vector.VectorNotations. 9 | Require Import Program.Equality. 10 | Require Import PeanoNat. 11 | 12 | From Hammer Require Import Hammer. 13 | From Hammer Require Import Tactics. 14 | 15 | Import Nat. 16 | Module Verification. 17 | 18 | Definition eval {n m} := @Language.semantics n m. 19 | Definition eval' {n m} := @Assembly.semantics n m. 20 | 21 | Lemma comp_len_eq : forall n m p p', eval p p' -> 22 | @Compiler.comp_len n (@Language.prog n m p) = 23 | @Compiler.comp_len n (@Language.prog n m p'). 24 | Proof. 25 | intros. 26 | assert (p.(Language.prog) = p'.(Language.prog)). 27 | + inversion H; assumption. 28 | + inversion H0. 29 | reflexivity. 30 | Defined. 31 | 32 | Definition comp_len_f 33 | {n n' m p p'} (H : eval p p') 34 | (q : @Assembly.state (@Compiler.comp_len n (@Language.prog n m p')) n') 35 | : @Assembly.state (@Compiler.comp_len n (@Language.prog n m p)) n'. 36 | Proof. 37 | assert (@Compiler.comp_len n (@Language.prog n m p) = 38 | @Compiler.comp_len n (@Language.prog n m p')). 39 | - apply comp_len_eq. 40 | assumption. 41 | - rewrite H0. 42 | exact q. 43 | Defined. 44 | 45 | Lemma match_tr {n m} : forall p p', Compiler.matched (n := n) (Language.prog p) -> 46 | eval p p' -> Compiler.matched (Language.prog p' (m := m)). 47 | Proof. 48 | intros. 49 | assert (Language.prog p = Language.prog p'). 50 | - inversion H0; assumption. 51 | - rewrite <- H1. 52 | assumption. 53 | Qed. 54 | 55 | Lemma comp_link_prog {n m} : forall p HA HA1 q, Compiler.compile_link p HA HA1 = q -> 56 | q.(Assembly.prog) = 57 | Compiler.link (@Compiler.compile'' n p.(@Language.prog n m)). 58 | Proof. 59 | intros. 60 | rewrite <- H. 61 | assert (Assembly.prog 62 | {| 63 | Assembly.prog := Compiler.link (Assembly.prog (Compiler.compile' p HA HA1)); 64 | Assembly.mem := Assembly.mem (Compiler.compile' p HA HA1); 65 | Assembly.pc := Assembly.pc (Compiler.compile' p HA HA1); 66 | Assembly.ac := Assembly.ac (Compiler.compile' p HA HA1); 67 | Assembly.b := Assembly.b (Compiler.compile' p HA HA1) 68 | |} = Compiler.link (Assembly.prog (Compiler.compile' p HA HA1))). 69 | now reflexivity. 70 | unfold Compiler.compile_link. 71 | rewrite H0. 72 | f_equal. 73 | Qed. 74 | 75 | Definition len_asm (i : Assembly.instr) : nat := 76 | match i with 77 | | Assembly.Add 1 => 1 78 | | Assembly.Sub 1 => 1 79 | | Assembly.Swap => 6 80 | | Assembly.Skip => 2 81 | | Assembly.Halt => 1 82 | | _ => 0 83 | end. 84 | 85 | Definition vec_len {A n} (v : Vector.t A n) : nat := n. 86 | 87 | Lemma read_instr_eq {n} : forall p i, 88 | (Compiler.compile'' p)[@@Compiler.compile_index n p i] 89 | = @Compiler.compile_first n p[@i]. 90 | Proof. 91 | induction i; dependent destruction p; 92 | destruct h; simpl; 93 | try (now reflexivity); 94 | try (apply IHi). 95 | Qed. 96 | 97 | Lemma link_stable : forall n p ind i, (i <> Assembly.UJUMP /\ i <> Assembly.URET) -> 98 | p[@ind] = i -> (@Compiler.link n p)[@ind] = i. 99 | Proof. 100 | Admitted. 101 | 102 | Lemma read_comp {n m} : forall p i H1 H2, Language.read_instr p i -> 103 | i <> Language.Jump -> i <> Language.Ret -> 104 | Assembly.read_instr (@Compiler.compile_link n m p H1 H2) 105 | (@Compiler.compile_first n i). 106 | Proof. 107 | unfold Compiler.compile_link. 108 | unfold Compiler.compile'. 109 | intros. 110 | ssimpl. 111 | apply Assembly.ri. 112 | unfold Assembly.read_instr'. simpl. 113 | assert ((Compiler.compile'' prog)[@Compiler.compile_index prog pc] = 114 | @Compiler.compile_first n prog[@pc]). 115 | apply read_instr_eq. 116 | apply link_stable. 117 | ssimpl. 118 | - unfold Compiler.compile_first in H4. 119 | qsimpl. 120 | - unfold Compiler.compile_first in H4. 121 | qsimpl. 122 | - qsimpl. 123 | Qed. 124 | 125 | Lemma to_nat_st {n} : forall a b, @Common.to_nat n a = Common.to_nat b -> a = b. 126 | Proof. 127 | intros. 128 | dependent induction a; dependent destruction b. 129 | reflexivity. 130 | assert (n = 0). ssimpl. exfalso. ssimpl. 131 | assert (n = 0). ssimpl. exfalso. ssimpl. 132 | f_equal. 133 | apply IHa. 134 | inversion H. 135 | reflexivity. 136 | Qed. 137 | 138 | Fixpoint weaken_fin_t {n : nat} (f : Fin.t n) : Fin.t (S n) := 139 | match f in Fin.t n return Fin.t (S n) with 140 | | Fin.F1 => Fin.F1 141 | | Fin.FS f' => Fin.FS (weaken_fin_t f') 142 | end. 143 | 144 | Definition safe_fs {n} (i : Fin.t n) (H : (Common.to_nat i) + 1 <> n) : Fin.t n. 145 | Proof. 146 | intros. 147 | destruct n. inversion i. 148 | pose (X := Fin.of_nat (Common.to_nat i + 1) (S n)). 149 | destruct X eqn:A. 150 | exact t0. 151 | sfirstorder. 152 | Defined. 153 | 154 | Lemma fs_lm : forall n i, @Common.to_nat n i <> n. 155 | Proof. 156 | intros. 157 | induction i, n. 158 | - simpl. lia. 159 | - simpl. lia. 160 | - inversion i. 161 | - sfirstorder. 162 | Qed. 163 | 164 | Lemma safe_fs_is_s {n} : forall i H, 165 | @Common.to_nat n (safe_fs i H) = (Common.to_nat i) + 1. 166 | Proof. 167 | intros. 168 | induction i, n. 169 | - simpl in H. lia. 170 | - now reflexivity. 171 | - inversion i. 172 | - hauto. 173 | Qed. 174 | 175 | Lemma not_final_lm1 {n} : forall prog pc pc', 176 | (@Common.to_nat n pc) + 1 = @Common.to_nat n pc' -> 177 | Common.to_nat (Compiler.compile_index prog pc) + 1 <> 178 | Compiler.comp_len prog. 179 | Proof. 180 | intros; 181 | assert (Common.to_nat pc' <> n) by apply fs_lm; 182 | rewrite <- H in H0; 183 | induction pc; dependent destruction pc'; dependent destruction prog. 184 | - sfirstorder. 185 | - simpl; dependent destruction pc'; dependent destruction prog; qsimpl. 186 | - simpl in H; inversion H. 187 | - ssimpl; (apply IHpc with (prog := prog) (pc' := pc'); (try assumption); 188 | try hauto). 189 | Qed. 190 | 191 | Lemma not_final {n} : forall pc prog spc, 192 | (Common.to_nat pc) + 1 = @Common.to_nat n spc -> 193 | exists sqpc, @Common.to_nat (Compiler.comp_len prog) sqpc = 194 | (Common.to_nat (@Compiler.compile_index n prog pc) + 1). 195 | Proof. 196 | intros. 197 | assert (Common.to_nat (@Compiler.compile_index n prog pc) + 1 198 | <> Compiler.comp_len prog). 199 | apply not_final_lm1 with (pc' := spc); assumption. 200 | exists (safe_fs (@Compiler.compile_index n prog pc) H0); 201 | apply safe_fs_is_s. 202 | Qed. 203 | 204 | Lemma compiled_pc : forall n prog pc pc0 i, Language.read_instr' prog pc0 = i -> 205 | Common.to_nat pc0 + 1 = Common.to_nat pc -> 206 | Common.to_nat (Compiler.compile_index prog pc0) + 207 | vec_len (Compiler.compile'' [i]) 208 | = Common.to_nat (@Compiler.compile_index n prog pc). 209 | Proof. 210 | intros. 211 | unfold vec_len. 212 | unfold Language.read_instr' in *. 213 | induction pc0; dependent destruction pc; dependent destruction prog. 214 | - sfirstorder. 215 | - ssimpl; dependent destruction pc; dependent destruction prog; ssimpl. 216 | - simpl in H. destruct i; destruct h; ssimpl. 217 | - simpl in H. destruct h; destruct i; hauto; do 6 f_equal; assumption. 218 | Qed. 219 | 220 | Theorem seq_instr {n} : forall p x x' 221 | (off : Fin.t (Compiler.comp_len ([p[@x]]))), 222 | Common.to_nat x' = 223 | Common.to_nat (@Compiler.compile_index n p x) + Common.to_nat off -> 224 | (Compiler.compile'' p)[@x'] = (Compiler.compile'' [p[@x]])[@off]. 225 | Proof. 226 | Admitted. 227 | 228 | Ltac seq_ins_n p pc' n H := 229 | intros; 230 | destruct p as [prog mem pc ptr]; 231 | unfold Compiler.compile_link in *; 232 | apply Assembly.ri; 233 | unfold Assembly.read_instr' in *; 234 | simpl in *; 235 | destruct H; try ssimpl; 236 | apply link_stable; try sdone; 237 | assert (Compiler.comp_len [prog[@pc]] <> 0) as EH2; 238 | try qauto; 239 | pose (X := Common.make_fn (Compiler.comp_len [prog[@pc]]) n EH2); 240 | assert ((Compiler.compile'' prog)[@pc'] = (Compiler.compile'' [prog[@pc]])[@X]) as EH; 241 | try (apply seq_instr); hauto. 242 | 243 | Lemma seq_inc1 {n m}: forall p q1 H H', 244 | (Language.prog p)[@Language.pc p] = Language.Inc -> 245 | Assembly.read_instr (Compiler.compile_link p H H') Assembly.Swap -> 246 | eval' (@Compiler.compile_link n m p H H') q1 -> 247 | Assembly.read_instr q1 Assembly.Load. 248 | Proof. 249 | seq_ins_n p pc0 1 H2. 250 | Qed. 251 | 252 | Lemma seq_inc2 {n m}: forall p q1 q2 H H', 253 | (Language.prog p)[@Language.pc p] = Language.Inc -> 254 | Assembly.read_instr (Compiler.compile_link p H H') Assembly.Swap -> 255 | eval' (@Compiler.compile_link n m p H H') q1 -> 256 | eval' q1 q2 -> Assembly.read_instr q1 Assembly.Load -> 257 | Assembly.read_instr q2 (Assembly.Add 1). 258 | Proof. 259 | seq_ins_n p pc0 2 H3. 260 | Qed. 261 | 262 | Lemma seq_inc3 {n m}: forall p q1 q2 q3 H H', 263 | (Language.prog p)[@Language.pc p] = Language.Inc -> 264 | Assembly.read_instr (Compiler.compile_link p H H') Assembly.Swap -> 265 | eval' (@Compiler.compile_link n m p H H') q1 -> 266 | eval' q1 q2 -> eval' q2 q3 -> Assembly.read_instr q1 Assembly.Load -> 267 | Assembly.read_instr q2 (Assembly.Add 1) -> 268 | Assembly.read_instr q3 (Assembly.Store). 269 | Proof. 270 | seq_ins_n p pc0 3 H4. 271 | Qed. 272 | Lemma seq_inc4 {n m}: forall p q1 q2 q3 q4 H H', 273 | (Language.prog p)[@Language.pc p] = Language.Inc -> 274 | Assembly.read_instr (Compiler.compile_link p H H') Assembly.Swap -> 275 | eval' (@Compiler.compile_link n m p H H') q1 -> 276 | eval' q1 q2 -> eval' q2 q3 -> eval' q3 q4 -> 277 | Assembly.read_instr q1 Assembly.Load -> 278 | Assembly.read_instr q2 (Assembly.Add 1) -> 279 | Assembly.read_instr q3 (Assembly.Store) -> 280 | Assembly.read_instr q4 (Assembly.Zero). 281 | Proof. 282 | (*seq_ins_n p pc0 4 H5.*) (*works, but too slow*) 283 | Admitted. 284 | Lemma seq_inc5 {n m}: forall p q1 q2 q3 q4 q5 H H', 285 | (Language.prog p)[@Language.pc p] = Language.Inc -> 286 | Assembly.read_instr (Compiler.compile_link p H H') Assembly.Swap -> 287 | eval' (@Compiler.compile_link n m p H H') q1 -> 288 | eval' q1 q2 -> eval' q2 q3 -> eval' q3 q4 -> eval' q4 q5 -> 289 | Assembly.read_instr q1 Assembly.Load -> 290 | Assembly.read_instr q2 (Assembly.Add 1) -> 291 | Assembly.read_instr q3 (Assembly.Store) -> 292 | Assembly.read_instr q4 (Assembly.Zero) -> 293 | Assembly.read_instr q5 (Assembly.Swap). 294 | Proof. 295 | (*seq_ins_n p pc0 5 H6.*) (*too slow*) 296 | Admitted. 297 | 298 | Theorem comp_correct {n m : nat} : 299 | forall p q, Compiler.compile p q -> 300 | forall p' (E : eval p p'), 301 | exists q', Compiler.compile p' q' /\ 302 | (Common.plus eval') q (comp_len_f (n := n) (n' := m) E q'). 303 | Proof. 304 | intros. 305 | assert (n <> 0). 306 | inversion H. assumption. 307 | assert (m <> 0). 308 | inversion H. assumption. 309 | exists (Compiler.compile_link p' H0 H1). 310 | split. 311 | - apply Compiler.comp_r with (H := H0) (H1 := H1). 312 | + assert (Compiler.matched (Language.prog p)). 313 | inversion H. 314 | assumption. 315 | apply match_tr with (p := p); assumption. 316 | + reflexivity. 317 | - (unfold comp_len_f; unfold eq_rec_r; unfold eq_rec; unfold eq_rect). 318 | ssimpl. 319 | (*Assembly.PtrInc*) 320 | + apply Common.t_base. 321 | apply Assembly.add with (n' := 1). 322 | * assert (Assembly.read_instr (@Compiler.compile_link n m {|Language.prog := prog; 323 | Language.mem := mem; 324 | Language.pc := pc0; 325 | Language.ptr := ptr0|} H2 H3) (Assembly.Add 1)). 326 | apply read_comp with (i := Language.PtrInc). ssimpl. 327 | discriminate. discriminate. 328 | assumption. 329 | * simpl. 330 | unfold Common.to_nat. 331 | apply compiled_pc with (i := Language.PtrInc); assumption. 332 | * now reflexivity. 333 | * now reflexivity. 334 | * simpl. unfold Compiler.make_f1. ssimpl. 335 | * ssimpl. 336 | (*Assembly.PtrDec*) 337 | + apply Common.t_base. 338 | apply Assembly.sub with (n' := 1). 339 | * assert (Assembly.read_instr (@Compiler.compile_link n m {|Language.prog := prog; 340 | Language.mem := mem; 341 | Language.pc := pc0; 342 | Language.ptr := ptr0|} H2 H3) (Assembly.Sub 1)). 343 | apply read_comp with (i := Language.PtrDec). ssimpl. 344 | discriminate. discriminate. 345 | assumption. 346 | * simpl. 347 | apply compiled_pc with (i := Language.PtrDec); assumption. 348 | * now reflexivity. 349 | * now reflexivity. 350 | * simpl. unfold Compiler.make_f1. ssimpl. 351 | * ssimpl. 352 | 353 | (*Assembly.Inc*) 354 | + remember (Compiler.compile_link {|Language.prog := prog;Language.mem := mem0; 355 | Language.pc := pc0; Language.ptr := ptr|} H2 H3) as q. 356 | remember (Compiler.compile_link {|Language.prog := prog;Language.mem := mem; 357 | Language.pc := pc; Language.ptr := ptr|} H0 H1) as q'. 358 | assert (prog[@pc0] = Language.Inc). ssimpl. 359 | assert (Compiler.compile'' [Language.Inc] = 360 | [Assembly.Swap; Assembly.Load; Assembly.Add 1; 361 | Assembly.Store;Assembly.Zero; Assembly.Swap]). 362 | now reflexivity. 363 | 364 | assert (Assembly.read_instr 365 | (@Compiler.compile_link n m {|Language.prog := prog; 366 | Language.mem := mem0; 367 | Language.pc := pc0; 368 | Language.ptr := ptr|} H2 H3) 369 | (Assembly.Swap)). 370 | apply read_comp with (i := Language.Inc). 371 | ssimpl. 372 | discriminate. discriminate. 373 | (**) 374 | assert (exists q1, eval' q q1). 375 | rewrite <- Heqq in *. 376 | assert (exists sqpc, 377 | @Common.to_nat (Compiler.comp_len prog) sqpc = 378 | (Common.to_nat (Assembly.pc q) + 1)). 379 | ssimpl. 380 | apply not_final with (spc := pc). 381 | assumption. 382 | destruct H7; rename x into sqpc. 383 | exists (Assembly.mkState _ _ (Assembly.prog q) (Assembly.mem q) 384 | (sqpc) (Assembly.b q) 385 | (Assembly.ac q)). 386 | ssimpl. 387 | destruct H7; rename x into q1. 388 | 389 | assert (Assembly.read_instr q1 Assembly.Load). 390 | apply seq_inc1 with (H := H2) (H' := H3); ssimpl. 391 | assert (exists q2, eval' q1 q2). 392 | admit. 393 | destruct H9; rename x into q2. 394 | assert (Assembly.read_instr q2 (Assembly.Add 1)). 395 | admit. 396 | assert (exists q3, eval' q2 q3). 397 | admit. 398 | destruct H11; rename x into q3. 399 | assert (Assembly.read_instr q3 Assembly.Store). 400 | admit. 401 | assert (exists q4, eval' q3 q4). 402 | admit. 403 | destruct H13; rename x into q4. 404 | assert (Assembly.read_instr q4 Assembly.Zero). 405 | admit. 406 | assert (exists q5, eval' q4 q5). 407 | admit. 408 | destruct H15; rename x into q5. 409 | assert (Assembly.read_instr q5 Assembly.Swap). 410 | admit. 411 | apply Common.t_trans with (y := q1). assumption. 412 | apply Common.t_trans with (y := q2). assumption. 413 | apply Common.t_trans with (y := q3). assumption. 414 | apply Common.t_trans with (y := q4). assumption. 415 | apply Common.t_trans with (y := q5). assumption. 416 | apply Common.t_base. 417 | apply Assembly.swap. 418 | * assumption. 419 | * assert (Assembly.prog q = Assembly.prog q'). 420 | ssimpl. 421 | assert (Assembly.prog q1 = Assembly.prog q). inversion H7; qsimpl. 422 | assert (Assembly.prog q2 = Assembly.prog q1). inversion H9; qsimpl. 423 | assert (Assembly.prog q3 = Assembly.prog q2). inversion H11; qsimpl. 424 | assert (Assembly.prog q4 = Assembly.prog q3). inversion H13; qsimpl. 425 | assert (Assembly.prog q5 = Assembly.prog q4). inversion H15; qsimpl. 426 | qsimpl. 427 | * admit. 428 | * admit. 429 | * admit. 430 | * admit. 431 | 432 | + (*same proof as before*) 433 | (*Assembly.Dec*) 434 | admit. 435 | + (*Assembly.Jump, resulting from two cases of Jump and two cases of Ret*) 436 | (* will require other lemmas, as we will have to consider linking: *) 437 | (*assert the existence of q1*) 438 | admit. 439 | + (*assert the existence of q1*) 440 | admit. 441 | + (*assert the existence of q1*) 442 | admit. 443 | + (*assert the existence of q1*) 444 | admit. 445 | Admitted. 446 | End Verification. --------------------------------------------------------------------------------