├── .gitignore ├── Makefile ├── README.md ├── coq ├── count_admit.sh ├── def │ ├── Debug.v │ ├── Decs.v │ ├── Exprs.v │ ├── Hints.v │ ├── Infrules.v │ ├── Nop.v │ ├── Ords.v │ ├── Postcond.v │ ├── TODO.v │ └── Validator.v ├── extract │ ├── Makefile │ ├── extract_defs.v │ └── extract_validator.v ├── proof │ ├── Adequacy.v │ ├── AdequacyLocal.v │ ├── AssnMem.v │ ├── AssnState.v │ ├── Behavior.v │ ├── GenericValues.v │ ├── Inject.v │ ├── MemAux.v │ ├── OpsemAux.v │ ├── Simulation.v │ ├── SimulationLocal.v │ ├── SimulationModule.v │ ├── SimulationNop.v │ ├── SimulationValid.v │ ├── SoundBase.v │ ├── SoundForgetMemory.v │ ├── SoundForgetMemoryCall.v │ ├── SoundForgetStack.v │ ├── SoundForgetStackCall.v │ ├── SoundImplies.v │ ├── SoundInfruleIntroGhost.v │ ├── SoundInfruleReduceMaydiff.v │ ├── SoundInfruleSubstitute.v │ ├── SoundInfruleTransitivity.v │ ├── SoundInfrules.v │ ├── SoundPostcondCall.v │ ├── SoundPostcondCmd.v │ ├── SoundPostcondCmdAdd.v │ ├── SoundPostcondPhinodes.v │ ├── SoundReduceMaydiff.v │ ├── SoundSnapshot.v │ ├── TODOProof.v │ └── ValidAux.v ├── status-admit.sh ├── status-issues.sh ├── status-proof.sh └── status.sh ├── ocaml ├── Makefile ├── TODOCAML.ml ├── addInfrule.ml ├── convertHint.ml ├── convertInfrule.ml ├── convertUtil.ml ├── coq2ml.ml ├── corehint │ └── coreHint.atd ├── domTreeUtil.ml ├── extract ├── infruleGen.ml ├── main.ml ├── postPropagation.ml ├── printer.ml ├── propagateHint.ml └── vellvm ├── script ├── attrchk.sh ├── copy-sources.sh ├── llvm-build.sh ├── llvm-install.sh ├── make-fail.sh ├── make_graph.sh ├── rsync-receive.sh ├── rsync-send.sh ├── rules.import.txt ├── rules.py ├── rules.txt └── sed.sh └── status_proof.sh /.gitignore: -------------------------------------------------------------------------------- 1 | # vim related 2 | *.swp 3 | *.swo 4 | 5 | # coq related 6 | *.vo 7 | *.v.d 8 | *.vio 9 | *.glob 10 | *.aux 11 | 12 | # tag files 13 | tags 14 | TAGS 15 | GTAGS 16 | GRTAGS 17 | GPATH 18 | 19 | .dir-locals.el 20 | _CoqProject 21 | Makefile.coq 22 | 23 | /coq/extract/*.ml 24 | /coq/extract/*.mli 25 | 26 | /.build 27 | /.build-proof 28 | /install 29 | 30 | /ocaml/_build/ 31 | /ocaml/corehint/* 32 | !/ocaml/corehint/*.atd 33 | /ocaml/main.native 34 | 35 | /results-opt 36 | 37 | lib/* 38 | crellvm-tests 39 | 40 | graph.dot 41 | graph.png 42 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | COQMODULE := Crellvm 2 | COQDEF := $(wildcard coq/def/*.v) 3 | COQEXTRACT := $(wildcard coq/extract/*.v) 4 | COQPROOF := $(filter-out $(COQEXTRACT), $(filter-out $(COQDEF), $(wildcard coq/*/*.v))) 5 | COQTHEORIES := $(COQDEF) $(COQEXTRACT) $(COQPROOF) 6 | PROOF_BUILD_DIR=.build-proof 7 | 8 | JOBS=24 9 | ROOT=`pwd` 10 | LLVM_SRCDIR=${ROOT}/lib/llvm 11 | LLVM_OBJDIR=${ROOT}/.build/llvm-obj 12 | 13 | .PHONY: all init Makefile.coq opt llvm lib def extract exec proof test clean 14 | 15 | all: llvm exec proof 16 | 17 | quick: llvm exec proof-quick 18 | 19 | init: 20 | opam install -y menhir ott.0.25 batteries biniou atdgen cppo easy-format ctypes coq.8.6 # Ott 0.25 is required for avoiding a strange build error, and Coq 8.6 is for building CompCert 2.4. 21 | git clone https://github.com/snu-sf/crellvm-llvm.git lib/llvm 22 | git clone https://github.com/snu-sf/crellvm-vellvm.git lib/vellvm 23 | git clone https://github.com/snu-sf/cereal.git lib/llvm/include/llvm/cereal 24 | git clone https://github.com/snu-sf/paco.git lib/paco 25 | $(MAKE) -C lib/vellvm init 26 | 27 | update: 28 | git -C lib/llvm pull 29 | git -C lib/vellvm pull 30 | git -C lib/llvm/include/llvm/cereal pull 31 | git -C lib/paco pull 32 | 33 | Makefile.coq: Makefile $(COQTHEORIES) 34 | (echo "-R coq $(COQMODULE)"; \ 35 | echo "-R lib/paco/src Paco"; \ 36 | echo "-R lib/vellvm/src Vellvm"; \ 37 | echo "-R lib/vellvm/lib/sflib sflib"; \ 38 | echo "-R lib/vellvm/lib/metalib metalib"; \ 39 | echo "-R lib/vellvm/lib/cpdtlib Cpdt"; \ 40 | echo "-R lib/vellvm/lib/compcert-2.4 compcert"; \ 41 | echo $(COQTHEORIES)) > _CoqProject 42 | coq_makefile -f _CoqProject -o Makefile.coq 43 | 44 | opt: 45 | cd .build/llvm-obj; cmake --build . -- opt -j$(JOBS) 46 | 47 | llvm: 48 | ./script/llvm-build.sh $(JOBS) 49 | 50 | rsync-send: 51 | $(MAKE) -C lib/vellvm src/Vellvm/syntax_base.v 52 | $(MAKE) -C lib/vellvm src/Vellvm/typing_rules.v 53 | sh script/rsync-send.sh 54 | 55 | lib: lib/paco/src lib/vellvm 56 | $(MAKE) -C lib/paco/src 57 | $(MAKE) -C lib/vellvm 58 | 59 | lib-quick: lib/paco/src lib/vellvm 60 | $(MAKE) -C lib/paco/src quick 61 | $(MAKE) -C lib/vellvm quick 62 | 63 | def: Makefile.coq lib $(COQDEF) 64 | $(MAKE) -f Makefile.coq $(patsubst %.v,%.vo,$(COQDEF)) 65 | 66 | def-quick: Makefile.coq lib-quick $(COQDEF) 67 | $(MAKE) -f Makefile.coq $(patsubst %.v,%.vio,$(COQDEF)) 68 | 69 | extract: def $(COQEXTRACT) 70 | $(MAKE) -C lib/vellvm extract 71 | $(MAKE) -C coq/extract 72 | 73 | exec: rsync-send 74 | $(MAKE) -C $(PROOF_BUILD_DIR) extract 75 | sh script/rsync-receive.sh 76 | $(MAKE) -C ocaml 77 | 78 | exec-rsync: exec 79 | 80 | proof: rsync-send 81 | $(MAKE) -C $(PROOF_BUILD_DIR) proof-inner 82 | 83 | proof-inner: def $(COQPROOF) 84 | $(MAKE) -f Makefile.coq $(patsubst %.v,%.vo,$(COQPROOF)) 85 | 86 | proof-quick: def-quick $(COQPROOF) 87 | $(MAKE) -f Makefile.coq $(patsubst %.v,%.vio,$(COQPROOF)) 88 | 89 | %.vo: Makefile.coq 90 | $(MAKE) -f Makefile.coq "$@" 91 | 92 | %.vio: Makefile.coq 93 | $(MAKE) -f Makefile.coq "$@" 94 | 95 | test-init: 96 | git clone https://github.com/snu-sf/crellvm-tests.git crellvm-tests -b pldi2018-ae 97 | git clone https://github.com/snu-sf/crellvm-tests-parallel.git crellvm-tests/crellvm-tests-parallel 98 | 99 | test-update: 100 | git -C crellvm-tests pull 101 | git -C crellvm-tests/crellvm-tests/parallel pull 102 | 103 | test: 104 | cd crellvm-tests; ./run-benchmark.sh 105 | 106 | clean: Makefile.coq 107 | $(MAKE) -f Makefile.coq clean 108 | rm -f Makefile.coq 109 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Crellvm: Verified Credible Compilation for LLVM 2 | 3 | 4 | ## Code Structure 5 | 6 | Crellvm is divided roughly into the following four parts: 7 | 8 | - LLVM in `lib/llvm` (https://github.com/snu-sf/crellvm-llvm) 9 | - Vellvm in `lib/vellvm` (https://github.com/snu-sf/crellvm-vellvm) 10 | - ERHL proof checker in [ocaml/](ocaml/) and [coq/def/](coq/def/) 11 | - Formal verification of the ERHL proof checker in [coq/proof/](coq/proof/) 12 | 13 | 14 | ### LLVM 15 | 16 | #### Proof Generation Code in Each Pass 17 | 18 | - Register promotion: [PromoteMemoryToRegister.cpp](https://github.com/snu-sf/crellvm-llvm/blob/master/lib/Transforms/Utils/PromoteMemoryToRegister.cpp) 19 | - GVN-PRE: [GVN.cpp](https://github.com/snu-sf/crellvm-llvm/blob/master/lib/Transforms/Scalar/GVN.cpp) 20 | - LICM: [LICM.cpp](https://github.com/snu-sf/crellvm-llvm/blob/master/lib/Transforms/Scalar/LICM.cpp), [LCSSA.cpp](https://github.com/snu-sf/crellvm-llvm/blob/master/lib/Transforms/Utils/LCSSA.cpp), [SSAUpdater.cpp](https://github.com/snu-sf/crellvm-llvm/blob/master/lib/Transforms/Utils/SSAUpdater.cpp) 21 | - InstCombine: files in the [InstCombine](https://github.com/snu-sf/crellvm-llvm/blob/master/lib/Transforms/InstCombine) directory 22 | 23 | Note that all our modifications are wrapped in the `crellvm::intrude()` function. 24 | 25 | #### Proof Generation Library 26 | 27 | - [.cpp files](https://github.com/snu-sf/crellvm-llvm/blob/master/lib/Crellvm) 28 | - [.h files](https://github.com/snu-sf/crellvm-llvm/blob/master/include/llvm/Crellvm) 29 | 30 | Most of those codes are automatically-generated codes for serialization. 31 | 32 | 33 | ### Validator 34 | 35 | - [def](coq/def) contains the definition of the proof checker and its dependency. 36 | + [Validator.v](coq/def/Validator.v) contains function `valid_module`, which is called from [main.ml](ocaml/main.ml). 37 | + [Postcond.v](coq/def/Postcond.v) contains a strong post-invariant generator. 38 | + [Infrules.v](coq/def/Infrules.v) contains inference rules and their semantics. 39 | - [corehint](ocaml/corehint/) contains the schema for serialization. 40 | - [main.ml](ocaml/main.ml) contains the entry point for the proof checker. It calls `valid_module` extracted from Coq. 41 | - [infruleGen.ml](ocaml/infruleGen.ml) contains the custom automation functions that find appropriate inference rules. 42 | 43 | 44 | ### Proof 45 | 46 | - [proof](coq/proof) contains the formal verification of the proof checker in Coq. 47 | + [Refinement.v](coq/proof/Refinement.v) proves behavioral refinement of two modules that pass the proof checker. 48 | + [SimulationNop.v](coq/proof/SimulationNop.v) proves behavioral refinement for two equivalent modules modulo nops. 49 | 50 | 51 | 52 | ## Development 53 | 54 | ### Requirements 55 | 56 | - Git 57 | + In Ubuntu 16.04, `sudo apt install git` 58 | 59 | - A C++ compiler, [Boost](http://www.boost.org/users/history/version_1_59_0.html), and [CMake](https://cmake.org/) 3.3.2+ 60 | + In Ubuntu 16.04, `sudo apt install gcc libboost-all-dev cmake` 61 | 62 | - [OPAM](http://opam.ocamlpro.com/): the OCaml package manager 63 | + In Ubuntu 16.04, `sudo apt install opam m4 pkg-config` 64 | + Also execute `opam init && opam update && opam switch 4.05.0` 65 | 66 | - [Scala](https://www.scala-lang.org/) 2.11.6+ for `make test` 67 | + In Ubuntu 16.04, `sudo apt install scala` 68 | 69 | 70 | ### Build 71 | 72 | You can build the proof-generating LLVM compiler and the ERHL proof checker as follows. (You can 73 | change the `JOBS` variable, whose default is 24. For example, you may want to `make JOBS=8 llvm` 74 | for systems with 8 CPUs.) 75 | 76 | - `make init`: Installs Coq and OCaml libraries, and fetches and builds dependencies. 77 | 78 | - `make update`: Updates dependencies. 79 | 80 | - `make all` (default): `make llvm exec proof` 81 | 82 | - `make quick`: `make llvm exec proof-quick` 83 | 84 | - `make llvm`: Builds LLVM in `.build/llvm-obj`. 85 | 86 | - `make opt`: Builds proof-generating LLVM IR optimizer in `.build/llvm-obj/bin/opt`. 87 | 88 | - `make exec`: Builds the ERHL proof checker in `ocaml/main.native`. 89 | 90 | - `make proof`: Compiles the Coq verification of the ERHL proof checker. 91 | 92 | - `make proof-quick`: Compiles the Coq verification with the `-quick` option (useful for interactive 93 | theorem proving). 94 | 95 | 96 | ### Execution 97 | 98 | The following executables are generated in the build process: 99 | 100 | - `.build/llvm-obj/bin/opt`: an LLVM IR optimizer, but it also generates ERHL proofs 101 | 102 | See `opt -help` for the additional options for proof generation, 103 | e.g. `-crellvm-passwhitelist=pass_name`, `-crellvm-compactjson`. 104 | 105 | - `ocaml/main.native`: the ERHL proof checker 106 | 107 | `ocaml/main.native $SRC $TGT $PROOF` validates a translation from `$SRC` to `$TGT` using `$PROOF` 108 | as the ERHL translation proof. See `ocaml/main.native -help` for more details. 109 | 110 | - Example 111 | 112 | ```sh 113 | mkdir -p temp; cd temp 114 | 115 | cp ../crellvm-tests/csmith/ll-files/00001.ll 00001.ll 116 | 117 | # opt generates proof for every mem2reg transformation 118 | ../.build/llvm-obj/bin/opt -O2 \ 119 | -crellvm-passwhitelist=mem2reg \ 120 | 00001.ll \ 121 | -o 00001.tgt.ll -S 122 | 123 | # Now source/target/proof triples are generated 124 | # ex. 00001.crc32_8bytes.74.src.bc / 00001.crc32_8bytes.74.tgt.bc / 00001.crc32_8bytes.74.hint.json 125 | # for the `crc32_8bytes` function's 74th mem2reg translation 126 | 127 | # Run the ERHL validator for a translation 128 | ../ocaml/main.native 00001.crc32_8bytes.74.src.bc 00001.crc32_8bytes.74.tgt.bc 00001.crc32_8bytes.74.hint.json 129 | 130 | # `Validation succeeded.` should be printed 131 | ``` 132 | 133 | 134 | ### Interactive Theorem Proving 135 | 136 | `make proof-quick` generates `.vio` files, which is enough for interactive theorem proving (either 137 | in CoqIDE or ProofGeneral). 138 | 139 | `coq/status-proof.sh` to grep all assumption keywords (e.g. `admit`, `Axiom`) in the Coq files. 140 | Currently it reports several admits, all of which are either (1) OCaml utility functions that are 141 | not relevant to the correctness of the proof checker, (2) functions that are implemented in OCaml 142 | for performance reasons, or (3) axioms on the external functions. 143 | 144 | 145 | ### Test 146 | 147 | - `make test-init`: Downloads benchmark programs. 148 | 149 | - `make test-update`: Updates benchmark programs. 150 | 151 | - `make test`: Performs benchmark (§7). 152 | 153 | + The benchmark programs (§7. "Benchmarks") are in the following directories: SPEC CINT2006 C 154 | Benchmarks in `crellvm-tests/speccpu2006-ll`; LLVM nightly test suite in 155 | `crellvm-tests/LNT-ll`; the five open-source C projects in `crellvm-tests/gnu-projects-ll`. 156 | 157 | 1000 randomly-generated C files (§7. "Validating Randomly Generated Programs") are in 158 | `crellvm-tests/csmith/ll-files`. 159 | 160 | FYI, `crellvm-tests/BENCHMARKS.md` explains how to extract `.ll` files from the benchmark 161 | programs. 162 | 163 | + `make test` executes `crellvm-tests/run-benchmark.sh`, which in turn executes 164 | `crellvm-tests/crellvm-tests-parallel/src/main/scala/main.scala`. `scala .../main.scala -h`: 165 | Gives a manual for the internal script: 166 | 167 | * `-j $CORE`: number of cores used for testing. 168 | * `-a $OPTION`: options to be passed to `opt`, e.g. `-O2`. 169 | * `-i $TESTDIR`: the address of the benchmark you want to compile and validate. 170 | 171 | + For example, `scala .../main.scala -j 8 -a "-O2" -i crellvm-tests/LNT-ll` means: 172 | 173 | * Execute `opt` (proof-generating LLVM IR optimizer) and `main.native` (ERHL proof checker) 174 | for each `.ll` files in `crellvm-tests/LNT-ll`. 175 | 176 | * The test result (files `report.summary`, `report.generate`, `report.validate`) will be in 177 | the `./test_result.LNT-ll.0` directory. 178 | -------------------------------------------------------------------------------- /coq/count_admit.sh: -------------------------------------------------------------------------------- 1 | echo "----------------------------------------------------------------------------------------------------------" 2 | echo "------------------------------Admitted--------------------------------------------------------------------" 3 | echo "----------------------------------------------------------------------------------------------------------" 4 | ag -G v$ -s "Admitted" --ignore=status.sh --ignore=count_admit.sh 5 | echo "----------------------------------------------------------------------------------------------------------" 6 | echo "------------------------------admit-----------------------------------------------------------------------" 7 | echo "----------------------------------------------------------------------------------------------------------" 8 | ag -G v$ -s "admit" --ignore=status.sh --ignore=count_admit.sh 9 | echo "----------------------------------------------------------------------------------------------------------" 10 | echo "------------------------------ADMIT--------------------------------------------------------------------" 11 | echo "----------------------------------------------------------------------------------------------------------" 12 | ag -G v$ -s "ADMIT" --ignore=status.sh --ignore=count_admit.sh 13 | #-s means case sensitive 14 | #http://minimul.com/ignoring-files-with-ag-silver-searcher.html 15 | 16 | #TODO move all proof in "def" to "proof", and only grep "proof". 17 | echo "----------------------------------------------------------------------------------------------------------" 18 | echo "------------------------------Other assumption keywords---------------------------------------------------" 19 | echo "----------------------------------------------------------------------------------------------------------" 20 | #https://coq.inria.fr/refman/Reference-Manual003.html#Vernacular 21 | #assumption_keyword ::= Axiom | Conjecture | Parameter | Parameters | Variable | Variables | Hypothesis | Hypotheses 22 | ag -G v$ -s "Axiom" --ignore=status.sh --ignore=count_admit.sh 23 | ag -G v$ -s "Conjecture" --ignore=status.sh --ignore=count_admit.sh 24 | ag -G v$ -s "Parameter" --ignore=status.sh --ignore=count_admit.sh 25 | ag -G v$ -s "Parameters" --ignore=status.sh --ignore=count_admit.sh 26 | ag -G v$ -s "Variable" --ignore=status.sh --ignore=count_admit.sh 27 | ag -G v$ -s "Variables" --ignore=status.sh --ignore=count_admit.sh 28 | ag -G v$ -s "Hypothesis" --ignore=status.sh --ignore=count_admit.sh 29 | ag -G v$ -s "Hypotheses" --ignore=status.sh --ignore=count_admit.sh 30 | -------------------------------------------------------------------------------- /coq/def/Debug.v: -------------------------------------------------------------------------------- 1 | Require Import Exprs. 2 | Require Import Hints. 3 | Require Import String. 4 | Require Import syntax. 5 | Import LLVMsyntax. 6 | Require Import Metatheory. 7 | 8 | Set Implicit Arguments. 9 | 10 | Definition failwith_false (msg:string) (ls:list l): bool := false. 11 | Definition failwith_None {A:Type} (msg:string) (ls:list l): option A := None. 12 | 13 | (* These will be handled explicitly during extraction, the definition is just to notify meaning. *) 14 | Definition debug_print (A: Type) (printer: A -> unit) (content: A): A := 15 | let unused := printer content in content. 16 | Definition debug_print2 (A B: Type) (printer: A -> unit) (content: A) (host: B): B := 17 | let unused := printer content in host. 18 | Definition debug_string (A: Type) (str: string) (host: A): A := host. 19 | 20 | Parameter atom_printer : atom -> unit. 21 | Parameter cmd_printer : cmd -> unit. 22 | Parameter cmd_pair_printer : (cmd * cmd) -> unit. 23 | Parameter idT_printer : IdT.t -> unit. 24 | Parameter infrule_printer : Infrule.t -> unit. 25 | Parameter assertion_printer : Assertion.t -> unit. 26 | Parameter expr_printer : Expr.t -> unit. 27 | 28 | Definition debug_print_validation_process 29 | (infrules: list Infrule.t) 30 | (inv0 inv1 inv2 inv3 inv: Assertion.t): Assertion.t := inv. 31 | 32 | Definition debug_print_auto (infrules: list Infrule.t) 33 | (inv: Assertion.t): Assertion.t := inv. 34 | -------------------------------------------------------------------------------- /coq/def/Decs.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | 4 | Require Import infrastructure. 5 | Require Import vellvm. 6 | 7 | Require Import sflib. 8 | Require Export Coqlib. 9 | Export LLVMsyntax. 10 | Export LLVMinfra. 11 | 12 | Ltac inv H := inversion H; subst; clear H. 13 | 14 | (** * Utilities *) 15 | 16 | Definition prod_dec: 17 | forall A (decA: forall x y: A, {x = y} + {~ x = y}) 18 | B (decB: forall x y: B, {x = y} + {~ x = y}) 19 | (x y: A * B), 20 | {x = y} + {~ x = y}. 21 | Proof. 22 | intros. 23 | destruct x, y. 24 | destruct (decA a a0), (decB b b0). 25 | left; subst; auto. 26 | right; intro; apply n; inv H; auto. 27 | right; intro; apply n; inv H; auto. 28 | right; intro; apply n; inv H; auto. 29 | Defined. 30 | 31 | (** * Hint Database: EqDecDb *) 32 | 33 | Create HintDb EqDecDb. 34 | 35 | Ltac eqdec_tac := decide equality; auto with EqDecDb. 36 | 37 | Hint Resolve INTEGER.dec: EqDecDb. 38 | Hint Resolve id_dec: EqDecDb. 39 | Hint Resolve typ_dec: EqDecDb. 40 | Hint Resolve value_dec: EqDecDb. 41 | Hint Resolve bop_dec: EqDecDb. 42 | Hint Resolve fbop_dec: EqDecDb. 43 | Hint Resolve list_const_dec: EqDecDb. 44 | Hint Resolve floating_point_dec: EqDecDb. 45 | Hint Resolve cmd_dec: EqDecDb. 46 | Hint Resolve inbounds_dec: EqDecDb. 47 | Hint Resolve truncop_dec: EqDecDb. 48 | Hint Resolve extop_dec: EqDecDb. 49 | Hint Resolve castop_dec: EqDecDb. 50 | Hint Resolve cond_dec: EqDecDb. 51 | Hint Resolve fcond_dec: EqDecDb. 52 | Hint Resolve varg_dec: EqDecDb. 53 | 54 | Lemma clattrs_dec : forall (c c0:clattrs), {c=c0}+{~c=c0}. 55 | Proof. 56 | destruct c as [tailc5 callconv5 attributes1 attributes2]; 57 | destruct c0 as [tailc0 callconv0 attributes0 attributes3]; 58 | destruct_wrt_type3 tailc5 tailc0; subst; try solve [done_right]; 59 | destruct_wrt_type3 callconv5 callconv0; subst; try solve [done_right]; 60 | destruct_wrt_type3 attributes1 attributes0; subst; try solve [done_right]; 61 | destruct_wrt_type3 attributes2 attributes3; 62 | subst; try solve [auto|done_right]. 63 | Defined. 64 | Hint Resolve clattrs_dec: EqDecDb. 65 | 66 | Definition align_dec : forall x y:align, {x = y} + {~ x = y} := Align.dec. 67 | Hint Resolve align_dec: EqDecDb. 68 | 69 | Definition sz_dec : forall x y:sz, {x = y} + {~ x = y} := Size.dec. 70 | Hint Resolve sz_dec: EqDecDb. 71 | 72 | (** * constant_dec *) 73 | 74 | Lemma typ_ind_gen: forall P : typ -> Prop, 75 | (forall sz5 : sz, P (typ_int sz5)) -> 76 | (forall floating_point5 : floating_point, 77 | P (typ_floatpoint floating_point5)) -> 78 | P typ_void -> 79 | P typ_label -> 80 | P typ_metadata -> 81 | (forall (sz5 : sz) (typ5 : typ), P typ5 -> P (typ_array sz5 typ5)) -> 82 | (forall typ_5 : typ, 83 | P typ_5 -> 84 | forall (l : list typ) (varg5 : varg) (IH: Forall P l), P (typ_function typ_5 l varg5)) -> 85 | (forall (l : list typ) (IH: Forall P l), P (typ_struct l)) -> 86 | (forall typ5 : typ, P typ5 -> P (typ_pointer typ5)) -> 87 | (forall id5 : id, P (typ_namedt id5)) -> forall t : typ, P t. 88 | Proof. 89 | intros; revert t; fix IH 1. 90 | intros; destruct t; try (by clear IH; eauto). 91 | - apply H4; eauto. 92 | - apply H5; eauto. 93 | induction l0; [by clear IH|]. 94 | by econs; [apply IH| apply IHl0]. 95 | - apply H6; eauto. 96 | induction l0; [by clear IH|]. 97 | by econs; [apply IH| apply IHl0]. 98 | - apply H7; eauto. 99 | Qed. 100 | 101 | Lemma const_ind_gen: 102 | forall P : const -> Prop, 103 | (forall typ5 : typ, P (const_zeroinitializer typ5)) -> 104 | (forall (sz5 : sz) (Int5 : Int), P (const_int sz5 Int5)) -> 105 | (forall (floating_point5 : floating_point) (Float5 : Float), 106 | P (const_floatpoint floating_point5 Float5)) -> 107 | (forall typ5 : typ, P (const_undef typ5)) -> 108 | (forall typ5 : typ, P (const_null typ5)) -> 109 | (forall (typ5 : typ) (l : list const) (IH: Forall P l), P (const_arr typ5 l)) -> 110 | (forall (typ5 : typ) (l : list const) (IH: Forall P l), P (const_struct typ5 l)) -> 111 | (forall (typ5 : typ) (id5 : id), P (const_gid typ5 id5)) -> 112 | (forall (truncop5 : truncop) (const5 : const), 113 | P const5 -> forall typ5 : typ, P (const_truncop truncop5 const5 typ5)) -> 114 | (forall (extop5 : extop) (const5 : const), 115 | P const5 -> forall typ5 : typ, P (const_extop extop5 const5 typ5)) -> 116 | (forall (castop5 : castop) (const5 : const), 117 | P const5 -> forall typ5 : typ, P (const_castop castop5 const5 typ5)) -> 118 | (forall (inbounds5 : inbounds) (const_5 : const), 119 | P const_5 -> forall (l : list const) (IH: Forall P l), P (const_gep inbounds5 const_5 l)) -> 120 | (forall const0 : const, 121 | P const0 -> 122 | forall const1 : const, 123 | P const1 -> 124 | forall const2 : const, 125 | P const2 -> P (const_select const0 const1 const2)) -> 126 | (forall (cond5 : cond) (const1 : const), 127 | P const1 -> 128 | forall const2 : const, P const2 -> P (const_icmp cond5 const1 const2)) -> 129 | (forall (fcond5 : fcond) (const1 : const), 130 | P const1 -> 131 | forall const2 : const, 132 | P const2 -> P (const_fcmp fcond5 const1 const2)) -> 133 | (forall const_5 : const, 134 | P const_5 -> forall (l : list const) (IH: Forall P l), P (const_extractvalue const_5 l)) -> 135 | (forall const_5 : const, 136 | P const_5 -> 137 | forall const' : const, 138 | P const' -> 139 | forall (l : list const) (IH: Forall P l), P (const_insertvalue const_5 const' l)) -> 140 | (forall (bop5 : bop) (const1 : const), 141 | P const1 -> 142 | forall const2 : const, P const2 -> P (const_bop bop5 const1 const2)) -> 143 | (forall (fbop5 : fbop) (const1 : const), 144 | P const1 -> 145 | forall const2 : const, P const2 -> P (const_fbop fbop5 const1 const2)) -> 146 | forall c : const, P c. 147 | Proof. 148 | intros; revert c; fix IH 1. 149 | intros; destruct c; try (by clear IH; eauto). 150 | - apply H4. 151 | induction l0; [by clear IH|]. 152 | by econs; [apply IH| apply IHl0]. 153 | - apply H5. 154 | induction l0; [by clear IH|]. 155 | by econs; [apply IH| apply IHl0]. 156 | - apply H7; eauto. 157 | - apply H8; eauto. 158 | - apply H9; eauto. 159 | - apply H10; eauto. 160 | induction l0; [by clear IH|]. 161 | by econs; [apply IH| apply IHl0]. 162 | - apply H11; eauto. 163 | - apply H12; eauto. 164 | - apply H13; eauto. 165 | - apply H14; eauto. 166 | induction l0; [by clear IH|]. 167 | by econs; [apply IH| apply IHl0]. 168 | - apply H15; eauto. 169 | induction l0; [by clear IH|]. 170 | by econs; [apply IH| apply IHl0]. 171 | - apply H16; eauto. 172 | - apply H17; eauto. 173 | Qed. 174 | 175 | Fixpoint const_eqb (c1 c2:const) : bool := 176 | match c1,c2 with 177 | | const_zeroinitializer t1, 178 | const_zeroinitializer t2 => typ_dec t1 t2 179 | | const_int s1 i1, 180 | const_int s2 i2 => sz_dec s1 s2 && INTEGER.dec i1 i2 181 | | const_floatpoint fp1 f1, 182 | const_floatpoint fp2 f2 => floating_point_dec fp1 fp2 && FLOAT.dec f1 f2 183 | | const_undef t1, 184 | const_undef t2 185 | | const_null t1, 186 | const_null t2 => typ_dec t1 t2 187 | | const_arr t1 lc1, 188 | const_arr t2 lc2 189 | | const_struct t1 lc1, 190 | const_struct t2 lc2 => typ_dec t1 t2 && 191 | (fix f (lc1 lc2: list const) := 192 | match lc1, lc2 with 193 | | cons hd1 tl1, cons hd2 tl2 => const_eqb hd1 hd2 && f tl1 tl2 194 | | nil, nil => true 195 | | _, _ => false 196 | end) lc1 lc2 197 | | const_gid t1 x1, 198 | const_gid t2 x2 => typ_dec t1 t2 && id_dec x1 x2 199 | | const_truncop top1 cc1 t1, 200 | const_truncop top2 cc2 t2 => truncop_dec top1 top2 && const_eqb cc1 cc2 && typ_dec t1 t2 201 | | const_extop eop1 cc1 t1, 202 | const_extop eop2 cc2 t2 => extop_dec eop1 eop2 && const_eqb cc1 cc2 && typ_dec t1 t2 203 | | const_castop cop1 cc1 t1, 204 | const_castop cop2 cc2 t2 => castop_dec cop1 cop2 && const_eqb cc1 cc2 && typ_dec t1 t2 205 | | const_gep ib1 cc1 lc1, 206 | const_gep ib2 cc2 lc2 => inbounds_dec ib1 ib2 && const_eqb cc1 cc2 && 207 | (fix f (lc1 lc2: list const) := 208 | match lc1, lc2 with 209 | | cons hd1 tl1, cons hd2 tl2 => const_eqb hd1 hd2 && f tl1 tl2 210 | | nil, nil => true 211 | | _, _ => false 212 | end) lc1 lc2 213 | | const_select cc1 cd1 ce1, 214 | const_select cc2 cd2 ce2 => const_eqb cc1 cc2 && const_eqb cd1 cd2 && const_eqb ce1 ce2 215 | | const_icmp cd1 ce1 cf1, 216 | const_icmp cd2 ce2 cf2 => cond_dec cd1 cd2 && const_eqb ce1 ce2 && const_eqb cf1 cf2 217 | | const_fcmp cd1 ce1 cf1, 218 | const_fcmp cd2 ce2 cf2 => fcond_dec cd1 cd2 && const_eqb ce1 ce2 && const_eqb cf1 cf2 219 | | const_extractvalue cc1 lc1, 220 | const_extractvalue cc2 lc2 => const_eqb cc1 cc2 && 221 | (fix f (lc1 lc2: list const) := 222 | match lc1, lc2 with 223 | | cons hd1 tl1, cons hd2 tl2 => const_eqb hd1 hd2 && f tl1 tl2 224 | | nil, nil => true 225 | | _, _ => false 226 | end) lc1 lc2 227 | | const_insertvalue cc1 cd1 lc1, 228 | const_insertvalue cc2 cd2 lc2 => const_eqb cc1 cc2 && const_eqb cd1 cd2 && 229 | (fix f (lc1 lc2: list const) := 230 | match lc1, lc2 with 231 | | cons hd1 tl1, cons hd2 tl2 => const_eqb hd1 hd2 && f tl1 tl2 232 | | nil, nil => true 233 | | _, _ => false 234 | end) lc1 lc2 235 | | const_bop b1 cc1 cd1, 236 | const_bop b2 cc2 cd2 => bop_dec b1 b2 && const_eqb cc1 cc2 && const_eqb cd1 cd2 237 | | const_fbop b1 cc1 cd1, 238 | const_fbop b2 cc2 cd2 => fbop_dec b1 b2 && const_eqb cc1 cc2 && const_eqb cd1 cd2 239 | | _,_ => false 240 | end. 241 | 242 | Ltac eqbtac := 243 | repeat 244 | (try match goal with 245 | | [H: andb ?a ?b = true |- _] => apply andb_true_iff in H; destruct H 246 | | [H: proj_sumbool (typ_dec ?a ?b) = true |- _] => destruct (typ_dec a b) 247 | | [H: proj_sumbool (sz_dec ?a ?b) = true |- _] => destruct (sz_dec a b) 248 | | [H: proj_sumbool (INTEGER.dec ?a ?b) = true |- _] => destruct (INTEGER.dec a b) 249 | | [H: proj_sumbool (floating_point_dec ?a ?b) = true |- _] => destruct (floating_point_dec a b) 250 | | [H: proj_sumbool (FLOAT.dec ?a ?b) = true |- _] => destruct (FLOAT.dec a b) 251 | | [H: proj_sumbool (id_dec ?a ?b) = true |- _] => destruct (id_dec a b) 252 | | [H: proj_sumbool (truncop_dec ?a ?b) = true |- _] => destruct (truncop_dec a b) 253 | | [H: proj_sumbool (inbounds_dec ?a ?b) = true |- _] => destruct (inbounds_dec a b) 254 | | [H: proj_sumbool (extop_dec ?a ?b) = true |- _] => destruct (extop_dec a b) 255 | | [H: proj_sumbool (castop_dec ?a ?b) = true |- _] => destruct (castop_dec a b) 256 | | [H: proj_sumbool (cond_dec ?a ?b) = true |- _] => destruct (cond_dec a b) 257 | | [H: proj_sumbool (fcond_dec ?a ?b) = true |- _] => destruct (fcond_dec a b) 258 | | [H: proj_sumbool (bop_dec ?a ?b) = true |- _] => destruct (bop_dec a b) 259 | | [H: proj_sumbool (fbop_dec ?a ?b) = true |- _] => destruct (fbop_dec a b) 260 | | [H: proj_sumbool (linkage_dec ?a ?b) = true |- _] => destruct (linkage_dec a b) 261 | | [H: proj_sumbool (gvar_spec_dec ?a ?b) = true |- _] => destruct (gvar_spec_dec a b) 262 | | [H: proj_sumbool (align_dec ?a ?b) = true |- _] => destruct (align_dec a b) 263 | | [H: proj_sumbool (fdec_dec ?a ?b) = true |- _] => destruct (fdec_dec a b) 264 | end; 265 | subst; ss; 266 | unfold sflib.is_true in *; 267 | unfold LLVMinfra.is_true in *). 268 | 269 | Lemma const_eqb_spec c1 c2 270 | (EQB: const_eqb c1 c2): 271 | c1 = c2. 272 | Proof. 273 | revert c2 EQB. 274 | induction c1 using const_ind_gen; destruct c2; ss; 275 | unfold const_eqb; fold const_eqb; i; 276 | repeat (eqbtac; try reflexivity); 277 | f_equal; eauto. 278 | - f_equal. revert l1 IH H0. induction l0; destruct l1; ss. i. 279 | inv IH. eqbtac. f_equal; eauto. 280 | - f_equal. revert l1 IH H0. induction l0; destruct l1; ss. i. 281 | inv IH. eqbtac. f_equal; eauto. 282 | - f_equal. revert l1 IH H0. induction l0; destruct l1; ss. i. 283 | inv IH. eqbtac. f_equal; eauto. 284 | - f_equal. revert l1 IH H0. induction l0; destruct l1; ss. i. 285 | inv IH. eqbtac. f_equal; eauto. 286 | - f_equal. revert l1 IH H0. induction l0; destruct l1; ss. i. 287 | inv IH. eqbtac. f_equal; eauto. 288 | Qed. 289 | 290 | Definition gvar_eqb (g1 g2:gvar) : bool := 291 | match g1,g2 with 292 | | gvar_intro x1 lk1 gs1 t1 c1 a1, 293 | gvar_intro x2 lk2 gs2 t2 c2 a2 => id_dec x1 x2 && linkage_dec lk1 lk2 && gvar_spec_dec gs1 gs2 && typ_dec t1 t2 && const_eqb c1 c2 && align_dec a1 a2 294 | | gvar_external x1 gs1 t1, 295 | gvar_external x2 gs2 t2 => id_dec x1 x2 && gvar_spec_dec gs1 gs2 && typ_dec t1 t2 296 | | _,_ => false 297 | end. 298 | 299 | Lemma gvar_eqb_spec gvar1 gvar2 300 | (EQB: gvar_eqb gvar1 gvar2): 301 | gvar1 = gvar2. 302 | Proof. 303 | destruct gvar1, gvar2; ss; eqbtac. 304 | apply const_eqb_spec in H1. subst. ss. 305 | Qed. 306 | -------------------------------------------------------------------------------- /coq/def/Nop.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Coqlib. 6 | Require Import infrastructure. 7 | Require Import Metatheory. 8 | Import LLVMsyntax. 9 | Import LLVMinfra. 10 | 11 | Require Import sflib. 12 | 13 | Require Import TODO. 14 | 15 | Set Implicit Arguments. 16 | 17 | (* Get next nop id. Each id should be unique in Function. *) 18 | (* Should manually be extracted to proper Ocaml code. *) 19 | Parameter next_nop_id: blocks -> id. 20 | 21 | Inductive nop_instr_index : Type := 22 | | phi_node : nop_instr_index 23 | | command_index : nat -> nop_instr_index 24 | . 25 | 26 | Definition nop_position : Type := l * nop_instr_index. 27 | 28 | (* Search through blocks with target label, and insert nop. *) 29 | (* Logic adding nop is commented below. *) 30 | (* If there is multiple blocks with target label, it only inserts in FIRST block. *) 31 | Definition insert_nop (target : nop_position) (bs:blocks): blocks := 32 | mapiAL (fun i stmts => 33 | let (target_l, pos_i) := target in 34 | if (eq_atom_dec i target_l) 35 | then 36 | match pos_i with 37 | | phi_node => 38 | let '(stmts_intro ps cmds t) := stmts in 39 | let cmds := insert_at 0 (insn_nop (next_nop_id bs)) cmds in 40 | (stmts_intro ps cmds t) 41 | | command_index idx => 42 | let '(stmts_intro phinodes cmds terminator) := stmts in 43 | let cmds := insert_at (idx + 1) (insn_nop (next_nop_id bs)) cmds in 44 | stmts_intro phinodes cmds terminator 45 | end 46 | else stmts 47 | ) bs. 48 | 49 | Definition insert_nops (targets:list nop_position) (bs:blocks): blocks := 50 | List.fold_left (flip insert_nop) targets bs. 51 | 52 | Definition is_nop (c: cmd) := 53 | match c with 54 | | insn_nop _ => true 55 | | _ => false 56 | end. 57 | 58 | Definition nop_cmds (cmds_src cmds_tgt:cmds) := 59 | filter (negb <*> is_nop) cmds_src = filter (negb <*> is_nop) cmds_tgt. 60 | 61 | Definition nop_blocks (blocks_src blocks_tgt:blocks): Prop := 62 | List.Forall2 63 | (fun (block_src block_tgt : block) => 64 | let (l_src, stmts_src) := block_src in 65 | let (l_tgt, stmts_tgt) := block_tgt in 66 | let '(stmts_intro phinodes_src cmds_src terminator_src) := stmts_src in 67 | let '(stmts_intro phinodes_tgt cmds_tgt terminator_tgt) := stmts_tgt in 68 | l_src = l_tgt /\ 69 | phinodes_src = phinodes_tgt /\ 70 | nop_cmds cmds_src cmds_tgt /\ 71 | terminator_src = terminator_tgt) 72 | blocks_src blocks_tgt 73 | . 74 | 75 | Inductive nop_fdef: forall (fdef_src fdef_tgt:fdef), Prop := 76 | | nop_fdef_intro 77 | header 78 | blocks_src blocks_tgt 79 | (BLOCKS: nop_blocks blocks_src blocks_tgt): 80 | nop_fdef (fdef_intro header blocks_src) (fdef_intro header blocks_tgt) 81 | . 82 | 83 | Lemma lookupAL_mapAL A B i (f:A -> B) l: 84 | lookupAL _ (map f l) i = option_map f (lookupAL _ l i). 85 | Proof. 86 | induction l; simpl in *; auto. 87 | destruct a. destruct (i == a); auto. 88 | Qed. 89 | 90 | Lemma nop_cmds_commutes 91 | x y (NOP: nop_cmds x y): 92 | nop_cmds y x. 93 | Proof. 94 | unfold nop_cmds. 95 | induction x; intros; simpl in *; auto. 96 | Qed. 97 | 98 | Lemma nop_blocks_commutes 99 | x y (NOP: nop_blocks x y): 100 | nop_blocks y x. 101 | Proof. 102 | induction NOP; ss. 103 | econs; eauto. 104 | destruct x. destruct y. destruct s0. destruct s. 105 | des. esplits; eauto. 106 | apply nop_cmds_commutes. eauto. 107 | Qed. 108 | 109 | Lemma lookupAL_mapiAL : 110 | forall (A B : Type) 111 | (i : atom) 112 | (f : atom -> A -> B) 113 | (l : AssocList A), 114 | lookupAL B (mapiAL f l) i = option_map (f i) (lookupAL A l i). 115 | Proof. 116 | induction l0; ii; simpl in *; auto. 117 | destruct a. 118 | destruct (i0 == a). 119 | - subst; auto. 120 | - auto. 121 | Qed. 122 | 123 | Lemma insert_nop_nop_cmds 124 | cmds n next_id 125 | : nop_cmds cmds (insert_at n (insn_nop next_id) cmds). 126 | Proof. 127 | revert n. 128 | induction cmds. 129 | - i. unfold insert_at. ss. 130 | rewrite util.firstn_nil. ss. 131 | rewrite util.skipn_nil. ss. 132 | - i. unfold nop_cmds in *. 133 | unfold insert_at. 134 | rewrite <- (firstn_skipn n (a::cmds0)) at 1. 135 | rewrite util.filter_app. 136 | rewrite util.filter_app. 137 | ss. 138 | Qed. 139 | 140 | Lemma insert_nop_spec1 nop_position bs: 141 | nop_blocks bs (insert_nop nop_position bs). 142 | Proof. 143 | ii. unfold insert_nop. 144 | unfold lift2_option. 145 | destruct nop_position. 146 | remember (next_nop_id bs) as next_id. 147 | clear Heqnext_id. 148 | destruct n; simpl. 149 | - unfold nop_blocks. 150 | induction bs; ss. 151 | econs; eauto. 152 | des_ifs. 153 | - unfold nop_blocks. 154 | induction bs; ss. 155 | econs; eauto. 156 | des_ifs. 157 | esplits; eauto. 158 | apply insert_nop_nop_cmds. 159 | Qed. 160 | 161 | Lemma insert_nop_spec2 id bs: 162 | nop_blocks (insert_nop id bs) bs. 163 | Proof. 164 | apply nop_blocks_commutes. 165 | apply insert_nop_spec1. 166 | Qed. 167 | -------------------------------------------------------------------------------- /coq/def/Validator.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Coqlib. 6 | Require Import infrastructure. 7 | Require Import Metatheory. 8 | Import LLVMsyntax. 9 | Import LLVMinfra. 10 | 11 | Require Import Exprs. 12 | Require Import Hints. 13 | Require Import TODO. 14 | Require Import Postcond. 15 | Require Import Infrules. 16 | 17 | Require Import Debug. 18 | 19 | Set Implicit Arguments. 20 | 21 | Parameter gen_infrules_from_insns : insn -> insn -> Assertion.t -> list Infrule.t. 22 | Parameter gen_infrules_next_inv : bool -> Assertion.t -> Assertion.t -> list Infrule.t. 23 | 24 | Fixpoint valid_cmds 25 | (m_src m_tgt:module) 26 | (src tgt:list cmd) 27 | (hint:list (list Infrule.t * Assertion.t)) 28 | (inv0:Assertion.t): option Assertion.t := 29 | match hint, src, tgt with 30 | | (infrules, inv)::hint, cmd_src::src, cmd_tgt::tgt => 31 | let (cmd_src, cmd_tgt) := 32 | (debug_print cmd_pair_printer (cmd_src, cmd_tgt)) in 33 | if (Assertion.has_false inv0) then valid_cmds m_src m_tgt src tgt hint inv else 34 | let oinv1 := 35 | match postcond_cmd cmd_src cmd_tgt inv0 with 36 | | Some inv1 => Some inv1 37 | | None => 38 | let infr := gen_infrules_from_insns (insn_cmd cmd_src) 39 | (insn_cmd cmd_tgt) 40 | inv0 in 41 | let inv0_infr := apply_infrules m_src m_tgt infr inv0 in 42 | let inv0_infr := debug_print_auto infr inv0_infr in 43 | postcond_cmd cmd_src cmd_tgt inv0_infr 44 | end 45 | in 46 | match oinv1 with 47 | | None => failwith_None "valid_cmds: postcond_cmd returned None" nil 48 | | Some inv1 => 49 | let infrules_auto := gen_infrules_next_inv true inv1 inv0 in 50 | let inv2 := apply_infrules m_src m_tgt (infrules_auto++infrules) inv1 in 51 | let inv3 := reduce_maydiff inv2 in 52 | let inv := debug_print_validation_process infrules inv0 inv1 inv2 inv3 inv in 53 | if 54 | (if Assertion.implies inv3 inv 55 | then true 56 | else 57 | (* TODO: need new print method *) 58 | let infrules := gen_infrules_next_inv false inv3 inv in 59 | let inv3_infr := apply_infrules m_src m_tgt infrules inv3 in 60 | let inv3_red := reduce_maydiff inv3_infr in 61 | let inv3_red := debug_print_auto infrules inv3_red in 62 | Assertion.implies inv3_red inv) 63 | then valid_cmds m_src m_tgt src tgt hint inv 64 | else failwith_None "valid_cmds: Assertion.implies returned false" nil 65 | end 66 | | nil, nil, nil => Some inv0 67 | | _, _, _ => None 68 | end. 69 | 70 | Definition lookup_phinodes_infrules hint_stmts l_from := 71 | match lookupAL _ hint_stmts.(ValidationHint.phinodes) l_from with 72 | | None => nil 73 | | Some infrules => infrules 74 | end. 75 | 76 | Definition valid_phinodes 77 | (hint_fdef:ValidationHint.fdef) 78 | (inv0:Assertion.t) 79 | (m_src m_tgt:module) 80 | (blocks_src blocks_tgt:blocks) 81 | (l_from l_to:l): bool := 82 | let l_from := (debug_print atom_printer l_from) in 83 | let l_to := (debug_print atom_printer l_to) in 84 | match lookupAL _ hint_fdef l_to, lookupAL _ blocks_src l_to, lookupAL _ blocks_tgt l_to with 85 | | Some hint_stmts, Some (stmts_intro phinodes_src _ _), Some (stmts_intro phinodes_tgt _ _) => 86 | let infrules := lookup_phinodes_infrules hint_stmts l_from in 87 | match postcond_phinodes l_from phinodes_src phinodes_tgt inv0 with 88 | | None => failwith_false "valid_phinodes: postcond_phinodes returned None at phinode" (l_from::l_to::nil) 89 | | Some inv1 => 90 | let infrules_auto := gen_infrules_next_inv true inv1 inv0 in 91 | let inv2 := apply_infrules m_src m_tgt (infrules_auto++infrules) inv1 in 92 | let inv3 := reduce_maydiff inv2 in 93 | let inv4 := hint_stmts.(ValidationHint.assertion_after_phinodes) in 94 | let inv4 := debug_print_validation_process infrules inv0 inv1 inv2 inv3 inv4 in 95 | if negb (Assertion.implies inv3 inv4) 96 | then 97 | let infrules := gen_infrules_next_inv false inv3 inv4 in 98 | let inv3_infr := apply_infrules m_src m_tgt infrules inv3 in 99 | let inv3_red := reduce_maydiff inv3_infr in 100 | let inv3_red := debug_print_auto infrules inv3_red in 101 | if negb (Assertion.implies inv3_red inv4) 102 | then failwith_false "valid_phinodes: Assertion.implies returned false at phinode" (l_from::l_to::nil) 103 | else true 104 | else true 105 | end 106 | | _, _, _ => false 107 | end. 108 | 109 | (* TODO: position *) 110 | Lemma const_l_dec (cl1 cl2:const * l): 111 | {cl1 = cl2} + {cl1 <> cl2}. 112 | Proof. 113 | decide equality. apply const_dec. 114 | Defined. 115 | 116 | (* TODO *) 117 | Require Import sflib. 118 | 119 | Lemma list_const_l_dec (cls1 cls2:list (const * l)): 120 | {cls1 = cls2} + {cls1 <> cls2}. 121 | Proof. 122 | revert cls2. 123 | induction cls1; destruct cls2; 124 | (try by left); 125 | (try by right). 126 | decide equality. apply const_l_dec. 127 | Defined. 128 | 129 | Definition valid_terminator 130 | (hint_fdef:ValidationHint.fdef) 131 | (inv0:Assertion.t) 132 | (m_src m_tgt:module) 133 | (blocks_src blocks_tgt:blocks) 134 | (bid:l) 135 | (src tgt:terminator): bool := 136 | if (Assertion.has_false inv0) then true else 137 | match src, tgt with 138 | | insn_return_void _, insn_return_void _ => true 139 | | insn_return _ ty_src val_src, insn_return _ ty_tgt val_tgt => 140 | if negb (typ_dec ty_src ty_tgt) 141 | then failwith_false "valid_terminator: return type not matched at block" [bid] 142 | else 143 | 144 | if negb (Assertion.inject_value 145 | inv0 146 | (ValueT.lift Tag.physical val_src) 147 | (ValueT.lift Tag.physical val_tgt)) 148 | then failwith_false "valid_terminator: inject_value of returned values failed at block" [bid] 149 | else true 150 | 151 | | insn_br _ val_src l1_src l2_src, insn_br _ val_tgt l1_tgt l2_tgt => 152 | if negb (Assertion.inject_value 153 | inv0 154 | (ValueT.lift Tag.physical val_src) 155 | (ValueT.lift Tag.physical val_tgt)) 156 | then failwith_false "valid_terminator: inject_value of branch conditions failed at block" [bid] 157 | else 158 | 159 | if negb (l_dec l1_src l1_tgt) 160 | then failwith_false "valid_terminator: labels of true branches not matched at block" [bid] 161 | else 162 | 163 | if negb (l_dec l2_src l2_tgt) 164 | then failwith_false "valid_terminator: labels of false branches not matched at block" [bid] 165 | else 166 | 167 | if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt l1_src) m_src m_tgt blocks_src blocks_tgt bid l1_src) 168 | then failwith_false "valid_terminator: valid_phinodes of true branches failed at block" [bid] 169 | else 170 | 171 | if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt l2_src) m_src m_tgt blocks_src blocks_tgt bid l2_src) 172 | then failwith_false "valid_terminator: valid_phinodes of false branches failed at block" [bid] 173 | else true 174 | 175 | | insn_br_uncond _ l_src, insn_br_uncond _ l_tgt => 176 | if negb (l_dec l_src l_tgt) 177 | then failwith_false "valid_terminator: labels of unconditional branches not matched at block" [bid] 178 | else 179 | 180 | if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt l_src) m_src m_tgt blocks_src blocks_tgt bid l_src) 181 | then failwith_false "valid_terminator: valid_phinodes of unconditional branches failed at block" [bid] 182 | else true 183 | 184 | | insn_switch _ typ_src val_src l0_src ls_src, 185 | insn_switch _ typ_tgt val_tgt l0_tgt ls_tgt => 186 | if negb (typ_dec typ_src typ_tgt) 187 | then failwith_false "valid_terminator: types of switch conditions failed at block" [bid] 188 | else 189 | 190 | if negb (Assertion.inject_value 191 | inv0 192 | (ValueT.lift Tag.physical val_src) 193 | (ValueT.lift Tag.physical val_tgt)) 194 | then failwith_false "valid_terminator: value of switch conditions failed at block" [bid] 195 | else 196 | 197 | if negb (l_dec l0_src l0_tgt) 198 | then failwith_false "valid_terminator: default labels of switch failed at block" [bid] 199 | else 200 | 201 | if negb (list_const_l_dec ls_src ls_tgt) 202 | then failwith_false "valid_terminator: other labels conditions failed at block" [bid] 203 | else 204 | 205 | if negb (forallb 206 | (fun cl => 207 | if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt cl.(snd)) m_src m_tgt blocks_src blocks_tgt bid cl.(snd)) 208 | then failwith_false "valid_terminator: valid_phinodes of switches failed at block" [bid] 209 | else true) 210 | ls_src) 211 | then failwith_false "valid_terminator: valid_phinodes failed" [bid] 212 | else 213 | 214 | if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt l0_src) m_src m_tgt blocks_src blocks_tgt bid l0_src) 215 | then failwith_false "valid_terminator: valid_phinodes failed" [bid] 216 | else true 217 | 218 | | insn_unreachable _, insn_unreachable _ => true 219 | | _, _ => failwith_false "valid_terminator: types of terminators not matched at block" [bid] 220 | end. 221 | 222 | Definition valid_stmts 223 | (hint_fdef:ValidationHint.fdef) 224 | (hint:ValidationHint.stmts) 225 | (m_src m_tgt:module) 226 | (blocks_src blocks_tgt:blocks) 227 | (bid:l) (src tgt:stmts): bool := 228 | let '(stmts_intro phinodes_src cmds_src terminator_src) := src in 229 | let '(stmts_intro phinodes_tgt cmds_tgt terminator_tgt) := tgt in 230 | match valid_cmds m_src m_tgt cmds_src cmds_tgt hint.(ValidationHint.cmds) hint.(ValidationHint.assertion_after_phinodes) with 231 | | None => failwith_false "valid_stmts: valid_cmds failed at block" [bid] 232 | | Some inv => 233 | (if (valid_terminator hint_fdef inv m_src m_tgt blocks_src blocks_tgt bid terminator_src terminator_tgt) 234 | then true 235 | else 236 | let infrules := gen_infrules_from_insns 237 | (insn_terminator terminator_src) 238 | (insn_terminator terminator_tgt) 239 | inv in 240 | let inv' := apply_infrules m_src m_tgt infrules inv in 241 | let inv' := debug_print_auto infrules inv' in 242 | (if (valid_terminator hint_fdef inv' m_src m_tgt blocks_src blocks_tgt bid terminator_src terminator_tgt) 243 | then true 244 | else failwith_false "valid_stmts: valid_terminator failed at block" [bid])) 245 | end. 246 | 247 | Definition valid_entry_stmts (src tgt:stmts) (hint:ValidationHint.stmts) 248 | (la_src la_tgt:args) (products_src products_tgt:products): bool := 249 | let '(stmts_intro phinodes_src _ _) := src in 250 | let '(stmts_intro phinodes_tgt _ _) := tgt in 251 | if negb (is_empty phinodes_src) 252 | then failwith_false "valid_entry_stmts: phinode of source not empty" nil 253 | else 254 | if negb (is_empty phinodes_tgt) 255 | then failwith_false "valid_entry_stmts: phinode of target not empty" nil 256 | else 257 | if negb (Assertion.implies (Assertion.function_entry_inv la_src la_tgt products_src products_tgt) hint.(ValidationHint.assertion_after_phinodes)) 258 | then failwith_false "valid_entry_stmts: implies fail at function entry" nil 259 | else true 260 | . 261 | 262 | Definition valid_fdef 263 | (m_src m_tgt:module) 264 | (src tgt:fdef) 265 | (hint:ValidationHint.fdef): bool := 266 | let '(fdef_intro fheader_src blocks_src) := src in 267 | let '(fdef_intro fheader_tgt blocks_tgt) := tgt in 268 | let '(module_intro layouts_src namedts_src products_src) := m_src in 269 | let '(module_intro layouts_tgt namedts_tgt products_tgt) := m_tgt in 270 | 271 | let fid_src := getFheaderID fheader_src in 272 | let fid_tgt :=getFheaderID fheader_tgt in 273 | 274 | if negb (fheader_dec fheader_src fheader_tgt) 275 | then failwith_false "valid_fdef: function headers not matched at fheaders" (fid_src::fid_tgt::nil) 276 | else 277 | match blocks_src, blocks_tgt with 278 | | (bid_src, block_src)::_, (bid_tgt, block_tgt)::_ => 279 | if negb (id_dec bid_src bid_tgt) 280 | then failwith_false "valid_fdef: entry block ids not matched at bids of" (fid_src::bid_src::bid_tgt::nil) 281 | else 282 | match lookupAL _ hint bid_src with 283 | | Some hint_stmts => 284 | if negb (valid_entry_stmts block_src block_tgt hint_stmts (getArgsOfFdef src) (getArgsOfFdef tgt) products_src products_tgt) 285 | then failwith_false "valid_fdef: valid_entry_stmts failed at" (fid_src::bid_src::nil) 286 | else true 287 | 288 | | None => failwith_false "valid_fdef: entry block hint not exist at block" (fid_src::bid_src::nil) 289 | end 290 | 291 | | _, _ => failwith_false "valid_fdef: empty source or target block" (fid_src::nil) 292 | end && 293 | forallb2AL 294 | (fun bid stmts_src stmts_tgt => 295 | match lookupAL _ hint bid with 296 | | Some hint_stmts => 297 | if negb (valid_stmts hint hint_stmts m_src m_tgt blocks_src blocks_tgt bid stmts_src stmts_tgt) 298 | then failwith_false "valid_fdef: valid_stmts failed at block" (fid_src::bid::nil) 299 | else true 300 | 301 | | None => failwith_false "valid_fdef: block hint not exist at block" (fid_src::bid::nil) 302 | end) 303 | blocks_src blocks_tgt. 304 | 305 | Definition valid_product (hint:ValidationHint.products) (m_src m_tgt:module) (src tgt:product): bool := 306 | match src, tgt with 307 | | product_gvar gvar_src, product_gvar gvar_tgt => 308 | if negb (Decs.gvar_eqb gvar_src gvar_tgt) 309 | then failwith_false "valid_product: global variables not matched" ((getGvarID gvar_src)::(getGvarID gvar_tgt)::nil) 310 | else true 311 | | product_fdec fdec_src, product_fdec fdec_tgt => 312 | if negb (fdec_dec fdec_src fdec_tgt) 313 | then failwith_false "valid_product: function declarations not matched" ((getFdecID fdec_src)::(getFdecID fdec_tgt)::nil) 314 | else true 315 | | product_fdef fdef_src, product_fdef fdef_tgt => 316 | let fid_src := getFdefID fdef_src in 317 | let fid_tgt := getFdefID fdef_tgt in 318 | if negb (id_dec fid_src fid_tgt) 319 | then failwith_false "valid_product: function ids not matched" (fid_src::fid_tgt::nil) 320 | else 321 | match lookupAL _ hint fid_src with 322 | | None => failwith_false "valid_product: hint of function not exist" [fid_src] 323 | | Some hint_fdef => 324 | if negb (valid_fdef m_src m_tgt fdef_src fdef_tgt hint_fdef) 325 | then failwith_false "valid_product: valid_fdef failed" [fid_src] 326 | else true 327 | end 328 | | _, _ => 329 | failwith_false "valid_product: source and target product types not matched" nil 330 | end. 331 | 332 | Definition valid_products (hint:ValidationHint.products) (m_src m_tgt:module) (src tgt:products): bool := 333 | list_forallb2 (valid_product hint m_src m_tgt) src tgt. 334 | 335 | Definition valid_module (hint:ValidationHint.module) (src tgt:module): option bool := 336 | let '(module_intro layouts_src namedts_src products_src) := src in 337 | let '(module_intro layouts_tgt namedts_tgt products_tgt) := tgt in 338 | if negb (layouts_dec layouts_src layouts_tgt) 339 | then Some false 340 | else 341 | if negb (namedts_dec namedts_src namedts_tgt) 342 | then Some false 343 | else 344 | if negb (valid_products hint src tgt products_src products_tgt) 345 | then failwith_None "valid_module: valid_products failed" nil 346 | else Some true. 347 | -------------------------------------------------------------------------------- /coq/extract/Makefile: -------------------------------------------------------------------------------- 1 | COQMODULE := Crellvm 2 | COQTHEORIES := extract_defs.v extract_validator.v $(wildcard ../def/*.v) 3 | 4 | all: extract 5 | echo $(COQTHEORIES) 6 | 7 | extract: Makefile.coq 8 | $(MAKE) -f Makefile.coq extract_defs.vo 9 | $(MAKE) -f Makefile.coq extract_validator.vo 10 | 11 | Makefile.coq: Makefile $(COQTHEORIES) 12 | (echo "-install none"; \ 13 | echo "-R ../../coq $(COQMODULE)"; \ 14 | echo "-R ../../lib/paco/src Paco"; \ 15 | echo "-R ../../lib/vellvm/src Vellvm"; \ 16 | echo "-R ../../lib/vellvm/lib/sflib sflib"; \ 17 | echo "-R ../../lib/vellvm/lib/metalib metalib"; \ 18 | echo "-R ../../lib/vellvm/lib/cpdtlib Cpdt"; \ 19 | echo "-R ../../lib/vellvm/lib/compcert-2.4 compcert"; \ 20 | echo $(COQTHEORIES)) > _CoqProject 21 | rm -f extract_validator.vo 22 | rm -f extract_defs.vo 23 | rm -f extract_validator.vio 24 | rm -f extract_defs.vio 25 | coq_makefile -f _CoqProject -o Makefile.coq 26 | 27 | clean: Makefile.coq 28 | make -f Makefile.coq clean 29 | rm -f Makefile.coq 30 | -------------------------------------------------------------------------------- /coq/extract/extract_defs.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import ZArith. 3 | 4 | (* Arithmetic operations that will be used for validation, e.g. add 5 | for the addition associativity-related optimization. Temporarily, the 6 | operations are defined by plus of ZArith, but later, it should be 7 | defined by operations that are used by vellvm for soundness proof. *) 8 | 9 | Module INTEGER_OPERATION. 10 | Definition add (lhs rhs : INTEGER.t) : INTEGER.t := (lhs + rhs)%Z. 11 | Definition sub (lhs rhs : INTEGER.t) : INTEGER.t := (lhs - rhs)%Z. 12 | End INTEGER_OPERATION. 13 | -------------------------------------------------------------------------------- /coq/extract/extract_validator.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import extract_defs. 3 | Require Import Ords. 4 | Require Import Validator. 5 | Require Import Infrules. 6 | Require Import Hints. 7 | Require Import Exprs. 8 | Require Import Postcond. 9 | Require Import TODO. 10 | Require Import Decs. 11 | Require Import Nop. 12 | Require Import Debug. 13 | 14 | Require Import extraction_core. 15 | Require Import extraction_dom. 16 | 17 | Require Import ExtrOcamlString. 18 | 19 | Extract Constant wrap_compare => "fun f x y -> 20 | if (x == y) 21 | then Eq 22 | else (f x y) 23 | ". 24 | 25 | Extract Constant OrdIdx.t => "int". 26 | Extract Constant OrdIdx.zero => "0". 27 | Extract Constant OrdIdx.one => "1". 28 | Extract Constant OrdIdx.two => "2". 29 | Extract Constant OrdIdx.three => "3". 30 | Extract Constant OrdIdx.four => "4". 31 | Extract Constant OrdIdx.five => "5". 32 | Extract Constant OrdIdx.six => "6". 33 | Extract Constant OrdIdx.seven => "7". 34 | Extract Constant OrdIdx.eight => "8". 35 | Extract Constant OrdIdx.nine => "9". 36 | Extract Constant OrdIdx.onezero => "10". 37 | Extract Constant OrdIdx.oneone => "11". 38 | Extract Constant OrdIdx.onetwo => "12". 39 | Extract Constant OrdIdx.onethree => "13". 40 | Extract Constant OrdIdx.onefour => "14". 41 | Extract Constant OrdIdx.onefive => "15". 42 | Extract Constant OrdIdx.onesix => "16". 43 | Extract Constant OrdIdx.oneseven => "17". 44 | Extract Constant OrdIdx.oneeight => "18". 45 | Extract Constant OrdIdx.onenine => "19". 46 | Extract Constant OrdIdx.compare => "fun x y -> 47 | let comp = x - y in 48 | if(comp < 0) then Lt 49 | else if (comp > 0) then Gt 50 | else Eq". 51 | 52 | Extract Constant INTEGER_OPERATION.add => "Coq2ml.llapint_add". 53 | Extract Constant INTEGER_OPERATION.sub => "Coq2ml.llapint_sub". 54 | 55 | Extract Constant next_nop_id => "fun _ -> ""%""^(string_of_int (Llvm2coq.get_fake_name ()))". 56 | Extract Constant failwith_false => "(fun cl ls -> let _ = Printer.debug_print ((TODOCAML.list_to_string cl)^"" ""^(String.concat "" "" ls)) in false)". 57 | Extract Constant failwith_None => "(fun cl ls -> let _ = Printer.debug_print ((TODOCAML.list_to_string cl)^"" ""^(String.concat "" "" ls)) in None)". 58 | Extract Constant debug_print_validation_process => "Printer.debug_print_validation_process". 59 | Extract Constant debug_print => "fun (printer: 'a -> unit) (x: 'a) -> let _ = printer x in x". 60 | Extract Constant debug_print2 => "fun (printer: 'a -> unit) (content: 'a) (host: 'b) -> let _ = printer content in host". 61 | Extract Constant debug_string => "Printer.debug_string". 62 | Extract Constant cmd_printer => "Printer.cmd_printer". 63 | Extract Constant cmd_pair_printer => "Printer.cmd_pair_printer". 64 | Extract Constant atom_printer => "Printer.atom_printer". 65 | Extract Constant idT_printer => "Printer.idT_printer". 66 | Extract Constant infrule_printer => "Printer.infrule_printer". 67 | Extract Constant assertion_printer => "Printer.PrintHints.assertion". 68 | Extract Constant expr_printer => "Printer.expr_printer". 69 | Extract Constant debug_print_auto => "Printer.debug_print_auto". 70 | 71 | Extract Constant gen_infrules_from_insns => 72 | "InfruleGen.gen_infrules_from_insns". 73 | Extract Constant gen_infrules_next_inv => 74 | "InfruleGen.gen_infrules_next_inv". 75 | 76 | Extract Constant sz.compare => "fun x y -> 77 | let comp = x - y in 78 | if(comp < 0) then Lt 79 | else if (comp > 0) then Gt 80 | else Eq". 81 | Extract Constant Int.compare => 82 | "fun x y -> 83 | let res = Llvm.APInt.compare_ord x y in 84 | if res < 0 then Lt else if res > 0 then Gt else Eq". 85 | 86 | Extract Constant power_sz => "(fun x -> 87 | if x = 0 then Coq_xH else Coq_xO (power_sz (x-1)))". 88 | Extract Constant signbit_of => "(fun x -> 89 | let rec positive_of_int = fun x -> 90 | if x = 1 then Coq_xH 91 | else if x mod 2 = 0 then Coq_xO (positive_of_int (x/2)) 92 | else Coq_xI (positive_of_int (x/2)) 93 | in 94 | let coq_Z_of_int = fun x -> 95 | if x = 0 then Z0 96 | else if x > 0 then Zpos (positive_of_int x) 97 | else Zneg (positive_of_int (-x)) 98 | in 99 | if x = 0 100 | then None 101 | else Some (Camlcoq.z2llapint (coq_Z_of_int x) (Zneg (power_sz (x-1))) true))". 102 | 103 | 104 | Extraction Library FMapWeakList. 105 | Extraction Library extract_defs. 106 | Extraction Library TODO. 107 | Extraction Library Ords. 108 | Extraction Library Exprs. 109 | Extraction Library Hints. 110 | Extraction Library Postcond. 111 | Extraction Library Infrules. 112 | Extraction Library Decs. 113 | Extraction Library Validator. 114 | Extraction Library Nop. 115 | Extraction Library Debug. 116 | -------------------------------------------------------------------------------- /coq/proof/Adequacy.v: -------------------------------------------------------------------------------- 1 | Require Import Program. 2 | Require Import sflib. 3 | 4 | Require Import vellvm. 5 | Require Import paco. 6 | Require Import opsem_props. 7 | Import Opsem. 8 | Import OpsemProps. 9 | 10 | Require Import GenericValues. 11 | Require Import Behavior. 12 | Require Import Simulation. 13 | 14 | Lemma strong_induction 15 | (P : nat -> Prop) 16 | (IH: forall (n:nat) (IH: forall (k:nat) (LT: (k < n)%nat), P k), P n): 17 | forall n : nat, P n. 18 | Proof. 19 | i. cut (forall (m k:nat), (k < m -> P k)%nat); [by eauto|]. 20 | induction m. 21 | - i. omega. 22 | - i. apply lt_le_S in H. inv H; eauto. 23 | Qed. 24 | 25 | Lemma adequacy 26 | conf_src conf_tgt idx st_src st_tgt 27 | (SIM: sim conf_src conf_tgt idx st_src st_tgt): 28 | behave conf_tgt st_tgt <1= behave conf_src st_src. 29 | Proof. 30 | s. revert idx st_src st_tgt SIM. pcofix CIH. i. 31 | punfold PR. inv PR. revert idx st_src SIM x0 MAT. 32 | dependent induction TAU; cycle 1. 33 | { i. destruct tr1, tr2; ss. 34 | punfold SIM. inv SIM. 35 | - pfold. econs; eauto. 36 | - exfalso. eapply final_stuck; eauto. 37 | - exploit STEP; eauto. i. des. inv H2; [|done]. 38 | exploit IHTAU; eauto. i. 39 | punfold H2. inv H2. pfold. econs; [|eauto]. 40 | rewrite <- E0_right. eapply sop_star_trans; eauto. 41 | inv H1; eauto. 42 | rewrite <- E0_right. econs 2; eauto. 43 | } 44 | intros idx. revert state. 45 | induction idx using strong_induction. i. 46 | punfold SIM. inv SIM. 47 | - pfold. econs; eauto. 48 | - inv MAT. 49 | + inv ERROR. congruence. 50 | + pfold. econs; eauto. econs 2. congruence. 51 | + exfalso. eapply final_stuck; eauto. 52 | + exfalso. eapply final_stuck; eauto. 53 | - inv MAT. 54 | + contradict PROGRESS. inv ERROR; ss. 55 | + contradict PROGRESS. ii. des. 56 | destruct (s_isFinalState conf_tgt state) eqn:X; ss. 57 | exfalso. eapply final_stuck; eauto. 58 | + exploit STEP; eauto. i. des. 59 | inv INF; [|done]. inv H1; [|done]. inv H0. 60 | * pfold. econs; eauto. 61 | * exploit IH; eauto. 62 | { punfold H2. inv H2. dependent induction TAU; eauto. 63 | destruct tr1, tr2; ss. econs 3; eauto. 64 | } 65 | i. punfold H0. inv H0. pfold. econs; [|eauto]. 66 | rewrite <- E0_right. eapply sop_star_trans; eauto. 67 | + exploit STEP; eauto. i. des. 68 | inv INF; [|done]. inv H1; [|done]. inv H0; [|done]. 69 | pfold. econs; eauto. 70 | Qed. 71 | 72 | Lemma sim_module_init 73 | module_src module_tgt main args 74 | conf_src st_src 75 | (SIM: sim_module module_src module_tgt) 76 | (SRC: s_genInitState [module_src] main args Mem.empty = ret (conf_src, st_src)) 77 | (FIT_ARGS: forall params (PARAMS: (get_params [module_src] main) = Some params), 78 | Forall2 (fun x y => (fit_gv (TD_of_module module_src) x.(fst).(fst) y = Some y)) params args) 79 | : 80 | exists conf_tgt st_tgt idx, 81 | <> /\ 82 | <>. 83 | Proof. exploit SIM; eauto. Qed. 84 | 85 | Lemma adequacy_module 86 | module_src module_tgt 87 | (SIM: sim_module module_src module_tgt) 88 | main args 89 | (FIT_ARGS: forall params (PARAMS: (get_params [module_src] main) = Some params), 90 | Forall2 (fun x y => (fit_gv (TD_of_module module_src) x.(fst).(fst) y = Some y)) params args) 91 | : 92 | behave_module module_tgt main args <1= behave_module module_src main args. 93 | Proof. 94 | s. intros obs TGT conf_src st_src INIT_SRC. 95 | exploit sim_module_init; eauto. i. des. 96 | exploit TGT; eauto. 97 | eapply adequacy. eauto. 98 | Qed. 99 | -------------------------------------------------------------------------------- /coq/proof/AssnMem.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import sflib. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Require Import vellvm. 10 | Require Import memory_sim. 11 | Require Import genericvalues_inject. 12 | Require Import memory_props. 13 | Import Opsem. 14 | 15 | Require Import Exprs. 16 | Require Import Hints. 17 | Require Import GenericValues. 18 | 19 | Set Implicit Arguments. 20 | 21 | Definition gv_diffblock_with_blocks (conf: Config) gv blocks : Prop := 22 | forall b 23 | (ING: In b (GV2blocks gv)) 24 | (INB: In b blocks), 25 | False. 26 | 27 | Definition private_block m public b : Prop := 28 | ~ public b /\ (b < m.(Mem.nextblock))%positive. 29 | 30 | Module Unary. 31 | Structure t := mk { 32 | private_parent: list mblock; 33 | mem_parent: mem; 34 | 35 | unique_parent: list mblock; 36 | 37 | nextblock: Values.block 38 | }. 39 | 40 | Inductive sem (conf:Config) (gmax:positive) (public:mblock -> Prop) (m:mem) (inv:t): Prop := 41 | | sem_intro 42 | (GLOBALS: wf_globals gmax conf.(Globals)) 43 | (WF: MemProps.wf_Mem gmax conf.(CurTargetData) m) 44 | (PRIVATE_PARENT: 45 | forall b (IN: In b inv.(private_parent)), 46 | private_block m public b) 47 | (MEM_PARENT: 48 | forall b (IN: In b inv.(private_parent)) 49 | mc o, 50 | mload_aux inv.(mem_parent) mc b o = 51 | mload_aux m mc b o) 52 | 53 | (UNIQUE_PARENT_MEM: 54 | forall mptr typ align val' 55 | (LOAD: mload conf.(CurTargetData) m mptr typ align = Some val'), 56 | gv_diffblock_with_blocks conf val' inv.(unique_parent)) 57 | (UNIQUE_PARENT_GLOBALS: 58 | forall b 59 | (IN_UNIQUE_PARENT: In b inv.(unique_parent)), 60 | (gmax < b)%positive) 61 | 62 | (UNIQUE_PRIVATE_PARENT: sublist inv.(unique_parent) inv.(private_parent)) 63 | (NEXTBLOCK: m.(Mem.nextblock) = inv.(nextblock)) 64 | (NEXTBLOCK_PARENT: (inv.(mem_parent).(Mem.nextblock) <= m.(Mem.nextblock))%positive) 65 | (* NB_PARENT is added for lift_unlift_le *) 66 | . 67 | 68 | Inductive le (lhs rhs:t): Prop := 69 | | le_intro 70 | (MEM_PARENT_EQ: lhs.(mem_parent) = rhs.(mem_parent)) 71 | (PRIVATE_PARENT_EQ: lhs.(private_parent) = rhs.(private_parent)) 72 | (UNIQUE_PARENT_EQ: lhs.(unique_parent) = rhs.(unique_parent)) 73 | (MEM_PARENT: 74 | forall b (IN: In b lhs.(private_parent)) 75 | mc o, 76 | mload_aux lhs.(mem_parent) mc b o = 77 | mload_aux rhs.(mem_parent) mc b o) 78 | (NEXTBLOCK_LE: (lhs.(nextblock) <= rhs.(nextblock))%positive) 79 | . 80 | 81 | Global Program Instance PreOrder_le: PreOrder le. 82 | Next Obligation. econs; ss. reflexivity. Qed. 83 | Next Obligation. 84 | ii. inv H. inv H0. econs. 85 | - etransitivity; eauto. 86 | - etransitivity; eauto. 87 | - etransitivity; eauto. 88 | - i. etransitivity. 89 | + eapply MEM_PARENT. eauto. 90 | + eapply MEM_PARENT0. rewrite <- PRIVATE_PARENT_EQ. ss. 91 | - etransitivity; eauto. 92 | Qed. 93 | 94 | Definition lift (m:mem) (uniqs:list mblock) (privs:list mblock) (inv:t): t := 95 | mk (privs ++ inv.(private_parent)) m 96 | (filter (fun x => existsb (Values.eq_block x) uniqs) privs ++ inv.(unique_parent)) inv.(nextblock). 97 | 98 | Definition unlift (inv0 inv1:t): t := 99 | mk inv0.(private_parent) 100 | inv0.(mem_parent) 101 | inv0.(unique_parent) 102 | inv1.(nextblock). 103 | End Unary. 104 | 105 | Module Rel. 106 | Structure t := mk { 107 | src: Unary.t; 108 | tgt: Unary.t; 109 | gmax: positive; 110 | inject: MoreMem.meminj; 111 | }. 112 | 113 | Definition public_src (inject:meminj) (b:mblock): Prop := 114 | inject b <> None. 115 | 116 | Definition public_tgt (inject:meminj) (b:mblock): Prop := 117 | exists b_src offset, inject b_src = Some (b, offset). 118 | 119 | Inductive sem (conf_src conf_tgt:Config) (mem_src mem_tgt:mem) (inv:t): Prop := 120 | | sem_intro 121 | (SRC: Unary.sem conf_src inv.(gmax) (public_src inv.(inject)) mem_src inv.(src)) 122 | (TGT: Unary.sem conf_tgt inv.(gmax) (public_tgt inv.(inject)) mem_tgt inv.(tgt)) 123 | (TGT_NOUNIQ: inv.(tgt).(Unary.unique_parent) = []) 124 | (INJECT: MoreMem.mem_inj inv.(inject) mem_src mem_tgt) 125 | (WF: genericvalues_inject.wf_sb_mi inv.(gmax) inv.(inject) mem_src mem_tgt) 126 | (FUNTABLE: ftable_simulation inv.(inject) conf_src.(FunTable) conf_tgt.(FunTable)) 127 | . 128 | 129 | (* Inspired from Compcert's inject_separated *) 130 | Inductive frozen (f_old f_new: MoreMem.meminj) (bound_src bound_tgt: mblock): Prop := 131 | | frozen_intro 132 | (NEW_IMPLIES_OUTSIDE: 133 | forall b_src b_tgt delta 134 | (NEW: f_old b_src = None /\ f_new b_src = Some(b_tgt, delta)), 135 | <> /\ <>) 136 | . 137 | 138 | (* TODO: not sure if inject_incr is enough. 139 | * cf. https://github.com/snu-sf/crellvm/blob/before_refact/coq/hint/hint_sem.v#L284 140 | *) 141 | Inductive le (lhs rhs:t): Prop := 142 | | le_intro 143 | (SRC: Unary.le lhs.(src) rhs.(src)) 144 | (TGT: Unary.le lhs.(tgt) rhs.(tgt)) 145 | (GMAX: lhs.(gmax) = rhs.(gmax)) 146 | (INJECT: inject_incr lhs.(inject) rhs.(inject)) 147 | (FROZEN: frozen lhs.(inject) rhs.(inject) 148 | lhs.(src).(Unary.mem_parent).(Mem.nextblock) 149 | lhs.(tgt).(Unary.mem_parent).(Mem.nextblock)) 150 | . 151 | 152 | Global Program Instance PreOrder_le: PreOrder le. 153 | Next Obligation. 154 | econs; ss; try reflexivity. 155 | econs; eauto. ii. des. clarify. 156 | Qed. 157 | Next Obligation. 158 | ii. inv H. inv H0. econs. 159 | - etransitivity; eauto. 160 | - etransitivity; eauto. 161 | - etransitivity; eauto. 162 | - eapply inject_incr_trans; eauto. 163 | - 164 | econs; eauto. 165 | ii. des. 166 | destruct (inject y b_src) eqn:T. 167 | + destruct p. 168 | inv FROZEN. 169 | hexploit NEW_IMPLIES_OUTSIDE; eauto; []; i; des. 170 | split; ss. 171 | exploit INJECT0; eauto; []; i; des. clarify. 172 | + inv FROZEN0. 173 | hexploit NEW_IMPLIES_OUTSIDE; eauto; []; i; des. 174 | inv SRC. inv TGT. rewrite MEM_PARENT_EQ. rewrite MEM_PARENT_EQ0. 175 | split; ss. 176 | Qed. 177 | 178 | Lemma frozen_preserves_src 179 | inv0 inv1 180 | (INJECT: inject_incr inv0.(inject) inv1.(inject)) 181 | bound_src bound_tgt 182 | (FROZEN: frozen inv0.(inject) inv1.(inject) bound_src bound_tgt) 183 | (* Above two can be driven from both "le inv0 inv1" && "le inv0 (unlift inv0 inv1)" *) 184 | (* in actual proof, the latter one is given as premise *) 185 | (* IDK if this is also true for former one *) 186 | (* Anyhow, I intentionally choose smaller premise that can serve for both cases *) 187 | b_src 188 | (INSIDE: (b_src < bound_src)%positive) 189 | : 190 | <> 191 | . 192 | Proof. 193 | inv FROZEN. 194 | destruct (inject inv0 b_src) eqn:T0; ss; 195 | destruct (inject inv1 b_src) eqn:T1; ss. 196 | - destruct p, p0; ss. 197 | exploit INJECT; eauto; []; i; des. 198 | clarify. 199 | - destruct p; ss. 200 | exploit INJECT; eauto; []; i; des. 201 | clarify. 202 | - destruct p; ss. 203 | exploit NEW_IMPLIES_OUTSIDE; eauto; []; i; des. 204 | exfalso. 205 | eapply TODOProof.Pos_lt_le_irrefl; revgoals; eauto. 206 | Qed. 207 | 208 | Lemma frozen_preserves_tgt 209 | inv0 inv1 210 | (INJECT: inject_incr inv0.(inject) inv1.(inject)) 211 | bound_src bound_tgt 212 | (FROZEN: frozen inv0.(inject) inv1.(inject) bound_src bound_tgt) 213 | b_tgt 214 | (INSIDE: (b_tgt < bound_tgt)%positive) 215 | : 216 | <> >> 218 | . 219 | Proof. 220 | inv FROZEN. 221 | ii. 222 | destruct (inject inv0 b_src) eqn:T; ss. 223 | - destruct p; ss. 224 | exploit INJECT; eauto; []; i; des. 225 | clarify. 226 | - exfalso. 227 | exploit NEW_IMPLIES_OUTSIDE; eauto; []; i; des. 228 | eapply TODOProof.Pos_lt_le_irrefl; revgoals; eauto. 229 | Qed. 230 | 231 | Lemma frozen_shortened 232 | f_old f_new 233 | bd_src0 bd_tgt0 234 | (FROZEN: frozen f_old f_new bd_src0 bd_tgt0) 235 | bd_src1 bd_tgt1 236 | (SHORT_SRC: (bd_src1 <= bd_src0)%positive) 237 | (SHORT_TGT: (bd_tgt1 <= bd_tgt0)%positive) 238 | : 239 | <> 240 | . 241 | Proof. 242 | inv FROZEN. 243 | econs; eauto. 244 | ii. des. 245 | hexploit NEW_IMPLIES_OUTSIDE; eauto; []; i; des. clear NEW_IMPLIES_OUTSIDE. 246 | split; ss. 247 | - red. etransitivity; eauto. 248 | - red. etransitivity; eauto. 249 | Qed. 250 | 251 | Definition lift 252 | (m_src m_tgt:mem) 253 | (uniqs_src uniqs_tgt:list mblock) 254 | (privs_src privs_tgt:list mblock) 255 | (inv:t): t := 256 | mk (Unary.lift m_src uniqs_src privs_src inv.(src)) 257 | (Unary.lift m_tgt uniqs_tgt privs_tgt inv.(tgt)) 258 | inv.(gmax) 259 | inv.(inject). 260 | 261 | (* TODO: le_public? *) 262 | Definition unlift (inv0 inv1:t): t := 263 | mk 264 | (Unary.unlift inv0.(src) inv1.(src)) 265 | (Unary.unlift inv0.(tgt) inv1.(tgt)) 266 | inv0.(gmax) inv1.(inject). 267 | 268 | End Rel. 269 | -------------------------------------------------------------------------------- /coq/proof/Behavior.v: -------------------------------------------------------------------------------- 1 | Require Import sflib. 2 | 3 | Require Import vellvm. 4 | Require Import paco. 5 | 6 | Require Import GenericValues. 7 | Import Opsem. 8 | 9 | 10 | (* TODO: obs_done should have the return value. *) 11 | CoInductive observation : Type := 12 | | obs_done (retval: val) 13 | | obs_inftau 14 | | obs_event (evt:event) (obs:observation) 15 | . 16 | 17 | Definition trace_observation (tr:trace) (obs:observation) : observation := 18 | fold_right obs_event obs tr. 19 | 20 | Inductive behmatch 21 | (conf:Config) 22 | (behave: forall (st:State) (obs:observation), Prop): 23 | forall (st:State) (obs:observation), Prop := 24 | | beh_error 25 | s obs 26 | (ERROR: error_state conf s): 27 | behmatch conf behave s obs 28 | | beh_done 29 | s retval 30 | (FINAL: s_isFinalState conf s = Some retval): 31 | behmatch conf behave s (obs_done retval) 32 | | beh_inftau 33 | s s' 34 | (ST: sInsn conf s s' E0) 35 | (INF: behave s' obs_inftau): 36 | behmatch conf behave s obs_inftau 37 | | beh_evt 38 | s s' tr obs 39 | (ST: sInsn conf s s' tr) 40 | (TR: tr <> E0) 41 | (INF: behave s' obs): 42 | behmatch conf behave s (trace_observation tr obs) 43 | . 44 | Hint Constructors behmatch. 45 | 46 | Inductive behave_ conf behave s obs: Prop := 47 | | behave_intro 48 | s' 49 | (TAU: sop_star conf s s' E0) 50 | (MAT: behmatch conf behave s' obs) 51 | . 52 | Hint Constructors behave_. 53 | 54 | Definition behave conf : _ -> _ -> Prop := paco2 (behave_ conf) bot2. 55 | 56 | Lemma behave_mon conf: monotone2 (@behave_ conf). 57 | Proof. 58 | ii; destruct IN; destruct MAT; eauto. 59 | Qed. 60 | Hint Resolve behave_mon: paco. 61 | 62 | Definition behave_module module main args obs: Prop := 63 | forall conf st (INIT: s_genInitState [module] main args Mem.empty = Some (conf, st)), 64 | behave conf st obs. 65 | -------------------------------------------------------------------------------- /coq/proof/GenericValues.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Require Import vellvm. 10 | Require Import TODO. 11 | Require Import TODOProof. 12 | 13 | Import Opsem. 14 | Require Import sflib. 15 | 16 | Module GVs. 17 | Definition lessdef (v1 v2:GenericValue): Prop := 18 | list_forall2 19 | (fun vc1 vc2 => 20 | Val.lessdef vc1.(fst) vc2.(fst) /\ 21 | vc1.(snd) = vc2.(snd) /\ 22 | (vc1.(fst) = Vundef -> vc2.(fst) <> Vundef -> Val.has_chunkb vc2.(fst) vc2.(snd))) 23 | v1 v2. 24 | 25 | Definition inject (alpha:meminj) (v1 v2:GenericValue): Prop := 26 | list_forall2 27 | (fun vc1 vc2 => 28 | val_inject alpha vc1.(fst) vc2.(fst) /\ 29 | vc1.(snd) = vc2.(snd)) 30 | v1 v2. 31 | 32 | Lemma lessdef_refl x: 33 | <>. 34 | Proof. 35 | induction x; ii; ss; des. 36 | { econs. } 37 | econs. 38 | - esplits; eauto. i. ss. 39 | - apply IHx. 40 | Qed. 41 | 42 | Lemma lessdef_trans 43 | x y z 44 | (LD01: lessdef x y) 45 | (LD12: lessdef y z) 46 | : 47 | <> 48 | . 49 | Proof. 50 | ginduction LD01; ii; ss. 51 | inv LD12. des. destruct b0, b1, a1; ss. clarify. 52 | econs; eauto. 53 | - ss. splits; ss. 54 | + eapply Val.lessdef_trans; eauto. 55 | + i; clarify. 56 | inv H2. 57 | * eapply H5; eauto. 58 | * eapply H1; eauto. 59 | - eapply IHLD01; eauto. 60 | Qed. 61 | 62 | Lemma lessdef_inject_compose_single mij a b c 63 | (LD: Val.lessdef a b) 64 | (INJECT: memory_sim.MoreMem.val_inject mij b c): 65 | << INJECT: memory_sim.MoreMem.val_inject mij a c >>. 66 | Proof. 67 | inv LD; inv INJECT; ss; try (econs; eauto; fail). 68 | Qed. 69 | 70 | Lemma inject_lessdef_compose_single mij a b c 71 | (INJECT: memory_sim.MoreMem.val_inject mij a b) 72 | (LD: Val.lessdef b c): 73 | << INJECT: memory_sim.MoreMem.val_inject mij a c >>. 74 | Proof. 75 | inv LD; inv INJECT; ss; try (econs; eauto; fail). 76 | Qed. 77 | 78 | Lemma lessdef_inject_compose mij a b c 79 | (LD: lessdef a b) 80 | (INJECT: genericvalues_inject.gv_inject mij b c): 81 | << INJECT: genericvalues_inject.gv_inject mij a c >>. 82 | Proof. 83 | red. 84 | generalize dependent a. 85 | generalize dependent c. 86 | induction b; ii; ss. 87 | { inv LD. destruct c; ss. } 88 | inv INJECT. 89 | inv LD; ss. des. destruct a1; ss. clarify. 90 | econs; eauto. 91 | { i. clarify. inv H4; ss. 92 | - eapply CHUNK; eauto. 93 | - destruct (classic (v1 = Vundef)). 94 | + clarify. 95 | inv H1. eapply CHUNK; eauto. 96 | + inv H1; try eapply H2; ss. 97 | } 98 | eapply lessdef_inject_compose_single; eauto. 99 | Qed. 100 | 101 | Lemma inject_lessdef_compose mij a b c 102 | (INJECT: genericvalues_inject.gv_inject mij a b) 103 | (LD: lessdef b c): 104 | << INJECT: genericvalues_inject.gv_inject mij a c >>. 105 | Proof. 106 | red. 107 | generalize dependent a. 108 | generalize dependent c. 109 | induction b; ii; ss. 110 | { inv LD. destruct a; ss. } 111 | inv INJECT. 112 | inv LD; ss. des. destruct b1; ss. clarify. 113 | econs; eauto. 114 | - i. clarify. 115 | destruct (classic (v2 = Vundef)). 116 | + clarify. apply H4; ss. 117 | + inv H1; ss. 118 | apply CHUNK; ss. 119 | - eapply inject_lessdef_compose_single; eauto. 120 | Qed. 121 | End GVs. 122 | 123 | 124 | (* TODO: position *) 125 | Inductive error_state conf st: Prop := 126 | | error_state_intro 127 | (STUCK: stuck_state conf st) 128 | (NFINAL: s_isFinalState conf st = None) 129 | . 130 | 131 | Lemma final_stuck 132 | conf st retval 133 | (FINAL: s_isFinalState conf st = Some retval): 134 | stuck_state conf st. 135 | Proof. 136 | ii. des. destruct st, EC0. ss. 137 | destruct CurCmds0, Terminator0, ECS0; ss. 138 | - inv H. 139 | - inv H. 140 | Qed. 141 | 142 | Lemma nerror_stuck_final 143 | conf st 144 | (NERROR: ~ error_state conf st) 145 | (STUCK: stuck_state conf st): 146 | exists retval, s_isFinalState conf st = Some retval. 147 | Proof. 148 | destruct (s_isFinalState conf st) eqn:X; eauto. 149 | exfalso. apply NERROR. econs; ss. 150 | Qed. 151 | 152 | Lemma nerror_nfinal_nstuck 153 | conf st1 154 | (NERROR: ~ error_state conf st1) 155 | (NFINAL: s_isFinalState conf st1 = None): 156 | exists st2 e, sInsn conf st1 st2 e. 157 | Proof. 158 | destruct (classic (stuck_state conf st1)). 159 | - contradict NERROR. econs; ss. 160 | - apply NNPP in H. ss. 161 | Qed. 162 | 163 | Definition val2block val := 164 | match val with 165 | | Vptr blck _ => Some blck 166 | | _ => None 167 | end. 168 | 169 | Definition GV2blocks (gval: GenericValue) := filter_map (val2block <*> fst) gval. 170 | 171 | Lemma GV2ptr_In_GV2blocks 172 | td sz gv b i 173 | (GV2PTR: GV2ptr td sz gv = Some (Values.Vptr b i)) 174 | : 175 | <> 176 | . 177 | Proof. 178 | induction gv; ii; des; ss. 179 | destruct a; ss. des_ifs. ss. 180 | left. ss. 181 | Qed. 182 | 183 | Lemma GV2blocks_cons 184 | v m gv 185 | : 186 | <> 187 | . 188 | Proof. 189 | red. 190 | unfold GV2blocks in *. 191 | unfold compose in *. 192 | ss. 193 | des_ifs. 194 | Qed. 195 | 196 | Lemma GV2blocks_In_cons 197 | b v1 m gv1 198 | (IN: In b (GV2blocks ((v1, m) :: gv1))) 199 | : 200 | <> 201 | . 202 | Proof. 203 | erewrite GV2blocks_cons in IN. 204 | apply in_app in IN. 205 | ss. 206 | Qed. 207 | 208 | Lemma GV2blocks_in_inv 209 | a gvs 210 | (IN: In a (GV2blocks gvs)) 211 | : 212 | <> 213 | . 214 | Proof. 215 | induction gvs; ii; ss; des; ss. 216 | destruct a0; ss. 217 | eapply GV2blocks_In_cons in IN. 218 | des. 219 | - destruct v; ss. des; ss. 220 | clarify. 221 | esplits; eauto. 222 | - exploit IHgvs; eauto; []; ii; des. 223 | esplits; eauto. 224 | Qed. 225 | 226 | Lemma GV2blocks_incl 227 | gvs1 gvs2 228 | (INCL: incl gvs1 gvs2) 229 | : 230 | <> 231 | . 232 | Proof. 233 | ii. 234 | apply GV2blocks_in_inv in H. 235 | des. 236 | eapply TODOProof.filter_map_spec; eauto. 237 | Qed. 238 | 239 | Lemma GV2blocks_lift 240 | z ofs mc gvs' 241 | (IN : In (Values.Vptr z ofs, mc) gvs') 242 | : 243 | <> 244 | . 245 | Proof. 246 | induction gvs'; ii; ss; des; ss; clarify. 247 | - cbn. left; ss. 248 | - exploit IHgvs'; eauto; []; ii; des. 249 | cbn. 250 | unfold compose in *. 251 | des_ifs. 252 | cbn. 253 | right; ss. 254 | Qed. 255 | 256 | Lemma GV2blocks_app_inv z xs ys 257 | (IN: In z (GV2blocks (xs ++ ys))) 258 | : 259 | <> 260 | . 261 | Proof. 262 | generalize dependent ys. 263 | induction xs; ii; ss; des; ss. 264 | { right; ss. } 265 | cbn in IN. 266 | unfold compose in *; ss. 267 | destruct a; ss. 268 | (* destruct v; ss. *) 269 | des_ifs; ss; cbn. 270 | - unfold compose; ss. 271 | des; ss; subst. 272 | + left. des_ifs. 273 | ss. left; ss. 274 | + des_ifs. 275 | eapply TODOProof.filter_map_inv in IN. 276 | des. 277 | eapply in_app in IN. 278 | des. 279 | * left. 280 | ss. right; ss. 281 | eapply TODOProof.filter_map_spec; eauto. 282 | * right. 283 | eapply TODOProof.filter_map_spec; eauto. 284 | - 285 | unfold compose; ss. 286 | eapply TODOProof.filter_map_inv in IN. 287 | des. 288 | eapply in_app in IN. 289 | des. 290 | + left. des_ifs. 291 | eapply TODOProof.filter_map_spec; eauto. 292 | + right. 293 | eapply TODOProof.filter_map_spec; eauto. 294 | Qed. 295 | 296 | (* TODO: Why error_state is defined in GenericValues? *) 297 | (* -> It is used in SoundPostcondCmdAdd. Is it essential? *) 298 | Lemma error_state_neg conf st 299 | (NERROR_SRC: ~error_state conf st) 300 | : 301 | <> 302 | . 303 | Proof. 304 | red. unfold not in NERROR_SRC. 305 | apply imply_to_or. 306 | i. 307 | destruct (s_isFinalState conf st) eqn:T. 308 | { esplits; eauto. } 309 | exploit NERROR_SRC; eauto. 310 | { econs; eauto. } 311 | i; ss. 312 | Qed. 313 | -------------------------------------------------------------------------------- /coq/proof/OpsemAux.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | 13 | Require Import sflib. 14 | Require Import paco. 15 | Import Opsem. 16 | 17 | Require Import TODO. 18 | Require Import Decs. 19 | Require Import Hints. 20 | Require Import Validator. 21 | Require Import GenericValues. 22 | Require Import Inject. 23 | 24 | Set Implicit Arguments. 25 | 26 | 27 | Lemma sInsn_non_call 28 | conf fdef bb cmd cmds term locals1 allocas1 ecs mem1 29 | st2 event 30 | (NONCALL: ~ Instruction.isCallInst cmd) 31 | (STEP: sInsn 32 | conf 33 | (mkState (mkEC fdef bb (cmd::cmds) term locals1 allocas1) ecs mem1) 34 | st2 35 | event): 36 | exists locals2 allocas2 mem2, 37 | st2 = mkState (mkEC fdef bb cmds term locals2 allocas2) ecs mem2. 38 | Proof. 39 | inv STEP; eauto. ss. congruence. 40 | Qed. 41 | 42 | Lemma inject_decide_nonzero 43 | TD inv 44 | val_src decision_src 45 | val_tgt decision_tgt 46 | (INJECT: genericvalues_inject.gv_inject inv val_src val_tgt) 47 | (SRC: decide_nonzero TD val_src decision_src) 48 | (TGT: decide_nonzero TD val_tgt decision_tgt): 49 | decision_src = decision_tgt. 50 | Proof. 51 | inv SRC. inv TGT. unfold GV2int in *. des_ifs. 52 | inv INJECT. ss. inv H1. 53 | apply inj_pair2 in H2. apply inj_pair2 in H. clarify. 54 | Qed. 55 | 56 | Coercion module_of_conf (conf: Config): module. 57 | Proof. 58 | destruct conf. 59 | destruct CurTargetData0. 60 | econs; eauto. 61 | Defined. 62 | 63 | Coercion get_cmds_from_stmts (s: stmts): cmds := 64 | let '(stmts_intro _ cs _) := s in cs 65 | . 66 | 67 | Coercion get_cmds_from_block (b: block): cmds := b.(snd). 68 | 69 | Inductive wf_EC (ec: ExecutionContext): Prop := 70 | | wf_EC_intro 71 | (BLOCK: blockInFdefB ec.(CurBB) ec.(CurFunction)) 72 | (* (CMDS: forall c (IN: In c ec.(CurCmds)), insnInBlockB (insn_cmd c) ec.(CurBB)) *) 73 | (* Instead of above definition, I intentionally choose below definition. It was easier. *) 74 | (* FYI: wf_fdef lemmas, such as "typings_props.wf_fdef__wf_cmd", doesn't use insnInBlockB *) 75 | (CMDS: sublist ec.(CurCmds) (ec.(CurBB): cmds)) 76 | (TERM: insnInBlockB (insn_terminator ec.(Terminator)) ec.(CurBB)) 77 | . 78 | -------------------------------------------------------------------------------- /coq/proof/Simulation.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Require Import vellvm. 10 | Import Opsem. 11 | 12 | Require Import sflib. 13 | Require Import paco. 14 | 15 | Require Import GenericValues. 16 | 17 | Set Implicit Arguments. 18 | 19 | 20 | Inductive sInsn_indexed (conf:Config): 21 | forall (st1 st2:State) (idx1 idx2:nat) (event:trace), Prop := 22 | | sInsn_step 23 | st1 st2 idx1 idx2 event 24 | (STEP: sInsn conf st1 st2 event): 25 | sInsn_indexed conf st1 st2 idx1 idx2 event 26 | | sInsn_stutter 27 | st idx1 idx2 28 | (IDX: (idx1 > idx2)%nat): 29 | sInsn_indexed conf st st idx1 idx2 E0 30 | . 31 | 32 | Section Sim. 33 | Variable (conf_src conf_tgt:Config). 34 | 35 | Inductive _sim 36 | (sim: forall (idx1:nat) (st1_src st1_tgt:State), Prop) 37 | (idx1:nat) (st1_src st1_tgt:State): Prop := 38 | | _sim_error 39 | st2_src 40 | (STEP: sop_star conf_src st1_src st2_src E0) 41 | (ERROR: error_state conf_src st2_src) 42 | 43 | | _sim_exit 44 | st2_src 45 | retval 46 | (STEP_SRC: sop_star conf_src st1_src st2_src E0) 47 | (EXIT_SRC: s_isFinalState conf_src st2_src = Some retval) 48 | (EXIT_TGT: s_isFinalState conf_tgt st1_tgt = Some retval) 49 | 50 | | _sim_step 51 | (PROGRESS: ~ stuck_state conf_tgt st1_tgt) 52 | (STEP: 53 | forall st3_tgt event 54 | (STEP: sInsn conf_tgt st1_tgt st3_tgt event), 55 | exists st2_src st3_src idx3, 56 | sop_star conf_src st1_src st2_src E0 /\ 57 | sInsn_indexed conf_src st2_src st3_src idx1 idx3 event /\ 58 | sim idx3 st3_src st3_tgt) 59 | . 60 | Hint Constructors _sim. 61 | 62 | Lemma _sim_mon: monotone3 _sim. 63 | Proof. 64 | repeat intro; inv IN. 65 | - econs 1; eauto. 66 | - econs 2; eauto. 67 | - econs 3; eauto. 68 | i. exploit STEP; eauto. i. des. 69 | esplits; eauto. 70 | Qed. 71 | Hint Resolve _sim_mon: paco. 72 | 73 | Definition sim: _ -> _ -> _ -> Prop := 74 | paco3 _sim bot3. 75 | End Sim. 76 | Hint Constructors _sim. 77 | Hint Resolve _sim_mon: paco. 78 | 79 | Lemma sop_star_sim 80 | conf_src conf_tgt sim idx 81 | st1_src st2_src 82 | st1_tgt 83 | (TAU: sop_star conf_src st1_src st2_src events.E0) 84 | (SIM: _sim conf_src conf_tgt sim idx st2_src st1_tgt): 85 | _sim conf_src conf_tgt sim idx st1_src st1_tgt. 86 | Proof. 87 | inv SIM. 88 | - econs 1; cycle 1; eauto. 89 | rewrite <- events.E0_left. 90 | eapply opsem_props.OpsemProps.sop_star_trans; eauto. 91 | - econs 2; cycle 1; eauto. 92 | rewrite <- events.E0_left. 93 | eapply opsem_props.OpsemProps.sop_star_trans; eauto. 94 | - econs 3; eauto. i. exploit STEP; eauto. i. des. 95 | esplits; cycle 1; eauto. 96 | rewrite <- events.E0_left. 97 | eapply opsem_props.OpsemProps.sop_star_trans; eauto. 98 | Qed. 99 | 100 | Lemma _sim_src_error 101 | conf_src conf_tgt sim idx 102 | st_src st_tgt 103 | (SIM: forall (ERROR_SRC: ~ error_state conf_src st_src), 104 | _sim conf_src conf_tgt sim idx 105 | st_src st_tgt): 106 | _sim conf_src conf_tgt sim idx 107 | st_src st_tgt. 108 | Proof. 109 | destruct (classic (error_state conf_src st_src)); eauto. 110 | Qed. 111 | 112 | Definition get_params (S: system) (fid: id): option args := 113 | match lookupFdefViaIDFromSystem S fid with 114 | | Some (fdef_intro (fheader_intro _ _ _ args _) _) => Some args 115 | | _ => None 116 | end 117 | . 118 | 119 | Definition TD_of_module (md: module): TargetData := 120 | match md with 121 | | module_intro los ndts _ => (los, ndts) 122 | end 123 | . 124 | 125 | Definition sim_module (module_src module_tgt:module): Prop := 126 | forall main args 127 | conf_src st_src 128 | (SRC: s_genInitState [module_src] main args Mem.empty = Some (conf_src, st_src)) 129 | (FIT_ARGS: 130 | forall params 131 | (PARAMS: (get_params [module_src] main) = Some params), 132 | Forall2 (fun x y => (fit_gv (TD_of_module module_src) x.(fst).(fst) y = Some y)) params args) 133 | , 134 | exists conf_tgt st_tgt idx, 135 | <> /\ 136 | <>. 137 | -------------------------------------------------------------------------------- /coq/proof/SoundForgetStackCall.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | 13 | Require Import sflib. 14 | Require Import paco. 15 | Import Opsem. 16 | 17 | Require Import TODO. 18 | Require Import TODOProof. 19 | Require Import Hints. 20 | Require Import Postcond. 21 | Require Import Validator. 22 | Require Import GenericValues. 23 | Require AssnMem. 24 | Require AssnState. 25 | Require Import Inject. 26 | Require Import SoundBase. 27 | Require Import SoundForgetStack. 28 | 29 | Set Implicit Arguments. 30 | 31 | 32 | Lemma forget_stack_call_Subset inv defs_src defs_tgt 33 | : Hints.Assertion.Subset (ForgetStackCall.t defs_src defs_tgt inv) inv. 34 | Proof. 35 | unfold ForgetStackCall.t. 36 | apply forget_stack_Subset. 37 | Qed. 38 | 39 | Lemma unary_sem_eq_locals_mem 40 | conf st0 st1 invst0 assnmem0 inv0 gmax public 41 | (LOCALS_EQ: Locals (EC st0) = Locals (EC st1)) 42 | (MEM_EQ : Mem st0 = Mem st1) 43 | (STATE: AssnState.Unary.sem conf st0 invst0 assnmem0 gmax public inv0) 44 | (EQ_FUNC: st0.(EC).(CurFunction) = st1.(EC).(CurFunction)) 45 | (EQ_ALLOCAS: st0.(EC).(Allocas) = st1.(EC).(Allocas)) 46 | (EQ_BB: st0.(EC).(CurBB) = st1.(EC).(CurBB)) 47 | (EQ_TERM: st0.(EC).(Terminator) = st1.(EC).(Terminator)) 48 | (CMDS_SUB: sublist st1.(EC).(CurCmds) st0.(EC).(CurCmds)) 49 | : AssnState.Unary.sem conf st1 invst0 assnmem0 gmax public inv0. 50 | Proof. 51 | inv STATE. 52 | econs. 53 | - ii. 54 | exploit LESSDEF; eauto. 55 | { erewrite sem_expr_eq_locals_mem; eauto. } 56 | i. des. 57 | esplits; eauto. 58 | erewrite sem_expr_eq_locals_mem; eauto. 59 | - inv NOALIAS. 60 | econs; i; [eapply DIFFBLOCK | eapply NOALIAS0]; 61 | try erewrite sem_valueT_eq_locals; eauto. 62 | - ii. exploit UNIQUE; eauto. intro UNIQ_X. inv UNIQ_X. 63 | econs; try rewrite <- LOCALS_EQ; try rewrite <- MEM_EQ; eauto. 64 | - ii. exploit PRIVATE; eauto. 65 | { erewrite sem_idT_eq_locals; eauto. } 66 | rewrite <- MEM_EQ. eauto. 67 | - rewrite <- EQ_ALLOCAS. ss. 68 | - rpapply ALLOCAS_VALID. 69 | + rewrite MEM_EQ. eauto. 70 | + rewrite EQ_ALLOCAS. eauto. 71 | - rewrite <- LOCALS_EQ. rewrite <- MEM_EQ. eauto. 72 | - rewrite <- MEM_EQ. eauto. 73 | - rewrite <- MEM_EQ. eauto. 74 | - rewrite <- LOCALS_EQ. eauto. 75 | - rewrite <- EQ_FUNC. ss. 76 | - destruct st0, st1; ss. destruct EC0, EC1; ss. clarify. 77 | clear - CMDS_SUB WF_EC. 78 | inv WF_EC. econs; ss; eauto. 79 | + eapply sublist_trans; eauto. 80 | Qed. 81 | 82 | Lemma invst_sem_eq_locals_mem 83 | st0_src st1_src conf_src 84 | st0_tgt st1_tgt conf_tgt 85 | invst assnmem inv 86 | (MEM_SRC: st0_src.(Mem) = st1_src.(Mem)) 87 | (MEM_TGT: st0_tgt.(Mem) = st1_tgt.(Mem)) 88 | (LOCAL_SRC: st0_src.(EC).(Locals) = st1_src.(EC).(Locals)) 89 | (LOCAL_TGT: st0_tgt.(EC).(Locals) = st1_tgt.(EC).(Locals)) 90 | (STATE : AssnState.Rel.sem conf_src conf_tgt st0_src st0_tgt invst assnmem inv) 91 | (EQ_BB_SRC: st0_src.(EC).(CurBB) = st1_src.(EC).(CurBB)) 92 | (EQ_BB_TGT: st0_tgt.(EC).(CurBB) = st1_tgt.(EC).(CurBB)) 93 | (EQ_FUNC_SRC: st0_src.(EC).(CurFunction) = st1_src.(EC).(CurFunction)) 94 | (EQ_FUNC_TGT: st0_tgt.(EC).(CurFunction) = st1_tgt.(EC).(CurFunction)) 95 | (EQ_ALLOCAS_SRC: st0_src.(EC).(Allocas) = st1_src.(EC).(Allocas)) 96 | (EQ_ALLOCAS_TGT: st0_tgt.(EC).(Allocas) = st1_tgt.(EC).(Allocas)) 97 | (EQ_TERM_SRC: st0_src.(EC).(Terminator) = st1_src.(EC).(Terminator)) 98 | (EQ_TERM_TGT: st0_tgt.(EC).(Terminator) = st1_tgt.(EC).(Terminator)) 99 | (CMDS_SUB_SRC: sublist st1_src.(EC).(CurCmds) st0_src.(EC).(CurCmds)) 100 | (CMDS_SUB_TGT: sublist st1_tgt.(EC).(CurCmds) st0_tgt.(EC).(CurCmds)) 101 | : AssnState.Rel.sem conf_src conf_tgt st1_src st1_tgt invst assnmem inv. 102 | Proof. 103 | inv STATE. 104 | econs. 105 | - eapply unary_sem_eq_locals_mem; eauto. 106 | - eapply unary_sem_eq_locals_mem; eauto. 107 | - ss. 108 | - i. hexploit MAYDIFF; eauto. i. 109 | ii. exploit H. 110 | { erewrite sem_idT_eq_locals; eauto. } 111 | i. erewrite sem_idT_eq_locals; eauto. 112 | - rewrite <- EQ_ALLOCAS_SRC. 113 | rewrite <- EQ_ALLOCAS_TGT. 114 | ss. 115 | Qed. 116 | 117 | Lemma genericvalues_inject_wf_valid_ptrs_src 118 | assnmem 119 | mem_src gv_src 120 | mem_tgt gv_tgt 121 | (INJ_FIT : genericvalues_inject.gv_inject assnmem.(AssnMem.Rel.inject) gv_src gv_tgt) 122 | (WF : genericvalues_inject.wf_sb_mi assnmem.(AssnMem.Rel.gmax) assnmem.(AssnMem.Rel.inject) mem_src mem_tgt) 123 | : memory_props.MemProps.valid_ptrs (Memory.Mem.nextblock mem_src) gv_src. 124 | Proof. 125 | generalize dependent gv_tgt. 126 | inv WF. 127 | induction gv_src; i; ss. 128 | des_ifs; inv INJ_FIT; 129 | try by eapply IHgv_src; eauto. 130 | inv H3. 131 | split; eauto. 132 | destruct (dom_libs.PositiveSet.MSet.Raw.MX.lt_dec b (Memory.Mem.nextblock mem_src)); ss. 133 | rewrite <- Pos.le_nlt in n. 134 | exploit Hmap1. 135 | { apply Pos.le_ge. eauto. } 136 | i. congruence. 137 | Qed. 138 | 139 | Lemma genericvalues_inject_wf_valid_ptrs_tgt 140 | assnmem 141 | mem_src gv_src 142 | mem_tgt gv_tgt 143 | (INJ_FIT : genericvalues_inject.gv_inject assnmem.(AssnMem.Rel.inject) gv_src gv_tgt) 144 | (WF : genericvalues_inject.wf_sb_mi assnmem.(AssnMem.Rel.gmax) assnmem.(AssnMem.Rel.inject) mem_src mem_tgt) 145 | (NOTUNDEF: List.Forall (fun v => v.(fst) <> Values.Vundef) gv_src) 146 | : memory_props.MemProps.valid_ptrs (Memory.Mem.nextblock mem_tgt) gv_tgt. 147 | Proof. 148 | generalize dependent gv_src. 149 | inv WF. 150 | induction gv_tgt; i; ss. 151 | inv INJ_FIT. inv NOTUNDEF. 152 | des_ifs; 153 | try by eapply IHgv_tgt; eauto. 154 | inv H2. 155 | - split; eauto. 156 | - ss. 157 | Qed. 158 | 159 | Lemma gv_inject_public_src 160 | gv_src gv_tgt meminj b 161 | (INJECT: genericvalues_inject.gv_inject meminj gv_src gv_tgt) 162 | (IN: In b (GV2blocks gv_src)) 163 | : 164 | <> 165 | . 166 | Proof. 167 | induction INJECT; ii; ss; des; ss. 168 | - eapply GV2blocks_In_cons in IN. 169 | des. 170 | + destruct v1; ss. des; ss. subst. 171 | inv H. 172 | clarify. 173 | + exploit IHINJECT; eauto. 174 | Qed. 175 | 176 | Lemma gv_inject_public_tgt 177 | gv_src gv_tgt meminj b 178 | (INJECT: genericvalues_inject.gv_inject meminj gv_src gv_tgt) 179 | (IN: In b (GV2blocks gv_tgt)) 180 | (NOTUNDEF: List.Forall (fun v => v.(fst) <> Values.Vundef) gv_src) 181 | : 182 | <> 183 | . 184 | Proof. 185 | induction INJECT; ii; ss; des; ss. 186 | - eapply GV2blocks_In_cons in IN. 187 | des. 188 | + destruct v2; ss. des; ss. subst. 189 | unfold AssnMem.Rel.public_tgt. 190 | inv H. 191 | * esplits; eauto. 192 | * inv NOTUNDEF. ss. 193 | + exploit IHINJECT; eauto. 194 | inv NOTUNDEF. ss. 195 | Qed. 196 | 197 | 198 | (* TODO: position *) 199 | Lemma gv_inject_no_private_src 200 | conf_src st_src gv_src 201 | conf_tgt st_tgt gv_tgt 202 | invst assnmem inv 203 | (STATE : AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst assnmem inv) 204 | (MEM : AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem) 205 | (INJECT: genericvalues_inject.gv_inject (AssnMem.Rel.inject assnmem) gv_src gv_tgt) 206 | : <> 211 | . 212 | Proof. 213 | inv STATE. rename SRC into STATE_SRC. rename TGT into STATE_TGT. clear MAYDIFF. 214 | clear MEM. 215 | ii. 216 | - clear STATE_TGT. 217 | inv STATE_SRC. 218 | clear LESSDEF NOALIAS UNIQUE 219 | WF_LOCAL WF_PREVIOUS WF_GHOST UNIQUE_PARENT_LOCAL. 220 | 221 | exploit PRIVATE; eauto. 222 | { apply Exprs.IdTSetFacts.mem_iff. eauto. } 223 | intro PRIV_IN_MEM. des. (* clear PARENT_DISJOINT. *) 224 | { 225 | eapply PRIVATE; eauto. 226 | eapply Exprs.IdTSetFacts.mem_iff; eauto. 227 | unfold AssnMem.private_block in *. des. 228 | hexploit gv_inject_public_src; eauto; []; intro PUB; des. 229 | clear - PUB PRIVATE_BLOCK. ss. 230 | } 231 | Qed. 232 | 233 | 234 | (* we need additional condition: all unique in inv1 is private, so not in inject: not in return value *) 235 | Lemma forget_stack_call_sound 236 | invst2 assnmem2 inv1 noret typ 237 | mem1_src conf_src retval1_src st0_src id_src cmds_src locals1_src 238 | mem1_tgt conf_tgt retval1_tgt st0_tgt id_tgt cmds_tgt 239 | (CONF: inject_conf conf_src conf_tgt) 240 | (STATE: 241 | AssnState.Rel.sem 242 | conf_src conf_tgt 243 | (mkState st0_src.(EC) st0_src.(ECS) mem1_src) 244 | (mkState st0_tgt.(EC) st0_tgt.(ECS) mem1_tgt) 245 | invst2 assnmem2 inv1) 246 | (CMDS_SUB_SRC: sublist cmds_src st0_src.(EC).(CurCmds)) 247 | (CMDS_SUB_TGT: sublist cmds_tgt st0_tgt.(EC).(CurCmds)) 248 | (UNIQUE_PRIVATE_SRC: unique_is_private_unary inv1.(Assertion.src)) 249 | (UNIQUE_PRIVATE_TGT: unique_is_private_unary inv1.(Assertion.tgt)) 250 | (MEM: AssnMem.Rel.sem conf_src conf_tgt mem1_src mem1_tgt assnmem2) 251 | (RETVAL: TODO.lift2_option (genericvalues_inject.gv_inject assnmem2.(AssnMem.Rel.inject)) retval1_src retval1_tgt) 252 | (VALID: valid_retvals mem1_src mem1_tgt retval1_src retval1_tgt) 253 | (RETURN_SRC: return_locals 254 | conf_src.(CurTargetData) 255 | retval1_src id_src noret typ 256 | st0_src.(EC).(Locals) 257 | = Some locals1_src) 258 | : exists locals2_tgt, 259 | <> /\ 264 | <>. 285 | Proof. 286 | unfold return_locals in *. 287 | destruct retval1_src; destruct retval1_tgt; ss. 288 | rename g into rgv_src. rename g0 into rgv_tgt. 289 | { (* some - some *) 290 | destruct noret. 291 | { esplits; eauto. clarify. ss. 292 | eapply Subset_sem. 293 | eapply invst_sem_eq_locals_mem; try exact STATE; eauto. 294 | apply forget_stack_call_Subset. 295 | } 296 | des_ifs. 297 | - rename g0 into rgv_fit_src. rename g into rgv_fit_tgt. 298 | hexploit genericvalues_inject.simulation__fit_gv; eauto. 299 | { inv MEM. eauto. } 300 | intro FIT_GV. destruct FIT_GV as [rgv_fit_tgt' [FIT_GV_TGT INJ_FIT]]. 301 | inv CONF. rewrite TARGETDATA in *. 302 | clarify. 303 | esplits; eauto. 304 | 305 | hexploit gv_inject_no_private_src; eauto. intros DIFF_FROM_PRIVATE_SRC. des. 306 | 307 | unfold ForgetStackCall.t. 308 | eapply forget_stack_sound; eauto. 309 | { econs; eauto. 310 | ss. ii. 311 | apply AtomSetImpl_singleton_mem_false in NOT_MEM. 312 | erewrite <- lookupAL_updateAddAL_neq; eauto. 313 | } 314 | { econs; eauto. 315 | ss. ii. 316 | apply AtomSetImpl_singleton_mem_false in NOT_MEM. 317 | erewrite <- lookupAL_updateAddAL_neq; eauto. 318 | } 319 | 320 | { inv STATE. inv SRC. 321 | inv MEM. inv SRC. 322 | econs; eauto; ss. 323 | - i. 324 | rewrite AtomSetProperties.empty_union_2 in *; ss. 325 | apply AtomSetImpl_singleton_mem_false in NO_LEAK. 326 | exploit UNIQUE. 327 | { apply AtomSetFacts.mem_iff; eauto. } 328 | intro UNIQUE_PREV. inv UNIQUE_PREV. 329 | econs; eauto; ss. 330 | + rewrite <- lookupAL_updateAddAL_neq; eauto. 331 | + i. 332 | destruct (id_dec reg id_src); cycle 1. 333 | * rewrite <- lookupAL_updateAddAL_neq in VAL'; eauto. 334 | * subst. 335 | rewrite lookupAL_updateAddAL_eq in VAL'. clarify. 336 | eapply DIFF_FROM_PRIVATE_SRC; eauto. 337 | - ii. 338 | destruct (id_dec id_src x). 339 | { subst. 340 | rewrite lookupAL_updateAddAL_eq in PTR. clarify. 341 | des. 342 | eapply sublist_In in UNIQUE_PRIVATE_PARENT; eauto. 343 | exploit PRIVATE_PARENT; eauto. intros [NOT_PUBLIC _]. 344 | apply NOT_PUBLIC. 345 | eapply gv_inject_public_src; eauto. 346 | } 347 | { erewrite <- lookupAL_updateAddAL_neq in PTR; eauto. 348 | exploit UNIQUE_PARENT_LOCAL; eauto. } 349 | } 350 | { inv STATE. inv TGT. 351 | inv MEM. inv TGT. 352 | 353 | econs; eauto; ss. 354 | - i. 355 | apply AtomSetFacts.mem_iff in MEM. 356 | expl TGT_NOUNIQ. ss. 357 | - rewrite TGT_NOUNIQ0. ii. inv INB. 358 | } 359 | { (* REMARK: We can use VALID premise just as in tgt. Actually this is more symmetric. *) 360 | (* But I intentionally leave this code, just to remember old logic: inject implies vaild, by wasabi *) 361 | ss. inv STATE. inv SRC. ss. 362 | apply memory_props.MemProps.updateAddAL__wf_lc; eauto. 363 | inv MEM. 364 | exploit genericvalues_inject_wf_valid_ptrs_src; eauto. 365 | } 366 | { apply memory_props.MemProps.updateAddAL__wf_lc; ss; eauto. 367 | - inv VALID. 368 | eapply fit_gv_preserves_valid_ptrs; eauto. 369 | - apply STATE. 370 | } 371 | { apply STATE. } 372 | { apply STATE. } 373 | { apply STATE. } 374 | { apply STATE. } 375 | { apply STATE. } 376 | { ss. 377 | inv STATE. inv SRC. 378 | clear - WF_FDEF WF_EC CMDS_SUB_SRC. 379 | ss. inv WF_EC. ss. 380 | econs; ss; eauto. 381 | eapply sublist_trans; eauto. 382 | } 383 | { ss. 384 | inv STATE. inv TGT. 385 | clear - WF_FDEF WF_EC CMDS_SUB_TGT. 386 | ss. inv WF_EC. ss. 387 | econs; ss; eauto. 388 | eapply sublist_trans; eauto. 389 | } 390 | - hexploit genericvalues_inject.simulation__fit_gv; eauto. 391 | { inv MEM. eauto. } 392 | i. des. 393 | inv CONF. rewrite TARGETDATA in *. 394 | congruence. 395 | } 396 | { (* none - none *) 397 | esplits; des_ifs; ss. 398 | unfold AtomSetImpl_from_list. ss. 399 | eapply Subset_sem; cycle 1. 400 | { unfold ForgetStackCall.t. 401 | apply forget_stack_Subset. } 402 | eapply invst_sem_eq_locals_mem; try exact STATE; eauto. 403 | } 404 | Qed. 405 | -------------------------------------------------------------------------------- /coq/proof/SoundInfruleReduceMaydiff.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | 13 | Require Import sflib. 14 | Require Import paco. 15 | Import Opsem. 16 | 17 | Require Import TODO. 18 | Require Import Exprs. 19 | Require Import Hints. 20 | Require Import Postcond. 21 | Require Import Validator. 22 | Require Import GenericValues. 23 | Require AssnMem. 24 | Require AssnState. 25 | Require Import Hints. 26 | Require Import Infrules. 27 | 28 | 29 | Set Implicit Arguments. 30 | 31 | 32 | Section Filter. 33 | Definition filter 34 | (preserved: Exprs.Tag.t * id -> bool) 35 | (inv: AssnState.Unary.t): AssnState.Unary.t := 36 | AssnState.Unary.update_ghost 37 | (filter_AL_atom (preserved <*> (pair Exprs.Tag.ghost))) 38 | (AssnState.Unary.update_previous 39 | (filter_AL_atom (preserved <*> (pair Exprs.Tag.previous))) 40 | inv). 41 | 42 | Lemma filter_subset_idT st_unary f id invst_unary val 43 | (VAL_SUBSET: (AssnState.Unary.sem_idT st_unary (filter f invst_unary) id = Some val)): 44 | <>. 45 | Proof. 46 | destruct id. destruct t; ss. 47 | - eapply lookup_AL_filter_some. exact VAL_SUBSET. 48 | - eapply lookup_AL_filter_some. exact VAL_SUBSET. 49 | Qed. 50 | 51 | Lemma filter_subset_valueT conf_unary st_unary f vt invst_unary val 52 | (VAL_SUBSET: (AssnState.Unary.sem_valueT 53 | conf_unary st_unary 54 | (filter f invst_unary) vt = Some val)): 55 | <>. 56 | Proof. 57 | red. destruct vt; ss. 58 | eapply filter_subset_idT; eauto. 59 | Qed. 60 | 61 | Lemma filter_subset_list_valueT conf_unary st_unary f vts invst_unary val 62 | (VAL_SUBSET: (AssnState.Unary.sem_list_valueT 63 | conf_unary st_unary 64 | (filter f invst_unary) vts = Some val)): 65 | <>. 66 | Proof. 67 | red. revert val VAL_SUBSET. induction vts; i; ss. destruct a. 68 | Ltac exploit_with H x := 69 | (exploit H; [exact x|]; eauto; ii; des). 70 | des_ifs; ss; 71 | (all_once exploit_with filter_subset_valueT); 72 | (exploit IHvts; eauto; i); clarify. 73 | Qed. 74 | 75 | Lemma filter_subset_expr conf_unary st_unary f expr invst_unary val 76 | (VAL_SUBSET: (AssnState.Unary.sem_expr 77 | conf_unary st_unary 78 | (filter f invst_unary) expr = Some val)): 79 | <>. 80 | Proof. 81 | red. 82 | Ltac exploit_filter_subset_with x := 83 | match (type of x) with 84 | | (AssnState.Unary.sem_valueT _ _ _ _ = Some _) => 85 | (exploit filter_subset_valueT; [exact x|]; eauto; ii; des) 86 | | (AssnState.Unary.sem_list_valueT _ _ _ _ = Some _) => 87 | (exploit filter_subset_list_valueT; [exact x|]; eauto; ii; des) 88 | end. 89 | Time destruct expr; ss; 90 | des_ifs; ss; (all_once exploit_filter_subset_with); clarify. 91 | (* exploit_with: Finished transaction in 25.39 secs (25.194u,0.213s) (successful) *) 92 | (* exploit_with_fast: Finished transaction in 7.575 secs (7.536u,0.044s) (successful) *) 93 | Qed. 94 | 95 | Lemma filter_preserved_valueT 96 | conf_unary st_unary invst_unary vt val f 97 | (VAL: AssnState.Unary.sem_valueT conf_unary st_unary invst_unary vt = Some val) 98 | (PRESERVED: (sflib.is_true (List.forallb f (Exprs.ValueT.get_idTs vt)))): 99 | <>. 100 | Proof. 101 | red. destruct vt; ss. repeat (des_bool; des). 102 | unfold AssnState.Unary.sem_idT. destruct x. s. 103 | destruct t; ss. 104 | - rewrite lookup_AL_filter_spec in *. des_ifs. 105 | unfold compose, Tag.t, Ords.id.t in *. rewrite PRESERVED in *. clarify. 106 | - rewrite lookup_AL_filter_spec in *. des_ifs. 107 | unfold compose, Tag.t, Ords.id.t in *. rewrite PRESERVED in *. clarify. 108 | Qed. 109 | 110 | Lemma filter_preserved_list_valueT 111 | conf_unary st_unary invst_unary vts val f 112 | (VAL: AssnState.Unary.sem_list_valueT conf_unary st_unary invst_unary vts = Some val) 113 | (PRESERVED: sflib.is_true (List.forallb 114 | (fun x => (List.forallb f (Exprs.ValueT.get_idTs x))) 115 | (List.map snd vts))): 116 | <>. 117 | Proof. 118 | revert val VAL PRESERVED. induction vts; i; ss. 119 | destruct a. ss. repeat (des_bool; des). 120 | des_ifs; ss. 121 | - (exploit filter_preserved_valueT; [exact Heq1| |]; eauto; ii; des). 122 | exploit IHvts; eauto; []; ii; des. clarify. 123 | - (exploit filter_preserved_valueT; [exact Heq1| |]; eauto; ii; des). 124 | exploit IHvts; eauto; []; ii; des. clarify. 125 | - (exploit filter_preserved_valueT; [exact Heq0| |]; eauto; ii; des). 126 | exploit IHvts; eauto; []; ii; des. clarify. 127 | Qed. 128 | 129 | Lemma filter_preserved_expr 130 | conf_unary st_unary invst_unary expr val f 131 | (VAL: AssnState.Unary.sem_expr conf_unary st_unary invst_unary expr = Some val) 132 | (PRESERVED: List.forallb f (Exprs.Expr.get_idTs expr)): 133 | <>. 134 | Proof. 135 | red. 136 | unfold Exprs.Expr.get_idTs in *. 137 | eapply forallb_filter_map in PRESERVED. des. 138 | unfold is_true in PRESERVED. (* des_bool should kill it!!!!!!! KILL ALL is_true *) 139 | 140 | Ltac exploit_filter_preserved_with x := 141 | match (type of x) with 142 | | (AssnState.Unary.sem_valueT _ _ (filter _ _) _ = _) => fail 1 143 | | (AssnState.Unary.sem_list_valueT _ _ (filter _ _) _ = _) => fail 1 144 | (* Above is REQUIRED in order to prevent inf loop *) 145 | | (AssnState.Unary.sem_valueT _ _ _ _ = Some _) => 146 | (exploit filter_preserved_valueT; [exact x| |]; eauto; ii; des) 147 | | (AssnState.Unary.sem_list_valueT _ _ _ _ = Some _) => 148 | (exploit filter_preserved_list_valueT; [exact x| |]; eauto; ii; des) 149 | end. 150 | 151 | Time destruct expr; ss; 152 | repeat (des_bool; des); des_ifs; clarify; 153 | (all_once exploit_filter_subset_with); clarify; 154 | (all_once exploit_filter_preserved_with); clarify. 155 | Qed. 156 | 157 | Lemma In_map_incl {A} (f: Exprs.ExprPair.t -> list A) x xs 158 | (IN: Exprs.ExprPairSet.In x xs): 159 | <>. 160 | Proof. 161 | rewrite ExprPairSetFacts.elements_iff in IN. induction IN; ss. 162 | - subst. apply incl_appl. solve_leibniz. apply incl_refl. 163 | - apply incl_appr. ss. 164 | Qed. 165 | 166 | Lemma filter_AL_atom_preserves_wf_lc 167 | f mem lc 168 | (WF_LOCAL : memory_props.MemProps.wf_lc mem lc) 169 | : memory_props.MemProps.wf_lc mem (filter_AL_atom f lc). 170 | Proof. 171 | unfold memory_props.MemProps.wf_lc in *. 172 | i. exploit WF_LOCAL; eauto. 173 | eapply lookup_AL_filter_some; eauto. 174 | Qed. 175 | 176 | Lemma incl_implies_preserved 177 | conf st invst0 expr val inv 178 | (preserved: _ -> bool) 179 | (PRESERVED: forall id (ID: In id (Assertion.get_idTs_unary inv)), preserved id) 180 | (VAL: AssnState.Unary.sem_expr conf st invst0 expr = Some val) 181 | (INCL: incl (Exprs.Expr.get_idTs expr) (Assertion.get_idTs_unary inv)): 182 | <>. 183 | Proof. 184 | eapply filter_preserved_expr; eauto. apply forallb_forall. i. 185 | apply PRESERVED. apply INCL. ss. 186 | Qed. 187 | 188 | Lemma filter_spec 189 | conf st invst assnmem inv gmax public 190 | (preserved: _ -> bool) 191 | (PRESERVED: forall id (ID: In id (Assertion.get_idTs_unary inv)), preserved id) 192 | (STATE: AssnState.Unary.sem conf st invst assnmem gmax public inv): 193 | AssnState.Unary.sem conf st (filter preserved invst) assnmem gmax public inv. 194 | Proof. 195 | inv STATE. econs; eauto. 196 | - ii. 197 | exploit filter_subset_expr; eauto. i. des. 198 | exploit LESSDEF; eauto. i. des. 199 | exploit incl_implies_preserved; eauto. 200 | eapply incl_tran; [|eapply incl_tran]; swap 2 3. 201 | + apply incl_appr. apply incl_refl. 202 | + unfold Assertion.get_idTs_unary. 203 | apply incl_appl. apply incl_refl. 204 | + eapply In_map_incl in H. des. refine H. 205 | - inv NOALIAS. econs; i. 206 | + eapply DIFFBLOCK; eauto. 207 | * eapply filter_subset_valueT; eauto. 208 | * eapply filter_subset_valueT; eauto. 209 | + eapply NOALIAS0; eauto. 210 | * eapply filter_subset_valueT; eauto. 211 | * eapply filter_subset_valueT; eauto. 212 | - ii. exploit PRIVATE; eauto. 213 | eapply filter_subset_idT; eauto. 214 | - apply filter_AL_atom_preserves_wf_lc. eauto. 215 | - apply filter_AL_atom_preserves_wf_lc. eauto. 216 | Qed. 217 | End Filter. 218 | 219 | 220 | 221 | Lemma reduce_maydiff_lessdef_sound 222 | m_src m_tgt 223 | conf_src st_src 224 | conf_tgt st_tgt 225 | invst assnmem inv 226 | (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt) 227 | (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst assnmem inv) 228 | (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem): 229 | <>. 231 | Proof. 232 | inversion STATE. econs; eauto. ii. 233 | ss. rewrite IdTSetFacts.filter_b in NOTIN; [|solve_compat_bool]. 234 | repeat (des_bool; des); ss; cycle 2. 235 | { exploit MAYDIFF; eauto. } clear MAYDIFF. 236 | apply ExprPairSetFacts.exists_iff in NOTIN; [|solve_compat_bool]. 237 | red in NOTIN; des. 238 | apply ExprPairSetFacts.exists_iff in NOTIN0; [|solve_compat_bool]. 239 | red in NOTIN0; des. 240 | apply AssnState.get_lhs_in_spec in NOTIN0. 241 | apply AssnState.get_rhs_in_spec in NOTIN. 242 | destruct x, x0. ss. des. subst. 243 | rename id0 into idt. 244 | 245 | (* src lessdef x, t0 --> t0's result exists *) 246 | inv SRC. clear NOALIAS UNIQUE PRIVATE. 247 | exploit LESSDEF; eauto; []; ii; des. clear LESSDEF. 248 | 249 | (* inject_expr t0, t1 --> t1's result exists *) 250 | exploit AssnState.Rel.inject_expr_spec; eauto; []; ii; des. 251 | 252 | (* tgt t1, x --> x's result exists *) 253 | inv TGT. clear NOALIAS UNIQUE PRIVATE. 254 | exploit LESSDEF; eauto; []; ii; des. clear LESSDEF. 255 | 256 | (* val_src >= val_a >= val_tgt >= val_b *) 257 | esplits; eauto. 258 | exploit GVs.inject_lessdef_compose; eauto; []; ii; des. 259 | exploit GVs.lessdef_inject_compose; try exact x0; eauto. 260 | Qed. 261 | 262 | Lemma reduce_maydiff_preserved_sem_idT st_src st_tgt 263 | invst inv id val_src val_tgt 264 | (VAL_SRC: AssnState.Unary.sem_idT st_src 265 | (filter (reduce_maydiff_preserved inv) (AssnState.Rel.src invst)) id = 266 | Some val_src) 267 | (VAL_TGT: AssnState.Unary.sem_idT st_tgt (AssnState.Rel.tgt invst) id = Some val_tgt): 268 | <>. 270 | Proof. 271 | destruct id. unfold Ords.id.t in *. rename t0 into id. 272 | unfold AssnState.Unary.sem_idT in *. ss. 273 | unfold AssnState.Unary.sem_tag in *. ss. 274 | unfold compose in *. 275 | destruct t; ss. 276 | - rewrite <- VAL_TGT. 277 | rewrite lookup_AL_filter_spec in *. 278 | rewrite lookup_AL_filter_spec in VAL_SRC. (* WHY SHOULD I WRITE IT ONCE AGAIN?? *) 279 | des_ifs. 280 | - rewrite <- VAL_TGT. 281 | rewrite lookup_AL_filter_spec in *. 282 | rewrite lookup_AL_filter_spec in VAL_SRC. (* WHY SHOULD I WRITE IT ONCE AGAIN?? *) 283 | des_ifs. 284 | Qed. 285 | 286 | Lemma reduce_maydiff_non_physical_sound 287 | m_src m_tgt 288 | conf_src st_src 289 | conf_tgt st_tgt 290 | invst0 assnmem inv 291 | (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt) 292 | (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst0 assnmem inv) 293 | (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem): 294 | exists invst1, 295 | <>. 297 | Proof. 298 | exists (AssnState.Rel.update_both (filter (reduce_maydiff_preserved 299 | ((Assertion.get_idTs_unary inv.(Assertion.src)) 300 | ++ (Assertion.get_idTs_unary inv.(Assertion.tgt))))) invst0). 301 | red. 302 | inv STATE. 303 | econs; ss; cycle 2. 304 | - ii. ss. 305 | rewrite IdTSetFacts.filter_b in NOTIN; [|solve_compat_bool]. 306 | des_bool. des. 307 | + exploit MAYDIFF; eauto. 308 | { exploit filter_subset_idT; eauto. } 309 | i. des. esplits; eauto. 310 | eapply reduce_maydiff_preserved_sem_idT; eauto. 311 | + destruct id0. unfold Ords.id.t in *. 312 | rename t into __t__, t0 into __i__. 313 | unfold AssnState.Unary.sem_idT in VAL_SRC. ss. 314 | unfold AssnState.Unary.sem_tag in VAL_SRC. ss. 315 | unfold compose in *. 316 | destruct __t__; inv NOTIN. 317 | * rewrite lookup_AL_filter_spec in VAL_SRC. 318 | unfold Tag.t in *. rewrite H0 in VAL_SRC. ss. 319 | * rewrite lookup_AL_filter_spec in VAL_SRC. 320 | unfold Tag.t in *. rewrite H0 in VAL_SRC. ss. 321 | - apply filter_spec; ss. i. 322 | unfold reduce_maydiff_preserved. apply orb_true_iff. right. 323 | rewrite find_app. 324 | match goal with 325 | | [|- context[match ?g with | Some _ => _ | None => _ end]] => 326 | let COND := fresh "COND" in 327 | destruct g eqn:COND 328 | end; ss. 329 | eapply find_none in COND; [|eauto]. 330 | destruct (IdT.eq_dec id0 id0); ss. 331 | - apply filter_spec; ss. i. 332 | unfold reduce_maydiff_preserved. apply orb_true_iff. right. 333 | rewrite find_app. 334 | match goal with 335 | | [|- context[match ?g with | Some _ => _ | None => _ end]] => 336 | let COND := fresh "COND" in 337 | destruct g eqn:COND 338 | end; ss. 339 | apply In_eq_find. ss. 340 | Grab Existential Variables. 341 | { eauto. } 342 | Qed. 343 | -------------------------------------------------------------------------------- /coq/proof/SoundInfruleSubstitute.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | 13 | Require Import sflib. 14 | Require Import paco. 15 | Import Opsem. 16 | 17 | Require Import TODO. 18 | Require Import TODOProof. 19 | Require Import Decs. 20 | Require Import Exprs. 21 | Require Import Validator. 22 | Require Import GenericValues. 23 | Require Import Inject. 24 | Require AssnMem. 25 | Require AssnState. 26 | Require Import Hints. 27 | Require Import memory_props. 28 | Import Memory. 29 | Require Import opsem_wf. 30 | Require Import genericvalues_inject. 31 | Require Import memory_sim. 32 | Require Import MemAux. 33 | Require Import SoundBase. 34 | 35 | Set Implicit Arguments. 36 | 37 | 38 | Section NONE. 39 | 40 | Lemma subst_none_value 41 | conf st invst0 x v 42 | (NONE: AssnState.Unary.sem_idT st invst0 x = None) 43 | val1 44 | (SEM: AssnState.Unary.sem_valueT conf st invst0 v = Some val1) 45 | y 46 | : 47 | <> 48 | . 49 | Proof. 50 | red. 51 | destruct v; ss. 52 | des_ifs. 53 | Qed. 54 | 55 | Lemma subst_none_list_value 56 | conf st invst0 x 57 | (NONE: AssnState.Unary.sem_idT st invst0 x = None) 58 | l0 lsv 59 | (SEM: AssnState.Unary.sem_list_valueT conf st invst0 lsv = Some l0) 60 | y 61 | : 62 | < (fst x0, ValueT.substitute x y (snd x0))) lsv = lsv>> 63 | . 64 | Proof. 65 | red. 66 | ginduction lsv; ii; ss. 67 | des_ifs. ss. 68 | repeat erewrite subst_none_value; eauto. 69 | f_equal. 70 | eapply IHlsv; eauto. 71 | Qed. 72 | 73 | Lemma subst_none_expr 74 | conf st invst0 x e 75 | (NONE: AssnState.Unary.sem_idT st invst0 x = None) 76 | val1 77 | (SEM: AssnState.Unary.sem_expr conf st invst0 e = Some val1) 78 | y 79 | : 80 | <> 81 | . 82 | Proof. 83 | red. 84 | destruct e; ss; des_ifs. 85 | - ss. repeat erewrite subst_none_value; eauto. 86 | - ss. repeat erewrite subst_none_value; eauto. 87 | - ss. repeat erewrite subst_none_value; eauto. 88 | - ss. repeat erewrite subst_none_value; eauto. 89 | - ss. repeat erewrite subst_none_value; eauto. 90 | f_equal. 91 | erewrite subst_none_list_value; eauto. 92 | - ss. repeat erewrite subst_none_value; eauto. 93 | - ss. repeat erewrite subst_none_value; eauto. 94 | - ss. repeat erewrite subst_none_value; eauto. 95 | - ss. repeat erewrite subst_none_value; eauto. 96 | - ss. repeat erewrite subst_none_value; eauto. 97 | - ss. repeat erewrite subst_none_value; eauto. 98 | - ss. repeat erewrite subst_none_value; eauto. 99 | - ss. repeat erewrite subst_none_value; eauto. 100 | Qed. 101 | 102 | Lemma subst_none_value_rev 103 | conf st invst0 y v 104 | (NONE: AssnState.Unary.sem_valueT conf st invst0 y = None) 105 | x val1 106 | (SEM: AssnState.Unary.sem_valueT conf st invst0 (ValueT.substitute x y v) = Some val1) 107 | : 108 | <> 109 | . 110 | Proof. 111 | red. 112 | destruct v; ss. 113 | des_ifs. 114 | Qed. 115 | 116 | Lemma subst_none_list_value_rev 117 | conf st invst0 y 118 | (NONE: AssnState.Unary.sem_valueT conf st invst0 y = None) 119 | l0 lsv x 120 | (SEM: AssnState.Unary.sem_list_valueT 121 | conf st invst0 122 | (List.map (fun x0 : sz * ValueT.t => (fst x0, ValueT.substitute x y (snd x0))) lsv) = 123 | Some l0) 124 | : 125 | < (fst x0, ValueT.substitute x y (snd x0))) lsv = lsv>> 126 | . 127 | Proof. 128 | red. 129 | ginduction lsv; ii; ss. 130 | des_ifs. destruct a; ss. 131 | erewrite subst_none_value_rev; eauto. 132 | f_equal; ss. 133 | eapply IHlsv; eauto. 134 | Qed. 135 | 136 | Lemma subst_none_expr_rev 137 | conf st invst0 y e 138 | (NONE: AssnState.Unary.sem_valueT conf st invst0 y = None) 139 | x val1 140 | (SEM: AssnState.Unary.sem_expr conf st invst0 (Expr.substitute x y e) = Some val1) 141 | : 142 | <> 143 | . 144 | Proof. 145 | red. 146 | destruct e; ss; des_ifs; 147 | f_equal; try erewrite subst_none_value_rev; eauto. 148 | erewrite subst_none_list_value_rev; eauto. 149 | Qed. 150 | 151 | End NONE. 152 | 153 | 154 | 155 | Section SPEC. 156 | 157 | (* TODO: location *) 158 | Lemma const_eqb_refl_list 159 | l0 160 | (IH: Forall (fun a : const => const_eqb a a) l0) 161 | : 162 | (fix f (lc1 lc2 : list const) {struct lc1} : bool := 163 | match lc1 with 164 | | [] => match lc2 with 165 | | [] => true 166 | | _ :: _ => false 167 | end 168 | | hd1 :: tl1 => match lc2 with 169 | | [] => false 170 | | hd2 :: tl2 => const_eqb hd1 hd2 && f tl1 tl2 171 | end 172 | end) l0 l0 173 | . 174 | Proof. 175 | ginduction l0; ii; ss. 176 | inv IH. 177 | rewrite H1; ss. 178 | eapply IHl0; eauto. 179 | Qed. 180 | 181 | (* TODO: location *) 182 | Lemma const_eqb_refl 183 | a 184 | : 185 | <> 186 | . 187 | Proof. 188 | red. 189 | induction a using const_ind_gen; ss; unfold proj_sumbool in *; des_ifs; ss; 190 | repeat (apply andb_true_iff; split; ss); 191 | try (by eapply const_eqb_refl_list; eauto); ss. 192 | Qed. 193 | 194 | (* TODO: location *) 195 | Lemma forallb_const_eqb_refl 196 | lc 197 | : 198 | <> 199 | . 200 | Proof. 201 | red. 202 | ginduction lc; ii; ss. 203 | rewrite IHlc; ss. 204 | unfold proj_sumbool in *. 205 | apply andb_true_iff; split; ss. 206 | apply const_eqb_refl; ss. 207 | Qed. 208 | 209 | Lemma substitute_same_modulo_spec 210 | e from to 211 | : 212 | <> 213 | . 214 | Proof. 215 | red. 216 | destruct e; ss; unfold proj_sumbool in *; ss; des_ifs; ss. 217 | - apply andb_true_iff. split; ss. 218 | apply forallb_const_eqb_refl; ss. 219 | - apply forallb_const_eqb_refl; ss. 220 | - clear_tac. 221 | exfalso. ginduction lsv; ii; ss. 222 | apply n. f_equal. 223 | exploit IHlsv; try eassumption. 224 | { ii. rewrite <- H in *. ss. } 225 | i; ss. 226 | Qed. 227 | 228 | (* TODO: location *) 229 | Lemma map_valueTs_get_valueTs_spec 230 | f e 231 | : 232 | List.map f (Expr.get_valueTs e) = (Expr.get_valueTs (Expr.map_valueTs e f)) 233 | . 234 | Proof. 235 | destruct e; ss. 236 | f_equal. 237 | clear_tac. 238 | ginduction lsv; ii; ss. 239 | f_equal. eauto. 240 | Qed. 241 | 242 | Lemma substitute_lessdef_spec 243 | conf st invst0 244 | (from: IdT.t) (to: ValueT.t) 245 | (LDFROMTO : AssnState.Unary.sem_lessdef conf st invst0 (Expr.value from, Expr.value to)) 246 | e 247 | : 248 | Forall2 (fun v1 v2 : ValueT.t => 249 | AssnState.Unary.sem_lessdef conf st invst0 (Expr.value v1, Expr.value v2)) 250 | (Expr.get_valueTs e) (Expr.get_valueTs (Expr.substitute from to e)) 251 | . 252 | Proof. 253 | unfold Expr.substitute. 254 | rewrite <- map_valueTs_get_valueTs_spec. 255 | abstr (Expr.get_valueTs e) tt. 256 | clear_tac. 257 | ginduction tt; ii; ss. 258 | econs; eauto. 259 | ii; ss. 260 | destruct a; ss. 261 | - des_ifs. 262 | + eapply LDFROMTO; eauto. 263 | + esplits; eauto. 264 | eapply GVs.lessdef_refl. 265 | - esplits; eauto. 266 | eapply GVs.lessdef_refl. 267 | Qed. 268 | 269 | Lemma substitute_lessdef_spec_rev 270 | conf st invst0 271 | (from: IdT.t) (to: ValueT.t) 272 | (LDFROMTO : AssnState.Unary.sem_lessdef conf st invst0 (Expr.value to, Expr.value from)) 273 | e 274 | : 275 | Forall2 (fun v1 v2 : ValueT.t => 276 | AssnState.Unary.sem_lessdef conf st invst0 (Expr.value v1, Expr.value v2)) 277 | (Expr.get_valueTs (Expr.substitute from to e)) (Expr.get_valueTs e) 278 | . 279 | Proof. 280 | unfold Expr.substitute. 281 | rewrite <- map_valueTs_get_valueTs_spec. 282 | abstr (Expr.get_valueTs e) tt. 283 | clear_tac. 284 | ginduction tt; ii; ss. 285 | econs; eauto. 286 | ii; ss. 287 | destruct a; ss. 288 | - des_ifs. 289 | + eapply LDFROMTO; eauto. 290 | + esplits; eauto. 291 | eapply GVs.lessdef_refl. 292 | - esplits; eauto. 293 | eapply GVs.lessdef_refl. 294 | Qed. 295 | 296 | (* TODO: location *) 297 | Lemma same_modulo_value_comm 298 | a b 299 | (SAME: Expr.same_modulo_value a b) 300 | : 301 | <> 302 | (* <> <--- little harder to prove, skip *) 303 | . 304 | Proof. 305 | red. 306 | destruct a, b; ss; unfold proj_sumbool in *; des_ifs; unfold is_true in *; ss; des_bool; des; clear_tac. 307 | - apply AssnState.Rel.list_forallb_const_eqb in SAME. des. clarify. 308 | eapply forallb_const_eqb_refl; eauto. 309 | - ss. 310 | - apply AssnState.Rel.list_forallb_const_eqb in SAME. des. clarify. 311 | eapply forallb_const_eqb_refl; eauto. 312 | - rewrite e1 in *. ss. 313 | Qed. 314 | 315 | End SPEC. 316 | 317 | 318 | 319 | Section SOME. 320 | 321 | Lemma substitute_some_id 322 | conf st from to idt0 invst0 val0 from_gv to_gv 323 | (FROM: AssnState.Unary.sem_idT st invst0 from = Some from_gv) 324 | (TO: AssnState.Unary.sem_valueT conf st invst0 to = Some to_gv) 325 | (LD: GVs.lessdef from_gv to_gv) 326 | (SEM: AssnState.Unary.sem_idT st invst0 idt0 = Some val0) 327 | : 328 | exists val1 : GenericValue, 329 | <> 331 | /\ <> 332 | . 333 | Proof. 334 | des_ifs. 335 | - esplits; eauto. 336 | - esplits; eauto. 337 | eapply GVs.lessdef_refl. 338 | Qed. 339 | 340 | Lemma substitute_some_value 341 | conf st from to v0 invst0 val0 from_gv to_gv 342 | (FROM: AssnState.Unary.sem_idT st invst0 from = Some from_gv) 343 | (TO: AssnState.Unary.sem_valueT conf st invst0 to = Some to_gv) 344 | (LD: GVs.lessdef from_gv to_gv) 345 | (SEM: AssnState.Unary.sem_valueT conf st invst0 v0 = Some val0) 346 | : 347 | exists val1 : GenericValue, 348 | <> /\ 349 | <> 350 | . 351 | Proof. 352 | destruct v0; ss. 353 | - eapply substitute_some_id; eauto. 354 | - esplits; eauto. eapply GVs.lessdef_refl. 355 | Qed. 356 | 357 | Lemma substitute_some_expr 358 | conf st from to e invst0 val0 from_gv to_gv 359 | (FROM: AssnState.Unary.sem_idT st invst0 from = Some from_gv) 360 | (TO: AssnState.Unary.sem_valueT conf st invst0 to = Some to_gv) 361 | (LD: GVs.lessdef from_gv to_gv) 362 | (SEM: AssnState.Unary.sem_expr conf st invst0 e = Some val0) 363 | : 364 | exists val1 : GenericValue, 365 | <> /\ 366 | <> 367 | . 368 | Proof. 369 | eapply AssnState.Rel.lessdef_expr_spec3; eauto. 370 | { eapply substitute_same_modulo_spec; eauto. } 371 | { assert(LDFROMTO: AssnState.Unary.sem_lessdef conf st invst0 (Expr.value from, Expr.value to)). 372 | { ii; esplits; eauto. ss. rewrite VAL1 in *. clarify. } 373 | clear - LDFROMTO. 374 | eapply substitute_lessdef_spec; eauto. 375 | } 376 | Qed. 377 | 378 | Lemma substitute_some_expr_rev 379 | conf st from to e invst0 val0 from_gv to_gv 380 | (TO: AssnState.Unary.sem_valueT conf st invst0 to = Some to_gv) 381 | (FROM: AssnState.Unary.sem_idT st invst0 from = Some from_gv) 382 | (LD: GVs.lessdef to_gv from_gv) 383 | (SEM: AssnState.Unary.sem_expr conf st invst0 (Expr.substitute from to e) = Some val0) 384 | : 385 | exists val1 : GenericValue, 386 | <> /\ <> 387 | . 388 | Proof. 389 | eapply AssnState.Rel.lessdef_expr_spec3; eauto. 390 | { rewrite same_modulo_value_comm; ss. 391 | eapply substitute_same_modulo_spec; eauto. } 392 | { assert(LDFROMTO: AssnState.Unary.sem_lessdef conf st invst0 (Expr.value to, Expr.value from)). 393 | { ii; esplits; eauto. ss. rewrite VAL1 in *. clarify. } 394 | clear - LDFROMTO. 395 | eapply substitute_lessdef_spec_rev; eauto. 396 | } 397 | Qed. 398 | 399 | End SOME. 400 | 401 | Lemma substitute_spec_unary 402 | conf st x y e pubs gmax 403 | invst0 assnmem0 inv0 404 | (SEM: AssnState.Unary.sem conf st invst0 assnmem0 gmax pubs inv0) 405 | (LD: AssnState.Unary.sem_lessdef conf st invst0 406 | (Exprs.Expr.value (Exprs.ValueT.id x), Exprs.Expr.value y)) 407 | : 408 | <> 412 | . 413 | Proof. 414 | econs; eauto; try apply SEM. 415 | inv SEM. clear - LESSDEF LD. 416 | ii. 417 | apply Exprs.ExprPairSetFacts.add_iff in H. 418 | des; cycle 1. 419 | { eapply LESSDEF; eauto. } 420 | clear LESSDEF. 421 | clarify. ss. 422 | unfold AssnState.Unary.sem_lessdef in *. 423 | ss. 424 | destruct (AssnState.Unary.sem_idT st invst0 x) eqn:T; cycle 1. 425 | { clear LD. 426 | solve_leibniz. 427 | clear - VAL1 T. 428 | erewrite subst_none_expr; eauto. esplits; eauto. eapply GVs.lessdef_refl. 429 | } 430 | specialize (LD g eq_refl). des. 431 | clear_tac. 432 | solve_leibniz. 433 | eapply substitute_some_expr; eauto. 434 | Qed. 435 | 436 | Lemma substitute_spec_unary_rev 437 | conf st x y e pubs gmax 438 | invst0 assnmem0 inv0 439 | (SEM: AssnState.Unary.sem conf st invst0 assnmem0 gmax pubs inv0) 440 | (LD: AssnState.Unary.sem_lessdef conf st invst0 441 | (Exprs.Expr.value y, Exprs.Expr.value (Exprs.ValueT.id x))) 442 | : 443 | <> 447 | . 448 | Proof. 449 | econs; eauto; try apply SEM. 450 | inv SEM. clear - LESSDEF LD. 451 | ii. 452 | apply Exprs.ExprPairSetFacts.add_iff in H. 453 | des; cycle 1. 454 | { eapply LESSDEF; eauto. } 455 | clear LESSDEF. 456 | clarify. ss. 457 | unfold AssnState.Unary.sem_lessdef in *. 458 | ss. 459 | destruct (AssnState.Unary.sem_valueT conf st invst0 y) eqn:T; cycle 1. 460 | { clear LD. 461 | solve_leibniz. 462 | clear - VAL1 T. 463 | erewrite subst_none_expr_rev in VAL1; eauto. esplits; eauto. eapply GVs.lessdef_refl. 464 | } 465 | specialize (LD g eq_refl). des. 466 | clear_tac. 467 | solve_leibniz. 468 | eapply substitute_some_expr_rev; eauto. 469 | Qed. 470 | 471 | -------------------------------------------------------------------------------- /coq/proof/SoundInfruleTransitivity.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | 13 | Require Import sflib. 14 | Require Import paco. 15 | Import Opsem. 16 | 17 | Require Import TODO. 18 | Require Import TODOProof. 19 | Require Import Decs. 20 | Require Import Exprs. 21 | Require Import Validator. 22 | Require Import GenericValues. 23 | Require Import Inject. 24 | Require AssnMem. 25 | Require AssnState. 26 | Require Import Hints. 27 | Require Import memory_props. 28 | Import Memory. 29 | Require Import opsem_wf. 30 | Require Import genericvalues_inject. 31 | Require Import memory_sim. 32 | Require Import MemAux. 33 | Require Import SoundBase. 34 | 35 | Set Implicit Arguments. 36 | 37 | Lemma load_realign_sem_expr 38 | conf st invst e0 39 | : 40 | <> 42 | . 43 | Proof. 44 | red. 45 | unfold Infrules.load_realign. des_ifs; ss. 46 | Qed. 47 | 48 | -------------------------------------------------------------------------------- /coq/proof/SoundInfrules.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | 13 | Require Import sflib. 14 | Require Import paco. 15 | Import Opsem. 16 | 17 | Require Import TODO. 18 | Require Import Validator. 19 | Require Import GenericValues. 20 | Require AssnMem. 21 | Require AssnState. 22 | Require Import SoundBase. 23 | Require Import TODOProof. 24 | Require Import SoundInfruleIntroGhost. 25 | Require Import SoundInfruleSubstitute. 26 | Require Import SoundInfruleTransitivity. 27 | Require Import SoundInfruleReduceMaydiff. 28 | Require Import Exprs. 29 | 30 | Set Implicit Arguments. 31 | 32 | Lemma apply_not_interesting_infrule_sound 33 | m_src m_tgt 34 | conf_src st_src 35 | conf_tgt st_tgt 36 | invst0 assnmem0 inv0 37 | infrule 38 | (INTEREST: Hints.Infrule.is_of_interest infrule = false) 39 | (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt) 40 | (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst0 assnmem0 inv0) 41 | (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem0): 42 | exists invst1 assnmem1, 43 | <> /\ 45 | <> /\ 46 | <>. 47 | Proof. 48 | ADMIT "We will not prove the soundness of arithmetic infrules as Alive (SMT solver) can prove them. 49 | Also, we will not prove the soundness of infrules that are only used inside instcombine pass.". 50 | Qed. 51 | 52 | Lemma apply_interesting_infrule_sound 53 | m_src m_tgt 54 | conf_src st_src 55 | conf_tgt st_tgt 56 | invst0 assnmem0 inv0 57 | infrule 58 | (INTEREST: Hints.Infrule.is_of_interest infrule = true) 59 | (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt) 60 | (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst0 assnmem0 inv0) 61 | (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem0): 62 | exists invst1 assnmem1, 63 | <> /\ 65 | <> /\ 66 | <>. 67 | Proof. 68 | destruct infrule; compute in INTEREST; try (by contradict INTEREST). 69 | - (* transitivity *) 70 | exists invst0, assnmem0. splits; eauto; [|reflexivity]. 71 | ss. 72 | match goal with 73 | | [|- context[if ?c then _ else _]] => destruct c eqn:C 74 | end; ss. 75 | inv STATE. econs; eauto. ss. clear TGT MAYDIFF ALLOCAS. 76 | econs; try apply SRC; eauto; ss. 77 | red. i. apply Exprs.ExprPairSetFacts.add_iff in H. 78 | des; cycle 1. 79 | { eapply SRC; eauto. } 80 | destruct x; ss. clarify. 81 | rename t into __e0__. 82 | rename e2 into __e1__. 83 | rename t0 into __e2__. 84 | des_bool; des. 85 | abstr (AssnState.Rel.src invst0) invst. 86 | clear MEM CONF. clear_tac. 87 | solve_leibniz. clarify. 88 | assert(LD01: AssnState.Unary.sem_lessdef conf_src st_src invst (__e0__, __e1__)). 89 | { clear C0. repeat (des_bool; des). 90 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto. 91 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 92 | repeat rewrite <- load_realign_sem_expr; eauto. 93 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 94 | repeat rewrite <- load_realign_sem_expr; eauto. 95 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 96 | repeat rewrite <- load_realign_sem_expr; eauto. 97 | } 98 | assert(LD12: AssnState.Unary.sem_lessdef conf_src st_src invst (__e1__, __e2__)). 99 | { clear C. repeat (des_bool; des). 100 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto. 101 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 102 | repeat rewrite <- load_realign_sem_expr; eauto. 103 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 104 | repeat rewrite <- load_realign_sem_expr; eauto. 105 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 106 | repeat rewrite <- load_realign_sem_expr; eauto. 107 | } 108 | eapply AssnState.Unary.sem_lessdef_trans; eauto. 109 | - (* transitivity_tgt *) 110 | exists invst0, assnmem0. 111 | esplits; eauto; [ | reflexivity ]. 112 | ss. 113 | match goal with 114 | | [|- context[if ?c then _ else _]] => destruct c eqn:C 115 | end; ss. 116 | econs; eauto; try apply STATE. ss. 117 | inv STATE. clear - TGT C. 118 | des_bool; des. 119 | abstr (AssnState.Rel.tgt invst0) invst. 120 | econs; try apply TGT; eauto; ss. 121 | red. i. apply Exprs.ExprPairSetFacts.add_iff in H. 122 | des; cycle 1. 123 | { eapply TGT; eauto. } 124 | destruct x; ss. clarify. 125 | rename t into __e0__. 126 | rename e2 into __e1__. 127 | rename t0 into __e2__. 128 | solve_leibniz. clarify. 129 | assert(LD01: AssnState.Unary.sem_lessdef conf_tgt st_tgt invst (__e0__, __e1__)). 130 | { clear C0. repeat (des_bool; des). 131 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto. 132 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 133 | repeat rewrite <- load_realign_sem_expr; eauto. 134 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 135 | repeat rewrite <- load_realign_sem_expr; eauto. 136 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 137 | repeat rewrite <- load_realign_sem_expr; eauto. 138 | } 139 | assert(LD12: AssnState.Unary.sem_lessdef conf_tgt st_tgt invst (__e1__, __e2__)). 140 | { clear C. repeat (des_bool; des). 141 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto. 142 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 143 | repeat rewrite <- load_realign_sem_expr; eauto. 144 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 145 | repeat rewrite <- load_realign_sem_expr; eauto. 146 | - eapply AssnState.Rel.lessdef_expr_spec2; eauto; 147 | repeat rewrite <- load_realign_sem_expr; eauto. 148 | } 149 | eapply AssnState.Unary.sem_lessdef_trans; eauto. 150 | - (* substitute *) 151 | exists invst0, assnmem0. 152 | esplits; eauto; [ | reflexivity ]. 153 | ss. des_ifs. 154 | econs; eauto; try apply STATE. 155 | hexploit AssnState.Rel.lessdef_expr_spec2; eauto; try apply STATE. 156 | intro LD; des. clear Heq. 157 | inv STATE. clear - SRC LD. 158 | eapply substitute_spec_unary; eauto. 159 | - (* substitute_rev *) 160 | exists invst0, assnmem0. 161 | esplits; eauto; [ | reflexivity ]. 162 | ss. des_ifs. 163 | econs; eauto; try apply STATE. 164 | hexploit AssnState.Rel.lessdef_expr_spec2; eauto; try apply STATE. 165 | intro LD; des. clear Heq. 166 | inv STATE. clear - SRC LD. 167 | eapply substitute_spec_unary_rev; eauto. 168 | - (* substitute_tgt *) 169 | exists invst0, assnmem0. 170 | esplits; eauto; [ | reflexivity ]. 171 | ss. des_ifs. 172 | econs; eauto; try apply STATE. 173 | hexploit AssnState.Rel.lessdef_expr_spec2; eauto; try apply STATE. 174 | intro LD; des. clear Heq. 175 | inv STATE. clear - TGT LD. 176 | eapply substitute_spec_unary; eauto. 177 | - (* intro_ghost *) 178 | ss. des_ifs; cycle 1. 179 | { esplits; eauto. reflexivity. } 180 | repeat (des_bool; des). 181 | rename g into i0. 182 | rename x into x0. 183 | Local Opaque AssnState.Unary.clear_idt. 184 | destruct (AssnState.Unary.sem_expr conf_src st_src 185 | (AssnState.Rel.clear_idt (Exprs.Tag.ghost, i0) invst0).(AssnState.Rel.src) x0) eqn:T0; cycle 1. 186 | { 187 | exists (AssnState.Rel.clear_idt (Exprs.Tag.ghost, i0) invst0), assnmem0. 188 | splits; ss; eauto; [|reflexivity]. 189 | exploit clear_idt_ghost_spec; eauto. 190 | { instantiate (1:= (Exprs.Tag.ghost, i0)). ss. } 191 | intro STATE_CLEAR; des. 192 | clear - STATE_CLEAR T0. 193 | unfold Hints.Assertion.update_tgt, Hints.Assertion.update_src, Hints.Assertion.update_lessdef. ss. 194 | econs; eauto; try apply STATE_CLEAR. 195 | + ss. 196 | inv STATE_CLEAR. clear - SRC T0. 197 | 198 | econs; eauto; try apply SRC. 199 | ss. 200 | inv SRC. clear - LESSDEF T0. 201 | 202 | ii. 203 | apply Exprs.ExprPairSetFacts.add_iff in H. des. 204 | * solve_leibniz. clarify. ss. rewrite T0 in *. clarify. 205 | * eapply LESSDEF; eauto. 206 | + ss. 207 | inv STATE_CLEAR. clear - TGT T0. 208 | 209 | econs; eauto; try apply TGT. 210 | ss. 211 | inv TGT. clear - LESSDEF T0. 212 | 213 | ii. 214 | apply Exprs.ExprPairSetFacts.add_iff in H. des. 215 | * clarify. ss. 216 | assert(NONE: AssnState.Unary.sem_idT 217 | st_tgt (AssnState.Rel.tgt 218 | (AssnState.Rel.clear_idt 219 | (Exprs.Tag.ghost, i0) invst0)) (Exprs.Tag.ghost, i0) = None). 220 | { clear - i0. 221 | unfold AssnState.Unary.sem_idT. ss. 222 | ss. 223 | Local Transparent AssnState.Unary.clear_idt. ss. 224 | rewrite lookup_AL_filter_spec. des_ifs. des_bool; des_sumbool. ss. 225 | Local Opaque AssnState.Unary.clear_idt. 226 | } 227 | unfold AssnState.Rel.clear_idt in *. ss. 228 | solve_leibniz. clarify. ss. 229 | rewrite NONE in *. clarify. 230 | * ss. eapply LESSDEF; eauto. 231 | } 232 | rename T0 into GV_SRC. 233 | rename g into gv_src. 234 | assert(GV_TGT: exists gv_tgt, 235 | AssnState.Unary.sem_expr conf_tgt st_tgt 236 | (AssnState.Rel.clear_idt (Exprs.Tag.ghost, i0) invst0).(AssnState.Rel.tgt) x0 237 | = Some gv_tgt 238 | /\ genericvalues_inject.gv_inject assnmem0.(AssnMem.Rel.inject) gv_src gv_tgt). 239 | { 240 | hexploit AssnState.Rel.not_in_maydiff_expr_spec; try apply GV_SRC; try apply STATE; eauto. 241 | { ii. 242 | assert(id0 <> (Exprs.Tag.ghost, i0)). 243 | { 244 | ii. clarify. ss. 245 | exploit clear_idt_inv_spec_id; try eassumption; ss. 246 | i. unfold proj_sumbool in *. des_ifs. 247 | } 248 | ss. 249 | erewrite <- clear_idt_spec_id; ss; cycle 1. 250 | { unfold proj_sumbool. des_ifs. } 251 | inv STATE. 252 | eapply MAYDIFF; ss. 253 | erewrite clear_idt_spec_id; try eassumption; cycle 1. 254 | unfold proj_sumbool. des_ifs. 255 | } 256 | } 257 | des. rename GV_TGT0 into GV_INJ. 258 | des. 259 | 260 | exploit clear_idt_ghost_spec; eauto. 261 | { instantiate (1:= (Exprs.Tag.ghost, i0)). ss. } 262 | intro STATE_CLEAR; des. 263 | clear - STATE_CLEAR GV_SRC GV_TGT GV_INJ MEM. 264 | 265 | exists (cons_idt (Exprs.Tag.ghost, i0) gv_src gv_tgt 266 | (AssnState.Rel.clear_idt (Exprs.Tag.ghost, i0) invst0)), assnmem0. 267 | splits; ss; eauto; [|reflexivity]. 268 | { 269 | econs; eauto; try apply STATE_CLEAR. 270 | - ss. 271 | eapply Subset_unary_sem; eauto. 272 | eapply cons_ghost_unary_spec; try apply STATE_CLEAR; eauto. 273 | { eapply sem_expr_preserves_valid_ptr; try apply STATE_CLEAR; try apply MEM; eauto. } 274 | unfold compose. 275 | econs; ss; eauto. 276 | + ii. apply Exprs.ExprPairSetFacts.add_iff. right. ss. 277 | + split; ss. 278 | - ss. 279 | eapply Subset_unary_sem; eauto. 280 | eapply cons_ghost_unary_spec; try apply STATE_CLEAR; eauto. 281 | { eapply sem_expr_preserves_valid_ptr; try apply STATE_CLEAR; try apply MEM; eauto. } 282 | unfold compose. 283 | econs; ss; eauto. 284 | + ii. 285 | apply Exprs.ExprPairSetFacts.add_iff in H. des. 286 | { apply Exprs.ExprPairSetFacts.add_iff. left. ss. } 287 | apply Exprs.ExprPairSetFacts.add_iff. right. 288 | apply Exprs.ExprPairSetFacts.add_iff. right. ss. 289 | + split; ss. 290 | - i. 291 | unfold Hints.Assertion.update_lessdef in NOTIN. ss. 292 | inv STATE_CLEAR. 293 | clear SRC TGT TGT_NOUNIQ ALLOCAS. 294 | ii. ss. 295 | destruct (Exprs.IdT.eq_dec id0 (Exprs.Tag.ghost, i0)). 296 | { clarify. 297 | unfold AssnState.Unary.sem_idT in *. ss. des_ifs. 298 | esplits; eauto. 299 | } 300 | erewrite <- cons_idt_spec_id in VAL_SRC; cycle 1. 301 | { unfold proj_sumbool; des_ifs. } 302 | erewrite <- cons_idt_spec_id; cycle 1. 303 | { unfold proj_sumbool; des_ifs. } 304 | eapply MAYDIFF; eauto. 305 | } 306 | - (* intro_eq_tgt *) 307 | exists invst0, assnmem0. splits; eauto; [|reflexivity]. 308 | inv STATE. econs; eauto. ss. 309 | inv TGT. econs; eauto. ss. 310 | ii. apply Exprs.ExprPairSetFacts.add_iff in H. des. 311 | + subst. solve_leibniz. clarify. esplits; eauto. apply GVs.lessdef_refl. 312 | + eapply LESSDEF; eauto. 313 | - exploit reduce_maydiff_lessdef_sound; eauto. i. 314 | esplits; eauto. reflexivity. 315 | - exploit reduce_maydiff_non_physical_sound; eauto. i. des. 316 | esplits; eauto. reflexivity. 317 | Qed. 318 | 319 | 320 | Lemma apply_infrule_sound 321 | m_src m_tgt 322 | conf_src st_src 323 | conf_tgt st_tgt 324 | invst0 assnmem0 inv0 325 | infrule 326 | (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt) 327 | (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst0 assnmem0 inv0) 328 | (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem0): 329 | exists invst1 assnmem1, 330 | <> /\ 332 | <> /\ 333 | <>. 334 | Proof. 335 | destruct (Hints.Infrule.is_of_interest infrule) eqn:T; ss. 336 | - eapply apply_interesting_infrule_sound; eauto. 337 | - eapply apply_not_interesting_infrule_sound; eauto. 338 | Qed. 339 | 340 | Lemma apply_infrules_sound 341 | m_src m_tgt 342 | conf_src st_src 343 | conf_tgt st_tgt 344 | invst0 assnmem0 inv0 345 | infrules 346 | (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt) 347 | (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst0 assnmem0 inv0) 348 | (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem0): 349 | exists invst1 assnmem1, 350 | <> /\ 352 | <> /\ 353 | <>. 354 | Proof. 355 | unfold Infrules.apply_infrules. rewrite <- fold_left_rev_right. 356 | move infrules at top. revert_until infrules. induction (rev infrules); i. 357 | - esplits; eauto. reflexivity. 358 | - exploit IHl0; eauto. i. des. 359 | exploit apply_infrule_sound; eauto. i. des. 360 | esplits; eauto. 361 | etransitivity; eauto. 362 | Qed. 363 | -------------------------------------------------------------------------------- /coq/proof/SoundPostcondCmd.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | Require Import memory_props. 13 | 14 | Require Import sflib. 15 | Require Import paco. 16 | Import Opsem. 17 | 18 | Require Import TODO. 19 | Require Import TODOProof. 20 | Require Import Exprs. 21 | Require Import Hints. 22 | Require Import Postcond. 23 | Require Import Validator. 24 | Require Import GenericValues. 25 | Require AssnMem. 26 | Require AssnState. 27 | Require Import Inject. 28 | Require Import SoundBase. 29 | Require Import SoundForgetStack. 30 | Require Import SoundForgetMemory. 31 | Require Import SoundPostcondCmdAdd. 32 | Require Import MemAux. 33 | 34 | Set Implicit Arguments. 35 | 36 | 37 | Lemma postcond_cmd_is_call 38 | c_src c_tgt inv1 inv2 39 | (POSTCOND: Postcond.postcond_cmd c_src c_tgt inv1 = Some inv2): 40 | Instruction.isCallInst c_src = Instruction.isCallInst c_tgt. 41 | Proof. 42 | unfold 43 | Postcond.postcond_cmd, 44 | Postcond.postcond_cmd_check in *. 45 | destruct c_src, c_tgt; ss; des_ifs. 46 | Qed. 47 | 48 | Lemma noncall_event 49 | conf st0 st1 evt cmd cmds 50 | (STEP: sInsn conf st0 st1 evt) 51 | (CMDS: st0.(EC).(CurCmds) = cmd::cmds) 52 | (NONCALL: Instruction.isCallInst cmd = false): 53 | evt = events.E0. 54 | Proof. 55 | inv STEP; ss. inv CMDS. ss. 56 | Qed. 57 | 58 | (* TODO: move this *) 59 | 60 | Lemma postcond_cmd_check_forgets_Subset 61 | cmd_src cmd_tgt inv0 62 | (COND : postcond_cmd_check 63 | cmd_src cmd_tgt 64 | (AtomSetImpl_from_list (Cmd.get_def cmd_src)) 65 | (AtomSetImpl_from_list (Cmd.get_def cmd_tgt)) 66 | (AtomSetImpl_from_list (Cmd.get_ids cmd_src)) 67 | (AtomSetImpl_from_list (Cmd.get_ids cmd_tgt)) 68 | (ForgetStack.t 69 | (AtomSetImpl_from_list (Cmd.get_def cmd_src)) 70 | (AtomSetImpl_from_list (Cmd.get_def cmd_tgt)) 71 | (AtomSetImpl_from_list (Cmd.get_leaked_ids cmd_src)) 72 | (AtomSetImpl_from_list (Cmd.get_leaked_ids cmd_tgt)) 73 | (ForgetMemory.t 74 | (Cmd.get_def_memory cmd_src) (Cmd.get_def_memory cmd_tgt) 75 | (Cmd.get_leaked_ids_to_memory cmd_src) (Cmd.get_leaked_ids_to_memory cmd_tgt) 76 | inv0)) = true) 77 | : postcond_cmd_check 78 | cmd_src cmd_tgt 79 | (AtomSetImpl_from_list (Cmd.get_def cmd_src)) 80 | (AtomSetImpl_from_list (Cmd.get_def cmd_tgt)) 81 | (AtomSetImpl_from_list (Cmd.get_ids cmd_src)) 82 | (AtomSetImpl_from_list (Cmd.get_ids cmd_tgt)) 83 | inv0 = true. 84 | Proof. 85 | unfold postcond_cmd_check in *. 86 | des_ifs. 87 | clear -Heq1 Heq2. 88 | rename Heq1 into INJECT_F. rename Heq2 into INJECT_T. 89 | apply negb_false_iff in INJECT_T. 90 | apply negb_true_iff in INJECT_F. 91 | exploit postcond_cmd_inject_event_Subset; eauto; 92 | (etransitivity; [apply forget_stack_Subset | apply forget_memory_Subset]). 93 | Qed. 94 | 95 | Lemma step_wf_lc 96 | conf st0 st1 evt 97 | cmd cmds 98 | (WF_LC: MemProps.wf_lc st0.(Mem) st0.(EC).(Locals)) 99 | (STEP: sInsn conf st0 st1 evt) 100 | (CMDS: st0.(EC).(CurCmds) = cmd :: cmds) 101 | (NONCALL: Instruction.isCallInst cmd = false) 102 | (NONMALLOC: isMallocInst cmd = false) 103 | gmax public assnmem0 104 | (MEM: AssnMem.Unary.sem conf gmax public st0.(Mem) assnmem0) 105 | : <> /\ 106 | <>. 107 | Proof. 108 | inv MEM. 109 | clear PRIVATE_PARENT MEM_PARENT UNIQUE_PARENT_MEM UNIQUE_PARENT_GLOBALS UNIQUE_PRIVATE_PARENT. 110 | inv STEP; destruct cmd; ss; 111 | try (split; [apply MemProps.updateAddAL__wf_lc; eauto; [] | by auto]); clarify. 112 | - 113 | eapply opsem_props.OpsemProps.BOP_inversion in H. 114 | des. 115 | eapply MemProps.mbop_preserves_valid_ptrs; eauto. 116 | - 117 | eapply opsem_props.OpsemProps.FBOP_inversion in H. 118 | des. 119 | eapply MemProps.mfbop_preserves_valid_ptrs; eauto. 120 | - 121 | eapply MemProps.extractGenericValue_preserves_valid_ptrs; eauto. 122 | (* unfold MemProps.wf_Mem in *. *) 123 | (* des. clear WF. *) 124 | eapply get_operand_valid_ptr; eauto. 125 | - 126 | eapply MemProps.insertGenericValue_preserves_valid_ptrs; eauto. 127 | + eapply get_operand_valid_ptr; eauto. 128 | + eapply get_operand_valid_ptr; eauto. 129 | - split. (* free *) 130 | + eapply MemProps.free_preserves_wf_lc; eauto. 131 | + eapply MemProps.free_preserves_wf_Mem; eauto. 132 | - split. (* alloca *) 133 | + exploit alloca_result; eauto. i. des. 134 | ii. destruct (id_dec id0 id5). 135 | * subst. 136 | rewrite lookupAL_updateAddAL_eq in *. clarify. ss. 137 | split; auto. 138 | rewrite NEXT_BLOCK. apply Plt_succ. 139 | * rewrite <- lookupAL_updateAddAL_neq in *; eauto. 140 | eapply MemProps.alloca_preserves_wf_lc_in_tail; eauto. 141 | + eapply MemProps.alloca_preserves_wf_Mem; eauto. 142 | - unfold MemProps.wf_Mem in *. des. 143 | eapply WF; eauto. 144 | - (* store *) 145 | assert(WF_LC2: MemProps.wf_lc Mem' lc). 146 | { eapply MemProps.mstore_preserves_wf_lc; eauto. } 147 | splits; eauto. 148 | red. 149 | (* exploit mstore_aux_valid_ptrs_preserves_wf_Mem; eauto. *) 150 | unfold MemProps.wf_Mem in *. 151 | des. 152 | eapply mstore_inversion in H1. des. clarify. 153 | exploit MemProps.nextblock_mstore_aux; eauto; []; intros NEXTBLOCK_SAME; des. 154 | splits; cycle 1. 155 | * 156 | rewrite <- NEXTBLOCK_SAME. 157 | ss. 158 | * 159 | ii. 160 | apply mload_inv in H1. des. clarify. 161 | exploit MemProps.mstore_aux_preserves_mload_aux_inv; eauto; []; ii; des. 162 | eapply MemProps.valid_ptrs_overlap; eauto. 163 | { eapply get_operand_valid_ptr; eauto. 164 | exploit mstore_aux_valid_ptrs_preserves_wf_Mem; eauto. 165 | { instantiate (1:= {| CurSystem := S; 166 | CurTargetData := TD; 167 | CurProducts := Ps; 168 | Globals := gl; 169 | FunTable := fs|}). ss. 170 | instantiate (1:= gmax). ss. } 171 | { eapply get_operand_valid_ptr; eauto. splits; ss. } 172 | ii; ss. } 173 | { 174 | rewrite <- NEXTBLOCK_SAME. 175 | eapply WF; eauto. 176 | Check ([(Values.Vptr b0 ofs0, cm)]): mptr. 177 | instantiate (3:= ([(Values.Vptr b0 ofs0, cm)])). 178 | cbn. 179 | erewrite H4. ss. } 180 | - 181 | eapply dopsem.GEP_inv in H1. des. 182 | + eapply MemProps.undef_valid_ptrs; eauto. 183 | + clarify. 184 | exploit get_operand_valid_ptr; eauto. 185 | - 186 | eapply opsem_props.OpsemProps.TRUNC_inversion in H. 187 | des. 188 | eapply MemProps.mtrunc_preserves_valid_ptrs; eauto. 189 | - 190 | eapply opsem_props.OpsemProps.EXT_inversion in H. 191 | des. 192 | eapply MemProps.mext_preserves_valid_ptrs; eauto. 193 | - 194 | eapply opsem_props.OpsemProps.CAST_inversion in H. 195 | des. 196 | eapply MemProps.mcast_preserves_valid_ptrs; eauto. 197 | eapply get_operand_valid_ptr; eauto. 198 | - 199 | eapply opsem_props.OpsemProps.ICMP_inversion in H. 200 | des. 201 | eapply MemProps.micmp_preserves_valid_ptrs; eauto. 202 | - 203 | eapply opsem_props.OpsemProps.FCMP_inversion in H. 204 | des. 205 | eapply MemProps.mfcmp_preserves_valid_ptrs; eauto. 206 | - unfold SELECT in *. des_ifs. 207 | unfold mselect, fit_chunk_gv in *. 208 | des_ifs; try (by eapply get_operand_valid_ptr; eauto); 209 | try (by eapply MemProps.undef_valid_ptrs; eauto). 210 | Unshelve. 211 | ss. 212 | Qed. 213 | 214 | Lemma disjoint_allocas_private_parent 215 | conf_unary st0_unary cmd_unary cmds_unary unary unary0 gmax evt 216 | st1_unary unary1 gmax0 inv public_unary0 public_unary 217 | (NONCALL_UNARY: Instruction.isCallInst cmd_unary = false) 218 | (CMDS_UNARY: CurCmds (EC st0_unary) = cmd_unary :: cmds_unary) 219 | (STEP_UNARY: sInsn conf_unary st0_unary st1_unary evt) 220 | (STATE_FORGET_MEMORY_UNARY: AssnState.Unary.sem conf_unary 221 | (mkState (EC st0_unary) (ECS st0_unary) (Mem st1_unary)) 222 | unary unary1 gmax0 public_unary0 inv) 223 | (MEMLE_UNARY: AssnMem.Unary.le unary0 unary1) 224 | (UNARY: AssnMem.Unary.sem conf_unary gmax public_unary (Mem st0_unary) unary0) 225 | : 226 | <> 227 | . 228 | Proof. 229 | inv STEP_UNARY; try apply STATE_FORGET_MEMORY_UNARY; cbn. 230 | - (* return *) 231 | clarify. 232 | - (* return_void *) 233 | clarify. 234 | - ss. 235 | assert(PARENT: list_disjoint (als) (AssnMem.Unary.private_parent unary1)). 236 | { apply STATE_FORGET_MEMORY_UNARY. } 237 | apply list_disjoint_cons_l; eauto. 238 | { 239 | ss. expl alloca_result. clarify. ss. 240 | intro MB_PRIVATE_PARENT0. 241 | assert(MB_PRIVATE_PARENT1: In (Memory.Mem.nextblock Mem0) 242 | (AssnMem.Unary.private_parent unary0)). 243 | { 244 | inv MEMLE_UNARY. rewrite PRIVATE_PARENT_EQ. ss. 245 | } 246 | clear - UNARY MB_PRIVATE_PARENT1. 247 | inv UNARY. ss. 248 | expl PRIVATE_PARENT. 249 | unfold AssnMem.private_block in PRIVATE_PARENT0. 250 | des. 251 | expl Pos.lt_irrefl. 252 | } 253 | - ss. (* call *) 254 | Qed. 255 | 256 | Lemma sublist_app_inv 257 | A 258 | (xs ys zs: list A) 259 | (SUB: sublist (zs ++ xs) ys) 260 | : 261 | <> 262 | . 263 | Proof. 264 | ginduction ys; ii; ss. 265 | - inv SUB. expl nil_eq_app. clarify. econs; eauto. 266 | - inv SUB. 267 | + expl nil_eq_app. clarify. econs; eauto. 268 | + destruct zs; ss. 269 | { clarify. econs; eauto. } 270 | { clarify. econs; eauto. eapply IHys; eauto. } 271 | + econs; eauto. eapply IHys; eauto. 272 | Qed. 273 | 274 | Lemma sublist_cons_inv 275 | A 276 | (xs ys: list A) 277 | x 278 | (SUB: sublist (x :: xs) ys) 279 | : 280 | <> 281 | . 282 | Proof. 283 | eapply sublist_app_inv. 284 | instantiate (1:= [x]). 285 | ss. 286 | Qed. 287 | 288 | Lemma step_wf_EC 289 | st0 290 | (WF: OpsemAux.wf_EC st0.(EC)) 291 | cmd cmds 292 | (CMDS: st0.(EC).(CurCmds) = cmd :: cmds) 293 | (NONCALL: Instruction.isCallInst cmd = false) 294 | conf st1 tr 295 | (STEP: sInsn conf st0 st1 tr) 296 | : 297 | <> 298 | . 299 | Proof. 300 | inv WF. 301 | inv STEP; ss; try (by econs; ss; eauto; [eapply sublist_cons_inv; eauto]). 302 | - des_ifs. 303 | Qed. 304 | 305 | Lemma postcond_cmd_sound 306 | m_src conf_src st0_src cmd_src cmds_src 307 | m_tgt conf_tgt st0_tgt cmd_tgt cmds_tgt 308 | invst0 assnmem0 inv0 309 | st1_tgt evt inv1 310 | (WF_CONF_SRC: opsem_wf.OpsemPP.wf_Config conf_src) 311 | (WF_CONF_TGT: opsem_wf.OpsemPP.wf_Config conf_tgt) 312 | (WF_STATE_PREV_SRC: opsem_wf.OpsemPP.wf_State conf_src st0_src) 313 | (WF_STATE_PREV_TGT: opsem_wf.OpsemPP.wf_State conf_tgt st0_tgt) 314 | (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt) 315 | (POSTCOND: Postcond.postcond_cmd cmd_src cmd_tgt inv0 = Some inv1) 316 | (STATE: AssnState.Rel.sem conf_src conf_tgt st0_src st0_tgt invst0 assnmem0 inv0) 317 | (MEM: AssnMem.Rel.sem conf_src conf_tgt st0_src.(Mem) st0_tgt.(Mem) assnmem0) 318 | (STEP_TGT: sInsn conf_tgt st0_tgt st1_tgt evt) 319 | (CMDS_SRC: st0_src.(EC).(CurCmds) = cmd_src :: cmds_src) 320 | (CMDS_TGT: st0_tgt.(EC).(CurCmds) = cmd_tgt :: cmds_tgt) 321 | (NONCALL_SRC: Instruction.isCallInst cmd_src = false) 322 | (NONCALL_TGT: Instruction.isCallInst cmd_tgt = false) 323 | (NERROR_SRC: ~ error_state conf_src st0_src): 324 | exists st1_src invst1 assnmem1, 325 | <> /\ 326 | <> /\ 327 | <> /\ 328 | <>. 329 | Proof. 330 | assert(NONMALLOC_SRC: isMallocInst cmd_src = false). 331 | { destruct cmd_src; ss. 332 | unfold postcond_cmd in *. ss. 333 | unfold postcond_cmd_check in *. ss. 334 | des_ifs. } 335 | assert(NONMALLOC_TGT: isMallocInst cmd_tgt = false). 336 | { destruct cmd_tgt; ss. 337 | unfold postcond_cmd in *. ss. 338 | unfold postcond_cmd_check in *. ss. 339 | unfold postcond_cmd_inject_event in *. des_ifs. } 340 | exploit postcond_cmd_is_call; eauto. i. 341 | unfold postcond_cmd in *. simtac. 342 | match goal with 343 | | [H: Instruction.isCallInst cmd_src = false |- _] => 344 | rename H into NONCALL_SRC 345 | end. 346 | 347 | destruct (s_isFinalState conf_src st0_src) eqn:FINAL. 348 | { unfold s_isFinalState in FINAL. des_ifs. } 349 | exploit nerror_nfinal_nstuck; eauto. intros [st1_src [evt_src STEP_SRC]]. 350 | replace evt_src with evt in *; cycle 1. 351 | { unfold postcond_cmd_check in COND. simtac. 352 | exploit (@noncall_event conf_src); eauto. i. 353 | exploit (@noncall_event conf_tgt); eauto. i. 354 | subst. ss. 355 | } 356 | exploit postcond_cmd_check_forgets_Subset; eauto. intro COND_INIT. 357 | 358 | (* forget-memory *) 359 | exploit forget_memory_sound; eauto. 360 | { unfold postcond_cmd_check in COND_INIT. 361 | des_ifs. des_bool. eauto. } 362 | i. des. 363 | rename STATE0 into STATE_FORGET_MEMORY. 364 | rename MEM0 into MEM_FORGET_MEMORY. 365 | 366 | (* forget *) 367 | exploit forget_stack_sound. 368 | instantiate (5 := {| EC := EC st0_src; ECS := ECS st0_src; Mem := Mem st1_src |}). 369 | instantiate (4 := {| EC := EC st0_tgt; ECS := ECS st0_tgt; Mem := Mem st1_tgt |}). 370 | { eauto. } 371 | { hexploit step_state_equiv_except; try exact CMDS_SRC; eauto. } 372 | { hexploit step_state_equiv_except; try exact CMDS_TGT; eauto. } 373 | { inv STATE_FORGET_MEMORY. inv MEM_FORGET_MEMORY. 374 | eapply step_unique_preserved_except; try exact CMDS_SRC; eauto. 375 | apply STATE. 376 | inv MEMLE. inv SRC1. 377 | rewrite <- PRIVATE_PARENT_EQ. ss. 378 | apply MEM. } 379 | { inv STATE_FORGET_MEMORY. inv MEM_FORGET_MEMORY. 380 | eapply step_unique_preserved_except; try exact CMDS_TGT; eauto. 381 | apply STATE. 382 | inv MEMLE. inv TGT1. 383 | rewrite <- PRIVATE_PARENT_EQ. ss. 384 | apply MEM. } 385 | { eapply step_wf_lc; try exact STEP_SRC; eauto. 386 | - apply STATE. 387 | - apply MEM. } 388 | { eapply step_wf_lc; try exact STEP_TGT; eauto. 389 | - apply STATE. 390 | - apply MEM. } 391 | { ss. inv STEP_SRC; ss. clarify. } 392 | { ss. inv STEP_TGT; ss. clarify. } 393 | { Ltac apply_goal H := apply H. 394 | hexploit disjoint_allocas_private_parent; try apply CMDS_SRC; 395 | try (all apply_goal); eauto. 396 | } 397 | { 398 | hexploit disjoint_allocas_private_parent; try apply CMDS_TGT; 399 | try (all apply_goal); eauto. 400 | } 401 | { ss. } 402 | { ss. } 403 | { ss. } 404 | { eapply step_wf_EC; try apply STEP_SRC; eauto. apply STATE. } 405 | { eapply step_wf_EC; try apply STEP_TGT; eauto. apply STATE. } 406 | i. des. 407 | 408 | hexploit postcond_cmd_add_sound; try apply CONF; try eapply STEP_SRC; try eapply MEMLE; 409 | try eapply STEP_TGT; try apply x1; (* needed to prohibit applying STATE *) eauto; []; ii; des. 410 | esplits; eauto. 411 | etransitivity; eauto. 412 | Qed. 413 | -------------------------------------------------------------------------------- /coq/proof/SoundReduceMaydiff.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | 13 | Require Import sflib. 14 | Require Import paco. 15 | Import Opsem. 16 | 17 | Require Import TODO. 18 | Require Import Exprs. 19 | Require Import Hints. 20 | Require Import Postcond. 21 | Require Import Validator. 22 | Require Import GenericValues. 23 | Require AssnMem. 24 | Require AssnState. 25 | 26 | Set Implicit Arguments. 27 | 28 | 29 | Lemma project_into_IdT_spec e x: 30 | project_into_IdT e = Some x <-> e = Expr.value (ValueT.id x). 31 | Proof. 32 | destruct e; ss. des_ifs. 33 | split; inversion 1; auto. 34 | Qed. 35 | 36 | Lemma project_into_IdTSet_In s x: 37 | IdTSet.In x (project_into_IdTSet s) -> 38 | exists e, ExprPairSet.In (Expr.value (ValueT.id x), e) s. 39 | Proof. 40 | unfold project_into_IdTSet. i. 41 | rewrite ExprPairSet.fold_1 in *. 42 | rewrite <- fold_left_rev_right in *. 43 | remember (rev (ExprPairSet.elements s)) as s_elem. 44 | 45 | assert (incl s_elem (rev (ExprPairSet.elements s))). 46 | { subst. apply incl_refl. } 47 | clear Heqs_elem. 48 | 49 | induction s_elem; i. 50 | { ss. inversion H. } 51 | 52 | destruct a as [a1 a2]. ss. 53 | des_ifs. 54 | - rewrite IdTSetFacts.add_iff in *. des. 55 | + rewrite project_into_IdT_spec in *. subst. 56 | exploit IdT.compare_leibniz; eauto. i. subst. 57 | exists a2. 58 | rewrite ExprPairSetFacts.elements_iff. 59 | eapply InA_equiv with (eqB:=eq). 60 | { split. 61 | - apply ExprPair.compare_leibniz. 62 | - inversion 1. apply ExprPairFacts.compare_refl. 63 | } 64 | apply InA_iff_In. 65 | apply in_rev. 66 | unfold ExprPairSet.elt in *. 67 | exploit elim_incl_cons; eauto. i. des. eauto. 68 | + exploit IHs_elem; eauto. 69 | exploit elim_incl_cons; eauto. i. des. eauto. 70 | - exploit IHs_elem; eauto. 71 | exploit elim_incl_cons; eauto. i. des. eauto. 72 | Qed. 73 | 74 | Lemma reduce_maydiff_sound 75 | m_src m_tgt 76 | conf_src st_src 77 | conf_tgt st_tgt 78 | invst assnmem inv 79 | (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt) 80 | (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst assnmem inv) 81 | (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem): 82 | exists invst1, 83 | <>. 85 | Proof. 86 | exists invst. 87 | unfold reduce_maydiff. red. 88 | inv STATE. 89 | econs; ss. intro x. i. 90 | 91 | rewrite IdTSetFacts.diff_b in NOTIN. des_bool. des. 92 | { apply MAYDIFF. auto. } 93 | 94 | des_bool. 95 | rewrite <- IdTSetFacts.mem_iff in NOTIN. 96 | apply project_into_IdTSet_In in NOTIN. des. 97 | 98 | rewrite ExprPairSetFacts.filter_iff in NOTIN; [|solve_compat_bool]. 99 | rewrite ExprPairSetFacts.filter_iff in NOTIN; [|solve_compat_bool]. 100 | rewrite ExprPairSetFacts.filter_iff in NOTIN; [|solve_compat_bool]. 101 | des. unfold swap_pair in *. ss. 102 | rewrite <- ExprPairSetFacts.mem_iff in *. 103 | 104 | ii. 105 | inv SRC. rename LESSDEF into LESSDEF_SRC. 106 | exploit LESSDEF_SRC; eauto. i. des. ss. 107 | 108 | exploit AssnState.Rel.not_in_maydiff_expr_spec; eauto. 109 | i. des. 110 | 111 | inv TGT. rename LESSDEF into LESSDEF_TGT. 112 | exploit LESSDEF_TGT; eauto. i. des. ss. 113 | esplits; eauto. 114 | 115 | eapply GVs.inject_lessdef_compose; eauto. 116 | eapply GVs.lessdef_inject_compose; eauto. 117 | Qed. 118 | -------------------------------------------------------------------------------- /coq/proof/ValidAux.v: -------------------------------------------------------------------------------- 1 | Require Import syntax. 2 | Require Import alist. 3 | Require Import FMapWeakList. 4 | 5 | Require Import Classical. 6 | Require Import Coqlib. 7 | Require Import infrastructure. 8 | Require Import Metatheory. 9 | Import LLVMsyntax. 10 | Import LLVMinfra. 11 | Require Import opsem. 12 | 13 | Require Import sflib. 14 | Require Import paco. 15 | Import Opsem. 16 | 17 | Require Import TODO. 18 | Require Import Decs. 19 | Require Import Hints. 20 | Require Import Validator. 21 | Require Import GenericValues. 22 | Require Import OpsemAux. 23 | Require Import SimulationLocal. 24 | Require Import Simulation. 25 | Require Import Inject. 26 | Require AssnMem. 27 | Require AssnState. 28 | Require Import SoundBase. 29 | 30 | Set Implicit Arguments. 31 | 32 | 33 | Lemma valid_fdef_valid_stmts 34 | m_src m_tgt fdef_src fdef_tgt fdef_hint l 35 | phinodes_src cmds_src terminator_src 36 | phinodes_tgt cmds_tgt terminator_tgt 37 | stmts_hint 38 | (FDEF: valid_fdef m_src m_tgt fdef_src fdef_tgt fdef_hint) 39 | (SRC: lookupAL stmts (get_blocks fdef_src) l = Some (stmts_intro phinodes_src cmds_src terminator_src)) 40 | (TGT: lookupAL stmts (get_blocks fdef_tgt) l = Some (stmts_intro phinodes_tgt cmds_tgt terminator_tgt)) 41 | (HINT: lookupAL _ fdef_hint l = Some stmts_hint): 42 | exists inv_term infrules, 43 | <> /\ 47 | <>. 52 | Proof. 53 | unfold valid_fdef in FDEF. 54 | do 4 simtac0. 55 | destruct (negb (fheader_dec fheader5 fheader0)) eqn:X; ss. 56 | apply andb_true_iff in FDEF. des. clear FDEF. simtac. 57 | revert SRC TGT FDEF0. 58 | generalize blocks0 at 1 3. 59 | generalize blocks5 at 1 3. 60 | induction blocks1; i; ss. 61 | destruct blocks2; [by inv FDEF0|]. 62 | unfold forallb2AL in FDEF0. simtac; eauto. 63 | - rewrite HINT in COND. inv COND. 64 | esplits; eauto. 65 | instantiate (1:= []). ss. 66 | - rewrite HINT in COND. inv COND. 67 | esplits; eauto. 68 | Qed. 69 | -------------------------------------------------------------------------------- /coq/status-admit.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | grep -E "(admit|Admitted|TODO)" coq/*/*.v 4 | grep -E "(admit|Admitted|TODO)" coq/*/*.v | wc 5 | -------------------------------------------------------------------------------- /coq/status-issues.sh: -------------------------------------------------------------------------------- 1 | egrep "(admit|Admitted|TODO|Todo|todo|ISSUE|Issue|issue|Axiom)" */*.v */*.ml 2 | -------------------------------------------------------------------------------- /coq/status-proof.sh: -------------------------------------------------------------------------------- 1 | echo "----------------------------------------------------------------------------------------------------------" 2 | echo "------------------------------Admitted--------------------------------------------------------------------" 3 | echo "----------------------------------------------------------------------------------------------------------" 4 | ag -G v$ -s "Admitted" --ignore=status.sh --ignore=count_admit.sh 5 | echo "----------------------------------------------------------------------------------------------------------" 6 | echo "------------------------------admit-----------------------------------------------------------------------" 7 | echo "----------------------------------------------------------------------------------------------------------" 8 | ag -G v$ -s "admit" --ignore=status.sh --ignore=count_admit.sh 9 | echo "----------------------------------------------------------------------------------------------------------" 10 | echo "------------------------------ADMIT--------------------------------------------------------------------" 11 | echo "----------------------------------------------------------------------------------------------------------" 12 | ag -G v$ -s "ADMIT" --ignore=status.sh --ignore=count_admit.sh 13 | #-s means case sensitive 14 | #http://minimul.com/ignoring-files-with-ag-silver-searcher.html 15 | 16 | #TODO move all proof in "def" to "proof", and only grep "proof". 17 | echo "----------------------------------------------------------------------------------------------------------" 18 | echo "------------------------------Other assumption keywords---------------------------------------------------" 19 | echo "----------------------------------------------------------------------------------------------------------" 20 | #https://coq.inria.fr/refman/Reference-Manual003.html#Vernacular 21 | #assumption_keyword ::= Axiom | Conjecture | Parameter | Parameters | Variable | Variables | Hypothesis | Hypotheses 22 | ag -G v$ -s "Axiom" --ignore=status.sh --ignore=count_admit.sh 23 | ag -G v$ -s "Conjecture" --ignore=status.sh --ignore=count_admit.sh 24 | ag -G v$ -s "Parameter" --ignore=status.sh --ignore=count_admit.sh 25 | ag -G v$ -s "Parameters" --ignore=status.sh --ignore=count_admit.sh 26 | ag -G v$ -s "Variable" --ignore=status.sh --ignore=count_admit.sh 27 | ag -G v$ -s "Variables" --ignore=status.sh --ignore=count_admit.sh 28 | ag -G v$ -s "Hypothesis" --ignore=status.sh --ignore=count_admit.sh 29 | ag -G v$ -s "Hypotheses" --ignore=status.sh --ignore=count_admit.sh 30 | -------------------------------------------------------------------------------- /coq/status.sh: -------------------------------------------------------------------------------- 1 | egrep "(admit|Admitted|TODO|Todo|todo|ISSUE|Issue|issue|Axiom)" */*.v */*.ml 2 | -------------------------------------------------------------------------------- /ocaml/Makefile: -------------------------------------------------------------------------------- 1 | ROOT = `pwd`/.. 2 | LLVM_OCAML_LIB = $(ROOT)/.build/llvm-obj/bindings/ocaml 3 | LLVM_LIB = $(ROOT)/.build/llvm-obj/lib/ocaml 4 | 5 | LIB_FILES = llvm.cmxa,llvm_analysis.cmxa,llvm_target.cmxa,llvm_bitreader.cmxa,llvm_bitwriter.cmxa,llvm_scalar_opts.cmxa 6 | 7 | OCAMLBUILD = ocamlbuild 8 | OCAMLBUILD_OPT = -r \ 9 | -I extract \ 10 | -I corehint \ 11 | -I vellvm \ 12 | -use-ocamlfind -pkg atdgen \ 13 | -cflags -I,$(LLVM_OCAML_LIB) \ 14 | -cflags -I,$(LLVM_LIB) \ 15 | -cflags -g \ 16 | -lflags -I,$(LLVM_OCAML_LIB) \ 17 | -lflags -I,$(LLVM_LIB) \ 18 | -lflags -cc,g++ \ 19 | -lflags -cclib,-lLLVMSupport \ 20 | -lflags -cclib,-lLLVMBitReader \ 21 | -lflags -cclib,-lLLVMBitWriter \ 22 | -lflags $(LIB_FILES) 23 | 24 | MLS = corehint/coreHint_j.ml corehint/coreHint_j.mli \ 25 | corehint/coreHint_t.ml corehint/coreHint_t.mli \ 26 | $(shell find *.ml*) \ 27 | $(shell find */*.ml*) 28 | 29 | all: main.native 30 | 31 | main.native: $(MLS) 32 | $(OCAMLBUILD) $(OCAMLBUILD_OPT) main.native 33 | 34 | corehint/coreHint_t.ml: corehint/coreHint.atd 35 | atdgen -t ./corehint/coreHint.atd 36 | atdgen -j ./corehint/coreHint.atd 37 | 38 | corehint/coreHint_j.ml: corehint/coreHint.atd 39 | atdgen -t ./corehint/coreHint.atd 40 | atdgen -j ./corehint/coreHint.atd 41 | 42 | corehint/coreHint_t.mli: corehint/coreHint.atd 43 | atdgen -t ./corehint/coreHint.atd 44 | atdgen -j ./corehint/coreHint.atd 45 | 46 | corehint/coreHint_j.mli: corehint/coreHint.atd 47 | atdgen -t ./corehint/coreHint.atd 48 | atdgen -j ./corehint/coreHint.atd 49 | 50 | clean: 51 | rm ./corehint/coreHint_j.mli 52 | rm ./corehint/coreHint_t.mli 53 | rm ./corehint/coreHint_j.ml 54 | rm ./corehint/coreHint_t.ml 55 | $(OCAMLBUILD) -clean 56 | 57 | -------------------------------------------------------------------------------- /ocaml/TODOCAML.ml: -------------------------------------------------------------------------------- 1 | open Printexc 2 | 3 | let flip f = fun x y -> f y x 4 | 5 | let compose f g x = f (g x) 6 | 7 | let rec filter_map f l = 8 | match l with 9 | | [] -> [] 10 | | x::l -> 11 | match f x with 12 | | Some y -> y::(filter_map f l) 13 | | None -> filter_map f l 14 | 15 | let findi p l = 16 | let rec r l idx = 17 | match l with 18 | | [] -> failwith "List.findi" 19 | | x::l -> 20 | if p idx x 21 | then (idx, x) 22 | else r l (idx + 1) 23 | in 24 | r l 0 25 | 26 | let get o = 27 | match o with 28 | | None -> 29 | print_endline (Printexc.raw_backtrace_to_string (Printexc.get_callstack(20))) ; 30 | failwith "Option.get None: " 31 | | Some x -> x 32 | 33 | let list_to_string (l:char list) : string = 34 | String.init (List.length l) (List.nth l) 35 | 36 | let int_list_max l default = 37 | List.fold_left (fun s i -> if(s < i) then i else s) default l 38 | 39 | let list_zip ls default = 40 | let rec fill_list_until i l = 41 | if(List.length l < i) 42 | then fill_list_until i (l @ [default]) 43 | else let _ = assert(List.length l == i) in l in 44 | let len = int_list_max (List.map (fun l -> List.length l) ls) 0 in 45 | let ls = List.map (fill_list_until len) ls in 46 | let _ = List.iter (fun l -> assert(List.length l = len)) in 47 | let rec pile ls i = 48 | if(i == 0) 49 | then [] (* should not be [[]] *) 50 | else (List.map List.hd ls) :: pile (List.map List.tl ls) (i-1) in 51 | pile ls len 52 | -------------------------------------------------------------------------------- /ocaml/addInfrule.ml: -------------------------------------------------------------------------------- 1 | (**********************************) 2 | (* add inference rule to the hint *) 3 | (**********************************) 4 | 5 | open Infrastructure 6 | open Printf 7 | open Llvm 8 | open Arg 9 | open Hints 10 | open Syntax 11 | open MetatheoryAtom 12 | open Extract_defs 13 | open CoreHint_t 14 | open ConvertUtil 15 | open Printexc 16 | 17 | type atom = AtomImpl.atom 18 | 19 | let add_infrule_phinode (coq_infrule:Infrule.t) 20 | (prev_block:atom) 21 | (block_hint:ValidationHint.stmts) : ValidationHint.stmts = 22 | let hint_phinodes = block_hint.ValidationHint.phinodes in 23 | let infrules = TODOCAML.get (Alist.lookupAL hint_phinodes prev_block) in 24 | let infrules = List.append infrules [coq_infrule] in 25 | let hint_phinodes = Alist.updateAL hint_phinodes prev_block infrules in 26 | let block_hint = { block_hint with ValidationHint.phinodes = hint_phinodes } in 27 | block_hint 28 | 29 | let add_infrule_command (infrule:Infrule.t) 30 | (line_num:int) 31 | (block_hint:ValidationHint.stmts) 32 | : ValidationHint.stmts = 33 | let hint_cmds = 34 | List.mapi 35 | (fun n (infrules, inv) -> 36 | if line_num <> n 37 | then (infrules, inv) 38 | else (List.append infrules [infrule], inv)) 39 | block_hint.ValidationHint.cmds 40 | in 41 | let block_hint = { block_hint with ValidationHint.cmds = hint_cmds } in 42 | block_hint 43 | 44 | let add_infrule (pos:Position.t) 45 | (infrule:Infrule.t) 46 | (block_hints:ValidationHint.fdef) 47 | : ValidationHint.fdef = 48 | let (block_name, idx) = pos in 49 | let block_hint = TODOCAML.get (Alist.lookupAL block_hints block_name) in 50 | let block_hint = 51 | match idx with 52 | | Position.Phinode prev_block -> 53 | add_infrule_phinode infrule prev_block block_hint 54 | | Position.Command line_num -> 55 | add_infrule_command infrule line_num block_hint 56 | in 57 | let block_hints = Alist.updateAL block_hints block_name block_hint in 58 | block_hints 59 | -------------------------------------------------------------------------------- /ocaml/convertHint.ml: -------------------------------------------------------------------------------- 1 | open Infrastructure 2 | open Printf 3 | open Llvm 4 | open Arg 5 | open Syntax 6 | open MetatheoryAtom 7 | open Dom_list 8 | open Dom_tree 9 | open Maps 10 | open LLVMsyntax 11 | open CoreHint_t 12 | open ConvertUtil 13 | open PropagateHint 14 | open ConvertInfrule 15 | open Hints 16 | open Exprs 17 | open AddInfrule 18 | open PostPropagation 19 | open Printer 20 | open DomTreeUtil 21 | 22 | type atom = AtomImpl.atom 23 | 24 | let rec nat_of_int n = 25 | assert (n >= 0); 26 | if n = 0 then Datatypes.O else Datatypes.S (nat_of_int (n - 1)) 27 | 28 | let nop_position_atd_to_coq (x : CoreHint_t.position) : Nop.nop_position = 29 | let nop_pos_i = 30 | match x.CoreHint_t.instr_index with 31 | | CoreHint_t.Phinode _ -> Nop.Coq_phi_node 32 | | CoreHint_t.Command pc -> Nop.Coq_command_index (nat_of_int pc.CoreHint_t.index) 33 | in 34 | (x.CoreHint_t.block_name, nop_pos_i) 35 | 36 | let sort_nop nops = 37 | List.sort (fun p1 p2 -> 38 | match p1.CoreHint_t.instr_index, p2.CoreHint_t.instr_index with 39 | | CoreHint_t.Phinode _, CoreHint_t.Phinode _ -> 0 40 | | CoreHint_t.Phinode _, CoreHint_t.Command _ -> (-1) 41 | | CoreHint_t.Command _, CoreHint_t.Phinode _ -> 1 42 | | CoreHint_t.Command c1, CoreHint_t.Command c2 -> 43 | (compare c1.CoreHint_t.index c2.CoreHint_t.index)) 44 | nops 45 | 46 | let insert_nop (f_id : string) (m : LLVMsyntax.coq_module) 47 | (nops : CoreHint_t.position list) : LLVMsyntax.coq_module = 48 | let nops = sort_nop nops in 49 | let Coq_module_intro (l, ns, ps) = m in 50 | let ps = List.map (fun (x : product) -> 51 | match x with 52 | | LLVMsyntax.Coq_product_fdef f -> 53 | if (f_id = LLVMinfra.getFdefID f) 54 | then 55 | let Coq_fdef_intro (h, blks) = f in 56 | let blks = (Nop.insert_nops (List.map nop_position_atd_to_coq nops) blks) in 57 | (LLVMsyntax.Coq_product_fdef (Coq_fdef_intro (h, blks))) 58 | else x 59 | | _ -> x 60 | ) ps in 61 | Coq_module_intro (l, ns, ps) 62 | 63 | module EmptyHint = struct 64 | (* TODO(@youngju.song): in Coq *) 65 | let unary_hint : Assertion.unary = 66 | { Assertion.lessdef = ExprPairSet.empty; 67 | Assertion.alias = 68 | { Assertion.noalias = PtrPairSet.empty; 69 | Assertion.diffblock = ValueTPairSet.empty; 70 | }; 71 | Assertion.unique = AtomSetImpl.empty; 72 | Assertion.coq_private = IdTSet.empty; 73 | } 74 | 75 | let assertion_hint : Assertion.t = 76 | { Assertion.src = unary_hint; 77 | Assertion.tgt = unary_hint; 78 | Assertion.maydiff = IdTSet.empty; 79 | } 80 | 81 | let stmts_hint (stmts: LLVMsyntax.stmts) (incoming_blocks: string list) : ValidationHint.stmts = 82 | let Coq_stmts_intro (phinodes, cmds, _) = stmts in 83 | 84 | let phinodes = List.map (fun bid -> (bid, [])) incoming_blocks in 85 | 86 | let cmds = List.map (fun _ -> ([], assertion_hint)) cmds in 87 | 88 | { ValidationHint.phinodes = phinodes; 89 | ValidationHint.assertion_after_phinodes = assertion_hint; 90 | ValidationHint.cmds = cmds; 91 | } 92 | 93 | let fdef_hint (fdef:LLVMsyntax.fdef) : ValidationHint.fdef = 94 | let Coq_fdef_intro (Coq_fheader_intro (_, _, id, _, _), blks) = fdef in 95 | let cfg_pred = Cfg.predecessors fdef in 96 | TODO.mapiAL (fun bname bstmts -> 97 | let incoming_blocks = 98 | let preds = Maps_ext.ATree.get bname cfg_pred in 99 | match preds with 100 | | None -> [] 101 | | Some t -> t 102 | in 103 | stmts_hint bstmts incoming_blocks) blks 104 | 105 | let stmts_hint_with (stmts: LLVMsyntax.stmts) (incoming_blocks: string list) 106 | (inv: Hints.Assertion.t): ValidationHint.stmts = 107 | let Coq_stmts_intro (phinodes, cmds, _) = stmts in 108 | 109 | let phinodes = List.map (fun bid -> (bid, [])) incoming_blocks in 110 | 111 | let cmds = List.map (fun _ -> ([], inv)) cmds in 112 | 113 | { ValidationHint.phinodes = phinodes; 114 | ValidationHint.assertion_after_phinodes = inv; 115 | ValidationHint.cmds = cmds; 116 | } 117 | 118 | let fdef_hint_with (fdef:LLVMsyntax.fdef) (inv: Hints.Assertion.t) : ValidationHint.fdef = 119 | let Coq_fdef_intro (Coq_fheader_intro (_, _, id, _, _), blks) = fdef in 120 | let cfg_pred = Cfg.predecessors fdef in 121 | TODO.mapiAL (fun bname bstmts -> 122 | let incoming_blocks = 123 | let preds = Maps_ext.ATree.get bname cfg_pred in 124 | match preds with 125 | | None -> [] 126 | | Some t -> t 127 | in 128 | (stmts_hint_with bstmts incoming_blocks inv)) blks 129 | 130 | 131 | let module_hint (m:LLVMsyntax.coq_module) : ValidationHint.coq_module = 132 | let Coq_module_intro (lo, nts, prods) = m in 133 | TODOCAML.filter_map 134 | (fun prod -> 135 | match prod with 136 | | LLVMsyntax.Coq_product_fdef fd -> Some (LLVMinfra.getFdefID fd, fdef_hint fd) 137 | | _ -> None) 138 | prods 139 | end 140 | 141 | let noret (hint_module:ValidationHint.coq_module) : ValidationHint.coq_module = 142 | failwith "TODO: don't know yet" 143 | 144 | (** execute corehint commands **) 145 | 146 | let apply_corehint_command 147 | (lfdef:LLVMsyntax.fdef) (rfdef:LLVMsyntax.fdef) 148 | (dtree_lfdef:LLVMsyntax.l coq_DTree) 149 | (nops:CoreHint_t.position list) 150 | (cmd_d:(CoreHint_t.hint_command * CoreHint_t.cpp_debug_info)) 151 | (hint_fdef:ValidationHint.fdef) 152 | : ValidationHint.fdef = 153 | let (command, d) = cmd_d in 154 | match command with 155 | | CoreHint_t.Propagate prop -> 156 | let assertion = PropagateHint.AssertionObject.convert prop.propagate lfdef rfdef in 157 | let range = Position.convert_range prop.propagate_range nops lfdef rfdef in 158 | propagate_hint lfdef dtree_lfdef assertion range hint_fdef 159 | | CoreHint_t.Infrule (pos, infrule) -> 160 | let pos = Position.convert pos nops lfdef rfdef in 161 | let infrule = convert_infrule infrule lfdef rfdef in 162 | add_infrule pos infrule hint_fdef 163 | 164 | let add_false_to_dead_block hint_fdef lfdef = 165 | let live_blocks = 166 | (* meaning of succs? *) 167 | (* A map from an id to its successors. *) 168 | (* Variable successors: T.t (list T.elt).*) 169 | (* cfg.v 57 line *) 170 | (* dfs spec = impl : dfs.v 1498 *) 171 | let entry_label = TODOCAML.get (LLVMinfra.getEntryLabel lfdef) in 172 | let po = 173 | let succs = Cfg.successors lfdef in 174 | Dfs.dfs succs entry_label BinNums.Coq_xH in 175 | (Dfs.coq_PO_a2p po) in 176 | 177 | let fill_with_false { ValidationHint.phinodes = phis; 178 | ValidationHint.assertion_after_phinodes = iphis; 179 | ValidationHint.cmds = cs } = 180 | let update_src_lessdef = 181 | TODOCAML.compose Assertion.update_src Assertion.update_lessdef in 182 | let insert_false = 183 | (fun y -> ExprPairSet.add Assertion.false_encoding y) in 184 | { ValidationHint.phinodes = phis ; 185 | ValidationHint.assertion_after_phinodes = 186 | update_src_lessdef insert_false iphis ; 187 | ValidationHint.cmds = 188 | List.map 189 | (fun (x, assertion) -> (x, update_src_lessdef insert_false assertion)) 190 | cs } in 191 | 192 | let hint_fdef: Hints.ValidationHint.fdef = 193 | let f = (fun i -> (fun (x: ValidationHint.stmts) -> 194 | let is_live = Maps_ext.ATree.get i live_blocks in 195 | match is_live with 196 | | Some _ -> x 197 | | None -> fill_with_false x)) in 198 | TODO.mapiAL f hint_fdef in 199 | hint_fdef 200 | 201 | module ConvertAuto = struct 202 | let convert_auto_option (opt:CoreHint_t.auto_opt) 203 | : InfruleGen.AutoOpt.pass_t = 204 | match opt with 205 | | CoreHint_t.AUTO_GVN -> InfruleGen.AutoOpt.GVN 206 | | CoreHint_t.AUTO_SROA -> InfruleGen.AutoOpt.SROA 207 | | CoreHint_t.AUTO_LICM -> InfruleGen.AutoOpt.LICM 208 | | CoreHint_t.AUTO_INSTCOMBINE -> InfruleGen.AutoOpt.INSTCOMBINE 209 | | _ -> InfruleGen.AutoOpt.DEFAULT 210 | 211 | let set_auto (opt:CoreHint_t.auto_opt): unit = 212 | let auto_opt = convert_auto_option opt in 213 | InfruleGen.AutoOpt.pass_option := auto_opt 214 | end 215 | 216 | module ConvertPostPropagation = struct 217 | let convert_postprop_opt (opt:CoreHint_t.postprop_opt) 218 | : PostPropagation.PostProp.t = 219 | match opt with 220 | | CoreHint_t.POSTPROP_GVN -> PostProp.remove_inconsistent_gep 221 | | _ -> PostProp.default 222 | end 223 | 224 | let apply_post_propagation_func hint_fdef lfdef dtree_lfdef core_hint = 225 | match core_hint.CoreHint_t.postprop_option.CoreHint_t.opt with 226 | | CoreHint_t.POSTPROP_NONE -> hint_fdef 227 | | k -> PostPropagation.update hint_fdef lfdef dtree_lfdef 228 | (ConvertPostPropagation.convert_postprop_opt k) (core_hint.CoreHint_t.postprop_option.CoreHint_t.itrnum) 229 | 230 | 231 | let convert 232 | (lm:LLVMsyntax.coq_module) 233 | (rm:LLVMsyntax.coq_module) 234 | (core_hint:CoreHint_t.hints) 235 | : ValidationHint.coq_module = 236 | let _ = ConvertAuto.set_auto core_hint.CoreHint_t.auto_option in 237 | 238 | let fid = core_hint.function_id in 239 | let lfdef = TODOCAML.get (LLVMinfra.lookupFdefViaIDFromModule lm fid) in 240 | let rfdef = TODOCAML.get (LLVMinfra.lookupFdefViaIDFromModule rm fid) in 241 | let dtree_lfdef = TODOCAML.get (AlgDom.create_dom_tree lfdef) in 242 | 243 | let nops = sort_nop core_hint.CoreHint_t.nop_positions in 244 | 245 | let (globals, others) = filter_global lfdef rfdef core_hint.CoreHint_t.commands in 246 | let global_obj: Hints.Assertion.t = 247 | List.fold_left (TODOCAML.flip AssertionObject.insert) EmptyHint.assertion_hint globals in 248 | 249 | let hint_fdef = EmptyHint.fdef_hint_with lfdef global_obj in 250 | let hint_fdef = List.fold_left 251 | (TODOCAML.flip (apply_corehint_command lfdef rfdef dtree_lfdef nops)) 252 | hint_fdef others in 253 | let hint_fdef = add_false_to_dead_block hint_fdef lfdef in 254 | let hint_fdef = apply_post_propagation_func hint_fdef lfdef dtree_lfdef core_hint in 255 | 256 | let hint_module = EmptyHint.module_hint lm in 257 | (* let hint_module = noret hint_module in *) (*TODO*) 258 | let hint_module = Alist.updateAL hint_module fid hint_fdef in 259 | hint_module 260 | -------------------------------------------------------------------------------- /ocaml/coq2ml.ml: -------------------------------------------------------------------------------- 1 | (* open Interpreter *) 2 | open Printf 3 | open Llvm 4 | open Arg 5 | 6 | exception Error 7 | 8 | let llapint_add x y = 9 | let x_bw = Llvm.APInt.get_bitwidth x in 10 | let y_bw = Llvm.APInt.get_bitwidth y in 11 | if x_bw <> y_bw then raise Error 12 | else Llvm.APInt.of_int64 13 | x_bw 14 | (Int64.add 15 | (Llvm.APInt.get_sext_value x) 16 | (Llvm.APInt.get_sext_value y)) 17 | true 18 | 19 | let llapint_sub x y = 20 | let x_bw = Llvm.APInt.get_bitwidth x in 21 | let y_bw = Llvm.APInt.get_bitwidth y in 22 | if x_bw <> y_bw then raise Error 23 | else Llvm.APInt.of_int64 24 | x_bw 25 | (Int64.sub 26 | (Llvm.APInt.get_sext_value x) 27 | (Llvm.APInt.get_sext_value y)) 28 | true 29 | -------------------------------------------------------------------------------- /ocaml/domTreeUtil.ml: -------------------------------------------------------------------------------- 1 | open MetatheoryAtom 2 | open Dom_list 3 | open Dom_tree 4 | 5 | let rec string_of_dtree dtree = 6 | match dtree with 7 | | DT_node (a, dtrees) -> a ^ "->(" ^ (string_of_dtrees dtrees) ^ ")" 8 | and string_of_dtrees dtrees = 9 | match dtrees with 10 | | DT_nil -> "" 11 | | DT_cons (dtree, dtrees) -> (string_of_dtree dtree) ^ ", " ^ (string_of_dtrees dtrees) 12 | 13 | let rec find_in_dtree a dtree = 14 | match dtree with 15 | | DT_node (a', dtrees) -> 16 | if a = a' 17 | then Some dtree 18 | else find_in_dtrees a dtrees 19 | and find_in_dtrees a dtrees = 20 | match dtrees with 21 | | DT_nil -> None 22 | | DT_cons (dtree, dtrees) -> 23 | (match find_in_dtree a dtree with 24 | | Some result -> Some result 25 | | None -> find_in_dtrees a dtrees) 26 | 27 | let rec collapse_dtree ?(acc=AtomSetImpl.empty) dtree = 28 | match dtree with 29 | | DT_node (a, dtrees) -> collapse_dtrees ~acc:(AtomSetImpl.add a acc) dtrees 30 | and collapse_dtrees ?(acc=AtomSetImpl.empty) dtrees = 31 | match dtrees with 32 | | DT_nil -> acc 33 | | DT_cons (dtree, dtrees) -> 34 | let acc' = collapse_dtree ~acc:acc dtree in 35 | let acc'' = collapse_dtrees ~acc:acc' dtrees in 36 | acc'' 37 | 38 | let rec bfs_traversal_of_tree (dtree: 'a coq_DTree) : 'a list = 39 | match dtree with 40 | | DT_node (a, dtrees) -> a :: (bfs_traversal_of_trees dtrees) 41 | and bfs_traversal_of_trees (dtrees: 'a coq_DTrees) : 'a list = 42 | match dtrees with 43 | | DT_nil -> [] 44 | | DT_cons (dtree, dtrees) -> 45 | let l1 = bfs_traversal_of_tree dtree in 46 | let l2 = bfs_traversal_of_trees dtrees in 47 | List.append l1 l2 48 | 49 | let dom_by a dtree = 50 | let dtree = 51 | match find_in_dtree a dtree with 52 | | None -> failwith "translateHints sdom_by" 53 | | Some dtree -> dtree 54 | in 55 | let result = collapse_dtree dtree in 56 | result 57 | -------------------------------------------------------------------------------- /ocaml/extract: -------------------------------------------------------------------------------- 1 | ../coq/extract -------------------------------------------------------------------------------- /ocaml/main.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Llvm 3 | open Arg 4 | open Syntax.LLVMsyntax 5 | open Printer 6 | open CoreHint_j 7 | 8 | let measure_time = ref false 9 | 10 | let prev_time = ref 0.0 11 | 12 | let print_time msg = 13 | if !measure_time 14 | then 15 | let cur_time = Sys.time() in 16 | Printf.fprintf stderr 17 | "MEASURE_TIME\t%s\t%s\t%s\n" 18 | (string_of_float (cur_time -. !prev_time)) 19 | (string_of_float cur_time) 20 | msg; 21 | prev_time := cur_time 22 | else () 23 | 24 | let read_im filename = 25 | let _ = debug_print "read_im.." in 26 | 27 | let _ = debug_print " context.." in 28 | let ic = create_context () in 29 | 30 | let _ = debug_print " imbuf.." in 31 | let imbuf = MemoryBuffer.of_file filename in 32 | 33 | let _ = debug_print " im.." in 34 | let im = Llvm_bitreader.parse_bitcode ic imbuf in 35 | let _ = debug_run (fun _ -> dump_module im) in 36 | 37 | let _ = debug_print " slottracker.." in 38 | let ist = SlotTracker.create_of_module im in 39 | let _ = debug_run (fun _ -> Llvm_pretty_printer.travel_module ist im) in 40 | 41 | (* let _ = Gc.full_major () in *) 42 | 43 | let _ = debug_print " coqim.." in 44 | let coqim = Llvm2coq.translate_module !Globalstates.debug ist im in 45 | let _ = debug_run (fun _ -> Coq_pretty_printer.travel_module coqim) in 46 | 47 | (* TODO: we commented the following out in order to prevent segfaults. *) 48 | (* let _ = SlotTracker.dispose ist in *) 49 | (* let _ = dispose_module im in *) 50 | (* let _ = dispose_context ic in *) 51 | 52 | coqim 53 | 54 | let read_hint filename = 55 | let _ = debug_print "read hint json.." in 56 | 57 | let hint = Ag_util.Json.from_file read_hints filename in 58 | let _ = 59 | debug_run 60 | (fun _ -> 61 | let json = Yojson.Safe.prettify ~std:true (string_of_hints hint) in 62 | let _ = output_string !out_channel json in 63 | let _ = output_char !out_channel '\n' in 64 | ()) 65 | in 66 | hint 67 | 68 | let get_last_sentence s = 69 | if String.contains s '\n' then 70 | let i = String.rindex s '\n' in 71 | String.sub s (i+1) (String.length s - i - 1) 72 | else s 73 | 74 | let main filename_src filename_tgt filename_hint = 75 | let _ = print_time "start" in 76 | let coq_im_src = read_im filename_src in 77 | let coq_im_tgt = read_im filename_tgt in 78 | let hint = read_hint filename_hint in 79 | 80 | let _ = print_time "read-done" in 81 | 82 | let _ = debug_print "description for this VU.." in 83 | let _ = debug_print hint.CoreHint_t.description in 84 | let _ = 85 | match hint.CoreHint_t.return_code with 86 | | ADMITTED -> print_endline "Set to admitted."; print_endline (get_last_sentence hint.CoreHint_t.description) 87 | | FAIL -> print_endline "Set to fail." 88 | | ACTUAL -> 89 | let (src_nop_positions, tgt_nop_positions) = 90 | List.partition 91 | (fun (nop:CoreHint_t.position) -> nop.CoreHint_t.scope = CoreHint_t.Source) 92 | hint.CoreHint_t.nop_positions in 93 | 94 | let coq_im_src = ConvertHint.insert_nop hint.function_id 95 | coq_im_src src_nop_positions in 96 | let coq_im_tgt = ConvertHint.insert_nop hint.function_id 97 | coq_im_tgt tgt_nop_positions in 98 | 99 | let _ = print_time "insert-nop-done" in 100 | 101 | let coq_hint = ConvertHint.convert coq_im_src coq_im_tgt hint in 102 | 103 | let _ = print_time "convert-hint-done" in 104 | 105 | let _ = debug_print "validation.." in 106 | let validation_result = 107 | Validator.valid_module coq_hint coq_im_src coq_im_tgt in 108 | let _ = print_time "validation-done" in 109 | match validation_result with 110 | | Some true -> print_endline "Validation succeeded." 111 | | Some false -> print_endline "Set to admitted."; print_endline "Named-types differ." 112 | | None -> (print_endline "Validation failed."; exit 1) 113 | in 114 | 115 | () 116 | 117 | let argspec = [ 118 | ("-d", Set Globalstates.debug, "debug"); 119 | ("-o", String (fun s -> out_channel := open_out s), "output file"); 120 | ("-t", Set measure_time, "time"); 121 | ] 122 | 123 | let args = ref [] 124 | let argfun f = args := f::!args 125 | 126 | let argmsg = "Usage: ./main.native file1.bc file2.bc hint.json" 127 | 128 | let () = 129 | let _ = Arg.parse argspec argfun argmsg in 130 | 131 | match !args with 132 | | [filename_hint; filename_tgt; filename_src] -> 133 | main filename_src filename_tgt filename_hint 134 | | _ -> 135 | let _ = print_endline "input filenames. ex) ./main.native file1.bc file2.bc hint.json" in 136 | exit 1 137 | -------------------------------------------------------------------------------- /ocaml/postPropagation.ml: -------------------------------------------------------------------------------- 1 | (*********************************) 2 | (* Post-propagation mechanisms *) 3 | (*********************************) 4 | (* refactoring *) 5 | open Infrastructure 6 | open Printf 7 | open Llvm 8 | open Arg 9 | open Syntax 10 | open MetatheoryAtom 11 | open Extract_defs 12 | open Dom_list 13 | open Dom_tree 14 | open CoreHint_t 15 | open ConvertUtil 16 | open DomTreeUtil 17 | open Hints 18 | open Exprs 19 | open ValueT 20 | open IdT 21 | open Tag 22 | open TODOCAML 23 | open Printer 24 | 25 | module PostProp = struct 26 | type t = Assertion.t -> Assertion.t -> Assertion.t option 27 | 28 | let counter:int ref = ref 0 29 | 30 | let update_lessdef_b (f:ExprPairSet.t -> (ExprPairSet.t * bool)) (invu:Assertion.unary) 31 | : Assertion.unary * bool = 32 | let (ld_post, flag) = f invu.Assertion.lessdef in 33 | (Assertion.update_lessdef (fun _ -> ld_post) invu, flag) 34 | 35 | let update_src_b (f:Assertion.unary -> (Assertion.unary * bool)) (inv:Assertion.t) 36 | : Assertion.t * bool = 37 | let (inv_src, flag) = f inv.Assertion.src in 38 | (Assertion.update_src (fun _ -> inv_src) inv, flag) 39 | 40 | let update_tgt_b (f:Assertion.unary -> (Assertion.unary * bool)) (inv:Assertion.t) 41 | : Assertion.t * bool = 42 | let (inv_tgt, flag) = f inv.Assertion.tgt in 43 | (Assertion.update_tgt (fun _ -> inv_tgt) inv, flag) 44 | 45 | let remove_inconsistent_gep (previnv:Assertion.t) (postinv:Assertion.t) = 46 | let rem_inc_ld (prev_ld:ExprPairSet.t) (post_ld:ExprPairSet.t) : (ExprPairSet.t * bool) = 47 | List.fold_left (fun (acc, cg) ep -> 48 | match ep with 49 | | (e1, Expr.Coq_gep (inb, ty1, v, lsz, ty2)) when inb = true -> 50 | if ExprPairSet.mem (e1, Expr.Coq_gep (false, ty1, v, lsz, ty2)) prev_ld 51 | then (ExprPairSet.remove ep acc, true) 52 | else (acc, cg) 53 | | (Expr.Coq_gep (inb, ty1, v, lsz, ty2), e2) when inb = false -> 54 | if ExprPairSet.mem (Expr.Coq_gep (true, ty1, v, lsz, ty2), e2) prev_ld 55 | then (ExprPairSet.remove ep acc, true) 56 | else (acc, cg) 57 | | _ -> (acc, cg)) (post_ld, false) (ExprPairSet.elements post_ld) 58 | in 59 | let _ = counter := !counter + 1 in 60 | let prev_ld_src = previnv.Assertion.src.Assertion.lessdef in 61 | let prev_ld_tgt = previnv.Assertion.tgt.Assertion.lessdef in 62 | let (postinv1, cg1) = update_src_b (update_lessdef_b (rem_inc_ld prev_ld_src)) postinv in 63 | let (postinv2, cg2) = update_tgt_b (update_lessdef_b (rem_inc_ld prev_ld_tgt)) postinv1 in 64 | if (cg1 || cg2) then Some postinv2 else None 65 | 66 | let default (previnv:Assertion.t) (postinv:Assertion.t) = None 67 | end 68 | 69 | let _apply_func_to_block (hint_fdef:ValidationHint.fdef) 70 | (func: PostProp.t) 71 | (blockid: atom) 72 | (preds: atom list) 73 | : (ValidationHint.fdef * bool) (* updated assertions, ischanged *) = 74 | let stmtsinv: ValidationHint.stmts = TODOCAML.get (Alist.lookupAL hint_fdef blockid) in 75 | (* First, update assertion_after_phinodes *) 76 | let (stmtsinv, changed_phiinv): (ValidationHint.stmts * bool) = 77 | List.fold_left 78 | (* return updated stmtsinv *) 79 | (fun ((stmtsinv, changed):(ValidationHint.stmts * bool)) prevblockid -> 80 | (* assertion of the previous block *) 81 | let prev_stmtsinv = TODOCAML.get (Alist.lookupAL hint_fdef prevblockid) in 82 | let prev_inv = 83 | (match (List.rev prev_stmtsinv.cmds) with 84 | | (_, prev_lastinv)::_ -> prev_lastinv 85 | | [] -> (* cmds assertion is empty! *) 86 | prev_stmtsinv.assertion_after_phinodes) in 87 | let this_inv = stmtsinv.assertion_after_phinodes in 88 | 89 | let updated_phiinv_option = func prev_inv this_inv in 90 | match updated_phiinv_option with 91 | | Some updated_phiinv -> 92 | (ValidationHint.update_assertion_after_phinodes 93 | (fun _ -> updated_phiinv) stmtsinv, true) 94 | | None -> (stmtsinv, changed) 95 | ) 96 | (stmtsinv, false) 97 | preds (* previous block id *) 98 | in 99 | (* assertion_after_phinode is fully updatd. *) 100 | (* Now update cmds. *) 101 | let changed_cmdinv: bool ref = ref false in 102 | let cmdinv_updater = 103 | let _func_applier prev_inv this_inv = 104 | match (func prev_inv this_inv) with 105 | | Some new_inv -> 106 | changed_cmdinv := true; 107 | new_inv 108 | | None -> this_inv 109 | in 110 | (fun (invlist:Assertion.t list) -> 111 | (* Now fold! *) 112 | let newinvlist = List.fold_left 113 | (fun prev_invs this_inv -> 114 | match prev_invs with 115 | | prev_inv::td -> 116 | (_func_applier prev_inv this_inv)::prev_inv::td 117 | | [] -> 118 | let phiinv = (stmtsinv.assertion_after_phinodes) in 119 | [_func_applier phiinv this_inv] 120 | ) 121 | [] 122 | invlist 123 | in List.rev newinvlist 124 | ) in 125 | let stmtsinv = ValidationHint.update_cmd_assertions cmdinv_updater stmtsinv in 126 | (Alist.updateAL hint_fdef blockid stmtsinv, (changed_phiinv || !changed_cmdinv)) 127 | 128 | let _apply_func_to_f (hint_fdef:ValidationHint.fdef) (lfdef: LLVMsyntax.fdef) 129 | (dtree_lfdef: atom coq_DTree) 130 | (func: PostProp.t) 131 | : (ValidationHint.fdef * bool) (* updated assertion, ischanged *) = 132 | let visitorder = bfs_traversal_of_tree dtree_lfdef in 133 | let _ = print_string "\n" in 134 | let preds = Cfg.predecessors lfdef in (* LLVMsyntax.ls ATree.t *) 135 | List.fold_left 136 | (fun (hint_fdef, changed) blockid -> 137 | let predlist = 138 | match Maps_ext.ATree.get blockid preds with 139 | | Some t -> t 140 | | None -> [] 141 | in 142 | let (hint_fdef, changed2) = _apply_func_to_block hint_fdef func blockid predlist in 143 | (hint_fdef, (changed || changed2)) 144 | ) 145 | (hint_fdef, false) 146 | visitorder 147 | 148 | let update (hint_fdef:ValidationHint.fdef) (lfdef:LLVMsyntax.fdef) 149 | (dtree_lfdef: atom coq_DTree) 150 | (func: PostProp.t) (itrcnt: int) 151 | : ValidationHint.fdef = 152 | let rec _update (hint_fdef:ValidationHint.fdef) (n:int) : ValidationHint.fdef = 153 | if n <= 0 then hint_fdef 154 | else 155 | let (hint_fdef, changed) = _apply_func_to_f hint_fdef lfdef dtree_lfdef func in 156 | if not changed then 157 | hint_fdef 158 | else 159 | _update hint_fdef (n - 1) 160 | in _update hint_fdef itrcnt 161 | -------------------------------------------------------------------------------- /ocaml/vellvm: -------------------------------------------------------------------------------- 1 | ../lib/vellvm/src/Extraction -------------------------------------------------------------------------------- /script/attrchk.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e -u 4 | 5 | # set clang and opt paths 6 | VALI="$( cd "$( dirname "$0" )" && pwd )" 7 | ROOT="$(dirname $(dirname $VALI))" 8 | BIN=$ROOT/installed/llvm/bin 9 | 10 | CMP_ATTR=$VALI/cmp_attrs.native 11 | OPT=$BIN/opt 12 | DIS=$BIN/llvm-dis 13 | AS=$BIN/llvm-as 14 | 15 | 16 | if [ $# -lt 1 ] 17 | then echo "usage: ./attrchk.sh a.bc" 18 | fi 19 | 20 | filename=$1 21 | tmpname="tmp" 22 | 23 | #echo $filename 24 | 25 | $DIS $filename -o "$tmpname"1.ll 26 | sed "s/^define\(.*\) readonly /define\1 /g" "$tmpname"1.ll > "$tmpname"2.ll 27 | sed "s/^define\(.*\) readnone /define\1 /g" "$tmpname"2.ll > "$tmpname"3.ll 28 | $OPT -functionattrs "$tmpname"3.ll -o "$tmpname"4.bc 29 | $CMP_ATTR $filename "$tmpname"4.bc 30 | rm "$tmpname"1.ll "$tmpname"2.ll "$tmpname"3.ll "$tmpname"4.bc 31 | 32 | 33 | # using mkfifo: exception by Llvm.IoError on ($CMP_ATTR $filename "$tmpname"4.bc) 34 | 35 | #rm -f "$tmpname"1.ll "$tmpname"2.ll "$tmpname"3.ll "$tmpname"4.bc 36 | #mkfifo "$tmpname"1.ll 37 | #mkfifo "$tmpname"2.ll 38 | #mkfifo "$tmpname"3.ll 39 | #mkfifo "$tmpname"4.bc 40 | # 41 | #$DIS $filename -o "$tmpname"1.ll & \ 42 | #sed "s/^define\(.*\) readonly /define\1 /g" "$tmpname"1.ll > "$tmpname"2.ll & \ 43 | #sed "s/^define\(.*\) readnone /define\1 /g" "$tmpname"2.ll > "$tmpname"3.ll & \ 44 | #$AS < "$tmpname"3.ll | $OPT -functionattrs > "$tmpname"4.bc & \ 45 | #$CMP_ATTR $filename "$tmpname"4.bc 46 | #rm "$tmpname"1.ll "$tmpname"2.ll "$tmpname"3.ll "$tmpname"4.bc 47 | -------------------------------------------------------------------------------- /script/copy-sources.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | for dir in `ls .`; do 4 | if [ $dir != 'temp' ]; then 5 | echo $dir 6 | for file in `cd $dir; ls *.v`; do 7 | mv $dir/$file $dir/${file}_backup 8 | mv temp/$file $dir/$file 9 | done 10 | fi 11 | done 12 | -------------------------------------------------------------------------------- /script/llvm-build.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | ROOT=`pwd` 4 | SRCDIR=$ROOT/lib/llvm 5 | OBJDIR=$ROOT/.build/llvm-obj 6 | 7 | function check_exit { 8 | if [ "$?" = "0" ]; then 9 | echo "$1 succeeded." 10 | else 11 | echo "$1 failed." 1>&2 12 | exit 1 13 | fi 14 | } 15 | 16 | mkdir -p $OBJDIR 17 | 18 | cd $OBJDIR 19 | 20 | if [ ! -f $OBJDIR/Makefile ]; then 21 | cmake $SRCDIR -DCMAKE_BUILD_TYPE=Release 22 | fi 23 | 24 | cmake --build . -- -j$1 25 | make ocaml_doc 26 | #make -j$JOBS; check_exit "llvm/make" 27 | #cp bindings/ocaml/llvm/META.llvm bindings/ocaml/llvm/Release/META.llvm 28 | #make install; check_exit "llvm/make install" 29 | -------------------------------------------------------------------------------- /script/llvm-install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | JOBS=${1-1} 4 | ROOT=`pwd` 5 | SRCDIR=$ROOT/lib/llvm 6 | OBJDIR=$ROOT/.build/llvm-obj 7 | LOCALDIR=$ROOT/install 8 | 9 | cd $OBJDIR 10 | mkdir $LOCALDIR 11 | 12 | cmake -DCMAKE_INSTALL_PREFIX=${LOCALDIR} -P cmake_install.cmake -- -j$1 13 | -------------------------------------------------------------------------------- /script/make-fail.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | cp coq/validator.ml coq/validator.ml.backup 4 | while read line; do n=$((++n)) && echo $line|sed -e 's/false/failwith \"!'$(($n))\"'/' ; done coq/validator.ml 5 | -------------------------------------------------------------------------------- /script/make_graph.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | #TODO: remove redundancy of "-R ~~" with Makefile 3 | coqdep -dumpgraph graph.dot \ 4 | -R coq Crellvm -R lib/paco/src Paco -R lib/vellvm/src Vellvm -R lib/vellvm/lib/sflib sflib \ 5 | -R lib/vellvm/lib/metalib metalib -R lib/vellvm/lib/cpdtlib Cpdt -R lib/vellvm/lib/compcert-2.4 compcert \ 6 | ** 7 | dot -Tpng graph.dot > graph.png 8 | -------------------------------------------------------------------------------- /script/rsync-receive.sh: -------------------------------------------------------------------------------- 1 | PROOF_BUILD_DIR=.build-proof 2 | 3 | rsync -av \ 4 | --include '*/' \ 5 | --include '*.ml' --include '*.mli' \ 6 | --exclude '*' \ 7 | "$PROOF_BUILD_DIR/" './' 8 | 9 | -------------------------------------------------------------------------------- /script/rsync-send.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | PROOF_BUILD_DIR=.build-proof 3 | 4 | rsync -av --copy-links --delete --prune-empty-dirs \ 5 | --exclude "$PROOF_BUILD_DIR" \ 6 | --exclude "lib/llvm/" --exclude "ocaml" \ 7 | --include '*/' \ 8 | --include '*.v' --include 'Makefile' \ 9 | --include '*.ott' --include 'fixextract.py' \ 10 | --exclude '*' \ 11 | './' "$PROOF_BUILD_DIR/" 12 | 13 | -------------------------------------------------------------------------------- /script/rules.import.txt: -------------------------------------------------------------------------------- 1 | Require Import hint_sem_props_resolve_add_assoc. 2 | Require Import hint_sem_props_resolve_replace_rhs. 3 | Require Import hint_sem_props_resolve_replace_rhs_opt. 4 | Require Import hint_sem_props_resolve_replace_lhs. 5 | Require Import hint_sem_props_resolve_remove_maydiff. 6 | Require Import hint_sem_props_resolve_remove_maydiff_rhs. 7 | Require Import hint_sem_props_resolve_eq_generate_same. 8 | Require Import hint_sem_props_resolve_eq_generate_same_heap. 9 | Require Import hint_sem_props_resolve_neq_generate_gm. 10 | Require Import hint_sem_props_resolve_neq_generate_mm. 11 | Require Import hint_sem_props_resolve_add_signbit. 12 | Require Import hint_sem_props_resolve_add_zext_bool. 13 | Require Import hint_sem_props_resolve_ptr_trans. 14 | Require Import hint_sem_props_resolve_pow_zero. 15 | Require Import hint_sem_props_resolve_add_onebit. 16 | Require Import hint_sem_props_resolve_stash_variable. 17 | Require Import hint_sem_props_resolve_add_shift. 18 | Require Import hint_sem_props_resolve_add_sub. 19 | Require Import hint_sem_props_resolve_add_commutative. 20 | Require Import hint_sem_props_resolve_sub_add. 21 | Require Import hint_sem_props_resolve_sub_onebit. 22 | Require Import hint_sem_props_resolve_sub_mone. 23 | Require Import hint_sem_props_resolve_sub_const_not. 24 | Require Import hint_sem_props_resolve_add_mul_fold. 25 | Require Import hint_sem_props_resolve_add_const_not. 26 | Require Import hint_sem_props_resolve_add_select_zero. 27 | Require Import hint_sem_props_resolve_add_select_zero2. 28 | Require Import hint_sem_props_resolve_sub_zext_bool. 29 | Require Import hint_sem_props_resolve_sub_const_add. 30 | Require Import hint_sem_props_resolve_sub_remove. 31 | Require Import hint_sem_props_resolve_sub_remove2. 32 | Require Import hint_sem_props_resolve_sub_sdiv. 33 | Require Import hint_sem_props_resolve_sub_shl. 34 | Require Import hint_sem_props_resolve_sub_mul. 35 | Require Import hint_sem_props_resolve_sub_mul2. 36 | Require Import hint_sem_props_resolve_mul_mone. 37 | Require Import hint_sem_props_resolve_mul_neg. 38 | Require Import hint_sem_props_resolve_mul_bool. 39 | Require Import hint_sem_props_resolve_mul_commutative. 40 | Require Import hint_sem_props_resolve_mul_shl. 41 | Require Import hint_sem_props_resolve_div_sub_srem. 42 | Require Import hint_sem_props_resolve_div_sub_urem. 43 | Require Import hint_sem_props_resolve_div_zext. 44 | Require Import hint_sem_props_resolve_div_mone. 45 | Require Import hint_sem_props_resolve_rem_zext. 46 | Require Import hint_sem_props_resolve_rem_neg. 47 | Require Import hint_sem_props_resolve_rem_neg2. 48 | -------------------------------------------------------------------------------- /script/rules.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | import os 4 | import sys 5 | 6 | if __name__ == "__main__": 7 | skelton = "" 8 | with open("coq/hint_sem_props_resolve_skeleton.v.skeleton") as f: 9 | skeleton = f.read() 10 | 11 | rules = [] 12 | 13 | with open("rules.txt") as f: 14 | for line in f.readlines(): 15 | args = line.split(' ') 16 | rule = args[0] 17 | args = (' '.join(args[1:]))[:-1] 18 | filename = "coq/hint_sem_props_resolve_%s.v" % rule 19 | content = skeleton.replace("$1", rule).replace("$2", args) 20 | rules.append(rule) 21 | 22 | with open(filename, "w") as g: 23 | g.write(content) 24 | 25 | with open("rules.import.txt", "w") as f: 26 | for rule in rules: 27 | f.write("Require Import hint_sem_props_resolve_%s.\n" % rule) 28 | -------------------------------------------------------------------------------- /script/rules.txt: -------------------------------------------------------------------------------- 1 | add_assoc z y x s c1 c2 c3 2 | replace_rhs z x y e e' 3 | replace_rhs_opt z x y e e' 4 | replace_lhs x y e 5 | remove_maydiff v e 6 | remove_maydiff_rhs v e 7 | eq_generate_same x y e 8 | eq_generate_same_heap x y p t a 9 | neq_generate_gm x y 10 | neq_generate_mm x y 11 | add_signbit x sz e s 12 | add_zext_bool x y b sz c c' 13 | ptr_trans p q v t a 14 | pow_zero x fp v s b 15 | add_onebit z x y 16 | stash_variable z t 17 | add_shift y s v 18 | add_sub z minusy s x y 19 | add_commutative z s x y 20 | sub_add z minusy s x y 21 | sub_onebit z x y 22 | sub_mone z s x 23 | sub_const_not z y s x c1 c2 24 | add_mul_fold z y s x c1 c2 25 | add_const_not z y s x c1 c2 26 | add_select_zero z x y c s n a 27 | add_select_zero2 z x y c s n a 28 | sub_zext_bool x y b sz c c' 29 | sub_const_add z y sz x c1 c2 c3 30 | sub_remove z y sz a b 31 | sub_remove2 z y sz a b 32 | sub_sdiv z y sz x c c' 33 | sub_shl z x y sz mx a 34 | sub_mul z y sz x c c' 35 | sub_mul2 z y sz x c c' 36 | mul_mone z sz x 37 | mul_neg z mx my sz x y 38 | mul_bool z x y 39 | mul_commutative z sz x y 40 | mul_shl z y sz x a 41 | div_sub_srem z b a sz x y 42 | div_sub_urem z b a sz x y 43 | div_zext z x y k sz1 sz2 a b 44 | div_mone z sz x 45 | rem_zext z x y k sz1 sz2 a b 46 | rem_neg z my sz x y 47 | rem_neg2 z sz x c1 c2 48 | -------------------------------------------------------------------------------- /script/sed.sh: -------------------------------------------------------------------------------- 1 | sed -i "s/impossible to prove due to incorrect semantics of Vellvm/impossible to prove due to incorrect semantics of undef in Vellvm/g" *resolve*.v 2 | -------------------------------------------------------------------------------- /status_proof.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | grep -E "(admit|Admitted|TODO)" coq/*/*.v 4 | grep -E "(admit|Admitted|TODO)" coq/*/*.v | wc 5 | --------------------------------------------------------------------------------