├── .envrc ├── ARTIFACT.md ├── HACKING.md ├── LICENSE ├── MMIO_design.txt ├── Makefile ├── README.md ├── USING.md ├── _CoqProject ├── case_study ├── Assumptions.v ├── MinimalCaps │ ├── Base.v │ ├── Contracts │ │ ├── Definitions.v │ │ ├── Notations.v │ │ ├── Statistics.v │ │ └── Verification.v │ ├── LoopVerification.v │ ├── Machine.v │ ├── Model.v │ ├── README.md │ ├── Shallow.v │ ├── Sig.v │ └── dune ├── RiscvPmp │ ├── Base.v │ ├── BlockVer │ │ ├── Examples.v │ │ ├── Spec.v │ │ └── Verifier.v │ ├── Contracts.v │ ├── FemtoKernel.v │ ├── IrisInstance.v │ ├── IrisInstanceBinary.v │ ├── IrisModel.v │ ├── IrisModelBinary.v │ ├── LoopVerification.v │ ├── LoopVerificationBinary.v │ ├── Machine.v │ ├── Model.v │ ├── ModelBinary.v │ ├── PmpCheck.v │ ├── README.md │ ├── Sig.v │ └── trace.v ├── deprecated │ └── RiscvPmpUnboundedInts │ │ ├── Base.v │ │ ├── BlockVer │ │ ├── Examples.v │ │ ├── Spec.v │ │ └── Verifier.v │ │ ├── Contracts.v │ │ ├── FemtoKernel.v │ │ ├── IrisInstance.v │ │ ├── IrisModel.v │ │ ├── LoopVerification.v │ │ ├── Machine.v │ │ ├── Model.v │ │ ├── README.md │ │ ├── Sig.v │ │ └── dune └── patches │ ├── MinimalCaps │ └── duplicate_add.patch │ ├── README.md │ ├── RiscvPmp │ └── duplicate_add.patch │ └── RiscvPmpBoundedInts │ └── duplicate_add.patch ├── default.nix ├── dune-project ├── flake.lock ├── flake.nix ├── scripts ├── shallow.sh └── timing.sh ├── test ├── Example.v ├── LinkedList.v ├── Replay.v └── SumMaxLen.v └── theories ├── Base.v ├── Bitvector.v ├── BitvectorSolve.v ├── Context.v ├── Environment.v ├── Iris ├── Base.v ├── BinaryAdequacy.v ├── BinaryInstance.v ├── BinaryResources.v ├── BinaryWeakestPre.v ├── Instance.v ├── LaterBinaryWp.v ├── Resources.v ├── TotalWeakestPre.v ├── WeakestPre.v ├── cocontexts.v └── cointro_patterns.v ├── MicroSail ├── RefineExecutor.v ├── ShallowExecutor.v ├── ShallowSoundness.v ├── Soundness.v └── SymbolicExecutor.v ├── Notations.v ├── Prelude.v ├── Program.v ├── Refinement └── Monads.v ├── Semantics.v ├── Semantics └── Registers.v ├── Sep ├── Hoare.v └── Logic.v ├── Shallow └── Monads.v ├── Signature.v ├── SmallStep ├── Inversion.v ├── Progress.v └── Step.v ├── Specification.v ├── Staging ├── BinaryExecutor │ └── ShallowExecutorRel.v ├── CommandStep.v ├── Monads.v ├── NewShallow │ ├── Executor.v │ ├── IrisInstance.v │ └── Soundness.v ├── WorldInstance.v └── WorldIsomorphisms.v ├── Symbolic ├── Instantiation.v ├── Monads.v ├── OccursCheck.v ├── PartialEvaluation.v ├── Propositions.v ├── Solver.v ├── UnifLogic.v └── Worlds.v ├── Syntax ├── Assertions.v ├── BinOps.v ├── Chunks.v ├── Expressions.v ├── Formulas.v ├── FunDecl.v ├── FunDef.v ├── Messages.v ├── Patterns.v ├── Predicates.v ├── Registers.v ├── Statements.v ├── Terms.v ├── TypeDecl.v ├── UnOps.v └── Variables.v ├── Tactics.v └── dune /.envrc: -------------------------------------------------------------------------------- 1 | # shellcheck shell=bash 2 | if ! has nix_direnv_version; then 3 | source_url "https://raw.githubusercontent.com/nix-community/nix-direnv/3.0.6/direnvrc" "sha256-RYcUJaRMf8oF5LznDrlCXbkOQrywm0HDv1VjYGaJGdM=" 4 | fi 5 | use flake 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019 2 | Dominique Devriese 3 | Georgy Lukyanov 4 | Sander Huyghebaert 5 | Steven Keuchel 6 | 7 | All rights reserved. 8 | 9 | This software was developed at the Software Languages Lab of the Department of 10 | Computer Science of the Vrije Universiteit Brussels. This work was supported in 11 | part by the Research Foundation - Flanders (FWO), and by the Flemish Research 12 | Programme Cybersecurity. 13 | 14 | Redistribution and use in source and binary forms, with or without 15 | modification, are permitted provided that the following conditions are 16 | met: 17 | 18 | 1. Redistributions of source code must retain the above copyright notice, 19 | this list of conditions and the following disclaimer. 20 | 21 | 2. Redistributions in binary form must reproduce the above copyright 22 | notice, this list of conditions and the following disclaimer in the 23 | documentation and/or other materials provided with the distribution. 24 | 25 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 26 | IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 27 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 28 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR 29 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 30 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 31 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 32 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 33 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 34 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 35 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | -------------------------------------------------------------------------------- /MMIO_design.txt: -------------------------------------------------------------------------------- 1 | Steps involved in implementing MMIO + verification over traces 2 | 3 | BASE 4 | * Define Parameters for isMMIO (possible concrete) + MMIO_STS (copy), change Memory variable (add Trace of Events and a State) 5 | * Change semantics of read and write to interact with Memory differently: 6 | Cfr. Cerise, if MMIO, change a different part of the state (In `Machine.v`) 7 | * Change regular resources: regular points-to implies non-MMIO (isMMIO = false) 8 | 9 | LOOP VERIFICATION 10 | * This should suffice to reprove the `loop` contract; the contracts only depend on non-MMIO chunks, and should hence be invariant under the addition of traces etc. 11 | 12 | FEMTOKERNEL 13 | * Add machinery for traces resources and predicates from cerise 14 | * Define a Katamaran `user_chunk` called `trace_pred_holds` which corresponds to an Iris invariant, which expresses that the trace holds with a given predicate resource, and the statement that the invariant holds over our trace resource (QUESTION: how to express the local state/predicate holding on the local state? even without local state; how to express predicate holding on value?) 15 | * Change read/write-mem contracts to keep this new trace resource in mind; extra boolean conjunct in case our current location is an MMIO location, and a requirement that the update preserves the predicate 16 | * Change femtokernel implementation; rather than ensuring the 42 never changes, it always writes 42 to the output (immediate <-> from memory?), and we want to make sure that (P = fun x, x = 42) holds over the output 17 | * Verify the new femtokernel using the new resources, lemma's over them and the new contracts 18 | 19 | FUTURE WORK 20 | * Refine the femtokernel implementation and the predicate we enforce to include a notion of polling, and implementation details for the GPIO pins (see below) 21 | * If we desire more realism, implement a notion of interrupts connected to the GPIO interrupt pins (to check: other types of interrupts present? Can we turn them off?) 22 | 23 | 24 | #################### 25 | 26 | Low-level details/notes about GPIO ports (this is below the abstraction level of the Sail spec): 27 | * The GPIO control registers are memory-mapped by the processor, and the different registers are documented in Chapter 17 of our board's spec. 28 | * Only 32-bit memory accesses are supported to all of the different control regions (the total length of the MMIO region is >= 44 bytes - this is the size listed in the table, but there's also the iof_en/iof_sel registers), but there are only 19 pins available on the board, so probably only the first 19 bits matter. 29 | * Many of the pins have to do with interrupts on a bit-wise level. Katamaran currently does not support interrupts, but we should be able to manually read them to implement a form of memory polling (although it remains to be seen whether or not other interrupts are present on the system anyway). 30 | * Writes on our specific board have to be aligned (and so are the MMIO regions), so no situations in which part of the write goes to the memory mapped region, and part goes to regular memory (thankfully, as this would be annoying to write specs for) 31 | * UART/SPI input can be configured to run through GPIO ports 32 | * Why did we pick GPIO over UART again? Easier to connect? 33 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Always run with nproc jobs by default. Can be overridden by the user. 2 | MAKEFLAGS := --jobs=$(shell nproc) 3 | 4 | # Comment out the below line if you want to be quiet by default. 5 | VERBOSE ?= 1 6 | ifeq ($(V),1) 7 | E=@true 8 | Q= 9 | else 10 | E=@echo 11 | Q=@ 12 | MAKEFLAGS += -s 13 | endif 14 | 15 | SRCS := $(shell egrep '^.*\.v$$' _CoqProject | grep -v '^#') 16 | AUXS := $(join $(dir $(SRCS)), $(addprefix ., $(notdir $(SRCS:.v=.aux)))) 17 | 18 | .PHONY: coq clean summaxlen install uninstall pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed-diff 19 | 20 | coq: Makefile.coq 21 | $(E) "MAKE Makefile.coq" 22 | $(Q)$(MAKE) -f Makefile.coq 23 | 24 | patch: 25 | $(Q) patch -p1 -N -r - < case_study/patches/RiscvPmp/duplicate_add.patch || true 26 | $(Q) patch -p1 -N -r - < case_study/patches/RiscvPmpBoundedInts/duplicate_add.patch || true 27 | $(Q) patch -p1 -N -r - < case_study/patches/MinimalCaps/duplicate_add.patch || true 28 | 29 | unpatch: 30 | $(Q) patch -p1 -NR -r - < case_study/patches/RiscvPmp/duplicate_add.patch || true 31 | $(Q) patch -p1 -NR -r - < case_study/patches/RiscvPmpBoundedInts/duplicate_add.patch || true 32 | $(Q) patch -p1 -NR -r - < case_study/patches/MinimalCaps/duplicate_add.patch || true 33 | 34 | Makefile.coq: _CoqProject Makefile $(SRCS) 35 | $(E) "COQ_MAKEFILE Makefile.coq" 36 | $(Q)coq_makefile -f _CoqProject -o Makefile.coq 37 | 38 | clean: Makefile.coq 39 | $(Q)$(MAKE) -f Makefile.coq clean 40 | $(Q)rm -f $(AUXS) 41 | $(Q)rm -f Makefile.coq *.bak *.d *.glob *~ result* 42 | 43 | install uninstall pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed-diff: Makefile.coq 44 | $(Q)$(MAKE) -f Makefile.coq $@ 45 | 46 | summaxlen: Makefile.coq 47 | $(Q)rm -f test/SumMaxLen.vo* 48 | $(Q)$(MAKE) -f Makefile.coq test/SumMaxLen.vo 49 | 50 | linkedlist: Makefile.coq 51 | $(Q)rm -f test/LinkedList.vo* 52 | $(Q)$(MAKE) -f Makefile.coq test/LinkedList.vo 53 | 54 | timings: Makefile.coq 55 | $(Q)rm -f case_study/MinimalCaps/Contracts.vo* 56 | $(Q)rm -f test/SumMaxLen.vo* 57 | $(Q)rm -f test/LinkedList.vo* 58 | $(Q)$(MAKE) -f Makefile.coq test/LinkedList.vo test/SumMaxLen.vo case_study/MinimalCaps/Contracts.vo | ts '%.s' | scripts/timing.sh 59 | 60 | Makefile2.coq: _CoqProject Makefile $(SRCS) case_study/MinimalCaps/Shallow.v 61 | $(E) "COQ_MAKEFILE Makefile2.coq" 62 | $(Q)coq_makefile -f _CoqProject -o Makefile2.coq case_study/MinimalCaps/Shallow.v 63 | 64 | minimalcaps: Makefile2.coq 65 | $(Q)rm -f case_study/MinimalCaps/Contracts.vo* 66 | $(Q)$(MAKE) -f Makefile.coq case_study/MinimalCaps/Contracts.vo 67 | $(Q)rm -f case_study/MinimalCaps/Shallow.vo* 68 | $(Q)$(MAKE) -f Makefile2.coq case_study/MinimalCaps/Shallow.vo | tr -s '[:space:]' '[\n*]' | scripts/shallow.sh 69 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![CircleCI](https://img.shields.io/circleci/build/github/katamaran-project/katamaran)](https://app.circleci.com/pipelines/github/katamaran-project/katamaran) 2 | [![FOSSA Status](https://app.fossa.com/api/projects/git%2Bgithub.com%2Fkatamaran-project%2Fkatamaran.svg?type=shield)](https://app.fossa.com/projects/git%2Bgithub.com%2Fkatamaran-project%2Fkatamaran?ref=badge_shield) 3 | 4 | Katamaran 5 | ========= 6 | 7 | Katamaran is a verification framework for instruction set architectures in the 8 | Coq proof assistant. It provides the deeply-embedded language μSail, a variant 9 | of the [Sail](https://github.com/rems-project/sail) language, for the 10 | specification of instructions sets and provides furthermore facilities for the 11 | specification of separation logic-based contracts and for semi-automatically 12 | verifying these contracts. The goal is to formally specify and verify with 13 | machine-checked proofs critical security guarantees of instruction sets. For 14 | more information visit [our website](https://katamaran-project.github.io/). 15 | 16 | Dependencies 17 | ------------ 18 | 19 | The development version of Katamaran has the following lower bounds: 20 | ``` 21 | coq >= 8.19 22 | coq-equations >= 1.3 23 | coq-iris >= 4.3 24 | coq-stdpp >= 1.11 25 | ``` 26 | and has also been tested with coq 8.20. 27 | 28 | ### Using opam 29 | 30 | An easy way to setup your system is to create a fresh opam switch, pin the Coq and Iris versions and install equations (stdpp will be installed as a dependency of Iris): 31 | ``` 32 | opam switch create katamaran ocaml-base-compiler.4.14.2 33 | opam repo add coq-released https://coq.inria.fr/opam/released 34 | opam pin add coq 8.19.2 35 | opam pin add coq-iris 4.3.0 36 | opam install coq-equations 37 | ``` 38 | 39 | ### Using nix 40 | 41 | The repository contains a flake.nix file that defines development shells that install all dependencies. To use it, you need to have [nix](https://nixos.org/download.html) installed. Then, you can enter a development shell with the following command: 42 | ``` 43 | nix develop 44 | ``` 45 | This will install all dependencies and open a shell with them available. Additionally it will set the COQPATH environment variable to include the dependencies. You can then compile the project within that shell or launch your favorite editor from within it. 46 | 47 | Installation 48 | ------------ 49 | 50 | ### Via opam (dev version) 51 | Add our opam repository and install the latest development version from Github 52 | with the following commands: 53 | ``` 54 | opam repo add katamaran https://github.com/katamaran-project/opam-repository.git 55 | opam install coq-katamaran 56 | ``` 57 | 58 | ### From github 59 | ``` 60 | git clone https://github.com/katamaran-project/katamaran.git 61 | cd katamaran && make && make install 62 | ``` 63 | 64 | Using 65 | ----- 66 | 67 | The basic usage structure of Katamaran is described in the [USING.md](USING.md) file. 68 | The easiest and recommended way to use the library for new developments is to adapt one of our existing case studies, for example the [MinimalCaps](case_study/MinimalCaps) machine. 69 | Some more information about the internal structure of the library is provided in the [HACKING.md](HACKING.md) file. 70 | 71 | License 72 | ------- 73 | The Katamaran implementation is distributed under the 2-clause BSD license. 74 | 75 | [![FOSSA Status](https://app.fossa.com/api/projects/git%2Bgithub.com%2Fkatamaran-project%2Fkatamaran.svg?type=large)](https://app.fossa.com/projects/git%2Bgithub.com%2Fkatamaran-project%2Fkatamaran?ref=badge_large) 76 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -arg "-w all" 2 | -arg "-w -disj-pattern-notation" 3 | -arg "-w -notation-overridden" 4 | -arg "-w -redundant-canonical-projection" 5 | -arg "-w -warn-transitive-library-file-stdlib-vector" 6 | -arg "-w -deprecated-transitive-library-file" 7 | -Q case_study/MinimalCaps Katamaran.MinimalCaps 8 | case_study/MinimalCaps/Base.v 9 | case_study/MinimalCaps/Machine.v 10 | case_study/MinimalCaps/Sig.v 11 | case_study/MinimalCaps/Contracts/Notations.v 12 | case_study/MinimalCaps/Contracts/Definitions.v 13 | case_study/MinimalCaps/Contracts/Verification.v 14 | case_study/MinimalCaps/Contracts/Statistics.v 15 | case_study/MinimalCaps/Model.v 16 | case_study/MinimalCaps/LoopVerification.v 17 | -Q case_study/RiscvPmp Katamaran.RiscvPmp 18 | case_study/RiscvPmp/Base.v 19 | case_study/RiscvPmp/Machine.v 20 | case_study/RiscvPmp/PmpCheck.v 21 | case_study/RiscvPmp/Sig.v 22 | case_study/RiscvPmp/Contracts.v 23 | case_study/RiscvPmp/trace.v 24 | case_study/RiscvPmp/IrisModel.v 25 | case_study/RiscvPmp/IrisInstance.v 26 | case_study/RiscvPmp/Model.v 27 | case_study/RiscvPmp/IrisModelBinary.v 28 | case_study/RiscvPmp/IrisInstanceBinary.v 29 | case_study/RiscvPmp/ModelBinary.v 30 | case_study/RiscvPmp/LoopVerification.v 31 | case_study/RiscvPmp/LoopVerificationBinary.v 32 | case_study/RiscvPmp/BlockVer/Examples.v 33 | case_study/RiscvPmp/BlockVer/Spec.v 34 | case_study/RiscvPmp/BlockVer/Verifier.v 35 | case_study/RiscvPmp/FemtoKernel.v 36 | case_study/Assumptions.v 37 | -R theories Katamaran 38 | test/Example.v 39 | test/LinkedList.v 40 | test/SumMaxLen.v 41 | test/Replay.v 42 | theories/Base.v 43 | theories/Bitvector.v 44 | theories/Context.v 45 | theories/Environment.v 46 | theories/Iris/Instance.v 47 | theories/Iris/Resources.v 48 | theories/Iris/WeakestPre.v 49 | theories/Iris/TotalWeakestPre.v 50 | theories/Iris/Base.v 51 | theories/Iris/BinaryResources.v 52 | theories/Iris/BinaryWeakestPre.v 53 | theories/Iris/BinaryAdequacy.v 54 | theories/Iris/BinaryInstance.v 55 | theories/Iris/cointro_patterns.v 56 | theories/MicroSail/RefineExecutor.v 57 | theories/MicroSail/ShallowExecutor.v 58 | theories/MicroSail/ShallowSoundness.v 59 | theories/MicroSail/Soundness.v 60 | theories/MicroSail/SymbolicExecutor.v 61 | theories/Notations.v 62 | theories/Prelude.v 63 | theories/Program.v 64 | theories/Refinement/Monads.v 65 | theories/Semantics.v 66 | theories/Semantics/Registers.v 67 | theories/Sep/Hoare.v 68 | theories/Sep/Logic.v 69 | theories/Shallow/Monads.v 70 | theories/Signature.v 71 | theories/SmallStep/Inversion.v 72 | theories/SmallStep/Progress.v 73 | theories/SmallStep/Step.v 74 | theories/Specification.v 75 | theories/Symbolic/Instantiation.v 76 | theories/Symbolic/Monads.v 77 | theories/Symbolic/OccursCheck.v 78 | theories/Symbolic/PartialEvaluation.v 79 | theories/Symbolic/Propositions.v 80 | theories/Symbolic/Solver.v 81 | theories/Symbolic/UnifLogic.v 82 | theories/Symbolic/Worlds.v 83 | theories/Syntax/Assertions.v 84 | theories/Syntax/BinOps.v 85 | theories/Syntax/Chunks.v 86 | theories/Syntax/Expressions.v 87 | theories/Syntax/Formulas.v 88 | theories/Syntax/FunDecl.v 89 | theories/Syntax/FunDef.v 90 | theories/Syntax/Messages.v 91 | theories/Syntax/Patterns.v 92 | theories/Syntax/Predicates.v 93 | theories/Syntax/Registers.v 94 | theories/Syntax/Statements.v 95 | theories/Syntax/Terms.v 96 | theories/Syntax/TypeDecl.v 97 | theories/Syntax/UnOps.v 98 | theories/Syntax/Variables.v 99 | theories/Tactics.v 100 | 101 | theories/Staging/CommandStep.v 102 | # theories/Staging/BinaryExecutor/ShallowExecutorRel.v 103 | # theories/Staging/NewShallow/Executor.v 104 | # theories/Staging/NewShallow/IrisInstance.v 105 | # theories/Staging/NewShallow/Soundness.v 106 | # theories/Staging/WorldInstance.v 107 | # theories/Staging/WorldIsomorphisms.v 108 | -------------------------------------------------------------------------------- /case_study/Assumptions.v: -------------------------------------------------------------------------------- 1 | 2 | Require 3 | Katamaran.MinimalCaps.LoopVerification 4 | Katamaran.RiscvPmp.FemtoKernel 5 | Katamaran.RiscvPmp.LoopVerification. 6 | Import Coq.Numbers.BinNums Coq.Strings.String Bitvector. 7 | 8 | Goal True. idtac "Assumptions of MinimalCaps universal contract:". Abort. 9 | Print Assumptions MinimalCaps.LoopVerification.valid_semContract_loop2. 10 | 11 | Goal True. idtac "Assumptions of Risc-V PMP universal contract:". Abort. 12 | Print Assumptions RiscvPmp.LoopVerification.valid_semTriple_loop. 13 | 14 | Goal True. idtac "Assumptions of FemtoKernel verification:". Abort. 15 | Print Assumptions RiscvPmp.FemtoKernel.femtokernel_init_safe. 16 | 17 | Goal True. idtac "Assumptions of femtokernel end-to-end theorem:". Abort. 18 | Print Assumptions RiscvPmp.FemtoKernel.femtokernel_endToEnd. 19 | -------------------------------------------------------------------------------- /case_study/MinimalCaps/Contracts/Notations.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Steven Keuchel, Dominique Devriese, Sander Huyghebaert *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Strings.String. 31 | From Katamaran Require Import 32 | MinimalCaps.Machine 33 | MinimalCaps.Sig 34 | Specification. 35 | 36 | Import ctx.notations. 37 | Import ctx.resolution. 38 | Import env.notations. 39 | Import MinCapsSignature. 40 | Open Scope string_scope. 41 | Open Scope ctx_scope. 42 | 43 | Module Notations. 44 | Inductive MinCapsBinding : Set := 45 | | B (name : string) (type : Ty) 46 | | destruct_cap (p b e a : string). 47 | 48 | Definition DCtx := Ctx MinCapsBinding. 49 | 50 | Declare Scope dctx_scope. 51 | Delimit Scope dctx_scope with dctx. 52 | Notation "x '::' τ" := (B x τ) : dctx_scope. 53 | Notation "'(' p ',' b ',' e ',' a ')' '::' 'ty.cap'" := 54 | (destruct_cap p b e a) : dctx_scope. 55 | (* Use the same notations as in ctx.notations *) 56 | Notation "[ ]" := (ctx.nil) : dctx_scope. 57 | Notation "[ctx]" := (ctx.nil) : dctx_scope. 58 | Notation "[ x ]" := (ctx.snoc ctx.nil x%dctx) : dctx_scope. 59 | Notation "[ x ; y ; .. ; z ]" := 60 | (ctx.snoc .. (ctx.snoc (ctx.snoc ctx.nil x%dctx) y%dctx) .. z%dctx) : dctx_scope. 61 | 62 | Fixpoint DCtx_to_PCtx (ctx : DCtx) : PCtx := 63 | match ctx with 64 | | ε => ε 65 | | Γ ▻ (B x σ) => DCtx_to_PCtx Γ ▻ (x∷σ) 66 | | Γ ▻ (destruct_cap p b e a) => 67 | DCtx_to_PCtx Γ ▻ (p∷ty.perm) ▻ (b∷ty.addr) ▻ (e∷ty.addr) ▻ (a∷ty.addr) 68 | end. 69 | 70 | Fixpoint DCtx_progvars (ctx : DCtx) : LCtx := 71 | match ctx with 72 | | ε => ε 73 | | Γ ▻ (B x σ) => DCtx_progvars Γ ▻ (x∷σ) 74 | | Γ ▻ (destruct_cap p b e a) => 75 | DCtx_progvars Γ ▻ (p∷ty.perm) ▻ (b∷ty.addr) ▻ (e∷ty.addr) ▻ (a∷ty.addr) 76 | end. 77 | 78 | Definition DCtx_logvars (Δ : DCtx) (Σ : LCtx) := 79 | DCtx_progvars Δ ▻▻ Σ. 80 | 81 | Fixpoint DCtx_to_Args (ctx : DCtx) (names : LCtx) : LCtx := 82 | match ctx, names with 83 | | ε , _ => ε 84 | | _ , ε => ε 85 | | Γ ▻ (B x σ) , Δ ▻ _ => DCtx_to_Args Γ Δ ▻ (x∷σ) 86 | | Γ ▻ (destruct_cap _ _ _ _) , Δ ▻ (c∷_) => 87 | let Γ' := DCtx_to_Args Γ Δ in 88 | Γ' ▻ (c∷ty.cap) 89 | end. 90 | 91 | #[program] Definition DCtx_to_SStore (Δ : DCtx) (names : LCtx) (Σ : LCtx) : SStore (DCtx_to_Args Δ names) (DCtx_logvars Δ Σ). 92 | Proof. 93 | generalize dependent names. 94 | induction Δ. 95 | - destruct names; simpl; exact [env]. 96 | - destruct names; simpl; first (destruct b; exact [env]). 97 | destruct b as [x τ | p b e a]. 98 | + unshelve eapply (env.snoc _ (_∷_) (term_var x)). 99 | fold DCtx_to_Args. 100 | apply env.tabulate. 101 | intros b bIn. 102 | pose proof (env.lookup (IHΔ names) bIn) as t. 103 | unshelve eapply (sub_term t _). 104 | unfold DCtx_logvars. 105 | simpl. 106 | apply sub_up. 107 | apply sub_wk1. 108 | simpl. 109 | unfold DCtx_logvars. 110 | apply ctx.in_cat_left. 111 | simpl. 112 | apply ctx.in_zero. 113 | + unfold DCtx_logvars; simpl. 114 | unshelve eapply 115 | (env.snoc _ (_∷_) 116 | (term_record capability [env].["cap_permission"∷ty.perm ↦ term_var p] 117 | .["cap_begin"∷ty.addr ↦ term_var b] 118 | .["cap_end"∷ty.addr ↦ term_var e] 119 | .["cap_cursor"∷ty.addr ↦ term_var a])); simpl; 120 | repeat 121 | (try apply ctx.in_cat_left; 122 | try apply ctx.in_zero; 123 | apply ctx.in_succ). 124 | apply env.tabulate. 125 | intros b1 b1In. 126 | pose proof (env.lookup (IHΔ names) b1In) as t. 127 | unshelve eapply (sub_term t _). 128 | unfold DCtx_logvars. 129 | apply sub_up. 130 | simpl. 131 | change (DCtx_progvars Δ ▻ p∷ty.perm ▻ b∷ty.addr ▻ e∷ty.addr ▻ a∷ty.addr) with (DCtx_progvars Δ ▻▻ [p∷ty.perm; b∷ty.addr; e∷ty.addr; a∷ty.addr]). 132 | apply sub_cat_left. 133 | Defined. 134 | 135 | (* TODO: following module needs to move into this file *) 136 | Import MinCapsContractNotations. 137 | 138 | (* 𝒱 should only be used with terms of type word or cap, otherwise it just 139 | returns bottom *) 140 | Definition 𝒱 {Σ τ} : Term Σ τ -> Assertion Σ := 141 | match τ with 142 | | ty.word => fun w => asn_safe w 143 | | ty.cap => fun w => asn_csafe w 144 | | ty.int => fun w => asn_safe (term_inl w) 145 | | _ => fun _ => ⊥ 146 | end. 147 | 148 | Notation "'(' tp ',' tb ',' te ',' ta ')'" := 149 | (term_record capability [tp; tb; te; ta]) : term_scope. 150 | Notation "'𝒱' '(' tp ',' tb ',' te ',' ta ')'" := 151 | (𝒱 (term_record capability [tp; tb; te; ta])) : term_scope. 152 | Notation "'𝒱' '(' t ')'" := 153 | (𝒱 t) : term_scope. 154 | 155 | Module ContractNotations. 156 | Record Fn {Δ τ} : Set := 157 | fn { fnsig : Fun Δ τ; 158 | args : DCtx; 159 | ret : Ty }. 160 | Arguments fn {Δ τ} fnsig args%_dctx ret. 161 | 162 | Definition fnsig_args {Δ τ} (f : @Fn Δ τ) := Δ. 163 | 164 | Notation "'{{' P '}}' fn '{{' res ',' Q '}}' 'with' logvars" := 165 | (MkSepContract (DCtx_to_Args (args fn) (fnsig_args fn)) (ret fn) (DCtx_logvars (args fn) logvars%ctx) 166 | (DCtx_to_SStore (args fn) (fnsig_args fn) logvars%ctx) 167 | P%term 168 | res 169 | Q%term) (at level 200, P at level 100, Q at level 100, res at level 100, fn at level 100, logvars at level 100). 170 | Notation "'{{' P '}}' fn '{{' res ',' Q '}}'" := 171 | (MkSepContract (DCtx_to_Args (args fn) (fnsig_args fn)) (ret fn) (DCtx_logvars (args fn) []%ctx) 172 | (DCtx_to_SStore (args fn) (fnsig_args fn) []%ctx) 173 | P%term 174 | res 175 | Q%term) (at level 200, P at level 100, Q at level 100, res at level 100, fn at level 100). 176 | End ContractNotations. 177 | 178 | Module LemmaNotations. 179 | Record Lm {Δ} : Set := 180 | lem { lemsig : Lem Δ; 181 | lemargs : DCtx }. 182 | Arguments lem {Δ} lemsig lemargs%_dctx. 183 | 184 | Definition lemsig_args {Δ} (l : @Lm Δ) := Δ. 185 | 186 | Notation "'{{' P '}}' l '{{' Q '}}' 'with' logvars" := 187 | (MkLemma (DCtx_to_Args (lemargs l) (lemsig_args l)) (DCtx_logvars (lemargs l) logvars%ctx) 188 | (DCtx_to_SStore (lemargs l) (lemsig_args l) logvars%ctx) 189 | P%term 190 | Q%term) (at level 200, P at level 100, Q at level 100, l at level 100, logvars at level 100). 191 | Notation "'{{' P '}}' l '{{' Q '}}'" := 192 | (MkLemma (DCtx_to_Args (lemargs l) (lemsig_args l)) (DCtx_logvars (lemargs l) []%ctx) 193 | (DCtx_to_SStore (lemargs l) (lemsig_args l) []%ctx) 194 | P%term 195 | Q%term) (at level 200, P at level 100, Q at level 100, l at level 100). 196 | End LemmaNotations. 197 | 198 | Module ForeignNotations. 199 | Record FnX {Δ τ} : Set := 200 | fn { fnsig : FunX Δ τ; (* Funx <> Fun (see Fn record) *) 201 | args : DCtx; 202 | ret : Ty }. 203 | Arguments fn {Δ τ} fnsig args%_dctx ret. 204 | 205 | Definition fnsig_args {Δ τ} (f : @FnX Δ τ) := Δ. 206 | 207 | Notation "'{{' P '}}' fn '{{' res ',' Q '}}' 'with' logvars" := 208 | (MkSepContract (DCtx_to_Args (args fn) (fnsig_args fn)) (ret fn) (DCtx_logvars (args fn) logvars%ctx) 209 | (DCtx_to_SStore (args fn) (fnsig_args fn) logvars%ctx) 210 | P%term 211 | res 212 | Q%term) (at level 200, P at level 100, Q at level 100, res at level 100, fn at level 100, logvars at level 100). 213 | Notation "'{{' P '}}' fn '{{' res ',' Q '}}'" := 214 | (MkSepContract (DCtx_to_Args (args fn) (fnsig_args fn)) (ret fn) (DCtx_logvars (args fn) []%ctx) 215 | (DCtx_to_SStore (args fn) (fnsig_args fn) []%ctx) 216 | P%term 217 | res 218 | Q%term) (at level 200, P at level 100, Q at level 100, res at level 100, fn at level 100). 219 | End ForeignNotations. 220 | End Notations. 221 | -------------------------------------------------------------------------------- /case_study/MinimalCaps/Contracts/Statistics.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Steven Keuchel, Dominique Devriese, Sander Huyghebaert *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Program.Tactics 31 | Strings.String 32 | ZArith.ZArith 33 | Classes.EquivDec 34 | micromega.Lia. 35 | 36 | From Equations Require Import 37 | Equations. 38 | 39 | From Katamaran Require Import 40 | Specification 41 | MinimalCaps.Machine 42 | MinimalCaps.Contracts.Verification. 43 | 44 | Section Statistics. 45 | Import MinCapsExecutor. 46 | Import List.ListNotations. 47 | 48 | Definition all_functions : list { Δ & { σ & Fun Δ σ } } := 49 | [ existT _ (existT _ read_reg); 50 | existT _ (existT _ read_reg_cap); 51 | existT _ (existT _ read_reg_num); 52 | existT _ (existT _ write_reg); 53 | existT _ (existT _ next_pc); 54 | existT _ (existT _ update_pc); 55 | existT _ (existT _ add_pc); 56 | existT _ (existT _ read_mem); 57 | existT _ (existT _ write_mem); 58 | existT _ (existT _ read_allowed); 59 | existT _ (existT _ write_allowed); 60 | existT _ (existT _ within_bounds); 61 | existT _ (existT _ perm_to_bits); 62 | existT _ (existT _ perm_from_bits); 63 | existT _ (existT _ and_perm); 64 | existT _ (existT _ is_sub_perm); 65 | existT _ (existT _ is_within_range); 66 | existT _ (existT _ abs); 67 | existT _ (existT _ is_not_zero); 68 | existT _ (existT _ can_incr_cursor); 69 | existT _ (existT _ exec_jalr_cap); 70 | existT _ (existT _ exec_cjalr); 71 | existT _ (existT _ exec_cjal); 72 | existT _ (existT _ exec_bne); 73 | existT _ (existT _ exec_cmove); 74 | existT _ (existT _ exec_ld); 75 | existT _ (existT _ exec_sd); 76 | existT _ (existT _ exec_cincoffset); 77 | existT _ (existT _ exec_candperm); 78 | existT _ (existT _ exec_csetbounds); 79 | existT _ (existT _ exec_csetboundsimm); 80 | existT _ (existT _ exec_cgettag); 81 | existT _ (existT _ exec_addi); 82 | existT _ (existT _ exec_add); 83 | existT _ (existT _ exec_sub); 84 | existT _ (existT _ exec_slt); 85 | existT _ (existT _ exec_slti); 86 | existT _ (existT _ exec_sltu); 87 | existT _ (existT _ exec_sltiu); 88 | existT _ (existT _ exec_cgetperm); 89 | existT _ (existT _ exec_cgetbase); 90 | existT _ (existT _ exec_cgetlen); 91 | existT _ (existT _ exec_cgetaddr); 92 | existT _ (existT _ exec_fail); 93 | existT _ (existT _ exec_ret); 94 | existT _ (existT _ exec_instr); 95 | existT _ (existT _ exec); 96 | existT _ (existT _ step); 97 | existT _ (existT _ loop) 98 | ]%list. 99 | 100 | Definition symbolic_stats : Stats := 101 | List.fold_right 102 | (fun '(existT _ (existT _ f)) r => 103 | match Symbolic.Statistics.calc f with 104 | | Some s => plus_stats s r 105 | | None => r 106 | end) 107 | empty_stats 108 | all_functions. 109 | 110 | Goal True. 111 | idtac "Symbolic branching statistics:". 112 | let t := eval compute in symbolic_stats in idtac t. 113 | Abort. 114 | 115 | (* The counting of the shallow nodes is too slow in Ltac. Hence there is and 116 | alternative command line solution. *) 117 | 118 | End Statistics. 119 | -------------------------------------------------------------------------------- /case_study/MinimalCaps/README.md: -------------------------------------------------------------------------------- 1 | # Cerise Comparison 2 | 3 | ## Instructions 4 | 5 | | Cerise | MinimalCaps (CHERI-RISC-V) | 6 | |----------|------------------------------------------------------------------------------| 7 | | Fail | Fail (“Illegal”1) | 8 | | Halt | Ret (“HLT”2) | 9 | | Jmp | Jalr.cap(cd, cs), CJalr(cd, cs, imm), CJal(cd, imm) | 10 | | Jnz | Bne(rs1, rs2, imm) | 11 | | Load | Ld(rd, rs, imm) | 12 | | Store | Sd(rs1, rs2, imm) | 13 | | Mov | CMove(cd, cs) (int move = addi) | 14 | | Lea | CIncOffset(cd, cs, rs) | 15 | | Restrict | CAndPerm(cd, cs, rs) | 16 | | Add | Add(rd, rs1, rs2), Addi(rd, rs, imm) | 17 | | Sub | Sub(rd, rs1, rs2) | 18 | | Lt | Slt(rd, rs1, rs2), Slti(rd, rs, imm), Sltu(rd, rs1, rs2), Sltiu(rd, rs, imm) | 19 | | Subseg | CSetBounds(cd, cs, rs), CSetBoundsImm(cd, cs, imm) | 20 | | GetA | CGetAddr(rd, cs) | 21 | | GetB | CGetBase(rd, cs) | 22 | | GetE | CGetLen(rd, cs) | 23 | | GetP | CGetPerm(rd, cs) | 24 | | IsPtr | CGetTag(rd, cs) | 25 | 26 | 1: No literal “fail” instruction, but the effect can be achieved with any illegal instruction encoding (for example, writing “HLT” or “FAIL” as an instruction) 27 | 28 | 2: The Ret of RISC-V will return from the subroutine, i.e., giving control back to the caller, an actual halt can be achieved similar to Fail 29 | -------------------------------------------------------------------------------- /case_study/MinimalCaps/Shallow.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2022 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | ZArith.ZArith. 31 | From Katamaran.MinimalCaps Require Import 32 | Contracts 33 | Machine. 34 | 35 | Import MinCapsProgram. 36 | Import MinCapsSpecification. 37 | Import MinCapsShallowExec. 38 | 39 | Definition all_shallow_vcs : Prop := 40 | List.fold_right 41 | (fun '(existT _ (existT _ f)) r => 42 | match CEnv f with 43 | | Some c => Shallow.ValidContract c (FunDef f) /\ r 44 | | None => r 45 | end) 46 | True 47 | all_functions. 48 | 49 | Set Printing Depth 500. 50 | Goal True. 51 | idtac "Shallow VC:". 52 | let P := eval compute - [CPureSpecM.FALSE CPureSpecM.TRUE CPureSpecM.FINISH 53 | negb Z.mul Z.opp Z.compare Z.add Z.geb Z.eqb 54 | Z.leb Z.gtb Z.ltb Z.le Z.lt Z.gt Z.ge] 55 | in all_shallow_vcs 56 | in idtac P. 57 | Abort. 58 | -------------------------------------------------------------------------------- /case_study/MinimalCaps/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Katamaran.MinimalCaps) 3 | (package coq-katamaran) 4 | (modules Base Machine Contracts Model) 5 | (theories Katamaran)) 6 | 7 | (include_subdirs qualified) 8 | -------------------------------------------------------------------------------- /case_study/RiscvPmp/IrisModel.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Steven Keuchel, Dominique Devriese, Sander Huyghebaert *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Katamaran Require Import 30 | Bitvector 31 | Environment 32 | Iris.Base 33 | RiscvPmp.Machine 34 | trace. 35 | From iris Require Import 36 | base_logic.lib.gen_heap 37 | proofmode.tactics. 38 | 39 | Set Implicit Arguments. 40 | 41 | Import RiscvPmpProgram. 42 | 43 | (* Instantiate the Iris framework solely using the operational semantics. At 44 | this point we do not commit to a set of contracts nor to a set of 45 | user-defined predicates. *) 46 | Module RiscvPmpIrisBase <: IrisBase RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 47 | (* Pull in the definition of the LanguageMixin and register ghost state. *) 48 | Include IrisPrelims RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 49 | 50 | (* Defines the memory ghost state. *) 51 | Section RiscvPmpIrisParams. 52 | Import bv. 53 | Definition Byte : Set := bv 8. 54 | Definition MemVal : Set := Byte. 55 | 56 | (* NOTE: no resource present for current `State`, since we do not wish to reason about it for now *) 57 | Class mcMemGS Σ := 58 | McMemGS { 59 | (* ghost variable for tracking state of heap *) 60 | mc_ghGS : gen_heapGS Addr MemVal Σ; 61 | (* tracking traces *) 62 | mc_gtGS : traceG Trace Σ; 63 | }. 64 | #[export] Existing Instance mc_ghGS. 65 | #[export] Existing Instance mc_gtGS. 66 | 67 | Definition memGS : gFunctors -> Set := mcMemGS. 68 | 69 | Definition mem_inv : forall {Σ}, mcMemGS Σ -> Memory -> iProp Σ := 70 | fun {Σ} hG μ => 71 | (∃ memmap, gen_heap_interp memmap 72 | ∗ ⌜ map_Forall (fun a v => memory_ram μ a = v) memmap ⌝ 73 | ∗ tr_auth1 (memory_trace μ) 74 | )%I. 75 | 76 | End RiscvPmpIrisParams. 77 | 78 | Include IrisResources RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 79 | Include IrisWeakestPre RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 80 | Include IrisTotalWeakestPre RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 81 | Include IrisTotalPartialWeakestPre RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 82 | 83 | Import iris.program_logic.weakestpre. 84 | 85 | Definition WP_loop `{sg : sailGS Σ} : iProp Σ := 86 | semWP env.nil (FunDef loop) (fun _ _ => True%I). 87 | 88 | (* Useful instance for some of the Iris proofs *) 89 | #[export] Instance state_inhabited : Inhabited State. 90 | Proof. repeat constructor. 91 | - intros ty reg. apply val_inhabited. 92 | - intro. apply bv.bv_inhabited. 93 | - apply state_inhabited. 94 | Qed. 95 | 96 | End RiscvPmpIrisBase. 97 | -------------------------------------------------------------------------------- /case_study/RiscvPmp/IrisModelBinary.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Steven Keuchel, Dominique Devriese, Sander Huyghebaert *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Katamaran Require Import 30 | Bitvector 31 | Environment 32 | trace 33 | Iris.Base 34 | Iris.BinaryResources 35 | RiscvPmp.Machine 36 | RiscvPmp.IrisModel 37 | RiscvPmp.IrisInstance. 38 | From iris Require Import 39 | base_logic.lib.gen_heap 40 | proofmode.tactics. 41 | 42 | Set Implicit Arguments. 43 | 44 | Import RiscvPmpProgram. 45 | 46 | (* Instantiate the Iris framework solely using the operational semantics. At 47 | this point we do not commit to a set of contracts nor to a set of 48 | user-defined predicates. *) 49 | Module RiscvPmpIrisBase2 <: IrisBase2 RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 50 | (* Pull in the definition of the LanguageMixin and register ghost state. *) 51 | Include RiscvPmpIrisBase. 52 | Import RiscvPmpIrisAdeqParameters. 53 | 54 | (* Defines the memory ghost state. *) 55 | Section RiscvPmpIrisParams2. 56 | Import bv. 57 | 58 | Class mcMemGS2 Σ := 59 | McMemGS2 { 60 | (* two copies of the unary ghost variables *) 61 | mc_ghGS2_left : RiscvPmpIrisBase.mcMemGS Σ 62 | ; mc_ghGS2_right : RiscvPmpIrisBase.mcMemGS Σ 63 | ; mc_gtGS2_left : traceG Trace Σ 64 | ; mc_gtGS2_right : traceG Trace Σ 65 | }. 66 | 67 | Definition memGS2 : gFunctors -> Set := mcMemGS2. 68 | Definition memGS2_memGS_left := @mc_ghGS2_left. 69 | Definition memGS2_memGS_right := @mc_ghGS2_right. 70 | Definition mem_inv2 : forall {Σ}, mcMemGS2 Σ -> Memory -> Memory -> iProp Σ := 71 | fun {Σ} hG μ1 μ2 => 72 | (RiscvPmpIrisBase.mem_inv mc_ghGS2_left μ1 ∗ RiscvPmpIrisBase.mem_inv mc_ghGS2_right μ2)%I. 73 | Lemma mem_inv2_mem_inv : 74 | forall `{mG : memGS2 Σ} (μ1 μ2 : Memory), 75 | mem_inv2 mG μ1 μ2 ⊣⊢ mem_inv (memGS2_memGS_left mG) μ1 ∗ mem_inv (memGS2_memGS_right mG) μ2. 76 | Proof. by unfold mem_inv2. Qed. 77 | End RiscvPmpIrisParams2. 78 | 79 | Include IrisResources2 RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 80 | 81 | End RiscvPmpIrisBase2. 82 | 83 | -------------------------------------------------------------------------------- /case_study/RiscvPmp/README.md: -------------------------------------------------------------------------------- 1 | # Case Study: RISC-V with PMP 2 | Case study for (base) RISC-V with Physical Memory Protection (PMP). 3 | 4 | Focus is on RV32I, with the PMP extension. 5 | Remarks/Comments/Info: 6 | - instructions with "W" suffix are not implemented (these are for RV64 and are variants that operate only on the lower 32 bits of a doubleword) 7 | - fence instructions not implemented, our model is simple and sequential, updates to registers and memory happen instantly 8 | - WFI (wait for interrupt) instruction not implemented, focus in this model is on exceptions, not interrupts 9 | - store & load instructions are simplified (i.e. no size, always word, no sign/zero extension, no aq or rl 10 | - keep AccessType simple (i.e. no type parameter for extensions, this is ignored in the PMP related code anyway), but still represent it as a *union* (note that we could opt to represent this as an enum, but this way is more faithful to the (simplified) Sail model) 11 | - the model does not support S-mode, so any checks/pattern matches that depend on M-mode and S-mode privileges are simplified to only consider the M-mode case 12 | - some auxiliary functions that convert bits to enums are dropped, the model uses the enum immediately (example: pmpAddrRange calls a function pmpAddrMatchType_of_bits that converts a bitvector into the corresponding enum value of PmpAddrMatchType) 13 | - note that the main loop (function "loop") just calls the step function, this is a lot simpler than the one in the actual sail model, which is complicated with tracing, interrupts, ... 14 | - step function shortened, dropped extension related code, also not doing anything with the "retire" result of an execution (has to do with "minstret", doesn't seem relevant for our case study at this point) 15 | + have kept the "stm_lit ty_retire RETIRE_SUCCESS/FAIL" stmts tho, can however drop this? (TODO: consider) 16 | - the fetch function is simplified, in the sail model it reads 16 bits at a time (to support the compressed extension), in our case we read the entire instruction at once (no support for the compressed extension) (this also means our fetchresult type is simplified) 17 | - trap vector register (mtvec) is limited to only direct mode, i.e. we don't include "mode" bit and take the address in mtvec as is 18 | - the mcause register is limited to just contain an exception code, this suffices for our purposes 19 | - No alignment checks 20 | - exception_delegatee is simplified, note that we can never transition to a less-privileged mode, resulting in this function always returning M-mode (we only have M-mode and U-mode support) 21 | - mem related function are simplified and some auxiliary functions are inlined (see riscv_mem.sail, example: mem_write_value calls mem_write_value_meta, which is inlined in our model) 22 | - mstatus is limited to those fields we require. The fields themselves are also *NOT* bits but rather the corresponding non-bit representation (for example: MPP is normally a 2-bit field of mstatus but in our model is a field that will contain Privilege enum value), this means that we don't need the conversion functions from/to bits 23 | 24 | ## Translation Notes 25 | Inline function call expressions get translated into 26 | ``` 27 | # ... 28 | # | RISCV_AUIPC => get_arch_pc() + off 29 | # ==> 30 | | RISCV_AUIPC => 31 | let: tmp := call get_arch_pc in 32 | tmp + off 33 | ``` 34 | 35 | Currently omitting alignment related checks and exceptions (bitvector support needed for this). 36 | -> OR simply check if address is divisible by 4? 37 | 38 | Ignoring instructions that rely on bitvector operations (like shift operations), this mostly affects the support for RTYPE- and ITYPE-instructions. 39 | 40 | ## Source 41 | 42 | This machine is based on a minimal model of the official RISC-V Sail model. 43 | 44 | The machine that this case study represents is based on the official RISC-V code, more specifically, (parts of) the following files: 45 | - [Base Instructions](https://github.com/rems-project/sail-riscv/blob/master/model/riscv_insts_base.sail) 46 | - [PMP Configuration](https://github.com/rems-project/sail-riscv/blob/master/model/riscv_pmp_regs.sail) 47 | - [PMP](https://github.com/rems-project/sail-riscv/blob/master/model/riscv_pmp_control.sail) 48 | -------------------------------------------------------------------------------- /case_study/RiscvPmp/trace.v: -------------------------------------------------------------------------------- 1 | From iris.algebra Require Import auth excl. 2 | From iris.base_logic Require Import lib.own. 3 | From iris.proofmode Require Import tactics. 4 | 5 | Class traceG (Trace : Type) Σ := TraceG { 6 | trace_inG :: inG Σ (authR (optionUR (exclR (leibnizO Trace)))); 7 | trace_name : gname 8 | }. 9 | 10 | Definition tracePreΣ (Trace : Type) : gFunctors := #[GFunctor (authR (optionUR (exclR (leibnizO Trace))))]. 11 | 12 | Class trace_preG (Trace : Type) Σ := { 13 | trace_preG_inG :: inG Σ (authR (optionUR (exclR (leibnizO Trace)))); 14 | }. 15 | 16 | #[export] Instance traceG_preG `{traceG T Σ} : trace_preG T Σ. 17 | Proof. constructor. typeclasses eauto. Defined. 18 | 19 | #[export] Instance subG_tracePreΣ {Σ T}: 20 | subG (tracePreΣ T) Σ → 21 | trace_preG T Σ. 22 | Proof. solve_inG. Qed. 23 | 24 | Section S. 25 | Context `{!trace_preG T Σ}. 26 | Context (γ : gname). (* To allow using different gnames *) 27 | 28 | Definition tr_auth (t: T) : iProp Σ := own γ (● (Some (Excl (t: leibnizO T)))). 29 | Definition tr_frag (t: T) : iProp Σ := own γ (◯ (Some (Excl (t: leibnizO T)))). 30 | 31 | Lemma trace_full_frag_eq t t': 32 | tr_auth t -∗ tr_frag t' -∗ 33 | ⌜ t = t' ⌝. 34 | Proof. 35 | iIntros "H1 H2". 36 | iDestruct (own_valid_2 with "H1 H2") as %[Hi Hv]%auth_both_valid_discrete. 37 | rewrite Excl_included in Hi. apply leibniz_equiv in Hi. subst; auto. 38 | Qed. 39 | 40 | Lemma tr_frag_excl t t' : 41 | tr_frag t -∗ tr_frag t' -∗ ⌜ False ⌝. 42 | Proof. 43 | iIntros "H1 H2". iDestruct (own_valid_2 with "H1 H2") as %Hv. 44 | now apply excl_auth.excl_auth_frag_op_valid in Hv. 45 | Qed. 46 | 47 | Lemma trace_update t t' : 48 | tr_auth t ∗ tr_frag t ==∗ 49 | tr_auth t' ∗ tr_frag t'. 50 | Proof. 51 | rewrite /tr_auth /tr_frag. rewrite -!own_op. 52 | iApply own_update. apply auth_update. 53 | apply option_local_update. 54 | apply exclusive_local_update. constructor. 55 | Qed. 56 | 57 | (* For the moment, there is no need for a lemma stating that traces can only be appened to, but we could customize the RA to enforce this. *) 58 | 59 | #[export] Instance tr_auth_Timeless t : Timeless (tr_auth t). 60 | Proof. 61 | intros. apply _. 62 | Qed. 63 | 64 | #[export] Instance tr_frag_Timeless t : Timeless (tr_frag t). 65 | Proof. 66 | intros. apply _. 67 | Qed. 68 | End S. 69 | 70 | Notation tr_auth1 := (tr_auth trace_name). 71 | Notation tr_frag1 := (tr_frag trace_name). 72 | 73 | Lemma trace_alloc_names `{!trace_preG T Σ} t : 74 | ⊢ |==> ∃ γ, tr_auth γ t ∗ tr_frag γ t. 75 | Proof. 76 | iMod (own_alloc (● (Some (Excl (t: leibnizO T))) ⋅ ◯ (Some (Excl (t: leibnizO T))))) as (γ) "[? ?]". 77 | { apply auth_both_valid_2; done. } 78 | iModIntro. iExists _. iFrame. 79 | Qed. 80 | 81 | Lemma trace_alloc `{!trace_preG T Σ} t : 82 | ⊢ |==> ∃ tG : traceG T Σ, 83 | 84 | @tr_auth _ _ (@traceG_preG _ _ tG) trace_name t ∗ @tr_frag _ _ (@traceG_preG _ _ tG) trace_name t. 85 | Proof. 86 | iMod (trace_alloc_names t) as (γ) "Hinit". 87 | by iExists (TraceG _ _ _ γ). 88 | Qed. 89 | 90 | (* Conditional trace fragments *) 91 | Definition tr_frag1_if `{traceG Σ} (trb : bool) t := 92 | if trb then tr_frag1 t else True%I. 93 | 94 | #[export] Instance tr_frag1_if_Timeless `{traceG Σ} trb t : Timeless (tr_frag1_if trb t). 95 | Proof. 96 | intros. rewrite /tr_frag1_if. destruct trb; apply _. 97 | Qed. 98 | -------------------------------------------------------------------------------- /case_study/deprecated/RiscvPmpUnboundedInts/IrisInstance.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Steven Keuchel, Dominique Devriese, Sander Huyghebaert *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Katamaran Require Import 30 | Base 31 | Iris.Instance 32 | Iris.Model 33 | Syntax.Predicates 34 | RiscvPmp.Base 35 | RiscvPmp.Machine 36 | RiscvPmp.IrisModel 37 | RiscvPmp.Sig. 38 | 39 | From iris.base_logic Require Import invariants lib.iprop lib.gen_heap. 40 | From iris.proofmode Require Import tactics. 41 | From stdpp Require namespaces. 42 | Module ns := stdpp.namespaces. 43 | 44 | Set Implicit Arguments. 45 | 46 | Module RiscvPmpIrisInstance <: 47 | IrisInstance RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics 48 | RiscvPmpSignature RiscvPmpIrisBase. 49 | Import RiscvPmpIrisBase. 50 | Import RiscvPmpProgram. 51 | 52 | Section WithSailGS. 53 | Context `{sailRegGS Σ} `{invGS Σ} `{mG : mcMemGS Σ}. 54 | 55 | Definition reg_file : gset (bv 3) := list_to_set (bv.finite.enum 3). 56 | 57 | Definition interp_ptsreg `{sailRegGS Σ} (r : RegIdx) (v : Word) : iProp Σ := 58 | match reg_convert r with 59 | | Some x => reg_pointsTo x v 60 | | None => True 61 | end. 62 | 63 | Definition interp_gprs : iProp Σ := 64 | [∗ set] r ∈ reg_file, (∃ v, interp_ptsreg r v)%I. 65 | 66 | Definition PmpEntryCfg : Set := Pmpcfg_ent * Xlenbits. 67 | 68 | Definition interp_pmp_entries (entries : list PmpEntryCfg) : iProp Σ := 69 | match entries with 70 | | (cfg0, addr0) :: (cfg1, addr1) :: [] => 71 | reg_pointsTo pmp0cfg cfg0 ∗ 72 | reg_pointsTo pmpaddr0 addr0 ∗ 73 | reg_pointsTo pmp1cfg cfg1 ∗ 74 | reg_pointsTo pmpaddr1 addr1 75 | | _ => False 76 | end. 77 | 78 | Definition femto_inv_ns : ns.namespace := (ns.ndot ns.nroot "ptsto_readonly"). 79 | Definition interp_ptsto (addr : Addr) (w : Word) : iProp Σ := 80 | mapsto addr (DfracOwn 1) w. 81 | Definition interp_ptsto_readonly (addr : Addr) (w : Word) : iProp Σ := 82 | inv femto_inv_ns (interp_ptsto addr w). 83 | Definition ptstoSth : Addr -> iProp Σ := fun a => (∃ w, interp_ptsto a w)%I. 84 | Definition ptstoSthL : list Addr -> iProp Σ := 85 | fun addrs => ([∗ list] k↦a ∈ addrs, ptstoSth a)%I. 86 | Lemma ptstoSthL_app {l1 l2} : (ptstoSthL (l1 ++ l2) ⊣⊢ ptstoSthL l1 ∗ ptstoSthL l2)%I. 87 | Proof. eapply big_sepL_app. Qed. 88 | 89 | Definition interp_pmp_addr_access (addrs : list Addr) (entries : list PmpEntryCfg) (m : Privilege) : iProp Σ := 90 | [∗ list] a ∈ addrs, 91 | (⌜∃ p, Pmp_access a entries m p⌝ -∗ ptstoSth a)%I. 92 | 93 | Definition interp_pmp_addr_access_without (addr : Addr) (addrs : list Addr) (entries : list PmpEntryCfg) (m : Privilege) : iProp Σ := 94 | (ptstoSth addr -∗ interp_pmp_addr_access addrs entries m)%I. 95 | 96 | Definition interp_ptsto_instr (addr : Addr) (instr : AST) : iProp Σ := 97 | (∃ v, interp_ptsto addr v ∗ ⌜ pure_decode v = inr instr ⌝)%I. 98 | 99 | End WithSailGS. 100 | 101 | Section RiscvPmpIrisPredicates. 102 | 103 | Import env.notations. 104 | 105 | Equations(noeqns) luser_inst `{sailRegGS Σ, invGS Σ, mcMemGS Σ} 106 | (p : Predicate) (ts : Env Val (𝑯_Ty p)) : iProp Σ := 107 | | pmp_entries | [ v ] => interp_pmp_entries v 108 | | pmp_addr_access | [ entries; m ] => interp_pmp_addr_access liveAddrs entries m 109 | | pmp_addr_access_without | [ addr; entries; m ] => interp_pmp_addr_access_without addr liveAddrs entries m 110 | | gprs | _ => interp_gprs 111 | | ptsto | [ addr; w ] => interp_ptsto addr w 112 | | ptsto_readonly | [ addr; w ] => interp_ptsto_readonly addr w 113 | | encodes_instr | [ code; instr ] => ⌜ pure_decode code = inr instr ⌝%I 114 | | ptstomem | _ => True%I 115 | | ptstoinstr | [ addr; instr ] => interp_ptsto_instr addr instr. 116 | 117 | Ltac destruct_pmp_entries := 118 | repeat match goal with 119 | | x : Val ty_pmpentry |- _ => 120 | destruct x; auto 121 | | x : Val (ty.list ty_pmpentry) |- _ => 122 | destruct x; auto 123 | | x : list (Val ty_pmpentry) |- _ => 124 | destruct x; auto 125 | end. 126 | 127 | Definition lduplicate_inst `{sailRegGS Σ, invGS Σ, mcMemGS Σ} : 128 | forall (p : Predicate) (ts : Env Val (𝑯_Ty p)), 129 | is_duplicable p = true -> 130 | (luser_inst p ts) ⊢ (luser_inst p ts ∗ luser_inst p ts). 131 | Proof. 132 | destruct p; intros ts Heq; try discriminate Heq; 133 | clear Heq; cbn in *; env.destroy ts; destruct_pmp_entries; auto. 134 | Qed. 135 | 136 | End RiscvPmpIrisPredicates. 137 | 138 | Include IrisSignatureRules RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics 139 | RiscvPmpSignature RiscvPmpIrisBase. 140 | 141 | End RiscvPmpIrisInstance. 142 | -------------------------------------------------------------------------------- /case_study/deprecated/RiscvPmpUnboundedInts/IrisModel.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Steven Keuchel, Dominique Devriese, Sander Huyghebaert *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Katamaran Require Import 30 | Environment 31 | Iris.Model 32 | RiscvPmp.Machine. 33 | From iris Require Import 34 | base_logic.lib.gen_heap 35 | proofmode.tactics. 36 | 37 | Set Implicit Arguments. 38 | 39 | Import RiscvPmpProgram. 40 | 41 | (* Instantiate the Iris framework solely using the operational semantics. At 42 | this point we do not commit to a set of contracts nor to a set of 43 | user-defined predicates. *) 44 | Module RiscvPmpIrisBase <: IrisBase RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 45 | (* Pull in the definition of the LanguageMixin and register ghost state. *) 46 | Include IrisPrelims RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 47 | 48 | (* Defines the memory ghost state. *) 49 | Section RiscvPmpIrisParams. 50 | 51 | Definition MemVal : Set := Word. 52 | 53 | Class mcMemGS Σ := 54 | McMemGS { 55 | (* ghost variable for tracking state of registers *) 56 | mc_ghGS : gen_heapGS Addr MemVal Σ 57 | }. 58 | #[export] Existing Instance mc_ghGS. 59 | 60 | Definition memGpreS : gFunctors -> Set := fun Σ => gen_heapGpreS Addr MemVal Σ. 61 | Definition memGS : gFunctors -> Set := mcMemGS. 62 | Definition memΣ : gFunctors := gen_heapΣ Addr MemVal. 63 | 64 | Definition liveAddrs := seqZ minAddr (maxAddr - minAddr + 1). 65 | Lemma NoDup_liveAddrs : NoDup liveAddrs. 66 | eapply NoDup_seqZ. 67 | Qed. 68 | Definition initMemMap μ := (list_to_map (map (fun a => (a , μ a)) liveAddrs) : gmap Addr MemVal). 69 | 70 | Definition memΣ_GpreS : forall {Σ}, subG memΣ Σ -> memGpreS Σ := 71 | fun {Σ} => subG_gen_heapGpreS (Σ := Σ) (L := Addr) (V := MemVal). 72 | 73 | Definition mem_inv : forall {Σ}, mcMemGS Σ -> Memory -> iProp Σ := 74 | fun {Σ} hG μ => 75 | (∃ memmap, gen_heap_interp memmap ∗ 76 | ⌜ map_Forall (fun a v => μ a = v) memmap ⌝ 77 | )%I. 78 | 79 | Definition mem_res : forall {Σ}, mcMemGS Σ -> Memory -> iProp Σ := 80 | fun {Σ} hG μ => 81 | ([∗ list] a' ∈ liveAddrs, mapsto a' (DfracOwn 1) (μ a'))%I. 82 | 83 | Lemma initMemMap_works μ : map_Forall (λ (a : Addr) (v : MemVal), μ a = v) (initMemMap μ). 84 | Proof. 85 | unfold initMemMap. 86 | rewrite map_Forall_to_list. 87 | rewrite Forall_forall. 88 | intros (a , v). 89 | rewrite elem_of_map_to_list. 90 | intros el. 91 | apply elem_of_list_to_map_2 in el. 92 | apply elem_of_list_In in el. 93 | apply in_map_iff in el. 94 | by destruct el as (a' & <- & _). 95 | Qed. 96 | 97 | Lemma big_sepM_list_to_map {Σ} {A B : Type} `{Countable A} {l : list A} {f : A -> B} (F : A -> B -> iProp Σ) : 98 | NoDup l -> 99 | ([∗ map] l↦v ∈ (list_to_map (map (λ a : A, (a, f a)) l)), F l v) 100 | ⊢ 101 | [∗ list] v ∈ l, F v (f v). 102 | Proof. 103 | intros ndl. 104 | induction ndl. 105 | - now iIntros "_". 106 | - cbn. 107 | rewrite big_sepM_insert. 108 | + iIntros "[$ Hrest]". 109 | now iApply IHndl. 110 | + apply not_elem_of_list_to_map_1. 111 | change (fmap fst ?l) with (map fst l). 112 | now rewrite map_map map_id. 113 | Qed. 114 | 115 | Lemma mem_inv_init `{gHP : memGpreS Σ} (μ : Memory) : 116 | ⊢ |==> ∃ mG : mcMemGS Σ, (mem_inv mG μ ∗ mem_res mG μ)%I. 117 | Proof. 118 | iMod (gen_heap_init (gen_heapGpreS0 := gHP) (L := Addr) (V := MemVal) empty) as (gH) "[inv _]". 119 | 120 | pose (memmap := initMemMap μ). 121 | iMod (gen_heap_alloc_big empty memmap (map_disjoint_empty_r memmap) with "inv") as "(inv & res & _)". 122 | iModIntro. 123 | 124 | rewrite (right_id empty union memmap). 125 | 126 | iExists (McMemGS gH). 127 | iSplitL "inv". 128 | - iExists memmap. 129 | iFrame. 130 | iPureIntro. 131 | apply initMemMap_works. 132 | - unfold mem_res, initMemMap in *. 133 | iApply (big_sepM_list_to_map (f := μ) (fun a v => mapsto a (DfracOwn 1) v) with "[$]"). 134 | now eapply NoDup_liveAddrs. 135 | Qed. 136 | End RiscvPmpIrisParams. 137 | 138 | Include IrisResources RiscvPmpBase RiscvPmpProgram RiscvPmpSemantics. 139 | 140 | Import iris.program_logic.weakestpre. 141 | 142 | Definition WP_loop `{sg : sailGS Σ} : iProp Σ := 143 | semWP (FunDef loop) (fun _ _ => True%I) env.nil. 144 | 145 | End RiscvPmpIrisBase. 146 | -------------------------------------------------------------------------------- /case_study/deprecated/RiscvPmpUnboundedInts/README.md: -------------------------------------------------------------------------------- 1 | # Case Study: RISC-V with PMP 2 | Case study for (base) RISC-V with Physical Memory Protection (PMP). 3 | 4 | Focus is on RV32I, with the PMP extension. 5 | Remarks/Comments/Info: 6 | - instructions with "W" suffix are not implemented (these are for RV64 and are variants that operate only on the lower 32 bits of a doubleword) 7 | - fence instructions not implemented, our model is simple and sequential, updates to registers and memory happen instantly 8 | - WFI (wait for interrupt) instruction not implemented, focus in this model is on exceptions, not interrupts 9 | - store & load instructions are simplified (i.e. no size, always word, no sign/zero extension, no aq or rl 10 | - keep AccessType simple (i.e. no type parameter for extensions, this is ignored in the PMP related code anyway), but still represent it as a *union* (note that we could opt to represent this as an enum, but this way is more faithful to the (simplified) Sail model) 11 | - MemoryOpResult is simplified and MemValue can only be a Word (no type param in definition of MemoryOpResult, this complicates EqDec...) 12 | - Store instructions involve a function mem_write that returns a MemoryOpResult with a boolean value to indicate failure, to keep things simple (point above), I model this as a ty_word where 0 = false and 1 = true 13 | - the model does not support S-mode, so any checks/pattern matches that depend on M-mode and S-mode privileges are simplified to only consider the M-mode case 14 | - some auxiliary functions that convert bits to enums are dropped, the model uses the enum immediately (example: pmpAddrRange calls a function pmpAddrMatchType_of_bits that converts a bitvector into the corresponding enum value of PmpAddrMatchType) 15 | - note that the main loop (function "loop") just calls the step function, this is a lot simpler than the one in the actual sail model, which is complicated with tracing, interrupts, ... 16 | - step function shortened, dropped extension related code, also not doing anything with the "retire" result of an execution (has to do with "minstret", doesn't seem relevant for our case study at this point) 17 | + have kept the "stm_lit ty_retire RETIRE_SUCCESS/FAIL" stmts tho, can however drop this? (TODO: consider) 18 | - the fetch function is simplified, in the sail model it reads 16 bits at a time (to support the compressed extension), in our case we read the entire instruction at once (no support for the compressed extension) (this also means our fetchresult type is simplified) 19 | - trap vector register (mtvec) is limited to only direct mode, i.e. we don't include "mode" bit and take the address in mtvec as is 20 | - the mcause register is limited to just contain an exception code, this suffices for our purposes 21 | - No alignment checks 22 | - exception_delegatee is simplified, note that we can never transition to a less-privileged mode, resulting in this function always returning M-mode (we only have M-mode and U-mode support) 23 | - mem related function are simplified and some auxiliary functions are inlined (see riscv_mem.sail, example: mem_write_value calls mem_write_value_meta, which is inlined in our model) 24 | - mstatus is limited to those fields we require. The fields themselves are also *NOT* bits but rather the corresponding non-bit representation (for example: MPP is normally a 2-bit field of mstatus but in our model is a field that will contain Privilege enum value), this means that we don't need the conversion functions from/to bits 25 | 26 | ## Translation Notes 27 | Inline function call expressions get translated into 28 | ``` 29 | # ... 30 | # | RISCV_AUIPC => get_arch_pc() + off 31 | # ==> 32 | | RISCV_AUIPC => 33 | let: tmp := call get_arch_pc in 34 | tmp + off 35 | ``` 36 | 37 | Currently ommitting alignment related checks and exceptions (bitvector support needed for this). 38 | -> OR simply check if address is divisible by 4? 39 | 40 | Ignoring instructions that rely on bitvector operations (like shift operations), this mostly affects the support for RTYPE- and ITYPE-instructions. 41 | 42 | ## Source 43 | 44 | This machine is based on a minimal model of the official RISC-V Sail model. 45 | The corresponding model can be found at [https://gitlab.soft.vub.ac.be/shuygheb/sail-minimal-riscv](sail-minimal-riscv). 46 | 47 | The machine that this case study represents is based on the official RISC-V code, more specifically, (parts of) the following files: 48 | - [https://github.com/rems-project/sail-riscv/blob/master/model/riscv_insts_base.sail](Base Instructions) 49 | - [https://github.com/rems-project/sail-riscv/blob/master/model/riscv_pmp_regs.sail](PMP Configuration) 50 | - [https://github.com/rems-project/sail-riscv/blob/master/model/riscv_pmp_control.sail](PMP) 51 | 52 | ## Machine Invariant 53 | TODO 54 | -------------------------------------------------------------------------------- /case_study/deprecated/RiscvPmpUnboundedInts/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Katamaran.RiscvPmp) 3 | (package coq-katamaran) 4 | (theories Katamaran)) 5 | 6 | (include_subdirs qualified) 7 | -------------------------------------------------------------------------------- /case_study/patches/MinimalCaps/duplicate_add.patch: -------------------------------------------------------------------------------- 1 | diff --git a/case_study/MinimalCaps/Base.v b/case_study/MinimalCaps/Base.v 2 | index 15fe263..77676e1 100644 3 | --- a/case_study/MinimalCaps/Base.v 4 | +++ b/case_study/MinimalCaps/Base.v 5 | @@ -55,6 +55,7 @@ Inductive Instruction : Set := 6 | | sd (rs1 : Src) (rs2 : Src) (imm : Imm) 7 | | addi (rd : Dst) (rs : Src) (imm : Imm) 8 | | add (rd : Dst) (rs1 : Src) (rs2 : Src) 9 | +| add' (rd : Dst) (rs1 : Src) (rs2 : Src) 10 | | sub (rd : Dst) (rs1 : Src) (rs2 : Src) 11 | | slt (rd : Dst) (rs1 : Src) (rs2 : Src) 12 | | slti (rd : Dst) (rs : Src) (imm : Imm) 13 | @@ -83,6 +84,7 @@ Inductive InstructionConstructor : Set := 14 | | ksd 15 | | kaddi 16 | | kadd 17 | +| kadd' 18 | | ksub 19 | | kslt 20 | | kslti 21 | @@ -167,7 +169,7 @@ Section Finite. 22 | 23 | #[export,program] Instance InstructionConstructor_finite : 24 | Finite InstructionConstructor := 25 | - {| enum := [kjalr_cap;kcjalr;kcjal;kbne;kcmove;kld;ksd;kcincoffset;kcandperm;kcsetbounds;kcsetboundsimm;kcgettag;kaddi;kadd;ksub;kslt;kslti;ksltu;ksltiu;kcgetperm;kcgetbase;kcgetlen;kcgetaddr;kfail;kret] |}. 26 | + {| enum := [kjalr_cap;kcjalr;kcjal;kbne;kcmove;kld;ksd;kcincoffset;kcandperm;kcsetbounds;kcsetboundsimm;kcgettag;kaddi;kadd;kadd';ksub;kslt;kslti;ksltu;ksltiu;kcgetperm;kcgetbase;kcgetlen;kcgetaddr;kfail;kret] |}. 27 | 28 | End Finite. 29 | 30 | @@ -233,6 +235,7 @@ Module Export MinCapsBase <: Base. 31 | | ksd => ty.tuple [ty.src; ty.src; ty.int] 32 | | kaddi => ty.tuple [ty.dst; ty.src; ty.int] 33 | | kadd => ty.tuple [ty.dst; ty.src; ty.src] 34 | + | kadd' => ty.tuple [ty.dst; ty.src; ty.src] 35 | | ksub => ty.tuple [ty.dst; ty.src; ty.src] 36 | | kslt => ty.tuple [ty.dst; ty.src; ty.src] 37 | | kslti => ty.tuple [ty.dst; ty.src; ty.int] 38 | @@ -278,6 +281,7 @@ Module Export MinCapsBase <: Base. 39 | | existT ksd (tt , rs1 , rs2, imm) => sd rs1 rs2 imm 40 | | existT kaddi (tt , rd , rs , imm) => addi rd rs imm 41 | | existT kadd (tt , rd , rs1 , rs2) => add rd rs1 rs2 42 | + | existT kadd' (tt , rd , rs1 , rs2) => add' rd rs1 rs2 43 | | existT ksub (tt , rd , rs1 , rs2) => sub rd rs1 rs2 44 | | existT kslt (tt , rd , rs1 , rs2) => slt rd rs1 rs2 45 | | existT kslti (tt , rd , rs , imm) => slti rd rs imm 46 | @@ -310,6 +314,7 @@ Module Export MinCapsBase <: Base. 47 | | sd rs1 rs2 imm => existT ksd (tt , rs1 , rs2 , imm) 48 | | addi rd rs imm => existT kaddi (tt , rd , rs , imm) 49 | | add rd rs1 rs2 => existT kadd (tt , rd , rs1 , rs2) 50 | + | add' rd rs1 rs2 => existT kadd' (tt , rd , rs1 , rs2) 51 | | sub rd rs1 rs2 => existT ksub (tt , rd , rs1 , rs2) 52 | | slt rd rs1 rs2 => existT kslt (tt , rd , rs1 , rs2) 53 | | slti rd rs imm => existT kslti (tt , rd , rs , imm) 54 | diff --git a/case_study/MinimalCaps/Contracts.v b/case_study/MinimalCaps/Contracts.v 55 | index 860b0a1..9f2c4b2 100644 56 | --- a/case_study/MinimalCaps/Contracts.v 57 | +++ b/case_study/MinimalCaps/Contracts.v 58 | @@ -543,6 +543,9 @@ Module Import MinCapsSpecification <: Specification MinCapsBase MinCapsProgram M 59 | Definition sep_contract_exec_add : SepContractFun exec_add := 60 | mach_inv_contract. 61 | 62 | + Definition sep_contract_exec_add' : SepContractFun exec_add' := 63 | + mach_inv_contract. 64 | + 65 | Definition sep_contract_exec_sub : SepContractFun exec_sub := 66 | mach_inv_contract. 67 | 68 | @@ -712,6 +715,7 @@ Module Import MinCapsSpecification <: Specification MinCapsBase MinCapsProgram M 69 | | exec_csetboundsimm => Some sep_contract_exec_csetboundsimm 70 | | exec_addi => Some sep_contract_exec_addi 71 | | exec_add => Some sep_contract_exec_add 72 | + | exec_add' => Some sep_contract_exec_add' 73 | | exec_sub => Some sep_contract_exec_sub 74 | | exec_slt => Some sep_contract_exec_slt 75 | | exec_slti => Some sep_contract_exec_slti 76 | @@ -1265,6 +1269,9 @@ Module MinCapsValidContracts. 77 | Lemma valid_contract_exec_add : ValidContract exec_add. 78 | Proof. reflexivity. Qed. 79 | 80 | + Lemma valid_contract_exec_add' : ValidContract exec_add'. 81 | + Proof. reflexivity. Qed. 82 | + 83 | Lemma valid_contract_exec_sub : ValidContract exec_sub. 84 | Proof. reflexivity. Qed. 85 | 86 | @@ -1367,6 +1374,7 @@ Module MinCapsValidContracts. 87 | - apply (valid_contract _ H valid_contract_exec_sd). 88 | - apply (valid_contract _ H valid_contract_exec_addi). 89 | - apply (valid_contract _ H valid_contract_exec_add). 90 | + - apply (valid_contract _ H valid_contract_exec_add'). 91 | - apply (valid_contract _ H valid_contract_exec_sub). 92 | - apply (valid_contract _ H valid_contract_exec_slt). 93 | - apply (valid_contract _ H valid_contract_exec_slti). 94 | @@ -1443,6 +1451,7 @@ Section Statistics. 95 | existT _ (existT _ exec_cgettag); 96 | existT _ (existT _ exec_addi); 97 | existT _ (existT _ exec_add); 98 | + existT _ (existT _ exec_add'); 99 | existT _ (existT _ exec_sub); 100 | existT _ (existT _ exec_slt); 101 | existT _ (existT _ exec_slti); 102 | diff --git a/case_study/MinimalCaps/Machine.v b/case_study/MinimalCaps/Machine.v 103 | index 309fac0..9fff2d4 100644 104 | --- a/case_study/MinimalCaps/Machine.v 105 | +++ b/case_study/MinimalCaps/Machine.v 106 | @@ -85,6 +85,7 @@ Section FunDeclKit. 107 | | exec_sd : Fun ["rs1" :: ty.src; "rs2" :: ty.src; "imm" :: ty.int] ty.bool 108 | | exec_addi : Fun ["rd" :: ty.dst; "rs" :: ty.src; "imm" :: ty.int] ty.bool 109 | | exec_add : Fun ["rd" :: ty.dst; "rs1" :: ty.src; "rs2" :: ty.src] ty.bool 110 | + | exec_add' : Fun ["rd" :: ty.dst; "rs1" :: ty.src; "rs2" :: ty.src] ty.bool 111 | | exec_sub : Fun ["rd" :: ty.dst; "rs1" :: ty.src; "rs2" :: ty.src] ty.bool 112 | | exec_slt : Fun ["rd" :: ty.dst; "rs1" :: ty.src; "rs2" :: ty.src] ty.bool 113 | | exec_slti : Fun ["rd" :: ty.dst; "rs" :: ty.src; "imm" :: ty.int] ty.bool 114 | @@ -416,6 +417,15 @@ Section FunDefKit. 115 | call update_pc ;; 116 | stm_val ty.bool true. 117 | 118 | + Definition fun_exec_add' : Stm ["rd" :: ty.dst; "rs1" :: ty.src; "rs2" :: ty.src] ty.bool := 119 | + let: "v1" :: int := call read_reg_num (exp_var "rs1") in 120 | + let: "v2" :: int := call read_reg_num (exp_var "rs2") in 121 | + let: "res" :: int := stm_exp (exp_var "v1" + exp_var "v2") in 122 | + use lemma int_safe [exp_var "res"] ;; 123 | + call write_reg (exp_var "rd") (exp_inl (exp_var "res")) ;; 124 | + call update_pc ;; 125 | + stm_val ty.bool true. 126 | + 127 | Definition fun_exec_sub : Stm ["rd" :: ty.dst; "rs1" :: ty.src; "rs2" :: ty.src] ty.bool := 128 | let: "v1" :: int := call read_reg_num (exp_var "rs1") in 129 | let: "v2" :: int := call read_reg_num (exp_var "rs2") in 130 | @@ -745,6 +755,8 @@ Section FunDefKit. 131 | (call exec_addi (exp_var "rd") (exp_var "rs") (exp_var "imm"))%exp 132 | | kadd => MkAlt (pat_tuple ("rd" , "rs1" , "rs2")) 133 | (call exec_add (exp_var "rd") (exp_var "rs1") (exp_var "rs2"))%exp 134 | + | kadd' => MkAlt (pat_tuple ("rd" , "rs1" , "rs2")) 135 | + (call exec_add' (exp_var "rd") (exp_var "rs1") (exp_var "rs2"))%exp 136 | | ksub => MkAlt (pat_tuple ("rd" , "rs1" , "rs2")) 137 | (call exec_sub (exp_var "rd") (exp_var "rs1") (exp_var "rs2"))%exp 138 | | kslt => MkAlt (pat_tuple ("rd" , "rs1" , "rs2")) 139 | @@ -849,6 +861,7 @@ Section FunDefKit. 140 | | exec_csetboundsimm => fun_exec_csetboundsimm 141 | | exec_addi => fun_exec_addi 142 | | exec_add => fun_exec_add 143 | + | exec_add' => fun_exec_add' 144 | | exec_sub => fun_exec_sub 145 | | exec_slt => fun_exec_slt 146 | | exec_slti => fun_exec_slti 147 | -------------------------------------------------------------------------------- /case_study/patches/README.md: -------------------------------------------------------------------------------- 1 | # Patches 2 | 3 | This directory contains patches for the case studies. 4 | All patches should be **applied from the root directory of this project**. 5 | We provide a `make` command to apply an example patch: `make patch`, the patch can then be reverted with `make unpatch` (these commands need to be run from the root directy). 6 | We currently provide the following patches: 7 | 8 | | Case Study | Patch File | Description | 9 | |-------------|-----------------------------------|-------------------------------------------------------| 10 | | MinimalCaps | `MinimalCaps/duplicate_add.patch` | Adds a duplicate instruction for `add`, called `add'` | 11 | | RiscvPmp | `RiscvPmp/duplicate_add.patch` | Adds a duplicate instruction for `add`, called `add'` | 12 | 13 | -------------------------------------------------------------------------------- /case_study/patches/RiscvPmp/duplicate_add.patch: -------------------------------------------------------------------------------- 1 | diff --git a/case_study/RiscvPmp/Base.v b/case_study/RiscvPmp/Base.v 2 | index 45fc015..bb34287 100644 3 | --- a/case_study/RiscvPmp/Base.v 4 | +++ b/case_study/RiscvPmp/Base.v 5 | @@ -111,6 +111,7 @@ Inductive PmpAddrMatch : Set := 6 | Inductive ROP : Set := 7 | | RISCV_ADD 8 | | RISCV_SUB 9 | +| RISCV_ADD' 10 | . 11 | 12 | Inductive IOP : Set := 13 | @@ -382,7 +383,7 @@ Section Finite. 14 | 15 | #[export,program] Instance ROP_finite : 16 | Finite ROP := 17 | - {| enum := [RISCV_ADD;RISCV_SUB] |}. 18 | + {| enum := [RISCV_ADD;RISCV_SUB;RISCV_ADD'] |}. 19 | 20 | #[export,program] Instance IOP_finite : 21 | Finite IOP := 22 | diff --git a/case_study/RiscvPmp/BlockVer/Verifier.v b/case_study/RiscvPmp/BlockVer/Verifier.v 23 | index ba30ae9..1a962ce 100644 24 | --- a/case_study/RiscvPmp/BlockVer/Verifier.v 25 | +++ b/case_study/RiscvPmp/BlockVer/Verifier.v 26 | @@ -128,6 +128,7 @@ Module BlockVerification. 27 | let bop := match op with 28 | | RISCV_ADD => bop.plus 29 | | RISCV_SUB => bop.minus 30 | + | RISCV_ADD' => bop.plus 31 | end in 32 | wX rd (peval_binop bop v12 v22). 33 | 34 | diff --git a/case_study/RiscvPmp/Machine.v b/case_study/RiscvPmp/Machine.v 35 | index fb33831..65128d0 100644 36 | --- a/case_study/RiscvPmp/Machine.v 37 | +++ b/case_study/RiscvPmp/Machine.v 38 | @@ -879,6 +879,7 @@ Module Import RiscvPmpProgram <: Program RiscvPmpBase. 39 | match: op in rop with 40 | | RISCV_ADD => rs1_val + rs2_val 41 | | RISCV_SUB => rs1_val - rs2_val 42 | + | RISCV_ADD' => rs1_val + rs2_val 43 | end in 44 | call wX rd result ;; 45 | stm_val ty_retired RETIRE_SUCCESS. 46 | -------------------------------------------------------------------------------- /case_study/patches/RiscvPmpBoundedInts/duplicate_add.patch: -------------------------------------------------------------------------------- 1 | diff --git a/case_study/RiscvPmpBoundedInts/Base.v b/case_study/RiscvPmpBoundedInts/Base.v 2 | index b197664..c34a642 100644 3 | --- a/case_study/RiscvPmpBoundedInts/Base.v 4 | +++ b/case_study/RiscvPmpBoundedInts/Base.v 5 | @@ -142,6 +142,7 @@ Inductive PmpAddrMatch : Set := 6 | Inductive ROP : Set := 7 | | RISCV_ADD 8 | | RISCV_SUB 9 | +| RISCV_ADD' 10 | . 11 | 12 | Inductive IOP : Set := 13 | @@ -413,7 +414,7 @@ Section Finite. 14 | 15 | #[export,program] Instance ROP_finite : 16 | Finite ROP := 17 | - {| enum := [RISCV_ADD;RISCV_SUB] |}. 18 | + {| enum := [RISCV_ADD;RISCV_SUB;RISCV_ADD'] |}. 19 | 20 | #[export,program] Instance IOP_finite : 21 | Finite IOP := 22 | diff --git a/case_study/RiscvPmpBoundedInts/Machine.v b/case_study/RiscvPmpBoundedInts/Machine.v 23 | index a6db7ea..56c64b6 100644 24 | --- a/case_study/RiscvPmpBoundedInts/Machine.v 25 | +++ b/case_study/RiscvPmpBoundedInts/Machine.v 26 | @@ -923,6 +923,7 @@ Module Import RiscvPmpProgram <: Program RiscvPmpBase. 27 | match: op in rop with 28 | | RISCV_ADD => rs1_val +ᵇ rs2_val 29 | | RISCV_SUB => rs1_val -ᵇ rs2_val 30 | + | RISCV_ADD' => rs1_val +ᵇ rs2_val 31 | end in 32 | call wX rd result ;; 33 | stm_val ty_retired RETIRE_SUCCESS. 34 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { lib 2 | , mkCoqDerivation 3 | , coq 4 | , equations 5 | , iris 6 | , stdlib 7 | , stdpp 8 | , python3 9 | , time 10 | , writeShellScript 11 | , ... 12 | }: 13 | 14 | let 15 | make-one-time-file = writeShellScript "make-one-time-file" '' 16 | exec ${python3}/bin/python3 ${coq}/lib/coq-core/tools/make-one-time-file.py "$@" 17 | ''; 18 | in 19 | 20 | mkCoqDerivation { 21 | pname = "katamaran"; 22 | owner = "katamaran-project"; 23 | version = "0.2.0"; 24 | src = ./.; 25 | nativeBuildInputs = [ time ]; 26 | buildFlags = [ 27 | "COQMAKE_ONE_TIME_FILE=${make-one-time-file}" 28 | "pretty-timed" 29 | ]; 30 | propagatedBuildInputs = [ 31 | equations 32 | iris 33 | stdlib 34 | stdpp 35 | ]; 36 | meta = { 37 | description = "Separation logic-based verification of instruction sets"; 38 | license = lib.licenses.bsd2; 39 | }; 40 | } 41 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.3) 2 | (name coq-katamaran) 3 | (using coq 0.4) 4 | 5 | (license BSD-2-Clause) 6 | (maintainers "Steven Keuchel ") 7 | (authors "Dominique Devriese" "Georgy Lukyanov" "Sander Huyghebaert" "Steven Keuchel") 8 | (source (github katamaran-project/katamaran)) 9 | (homepage "https://katamaran-project.github.io/") 10 | 11 | (version 0.2.0) 12 | (package 13 | (name coq-katamaran) 14 | (synopsis "Separation logic-based verification of instruction sets") 15 | (description "Katamaran is a semi-automated separation logic verifier for 16 | the Sail specification language. It works on an embedded 17 | version of Sail called Sail and verifies separation 18 | logic-based contracts of functions by generating (succinct) 19 | first-order verification conditions. It further comes with a 20 | complete model based on the Iris separation logic 21 | framework.") 22 | (tags 23 | ("keyword:program verification" 24 | "keyword:separation logic" 25 | "keyword:symbolic execution" 26 | "keyword:instruction sets" 27 | "category:Computer Science/Semantics and Compilation/Semantics" 28 | "logpath:Katamaran")) 29 | (depends 30 | (coq (and (>= 8.19) (< 9.0))) 31 | (coq-equations (and (>= 1.3) (< 1.4))) 32 | (coq-iris (and (>= 4.3.0) (< 4.4))) 33 | (coq-stdpp (and (>= 1.11.0) (< 1.12))))) 34 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1731533236, 9 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1740367490, 24 | "narHash": "sha256-WGaHVAjcrv+Cun7zPlI41SerRtfknGQap281+AakSAw=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "0196c0175e9191c474c26ab5548db27ef5d34b05", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "NixOS", 32 | "ref": "nixos-unstable", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "root": { 38 | "inputs": { 39 | "flake-utils": "flake-utils", 40 | "nixpkgs": "nixpkgs" 41 | } 42 | }, 43 | "systems": { 44 | "locked": { 45 | "lastModified": 1681028828, 46 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 47 | "owner": "nix-systems", 48 | "repo": "default", 49 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "nix-systems", 54 | "repo": "default", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; 3 | inputs.flake-utils.url = "github:numtide/flake-utils"; 4 | 5 | outputs = inputs: inputs.flake-utils.lib.eachDefaultSystem (system: 6 | let 7 | pkgs = import inputs.nixpkgs { inherit system; }; 8 | # Function to override versions of coq packages. This function takes two arguments: 9 | # - coqPackages: The set of all Coq packages. 10 | # - versions: An attribute set of packages with their versions we want to override. 11 | patchCoqPackages = coqPackages: versions: 12 | coqPackages.overrideScope ( 13 | self: super: 14 | pkgs.lib.foldlAttrs 15 | # foldAttrs is used to iterate over the versions set and apply a function 16 | # to each attribute. This function takes three arguments: the accumulator set, 17 | # the attribute name (package name), and the attribute value (version). 18 | (acc: pkg: version: 19 | # This function returns a new set with the current attribute added to the 20 | # accumulator set. The attribute name is the package name, and the value 21 | # is the overridden package. 22 | acc // { ${pkg} = super.${pkg}.override { inherit version; }; }) 23 | # The initial value of the accumulator set. We add our own package here. 24 | { katamaran = self.callPackage ./default.nix { }; } 25 | # The attribute set to iterate over. 26 | versions 27 | ); 28 | 29 | iris43 = { 30 | iris = "4.3.0"; 31 | stdpp = "1.11.0"; 32 | }; 33 | 34 | coqPackages819 = patchCoqPackages pkgs.coqPackages_8_19 iris43; 35 | coqPackages820 = patchCoqPackages pkgs.coqPackages_8_20 iris43; 36 | 37 | mkDeps = pkg: pkgs.linkFarmFromDrvs "deps" 38 | (pkg.buildInputs ++ pkg.nativeBuildInputs ++ pkg.propagatedBuildInputs); 39 | in 40 | rec { 41 | packages = rec { 42 | default = coq819; 43 | coq819 = coqPackages819.katamaran; 44 | coq820 = coqPackages820.katamaran; 45 | 46 | coq819-deps = mkDeps coq819; 47 | coq820-deps = mkDeps coq820; 48 | }; 49 | } 50 | ); 51 | } 52 | -------------------------------------------------------------------------------- /scripts/shallow.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -e 3 | 4 | FINISH=0 5 | PRUNED=0 6 | 7 | while read line 8 | do 9 | if [[ "$line" =~ CPureSpecM.FALSE ]]; then 10 | ((++PRUNED)) 11 | fi 12 | if [[ "$line" =~ CPureSpecM.TRUE ]]; then 13 | ((++PRUNED)) 14 | fi 15 | if [[ "$line" =~ CPureSpecM.FINISH ]]; then 16 | ((++FINISH)) 17 | fi 18 | done 19 | 20 | echo "Shallow branching statistics:" 21 | echo "{| branches := $((FINISH+PRUNED)); pruned := $PRUNED} |}" 22 | -------------------------------------------------------------------------------- /scripts/timing.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -e 3 | 4 | declare -A before 5 | declare -A after 6 | 7 | REBEFORE='([0-9.]+) Timing before: (.+)' 8 | REAFTER='([0-9.]+) Timing after: (.+)' 9 | 10 | while read line 11 | do 12 | # echo $line 13 | if [[ "$line" =~ $REBEFORE ]]; then 14 | func="${BASH_REMATCH[2]}" 15 | time="${BASH_REMATCH[1]}" 16 | before[$func]="$time" 17 | fi 18 | 19 | if [[ "$line" =~ $REAFTER ]]; then 20 | func="${BASH_REMATCH[2]}" 21 | time="${BASH_REMATCH[1]}" 22 | awk "BEGIN {printf(\"$func %.4f\n\", $time - ${before[$func]})}" 23 | fi 24 | done 25 | -------------------------------------------------------------------------------- /theories/BitvectorSolve.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Aïna Linn Georges, Armaël Guéneau, Thomas Van Strydonck,*) 3 | (* Amin Timany, Alix Trieu, Dominique Devriese, Lars Birkedal *) 4 | (* Copyright (c) 2023 Steven Keuchel, Dominique Devriese, Sander Huyghebaert *) 5 | (* All rights reserved. *) 6 | (* *) 7 | (* Redistribution and use in source and binary forms, with or without *) 8 | (* modification, are permitted provided that the following conditions are *) 9 | (* met: *) 10 | (* *) 11 | (* 1. Redistributions of source code must retain the above copyright notice, *) 12 | (* this list of conditions and the following disclaimer. *) 13 | (* *) 14 | (* 2. Redistributions in binary form must reproduce the above copyright *) 15 | (* notice, this list of conditions and the following disclaimer in the *) 16 | (* documentation and/or other materials provided with the distribution. *) 17 | (* 3. Neither the name of the copyright holder nor the names of its *) 18 | (* contributors may be used to endorse or promote products derived from *) 19 | (* this software without specific prior written permission. *) 20 | (* *) 21 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 22 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 23 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 24 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 25 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 26 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 27 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 28 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 29 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 30 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 31 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 32 | (******************************************************************************) 33 | 34 | (* Faster alternative to [set (H := v) in *] *) 35 | (* https://github.com/coq/coq/issues/13788#issuecomment-767217670 *) 36 | Ltac fast_set H v := 37 | pose v as H; change v with H; 38 | repeat match goal with H' : context[v] |- _ => change v with H in H' end. 39 | 40 | (* Replace term `v` with a fresh variable everywhere *) 41 | (* Use this tactic once a spec for `v` has been introduced as a hypothesis *) 42 | Ltac fast_set_fresh v := 43 | let fx := fresh "fx" in 44 | fast_set fx v; 45 | clearbody fx. 46 | (* Use this version if an equality of the form `v = trm` is already present in the context after applying a spec. *) 47 | Ltac fast_set_fresh_subst v := 48 | let fx := fresh "fx" in 49 | fast_set fx v; 50 | clearbody fx; subst fx. 51 | 52 | Ltac solve_bv_cbn := 53 | cbv [bv.ult bv.ule bv.ugt bv.uge bv.unsigned]; 54 | cbn [bv.of_Z bv.of_N bv.of_nat]. (* Lemmas operate on these; don't always unfold *) 55 | 56 | Ltac solve_bv_cbn_in_all := 57 | cbv [bv.ult bv.ule bv.ugt bv.uge bv.unsigned] in *; 58 | cbn [bv.of_Z bv.of_N bv.of_nat] in *. 59 | 60 | Ltac bv_zify_op_nonbranching_step := 61 | lazymatch goal with 62 | (* Options *) 63 | | |- @eq (option (bv _)) (Some _) (Some _) => 64 | f_equal 65 | | H : @eq (option (bv _)) (Some _) (Some _) |- _ => 66 | apply some_inj in H 67 | | |- @eq (option (bv _)) (Some _) None => 68 | exfalso 69 | | |- @eq (option (bv _)) None (Some _) => 70 | exfalso 71 | | H : @eq (option (bv _)) (Some _) None |- _ => 72 | discriminate H 73 | | H : @eq (option (bv _)) None (Some _) |- _ => 74 | discriminate H 75 | (* Non-branching specs *) 76 | | |- context [ bv.bin (bv.one) ] => 77 | rewrite bin_one ; [ | cbn; lia] (* TODO create spec Ltac for these? Currently assumes n > 0 *) 78 | | H : context [ bv.bin (bv.one) ] |- _ => 79 | rewrite bin_one in H ; [ | cbn; lia] 80 | | |- context [ bv.bin (bv.zero) ] => 81 | change_no_check (bv.bin (bv.zero)) with 0%N 82 | | H : context [ bv.bin (bv.zero) ] |- _ => 83 | change_no_check (bv.bin (bv.zero)) with 0%N in H 84 | end. 85 | 86 | Ltac bv_zify_nonbranching_step := 87 | first [ progress solve_bv_cbn_in_all 88 | | bv_zify_op_nonbranching_step ]. 89 | 90 | Ltac rename_or_learn H HTy := 91 | lazymatch goal with 92 | | H' : HTy |- _ => rename H' into H 93 | | _ => destruct (decide HTy) as [H|H] end. 94 | 95 | (* TODO: we could provide a more precise spec in case of overflow; either `bin(x + y) = bin x + bin y`, or they are `2^n` off *) 96 | Ltac bin_add_spec n x y := 97 | let HTy := constr:((bv.bin x + bv.bin y < bv.exp2 n)%N) in 98 | (* Check if `HyT` has been assumed before? *) 99 | let H := fresh "H" in 100 | rename_or_learn H HTy; 101 | [generalize (bv.bin_add_small H); intros ?; fast_set_fresh_subst (bv.bin (bv.add x y)) | 102 | apply N.nlt_ge in H; fast_set_fresh (bv.bin (bv.add x y)) ..]. (* Note: second tactic is only run if we did not yet know `HTy` *) 103 | 104 | (* TODO: more precise spec using `mod` possible, but might make it harder for `lia` to discharge some goals *) 105 | Ltac bin_of_nat_spec n x := 106 | let HTy := constr:((N.of_nat x < bv.exp2 n)%N) in 107 | (* Check if `HyT` has been assumed before? *) 108 | let H := fresh "H" in 109 | rename_or_learn H HTy; 110 | [generalize (bv.bin_of_nat_small H); intros ?; fast_set_fresh_subst (@bv.bin n (bv.of_nat x)) | 111 | apply N.nlt_ge in H; fast_set_fresh (@bv.bin n (bv.of_nat x)) ..] (* Note: second tactic is only run if we did not yet know `HTy` *). 112 | 113 | Ltac bv_zify_op_branching_goal_step := 114 | lazymatch goal with 115 | | |- context [ bv.bin (@bv.add ?n ?x ?y) ] => 116 | bin_add_spec n x y 117 | | |- context [ bv.bin (@bv.of_nat ?n ?x) ] => 118 | bin_of_nat_spec n x 119 | end. 120 | 121 | Ltac bv_zify_op_branching_hyps_step := 122 | lazymatch goal with 123 | | _ : context [ bv.bin (@bv.add ?n ?x ?y) ] |- _ => 124 | bin_add_spec n x y 125 | | _ : context [ bv.bin (@bv.of_nat ?n ?x) ] |- _ => 126 | bin_of_nat_spec n x 127 | end. 128 | 129 | (* Getting rid of all mentions of bv's at the end, by introducing wf-constraints explicitly for lia *) 130 | (* TODO: probably better to (also) generate this wf-spec earlier on -> This prevents duplication of goals along the way *) 131 | Ltac bv_zify_ty_step_on f := 132 | generalize (bv.bv_is_wf f); intros ?; 133 | fast_set_fresh (bv.bin f); 134 | first [ clear f | generalize dependent f ]. 135 | 136 | Ltac bv_zify_ty_step_var := 137 | lazymatch goal with 138 | | f : bv _ |- _ => bv_zify_ty_step_on f 139 | end. 140 | 141 | Ltac bv_zify_ty_step_subterm := 142 | match goal with 143 | | H : context [ ?x ] |- _ => 144 | lazymatch type of x with bv _ => 145 | let X := fresh in 146 | set (X := x) in *; 147 | bv_zify_ty_step_on X 148 | end 149 | end. 150 | 151 | Ltac bv_zify_ty_step := 152 | first [ bv_zify_ty_step_var | bv_zify_ty_step_subterm ]. 153 | 154 | (* Naive, greedy procedure that converts everything to Z without simplifying bitvectors *) 155 | Ltac bv_zify_greedy := 156 | intros; solve_bv_cbn; 157 | repeat (first [ bv_zify_nonbranching_step 158 | | bv_zify_op_branching_goal_step 159 | | bv_zify_op_branching_hyps_step ]); 160 | repeat bv_zify_ty_step; intros. 161 | 162 | (* From a high-level perspective, [bv_zify] is equivalent to [bv_zify_greedy] followed by [lia]. 163 | 164 | However, this gets very slow when there are branching steps (anything that branches on small-ness) in the context (and some of those may not be relevant to prove the goal at hand), so the implementation is a bit more clever. Instead, we try to call [lia] as soon as possible to quickly terminate sub-goals than can be proved before the whole context gets translated. *) 165 | 166 | Ltac bv_zify_op_goal_step := 167 | first [ bv_zify_nonbranching_step 168 | | bv_zify_op_branching_goal_step ]. 169 | 170 | Ltac bv_zify_op_deepen := 171 | bv_zify_op_branching_hyps_step; 172 | repeat bv_zify_nonbranching_step; 173 | try ( 174 | bv_zify_op_branching_hyps_step; 175 | repeat bv_zify_nonbranching_step 176 | ). 177 | 178 | Ltac bv_zify_close_proof := 179 | repeat bv_zify_ty_step; intros; 180 | solve [ auto | lia | congruence ]. 181 | 182 | Ltac bv_zify := 183 | intros; solve_bv_cbn; 184 | (* Branches on the goal are always forced: do all of these at once *) 185 | repeat bv_zify_op_goal_step; 186 | (* Are we done? *) 187 | try bv_zify_close_proof; 188 | (* Take <=2 branching steps at a time and try to finish the proof *) 189 | repeat ( 190 | bv_zify_op_deepen; 191 | try bv_zify_close_proof 192 | ); 193 | bv_zify_close_proof. 194 | 195 | -------------------------------------------------------------------------------- /theories/Iris/Base.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Sander Huyghebaert, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Katamaran Require Import 30 | Prelude 31 | Semantics. 32 | 33 | From iris Require Import 34 | program_logic.adequacy 35 | program_logic.total_weakestpre 36 | program_logic.weakestpre 37 | proofmode.tactics. 38 | 39 | From Katamaran Require Export 40 | Iris.Resources 41 | Iris.WeakestPre 42 | Iris.TotalWeakestPre. 43 | 44 | (* TotalPartialWeakestPre adds some lemmas that involve both the twp and wp. *) 45 | Module Type IrisTotalPartialWeakestPre 46 | (Import B : Base) 47 | (Import PROG : Program B) 48 | (Import SEM : Semantics B PROG) 49 | (Import IPre : IrisPrelims B PROG SEM) 50 | (Import IP : IrisParameters B) 51 | (Import IR : IrisResources B PROG SEM IPre IP) 52 | (Import IWP : IrisWeakestPre B PROG SEM IPre IP IR) 53 | (Import ITWP : IrisTotalWeakestPre B PROG SEM IPre IP IR). 54 | 55 | Section WithSailGS. 56 | Context `{sG : sailGS Σ}. 57 | 58 | Lemma semTWP_semWP {Γ τ} {s : Stm Γ τ} {δ Q} : 59 | semTWP δ s Q ⊢ semWP δ s Q. 60 | Proof. iApply twp_wp. Qed. 61 | End WithSailGS. 62 | End IrisTotalPartialWeakestPre. 63 | 64 | Module Type IrisBase (B : Base) (PROG : Program B) (SEM : Semantics B PROG) := 65 | IrisPrelims B PROG SEM <+ IrisParameters B <+ IrisResources B PROG SEM <+ IrisWeakestPre B PROG SEM <+ IrisTotalWeakestPre B PROG SEM <+ IrisTotalPartialWeakestPre B PROG SEM. 66 | -------------------------------------------------------------------------------- /theories/Iris/BinaryInstance.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Sander Huyghebaert, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Program.Equality. 31 | From Equations Require Import 32 | Equations Signature. 33 | Require Import Equations.Prop.EqDec. 34 | 35 | From stdpp Require finite gmap list. 36 | 37 | From iris Require Import 38 | algebra.auth 39 | algebra.excl 40 | algebra.gmap 41 | base_logic.lib.fancy_updates 42 | base_logic.lib.gen_heap 43 | base_logic.lib.own 44 | bi.big_op 45 | bi.interface 46 | program_logic.adequacy 47 | program_logic.weakestpre 48 | proofmode.tactics. 49 | 50 | From Katamaran Require Import 51 | Iris.Base 52 | Iris.Instance 53 | Prelude 54 | Semantics 55 | Sep.Hoare 56 | Signature 57 | SmallStep.Step 58 | Specification 59 | BinaryResources 60 | BinaryWeakestPre 61 | BinaryAdequacy. 62 | 63 | Import ctx.notations. 64 | Import env.notations. 65 | 66 | Set Implicit Arguments. 67 | 68 | Module Type IrisInstance2 (B : Base) (SIG : Signature B) (PROG : Program B) 69 | (SEM : Semantics B PROG) (IB2 : IrisBase2 B PROG SEM) (IAP : IrisAdeqParameters2 B PROG SEM IB2 IB2 IB2) := 70 | IrisPredicates2 B SIG PROG SEM IB2 <+ IrisSignatureRules2 B SIG PROG SEM IB2 71 | <+ IrisAdequacy2 B SIG PROG SEM IB2 IAP. 72 | 73 | (* * The following module defines the parts of the Iris model that must depend on the Specification, not just on the Signature. *) 74 | (* * This is kept to a minimum (see comment for the IrisPredicates module). *) 75 | (* *) 76 | Module IrisInstanceWithContracts2 77 | (Import B : Base) 78 | (Import SIG : Signature B) 79 | (Import PROG : Program B) 80 | (Import SEM : Semantics B PROG) 81 | (Import SPEC : Specification B SIG PROG) 82 | (Import IB2 : IrisBase2 B PROG SEM) 83 | (Import IAP : IrisAdeqParameters2 B PROG SEM IB2 IB2 IB2) 84 | (Import II : IrisInstance2 B SIG PROG SEM IB2 IAP) 85 | (Import PLOG : ProgramLogicOn B SIG PROG SPEC). 86 | 87 | Section WithSailGS. 88 | Import ProgramLogic. 89 | Context `{sG : sailGS2 Σ}. 90 | 91 | Definition ValidContractEnvSem (cenv : SepContractEnv) : iProp Σ := 92 | (∀ σs σ (f : 𝑭 σs σ), 93 | match cenv σs σ f with 94 | | Some c => ValidContractSem (FunDef f) c 95 | | None => True 96 | end)%I. 97 | 98 | Definition ForeignSem := 99 | ∀ (Δ : PCtx) (τ : Ty) (f : 𝑭𝑿 Δ τ), 100 | ValidContractForeign (CEnvEx f) f. 101 | 102 | Definition LemmaSem : Prop := 103 | forall (Δ : PCtx) (l : 𝑳 Δ), 104 | ValidLemma (LEnv l). 105 | 106 | Lemma iris_rule_stm_call {Γ} (δ : CStore Γ) 107 | {Δ σ} (f : 𝑭 Δ σ) (c : SepContract Δ σ) (es : NamedEnv (Exp Γ) Δ) 108 | (P : iProp Σ) 109 | (Q : Val σ -> CStore Γ -> iProp Σ) : 110 | CEnv f = Some c -> 111 | CTriple P c (evals es δ) (fun v => Q v δ) -> 112 | ⊢ ▷ ValidContractEnvSem CEnv -∗ 113 | semTriple δ P (stm_call f es) Q. 114 | Proof. 115 | iIntros (ceq ctrip) "cenv P". 116 | iApply semWP2_call_inline_later. 117 | iModIntro. 118 | iSpecialize ("cenv" $! _ _ f). 119 | rewrite ceq. clear ceq. 120 | destruct c as [Σe δΔ req res ens]; cbn in *. 121 | iPoseProof (ctrip with "P") as (ι Heq) "[req consr]". clear ctrip. 122 | iPoseProof ("cenv" $! ι with "req") as "wpf0". rewrite Heq. 123 | iApply (semWP2_mono with "wpf0"). 124 | iIntros ([] ? ? ?) "(<- & <- & H)"; auto. 125 | repeat iSplitR; auto. 126 | by iApply "consr". 127 | Qed. 128 | 129 | Lemma iris_rule_stm_call_frame {Γ} (δ : CStore Γ) 130 | (Δ : PCtx) (δΔ : CStore Δ) (τ : Ty) (s : Stm Δ τ) 131 | (P : iProp Σ) (Q : Val τ -> CStore Γ -> iProp Σ) : 132 | ⊢ (semTriple δΔ P s (fun v _ => Q v δ) -∗ 133 | semTriple δ P (stm_call_frame δΔ s) Q). 134 | Proof. 135 | iIntros "trips P". 136 | iSpecialize ("trips" with "P"). 137 | iApply semWP2_call_frame. 138 | iApply (semWP2_mono with "trips"). 139 | iIntros ([] ? ? ?) "(<- & <- & $)"; auto. 140 | Qed. 141 | 142 | Lemma iris_rule_stm_foreign 143 | {Γ} (δ : CStore Γ) {τ} {Δ} (f : 𝑭𝑿 Δ τ) (es : NamedEnv (Exp Γ) Δ) 144 | (P : iProp Σ) (Q : Val τ -> CStore Γ -> iProp Σ) : 145 | ForeignSem -> 146 | CTriple P (CEnvEx f) (evals es δ) (λ v : Val τ, Q v δ) -> 147 | ⊢ semTriple δ P (stm_foreign f es) Q. 148 | Proof. 149 | iIntros (forSem ctrip) "P". 150 | specialize (forSem Δ τ f Γ es δ). 151 | destruct CEnvEx as [Σe δΔ req res ens]; cbn in *. 152 | iPoseProof (ctrip with "P") as "[%ι [%Heq [req consr]]]". clear ctrip. 153 | iPoseProof (forSem ι Heq with "req") as "WPf". clear forSem. 154 | iApply (semWP2_mono with "WPf"). 155 | iIntros ([v|m] δΓ' ? ?) "(<- & <- & H)"; auto. 156 | repeat iSplitR; auto. 157 | iDestruct "H" as "(H & <-)". 158 | by iApply "consr". 159 | Qed. 160 | 161 | Lemma iris_rule_stm_lemmak 162 | {Γ} (δ : CStore Γ) {τ} {Δ} (l : 𝑳 Δ) (es : NamedEnv (Exp Γ) Δ) (k : Stm Γ τ) 163 | (P Q : iProp Σ) (R : Val τ -> CStore Γ -> iProp Σ) : 164 | LemmaSem -> 165 | LTriple (evals es δ) P Q (LEnv l) -> 166 | ⊢ semTriple δ Q k R -∗ 167 | semTriple δ P (stm_lemmak l es k) R. 168 | Proof. 169 | iIntros (lemSem ltrip) "tripk P". iApply semWP2_lemmak. iApply "tripk". 170 | specialize (lemSem _ l). remember (LEnv l) as contractL. 171 | clear - lemSem ltrip. 172 | destruct ltrip as [Ψ' pats req ens ent]; cbn in lemSem. 173 | iPoseProof (ent with "P") as (ι Heq) "[req consr]". 174 | iApply "consr". by iApply lemSem. 175 | Qed. 176 | 177 | Lemma sound_stm 178 | {Γ} {τ} (s : Stm Γ τ) {δ : CStore Γ}: 179 | forall (PRE : iProp Σ) (POST : Val τ -> CStore Γ -> iProp Σ), 180 | ForeignSem -> 181 | LemmaSem -> 182 | (∃ fuel, # fuel ⦃ PRE ⦄ s ; δ ⦃ POST ⦄) -> 183 | ⊢ (□ ▷ ValidContractEnvSem CEnv -∗ 184 | semTriple δ PRE s POST)%I. 185 | Proof. 186 | iIntros (PRE POST extSem lemSem [fuel triple]) "#vcenv". 187 | iInduction triple as [x|x|x|x|x|x|x|x|x|x|x|x|x|x|x|x|x|x|x|x|x|x] "trips". 188 | - by iApply iris_rule_consequence. 189 | - by iApply iris_rule_frame. 190 | - by iApply iris_rule_pull. 191 | - by iApply iris_rule_exist. 192 | - iApply iris_rule_stm_val. 193 | by iApply H. 194 | - iApply iris_rule_stm_exp. 195 | by iApply H. 196 | - by iApply iris_rule_stm_let. 197 | - by iApply iris_rule_stm_block. 198 | - by iApply iris_rule_stm_seq. 199 | - iApply iris_rule_stm_assertk. 200 | iIntros "H". by iApply "trips". 201 | - by iApply iris_rule_stm_fail. 202 | - by iApply iris_rule_stm_read_register. 203 | - by iApply iris_rule_stm_write_register. 204 | - by iApply iris_rule_stm_assign. 205 | - by iApply iris_rule_stm_call. 206 | - by iApply iris_rule_stm_call_inline. 207 | - by iApply iris_rule_stm_call_frame. 208 | - by iApply iris_rule_stm_foreign. 209 | - by iApply iris_rule_stm_lemmak. 210 | - by iApply iris_rule_stm_bind. 211 | - by iApply iris_rule_stm_debugk. 212 | - by iApply iris_rule_stm_pattern_match. 213 | Qed. 214 | 215 | Lemma sound : 216 | ForeignSem -> LemmaSem -> ValidContractCEnv -> 217 | ⊢ ValidContractEnvSem CEnv. 218 | Proof. 219 | intros extSem lemSem vcenv. 220 | iLöb as "IH". 221 | iIntros (σs σ f). 222 | specialize (vcenv σs σ f). 223 | destruct (CEnv f) as [[]|];[|trivial]. 224 | iIntros (ι). 225 | specialize (vcenv _ eq_refl ι) as [fuel vcenv]. 226 | iApply (sound_stm extSem lemSem); [|trivial]. 227 | exists fuel. 228 | apply vcenv. 229 | Qed. 230 | 231 | End WithSailGS. 232 | End IrisInstanceWithContracts2. 233 | -------------------------------------------------------------------------------- /theories/Iris/BinaryResources.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Sander Huyghebaert, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From stdpp Require finite gmap list. 30 | 31 | From iris Require Import 32 | algebra.auth 33 | algebra.excl 34 | algebra.gmap 35 | base_logic.lib.fancy_updates 36 | base_logic.lib.gen_heap 37 | base_logic.lib.own 38 | bi.big_op 39 | bi.interface 40 | program_logic.adequacy 41 | program_logic.weakestpre 42 | proofmode.tactics. 43 | 44 | From Katamaran Require Import 45 | Iris.Base 46 | Iris.Instance 47 | Prelude 48 | Semantics 49 | Sep.Hoare 50 | Signature 51 | SmallStep.Step 52 | Specification. 53 | 54 | Import ctx.notations. 55 | Import env.notations. 56 | 57 | Set Implicit Arguments. 58 | 59 | Class irisGS2 (Λ1 Λ2 : language) (Σ : gFunctors) := IrisG { 60 | iris_invGS2 :: invGS Σ; 61 | 62 | (** The state interpretation is an invariant that should hold in 63 | between each step of reduction. Here [Λstate] is the global state, 64 | the first [nat] is the number of steps already performed by the 65 | program. *) 66 | state_interp2 : state Λ1 -> state Λ2 → nat → iProp Σ; 67 | 68 | (** Number of additional logical steps (i.e., later modality in the 69 | definition of WP) per physical step, depending on the physical steps 70 | counter. In addition to these steps, the definition of WP adds one 71 | extra later per physical step to make sure that there is at least 72 | one later for each physical step. *) 73 | num_laters_per_step2 : nat → nat; 74 | 75 | (** When performing pure steps, the state interpretation needs to be 76 | adapted for the change in the [ns] parameter. 77 | 78 | Note that we use an empty-mask fancy update here. We could also use 79 | a basic update or a bare magic wand, the expressiveness of the 80 | framework would be the same. If we removed the modality here, then 81 | the client would have to include the modality it needs as part of 82 | the definition of [state_interp]. Since adding the modality as part 83 | of the definition [state_interp_mono] does not significantly 84 | complicate the formalization in Iris, we prefer simplifying the 85 | client. *) 86 | state_interp_mono2 σ1 σ2 ns : 87 | state_interp2 σ1 σ2 ns ={∅}=∗ state_interp2 σ1 σ2 (S ns) 88 | }. 89 | Global Opaque iris_invGS2. 90 | 91 | Module Type IrisParameters2 92 | (Import B : Base) 93 | (Import IB : IrisParameters B). 94 | 95 | Parameter Inline memGS2 : gFunctors -> Set. 96 | Existing Class memGS2. 97 | Parameter memGS2_memGS_left : forall `{memGS2 Σ}, memGS Σ. 98 | Parameter memGS2_memGS_right : forall `{memGS2 Σ}, memGS Σ. 99 | Parameter mem_inv2 : forall `{mG : memGS2 Σ}, Memory -> Memory -> iProp Σ. 100 | Parameter mem_inv2_mem_inv : forall `{mG : memGS2 Σ} (μ1 μ2 : Memory), 101 | mem_inv2 μ1 μ2 ⊣⊢ @mem_inv _ memGS2_memGS_left μ1 ∗ @mem_inv _ memGS2_memGS_right μ2. 102 | End IrisParameters2. 103 | 104 | Module Type IrisResources2 105 | (Import B : Base) 106 | (Import PROG : Program B) 107 | (Import SEM : Semantics B PROG) 108 | (Import IPre : IrisPrelims B PROG SEM) 109 | (Import IP : IrisParameters B) 110 | (Import IP2 : IrisParameters2 B IP) 111 | (Import IR : IrisResources B PROG SEM IPre IP). 112 | 113 | Class sailRegGS2 Σ := SailRegGS2 { 114 | sailRegGS2_sailRegGS_left : sailRegGS Σ; 115 | sailRegGS2_sailRegGS_right : sailRegGS Σ; 116 | }. 117 | Class sailGS2 Σ := SailGS2 { (* resources for the implementation side *) 118 | sailGS2_invGS : invGS Σ; (* for fancy updates, invariants... *) 119 | sailGS2_regGS2 : sailRegGS2 Σ; 120 | (* ghost variable for tracking user-defined state *) 121 | sailGS2_memGS : memGS2 Σ; 122 | }. 123 | 124 | #[export] Existing Instance sailGS2_invGS. 125 | #[export] Existing Instance sailGS2_regGS2. 126 | #[export] Existing Instance sailGS2_memGS. 127 | 128 | Definition regs_inv2 `{sailRegGS2 Σ} γ1 γ2 := (regs_inv (srGS := sailRegGS2_sailRegGS_left) γ1 ∗ regs_inv (srGS := sailRegGS2_sailRegGS_right) γ2)%I. 129 | Definition mem_inv2_sail `{sailGS2 Σ} μ1 μ2 := @mem_inv2 _ (sailGS2_memGS) μ1 μ2. 130 | 131 | Definition reg_pointsTo2 `{sailRegGS2 Σ} {τ} : 𝑹𝑬𝑮 τ → Val τ → Val τ → iProp Σ := 132 | fun reg v1 v2 => 133 | (@reg_pointsTo _ sailRegGS2_sailRegGS_left _ reg v1 ∗ @reg_pointsTo _ sailRegGS2_sailRegGS_right _ reg v2)%I. 134 | 135 | Definition sailGS2_sailGS_left `{sG2 : sailGS2 Σ} : sailGS Σ := 136 | {| sailGS_invGS := sailGS2_invGS; 137 | sailGS_sailRegGS := sailRegGS2_sailRegGS_left; 138 | sailGS_memGS := memGS2_memGS_left; 139 | |}. 140 | 141 | Definition sailGS2_sailGS_right `{sG2 : sailGS2 Σ} : sailGS Σ := 142 | {| sailGS_invGS := sailGS2_invGS; 143 | sailGS_sailRegGS := sailRegGS2_sailRegGS_right; 144 | sailGS_memGS := memGS2_memGS_right; 145 | |}. 146 | 147 | #[export] Program Instance sailGS2_irisGS2 `{sailGS2 Σ} {Γ1 Γ2 τ} : irisGS2 (microsail_lang Γ1 τ) (microsail_lang Γ2 τ) Σ := 148 | {| 149 | iris_invGS2 := sailGS2_invGS; 150 | state_interp2 σ1 σ2 κ := (regs_inv2 σ1.1 σ2.1 ∗ mem_inv2_sail σ1.2 σ2.2)%I; 151 | num_laters_per_step2 := fun _ => 0 152 | |}. 153 | 154 | End IrisResources2. 155 | 156 | Module Type IrisBase2 (B : Base) (PROG : Program B) (SEM : Semantics B PROG) := 157 | IrisBase B PROG SEM <+ IrisParameters2 B <+ IrisResources2 B PROG SEM. 158 | -------------------------------------------------------------------------------- /theories/Iris/cointro_patterns.v: -------------------------------------------------------------------------------- 1 | From stdpp Require Export strings. 2 | From iris.proofmode Require Import base tokens. 3 | From iris.prelude Require Import options. 4 | 5 | Inductive goal_kind := GSpatial | GModal | GIntuitionistic. 6 | 7 | Record cointro_goal := SpecGoal { 8 | cointro_goal_kind : goal_kind; 9 | cointro_goal_negate : bool; 10 | cointro_goal_hyps : list ident 11 | }. 12 | 13 | Inductive cointro_pat := 14 | | SDrop : cointro_pat 15 | | SFrame : ident → list cointro_pat → cointro_pat 16 | | SFrameByName : ident → list cointro_pat → cointro_pat 17 | | SPureGoal (perform_done : bool) : cointro_pat 18 | | SCoHyp : ident -> cointro_pat 19 | | SSplitGoal : cointro_goal → cointro_pat 20 | | SRefl : cointro_pat 21 | | SList : list (cointro_pat) -> cointro_pat 22 | . 23 | 24 | (* Definition goal_kind_modal (k : goal_kind) : bool := *) 25 | (* match k with GModal => true | _ => false end. *) 26 | (* Definition cointro_pat_modal (p : cointro_pat) : bool := *) 27 | (* match p with *) 28 | (* | SSplitGoal g => goal_kind_modal (cointro_goal_kind g) *) 29 | (* | _ => false *) 30 | (* end. *) 31 | 32 | Module cointro_pat. 33 | Inductive stack_item := 34 | | StPat : cointro_pat → stack_item 35 | | StFrame : string → stack_item 36 | | StList : stack_item. 37 | Notation stack := (list stack_item). 38 | 39 | Fixpoint close (k : stack) (ps : list cointro_pat) : option (list cointro_pat) := 40 | match k with 41 | | [] => Some ps 42 | | StPat p :: k => close k (p :: ps) 43 | | StFrame _ :: _ => None 44 | | StList :: _ => None 45 | end. 46 | 47 | Fixpoint close_ident (k : stack) (ps : list cointro_pat) : option stack := 48 | match k with 49 | | [] => None 50 | | StPat p :: k => close_ident k (p :: ps) 51 | | StFrame s :: k => Some (StPat (SFrame s ps) :: k) 52 | | StList :: k => Some (StPat (SList ps) :: k) 53 | end. 54 | 55 | Fixpoint parse_go (ts : list token) (k : stack) : option (list cointro_pat) := 56 | match ts with 57 | | [] => close k [] 58 | | TParenL :: ts => parse_go ts (StList :: k) 59 | | TParenR :: ts => k ← close_ident k []; parse_go ts k 60 | | TName s :: ts => parse_go ts (StPat (SCoHyp s) :: k) 61 | | TPure x :: ts => parse_go ts (StPat (SPureGoal false) :: k) 62 | | TBracketL :: TPure None :: TBracketR :: ts => 63 | parse_go ts (StPat (SPureGoal false) :: k) 64 | | TBracketL :: TPure None :: TDone :: TBracketR :: ts => 65 | parse_go ts (StPat (SPureGoal true) :: k) 66 | | TBracketL :: TIntuitionistic :: ts => parse_goal ts GIntuitionistic false [] k 67 | | TBracketL :: TModal :: ts => parse_goal ts GModal false [] k 68 | | TBracketL :: ts => parse_goal ts GSpatial false [] k 69 | | _ => None 70 | end 71 | with parse_goal (ts : list token) 72 | (ki : goal_kind) (neg : bool) (hyps : list ident) 73 | (k : stack) : option (list cointro_pat) := 74 | match ts with 75 | | TName s :: ts => parse_goal ts ki neg (INamed s :: hyps) k 76 | | TMinus :: ts => 77 | if decide (¬neg ∧ hyps = []) 78 | then parse_goal ts ki true hyps k 79 | else None 80 | | TBracketR :: ts => 81 | parse_go ts (StPat (SSplitGoal (SpecGoal ki neg (reverse hyps))) :: k) 82 | | _ => None 83 | end. 84 | Definition parse (s : string) : option (list cointro_pat) := 85 | parse_go (tokenize s) []. 86 | 87 | Ltac parse s := 88 | lazymatch type of s with 89 | | list cointro_pat => s 90 | | cointro_pat => constr:([s]) 91 | | string => 92 | lazymatch eval vm_compute in (parse s) with 93 | | Some ?pats => pats 94 | | _ => fail "cointro_pat.parse: cannot parse" s "as a cointroduction pattern" 95 | end 96 | | ident => constr:([SCoHyp s]) 97 | | ?X => fail "cointro_pat.parse: the term" s 98 | "is expected to be a cointroduction pattern" 99 | "(usually a string)," 100 | "but has unexpected type" X 101 | end. 102 | End cointro_pat. 103 | -------------------------------------------------------------------------------- /theories/MicroSail/Soundness.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Sander Huyghebaert, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Katamaran Require Import 30 | Signature 31 | Specification 32 | Program 33 | Tactics 34 | MicroSail.ShallowExecutor 35 | MicroSail.SymbolicExecutor 36 | MicroSail.RefineExecutor. 37 | 38 | Module MakeSymbolicSoundness 39 | (Import B : Base) 40 | (Import SIG : Signature B) 41 | (Import PROG : Program B) 42 | (Import SPEC : Specification B SIG PROG) 43 | (Import SHAL : ShallowExecOn B SIG PROG SPEC) 44 | (Import SYMB : SymbolicExecOn B SIG PROG SPEC). 45 | 46 | Include RefineExecOn B SIG PROG SPEC SHAL SYMB. 47 | End MakeSymbolicSoundness. 48 | -------------------------------------------------------------------------------- /theories/Notations.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019 Steven Keuchel, Dominique Devriese, Georgy Lukyanov *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | (* Really short summary on notations in Coq: 30 | - Coq uses precedence levels from 0 to 100. 31 | - Lower levels bound tighter than higher levels. 32 | - A /\ B is at level 80, right assoc 33 | - A \/ B is at level 85, right assoc 34 | - x = y is at level 70 35 | *) 36 | 37 | Reserved Infix "▻" (at level 61, left associativity). 38 | Reserved Infix "▻▻" (at level 61, left associativity). 39 | (* stdpp defines this at level 70 *) 40 | Reserved Infix "∈" (at level 70). 41 | (* Notation for bindings and type of bindings defined in the Context module. 42 | This is at level 49 because "-" is at level 50. This avoid parens when 43 | removing a binding an element from a context, e.g. Γ - x∷σ. *) 44 | Reserved Notation "x ∷ t" (at level 49, no associativity, format "'[' x ∷ t ']'"). 45 | 46 | Reserved Notation "[ ]" (format "[ ]"). 47 | Reserved Notation "[ x ]". 48 | Reserved Notation "[ x ; y ; .. ; z ]". 49 | 50 | (* We use the character ↦ as an infix notation for points-to predicates in the 51 | case-studies. This should bind tighter than ∗ which is at level 80. Hence 52 | x in this notation has to bind at least tighter than that. Also it should 53 | allow for x being a typed binding (y ∷ t) which is at level 49, so looser 54 | than that. *) 55 | Reserved Notation "δ ► ( x ↦ v )" (at level 50, x at level 50, left associativity, 56 | format "δ ► ( x ↦ v )"). 57 | Reserved Notation "δ1 ►► δ2" (at level 50, left associativity). 58 | Reserved Notation "δ ⟪ x ↦ v ⟫" (at level 90, x at level 0, v at level 0, left associativity). 59 | Reserved Notation "δ ‼ x" (at level 56, no associativity). 60 | 61 | Reserved Notation "⟨ γ1 , μ1 , δ1 , s1 ⟩ ---> ⟨ γ2 , μ2 , δ2 , s2 ⟩" (at level 75, no associativity). 62 | Reserved Notation "⟨ γ1 , μ1 , δ1 , s1 ⟩ --->* ⟨ γ2 , μ2 , δ2 , s2 ⟩" (at level 75, no associativity). 63 | (* Notation "( x , y , .. , z )" := *) 64 | (* (tuplepat_snoc .. (tuplepat_snoc (tuplepat_snoc tuplepat_nil x) y) .. z). *) 65 | 66 | Reserved Notation "s1 ;; s2" (at level 100, s2 at level 200, right associativity, 67 | format "'[v' s1 ;; '/' s2 ']'"). 68 | 69 | Reserved Notation "⦃ P ⦄ s ; δ ⦃ Q ⦄" (at level 75, no associativity). 70 | 71 | (* Subst / persist / inst notations. *) 72 | Reserved Notation "a ⟨ ζ ⟩" (at level 7, left associativity, format "a ⟨ ζ ⟩"). 73 | Reserved Infix "∘" (at level 40, left associativity). 74 | 75 | (* Functor notations. Compatible with stdpp. *) 76 | Reserved Infix "<$>" (at level 61, left associativity). 77 | Reserved Infix "<*>" (at level 61, left associativity). 78 | 79 | (* Logic notations. These were chosen to be compatible with Coq.Unicode.Utf8, stdpp and iris. *) 80 | Reserved Notation "P ⊢ Q" (at level 99, Q at level 200, right associativity). 81 | Reserved Notation "P '⊢@{' L } Q" (at level 99, Q at level 200, right associativity). 82 | Reserved Notation "P ⊢f f" (at level 99, f at level 200, no associativity). 83 | Reserved Notation "P ⊣⊢ Q" (at level 95, no associativity). 84 | Reserved Notation "P '⊣⊢@{' L } Q" (at level 95, no associativity). 85 | Reserved Infix "∧" (at level 80, right associativity). 86 | Reserved Infix "∨" (at level 85, right associativity). 87 | Reserved Notation "x → y" (at level 99, y at level 200, right associativity). 88 | Reserved Notation "'!!' e" (at level 25). 89 | Reserved Notation "P ∗ Q" (at level 80, right associativity). 90 | Reserved Notation "P -∗ Q" 91 | (at level 99, Q at level 200, right associativity, 92 | format "'[' P '/' -∗ Q ']'"). 93 | 94 | Reserved Infix "!=" (at level 70, no associativity). 95 | 96 | Reserved Infix "+ᵇ" (at level 50, left associativity). 97 | Reserved Infix "-ᵇ" (at level 50, left associativity). 98 | Reserved Infix "*ᵇ" (at level 40, left associativity). 99 | 100 | (* Signed bitvector operations *) 101 | Reserved Infix ">=ˢ" (at level 70, no associativity). 102 | Reserved Infix ">ˢ" (at level 70, no associativity). 103 | Reserved Infix "<=ˢ" (at level 70, no associativity). 104 | Reserved Infix "<ˢ" (at level 70, no associativity). 105 | Reserved Infix ">=ˢ?" (at level 70, no associativity). 106 | Reserved Infix ">ˢ?" (at level 70, no associativity). 107 | Reserved Infix "<=ˢ?" (at level 70, no associativity). 108 | Reserved Infix "<ˢ?" (at level 70, no associativity). 109 | 110 | (* Unsigned bitvector operations *) 111 | Reserved Infix ">=ᵘ" (at level 70, no associativity). 112 | Reserved Infix ">ᵘ" (at level 70, no associativity). 113 | Reserved Infix "<=ᵘ" (at level 70, no associativity). 114 | Reserved Infix "<ᵘ" (at level 70, no associativity). 115 | Reserved Infix ">=ᵘ?" (at level 70, no associativity). 116 | Reserved Infix ">ᵘ?" (at level 70, no associativity). 117 | Reserved Infix "<=ᵘ?" (at level 70, no associativity). 118 | Reserved Infix "<ᵘ?" (at level 70, no associativity). 119 | 120 | (* Semantic equivalence *) 121 | Reserved Infix "≈ᴱ" (at level 70). 122 | Reserved Infix "≈ᴺ" (at level 70). 123 | Reserved Infix "≈ᵀ" (at level 70). 124 | -------------------------------------------------------------------------------- /theories/Program.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019 Dominique Devriese, Georgy Lukyanov, *) 3 | (* Sander Huyghebaert, Steven Keuchel *) 4 | (* All rights reserved. *) 5 | (* *) 6 | (* Redistribution and use in source and binary forms, with or without *) 7 | (* modification, are permitted provided that the following conditions are *) 8 | (* met: *) 9 | (* *) 10 | (* 1. Redistributions of source code must retain the above copyright notice, *) 11 | (* this list of conditions and the following disclaimer. *) 12 | (* *) 13 | (* 2. Redistributions in binary form must reproduce the above copyright *) 14 | (* notice, this list of conditions and the following disclaimer in the *) 15 | (* documentation and/or other materials provided with the distribution. *) 16 | (* *) 17 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 18 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 19 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 20 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 21 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 22 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 23 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 24 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 25 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 26 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 27 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 28 | (******************************************************************************) 29 | 30 | From Katamaran Require Export 31 | Syntax.FunDecl 32 | Syntax.FunDef 33 | Syntax.Statements 34 | Base. 35 | 36 | Module Type FunDeclMixin (B : Base) := 37 | StatementsOn B. 38 | 39 | Module Type ProgramMixin (B : Base) := 40 | Equalities.Nop. 41 | 42 | Module Type Program (B : Base) := 43 | FunDeclKit B <+ FunDeclMixin B <+ FunDefKit B <+ ProgramMixin B. 44 | -------------------------------------------------------------------------------- /theories/Semantics.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2022 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Katamaran Require Export 30 | Base 31 | Program 32 | SmallStep.Step 33 | (* SmallStep.Inversion *) 34 | SmallStep.Progress. 35 | 36 | Module Type SemanticsMixin (B : Base) (P : Program B) := 37 | SmallStepOn B P <+ (* InversionOn B P <+ *) ProgressOn B P. 38 | Module Type Semantics (B : Base) (P : Program B) := 39 | Equalities.Nop <+ SemanticsMixin B P. 40 | Module MakeSemantics (B : Base) (P : Program B) <: Semantics B P := 41 | Equalities.Nop <+ SemanticsMixin B P. 42 | -------------------------------------------------------------------------------- /theories/Semantics/Registers.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2021 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Equations Require Import 30 | Equations. 31 | From Katamaran Require Import 32 | Context 33 | Prelude 34 | Base. 35 | 36 | Local Set Implicit Arguments. 37 | 38 | Module Type RegStoreKit (Import B : Base). 39 | 40 | (* We choose to make [RegStore] a parameter so the users of the module would be able to 41 | instantiate it with their own data structure and [read_register]/[write_register] 42 | functions *) 43 | Parameter RegStore : Type. 44 | Parameter read_register : forall (γ : RegStore) {σ} (r : 𝑹𝑬𝑮 σ), Val σ. 45 | Parameter write_register : forall (γ : RegStore) {σ} (r : 𝑹𝑬𝑮 σ) (v : Val σ), RegStore. 46 | 47 | Parameter read_write : forall (γ : RegStore) σ (r : 𝑹𝑬𝑮 σ) (v : Val σ), 48 | read_register (write_register γ r v) r = v. 49 | 50 | Parameter read_write_distinct : 51 | forall (γ : RegStore) {σ τ} (r__σ : 𝑹𝑬𝑮 σ) (r__τ : 𝑹𝑬𝑮 τ) (v__σ : Val σ), 52 | existT _ r__σ <> existT _ r__τ -> 53 | read_register (write_register γ r__σ v__σ) r__τ = read_register γ r__τ. 54 | 55 | End RegStoreKit. 56 | 57 | Module DefaultRegStoreKit (Import B : Base) <: RegStoreKit B. 58 | 59 | Definition RegStore : Type := forall σ, 𝑹𝑬𝑮 σ -> Val σ. 60 | 61 | Definition write_register (γ : RegStore) {σ} (r : 𝑹𝑬𝑮 σ) 62 | (v : Val σ) : RegStore := 63 | fun τ r' => 64 | match eq_dec_het r r' with 65 | | left eqt => eq_rect σ Val v τ (f_equal projT1 eqt) 66 | | right _ => γ τ r' 67 | end. 68 | 69 | Definition read_register (γ : RegStore) {σ} (r : 𝑹𝑬𝑮 σ) : 70 | Val σ := γ _ r. 71 | 72 | Lemma read_write γ {σ} (r : 𝑹𝑬𝑮 σ) (v : Val σ) : 73 | read_register (write_register γ r v) r = v. 74 | Proof. 75 | unfold read_register, write_register. 76 | unfold eq_dec_het. now rewrite EqDec.eq_dec_refl. 77 | Qed. 78 | 79 | Lemma read_write_distinct γ {σ τ} (r : 𝑹𝑬𝑮 σ) (k : 𝑹𝑬𝑮 τ) (v : Val σ): 80 | existT _ r <> existT _ k -> 81 | read_register (write_register γ r v) k = read_register γ k. 82 | Proof. 83 | intros ?; unfold read_register, write_register. 84 | destruct (eq_dec_het r k). 85 | - congruence. 86 | - reflexivity. 87 | Qed. 88 | 89 | Lemma write_read γ {σ} (r : 𝑹𝑬𝑮 σ) : 90 | forall τ (r' : 𝑹𝑬𝑮 τ), 91 | write_register γ r (read_register γ r) r' = γ τ r'. 92 | Proof. 93 | intros ? ?. 94 | unfold write_register, read_register. 95 | destruct (eq_dec_het r r') as [e|]. 96 | - now dependent elimination e. 97 | - reflexivity. 98 | Qed. 99 | 100 | Lemma write_write γ {σ} (r : 𝑹𝑬𝑮 σ) (v1 v2 : Val σ) : 101 | forall τ (r' : 𝑹𝑬𝑮 τ), 102 | write_register (write_register γ r v1) r v2 r' = 103 | write_register γ r v2 r'. 104 | Proof. 105 | intros ? ?. 106 | unfold write_register, read_register. 107 | destruct (eq_dec_het r r'); reflexivity. 108 | Qed. 109 | 110 | End DefaultRegStoreKit. 111 | -------------------------------------------------------------------------------- /theories/Sep/Logic.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Georgy Lukyanov, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From iris.bi Require Export interface derived_laws. 30 | From Katamaran Require Import Context Environment Prelude. 31 | 32 | Section WithBi. 33 | Context {L : bi}. 34 | 35 | Lemma forall_elim' {A : Type} (a : A) (Ψ : A → L) Φ : 36 | (Ψ a ⊢ Φ) → (bi_forall Ψ ⊢ Φ). 37 | Proof. intros. transitivity (Ψ a); auto. apply bi.forall_elim. Qed. 38 | 39 | Section Forall. 40 | 41 | Context {B : Set} {D : B -> Set}. 42 | 43 | Fixpoint Forall {Δ : Ctx B} : (Env D Δ -> L) -> L := 44 | match Δ with 45 | | ctx.nil => fun P => P env.nil 46 | | ctx.snoc Δ b => fun P => Forall (fun E => ∀ v, P (env.snoc E b v)) 47 | end%I. 48 | 49 | Lemma Forall_forall (Δ : Ctx B) (P : Env D Δ -> L) : 50 | (Forall P) ⊣⊢ (∀ E : Env D Δ, P E). 51 | Proof. 52 | induction Δ; cbn. 53 | - apply bi.entails_anti_sym. 54 | + apply bi.forall_intro; intros E. now env.destroy E. 55 | + apply bi.forall_elim. 56 | - rewrite IHΔ. clear IHΔ. 57 | apply bi.entails_anti_sym; apply bi.forall_intro. 58 | + intros E. destruct (env.view E) as [E v]. 59 | now apply (forall_elim' E), (forall_elim' v). 60 | + intros E. apply bi.forall_intro. intros v. 61 | now apply (forall_elim' (env.snoc E _ v)). 62 | Qed. 63 | 64 | End Forall. 65 | 66 | Lemma wand_or_distr {P Q R : L} : 67 | ((P ∨ Q) -∗ R) ⊣⊢ ((P -∗ R) ∧ (Q -∗ R)). 68 | Proof. 69 | apply bi.entails_anti_sym. 70 | - apply bi.and_intro; apply bi.wand_mono; try easy. 71 | apply bi.or_intro_l. apply bi.or_intro_r. 72 | - apply bi.wand_intro_r. 73 | rewrite bi.sep_comm. 74 | apply bi.wand_elim_l'. 75 | apply bi.or_elim. 76 | + apply bi.wand_intro_r. 77 | rewrite bi.and_elim_l. 78 | apply bi.wand_elim_r. 79 | + apply bi.wand_intro_r. 80 | rewrite bi.and_elim_r. 81 | apply bi.wand_elim_r. 82 | Qed. 83 | 84 | Lemma entails_wand_iff {P Q : L} : 85 | (P ⊢ Q) ↔ (P -∗ Q). 86 | Proof. split. apply bi.entails_wand. apply bi.wand_entails. Qed. 87 | 88 | Lemma entails_apply {P Q : L} : 89 | (True ⊢ P) -> ((P → Q) ⊢ Q). 90 | Proof. 91 | intros H. transitivity ((P → Q) ∧ P)%I. 92 | - apply bi.and_intro. easy. 93 | transitivity (@bi_pure L True); auto. 94 | apply bi.True_intro. 95 | - apply bi.impl_elim_l. 96 | Qed. 97 | 98 | End WithBi. 99 | -------------------------------------------------------------------------------- /theories/Signature.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Georgy Lukyanov, *) 3 | (* Sander Huyghebaert, Steven Keuchel *) 4 | (* All rights reserved. *) 5 | (* *) 6 | (* Redistribution and use in source and binary forms, with or without *) 7 | (* modification, are permitted provided that the following conditions are *) 8 | (* met: *) 9 | (* *) 10 | (* 1. Redistributions of source code must retain the above copyright notice, *) 11 | (* this list of conditions and the following disclaimer. *) 12 | (* *) 13 | (* 2. Redistributions in binary form must reproduce the above copyright *) 14 | (* notice, this list of conditions and the following disclaimer in the *) 15 | (* documentation and/or other materials provided with the distribution. *) 16 | (* *) 17 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 18 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 19 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 20 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 21 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 22 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 23 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 24 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 25 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 26 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 27 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 28 | (******************************************************************************) 29 | 30 | From Katamaran Require Export 31 | Base 32 | Refinement.Monads 33 | Shallow.Monads 34 | Symbolic.Monads 35 | Symbolic.Propositions 36 | Symbolic.Solver 37 | Symbolic.UnifLogic 38 | Symbolic.Worlds 39 | Syntax.Assertions 40 | Syntax.Chunks 41 | Syntax.Predicates. 42 | 43 | Module Type SignatureMixin 44 | (B : Base) (P : PredicateKit B) (W : WorldsMixin B P) (S : SolverKit B P W) := 45 | SymPropOn B P W <+ UnifLogicOn B P W <+ LogSymPropOn B P W <+ 46 | AssertionsOn B P W <+ 47 | GenericSolverOn B P W S <+ ShallowMonadsOn B P W <+ 48 | SymbolicMonadsOn B P W S <+ 49 | RefinementMonadsOn B P W S. 50 | 51 | Module Type Signature (B : Base) := 52 | PredicateKit B <+ WorldsMixin B <+ SolverKit B <+ SignatureMixin B. 53 | -------------------------------------------------------------------------------- /theories/SmallStep/Progress.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019 Steven Keuchel, Georgy Lukyanov *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Program.Tactics. 31 | From Katamaran Require Import 32 | Notations 33 | SmallStep.Step 34 | Program. 35 | 36 | Module ProgressOn (Import B : Base) (Import P : Program B) (Import STEP : SmallStepOn B P). 37 | 38 | Local Ltac progress_can_form := 39 | match goal with 40 | | [ H: CStore (ctx.cat _ _) |- _ ] => destruct (env.catView H) 41 | | [ H: Final ?s |- _ ] => destruct s; cbn in H 42 | end; destruct_conjs; subst; try contradiction. 43 | 44 | Local Ltac progress_simpl := 45 | repeat 46 | (cbn in *; destruct_conjs; subst; 47 | try progress_can_form; 48 | try match goal with 49 | | [ |- True \/ _] => left; constructor 50 | | [ |- False \/ _] => right 51 | | [ |- forall _, _ ] => intro 52 | | [ H : True |- _ ] => clear H 53 | | [ H : _ \/ _ |- _ ] => destruct H 54 | end). 55 | 56 | Local Ltac progress_inst T := 57 | match goal with 58 | | [ IH: (forall (γ : RegStore) (μ : Memory) (δ : CStore (ctx.cat ?Γ ?Δ)), _), 59 | γ : RegStore, μ : Memory, δ1: CStore ?Γ, δ2: CStore ?Δ |- _ 60 | ] => specialize (IH γ μ (env.cat δ1 δ2)); T 61 | | [ IH: (forall (γ : RegStore) (μ : Memory) (δ : CStore ?Γ), _), 62 | γ : RegStore, δ: CStore ?Γ |- _ 63 | ] => solve [ specialize (IH γ μ δ); T | clear IH; T ] 64 | end. 65 | 66 | Lemma progress_foreign 67 | {Γ Δ : PCtx} {σ : Ty} (f : 𝑭𝑿 Δ σ) (es : NamedEnv (Exp Γ) Δ) 68 | (γ : RegStore) (μ : Memory) (δ : CStore Γ) : 69 | exists (γ' : RegStore) (μ' : Memory) (δ' : CStore Γ) (s' : Stm Γ σ), 70 | ⟨ γ, μ, δ, stm_foreign f es ⟩ ---> ⟨ γ', μ', δ', s' ⟩. 71 | Proof. 72 | destruct (ForeignProgress f (evals es δ) γ μ) as (γ' & μ' & res & p). 73 | exists γ', μ', δ. eexists; constructor; eauto. 74 | Qed. 75 | 76 | Local Ltac progress_tac := 77 | auto using progress_foreign; 78 | progress_simpl; 79 | solve 80 | [ repeat eexists; constructor; eauto 81 | | progress_inst progress_tac 82 | ]. 83 | 84 | Lemma progress {Γ σ} (s : Stm Γ σ) : 85 | Final s \/ forall γ μ δ, exists γ' μ' δ' s', ⟨ γ , μ , δ , s ⟩ ---> ⟨ γ' , μ' , δ' , s' ⟩. 86 | Proof. induction s; intros; try progress_tac. Qed. 87 | 88 | End ProgressOn. 89 | -------------------------------------------------------------------------------- /theories/Specification.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Georgy Lukyanov, *) 3 | (* Sander Huyghebaert, Steven Keuchel *) 4 | (* All rights reserved. *) 5 | (* *) 6 | (* Redistribution and use in source and binary forms, with or without *) 7 | (* modification, are permitted provided that the following conditions are *) 8 | (* met: *) 9 | (* *) 10 | (* 1. Redistributions of source code must retain the above copyright notice, *) 11 | (* this list of conditions and the following disclaimer. *) 12 | (* *) 13 | (* 2. Redistributions in binary form must reproduce the above copyright *) 14 | (* notice, this list of conditions and the following disclaimer in the *) 15 | (* documentation and/or other materials provided with the distribution. *) 16 | (* *) 17 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 18 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 19 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 20 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 21 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 22 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 23 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 24 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 25 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 26 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 27 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 28 | (******************************************************************************) 29 | 30 | From Coq Require Import 31 | Classes.Morphisms 32 | Classes.RelationClasses 33 | Program.Tactics 34 | Relations.Relation_Definitions 35 | String. 36 | 37 | From Katamaran Require Export 38 | Base 39 | Program 40 | Signature. 41 | 42 | Import ctx.notations. 43 | Import env.notations. 44 | 45 | Module Type SpecificationMixin (B : Base) (Import SIG : Signature B) (Import P : Program B). 46 | 47 | Definition SepContractEnv : Type := 48 | forall Δ τ (f : 𝑭 Δ τ), option (SepContract Δ τ). 49 | Definition SepContractEnvEx : Type := 50 | forall Δ τ (f : 𝑭𝑿 Δ τ), SepContract Δ τ. 51 | Definition LemmaEnv : Type := 52 | forall Δ (l : 𝑳 Δ), Lemma Δ. 53 | 54 | End SpecificationMixin. 55 | 56 | Module Type SpecificationKit (B : Base) (Import SIG : Signature B) (P : Program B) 57 | (Import SM : SpecificationMixin B SIG P). 58 | 59 | Local Set Implicit Arguments. 60 | 61 | Parameter CEnv : SepContractEnv. 62 | Parameter CEnvEx : SepContractEnvEx. 63 | Parameter LEnv : LemmaEnv. 64 | 65 | End SpecificationKit. 66 | 67 | Module Type Specification (B : Base) (SIG : Signature B) (P : Program B). 68 | Include SpecificationMixin B SIG P. 69 | Include SpecificationKit B SIG P. 70 | End Specification. 71 | -------------------------------------------------------------------------------- /theories/Staging/CommandStep.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2021 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Program.Tactics 31 | Strings.String. 32 | From Equations Require Import 33 | Equations. 34 | From Katamaran Require Import 35 | Semantics.Registers 36 | Program 37 | Tactics. 38 | 39 | Import ctx.notations. 40 | Import env.notations. 41 | 42 | Set Implicit Arguments. 43 | 44 | Module Type CommandsOn (Import B : Base) (Import F : FunDeclKit B). 45 | 46 | Inductive Command (A : Type) : Type := 47 | | cmd_return (a : A) 48 | | cmd_fail 49 | | cmd_read_register {τ} (reg : 𝑹𝑬𝑮 τ) (c : Val τ -> Command A) 50 | | cmd_write_register {τ} (reg : 𝑹𝑬𝑮 τ) (v : Val τ) (c : Command A) 51 | | cmd_call {Δ τ} (f : 𝑭 Δ τ) (vs : CStore Δ) (c : Val τ -> Command A) 52 | | cmd_foreign {Δ τ} (f : 𝑭𝑿 Δ τ) (vs : CStore Δ) (c : Val τ -> Command A). 53 | Global Arguments cmd_fail {A}. 54 | 55 | Fixpoint cmd_bind {A B} (m : Command A) (g : A -> Command B) {struct m} : Command B := 56 | match m with 57 | | cmd_return a => g a 58 | | cmd_fail => cmd_fail 59 | | cmd_read_register reg k => cmd_read_register reg (fun v => cmd_bind (k v) g) 60 | | cmd_write_register reg v c => cmd_write_register reg v (cmd_bind c g) 61 | | cmd_call f vs k => cmd_call f vs (fun v => cmd_bind (k v) g) 62 | | cmd_foreign f vs k => cmd_foreign f vs (fun v => cmd_bind (k v) g) 63 | end. 64 | 65 | Definition cmd_map {A B} (f : A -> B) (ma : Command A) : Command B := 66 | cmd_bind ma (fun v => cmd_return (f v)). 67 | 68 | End CommandsOn. 69 | 70 | Module Type CFunDefKit (Import B : Base) (Import F : FunDeclKit B) (Import C : CommandsOn B F). 71 | 72 | Include RegStoreKit B. 73 | 74 | (* Memory model *) 75 | Parameter Memory : Type. 76 | (* Step relation for calling an external function. The complete function call 77 | is done in one step. The result of an external call is either a failure 78 | with an error message msg (res = inl msg) or a successful computation with 79 | a result value v (res = inr v). 80 | *) 81 | Parameter ForeignCall : 82 | forall 83 | {Δ σ} (f : 𝑭𝑿 Δ σ) 84 | (args : CStore Δ) 85 | (res : string + Val σ) 86 | (γ γ' : RegStore) 87 | (μ μ' : Memory), Prop. 88 | Parameter ForeignProgress : 89 | forall {Δ σ} (f : 𝑭𝑿 Δ σ) (args : CStore Δ) γ μ, 90 | exists γ' μ' res, ForeignCall f args res γ γ' μ μ'. 91 | 92 | Parameter Inline FunDef : forall {Δ τ} (f : 𝑭 Δ τ), CStore Δ -> Command (Val τ). 93 | 94 | End CFunDefKit. 95 | 96 | Module Type CProgram (B : Base) := FunDeclKit B <+ CommandsOn B <+ CFunDefKit B. 97 | 98 | Module SmallStepOn (Import B : Base) (Import P : CProgram B). 99 | 100 | Reserved Notation "⟨ γ1 , μ1 , c1 ⟩ ---> ⟨ γ2 , μ2 , s2 ⟩" (at level 75, no associativity). 101 | 102 | Inductive Step {A} (γ : RegStore) (μ : Memory) : 103 | forall (γ2 : RegStore) (μ2 : Memory) (c1 c2 : Command A), Prop := 104 | 105 | | step_call 106 | {Δ τ} {f : 𝑭 Δ τ} (vs : CStore Δ) (c : Val τ -> Command A) : 107 | ⟨ γ , μ , cmd_call f vs c ⟩ ---> 108 | ⟨ γ , μ , cmd_bind (FunDef f vs) c ⟩ 109 | | step_foreign 110 | {Δ τ} {f : 𝑭𝑿 Δ τ} (vs : CStore Δ) (c : Val τ -> Command A) 111 | (γ' : RegStore) (μ' : Memory) (res : string + Val τ) : 112 | ForeignCall f vs res γ γ' μ μ' -> 113 | ⟨ γ , μ , cmd_foreign f vs c ⟩ ---> 114 | ⟨ γ' , μ' , match res with 115 | | inl msg => cmd_fail 116 | | inr v => c v 117 | end ⟩ 118 | | step_read_register 119 | {τ} (r : 𝑹𝑬𝑮 τ) (c : Val τ -> Command A) : 120 | ⟨ γ, μ , cmd_read_register r c ⟩ ---> ⟨ γ, μ , c (read_register γ r) ⟩ 121 | | step_write_register 122 | {τ} (r : 𝑹𝑬𝑮 τ) (v : Val τ) (c : Command A) : 123 | ⟨ γ , μ , cmd_write_register r v c ⟩ ---> ⟨ write_register γ r v , μ , c ⟩ 124 | 125 | where "⟨ γ1 , μ1 , c1 ⟩ ---> ⟨ γ2 , μ2 , c2 ⟩" := (@Step _ γ1%env μ1%env γ2%env μ2%env c1 c2). 126 | 127 | End SmallStepOn. 128 | 129 | Module CInterpreter (Import B : Base) 130 | (Import F : FunDeclKit B) (Import C : CommandsOn B F) 131 | (Import S : StatementsOn B F). 132 | 133 | Definition M (Γ1 Γ2 : PCtx) (A : Type) : Type := 134 | CStore Γ1 -> Command (CStore Γ2 * A). 135 | Definition run {Γ1 Γ2 A} (m : M Γ1 Γ2 A) (δ : CStore Γ1) : Command A := 136 | cmd_map snd (m δ). 137 | 138 | Definition pure {Γ A} (a : A) : M Γ Γ A := 139 | fun δ => cmd_return (δ , a). 140 | Definition bind {Γ1 Γ2 Γ3 A B} (m : M Γ1 Γ2 A) (f : A -> M Γ2 Γ3 B) : M Γ1 Γ3 B := 141 | fun δ1 => cmd_bind (m δ1) (fun '(δ2,a) => f a δ2). 142 | Definition bind_right {Γ1 Γ2 Γ3 A B} (ma : M Γ1 Γ2 A) (mb : M Γ2 Γ3 B) : M Γ1 Γ3 B := 143 | bind ma (fun _ => mb). 144 | Definition map {Γ1 Γ2 A B} (f : A -> B) (ma : M Γ1 Γ2 A) : M Γ1 Γ2 B := 145 | bind ma (fun a => pure (f a )). 146 | Definition error {Γ1 Γ2 A} : M Γ1 Γ2 A := 147 | fun _ => @cmd_fail _. 148 | Definition mcall {Γ Δ τ} (f : 𝑭 Δ τ) (args : CStore Δ) : M Γ Γ (Val τ) := 149 | fun δ => cmd_call f args (fun v => cmd_return (δ,v)). 150 | Definition mforeign {Γ Δ τ} (f : 𝑭𝑿 Δ τ) (args : CStore Δ) : M Γ Γ (Val τ) := 151 | fun δ => cmd_foreign f args (fun v => cmd_return (δ,v)). 152 | Definition mreadreg {Γ τ} (reg : 𝑹𝑬𝑮 τ) : M Γ Γ (Val τ) := 153 | fun δ => cmd_read_register reg (fun v => cmd_return (δ,v)). 154 | Definition mwritereg {Γ τ} (reg : 𝑹𝑬𝑮 τ) (v : Val τ) : M Γ Γ unit := 155 | fun δ => cmd_write_register reg v (cmd_return (δ,tt)). 156 | 157 | Definition pushpop {A Γ1 Γ2 x σ} (v : Val σ) 158 | (d : M (Γ1 ▻ x∷σ) (Γ2 ▻ x∷σ) A) : M Γ1 Γ2 A := 159 | fun δ1 => cmd_map (fun '(δ2,a) => (env.tail δ2 , a)) (d (δ1 ► (x∷σ ↦ v))). 160 | Definition pushspops {A} {Γ1 Γ2 Δ} (δΔ : CStore Δ) 161 | (d : M (Γ1 ▻▻ Δ) (Γ2 ▻▻ Δ) A) : M Γ1 Γ2 A := 162 | fun δ1 => cmd_map (fun '(δ2,a) => (env.drop Δ δ2 , a)) (d (δ1 ►► δΔ)). 163 | Definition get_local {Γ} : M Γ Γ (CStore Γ) := 164 | fun δ => cmd_return (δ,δ). 165 | Definition put_local {Γ1 Γ2} (δ : CStore Γ2) : M Γ1 Γ2 unit := 166 | fun _ => cmd_return (δ,tt). 167 | 168 | Definition eval_exp {Γ σ} (e : Exp Γ σ) : M Γ Γ (Val σ) := 169 | fun δ => cmd_return (δ,eval e δ). 170 | Definition eval_exps {Γ} {σs : PCtx} (es : NamedEnv (Exp Γ) σs) : M Γ Γ (CStore σs) := 171 | fun δ => cmd_return (δ,evals es δ). 172 | Definition assign {Γ} x {σ} {xIn : x∷σ ∈ Γ} (v : Val σ) : M Γ Γ unit := 173 | fun δ => cmd_return (δ ⟪ x ↦ v ⟫ , tt). 174 | Arguments assign {Γ} x {σ xIn} v. 175 | 176 | Notation "x <- ma ;; mb" := 177 | (bind ma (fun x => mb)) 178 | (at level 80, ma at level 90, mb at level 200, right associativity). 179 | Notation "m1 ;; m2" := (bind_right m1 m2). 180 | 181 | Fixpoint exec {Γ τ} (s : Stm Γ τ) : M Γ Γ (Val τ) := 182 | match s with 183 | | stm_val _ l => pure l 184 | | stm_exp e => eval_exp e 185 | | stm_let x σ s k => 186 | v <- exec s ;; 187 | pushpop v (exec k) 188 | | stm_block δ k => 189 | pushspops δ (exec k) 190 | | stm_assign x e => 191 | v <- exec e ;; 192 | assign x v ;; 193 | pure v 194 | | stm_call f es => 195 | bind (eval_exps es) (mcall f) 196 | | stm_foreign f es => 197 | bind (eval_exps es) (mforeign f) 198 | | stm_lemmak l es k => 199 | exec k 200 | | stm_call_frame δ' s => 201 | δ <- get_local ;; 202 | put_local δ' ;; 203 | v <- exec s ;; 204 | put_local δ ;; 205 | pure v 206 | | stm_seq s k => exec s ;; exec k 207 | | stm_assertk e1 _ k => 208 | v <- eval_exp e1 ;; 209 | if v then exec k else error 210 | | stm_fail _ s => 211 | error 212 | | stm_pattern_match s pat rhs => 213 | v <- exec s ;; 214 | let (pc,δpc) := pattern_match_val pat v in 215 | pushspops δpc (exec (rhs pc)) 216 | | stm_read_register reg => 217 | mreadreg reg 218 | | stm_write_register reg e => 219 | v <- eval_exp e ;; 220 | mwritereg reg v ;; 221 | pure v 222 | | stm_bind s k => 223 | v <- exec s ;; 224 | exec (k v) 225 | | stm_debugk k => 226 | exec k 227 | end. 228 | 229 | End CInterpreter. 230 | -------------------------------------------------------------------------------- /theories/Staging/Monads.v: -------------------------------------------------------------------------------- 1 | 2 | (* #[export] Instance purespecm : CPureSpecM CPureSpec := *) 3 | (* {| CPureSpecM.pure := @pure; *) 4 | (* CPureSpecM.bind := @bind; *) 5 | (* CPureSpecM.error := @error; *) 6 | (* CPureSpecM.block := @block; *) 7 | (* CPureSpecM.angelic := @angelic; *) 8 | (* CPureSpecM.demonic := @demonic; *) 9 | (* CPureSpecM.angelic_ctx := @angelic_ctx; *) 10 | (* CPureSpecM.demonic_ctx := @demonic_ctx; *) 11 | (* CPureSpecM.assert_pathcondition := @assert_pathcondition; *) 12 | (* CPureSpecM.assert_formula := @assert_formula; *) 13 | (* CPureSpecM.assume_pathcondition := @assume_pathcondition; *) 14 | (* CPureSpecM.assume_formula := @assume_formula; *) 15 | (* CPureSpecM.angelic_binary := @angelic_binary; *) 16 | (* CPureSpecM.demonic_binary := @demonic_binary; *) 17 | (* CPureSpecM.angelic_pattern_match := @angelic_pattern_match; *) 18 | (* CPureSpecM.demonic_pattern_match := @demonic_pattern_match; *) 19 | (* CPureSpecM.new_pattern_match := @new_pattern_match; *) 20 | (* CPureSpecM.debug := fun _ m => m; *) 21 | (* |}. *) 22 | 23 | (* #[global] Arguments CPureSpec.pure {_} _ /. *) 24 | (* #[global] Arguments CPureSpec.error {_} /. *) 25 | (* #[global] Arguments CPureSpec.bind {_ _} _ _ _ /. *) 26 | (* #[global] Arguments CPureSpec.assert_formula _ /. *) 27 | (* #[global] Arguments CPureSpec.assert_pathcondition _ /. *) 28 | (* #[global] Arguments CPureSpec.assume_formula _ /. *) 29 | (* #[global] Arguments CPureSpec.assume_pathcondition _ /. *) 30 | (* #[global] Arguments CPureSpec.angelic_binary {_} _ _ /. *) 31 | (* #[global] Arguments CPureSpec.demonic_binary {_} _ _ /. *) 32 | 33 | 34 | (* #[export] Instance mon_purespecm : MPureSpecM CPureSpec. *) 35 | (* Proof. constructor; try typeclasses eauto. Qed. *) 36 | -------------------------------------------------------------------------------- /theories/Staging/NewShallow/Soundness.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Sander Huyghebaert, Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Classes.Morphisms 31 | Strings.String 32 | ZArith.BinInt. 33 | From Katamaran Require Import 34 | Signature 35 | Sep.Hoare 36 | Sep.Logic 37 | Specification 38 | Prelude 39 | Program 40 | Staging.NewShallow.Executor. 41 | 42 | Set Implicit Arguments. 43 | 44 | Import ctx.notations. 45 | Import env.notations. 46 | 47 | Module Type Soundness 48 | (Import B : Base) 49 | (Import SIG : Signature B) 50 | (Import PROG : Program B) 51 | (Import SPEC : Specification B SIG PROG) 52 | (Import EXEC : NewShallowExecOn B SIG PROG SPEC) 53 | (Import HOAR : ProgramLogicOn B SIG PROG SPEC). 54 | 55 | Import CHeapSpecM. 56 | Import ProgramLogic. 57 | 58 | Section Soundness. 59 | 60 | Context {L} {biA : BiAffine L} {PI : PredicateDef L}. 61 | 62 | Lemma call_contract_sound {Δ τ} 63 | (c : SepContract Δ τ) (δΔ : CStore Δ) (POST : Val τ -> L) : 64 | CTriple (CPureSpecM.call_contract c δΔ POST) c δΔ POST. 65 | Proof. 66 | unfold CTriple. destruct c as [Σe δe req result ens]. 67 | now rewrite CPureSpecM.equiv_call_contract. 68 | Qed. 69 | 70 | Lemma call_lemma_sound {Δ} 71 | (lem : Lemma Δ) (δΔ : CStore Δ) (POST : unit -> L) : 72 | LTriple δΔ (CPureSpecM.call_lemma lem δΔ POST) (POST tt) lem. 73 | Proof. 74 | destruct lem as [Σe δe req ens]. constructor. 75 | now rewrite CPureSpecM.equiv_call_lemma. 76 | Qed. 77 | 78 | Definition SoundExec (rec : Exec) : Prop := 79 | forall Γ σ (s : Stm Γ σ) (POST : Val σ -> CStore Γ -> L) (δ1 : CStore Γ), 80 | ⦃ rec _ _ s POST δ1 ⦄ s ; δ1 ⦃ POST ⦄. 81 | 82 | Lemma exec_aux_sound rec (rec_sound : SoundExec rec) : 83 | SoundExec (exec_aux (exec_call_with_contracts rec)). 84 | Proof. 85 | unfold SoundExec. intros ? ? s. 86 | induction s; intros ? ?; cbn. 87 | 88 | - (* stm_val *) 89 | now apply rule_stm_val. 90 | 91 | - (* stm_exp *) 92 | now apply rule_stm_exp. 93 | 94 | - (* stm_let *) 95 | eapply rule_stm_let. apply IHs1. intros v2 δ2; cbn. apply IHs2. 96 | 97 | - (* stm_block *) 98 | now apply rule_stm_block, IHs. 99 | 100 | - (* stm_assign *) 101 | now apply rule_stm_assign, IHs. 102 | 103 | - (* stm_call *) 104 | destruct (CEnv f) as [c|] eqn:Heq. 105 | + apply rule_stm_call with c. 106 | assumption. 107 | now apply call_contract_sound. 108 | + apply rule_stm_call_inline. 109 | apply rec_sound. 110 | 111 | - (* stm_call_frame *) 112 | now apply rule_stm_call_frame, IHs. 113 | 114 | - (* stm_foreign *) 115 | apply rule_stm_foreign. 116 | apply call_contract_sound. 117 | 118 | - (* stm_lemmak *) 119 | unfold eval_exps. 120 | eapply rule_stm_lemmak. 121 | apply call_lemma_sound. 122 | apply IHs. 123 | 124 | - (* stm_seq *) 125 | eapply rule_stm_seq. apply IHs1. intros δ2. apply IHs2. 126 | 127 | - (* stm_assert *) 128 | apply rule_stm_assert; intro Heval. 129 | eapply rule_consequence_left. apply IHs. 130 | now apply entails_apply, bi.pure_intro. 131 | 132 | - (* stm_fail *) 133 | eapply rule_consequence_left. 134 | apply rule_stm_fail. 135 | reflexivity. 136 | 137 | - (* stm_pattern_match *) 138 | eapply rule_stm_pattern_match. apply IHs. cbn. 139 | intros pc δpc δ1'. rewrite pattern_match_val_inverse_right. 140 | now apply H. 141 | 142 | - (* stm_read_register *) 143 | apply rule_exist. intros v. 144 | apply (rule_stm_read_register_backwards (v := v)). 145 | 146 | - (* stm_write_register *) 147 | apply rule_exist. intros v. 148 | apply (rule_stm_write_register_backwards (v := v)). 149 | 150 | - (* stm_bind *) 151 | eapply rule_stm_bind. apply IHs. intros v2 δ2; cbn. apply H. 152 | - constructor. auto. 153 | Qed. 154 | 155 | Lemma exec_sound n : SoundExec (exec n). 156 | Proof. 157 | induction n; cbn. 158 | - unfold SoundExec. intros. apply rule_false. 159 | - apply exec_aux_sound; auto using exec_monotonic. 160 | Qed. 161 | 162 | Lemma vcgen_sound n {Δ τ} (c : SepContract Δ τ) (body : Stm Δ τ) : 163 | CHeapSpecM.vcgen n c body -> 164 | ProgramLogic.ValidContract c body. 165 | Proof. 166 | rewrite CHeapSpecM.vcgen_equiv. 167 | unfold CHeapSpecM.vcgen', ProgramLogic.ValidContract. 168 | unfold inst_contract_localstore. 169 | destruct c as [Σ δΣ req result ens]; cbn; intros HYP ι. 170 | eapply rule_consequence_left. 171 | apply exec_sound. apply HYP. 172 | Qed. 173 | 174 | Lemma shallow_vcgen_soundness {Δ τ} (c : SepContract Δ τ) (body : Stm Δ τ) : 175 | Shallow.ValidContract c body -> 176 | ProgramLogic.ValidContract c body. 177 | Proof. apply vcgen_sound. Qed. 178 | 179 | (* Print Assumptions shallow_vcgen_soundness. *) 180 | 181 | End Soundness. 182 | 183 | End Soundness. 184 | -------------------------------------------------------------------------------- /theories/Staging/WorldInstance.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Georgy Lukyanov, *) 3 | (* Sander Huyghebaert, Steven Keuchel *) 4 | (* All rights reserved. *) 5 | (* *) 6 | (* Redistribution and use in source and binary forms, with or without *) 7 | (* modification, are permitted provided that the following conditions are *) 8 | (* met: *) 9 | (* *) 10 | (* 1. Redistributions of source code must retain the above copyright notice, *) 11 | (* this list of conditions and the following disclaimer. *) 12 | (* *) 13 | (* 2. Redistributions in binary form must reproduce the above copyright *) 14 | (* notice, this list of conditions and the following disclaimer in the *) 15 | (* documentation and/or other materials provided with the distribution. *) 16 | (* *) 17 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 18 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 19 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 20 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 21 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 22 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 23 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 24 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 25 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 26 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 27 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 28 | (******************************************************************************) 29 | 30 | From Katamaran Require Import 31 | Prelude 32 | Base 33 | Syntax.Predicates 34 | Symbolic.Worlds. 35 | 36 | Import ctx.notations. 37 | 38 | Set Implicit Arguments. 39 | 40 | (* Unused, but don't let it bitrot. *) 41 | Module Type UnusedWorldInstance 42 | (Import B : Base) 43 | (Import P : PredicateKit B) 44 | (Import W : WorldsMixin B P). 45 | 46 | Import ModalNotations. 47 | Local Open Scope modal. 48 | 49 | Record WInstance (w : World) : Set := 50 | MkWInstance 51 | { ιassign :> Valuation w; 52 | ιvalid : instprop (wco w) ιassign; 53 | }. 54 | 55 | Program Definition winstance_formula {w} (ι : WInstance w) (fml : Formula w) (p : instprop fml ι) : 56 | WInstance (wformula w fml) := 57 | {| ιassign := ι; |}. 58 | Next Obligation. 59 | Proof. intros. cbn. split; auto. apply ιvalid. Qed. 60 | 61 | Program Definition winstance_snoc {w} (ι : WInstance w) {b : LVar ∷ Ty} (v : Val (type b)) : 62 | WInstance (wsnoc w b) := 63 | {| ιassign := env.snoc (ιassign ι) b v; |}. 64 | Next Obligation. 65 | Proof. 66 | intros. unfold wsnoc. cbn [wctx wco]. 67 | rewrite instprop_subst, inst_sub_wk1. 68 | apply ιvalid. 69 | Qed. 70 | 71 | Program Definition winstance_subst {w} (ι : WInstance w) {x σ} {xIn : x∷σ ∈ w} 72 | (t : Term (w - x∷σ) σ) (p : inst t (env.remove (x∷σ) (ιassign ι) xIn) = env.lookup (ιassign ι) xIn) : 73 | WInstance (wsubst w x t) := 74 | @MkWInstance (wsubst w x t) (env.remove _ (ιassign ι) xIn) _. 75 | Next Obligation. 76 | intros * p. cbn. rewrite instprop_subst, <- inst_sub_shift in *. 77 | rewrite inst_sub_single_shift; auto using ιvalid. 78 | Qed. 79 | 80 | Program Definition instacc {w0 w1} (ω01 : w0 ⊒ w1) : WInstance w1 -> WInstance w0 := 81 | match ω01 in (_ ⊒ w) return (WInstance w -> WInstance w0) with 82 | | acc_refl => fun ι => ι 83 | | @acc_sub _ w1 ζ ent => fun ι1 => {| ιassign := inst ζ ι1; |} 84 | end. 85 | Next Obligation. 86 | Proof. 87 | intros. specialize (ent ι1). 88 | rewrite <- instprop_subst. 89 | apply ent. 90 | apply ιvalid. 91 | Qed. 92 | 93 | End UnusedWorldInstance. 94 | -------------------------------------------------------------------------------- /theories/Syntax/FunDecl.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019 Dominique Devriese, Georgy Lukyanov, *) 3 | (* Sander Huyghebaert, Steven Keuchel *) 4 | (* All rights reserved. *) 5 | (* *) 6 | (* Redistribution and use in source and binary forms, with or without *) 7 | (* modification, are permitted provided that the following conditions are *) 8 | (* met: *) 9 | (* *) 10 | (* 1. Redistributions of source code must retain the above copyright notice, *) 11 | (* this list of conditions and the following disclaimer. *) 12 | (* *) 13 | (* 2. Redistributions in binary form must reproduce the above copyright *) 14 | (* notice, this list of conditions and the following disclaimer in the *) 15 | (* documentation and/or other materials provided with the distribution. *) 16 | (* *) 17 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 18 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 19 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 20 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 21 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 22 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 23 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 24 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 25 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 26 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 27 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 28 | (******************************************************************************) 29 | 30 | From Katamaran Require Import 31 | Context 32 | Syntax.TypeDecl 33 | Syntax.Variables. 34 | 35 | Module Type FunDeclKit (Import T : Types). 36 | 37 | Local Notation PCtx := (NCtx PVar ty.Ty). 38 | 39 | (* Names of functions. *) 40 | Parameter Inline 𝑭 : PCtx -> Ty -> Set. 41 | Parameter Inline 𝑭𝑿 : PCtx -> Ty -> Set. 42 | (* Names of lemmas. *) 43 | Parameter Inline 𝑳 : PCtx -> Set. 44 | 45 | End FunDeclKit. 46 | -------------------------------------------------------------------------------- /theories/Syntax/FunDef.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019 Dominique Devriese, Georgy Lukyanov, *) 3 | (* Sander Huyghebaert, Steven Keuchel *) 4 | (* All rights reserved. *) 5 | (* *) 6 | (* Redistribution and use in source and binary forms, with or without *) 7 | (* modification, are permitted provided that the following conditions are *) 8 | (* met: *) 9 | (* *) 10 | (* 1. Redistributions of source code must retain the above copyright notice, *) 11 | (* this list of conditions and the following disclaimer. *) 12 | (* *) 13 | (* 2. Redistributions in binary form must reproduce the above copyright *) 14 | (* notice, this list of conditions and the following disclaimer in the *) 15 | (* documentation and/or other materials provided with the distribution. *) 16 | (* *) 17 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 18 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 19 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 20 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 21 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 22 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 23 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 24 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 25 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 26 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 27 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 28 | (******************************************************************************) 29 | 30 | From Coq Require Import 31 | Strings.String. 32 | From Katamaran Require Import 33 | Base 34 | Semantics.Registers 35 | Syntax.FunDecl 36 | Syntax.Statements. 37 | 38 | Module Type FunDefKit (Import B : Base) (Import F : FunDecl B). 39 | Include RegStoreKit B. 40 | 41 | (* Step relation for calling an external function. The complete function call 42 | is done in one step. The result of an external call is either a failure 43 | with an error message msg (res = inl msg) or a successful computation with 44 | a result value v (res = inr v). 45 | *) 46 | Parameter ForeignCall : 47 | forall 48 | {Δ σ} (f : 𝑭𝑿 Δ σ) 49 | (args : CStore Δ) 50 | (res : string + Val σ) 51 | (γ γ' : RegStore) 52 | (μ μ' : Memory), Prop. 53 | Parameter ForeignProgress : 54 | forall {Δ σ} (f : 𝑭𝑿 Δ σ) (args : CStore Δ) γ μ, 55 | exists γ' μ' res, ForeignCall f args res γ γ' μ μ'. 56 | 57 | Parameter FunDef : forall {Δ τ} (f : 𝑭 Δ τ), Stm Δ τ. 58 | 59 | End FunDefKit. 60 | -------------------------------------------------------------------------------- /theories/Syntax/Messages.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2022 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Katamaran Require Import 30 | Context 31 | Prelude 32 | Symbolic.Instantiation 33 | Symbolic.OccursCheck 34 | Syntax.Terms 35 | Syntax.TypeDecl 36 | Syntax.Variables. 37 | 38 | Import ctx.notations. 39 | Import option.notations. 40 | 41 | Module Type MessagesOn 42 | (Import TY : Types) 43 | (Import TM : TermsOn TY) 44 | (Import IN : InstantiationOn TY TM) 45 | (Import OC : OccursCheckOn TY TM). 46 | 47 | #[local] Notation LCtx := (NCtx LVar Ty). 48 | 49 | Module amsg. 50 | Inductive CloseMessage (M : LCtx -> Type) (Σ : LCtx) : Type := 51 | | there {b} (msg : M (Σ ▻ b)). 52 | #[global] Arguments there {_ _ _} msg. 53 | 54 | (* Without the precedence, typeclass resolution sometimes mysteriously enters a loop... *) 55 | #[export] Instance subst_closemessage `{Subst M} : Subst (CloseMessage M) | 2 := 56 | fun {Σ} m {Σ2} ζ => 57 | match m with 58 | | there msg => there (subst msg (sub_up1 ζ)) 59 | end. 60 | 61 | #[export] Instance substlaws_closemessage `{SubstLaws M} : SubstLaws (CloseMessage M) | 2. 62 | Proof. 63 | constructor. 64 | - intros ? m. destruct m; cbn; f_equal; 65 | rewrite ?sub_up1_id; auto using subst_sub_id. 66 | - intros ? ? ? ? ? m. revert Σ1 ζ1 Σ2 ζ2. 67 | destruct m; cbn; intros; f_equal; 68 | rewrite ?sub_up1_comp; auto using subst_sub_comp. 69 | Qed. 70 | 71 | (* Without the precedence, typeclass resolution sometimes mysteriously enters a loop... *) 72 | #[export] Instance occurscheck_closemessage `{OccursCheck M} : OccursCheck (CloseMessage M) | 2 := 73 | fun {Σ x} xIn m => 74 | match m with 75 | | there msg => there <$> occurs_check (ctx.in_succ xIn) msg 76 | end. 77 | 78 | Inductive AMessage (Σ : LCtx) : Type := 79 | | mk {M} {subM : Subst M} {subLM : SubstLaws M} {occM: OccursCheck M} (msg : M Σ). 80 | #[global] Arguments mk {_ _ _ _ _} msg. 81 | 82 | Definition empty {Σ} : AMessage Σ := mk (M := Unit) tt. 83 | 84 | Fixpoint closeAux {Σ ΣΔ} {struct ΣΔ} : forall {M} {subM : Subst M} {subLM : SubstLaws M} {occM: OccursCheck M}, M (Σ ▻▻ ΣΔ) -> AMessage Σ := 85 | match ΣΔ with 86 | | [] => fun _ _ _ _ msg => mk msg 87 | | ΣΔ ▻ b => fun _ _ _ _ msg => closeAux (there msg) 88 | end%ctx. 89 | 90 | Definition close {Σ ΣΔ} (msg : AMessage (Σ ▻▻ ΣΔ)) : AMessage Σ := 91 | match msg with mk msg => closeAux msg end. 92 | 93 | #[export] Instance subst_amessage : Subst AMessage := 94 | fix sub {Σ} m {Σ2} ζ {struct m} := 95 | match m with 96 | | mk msg => mk (subst msg ζ) 97 | end. 98 | 99 | #[export] Instance substlaws_amessage : SubstLaws AMessage. 100 | Proof. 101 | constructor. 102 | - intros ? m. induction m; cbn; f_equal; 103 | rewrite ?sub_up1_id; auto using subst_sub_id. 104 | - intros ? ? ? ? ? m. revert Σ1 ζ1 Σ2 ζ2. 105 | induction m; cbn; intros; f_equal; 106 | rewrite ?sub_up1_comp; auto using subst_sub_comp. 107 | Qed. 108 | 109 | #[export] Instance occurscheck_amessage : OccursCheck AMessage := 110 | fix oc {Σ x} xIn m {struct m} := 111 | match m with 112 | | mk msg => mk <$> occurs_check xIn msg 113 | end. 114 | 115 | #[export] Instance instprop_amessage : InstProp AMessage := 116 | fun _ _ _ => True. 117 | 118 | #[export] Instance instpropsubst_amessage : InstPropSubst AMessage. 119 | Proof. easy. Qed. 120 | 121 | End amsg. 122 | Export amsg (AMessage). 123 | Export (hints) amsg. 124 | 125 | End MessagesOn. 126 | -------------------------------------------------------------------------------- /theories/Syntax/Predicates.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2020 Dominique Devriese, Georgy Lukyanov, *) 3 | (* Sander Huyghebaert, Steven Keuchel *) 4 | (* All rights reserved. *) 5 | (* *) 6 | (* Redistribution and use in source and binary forms, with or without *) 7 | (* modification, are permitted provided that the following conditions are *) 8 | (* met: *) 9 | (* *) 10 | (* 1. Redistributions of source code must retain the above copyright notice, *) 11 | (* this list of conditions and the following disclaimer. *) 12 | (* *) 13 | (* 2. Redistributions in binary form must reproduce the above copyright *) 14 | (* notice, this list of conditions and the following disclaimer in the *) 15 | (* documentation and/or other materials provided with the distribution. *) 16 | (* *) 17 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 18 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 19 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 20 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 21 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 22 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 23 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 24 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 25 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 26 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 27 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 28 | (******************************************************************************) 29 | 30 | From iris Require Import 31 | bi.interface. 32 | From Katamaran Require Import 33 | Context 34 | Environment 35 | Prelude 36 | Base. 37 | 38 | From Equations Require Import 39 | Equations. 40 | 41 | Class IsDuplicable (T : Type) := 42 | { is_duplicable : T -> bool 43 | }. 44 | 45 | Module Type PurePredicateKit (Import B : Base). 46 | (** Pure Predicates *) 47 | (* Predicate names. *) 48 | Parameter Inline 𝑷 : Set. 49 | (* Predicate field types. *) 50 | Parameter Inline 𝑷_Ty : 𝑷 -> Ctx Ty. 51 | Parameter Inline 𝑷_inst : forall p : 𝑷, env.abstract Val (𝑷_Ty p) Prop. 52 | 53 | #[export] Declare Instance 𝑷_eq_dec : EqDec 𝑷. 54 | 55 | End PurePredicateKit. 56 | 57 | Module Type HeapPredicateKit (Import B : Base). 58 | (** Heap Predicates *) 59 | (* Predicate names. *) 60 | Parameter Inline 𝑯 : Set. 61 | (* Predicate field types. *) 62 | Parameter Inline 𝑯_Ty : 𝑯 -> Ctx Ty. 63 | (* Duplicable? *) 64 | #[export] Declare Instance 𝑯_is_dup : IsDuplicable 𝑯. 65 | 66 | #[export] Declare Instance 𝑯_eq_dec : EqDec 𝑯. 67 | 68 | Parameter 𝑯_precise : forall p : 𝑯, option (Precise 𝑯_Ty p). 69 | 70 | End HeapPredicateKit. 71 | 72 | Module Type PredicateMixin (Import B : Base) (Import PP : PurePredicateKit B) (Import HP : HeapPredicateKit B). 73 | Class PredicateDef (HProp : bi) : Type := 74 | { lptsreg : forall {σ : Ty}, 𝑹𝑬𝑮 σ -> Val σ -> HProp; 75 | luser : forall (p : 𝑯), Env Val (𝑯_Ty p) -> HProp; 76 | lduplicate : forall (p : 𝑯) (ts : Env Val (𝑯_Ty p)), 77 | is_duplicable p = true -> 78 | @luser p ts ⊢ @luser p ts ∗ @luser p ts; 79 | }. 80 | Arguments luser {_ _} p _. 81 | End PredicateMixin. 82 | 83 | Module Type PredicateKit (B : Base) := 84 | PurePredicateKit B <+ HeapPredicateKit B <+ PredicateMixin B. 85 | 86 | Module DefaultPurePredicateKit (Import B : Base) <: PurePredicateKit B. 87 | 88 | Definition 𝑷 := Empty_set. 89 | Definition 𝑷_Ty : 𝑷 -> Ctx Ty := fun p => match p with end. 90 | Definition 𝑷_inst (p : 𝑷) : env.abstract Val (𝑷_Ty p) Prop := match p with end. 91 | #[export] Instance 𝑷_eq_dec : EqDec 𝑷 := fun p => match p with end. 92 | 93 | End DefaultPurePredicateKit. 94 | 95 | Module DefaultHeapPredicateKit (Import B : Base) <: HeapPredicateKit B. 96 | 97 | Definition 𝑯 := Empty_set. 98 | Definition 𝑯_Ty : 𝑯 -> Ctx Ty := fun p => match p with end. 99 | #[export] Instance 𝑯_eq_dec : EqDec 𝑯 := fun p => match p with end. 100 | #[export] Instance 𝑯_is_dup : IsDuplicable 𝑯 := { is_duplicable := fun p => match p with end }. 101 | Definition 𝑯_precise (p : 𝑯) : option (Precise 𝑯_Ty p) := None. 102 | 103 | End DefaultHeapPredicateKit. 104 | 105 | Module DefaultPredicateKit (B : Base) := 106 | DefaultPurePredicateKit B <+ DefaultHeapPredicateKit B. 107 | -------------------------------------------------------------------------------- /theories/Syntax/Registers.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2021 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Equations Require Import 30 | Equations. 31 | From Katamaran Require Import 32 | Prelude 33 | Tactics 34 | Syntax.TypeDecl. 35 | 36 | Local Set Implicit Arguments. 37 | 38 | Module Type RegDeclKit (Import T : Types). 39 | (* Names of registers. *) 40 | Parameter Inline 𝑹𝑬𝑮 : Ty -> Set. 41 | #[export] Declare Instance 𝑹𝑬𝑮_eq_dec : EqDec (sigT 𝑹𝑬𝑮). 42 | #[export] Declare Instance 𝑹𝑬𝑮_finite : finite.Finite (sigT 𝑹𝑬𝑮). 43 | End RegDeclKit. 44 | 45 | Module DefaultRegDeclKit (Import T : Types) <: RegDeclKit T. 46 | Definition 𝑹𝑬𝑮 : Ty -> Set := fun _ => Empty_set. 47 | #[export] Instance 𝑹𝑬𝑮_eq_dec : EqDec (sigT 𝑹𝑬𝑮) := sigma_eqdec _ _. 48 | 49 | Local Obligation Tactic := 50 | finite_from_eqdec. 51 | 52 | #[export,program] Instance 𝑹𝑬𝑮_finite : finite.Finite (sigT 𝑹𝑬𝑮) := 53 | {| finite.enum := nil |}. 54 | 55 | End DefaultRegDeclKit. 56 | -------------------------------------------------------------------------------- /theories/Syntax/UnOps.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2023 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Arith.PeanoNat 31 | ZArith.BinInt. 32 | From Equations Require Import 33 | Equations. 34 | From Katamaran Require Import 35 | Bitvector 36 | Context 37 | Prelude 38 | Syntax.TypeDecl. 39 | 40 | Import ctx.notations. 41 | 42 | Local Set Implicit Arguments. 43 | Local Set Transparent Obligations. 44 | 45 | Module uop. 46 | 47 | Import ty. 48 | 49 | Section WithTypeDecl. 50 | Context {TDC : TypeDeclKit}. 51 | 52 | Variant UnOp : Ty -> Ty -> Set := 53 | | inl {σ1 σ2 : Ty} : UnOp σ1 (sum σ1 σ2) 54 | | inr {σ1 σ2 : Ty} : UnOp σ2 (sum σ1 σ2) 55 | | neg : UnOp int int 56 | | not : UnOp bool bool 57 | | rev {σ} : UnOp (ty.list σ) (ty.list σ) 58 | | sext {m n} {p : IsTrue (m <=? n)} : UnOp (bvec m) (bvec n) 59 | | zext {m n} {p : IsTrue (m <=? n)} : UnOp (bvec m) (bvec n) 60 | | get_slice_int {n} : UnOp int (bvec n) 61 | | signed {n} : UnOp (bvec n) int 62 | | unsigned {n} : UnOp (bvec n) int 63 | | truncate {n} (m : nat) {p : IsTrue (m <=? n)} : UnOp (bvec n) (bvec m) 64 | | vector_subrange {n} (s l : nat) {p : IsTrue (s + l <=? n)} : UnOp (bvec n) (bvec l) 65 | | bvnot {n} : UnOp (bvec n) (bvec n) 66 | | bvdrop m {n} : UnOp (bvec (m + n)) (bvec n) 67 | | bvtake m {n} : UnOp (bvec (m + n)) (bvec m) 68 | | negate {n} : UnOp (bvec n) (bvec n). 69 | Set Transparent Obligations. 70 | Derive Signature for UnOp. 71 | Derive NoConfusion for UnOp. 72 | 73 | End WithTypeDecl. 74 | 75 | Section WithTypeDef. 76 | Context {TDC : TypeDeclKit}. 77 | Context {TDN : TypeDenoteKit TDC}. 78 | Context {TDF : TypeDefKit TDN}. 79 | 80 | #[local] Set Equations With UIP. 81 | 82 | Definition Tel (τ : Ty) : Set := 83 | sigma (fun σ : Ty => UnOp σ τ). 84 | 85 | Lemma eq_tel_bvdrop_inv {m1 m2 n} (H : m1 <> m2) : 86 | sigmaI (fun σ => UnOp σ (bvec n)) (bvec (m1 + n)) (bvdrop m1) <> 87 | sigmaI (fun σ => UnOp σ (bvec n)) (bvec (m2 + n)) (bvdrop m2). 88 | Proof. intros e%(f_equal pr1). cbn in e. depelim e. Lia.lia. Qed. 89 | 90 | Lemma eq_tel_bvtake_inv {m n1 n2} (H : n1 <> n2) : 91 | sigmaI (fun σ => UnOp σ (bvec m)) (bvec (m + n1)) (bvtake m) <> 92 | sigmaI (fun σ => UnOp σ (bvec m)) (bvec (m + n2)) (bvtake m). 93 | Proof. intros e%(f_equal pr1). cbn in e. depelim e. Lia.lia. Qed. 94 | 95 | Obligation Tactic := cbn; intros; 96 | try solve 97 | [eauto using eq_tel_bvdrop_inv, eq_tel_bvtake_inv 98 | |let e := fresh in intro e; depelim e; try easy; 99 | try progress cbn in * |-; congruence 100 | |subst; repeat f_equal; apply IsTrue.proof_irrelevance 101 | ]. 102 | 103 | #[derive(equations=no)] Equations tel_eq_dec {σ1 σ2 τ : Ty} 104 | (op1 : UnOp σ1 τ) (op2 : UnOp σ2 τ) : 105 | dec_eq (A := Tel τ) (sigmaI _ σ1 op1) (sigmaI _ σ2 op2) := 106 | | inl | inl => left eq_refl 107 | | inr | inr => left eq_refl 108 | | neg | neg => left eq_refl 109 | | not | not => left eq_refl 110 | | rev | rev => left eq_refl 111 | | @sext _ m1 ?(n) p1 | @sext _ m2 n p2 with eq_dec m1 m2 => { 112 | | left _ => left _ 113 | | right _ => right _ 114 | } 115 | | @zext _ m1 ?(n) p1 | @zext _ m2 n p2 with eq_dec m1 m2 => { 116 | | left _ => left _ 117 | | right _ => right _ 118 | } 119 | | get_slice_int | get_slice_int => left eq_refl 120 | | @unsigned _ m | @unsigned _ n with eq_dec m n => { 121 | | left _ => left _ 122 | | right _ => right _ 123 | } 124 | | @signed _ m | @signed _ n with eq_dec m n => { 125 | | left _ => left _ 126 | | right _ => right _ 127 | } 128 | | @truncate _ m1 ?(n) p1 | @truncate _ m2 n p2 with eq_dec m1 m2 => { 129 | | left _ => left _ 130 | | right _ => right _ 131 | } 132 | | @vector_subrange _ n1 s1 ?(l) p1 | @vector_subrange _ n2 s2 l p2 with eq_dec n1 n2, eq_dec s1 s2 => { 133 | | left _ | left _ => left _ 134 | | left _ | right _ => right _ 135 | | right _ | _ => right _ 136 | } 137 | | bvnot | bvnot => left eq_refl 138 | | bvdrop m1 | bvdrop m2 with eq_dec m1 m2 => { 139 | | left _ => left _ 140 | | right _ => right _ 141 | } 142 | | @bvtake _ ?(m) n1 | @bvtake _ m n2 with eq_dec n1 n2 => { 143 | | left _ => left _ 144 | | right _ => right _ 145 | } 146 | | negate | negate => left eq_refl 147 | | _ | _ => right _. 148 | 149 | #[local] Instance eq_dec_unop [σ1 σ2] : EqDec (UnOp σ1 σ2) := 150 | fun x y => 151 | match tel_eq_dec x y with 152 | | left e => left 153 | (* Uses decidable equality of Ty. *) 154 | (inj_right_sigma _ _ _ e) 155 | | right b => right (fun e => b (f_equal _ e)) 156 | end. 157 | 158 | Definition eval {σ1 σ2 : Ty} (op : UnOp σ1 σ2) : Val σ1 -> Val σ2 := 159 | match op in UnOp σ1 σ2 return Val σ1 -> Val σ2 with 160 | | inl => Datatypes.inl 161 | | inr => Datatypes.inr 162 | | rev => @List.rev (Val _) 163 | | neg => Z.opp 164 | | not => negb 165 | | sext => fun v => bv.sext v 166 | | zext => fun v => bv.zext v 167 | | get_slice_int => bv.of_Z 168 | | signed => fun v => bv.signed v 169 | | unsigned => fun v => bv.unsigned v 170 | | truncate m => fun v => bv.truncate m v 171 | | vector_subrange s l => bv.vector_subrange s l 172 | | bvnot => bv.not 173 | | bvdrop m => bv.drop m 174 | | bvtake m => bv.take m 175 | | negate => bv.negate 176 | end. 177 | 178 | End WithTypeDef. 179 | #[export] Existing Instance eq_dec_unop. 180 | 181 | End uop. 182 | #[export] Existing Instance uop.eq_dec_unop. 183 | Export uop (UnOp). 184 | -------------------------------------------------------------------------------- /theories/Syntax/Variables.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2021 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import 30 | Strings.String. 31 | 32 | From Equations Require Import 33 | Equations. 34 | 35 | From Katamaran Require Export 36 | Context Prelude. 37 | 38 | Local Set Implicit Arguments. 39 | 40 | Class VarKit : Type := 41 | { (* Program variable names. *) 42 | PVar : Set; 43 | (* For name resolution we rely on decidable equality of program variables. 44 | The functions in this module resolve to the closest binding of an equal 45 | name and fill in the de Bruijn index automatically from a successful 46 | resolution. *) 47 | PVar_eq_dec : EqDec PVar; 48 | 49 | (* Names of logic variables. These represent immutable variables standing 50 | for concrete value. *) 51 | LVar : Set; 52 | LVar_eq_dec : EqDec LVar; 53 | 54 | (* Conversion of program variables to logic variables. *) 55 | PVartoLVar : PVar -> LVar; 56 | 57 | (* Generation of program variable names that is fresh for a given context 58 | and that tries to reuse an optional old name. *) 59 | fresh_pvar : forall T, NCtx PVar T -> option PVar -> PVar; 60 | 61 | (* Generation of logic variable names that is fresh for a given context 62 | and that tries to reuse an optional old name. *) 63 | fresh_lvar : forall T, NCtx LVar T -> option LVar -> LVar; 64 | }. 65 | #[export] Existing Instance PVar_eq_dec. 66 | #[export] Existing Instance LVar_eq_dec. 67 | 68 | Definition DefaultVarKit : VarKit := 69 | {| PVar := string; 70 | PVar_eq_dec := string_dec; 71 | LVar := string; 72 | LVar_eq_dec := string_dec; 73 | PVartoLVar x := x; 74 | fresh_pvar := ctx.fresh; 75 | fresh_lvar := ctx.fresh; 76 | |}. 77 | -------------------------------------------------------------------------------- /theories/Tactics.v: -------------------------------------------------------------------------------- 1 | (******************************************************************************) 2 | (* Copyright (c) 2019 Steven Keuchel *) 3 | (* All rights reserved. *) 4 | (* *) 5 | (* Redistribution and use in source and binary forms, with or without *) 6 | (* modification, are permitted provided that the following conditions are *) 7 | (* met: *) 8 | (* *) 9 | (* 1. Redistributions of source code must retain the above copyright notice, *) 10 | (* this list of conditions and the following disclaimer. *) 11 | (* *) 12 | (* 2. Redistributions in binary form must reproduce the above copyright *) 13 | (* notice, this list of conditions and the following disclaimer in the *) 14 | (* documentation and/or other materials provided with the distribution. *) 15 | (* *) 16 | (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) 17 | (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) 18 | (* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) 19 | (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR *) 20 | (* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *) 21 | (* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *) 22 | (* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *) 23 | (* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) 24 | (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *) 25 | (* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *) 26 | (* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) 27 | (******************************************************************************) 28 | 29 | From Coq Require Import Bool.Bool PeanoNat. 30 | From Equations Require Import Equations. 31 | From stdpp Require base decidable finite list. 32 | From Katamaran Require Import Context Environment Prelude. 33 | 34 | (* Extract the head of a term. 35 | from http://poleiro.info/posts/2018-10-15-checking-for-constructors.html 36 | *) 37 | Ltac head t := 38 | match t with 39 | | ?t' _ => head t' 40 | | _ => t 41 | end. 42 | 43 | Ltac constructor_congruence := 44 | repeat 45 | match goal with 46 | | H: ?x = ?y |- _ => 47 | let hx := head x in 48 | let hy := head y in 49 | is_constructor hx; is_constructor hy; 50 | dependent elimination H 51 | | |- ?x = ?y => 52 | let hx := head x in 53 | let hy := head y in 54 | is_constructor hx; is_constructor hy; 55 | f_equal 56 | end. 57 | 58 | Ltac solve_eqb_spec' tac := 59 | repeat 60 | (intros; try progress cbn in *; 61 | match goal with 62 | | H: ?x <> ?x |- _ => congruence 63 | | |- _ <> _ => intro 64 | | |- ?x = ?x => reflexivity 65 | | |- @eq Datatypes.unit ?x ?y => 66 | try (is_var x; destruct x); 67 | try (is_var y; destruct y); 68 | reflexivity 69 | | |- reflect _ true => constructor 70 | | |- reflect _ false => constructor 71 | | H: ?x = ?y |- _ => 72 | let hx := head x in 73 | let hy := head y in 74 | is_constructor hx; is_constructor hy; 75 | dependent elimination H 76 | | |- context[eq_dec ?x ?y] => destruct (eq_dec x y); subst 77 | | |- context[eq_dec_het ?x ?y] => destruct (eq_dec_het x y); subst 78 | | H : forall y, reflect _ (?eq ?x y) |- context[?eq ?x ?y] => 79 | destruct (H y) 80 | | H : forall x y, reflect _ (?eq x y) |- context[?eq ?x ?y] => 81 | destruct (H x y) 82 | | [ H : reflect _ ?b |- context[?b] ] => 83 | let H1 := fresh in destruct H as [H1 |]; [dependent elimination H1 | idtac] 84 | | e : ?x = ?y |- context[eq_rect ?x _ _ ?y ?e] => destruct e; cbn 85 | | p: @ctx.nth_is ?B ?Γ ?n ?b, q: @ctx.nth_is ?B ?Γ ?n ?b |- _ => 86 | pose proof (@ctx.proof_irrelevance_nth_is B _ Γ n b p q); subst 87 | | |- context[ctx.In_eqb ?x ?y] => destruct (ctx.In_eqb_spec x y); subst 88 | | |- context[Nat.eqb ?x ?y] => destruct (Nat.eqb_spec x y); subst 89 | | |- _ => tac; subst; cbn 90 | end; 91 | rewrite ?andb_true_r, ?andb_false_r); 92 | try progress cbn in *; 93 | try congruence. 94 | 95 | Ltac solve_eqb_spec := solve_eqb_spec' idtac. 96 | 97 | Tactic Notation "solve_eqb_spec" "with" tactic(tac) := 98 | solve_eqb_spec' tac. 99 | 100 | Ltac destruct_propositional H := 101 | lazymatch type of H with 102 | | _ /\ _ => 103 | let H1 := fresh "H1" in 104 | let H2 := fresh "H2" in 105 | destruct H as [H1 H2]; 106 | destruct_propositional H1; 107 | destruct_propositional H2 108 | | _ \/ _ => 109 | destruct H as [H|H]; 110 | destruct_propositional H 111 | | exists _, _ => 112 | let x := fresh in 113 | destruct H as [x H]; 114 | destruct_propositional H 115 | | _ => idtac 116 | end. 117 | 118 | (* Adopted from 119 | https://softwarefoundations.cis.upenn.edu/plf-current/LibTactics.html 120 | *) 121 | Ltac check_noevar M := 122 | first [ has_evar M; fail 1 | idtac ]. 123 | Ltac check_noevar_hyp H := 124 | let T := type of H in check_noevar T. 125 | 126 | (* This tactic instantiates a hypothesis with fresh unification variables, 127 | possibly solving some on the fly. 128 | Adopted from CPDT: http://adam.chlipala.net/cpdt/html/Match.html 129 | *) 130 | Ltac inster_gen H tac := 131 | match type of H with 132 | | forall x : ?T, _ => 133 | match type of T with 134 | | Prop => 135 | (let H' := fresh "H'" in 136 | assert (H' : T) by solve [ tac ]; 137 | specialize (H H'); clear H'; 138 | first [ check_noevar_hyp H | inster_gen H tac ]) 139 | || fail 1 140 | | _ => 141 | let x := fresh "x" in 142 | evar (x : T); 143 | let x' := eval unfold x in x in 144 | clear x; specialize (H x'); 145 | first [ check_noevar_hyp H | inster_gen H tac ] 146 | end 147 | end. 148 | 149 | Ltac inster_loop H tac := 150 | repeat 151 | (inster_gen H tac; 152 | check_noevar_hyp H). 153 | 154 | Tactic Notation "inster" constr(H) "by" tactic(tac) := 155 | inster_loop H tac. 156 | -------------------------------------------------------------------------------- /theories/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Katamaran) 3 | (package coq-katamaran)) 4 | 5 | (include_subdirs qualified) 6 | --------------------------------------------------------------------------------