From 78460fa18045bad55ae1ca6ee3604ef4939b1fc1 Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Mon, 13 Nov 2023 10:30:54 +0100 Subject: [PATCH] Initial commit --- .github/workflows/docker-image.yml | 19 + .gitignore | 13 + Dockerfile | 29 + INSTALL.md | 106 + README.md | 111 + coq-iris-axiomatic-arm.opam | 36 + dune-project | 30 + system-semantics/Common/CBase.v | 205 ++ system-semantics/Common/CBitvector.v | 547 ++++ system-semantics/Common/CBool.v | 98 + system-semantics/Common/CInduction.v | 140 + system-semantics/Common/CList.v | 331 +++ system-semantics/Common/CMaps.v | 199 ++ system-semantics/Common/CSets.v | 244 ++ system-semantics/Common/Common.v | 149 + system-semantics/Common/Exec.v | 649 +++++ system-semantics/Common/GRel.v | 890 ++++++ system-semantics/Common/README.md | 15 + system-semantics/Common/_CoqProject | 1 + system-semantics/Common/dune | 23 + system-semantics/INSTALL.md | 17 + system-semantics/ISASem/ArmInst.v | 106 + system-semantics/ISASem/Interface.v | 303 ++ system-semantics/ISASem/README.md | 4 + system-semantics/ISASem/SailArmInstTypes.v | 1091 +++++++ system-semantics/ISASem/dune | 24 + system-semantics/LICENSE | 36 + system-semantics/coq-system-semantics.opam | 25 + system-semantics/dune | 3 + system-semantics/dune-project | 2 + theories/CandidateExecutions.v | 1033 +++++++ theories/algebra/base.v | 116 + theories/algebra/ghost_map_ag.v | 156 + theories/algebra/lib/gmap_view_ag.v | 391 +++ theories/algebra/mono_pg.v | 233 ++ theories/cmra.v | 5 + theories/dune | 17 + theories/examples/co/corr.v | 221 ++ theories/examples/co/coww.v | 187 ++ theories/examples/isa2/isa2.v | 317 +++ theories/examples/lb/adequacy.v | 189 ++ theories/examples/lb/ctrls.v | 315 +++ theories/examples/lb/data_data1.v | 145 + theories/examples/lb/data_data2.v | 197 ++ theories/examples/lb/data_dmbsy.v | 212 ++ theories/examples/mp/rel_acq.v | 190 ++ theories/examples/mp/rel_addr.v | 177 ++ theories/examples/mp/rel_ctrl.v | 240 ++ theories/examples/mp/rel_dmb.v | 197 ++ theories/examples/try_lock/implementation.v | 252 ++ theories/examples/try_lock/mutual_exclusion.v | 844 ++++++ theories/iris_extra.v | 171 ++ theories/lang/instrs.v | 149 + theories/lang/machine.v | 55 + theories/lang/mm.v | 2506 +++++++++++++++++ theories/lang/opsem.v | 1167 ++++++++ theories/low/adequacy.v | 630 +++++ theories/low/instantiation.v | 1320 +++++++++ theories/low/interp_mod.v | 307 ++ theories/low/iris.v | 23 + theories/low/lib/annotations.v | 494 ++++ theories/low/lib/edge.v | 337 +++ theories/low/lib/event.v | 179 ++ theories/low/lifting.v | 457 +++ theories/low/rules/announce.v | 63 + theories/low/rules/barrier.v | 188 ++ theories/low/rules/prelude.v | 134 + theories/low/rules/read.v | 631 +++++ theories/low/rules/reg.v | 129 + theories/low/rules/util.v | 71 + theories/low/rules/write.v | 181 ++ theories/low/rules/write_xcl.v | 308 ++ theories/low/weakestpre.v | 835 ++++++ theories/middle/excl.v | 96 + theories/middle/instantiation.v | 260 ++ theories/middle/rules.v | 1069 +++++++ theories/middle/specialised_rules.v | 634 +++++ theories/middle/weakestpre.v | 539 ++++ theories/stdpp_extra.v | 375 +++ 79 files changed, 24388 insertions(+) create mode 100644 .github/workflows/docker-image.yml create mode 100644 .gitignore create mode 100644 Dockerfile create mode 100644 INSTALL.md create mode 100644 README.md create mode 100644 coq-iris-axiomatic-arm.opam create mode 100644 dune-project create mode 100644 system-semantics/Common/CBase.v create mode 100644 system-semantics/Common/CBitvector.v create mode 100644 system-semantics/Common/CBool.v create mode 100644 system-semantics/Common/CInduction.v create mode 100644 system-semantics/Common/CList.v create mode 100644 system-semantics/Common/CMaps.v create mode 100644 system-semantics/Common/CSets.v create mode 100644 system-semantics/Common/Common.v create mode 100644 system-semantics/Common/Exec.v create mode 100644 system-semantics/Common/GRel.v create mode 100644 system-semantics/Common/README.md create mode 100644 system-semantics/Common/_CoqProject create mode 100644 system-semantics/Common/dune create mode 100644 system-semantics/INSTALL.md create mode 100644 system-semantics/ISASem/ArmInst.v create mode 100644 system-semantics/ISASem/Interface.v create mode 100644 system-semantics/ISASem/README.md create mode 100644 system-semantics/ISASem/SailArmInstTypes.v create mode 100644 system-semantics/ISASem/dune create mode 100644 system-semantics/LICENSE create mode 100644 system-semantics/coq-system-semantics.opam create mode 100644 system-semantics/dune create mode 100644 system-semantics/dune-project create mode 100644 theories/CandidateExecutions.v create mode 100644 theories/algebra/base.v create mode 100644 theories/algebra/ghost_map_ag.v create mode 100644 theories/algebra/lib/gmap_view_ag.v create mode 100644 theories/algebra/mono_pg.v create mode 100644 theories/cmra.v create mode 100644 theories/dune create mode 100644 theories/examples/co/corr.v create mode 100644 theories/examples/co/coww.v create mode 100644 theories/examples/isa2/isa2.v create mode 100644 theories/examples/lb/adequacy.v create mode 100644 theories/examples/lb/ctrls.v create mode 100644 theories/examples/lb/data_data1.v create mode 100644 theories/examples/lb/data_data2.v create mode 100644 theories/examples/lb/data_dmbsy.v create mode 100644 theories/examples/mp/rel_acq.v create mode 100644 theories/examples/mp/rel_addr.v create mode 100644 theories/examples/mp/rel_ctrl.v create mode 100644 theories/examples/mp/rel_dmb.v create mode 100644 theories/examples/try_lock/implementation.v create mode 100644 theories/examples/try_lock/mutual_exclusion.v create mode 100644 theories/iris_extra.v create mode 100644 theories/lang/instrs.v create mode 100644 theories/lang/machine.v create mode 100644 theories/lang/mm.v create mode 100644 theories/lang/opsem.v create mode 100644 theories/low/adequacy.v create mode 100644 theories/low/instantiation.v create mode 100644 theories/low/interp_mod.v create mode 100644 theories/low/iris.v create mode 100644 theories/low/lib/annotations.v create mode 100644 theories/low/lib/edge.v create mode 100644 theories/low/lib/event.v create mode 100644 theories/low/lifting.v create mode 100644 theories/low/rules/announce.v create mode 100644 theories/low/rules/barrier.v create mode 100644 theories/low/rules/prelude.v create mode 100644 theories/low/rules/read.v create mode 100644 theories/low/rules/reg.v create mode 100644 theories/low/rules/util.v create mode 100644 theories/low/rules/write.v create mode 100644 theories/low/rules/write_xcl.v create mode 100644 theories/low/weakestpre.v create mode 100644 theories/middle/excl.v create mode 100644 theories/middle/instantiation.v create mode 100644 theories/middle/rules.v create mode 100644 theories/middle/specialised_rules.v create mode 100644 theories/middle/weakestpre.v create mode 100644 theories/stdpp_extra.v diff --git a/.github/workflows/docker-image.yml b/.github/workflows/docker-image.yml new file mode 100644 index 0000000..5cb1769 --- /dev/null +++ b/.github/workflows/docker-image.yml @@ -0,0 +1,19 @@ +name: Docker CI + +on: + push: + branches: [ "main" ] + pull_request: + branches: [ "main" ] + workflow_dispatch: + schedule: + - cron: 0 0 1 * * # once a month + +jobs: + build: + runs-on: ubuntu-latest + steps: + - name: Check out repos + uses: actions/checkout@v3 + - name: Build the Docker image + run: docker build . --file Dockerfile --tag axsl:$(date +%s) diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..443ccba --- /dev/null +++ b/.gitignore @@ -0,0 +1,13 @@ +_build/ +_opam/ +.vscode/ + +.*.aux +*.vo +*.vok +*.glob +*.v.b + +.lia.cache + +.DS_Store diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..3691afa --- /dev/null +++ b/Dockerfile @@ -0,0 +1,29 @@ +ARG BASE_TAG="latest" +FROM coqorg/coq:8.16.1-ocaml-4.14.1-flambda + +COPY --chown=coq . /artifact/axsl +WORKDIR /artifact + +# hadolint ignore=SC2046 +RUN sudo apt-get update && sudo apt-get install zlib1g-dev -y + +RUN eval $(opam env --set-switch) \ + && opam update -y -u \ + && opam config list && opam repo list && opam list \ + && opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git + +RUN git clone https://github.com/rems-project/coq-sail \ + && cd coq-sail \ + && git checkout aeca2c5 \ + && opam pin . -y + +RUN opam install axsl/. --deps-only -y + +RUN git clone https://github.com/tchajed/iris-named-props.git \ + && cd iris-named-props \ + && git checkout 327119f \ + && opam pin . -y + +RUN opam list \ + && cd axsl \ + && dune build --display short diff --git a/INSTALL.md b/INSTALL.md new file mode 100644 index 0000000..fa3fb41 --- /dev/null +++ b/INSTALL.md @@ -0,0 +1,106 @@ +# Building from scratch + +## Compiling the development with Docker + +We recommend compiling the development using Docker. To do this, + +1. Make sure you have [Docker](https://docs.docker.com/get-docker/) installed. +2. Run `docker build -t="axsl:popl" .` in the source code directory (which contains a `Dockerfile`) +to build the Docker image. + +The building process may take up to one hour, including installing dependencies and compilation. + +Optionally, you can follow this by executing `docker run -i -t axsl:popl` to start a container with +the freshly built image and access an interactive shell inside it. + +### Troubleshooting + +In order to build the development, you might have to increase the amount of +memory allocated to a running Docker container. For instructions, see +[here](https://stackoverflow.com/questions/44533319/how-to-assign-more-memory-to-docker-container). + +## Manually Installing with opam + +### Opam and ocaml + +All dependencies install instruction assume you can use `opam`. If needed, +instructions are available here: https://opam.ocaml.org/doc/Install.html. + +You need to add the coq opam repository for some of the dependencies: +``` +opam repo add coq-released https://coq.inria.fr/opam/released +``` + + +### Dune + +This project uses the dune build system. It can be installed with: +``` +opam install dune +``` + + +### Coq + +Install Coq `8.16.1` +``` +opam pin coq 8.16.1 +``` + +### Coq libraries + +#### Iris and stdpp + +You need to add the iris opam repository to install Iris and stdpp : +``` +opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git +``` + +This development uses a development version of Iris and stdpp: +``` +opam install coq-iris.dev.2023-08-11.1.81f394da -y +``` + +This development uses an unstable extension of `stdpp`: +``` +opam install coq-stdpp-unstable.dev.2023-08-03.3.4be5fd62 -y +``` + +#### iris-named-props + +This development uses a small Iris extension `iris-named-prop`. + +Clone it with +``` +git clone https://github.com/tchajed/iris-named-props.git +``` + +In the cloned directory, check out to the version that has been tested: +``` +git checkout 327119f +``` + +Install with opam: +``` +opam pin . -y +``` + + +#### Coq Record Update + +This repository use the Coq record update library. To install it do: +``` +opam install coq-record-update +``` + +#### Dependencies of system-semantics + +Install the libraries listed in `system-semantics/INSTALL.md` but not mentioned above + +### Build the development + +In the directory, run: + +``` +dune build +``` diff --git a/README.md b/README.md new file mode 100644 index 0000000..4ce5488 --- /dev/null +++ b/README.md @@ -0,0 +1,111 @@ +This repositary contains the artifact of POPL 2024 paper +"An axiomatic basis for computer programming on the relaxed Arm-A architecture: the AxSL Logic". + +## About the Artifact + +This artifact is a mechanised proof development that contains formalised definitions and proofs that +can be checked by the Coq proof assistant. It contains all the results presented in the paper. + +## Building the Project + +The project can be compiled using the OCaml building system `dune` with required denpendencies installed. +The building scripts are organised into `dune-project` and severnal `dune` files. + +Refer to `INSTALL.md` for more information on building it in a Docker environment or +manually. + +## Structure of the Development + +The Coq development is organised into two subdirectories. + +The `theories` directory contains the primary Coq development of the work, including: + +- `lang`: This directory contains definitions of instructions, the Arm memory model, and our opax +semantics. + - `lang/instrs.v` defines the semantics of instructions using the outcome interface. + - `lang/mm.v` (combined with `CandidateExecutions.v`) defines the (user) Arm memory model. + - `lang/opsem.v` defines the opax semantics. + +- `algebra`: This directory includes most of the ghost state constructions for the logical assertions +of `AxSL`. + +- `low`: This directory contains the definition of weakest preconditions, the soundness proof of +low-level proof rules, and the adequacy theorem. + - `low/weakestpre.v` defines the base weakest precondition that is parameterised by the implementation + of state interpretation. + - `low/instantiation.v` contains the instantiation of the base weakest precondition with a specific + state interpretation implementation. + - `low/rules/*.v` contain base proof rules and their soundness proofs. + - `low/lifting.v` and `low/adequacy.v` contain the adequacy proof with respect to the base weakest + precondition. + - `low/lib/annotations.v` contains the definitions of protocols and flow implications. + +- `middle`: This directory contains the proof rules for all microinstructions and abstraction layers. + - `middle/weakestpre.v` defines an abstraction layer based on low-level weakest preconditions. + - `middle/rules.v` contains proof rules for some instructions and their soundness proofs (utilising + the results of `low/rules/*.v`). + - `middle/excl.v` contains our solution for supporting exclusives. + - `middle/specialised_rules.v` contains proof rules for specific instructions used in verified examples + and their soundness proofs. + +- `examples`: This directory contains the examples. + - `examples/lb/` includes three variants of load-buffering and their proofs. + - `examples/mp/` contains four variants of message-passing and their proofs. + +The `system-semantics` directory contains the Coq infrastructure used to define and reason about +memory models, including: + +- `ISASem`: This directory contains the ISA semantics interface that models may use. + - `ISASem/Interface.v` defines the main concurrency interface. + - `ISASem/ArmInst.v` and `ISASem/SailArmInstTypes.v` together define the Arm instantiation of the + interface, which is used to define the Arm memory model. + +- `Common`: This directory contains standard-library-like features, support type definitions, and +automation helpers. + - `Common/GRel.v` contains an implementation of relations and operations for relation algebra. + + +## Reference for the Results of the Paper + +| § | Result(s) in paper | Location in code | Object(s) in code | Remarks/Diffs | +|---|--------------------------|----------------------------|------------------------------------------------------------|--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| +| 2 | Fig. 3 | `lang/mm.v` | Module `AAConsistent` | Consistency axioms are in the record `t`. | +| 3 | The splitting rule used in Fig. 7 | `low/rules/prelude.v` | `annot_split_iupd` | `↦ₐ` is the notation for tied assertions. | +| 4 | Fig. 8 | `lang/instrs.v` | Section `instructions` | `os` and `vr` are defined in `system-semantics-coq`. | +| | Fig. 9 | | Section `interpretation` | The outcome interface is from `system-semantics-coq`. `;;` corresponds to `>>=`. | +| | `Whole-system-execution` | `low/adequacy.v` | `tpsteps`, `tpstate_done`, `tp_state_init` | There is no formal definition of the rule; we instead only defined the premises. | +| | Fig. 10 | `lang/opsem.v` | Module `LThreadStep` | `t` of the module defines the reduction relation; see below for more. | +| | Graph `X` and Instruction memory `I` | | Module `GlobalState` | | +| | `H-mem-read` | | `TStepReadMem` | We use `⊆` instead of `=` for `addr` and `ctrl`; `po1` is handled differently in our formalisation. | +| | `H-reg-write` | | `TStepRegWrite` | `po1` is handled differently in our formalisation. | +| | `H-reload` | | `TStepReload` | `ts_is_done_instr` is omitted in the rule. | +| | `H-term` | | `TStepTerm` | `ts_is_done_thd` implements the last premise. | +| | `T` of `Ctd T` and `R` of `Done R` | | Module `ThreadState` | Field `ts.reqs` of record `t` corresponds to program `T.p`; `R` is the rest of the fields, except for that we have an extra `ts_rmw_pred` to handle exclusive; `iis_iid` and `iis_cntr` together correspond to `e`; `next-e` is inline; `e_{po}` is defined separately as `lls_pop` of `LogicalLocalState`. | +| | `Ctd T` and `Done R` | | Module `LThreadState` | Both take `ThreadState.t` in the code. | +| 5 | Protocol `Φ` | `low/instantiation.v` | Typeclass `UserProt` | The type `prot_t` is defined in `low/lib/annotations.v`. | +| | Fig. 11 | `middle/specialised_rules.v` | `mem_read_external` | Hoare triples are implemented in a continuation-passing style using `WP`: the preconditions are premises; the post conditions are in the continuation. The Coq definition is slightly more general: it does not have constraint `(2)`. Detailed correspondence can be found below. | +| | `(1) & (10) NoLocalWrites` | | `last_local_write` | | +| | `(3) & (11) PoPred` | | `o_po_src -{LPo}>` | | +| | `(4) & (12) CtrlPreds` | | `ctrl_srcs -{Ctrl}>` | | +| | `(5) & (13)` | | `([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv)` | `dep_regs` is `regs`. | +| | `(6)` | | `([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot)` | `lob_annot` is `m`. | +| | `(7) & (14) GraphFacts` | | `R_graph_facts` of `mem_read_external` | | +| | `(8) Lob` | | Lines between comments `Lob edge formers` and `FE` | | +| | `(9) FlowIn` | | Lines between comment `FE` and `continuation` | `={⊤}[∅]▷=∗` is the view shift that also supports invariants; `prot` (field of `UserProt`) is the protocol `Φ`. The persistent `R_graph_facts` are assumed again. | +| | `(15)` | | `eid ↦ₐ R addr val eid_w` | | +| | Fig. 13, 14 | `examples/lb/data_data2.v` | `instrs`, `userprot_val`, `write_val_thread_1`, `write_val_thread_2` | `instrs` is the LB program, `userprot_val` is `Φ`, and the remaining two are the specs and their proofs. | +| | Oneshot | `one_shot` | Section `one_shot` | | +| | Instruction Hoare triple | | `SSWPi` | Defined using single-step instruction weakest precondition `SSWPi`. | +| | Fig. 15 | | `wpi_pln_read`, `wpi_pln_write_data` | | +| | Fig. 16 | `examples/mp.v` | `send_instrs`, `dep_receive_instrs` | | +| | `Φ(flag,v,e)` | | `flag_prot` | | +| | The invariant for exclusives | `middle/excl.v` | `excl_inv` | | +| | Proof rules for exclusives | `middle/rules.v` | `mem_write_xcl_Some_inv`, `mem_write_xcl_None` | Again in the continuation-passing style. For successful and unsuccessful exclusive stores; Exclusive loads are handled in `mem_read_external` with extra machinery. | +| 6 | The microinstruction Hoare triple | `middle/weakestpre.v` | `wpi_def` | Defined using weakest preconditions, so `P` is not mentioned. The Coq definition (`WPi`) is actually a weakest precondition for instructions, not microinstructions, but the definition follows the same spirit as the presented microinstruction one. | +| | `SI-reg-agree` and `SI-reg-update` | | `reg_interp_agree`, `reg_interp_update` | | +| | Definition of weakest precondition | `low/weakestpre.v` | `wp_pre` | The formalisation in Coq is quite different -- the paper only demonstrates the key ideas. Most importantly: `annot_interp` is `SI_{T}`; `gconst_interp` is `SI_{G}`; `flow_eq` is `FlowImp`; `post_lifting` is `PullOutTied`. | +| | `FlowImp` | `low/lib/annotations.v` | `flow_eq_ea`, `na_splitting_wf` | `flow_eq_ea` is the view shift; `na_splitting_wf` is `Detach`; the map extension is inlined in `wp_pre`. | +| | Supporting framing | `low/instantiation.v` | `annot_split` | | +| | Supporting invariants | `low/lib/annotations.v` | `={⊤,∅}=∗ ▷ \|={∅,⊤}=>` of `flow_eq_ea` | Same as `={⊤}[∅]▷=∗`. | +| | Theorem 6.1 | `middle/rules.v`, `middle/specialised_rules.v`, `low/rules/*.v` | | `middle/rules.v` and `middle/specialised_rules.v` contain the soundness proof of all microinstruction proof rules (in continuation style, proved using results in `low/rules/*.v`). | +| | Theorem 6.2 | `low/adequacy.v` | `adequacy_pure` | With insignificant details omitted. | diff --git a/coq-iris-axiomatic-arm.opam b/coq-iris-axiomatic-arm.opam new file mode 100644 index 0000000..1c5f8e1 --- /dev/null +++ b/coq-iris-axiomatic-arm.opam @@ -0,0 +1,36 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +maintainer: ["Zongyuan Liu "] +authors: [ + "Zongyuan Liu " + "Angus Hammond " + "Jean Pichon-Pharabod " + "Thibaut Pérami " +] +homepage: "https://github.com/logsem/AxSL" +bug-reports: "https://github.com/logsem/AxSL/issues" +depends: [ + "dune" {>= "3.9"} + "coq" {= "8.16.1"} + "coq-record-update" {= "0.3.2"} + "coq-hammer-tactics" {= "1.3.2+8.16"} + "coq-stdpp" {= "dev.2023-08-03.3.4be5fd62"} + "coq-stdpp-unstable" {= "dev.2023-08-03.3.4be5fd62"} + "coq-iris" {= "dev.2023-08-11.1.81f394da"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/logsem/AxSL.git" diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..01b8518 --- /dev/null +++ b/dune-project @@ -0,0 +1,30 @@ +(lang dune 3.9) +(name coq-iris-axiomatic-arm) +(using coq 0.8) + +(generate_opam_files true) + +(authors + "Zongyuan Liu " + "Angus Hammond " + "Jean Pichon-Pharabod " + "Thibaut Pérami ") + +(maintainers + "Zongyuan Liu ") + +(source + (github logsem/AxSL)) + +(package + (name coq-iris-axiomatic-arm) + (allow_empty) + (depends + (coq (= 8.16.1)) + (coq-record-update (= 0.3.2)) + (coq-hammer-tactics (= "1.3.2+8.16")) + (coq-stdpp (= "dev.2023-08-03.3.4be5fd62")) + (coq-stdpp-unstable (= "dev.2023-08-03.3.4be5fd62")) + (coq-iris (= "dev.2023-08-11.1.81f394da")) + ) +) diff --git a/system-semantics/Common/CBase.v b/system-semantics/Common/CBase.v new file mode 100644 index 0000000..8556db3 --- /dev/null +++ b/system-semantics/Common/CBase.v @@ -0,0 +1,205 @@ + +From stdpp Require Export base. +From stdpp Require Export tactics. +Require Import DecidableClass. +Require Export Relations. +From RecordUpdate Require Export RecordSet. +From Hammer Require Export Tactics. +Require Import ZArith. + +#[export] Set Keyed Unification. + +(*** Notations ***) + + +(** Functional pipe notation. + + Currently parsing level is just below relation so + that a = b |> f will be parsed as a = (b |> f). *) +Notation "v |> f" := (f v) (at level 69, only parsing, left associativity). + +(** Monadic bind with an explicit monad annotation *) +Notation "x ←@{ M } y ; z" := (@mbind M _ _ _ (λ x : _, z) y) + (at level 20, y at level 100, z at level 200, only parsing) : stdpp_scope. +Notation "' x ←@{ M } y ; z" := (@mbind M _ _ _ (λ x : _, z) y) + (at level 20, x pattern, y at level 100, z at level 200, only parsing) : stdpp_scope. + + +(*** Utility functions ***) + +(** Convenient iff destruction *) +Definition iffLR {A B : Prop} (i : A <-> B) : A -> B := proj1 i. +Definition iffRL {A B : Prop} (i : A <-> B) : B -> A := proj2 i. + +(** Convert a true proposition into a rewriting rule of that proposition to true +*) +Definition Prop_for_rewrite {P : Prop} (H : P) : P <-> True. + firstorder. +Defined. + +Definition setv {R T} (proj : R -> T) {_ : Setter proj} ( v: T) : R -> R := + set proj (fun _ => v). + +(** This allows to use set fst and set snd on pairs *) +#[global] Instance eta_pair A B : Settable (A * B) := + settable! (fun (a : A) (b : B) => (a, b)) . + + +(*** Constrained quantifiers ***) + +Notation "∀' x ∈ b , P" := (∀ x, x ∈ b → P) + (at level 200, x binder, right associativity, + format "'[ ' '[ ' ∀' x ∈ b ']' , '/' P ']'") : type_scope. + +(* The formatting, doesn't work so this is still printed as exists x, x ∈ b ∧ P + but that's not really a problem *) +Notation "∃' x ∈ b , P" := (∃ x, x ∈ b ∧ P) + (at level 200, x binder, right associativity, + format "'[ ' '[ ' ∃' x ∈ b ']' , '/' P ']'") : type_scope. + + +(*** Relations ***) + +Arguments clos_refl_trans {_}. + + +(*** Utility tactics ***) + +Ltac block t := change t with (block t) in *. +Ltac unblock := unfold block in *. + +(* useful for debugging *) +Ltac deintro := + match goal with + | H : _ |- _ => generalize dependent H + end. +Ltac deintros := repeat deintro. +Ltac print_full_goal := try(deintros; match goal with |- ?G => idtac G end; fail). + +(* run tac on all hypotheses in first-to-last order *) +Ltac forall_hyps tac := + lazymatch goal with + | H : _ |- _ => revert H; try (forall_hyps tac); intro H; try(tac H) + end. + +(** Actual dependent rewrite by calling destruct on the equality. + The rewrite must be of the form var = exp where var is a plain variable and not + a complicated expression *) +Tactic Notation "drewrite" "<-" constr(H) := + match type of H with + | _ = _ => destruct H + end. +Tactic Notation "drewrite" "->" constr(H) := symmetry in H; drewrite <- H. +Tactic Notation "drewrite" constr(H) := drewrite -> H. + +(** Typeclass clean to help prove typeclasss lemmas *) +Ltac tcclean_hyp H := + lazymatch type of H with + | forall x y, @?P x y => + let tP := type of P in + let Q := mk_evar tP in + let Hb := fresh "H" in + rename H into Hb; + assert (forall x y, Q x y); + [intros x y; destruct (Hb x y) as [H]; exact H |]; + simpl in H; + clear Hb; + try(repeat (setoid_rewrite <- H || rewrite <- H)) + | forall z, @?P z => + let tP := type of P in + let Q := mk_evar tP in + let Hb := fresh "H" in + rename H into Hb; + assert (forall z, Q z); + [intro z; destruct (Hb z) as [H]; exact H |]; + simpl in H; + clear Hb; + try(repeat (setoid_rewrite <- H || rewrite <- H)) + | TCEq _ _ => rewrite TCEq_eq in H; try (setoid_rewrite H) + | Unconvertible _ _ _ => clear H + | TCFastDone _ => apply (@tc_fast_done _) in H + | _ => destruct H as [H]; try(repeat (setoid_rewrite <- H || rewrite <- H)) + end. + +Ltac tcclean := + repeat (let H := fresh "H" in intro H; try (tcclean_hyp H)); + constructor. + +(*** Integer lattice ***) + +(* n ⊔ n' means max and n ⊓ n' means min *) + +#[global] Instance join_nat : Join nat := Nat.max. +#[global] Instance meet_nat : Meet nat := Nat.min. +#[global] Instance join_pos : Join positive := Pos.max. +#[global] Instance meet_pos : Meet positive := Pos.min. +#[global] Instance join_N : Join N := N.max. +#[global] Instance meet_N : Meet N := N.min. +#[global] Instance join_Z : Join Z := Z.max. +#[global] Instance meet_Z : Meet Z := Z.min. + + +(*** Typeclass magic ***) + +Require Import Morphisms. +Import Morphisms.ProperNotations. +Require Import Coq.Classes.RelationClasses. +From stdpp Require Import sets. + +Opaque Unconvertible. + +Global Instance Unconvertible_proper A : + Proper ((=) ==> (=) ==> (=)) (Unconvertible A). +Proof. + unfold Proper. + solve_proper. +Qed. + +(* I don't want unfolding typeclasses such as SetUnfold to unfold an mbind ever *) +Global Typeclasses Opaque mbind. + +(* A variation of solve_proper that uses setoid_rewrite *) + +Ltac solve_proper2_core tac := + match goal with + | |- Proper _ _ => unfold Proper; solve_proper2_core tac + | |- respectful _ _ _ _ => + let H := fresh "h" in + intros ? ? H; solve_proper2_core tac; + let t := type of H in + try rewrite H in * + | |- _ => tac + end. + +(* For Proper of a typeclass in Prop (the last relation must be iff) + The tactic passed to core will see a goal of the form + TC arg1 arg2 ↔ TC arg1' arg2' *) +Ltac solve_proper2_tc := + solve_proper2_core ltac:(split; destruct 1; constructor); assumption. + +(* For Proper of an unfoldable function *) +Ltac solve_proper2_funcs := + solve_proper2_core solve_proper_unfold; reflexivity. + +Global Instance SetUnfold_proper : + Proper (iff ==> iff ==> iff) SetUnfold. +Proof. solve_proper2_tc. Qed. + +Global Instance SetUnfoldElemOf_proper `{ElemOf A C} : + Proper ((=@{A}) ==> (≡@{C}) ==> iff ==> iff) SetUnfoldElemOf. +Proof. solve_proper2_tc. Qed. + + + +(*** Generic hints ***) + +Lemma exists_pair B C P: + (exists x : C * B, P x) <-> exists x y, P (x, y). +Proof. hauto lq:on. Qed. +#[global] Hint Resolve <- exists_pair : core. +#[global] Hint Rewrite exists_pair : core. + +Lemma forall_pair B C (P : B * C -> Prop): + (forall x : B * C, P x) <-> forall x y, P (x, y). +Proof. hauto lq:on. Qed. +#[global] Hint Rewrite forall_pair : core. diff --git a/system-semantics/Common/CBitvector.v b/system-semantics/Common/CBitvector.v new file mode 100644 index 0000000..0a9b838 --- /dev/null +++ b/system-semantics/Common/CBitvector.v @@ -0,0 +1,547 @@ +(** Unfortunately this development needs to support two kinds of bitvector. + The module will attempt to provide smooth interoperability between the two *) + +Require Import Lia. +Require Export stdpp.unstable.bitvector. +Require Export stdpp.unstable.bitvector_tactics. +Require Export bbv.Word. +Require Import CBase. +Require Import CBool. +Require Import Coq.Logic.Eqdep. (* <- This assumes UIP *) + +From Hammer Require Import Tactics. + + +(*** Dependent types stuff ***) + +Lemma symmetry_symmetry {A} (x y : A) (e : x = y) : + symmetry (symmetry e) = e. +Proof. sfirstorder. Qed. +#[global] Hint Rewrite @symmetry_symmetry : core. + +Section Transport. + Context {A : Type}. + Context (P : A -> Type). + + (* I love dependent types /s *) + Definition transport {x y : A} (e : x = y) (t : P x) : P y := + match e with + | eq_refl => t + end. + + (* This equivalent to eq_rect_eq which is itself equivalent to UIP *) + Lemma transport_simpl {x} (e : x = x) (t : P x) : + transport e t = t. + Proof. + unfold transport. + rewrite (eq_rect_eq A x P t e) at 2. (* <- This is where UIP is used *) + unfold eq_rect. + reflexivity. + Qed. + + Lemma transport_eq_trans {x y z} (e : x = y) (e' : y = z) (t : P x) : + t |> transport e |> transport e' = t |> transport (eq_trans e e'). + Proof. sfirstorder. Qed. + + Lemma transport_symmetry {x y : A} (e : x = y) (a : P x) (b : P y) : + a = transport (symmetry e) b <-> transport e a = b. + Proof. sfirstorder. Qed. + + Lemma transport_eq_dep {x y : A} (a : P x) (b : P y) : + eq_dep A P x a y b <-> exists e : y = x, a = transport e b. + Proof. + split. + - unfold transport. + destruct 1. + exists eq_refl. + reflexivity. + - destruct 1 as [e H]. + destruct e. + unfold transport in H. + rewrite H. + constructor. + Qed. + + Lemma transport_fdep (f : forall A, P A) {x y : A} (e : x = y) : + f y = transport e (f x). + Proof. hauto use:transport_simpl. Qed. + +End Transport. +Arguments transport_fdep {_ _} _ {_ _}. + +Ltac transport_symmetry := + lazymatch goal with + | |- ?a = transport ?P ?e ?b => symmetry; apply transport_symmetry; symmetry + | |- transport ?P ?e ?a = ?b => apply transport_symmetry + end. + +#[global] Hint Rewrite @transport_simpl : transport. +#[global] Hint Rewrite @transport_eq_trans : transport. + +Lemma transport_func {A B} {P : A -> Type} {x y : A} (e : x = y) (b : B) + (f : B -> P x) + : (transport (fun x : A => B -> P x) e f) b = transport P e (f b). +Proof. + hauto db:transport. +Qed. +#[global] Hint Rewrite @transport_func : transport. + + + +(*** Arithmetic helper stuff ***) + +(* Makes lia able to handle euclidean division, which makes bv_solve, + bv_solve' and bv_word_solve able to handle concat and extract *) +Ltac Zify.zify_convert_to_euclidean_division_equations_flag ::= constr:(true). + +(* These need to be easily available to create equalities directly in Gallina *) +Arguments N2Nat.id {_}. +Arguments Nat2N.id {_}. + +Lemma eq_N_to_nat {n m : N} : + n = m -> N.to_nat n = N.to_nat m. +Proof. lia. Qed. + +Lemma eq_nat_to_N {n m : nat} : + n = m -> N.of_nat n = N.of_nat m. +Proof. lia. Qed. + + +(* The arith rewrite database helps simplify arithmetic *) +#[global] Hint Rewrite N_nat_Z : arith. +#[global] Hint Rewrite nat_N_Z : arith. +#[global] Hint Rewrite @N2Nat.id : arith. +#[global] Hint Rewrite @Nat2N.id : arith. +(* #[global] Hint Rewrite @Zmod_mod : arith. *) + + +(* Reduce concrete arithmetic values to help lia. This is a tactic from stdpp bitvector + that is redefined so it will also affect development done there*) +Ltac reduce_closed_N ::= + reduce_closed_N_tac; + repeat match goal with + | |- context [Pos.to_nat ?a] => progress reduce_closed (Pos.to_nat a) + | H: context [Pos.to_nat ?a] |- _ => progress reduce_closed (Pos.to_nat a) + | |- context [N.to_nat ?a] => progress reduce_closed (N.to_nat a) + | H: context [N.to_nat ?a] |- _ => progress reduce_closed (N.to_nat a) + | |- context [N.of_nat ?a] => progress reduce_closed (N.of_nat a) + | H: context [N.of_nat ?a] |- _ => progress reduce_closed (N.of_nat a) + | |- context [Z.to_nat ?a] => progress reduce_closed (Z.to_nat a) + | H: context [Z.to_nat ?a] |- _ => progress reduce_closed (Z.to_nat a) + | |- context [Z.of_nat ?a] => progress reduce_closed (Z.of_nat a) + | H: context [Z.of_nat ?a] |- _ => progress reduce_closed (Z.of_nat a) + | |- context [N.add ?a ?b] => progress reduce_closed (N.add a b) + | H : context [N.add ?a ?b] |- _ => progress reduce_closed (N.add a b) + end. + +Ltac simplify_arith := + reduce_closed_N; + (try rewrite_strat topdown hints arith); + repeat match goal with + | H : _ |- _ => progress rewrite_strat topdown hints arith in H + end. + + +(*** Bitvector decision ***) + +(* Interface Equality decision for words (from bbv) *) +Global Instance word_eq_dec n : EqDecision (word n). +Proof. + unfold EqDecision. + unfold Decision. + apply weq. +Defined. + +(* This is already instanciated for bv *) + +(*** word rewrite database ***) + +(* The word database simplifies word related expressions *) + +#[global] Hint Rewrite @uwordToZ_ZToWord using unfold bv_modulus in *;lia : word. +#[global] Hint Rewrite @ZToWord_uwordToZ : word. + +Lemma transport_ZToWord {n m : nat} (e : n = m) (z : Z) : + transport word e (ZToWord n z) = ZToWord m z. +Proof. scongruence. Qed. +#[global] Hint Rewrite @transport_ZToWord : word. + +Lemma transport_uwordToZ (n m : nat) (w : word n) (e : n = m): + uwordToZ (transport word e w) = uwordToZ w. +Proof. scongruence. Qed. +#[global] Hint Rewrite transport_uwordToZ : word. + +Lemma transport_wordToZ (n m : nat) (w : word n) (e : n = m): + wordToZ (transport word e w) = wordToZ w. +Proof. scongruence. Qed. +#[global] Hint Rewrite transport_wordToZ : word. + +Lemma transport_wordToN (n m : nat) (w : word n) (e : n = m): + wordToN (transport word e w) = wordToN w. +Proof. scongruence. Qed. +#[global] Hint Rewrite transport_wordToN : word. + + +(* Do a transport_symmetry only if it enables immediate progress on + either side of the equality *) +Ltac transport_symmetry_word := + transport_symmetry; rewrite_strat subterm hints word. + +(*** bv rewrite database ***) + +Lemma bv_wrap_bv_unsigned' {n m} (b : bv m) : + n = m -> bv_wrap n (bv_unsigned b) = bv_unsigned b. +Proof. intro H. rewrite H. apply bv_wrap_bv_unsigned. Qed. +#[global] Hint Rewrite @bv_wrap_bv_unsigned' using lia : bv. + +Lemma bv_wrap_uwordToZ {n m} (w : word m) : + n = N.of_nat m -> bv_wrap n (uwordToZ w) = uwordToZ w. +Proof. + intro H. + rewrite bv_wrap_small. + - reflexivity. + - use uwordToZ_bound. + unfold bv_modulus. + sauto lq:on. +Qed. +#[global] Hint Rewrite @bv_wrap_uwordToZ using lia : bv. + +#[global] Hint Rewrite Z_to_bv_small + using unfold bv_modulus in *; lia : bv. +#[global] Hint Rewrite bv_wrap_small + using unfold bv_modulus in *; lia : bv. +#[global] Hint Rewrite bv_wrap_bv_wrap using lia : bv. +#[global] Hint Rewrite bv_extract_concat_here using lia : bv. +#[global] Hint Rewrite bv_extract_concat_later using lia : bv. +#[global] Hint Rewrite Z_to_bv_unsigned : bv. +#[global] Hint Rewrite Z_to_bv_bv_unsigned : bv. + + +Lemma transport_Z_to_bv {n m : N} (e : n = m) (z : Z) : + transport bv e (Z_to_bv n z) = Z_to_bv m z. +Proof. scongruence. Qed. +#[global] Hint Rewrite @transport_Z_to_bv : bv. +#[global] Hint Rewrite @transport_Z_to_bv : bv_simplify. + +Lemma transport_bv_unsigned (n m i l : N) (b : bv n) (e : n = m): + bv_unsigned (transport bv e b) = bv_unsigned b. +Proof. scongruence. Qed. +#[global] Hint Rewrite transport_bv_unsigned : bv. +#[global] Hint Rewrite transport_bv_unsigned : bv_simplify. + +Lemma transport_bv_extract1 (n m i l : N) (b : bv n) (e : n = m): + bv_extract i l (transport bv e b) = bv_extract i l b. +Proof. scongruence. Qed. +#[global] Hint Rewrite transport_bv_extract1 : bv. +#[global] Hint Rewrite transport_bv_extract1 : bv_simplify. + +Lemma transport_bv_extract2 (n i l l' : N) (b : bv n) (e : l = l'): + transport bv e (bv_extract i l b) = bv_extract i l' b. +Proof. scongruence. Qed. +#[global] Hint Rewrite transport_bv_extract2 : bv. +#[global] Hint Rewrite transport_bv_extract2 : bv_simplify. + +Ltac transport_symmetry_bv := + transport_symmetry; rewrite_strat subterm hints bv. + + + +(*** bv to word and back conversions ***) + +Definition bv_to_word {n} (b : bv n) : word (N.to_nat n) := + ZToWord (N.to_nat n) (bv_unsigned b). + +Definition word_to_bv {n} (b : word n) : bv (N.of_nat n) := + Z_to_bv (N.of_nat n) (uwordToZ b). + + +Lemma word_to_bv_to_word' {n} (b : word n) : + b |> word_to_bv |> bv_to_word |> transport word Nat2N.id = b. +Proof. + unfold word_to_bv, bv_to_word. + sauto lq:on db:bv,word use:uwordToZ_bound. +Qed. +#[global] Hint Rewrite @word_to_bv_to_word' : word. + +Lemma word_to_bv_to_word {n} (b : word n) : + b |> word_to_bv |> bv_to_word = transport word (symmetry Nat2N.id) b. +Proof. + transport_symmetry. + autorewrite with core word. + reflexivity. +Qed. +#[global] Hint Rewrite @word_to_bv_to_word : word. + +Lemma bv_to_word_to_bv' {n} (b : bv n) : + b |> bv_to_word |> word_to_bv |> transport bv N2Nat.id = b. +Proof. + unfold word_to_bv. unfold bv_to_word. + hauto lq:on db:bv,word,arith use:bv_unsigned_in_range. +Qed. +#[global] Hint Rewrite @bv_to_word_to_bv' : bv. + +Lemma bv_to_word_to_bv {n} (b : bv n) : + b |> bv_to_word |> word_to_bv = transport bv (symmetry N2Nat.id) b. +Proof. + transport_symmetry. + autorewrite with core bv. + reflexivity. +Qed. +#[global] Hint Rewrite @bv_to_word_to_bv : bv. +#[global] Hint Rewrite @bv_to_word_to_bv : bv_simplify. + + +Lemma transport_word_to_bv (n m : nat) (w : word n) (e : n = m): + word_to_bv (transport word e w) = transport bv (eq_nat_to_N e) (word_to_bv w). +Proof. + unfold word_to_bv. + autorewrite with bv word. + reflexivity. +Qed. +#[global] Hint Rewrite transport_word_to_bv : bv. + + +(* Doing `rewrite bv_to_word_to_bv` sometimes fails, if bitvector size are + too concrete, this tactic perform the rewrite anyway *) +Ltac bv_to_word_to_bv := + match goal with + | |- context C [@word_to_bv ?m (@bv_to_word ?n ?b)] => + let H := fresh "H" in + assert_succeeds (enough (H : m = N.to_nat n);[| reflexivity]); + let nG := context C [@word_to_bv (N.to_nat n) (@bv_to_word n b)] in + let G := fresh "G" in + enough (G : nG);[exact G| rewrite bv_to_word_to_bv] + | Hyp : context C [@word_to_bv ?m (@bv_to_word ?n ?b)] |- _ => + let H := fresh "H" in + assert_succeeds (enough (H : m = N.to_nat n);[| reflexivity]); + let nG := context C [@word_to_bv (N.to_nat n) (@bv_to_word n b)] in + let G := fresh "G" in + rename Hyp into G; + assert (Hyp : nG); + [assumption | clear G; rewrite bv_to_word_to_bv in Hyp] + end. + +(* Doing `rewrite word_to_bv_to_word` sometimes fails, if bitvector size are + too concrete, this tactic perform the rewrite anyway *) +Ltac word_to_bv_to_word := + match goal with + | |- context C [@bv_to_word ?m (@word_to_bv ?n ?w)] => + let H := fresh "H" in + assert_succeeds (enough (H : m = N.of_nat n);[| reflexivity]); + let nG := context C [@bv_to_word (N.of_nat n) (@word_to_bv n w)] in + let G := fresh "G" in + enough (G : nG);[exact G| rewrite word_to_bv_to_word] + | Hyp : context C [@bv_to_word ?m (@word_to_bv ?n ?w)] |- _ => + let H := fresh "H" in + assert_succeeds (enough (H : m = N.of_nat n);[| reflexivity]); + let nG := context C [@bv_to_word (N.of_nat n) (@word_to_bv n w)] in + let G := fresh "G" in + rename Hyp into G; + assert (Hyp : nG); + [assumption | clear G; rewrite word_to_bv_to_word in Hyp] + end. + +(*** Convert a mixed bv + word goal into a pure bv goal ***) + +Lemma word_to_bv_eq {n : nat} (w w' : word n) : + word_to_bv w = word_to_bv w' <-> w = w'. +Proof. + split. + + unfold word_to_bv. + intro H. + apply (f_equal bv_unsigned) in H. + hauto db:bv use:ZToWord_uwordToZ. + + scongruence. +Qed. + +Lemma word_to_bv_neq {n : nat} (w w' : word n) : + word_to_bv w ≠ word_to_bv w' <-> w ≠ w'. +Proof. rewrite word_to_bv_eq. reflexivity. Qed. + + +(* Replace the variable w of type by an equivalent variable of type bv *) +Ltac remove_word_var w := + let w2 := fresh "w" in + rename w into w2; + rewrite <- (word_to_bv_to_word' w2) in *; + set (w := word_to_bv w2) in *; + clearbody w; + clear w2; + autorewrite with bv word transport in *; + reduce_closed_N. + +(* Replace all context variables of type word by equivalent variables of type +bv *) +Ltac remove_word_vars := + repeat (match goal with + | w : ?T |- _ => eunify T (word _); remove_word_var w end). + +(* Replace a word equality by a bitvector equality *) +Ltac remove_word_eq := + match goal with + | |- ?w = ?w' => + let t := type of w in + eunify t (word _); + apply word_to_bv_eq + | |- ?w ≠ ?w' => + let t := type of w in + eunify t (word _); + apply word_to_bv_neq + | H : ?w = ?w' |- _ => + let t := type of w in + eunify t (word _); + apply word_to_bv_eq in H + | H : ?w ≠ ?w' |- _ => + let t := type of w in + eunify t (word _); + apply word_to_bv_neq in H + end. + +(* Replace a word equality by a bitvector equality *) +Ltac remove_word_eqs := + repeat remove_word_eq. + +Ltac remove_words := + remove_word_vars; remove_word_eqs. + + +(*** bv_solve improvements ***) + + +(* Full bitvector simplification for both word and bv, contrary to bv_simplify, + it does not move the goal to Z. Equalities in bv will stay in bv *) +Ltac bv_word_simp := + repeat (autorewrite with bv word transport arith in *; + try bv_to_word_to_bv; + try word_to_bv_to_word). + + +(* Makes bv_unfold slower but more powerful, we'll see if that is better. *) +Global Hint Constants Transparent : bv_unfold_db. + +(* Support transport in bv_simplify, bv_solve *) +Lemma bv_unfold_transport n m s w (e : n = m) (b : bv n) z: + BvUnfold n s w b z -> + BvUnfold m s w (transport bv e b) z. +Proof. scongruence. Qed. +Global Hint Resolve bv_unfold_transport | 10 : bv_unfold_db. +Global Hint Extern 20 => apply bv_unfold_transport : bv_unfold_db. + +(** Simplify all bitvector equation in Z equations everywhere. Aimed for + bitblast and bit by bit analysis*) +Ltac bv_simplify' := + forall_hyps ltac:(fun H => bv_simplify H); bv_simplify. + +(** Simplify all bitvector equation in Z equations everywhere. Aimed for + lia and arithmetic analysis*) +Ltac bv_simplify_arith' := + forall_hyps ltac:(fun H => bv_simplify_arith H); bv_simplify_arith. + +(** Improvement of bv_solve that also simplifies the hypothesis *) +Ltac bv_solve' := + forall_hyps ltac:(fun H => bv_simplify_arith H); bv_solve. + +(** Solve a goal with mixed word and bv reasoning, with lia as backend. + Therefore it will not support bitwise and, or and xor. *) +Ltac bv_word_solve' := remove_words; bv_word_simp; bv_solve'. + +Ltac bv_word_solve := + match goal with + | |- _ =@{?T} _ => (eunify T (bv _) + eunify T (word _)) + | |- _ ≠@{?T} _ => (eunify T (bv _) + eunify T (word _)) + | H : _ =@{?T} _ |- _ => (eunify T (bv _) + eunify T (word _)); exfalso + | H : _ ≠@{?T} _ |- _ => (eunify T (bv _) + eunify T (word _)); exfalso + end; bv_word_solve'. + + +(*** Convert word operation to bv operations ***) + +Lemma word_to_bv_ZToWord n z : + word_to_bv (ZToWord n z) = Z_to_bv (N.of_nat n) z. +Proof. + destruct n. + - setoid_rewrite word0. + bv_solve. + - unfold word_to_bv. + rewrite uwordToZ_ZToWord_full; [|lia]. + bv_simplify_arith'. + bv_word_simp. + reflexivity. +Qed. +#[global] Hint Rewrite word_to_bv_ZToWord : bv. + +Lemma word_to_bv_natToWord n m : + word_to_bv (natToWord n m) = Z_to_bv (N.of_nat n) (Z.of_nat m). +Proof. + rewrite <- ZToWord_Z_of_nat. + bv_word_solve. +Qed. +#[global] Hint Rewrite word_to_bv_natToWord : bv. + +Lemma word_to_bv_NToWord n m : + word_to_bv (NToWord n m) = Z_to_bv (N.of_nat n) (Z.of_N m). +Proof. + rewrite <- ZToWord_Z_of_N. + bv_word_solve. +Qed. +#[global] Hint Rewrite word_to_bv_NToWord : bv. + +Lemma uwordToZ_bv_to_word n (b : bv n): + uwordToZ (bv_to_word b) = bv_unsigned b. +Proof. + unfold bv_to_word. + hauto lq:on db:bv,word,arith use:bv_unsigned_in_range. +Qed. +#[global] Hint Rewrite uwordToZ_bv_to_word : bv. + +(* I need this because fold won't work *) +Lemma uwordToZ_def sz (w : word sz) : Z.of_N (wordToN w) = uwordToZ w. + Proof. reflexivity. Qed. +#[global] Hint Rewrite uwordToZ_def : word. + + +Lemma word_to_bv_wplus n (w w' : word n) : + word_to_bv (wplus w w') = (word_to_bv w + word_to_bv w')%bv. +Proof. + unfold wplus,wordBin. + remove_words. + rewrite N2Z.inj_add. + bv_word_solve. +Qed. +#[global] Hint Rewrite word_to_bv_wplus : bv. + + + + + +(*** Extra bitvector function ***) + + +(* This section might be upstreamed to stdpp. *) + +(* Give minimal number of block of size n to cover m + + Unspecified if n = 0 + *) +Definition align_up (m n : N) := ((m + (n - 1)) / n)%N. + +(** Transform a bitvector to bytes of size n. *) +Definition bv_to_bytes (n : N) {m : N} (b : bv m) : list (bv n) := + bv_to_little_endian (Z.of_N $ align_up m n) n (bv_unsigned b). + +(** Transform a list of bytes of size n to a bitvector of size m. + + If m is larger than n*(length l), the result is zero-extended to m + If m is smaller than n*(length l), the result is truncated to m *) +Definition bv_of_bytes (n : N) (m : N) (l : list (bv n)) : bv m := + little_endian_to_bv n l |> Z_to_bv m. + + +Definition bv_get_bit (i : N) {n : N} (b : bv n) : bool := + negb (bv_extract i 1 b =? bv_0 1). + +Definition bv_set_bit (i : N) {n : N} (b : bv n) : bv n := + bv_and b (Z_to_bv n (bv_modulus i)). + +Definition bv_unset_bit (i : N) {n : N} (b : bv n) : bv n := + bv_or b (bv_not (Z_to_bv n (bv_modulus i))). diff --git a/system-semantics/Common/CBool.v b/system-semantics/Common/CBool.v new file mode 100644 index 0000000..de1a3e5 --- /dev/null +++ b/system-semantics/Common/CBool.v @@ -0,0 +1,98 @@ +(** This module cover all thing related to uses of boolean, mainly as decidable + proposition. + + In particular it will cover boolean reflection and decidable generic + operations like equality. *) +From stdpp Require Import base. +From stdpp Require Export decidable. +From stdpp Require Export sets. +From Hammer Require Import Tactics. +Require Export DecidableClass. + +Require Import CBase. + +From Hammer Require Reflect. + +(*** Bool unfold ***) + +(* This an attempt to have a custom boolean unfolding, to not need to handle the + mess with having both is_true and Is_true coercion. *) + +Class BoolUnfold (b : bool) (P : Prop) := + {bool_unfold : b <-> P }. +Global Hint Mode BoolUnfold + - : typeclass_instances. + +Global Instance BoolUnfold_proper : + Proper (eq ==> iff ==> iff) BoolUnfold. +Proof. solve_proper2_tc. Qed. + + +(* Explain to coq hammer tactic how to use Is_true and BoolUnfold *) +#[export] Hint Rewrite @bool_unfold using typeclasses eauto : brefl. + +Lemma true_is_true (b : bool) : b <-> is_true b. + Proof. destruct b; naive_solver. Qed. +#[export] Hint Rewrite <- true_is_true : brefl. + +Lemma true_eq_true (b : bool) : b <-> b = true. + Proof. destruct b; naive_solver. Qed. +#[export] Hint Rewrite <- true_eq_true : brefl. + + +(* Basic implementation of BoolUnfold *) +Global Instance bool_unfold_default (b : bool) : + BoolUnfold b b | 1000. +Proof. done. Qed. + +Global Instance bool_unfold_false : BoolUnfold false False. +Proof. done. Qed. + +Global Instance bool_unfold_true : BoolUnfold true True. +Proof. done. Qed. + +Global Instance bool_unfold_and (b b' : bool) P Q : + BoolUnfold b P -> BoolUnfold b' Q -> + BoolUnfold (b && b') (P /\ Q). +Proof. tcclean. destruct b; destruct b'; naive_solver. Qed. + +Global Instance bool_unfold_or (b b' : bool) P Q : + BoolUnfold b P -> BoolUnfold b' Q -> + BoolUnfold (b || b') (P \/ Q). +Proof. tcclean. destruct b; destruct b'; naive_solver. Qed. + +Global Instance bool_unfold_not (b : bool) P : + BoolUnfold b P -> + BoolUnfold (negb b) (¬ P). +Proof. tcclean. destruct b; naive_solver. Qed. + +Global Instance bool_unfold_implb (b b' : bool) P Q : + BoolUnfold b P -> BoolUnfold b' Q -> + BoolUnfold (implb b b') (P -> Q). +Proof. tcclean. destruct b; destruct b'; naive_solver. Qed. + +Global Instance bool_unfold_iff (b b' : bool) P Q : + BoolUnfold b P -> BoolUnfold b' Q -> + BoolUnfold (eqb b b') (P <-> Q). +Proof. tcclean. destruct b; destruct b'; naive_solver. Qed. + +Global Instance bool_unfold_bool_decide `{Decision P} : + BoolUnfold (bool_decide P) P. +Proof. tcclean. destruct (decide P); naive_solver. Qed. + + + +(*** Decidable propositions ***) + +(** Decidable equality notation that use the Decision type class from stdpp*) +Notation "x =? y" := (bool_decide (x = y)) (at level 70, no associativity) + : stdpp_scope. + +(** Convert automatical a Decidable instance (Coq standard library) to + a Decision instance (stdpp) *) +Global Instance Decidable_to_Decision P `{dec : Decidable P} : Decision P := + match dec with + | {| Decidable_witness := true; Decidable_spec := spec |} => + left ((iffLR spec) eq_refl) + | {| Decidable_witness := false; Decidable_spec := spec |} => + right (fun HP => match (iffRL spec HP) with end) + end. diff --git a/system-semantics/Common/CInduction.v b/system-semantics/Common/CInduction.v new file mode 100644 index 0000000..f96688d --- /dev/null +++ b/system-semantics/Common/CInduction.v @@ -0,0 +1,140 @@ +Require Import Program.Tactics. +Require Import Arith. +Require Import CBase. + +(** This module exists because I got fed up by how the normal induction tactic + did not work on custom induction principles. This new tactic is named + "cinduction" and is based on the "CInduction" typeclass. The induction lemma + used can be either found by typeclass resolution or by specifying it + explicitly. + + For an integer of type nat, "induction n" and "cinduction n" do the same + thing up to calling intro a few times. + + But one can also use the lt_wf_cind instance by calling cinduction n using + lt_wf_cind, to do a strong induction. + + One can register a custom induction principle for any type, including + propositions using the typeclass. The typeclass does not impose any shape + between the input value and the induction predicate. If multiple value are + needed, you can thus just call cinduction on a tuple. + + In order to name the generated hypotheses, one can use "with", for example: + cinduction n with [>| intros n IH]. + + There is currently no way to use intro patterns in the same way as the + normal induction. *) + +From stdpp Require Export fin_maps. +From stdpp Require Export sets. + + +Class CInduction {A : Type} (a : A) (P : Prop) := + { + induction_requirement : Prop; + induction_lemma : induction_requirement -> P + }. + +Arguments induction_lemma {_} _ {_ _}. +Arguments induction_requirement {_} _ {_ _}. + +(*** Tactic definition ***) + +Ltac instanciate_as_found e := + let x := fresh in + let H := fresh in + pose (x := e); + assert (x = e) as H; [reflexivity |]; + rewrite <- H; rewrite -> H; + clear H; clear x. + +(* If someone ever needs to have more than 3 parameter in the induction + predicate, feel free to add case + + If someone finds a Ltac hack to have exactly the same semantics for any + number of arguments, Please replace and check that everything depending still + builds *) +Ltac pattern_for H := + lazymatch (type of H) with + | _ ?a ?b ?c => + try(instanciate_as_found a); + try(instanciate_as_found b); + try(instanciate_as_found c); + pattern a, b, c; + apply H + | _ ?a ?b => + try(instanciate_as_found a); + try(instanciate_as_found b); + pattern a, b; + apply H + | _ ?a => + try(instanciate_as_found a); + pattern a; + apply H + | _ => fail "Not an application" + end. + +Tactic Notation "cinduction" constr(e) "with" tactic(intr) := + let H := fresh "H" in + eenough (induction_requirement e) as H; + [ apply (induction_lemma e) in H | + hnf; repeat split; intr]; + [ repeat (pattern_for H); fail "Couldn't apply induction" | ..]; + cbn in *. + +Tactic Notation "cinduction" constr(e) := cinduction e with intros. + +Tactic Notation "cinduction" constr(e) "using" constr(i) "with" tactic(intr) := + let P := mk_evar Prop in + let CI := fresh "CI" in + let _ := match goal with _ => evar (CI:CInduction e P) end in + only [CI] : rapply i; + let H := fresh "H" in + eenough (@induction_requirement _ e _ CI) as H; + [ apply (induction_lemma e) in H | + hnf; repeat split; intr]; + [ repeat (pattern_for H); fail "Couldn't apply induction" | ..]; + cbn in *; + clear CI. + + +Tactic Notation "cinduction" constr(e) "using" constr(i) := + cinduction e using i with intros. + + +(*** Example implementations ***) + +Program Global Instance nat_cind (n : nat) (P : nat -> Prop) : CInduction n (P n) := + {| + induction_requirement := (P 0) /\ (forall n, P n -> P (S n)) + |}. +Next Obligation. + intros. induction n; hauto. +Defined. + +Program Definition lt_wf_cind (n : nat) (P : nat -> Prop) : CInduction n (P n) := + {| + induction_requirement := (forall n, (forall m, m < n -> P m) -> P n) + |}. +Next Obligation. apply lt_wf_ind. Qed. + +Program Global Instance le_cind (n m: nat) (H : n <= m) (P : nat -> Prop) : + CInduction H (P m) := + {| + induction_requirement := P n /\ (∀ m, n ≤ m → P m → P (S m)) + |}. +Next Obligation. intros. induction H; hauto. Defined. + +Program Global Instance list_cind A (l: list A) (P : list A -> Prop) : + CInduction l (P l) := + {| + induction_requirement := P [] /\ (∀ a t, P t → P (a :: t)) + |}. +Next Obligation. intros. induction l; hauto. Defined. + +Program Definition list_rev_cind A (l: list A) (P : list A -> Prop) : + CInduction l (P l) := + {| + induction_requirement := P [] /\ (∀ a t, P t → P (t ++ [a])) + |}. +Next Obligation. intros. apply rev_ind; hauto. Qed. diff --git a/system-semantics/Common/CList.v b/system-semantics/Common/CList.v new file mode 100644 index 0000000..afbd033 --- /dev/null +++ b/system-semantics/Common/CList.v @@ -0,0 +1,331 @@ +Require Import CBase CBool CMaps. +From stdpp Require Import base. +From stdpp Require Export list. +From stdpp Require Export listset. + +Global Instance proper_list_mbind A B : + Proper (pointwise_relation A (=) ==> (=@{list A}) ==> (=@{list B})) mbind. +Proof. + intros x y H ? l ->. + unfold pointwise_relation in H. + induction l; hauto q:on. +Qed. + + +(*** List simplification ***) + +(** Automation for list simplifications *) +Tactic Notation "list_simp" "in" "|-*" := + rewrite_strat topdown hints list. + +Tactic Notation "list_simp" "in" hyp(H) := + rewrite_strat topdown hints list in H. + +Tactic Notation "list_simp" := + progress (try list_simp in |-*; + repeat match goal with + | [H : _ |- _ ] => rewrite_strat topdown hints list in H + end). + +#[global] Hint Rewrite <- app_assoc : list. +#[global] Hint Rewrite map_app : list. + +Lemma elem_of_app {A} (l l' : list A) (a : A) : + a ∈ l ++ l' <-> a ∈ l \/ a ∈ l'. +Proof. repeat rewrite elem_of_list_In. apply in_app_iff. Qed. +#[global] Hint Rewrite @elem_of_app : list. + +(** Simple type class instance should be systematically simplfied *) +Arguments list_subseteq _ _ _ /. + +#[global] Hint Rewrite @Forall_forall : list. + +Lemma elem_of_map {A B} (f : A → B) (l : list A) (x : A): + x ∈ l → (f x) ∈ (map f l). +Proof. setoid_rewrite elem_of_list_In. apply in_map. Qed. +#[global] Hint Resolve elem_of_map : list. + +Lemma elem_of_map_iff {A B} (f : A -> B) (l : list A) (x : B): + x ∈ map f l <-> ∃'y ∈ l, x = f y. +Proof. + setoid_rewrite elem_of_list_In. + rewrite in_map_iff. + firstorder. +Qed. +(* #[global] Hint Rewrite @elem_of_map_iff : list. *) + +Lemma forall_elem_of_map {A B} (f : A -> B) (l : list A) (P : B -> Prop) : + (∀'x ∈ map f l, P x) <-> ∀'y ∈ l, P (f y). +Proof. + setoid_rewrite elem_of_map_iff. + hauto lq:on. +Qed. +#[global] Hint Rewrite @forall_elem_of_map : list. + +Lemma Permutation_elem_of A (l l' : list A) x: l ≡ₚ l' → x ∈ l → x ∈ l'. +Proof. setoid_rewrite elem_of_list_In. apply Permutation_in. Qed. + +Global Instance set_unfold_list_permutation A (l l' : list A) P Q: + TCFastDone (NoDup l) -> + TCFastDone (NoDup l') -> + (forall x, SetUnfoldElemOf x l (P x)) -> + (forall x, SetUnfoldElemOf x l' (Q x)) -> + SetUnfold (l ≡ₚ l') (forall x, P x <-> Q x). +Proof. + tcclean. + split. + - sfirstorder use:Permutation_elem_of use:Permutation_sym. + - sfirstorder use:NoDup_Permutation. +Qed. + +(*** List lookup with different keys ***) + +Global Instance list_lookupPos {A} : Lookup positive A (list A) := + fun p l => l !! (Pos.to_nat p). + +Global Instance list_lookupN {A} : Lookup N A (list A) := + fun n l => l !! (N.to_nat n). + +Global Instance list_lookupZ {A} : Lookup Z A (list A) := + fun z l => + match z with + | Zpos p => l !! p + | Z0 => head l + | Zneg _ => None + end. + +(*** List boolean unfolding ***) + +Global Instance bool_unfold_existsb A (f : A -> bool) (l : list A) (P : A -> Prop) : + (forall a, BoolUnfold (f a) (P a)) -> + BoolUnfold (existsb f l) (∃'x ∈ l, P x). +Proof. + tcclean. + setoid_rewrite true_is_true. + unfold is_true. + rewrite existsb_exists. + setoid_rewrite elem_of_list_In. + reflexivity. +Qed. + +Global Instance bool_unfold_forallb A (f : A -> bool) (l : list A) (P : A -> Prop) : + (forall a, BoolUnfold (f a) (P a)) -> + BoolUnfold (forallb f l) (∀'x ∈ l, P x). +Proof. + tcclean. + setoid_rewrite true_is_true. + unfold is_true. + rewrite forallb_forall. + setoid_rewrite elem_of_list_In. + reflexivity. +Qed. + + +(*** List as sets ***) + +Global Instance list_omap : OMap listset := λ A B f '(Listset l), + Listset (omap f l). + +Global Instance list_Empty {A} : Empty (list A) := []. + + +(*** List utility functions ***) + +Fixpoint list_from_func_aux {A} (f : nat -> A) (len : nat) (acc : list A) := + match len with + | 0 => acc + | S len => list_from_func_aux f len ((f len) :: acc) + end. + +Definition list_from_func (len : nat) {A} (f : nat -> A) := + list_from_func_aux f len []. + +Lemma list_from_func_aux_eq {A} (f : nat -> A) n acc : + list_from_func_aux f n acc = list_from_func n f ++ acc. +Proof. + generalize dependent acc. + induction n. + - sfirstorder. + - sauto db:list simp+:cbn;rewrite IHn. +Qed. + +Lemma seq_end n l : seq n (S l) = seq n l ++ [n + l]. +Proof. + generalize dependent n. + induction l; sauto db:list. +Qed. + +Lemma list_from_func_map {A} (f : nat -> A) n : + list_from_func n f = map f (seq 0 n). +Proof. + induction n; sauto lq:on db:list use:seq_end,list_from_func_aux_eq. +Qed. + +Definition is_emptyb {A} (l : list A) := + match l with + | [] => true + | _ => false + end. + +Lemma is_emptyb_eq_nil {A} (l : list A) : is_true (is_emptyb l) <-> l = []. +Proof. sauto lq:on. Qed. +#[global] Hint Rewrite @is_emptyb_eq_nil: brefl. + +Definition enumerate {A} (l : list A) : list (nat * A) := + zip_with pair (seq 0 (length l)) l. +#[global] Typeclasses Opaque enumerate. +#[global] Typeclasses Opaque zip_with. + + +Global Instance set_elem_of_zip_with A B C (x : C) (f : A → B → C) l1 l2: + SetUnfoldElemOf x (zip_with f l1 l2) + (∃ (n : nat) y z, l1 !! n = Some y ∧ l2 !! n = Some z ∧ f y z = x) | 10. +Proof. tcclean. rewrite elem_of_lookup_zip_with. naive_solver. Qed. + +Global Instance set_elem_of_zip A B (x : A * B) l1 l2: + SetUnfoldElemOf x (zip l1 l2) + (∃ (n : nat), l1 !! n = Some x.1 ∧ l2 !! n = Some x.2). +Proof. tcclean. set_unfold. hauto lq:on. Qed. + +Global Instance lookup_seq n i l: + LookupUnfold n (seq i l) (if decide (n < l) then Some (n + i) else None)%nat. +Proof. + tcclean. + generalize dependent i. + generalize dependent n. + induction l; intros n i. + - compute_done. + - destruct n; cbn; try reflexivity. + rewrite IHl. + hauto l:on. +Qed. + +Lemma lookup_seq_success (n i l m : nat): + (seq i l) !! n = Some m → m = (n + i)%nat. +Proof. rewrite lookup_unfold. case_decide; naive_solver. Qed. + +Lemma lookup_length A (l : list A) n x : + l !! n = Some x → (n < length l)%nat. +Proof. rewrite <- lookup_lt_is_Some. naive_solver. Qed. + +Ltac list_saturate := + match goal with + | H : _ !! _ = Some _ |- _ => learn_hyp (lookup_length _ _ _ _ H) + | H : _ !! _ = Some _ |- _ => learn_hyp (elem_of_list_lookup_2 _ _ _ H) + end. + +Global Instance set_elem_of_enumerate A (x : nat * A) l: + SetUnfoldElemOf x (enumerate l) (l !! x.1 = Some x.2). +Proof. + tcclean. + unfold enumerate. + set_unfold. + setoid_rewrite lookup_unfold. + hauto l:on simp+:eexists simp+:list_saturate. +Qed. + +Section FilterMap. + Context {A B : Type}. + Variable f : A -> option B. + Fixpoint list_filter_map (l : list A) := + match l with + | [] => [] + | hd :: tl => + match f hd with + | Some b => b :: (list_filter_map tl) + | None => list_filter_map tl + end + end. + + Lemma list_filter_map_mbind (l : list A) : + list_filter_map l = a ← l; f a |> option_list. + Proof using. induction l; hauto lq:on. Qed. +End FilterMap. + +(*** List lemmas ***) + +Lemma length_one_iff_singleton A (l : list A) : + length l = 1 <-> exists a, l = [a]. +Proof. sauto lq: on rew:off. Qed. + + +(*** Fmap Unfold ***) +Class FMapUnfold {M : Type → Type} {fm : FMap M} + {A B} (f : A → B) (ma : M A) (mb : M B) := {fmap_unfold : f <$> ma = mb }. +Global Hint Mode FMapUnfold + + + + + + - : typeclass_instances. + +Global Instance fmap_unfold_default `{FMap M} {A B} (f : A → B) (l : M A): + FMapUnfold f l (f <$> l) | 1000. +Proof. tcclean. reflexivity. Qed. + +Global Instance fmap_unfold_list_app {A B} (f : A → B) l l' l2 l2': + FMapUnfold f l l2 → FMapUnfold f l' l2' → + FMapUnfold f (app l l') (app l2 l2'). +Proof. tcclean. apply fmap_app. Qed. + +Lemma list_bind_fmap A B C (l : list A) (f : A → list B) (g : B -> C): + g <$> (x ← l; f x) = x ← l; g <$> (f x). +Proof. + induction l. { done. } + cbn. + rewrite fmap_unfold. + rewrite <- IHl. + reflexivity. +Qed. +Global Instance fmap_unfold_list_mbind {A B C} (f : B → C) (g : A → list B) l l2: + (∀ x, FMapUnfold f (g x) (l2 x)) → + FMapUnfold f (x ← l; g x) (x ← l; l2 x). +Proof. tcclean. apply list_bind_fmap. Qed. + +Global Instance fmap_unfold_let_pair {A B C D} (f : C → D) x + (l : A → B → list C) l2: + (∀ a b, FMapUnfold f (l a b) (l2 a b)) → + FMapUnfold f (let '(a, b) := x in l a b) (let '(a, b) := x in l2 a b). +Proof. tcclean. destruct x. done. Qed. + + +(*** NoDup management ***) + +Global Hint Resolve NoDup_nil_2 : nodup. +Global Hint Resolve NoDup_cons_2 : nodup. +Global Hint Rewrite @list.NoDup_cons : nodup. +Global Hint Resolve NoDup_singleton : nodup. + + +Lemma NoDup_zip_with_l {A B C} (f : A → B → C) l l': + (∀ x y x' y', f x x' = f y y' → x = y) → NoDup l → + NoDup (zip_with f l l'). +Proof. + intros Hinj HND. + generalize dependent l'. + induction l; + destruct l'; + hauto l:on db:nodup simp+:list_saturate simp+:set_unfold. +Qed. + +Lemma NoDup_zip_with_r {A B C} (f : A → B → C) l l': + (∀ x y x' y', f x x' = f y y' → x' = y') → NoDup l' → + NoDup (zip_with f l l'). +Proof. + intros Hinj HND. + generalize dependent l. + induction l'; + destruct l; + hauto l:on db:nodup simp+:list_saturate simp+:set_unfold. +Qed. + +Lemma NoDup_zip_l {A B} (l : list A) (l' : list B): + NoDup l → NoDup (zip l l'). +Proof. intro. apply NoDup_zip_with_l; naive_solver. Qed. + +Lemma NoDup_zip_r {A B} (l : list A) (l' : list B): + NoDup l' → NoDup (zip l l'). +Proof. intro. apply NoDup_zip_with_r; naive_solver. Qed. + +Lemma NoDup_enumerate A (l : list A) : NoDup (enumerate l). +Proof. + unfold enumerate. + apply NoDup_zip_l. + apply NoDup_seq. +Qed. +Global Hint Resolve NoDup_enumerate : nodup. diff --git a/system-semantics/Common/CMaps.v b/system-semantics/Common/CMaps.v new file mode 100644 index 0000000..32f8518 --- /dev/null +++ b/system-semantics/Common/CMaps.v @@ -0,0 +1,199 @@ +From stdpp Require Export gmap. +From stdpp Require Export fin_maps. + +Require Import CBase. +Require Import CBool. +Require Import CInduction. + +(** This file provide utilities to deal with stdpp maps. + + In particular it provide a way of automatically unfolding a + lookup accross various map operations *) + + +(*** Lookup Unfold ***) + +Class LookupUnfold {K A M : Type} {lk : Lookup K A M} + (k : K) (m : M) (oa : option A) := + {lookup_unfold : m !! k = oa }. +Global Hint Mode LookupUnfold + + + + + + - : typeclass_instances. + +Global Instance lookup_unfold_default `{Lookup K A M} (k : K) (m : M) : + LookupUnfold k m (m !! k) | 1000. +Proof. done. Qed. + +Global Instance lookup_unfold_empty `{FinMap K M} A (k : K) : + LookupUnfold k (∅ : M A) (None : option A). +Proof. sfirstorder. Qed. + +Global Instance lookup_unfold_partial_alter_same `{FinMap K M} + A f (m : M A) o (k : K) : + LookupUnfold k m o -> + LookupUnfold k (partial_alter f k m) (f o) | 10. +Proof. tcclean. sfirstorder. Qed. + +Global Instance lookup_unfold_partial_alter `{FinMap K M} A f + (m : M A) o (k k' : K) : + LookupUnfold k m o -> + LookupUnfold k (partial_alter f k' m) (if k =? k' then f o else o) | 20. +Proof. tcclean. sauto. Qed. + +Global Instance lookup_unfold_fmap `{FinMap K M} A B + (f : A -> B) (m : M A) (o : option A) (k : K) : + LookupUnfold k m o -> + LookupUnfold k (f <$> m) (f <$> o). +Proof. tcclean. sfirstorder. Qed. + +Global Instance lookup_unfold_omap `{FinMap K M} A B + (f : A -> option B) (m : M A) (o : option A) (k : K) : + LookupUnfold k m o -> + LookupUnfold k (omap f m) (o ≫= f). +Proof. tcclean. sfirstorder. Qed. + +Global Instance lookup_unfold_merge `{FinMap K M} A B C + (f : option A -> option B -> option C) (ma : M A) (mb : M B) + (oa : option A) (ob : option B) (k : K) : + LookupUnfold k ma oa -> LookupUnfold k mb ob -> + LookupUnfold k (merge f ma mb) (diag_None f oa ob) | 20. +Proof. tcclean. sfirstorder. Qed. + +Global Instance lookup_unfold_merge_simpl `{FinMap K M} A B C + (f : option A -> option B -> option C) (ma : M A) (mb : M B) + (oa : option A) (ob : option B) (k : K) : + TCEq (f None None) None -> LookupUnfold k ma oa -> LookupUnfold k mb ob -> + LookupUnfold k (merge f ma mb) (f oa ob) | 10. +Proof. + tcclean. + rewrite lookup_unfold. + hauto unfold:diag_None lq:on. +Qed. + + + +(*** Lookup Total Unfold ***) + +Class LookupTotalUnfold {K A M : Type} {lk : LookupTotal K A M} + (k : K) (m : M) (a : A) := {lookup_total_unfold : m !!! k = a }. +Global Hint Mode LookupTotalUnfold + + + + + + - : typeclass_instances. + +Lemma lookup_total_lookup `{FinMap K M} `{Inhabited A} (m : M A) (k : K) : + m !!! k = default inhabitant (m !! k). +Proof. sfirstorder. Qed. + +Lemma lookup_lookup_total `{FinMap K M} `{Inhabited A} (m : M A) (k : K) g : + m !! k = Some g -> m !! k = Some (m !!! k). +Proof. rewrite lookup_total_lookup. hauto lq:on. Qed. + + +Global Instance lookup_total_unfold_default + `{LookupTotal K A M} (k : K) (m : M) : + LookupTotalUnfold k m (m !!! k) | 1000. +Proof. done. Qed. + +Global Instance lookup_total_unfold_empty `{FinMap K M} `{Inhabited A} (k : K) : + LookupTotalUnfold k (∅ : M A) inhabitant | 20. +Proof. + tcclean. + rewrite lookup_total_lookup. + rewrite lookup_unfold. + naive_solver. +Qed. + +Global Instance lookup_total_unfold_empty_empty + `{FinMap K M} `{Empty A} (k : K) : + LookupTotalUnfold k (∅ : M A) ∅ | 10. +Proof. + tcclean. + rewrite lookup_total_lookup. + rewrite lookup_unfold. + naive_solver. +Qed. + +Global Instance lookup_total_unfold_singleton_same + `{FinMap K M} `{Empty A} (k : K) (a : A) : + LookupTotalUnfold k ({[k := a]} : M A) a | 10. +Proof. + tcclean. + rewrite lookup_total_lookup. + rewrite lookup_unfold. + naive_solver. +Qed. + +Global Instance lookup_total_unfold_singleton_different + `{FinMap K M} `{Empty A} (k k' : K) (a : A) : + TCFastDone (k ≠ k') -> + LookupTotalUnfold k ({[k' := a]} : M A) ∅ | 15. +Proof. + tcclean. + rewrite lookup_total_lookup. + rewrite lookup_unfold. + hauto. +Qed. + +Global Instance lookup_total_unfold_singleton + `{FinMap K M} `{Empty A} (k k' : K) (a : A) : + LookupTotalUnfold k ({[k' := a]} : M A) (if k =? k' then a else ∅) | 20. +Proof. + tcclean. + rewrite lookup_total_lookup. + rewrite lookup_unfold. + hauto. +Qed. + +Global Instance lookup_total_unfold_insert_same + `{FinMap K M} `{Empty A} (k : K) (a : A) (m : M A) : + LookupTotalUnfold k (<[k := a]> m) a | 10. +Proof. + tcclean. + rewrite lookup_total_lookup. + rewrite lookup_unfold. + naive_solver. +Qed. + +Global Instance lookup_total_unfold_insert_different + `{FinMap K M} `{Empty A} (k k' : K) (a a' : A) (m : M A) : + TCFastDone (k ≠ k') -> + LookupTotalUnfold k m a' -> + LookupTotalUnfold k (<[k' := a]> m) a' | 15. +Proof. + tcclean. + rewrite lookup_total_lookup. + rewrite lookup_unfold. + hauto. +Qed. + +Global Instance lookup_total_unfold_insert + `{FinMap K M} `{Empty A} (k k' : K) (a a' : A) (m : M A) : + LookupTotalUnfold k m a' -> + LookupTotalUnfold k (<[k' := a]> m) (if k =? k' then a else a') | 20. +Proof. + tcclean. + rewrite lookup_total_lookup. + rewrite lookup_unfold. + hauto. +Qed. + + +(*** Map induction ***) + +Program Global Instance map_cind `{FinMap K M} A (m : M A) (P : M A -> Prop) : + CInduction m (P m) := + {| + induction_requirement := + (P ∅) /\ (forall i x m, m !! i = None -> P m -> P (<[i := x]>m)) + |}. +Solve All Obligations with intros; apply map_ind; naive_solver. + +(* When one of the argument of the generic predicate depends on the other, the + dependent one should be after its dependency in the argument order otherwise + the pattern matching of cinduction fails *) +Program Definition map_fold_cind `{FinMap K M} A B (m : M A) + (b : B) (f : K -> A -> B -> B) (P : M A -> B -> Prop) : + CInduction m (P m (map_fold f b m)) := + {| + induction_requirement := + P ∅ b /\ + (forall i x m r, m !! i = None -> P m r -> P (<[i:=x]> m) (f i x r) ) + |}. +Solve All Obligations with intros; apply (map_fold_ind (fun x y => P y x)); hauto. +Arguments map_fold_cind : clear implicits. diff --git a/system-semantics/Common/CSets.v b/system-semantics/Common/CSets.v new file mode 100644 index 0000000..eb2c0b8 --- /dev/null +++ b/system-semantics/Common/CSets.v @@ -0,0 +1,244 @@ +From stdpp Require Export sets. +From stdpp Require Export gmap. (* <- contains gset *) +From stdpp Require Export finite. + +Require Import CBase. +Require Import CBool. +Require Import CList. +Require Import CInduction. + +(** This file provide utility for dealing with sets. *) + +(*** Utilities ***) + +Lemma elements_singleton_iff `{FinSet A C} (s : C) (a : A) : + elements s = [a] <-> s ≡ {[a]}. +Proof. + rewrite <- Permutation_singleton_r. + assert (NoDup [a]). sauto lq:on. + assert (NoDup (elements s)). sfirstorder. + set_solver. +Qed. + + +(** The size of a finite set. *) +Definition set_size `{Elements A C} (s : C) : nat := length (elements s). + +Global Instance proper_set_size_equiv `{FinSet A C} : + Proper (equiv ==> eq) (set_size : C -> nat). +Proof. solve_proper2_funcs. Qed. + +Lemma set_size_zero `{FinSet A C} (s : C) : + set_size s = 0 <-> s ≡ ∅. +Proof. + unfold set_size. + rewrite length_zero_iff_nil. + apply elements_empty_iff. +Qed. + +Lemma set_size_zero_L `{FinSet A C} {lei : LeibnizEquiv C} (s : C) : + set_size s = 0 <-> s = ∅. +Proof. rewrite set_size_zero. hauto l:on. Qed. + +Lemma set_size_one `{FinSet A C} (s : C) : + set_size s = 1 <-> exists x : A, s ≡ {[x]}. +Proof. + unfold set_size. + rewrite length_one_iff_singleton. + hauto lq:on use:elements_singleton_iff. +Qed. + +Lemma set_size_one_L `{FinSet A C} {lei : LeibnizEquiv C} (s : C) : + set_size s = 1 <-> exists x : A, s = {[x]}. +Proof. rewrite set_size_one. set_solver. Qed. + +Lemma set_size_le1 `{FinSet A C} (s : C) : + set_size s ≤ 1 ↔ (∀ y z : A, y ∈ s → z ∈ s → y = z). +Proof. + unfold set_size. + setoid_rewrite <- elem_of_elements. + assert (NoDup (elements s)). { sfirstorder. } + generalize dependent (elements s). intros l ND. + do 2 (destruct ND;[sauto lq:on rew:off|]). + split. + - sauto q:on. + - set_solver. +Qed. + +Definition set_forallb `{Elements A C} (P : A -> bool) (s : C) := + forallb P (elements s). + +Definition option_to_set (C : Type) `{Empty C} `{Singleton A C} (o : option A) : C := + match o with + | None => ∅ + | Some a => {[a]} + end. + +Global Instance set_unfold_option_to_set `{SemiSet A C} (o : option A) x: + SetUnfoldElemOf x (option_to_set C o) (o = Some x). +Proof. tcclean. unfold option_to_set. sauto lq:on. Qed. + +(*** Simplification ***) + +(** Automation for set simplifications *) +Tactic Notation "set_simp" "in" "|-*" := + rewrite_strat topdown hints set. + +Tactic Notation "set_simp" "in" hyp(H) := + rewrite_strat topdown hints set in H. + +Tactic Notation "set_simp" := + progress (try set_simp in |-*; + repeat match goal with + | [H : _ |- _ ] => rewrite_strat topdown hints set in H + end). + +#[global] Hint Rewrite @set_fold_empty using typeclasses eauto : set. +#[global] Hint Rewrite @set_fold_singleton using typeclasses eauto : set. +#[global] Hint Rewrite @empty_union_L using typeclasses eauto : set. + + +Section SetSimp. + Context {A C : Type}. + Context `{SemiSet A C}. + Context {lei : LeibnizEquiv C}. + + Lemma set_left_id_union (s : C) : ∅ ∪ s = s. + Proof. apply leibniz_equiv. set_unfold. naive_solver. Qed. + + Lemma set_right_id_union (s : C) : s ∪ ∅ = s. + Proof. apply leibniz_equiv. set_unfold. naive_solver. Qed. +End SetSimp. +#[global] Hint Rewrite @set_left_id_union using typeclasses eauto : set. +#[global] Hint Rewrite @set_right_id_union using typeclasses eauto : set. + + + +(*** Set Unfolding ***) + +(** This section is mostly about improving the set_unfold tactic *) + + + +Global Instance set_unfold_elem_of_if_bool_decide `{ElemOf A C} `{Decision P} + (x : A) (X Y : C) Q R: + SetUnfoldElemOf x X Q -> SetUnfoldElemOf x Y R -> + SetUnfoldElemOf x (if bool_decide P then X else Y) (if bool_decide P then Q else R). +Proof. sauto q:on. Qed. + + +Global Instance set_unfold_elem_of_if_decide `{ElemOf A C} `{Decision P} + (x : A) (X Y : C) Q R: + SetUnfoldElemOf x X Q -> SetUnfoldElemOf x Y R -> + SetUnfoldElemOf x (if decide P then X else Y) (if decide P then Q else R). +Proof. sauto lq:on. Qed. + +Global Instance set_unfold_Some A Q (x y : A) : + SetUnfold (x = y) Q -> SetUnfold (Some x = Some y) Q. +Proof. sauto lq:on. Qed. + +Global Instance set_unfold_enum `{Finite A} a : + SetUnfoldElemOf a (enum A) True. +Proof. tcclean. sauto. Qed. + +(** Import this module so that set_unfold unfold X = Y into + (x,y) ∈ X <-> (x,y) ∈ Y if X and Y are sets of pairs *) +Module SetUnfoldPair. + + #[export] Instance set_unfold_equiv_pair `{ElemOf (A * B) C} + (P Q : A -> B → Prop) (X Y : C) : + (∀ x y, SetUnfoldElemOf (x, y) X (P x y)) → + (∀ x y, SetUnfoldElemOf (x, y) Y (Q x y)) → + SetUnfold (X ≡ Y) (∀ x y, P x y ↔ Q x y) | 9. + Proof. tcclean. set_unfold. hauto. Qed. + + #[export] Instance set_unfold_equiv_L_pair `{ElemOf (A * B) C} {l : LeibnizEquiv C} + (P Q : A -> B → Prop) (X Y : C) : + (∀ x y, SetUnfoldElemOf (x, y) X (P x y)) → + (∀ x y, SetUnfoldElemOf (x, y) Y (Q x y)) → + SetUnfold (X = Y) (∀ x y, P x y ↔ Q x y) | 9. + Proof. tcclean. unfold_leibniz. set_unfold. hauto. Qed. + + #[export] Instance set_elem_of_let_pair A B `{ElemOf D C} (S : A → B → C) + (c : A * B) P (x : D): + SetUnfoldElemOf x (S c.1 c.2) P → + SetUnfoldElemOf x (let '(a, b) := c in S a b) P. + Proof. tcclean. hauto l:on. Qed. +End SetUnfoldPair. + + +(*** Set Induction ***) + +(* There are some case where both instances can apply, but they both give the + same result so we don't really care which one is chosen *) + +Program Global Instance set_cind `{FinSet A C} (X : C) (P : C -> Prop) + {pr: Proper (equiv ==> iff) P} : CInduction X (P X) := + {| + induction_requirement := + (P ∅) /\ (forall x X, x ∉ X -> P X -> P ({[x]} ∪ X)) + |}. +Solve All Obligations with + intros; apply set_ind;try naive_solver; intros ????; apply (pr x y);auto. + +Program Global Instance set_cind_L `{FinSet A C} {lei : LeibnizEquiv C} + (X : C) (P : C -> Prop) : CInduction X (P X) := + {| + induction_requirement := + (P ∅) /\ (forall x X, x ∉ X -> P X -> P ({[x]} ∪ X)) + |}. +Solve All Obligations with intros; apply set_ind_L; naive_solver. + +(** Induction principles over set_fold *) +Program Definition set_fold_cind `{FinSet A C} B (X : C) + (b : B) (f : A -> B -> B) (P : C -> B -> Prop) + {pr: Proper (equiv ==> eq ==> iff) P} : CInduction X (P X (set_fold f b X)) := + {| + induction_requirement := + (P ∅ b) /\ (forall x X r, x ∉ X -> P X r -> P ({[x]} ∪ X) (f x r)) + |}. +Solve All Obligations with + intros;apply (set_fold_ind (fun x y => P y x)); [intros ??? eq ?; eapply (pr x0 y eq x);eauto | hauto..]. +Arguments set_fold_cind : clear implicits. + +Program Definition set_fold_cind_L `{FinSet A C} B (X : C) + {lei : LeibnizEquiv C} (b : B) (f : A -> B -> B) (P : C -> B -> Prop) + : CInduction X (P X (set_fold f b X)) := + {| + induction_requirement := + (P ∅ b) /\ (forall x X r, x ∉ X -> P X r -> P ({[x]} ∪ X) (f x r)) + |}. +Solve All Obligations with + intros; apply (set_fold_ind_L (fun x y => P y x)); hauto. + +Arguments set_fold_cind_L : clear implicits. + + +(*** GSet Cartesian product ***) + + +Section GSetProduct. + Context `{Countable A}. + Context `{Countable B}. + + Definition gset_product (sa : gset A) (sb : gset B) : gset (A * B) := + set_fold (fun e1 res => res ∪ set_map (e1,.) sb) ∅ sa. + + (** × must be left associative because the * of types is left associative. + Thus if you have sa : gset A, sb : gset B and sc : gset C, then + sa × sb × sc : gset (A * B * C) *) + Infix "×" := gset_product (at level 44, left associativity) : stdpp_scope. + + Lemma gset_product_spec (sa : gset A) (sb : gset B) a b : + (a, b) ∈ sa × sb <-> a ∈ sa /\ b ∈ sb. + Proof using. + unfold gset_product. + cinduction sa using set_fold_cind_L; set_solver. + Qed. + + Global Instance set_unfold_gset_product (sa : gset A) (sb : gset B) x P Q : + SetUnfoldElemOf x.1 sa P -> SetUnfoldElemOf x.2 sb Q -> + SetUnfoldElemOf x (sa × sb) (P /\ Q). + Proof using. tcclean. destruct x. apply gset_product_spec. Qed. +End GSetProduct. +Infix "×" := gset_product (at level 44, left associativity) : stdpp_scope. diff --git a/system-semantics/Common/Common.v b/system-semantics/Common/Common.v new file mode 100644 index 0000000..ec9f8d0 --- /dev/null +++ b/system-semantics/Common/Common.v @@ -0,0 +1,149 @@ +(** This file is the top level of the SSCCommon library. Users should just + Require Import SSCCommon.Common. + *) + +From Hammer Require Export Tactics. +Require Export bbv.Word. +Require Import DecidableClass. +From stdpp Require Export strings. +From stdpp Require Export fin. +From stdpp Require Export pretty. +From stdpp Require Export vector. +From stdpp Require Export finite. +From stdpp Require Export relations. +Require Export Ensembles. + +Require Export CBase. +Require Export CBool. +Require Export CList. +Require Export CBitvector. +Require Export CSets. +Require Export CMaps. +Require Export CInduction. + +(*** Utility functions ***) + +(** Update a function at a specific value *) +Definition fun_add {A B} {_: EqDecision A} (k : A) (v : B) (f : A -> B) := + fun x : A => if k =? x then v else f x. + + +(*** Ensembles ***) +(* I really don't understand why this is not in stdpp *) +(* stdpp use propset instead of Ensemble, maybe that would be better *) + +Global Instance Ensemble_elem_of {A} : ElemOf A (Ensemble A) := fun x P => P x. + +Global Instance Ensemble_empty {A} : Empty (Ensemble A) := fun a => False. + +Global Instance Ensemble_singleton {A} : + Singleton A (Ensemble A) := fun x y => x = y. + +Global Instance Ensemble_union {A} : + Union (Ensemble A) := fun P Q x => P x \/ Q x. +Global Instance Ensemble_intersection {A} : + Intersection (Ensemble A) := fun P Q x => P x /\ Q x. + +Global Instance Ensemble_difference {A} : + Difference (Ensemble A) := fun P Q x => P x /\ ¬(Q x). + + +Global Instance Ensemble_mbind : MBind Ensemble := λ A B f E b, + ∃'a ∈ E, b ∈ f a. + +Global Instance Ensemble_omap : OMap Ensemble := λ A B f E b, + ∃'a ∈ E, f a = Some b. + + +Definition Ensemble_from_set {A C} `{ElemOf A C} (c : C) : Ensemble A := fun a => a ∈ c. + +Global Instance Ensemble_SemiSet A : SemiSet A (Ensemble A). +Proof. sauto l:on. Qed. + +Global Instance Ensemble_Set A : Set_ A (Ensemble A). +Proof. sauto l:on. Qed. + + +(*** Vectors ***) + +(* This is purposefully not in stdpp because Coq does not apply it automatically + because of dependent types. This can be solved with a Hint Resolve *) +Global Instance vector_insert {n} {V} : Insert (fin n) V (vec V n) := vinsert. +Global Hint Resolve vector_insert : typeclass_instances. + +Create HintDb vec discriminated. + +#[global] Hint Rewrite @lookup_fun_to_vec : vec. +#[global] Hint Rewrite @vlookup_map : vec. +#[global] Hint Rewrite @vlookup_zip_with : vec. + +(* There are probably lots of other lemmas to be added here, + I'll do case by case. *) + + +(*** Finite decidable quantifiers ***) + +Definition fforallb `{Finite A} (P : A -> bool) : bool := + forallb P (enum A). + +Global Instance fforallb_unfold `{Finite A} (P : A -> bool) Q: + (forall a : A, BoolUnfold (P a) (Q a)) -> + BoolUnfold (fforallb P) (forall a : A, Q a). +Proof. + tcclean. + unfold fforallb. + rewrite bool_unfold. + sauto lq:on dep:on. +Qed. + +Definition fexistsb `{Finite A} (P : A -> bool) : bool := + existsb P (enum A). + +Global Instance fexistsb_unfold `{Finite A} (P : A -> bool) Q: + (forall a : A, BoolUnfold (P a) (Q a)) -> + BoolUnfold (fexistsb P) (exists a : A, Q a). +Proof. + tcclean. + unfold fexistsb. + rewrite bool_unfold. + sauto lq:on dep:on. +Qed. + + +(*** Finite number utilities *) + +Bind Scope fin_scope with fin. + +(* stdpp provides notation from 0 to 10. We need them up to 30 for + register numbering *) +(* Python: +for i in range(11, 31): + print("Notation \"{}\" := (FS {}) : fin_scope.".format(i, i - 1)) +*) +Notation "11" := (FS 10) : fin_scope. +Notation "12" := (FS 11) : fin_scope. +Notation "13" := (FS 12) : fin_scope. +Notation "14" := (FS 13) : fin_scope. +Notation "15" := (FS 14) : fin_scope. +Notation "16" := (FS 15) : fin_scope. +Notation "17" := (FS 16) : fin_scope. +Notation "18" := (FS 17) : fin_scope. +Notation "19" := (FS 18) : fin_scope. +Notation "20" := (FS 19) : fin_scope. +Notation "21" := (FS 20) : fin_scope. +Notation "22" := (FS 21) : fin_scope. +Notation "23" := (FS 22) : fin_scope. +Notation "24" := (FS 23) : fin_scope. +Notation "25" := (FS 24) : fin_scope. +Notation "26" := (FS 25) : fin_scope. +Notation "27" := (FS 26) : fin_scope. +Notation "28" := (FS 27) : fin_scope. +Notation "29" := (FS 28) : fin_scope. +Notation "30" := (FS 29) : fin_scope. + +Global Instance pretty_fin (n : nat) : Pretty (fin n) := + (fun n => pretty (n : nat)). +Global Hint Mode Pretty ! : typeclass_instances. + +Definition fin_to_N {n : nat} : fin n -> N := N.of_nat ∘ fin_to_nat. +Coercion fin_to_N : fin >-> N. diff --git a/system-semantics/Common/Exec.v b/system-semantics/Common/Exec.v new file mode 100644 index 0000000..6a36d63 --- /dev/null +++ b/system-semantics/Common/Exec.v @@ -0,0 +1,649 @@ +(* This file defines an execution monad for the model. + + The execution model is Either a named error or a lists of possible outputs. + This is used to represent non-deterministic but computational execution that + may fail. + + Getting a Results l, means that all path from the initial state have been + computed and all the results are in l and none of them are errors. + + Getting an Error e, means that there is one non-deterministic path that + reaches that error. All other possible outcome are specified. + + In the case of this model, an Error means a behavior not supported by the + model. In particular, since processor exceptions are not supported, any + invalid code that would trigger them will make the whole execution return + an error with hopefully a descriptive message. *) + +Require Import Common. + + +(*** Tactics ***) + +Create HintDb exec discriminated. + +Tactic Notation "exec_simp" "in" "|-*" := + rewrite_strat topdown hints exec. + +Tactic Notation "exec_simp" "in" hyp(H) := + rewrite_strat topdown hints exec in H. + +Tactic Notation "exec_simp" := + progress + (repeat exec_simp in |-*; + repeat match goal with + | [H : _ |- _ ] => rewrite_strat topdown (repeat hints exec) in H + end). + +Module Exec. + +(*** Definition and utility functions ***) + +Inductive t (E A : Type) : Type := +| Error : E -> t E A +| Results : list A -> t E A. +Arguments Error {_ _} _. +Arguments Results {_ _} _. + +(** Means that this execution has no output and may be safely discarded.*) +Notation discard := (Results []). + +(** Monadic return *) +Definition ret {E A} (a : A) : t E A := Results [a]. + +(** Takes an option but convert None into an error *) +Definition error_none {E A} (e : E) : option A -> t E A := + from_option ret (Error e). + +(** Takes an option but convert None into a discard *) +Definition discard_none {E A} : option A -> t E A := + from_option ret discard. + +(** Returns an error if the condition is met *) +Definition fail_if {E} (b : bool) (e : E) : t E () := + if b then Error e else ret (). + +(** Discards the execution if the condition is not met *) +Definition assert {E} (b : bool) : t E () := + if b then ret () else discard. + +(** Non-deterministically choose an element in a finite set *) +Definition choose {E} (A : Type) `{Finite A} : t E A := Results (enum A). + +(** Maps the error to another error type. *) +Definition map_error {E E' A} (f : E -> E') (e : t E A) : t E' A := + match e with + | Error err => Error (f err) + | Results l => Results l + end. + +(** Merge the results of two executions *) +Definition merge {E A} (e1 e2 : t E A) := + match e1 with + | Error e => Error e + | Results l => + match e2 with + | Error e => Error e + | Results l' => Results (l ++ l') + end + end. + + +(*** Monad instance ***) + +Global Instance mret_inst {E} : MRet (t E) := { mret A := ret }. + +Global Instance mbind_inst {E} : MBind (t E) := + { mbind _ _ f x := + match x with + | Error e => Error e + | Results l => foldl merge discard (map f l) + end + }. +Global Typeclasses Opaque mbind_inst. + +Global Instance fmap_inst {E} : FMap (t E) := + { fmap _ _ f x := + match x with + | Error e => Error e + | Results l => Results (map f l) + end }. +Global Typeclasses Opaque fmap_inst. + + + +(*** Simplification lemmas ***) + +Lemma mbind_ret E A B (x : A) (f : A -> t E B) : (ret x ≫= f) = f x. +Proof. hauto lq:on. Qed. +#[global] Hint Rewrite mbind_ret : exec. +#[global] Hint Rewrite mbind_ret : execc. + +Lemma mbind_error (E A B : Type) e (f : A -> t E B) : Error e ≫= f = Error e. +Proof. done. Qed. +#[global] Hint Rewrite mbind_error : exec. +#[global] Hint Rewrite mbind_error : execc. + +Lemma mbind_discard E A B (f : A -> t E B) : discard ≫= f = discard. +Proof. done. Qed. +#[global] Hint Rewrite mbind_discard : exec. +#[global] Hint Rewrite mbind_discard : execc. + +Lemma merge_error E A s (e : t E A): + merge (Error s) e = Error s. +Proof. done. Qed. +#[global] Hint Rewrite merge_error : exec. +#[global] Hint Rewrite merge_error : execc. + +Lemma foldl_merge_error E A s (l : list (t E A)): + foldl merge (Error s) l = Error s. +Proof. by induction l. Qed. +#[global] Hint Rewrite foldl_merge_error : exec. +#[global] Hint Rewrite foldl_merge_error : execc. + +Lemma merge_discard E A (e : t E A) : merge discard e = e. +Proof. by destruct e. Qed. +#[global] Hint Rewrite merge_discard : exec. +#[global] Hint Rewrite merge_discard : execc. + +Lemma merge_discard2 E A (e : t E A) : merge e discard = e. +Proof. destruct e; hauto db:list. Qed. +#[global] Hint Rewrite merge_discard2 : exec. +#[global] Hint Rewrite merge_discard2 : execc. + +Lemma mbind_cons E A B (x : A) (l : list A) (f : A -> t E B): + Results (x :: l) ≫= f = + merge (f x) (Results l ≫= f). + cbn. + destruct (f x) as [|lx]; [ by exec_simp| clear x]. + - generalize dependent lx. + induction (map f l) as [| y lt]; hauto use: app_assoc inv:t db:exec,list. +Qed. +#[global] Hint Rewrite mbind_cons : exec. +#[global] Hint Rewrite mbind_cons : execc. + +Opaque mbind_inst. + + +(*** Predicate on the results ***) + +(** Describe an non-error execution *) +Inductive has_results {E A} : t E A -> Prop := +| HResults l : has_results (Results l). +#[global] Hint Constructors has_results : exec. + +(** Describe the fact that an execution is successful and contains the + specified value *) +Inductive elem_of {E A} : ElemOf A (t E A):= +| ElemOf x l : x ∈ l -> elem_of x (Results l). +#[global] Hint Constructors elem_of : exec. +Global Existing Instance elem_of. + +Lemma elem_of_has_results E A (e : t E A) x : x ∈ e -> has_results e. +Proof. sauto lq:on. Qed. +#[global] Hint Resolve elem_of_has_results : exec. +#[global] Hint Resolve elem_of_has_results : execc. + + + +(*** Exec unfolding ***) + +Class ExecUnfold (P Q : Prop) := { exec_unfold : P ↔ Q }. +Global Arguments exec_unfold _ _ {_} : assert. +Global Hint Mode ExecUnfold + - : typeclass_instances. + +Global Instance exec_unfold_default P : ExecUnfold P P | 1000. done. Qed. +Definition exec_unfold_1 `{ExecUnfold P Q} : P → Q := proj1 (exec_unfold P Q). +Definition exec_unfold_2 `{ExecUnfold P Q} : Q → P := proj2 (exec_unfold P Q). + +Tactic Notation "exec_unfold" := + let rec unfold_hyps := + try match goal with + | H : ?P |- _ => + lazymatch type of P with + | Prop => + apply exec_unfold_1 in H; revert H; + first [unfold_hyps; intros H | intros H; fail 1] + | _ => fail + end + end in + apply exec_unfold_2; unfold_hyps; csimpl in *. + +Tactic Notation "exec_unfold" "in" ident(H) := + let P := type of H in + lazymatch type of P with + | Prop => apply exec_unfold_1 in H + | _ => fail "hypothesis" H "is not a proposition" + end. + + +Class UnfoldElemOf {A E} (x : A) (e : t E A) (Q : Prop) := + {unfold_elem_of : x ∈ e <-> Q}. +Arguments unfold_elem_of {_ _} _ _ _ {_} : assert. +Global Hint Mode UnfoldElemOf + + - + - : typeclass_instances. + +Global Instance unfold_elem_of_exec_unfold {A E} (x : A) (e : t E A) Q : + UnfoldElemOf x e Q → ExecUnfold (x ∈ e) Q. +Proof. sfirstorder. Qed. +Global Instance unfold_elem_of_default {A E} (x : A) (e : t E A) : + UnfoldElemOf x e (x ∈ e) | 1000. +Proof. done. Qed. + +Global Instance unfold_elem_of_let_pair {A B C E} (x : A) (p : B * C) (e : B -> C -> t E A) Q : + (forall y z, UnfoldElemOf x (e y z) (Q y z)) -> + UnfoldElemOf x (let '(y, z) := p in e y z) (let '(y, z) := p in Q y z). +Proof. by destruct p. Qed. + + +Class UnfoldHasResults {A E} (e : t E A) (Q : Prop) := + {unfold_has_results : has_results e <-> Q}. +Global Hint Mode UnfoldHasResults + + + - : typeclass_instances. + +Global Instance unfold_has_results_exec_unfold {A E} (e : t E A) Q : + UnfoldHasResults e Q → ExecUnfold (has_results e) Q. +Proof. sfirstorder. Qed. +Global Instance unfold_has_results_default {A E} (e : t E A) : + UnfoldHasResults e (has_results e) | 1000. +Proof. done. Qed. + +Global Instance unfold_has_result_let_pair {A B C E} (p : B * C) (e : B -> C -> t E A) Q : + (forall y z, UnfoldHasResults (e y z) (Q y z)) -> + UnfoldHasResults (let '(y, z) := p in e y z) (let '(y, z) := p in Q y z). +Proof. by destruct p. Qed. + +Global Instance UnfoldElemOf_proper {A E} : + Proper (@eq A ==> @eq (t E A) ==> iff ==> iff) UnfoldElemOf. +Proof. solve_proper2_tc. Qed. + +Global Instance UnfoldHasResults_proper {A E} : + Proper (@eq (t E A) ==> iff ==> iff) UnfoldHasResults. +Proof. solve_proper2_tc. Qed. + +(** Importing this will make set_unfold also unfold exec values *) +Module SetUnfoldExecUnfold. + + #[export] Instance unfold_has_results_set_unfold {A E} (e : t E A) Q : + UnfoldHasResults e Q → SetUnfold (has_results e) Q. + Proof. sfirstorder. Qed. + + #[export] Instance unfold_elem_of_set_unfold_elemOf {A E} (x : A) (e : t E A) Q : + UnfoldElemOf x e Q → SetUnfoldElemOf x e Q. + Proof. sfirstorder. Qed. +End SetUnfoldExecUnfold. + +Import SetUnfoldExecUnfold. + +Lemma exec_unfold_impl P Q P' Q' : + ExecUnfold P P' → ExecUnfold Q Q' → ExecUnfold (P → Q) (P' → Q'). +Proof. constructor. by rewrite (exec_unfold P P'), (exec_unfold Q Q'). Qed. +Lemma exec_unfold_and P Q P' Q' : + ExecUnfold P P' → ExecUnfold Q Q' → ExecUnfold (P ∧ Q) (P' ∧ Q'). +Proof. constructor. by rewrite (exec_unfold P P'), (exec_unfold Q Q'). Qed. +Lemma exec_unfold_or P Q P' Q' : + ExecUnfold P P' → ExecUnfold Q Q' → ExecUnfold (P ∨ Q) (P' ∨ Q'). +Proof. constructor. by rewrite (exec_unfold P P'), (exec_unfold Q Q'). Qed. +Lemma exec_unfold_iff P Q P' Q' : + ExecUnfold P P' → ExecUnfold Q Q' → ExecUnfold (P ↔ Q) (P' ↔ Q'). +Proof. constructor. by rewrite (exec_unfold P P'), (exec_unfold Q Q'). Qed. +Lemma exec_unfold_not P P' : ExecUnfold P P' → ExecUnfold (¬P) (¬P'). +Proof. constructor. by rewrite (exec_unfold P P'). Qed. +Lemma exec_unfold_forall {A} (P P' : A → Prop) : + (∀ x, ExecUnfold (P x) (P' x)) → ExecUnfold (∀ x, P x) (∀ x, P' x). +Proof. constructor. naive_solver. Qed. +Lemma exec_unfold_exist {A} (P P' : A → Prop) : + (∀ x, ExecUnfold (P x) (P' x)) → ExecUnfold (∃ x, P x) (∃ x, P' x). +Proof. constructor. naive_solver. Qed. + +(* Avoid too eager application of the above instances (and thus too eager +unfolding of type class transparent definitions). *) +Global Hint Extern 0 (ExecUnfold (_ → _) _) => + class_apply exec_unfold_impl : typeclass_instances. +Global Hint Extern 0 (ExecUnfold (_ ∧ _) _) => + class_apply exec_unfold_and : typeclass_instances. +Global Hint Extern 0 (ExecUnfold (_ ∨ _) _) => + class_apply exec_unfold_or : typeclass_instances. +Global Hint Extern 0 (ExecUnfold (_ ↔ _) _) => + class_apply exec_unfold_iff : typeclass_instances. +Global Hint Extern 0 (ExecUnfold (¬ _) _) => + class_apply exec_unfold_not : typeclass_instances. +Global Hint Extern 1 (ExecUnfold (∀ _, _) _) => + class_apply exec_unfold_forall : typeclass_instances. +Global Hint Extern 0 (ExecUnfold (∃ _, _) _) => + class_apply exec_unfold_exist : typeclass_instances. + +(********** Simplification with the predicates **********) + +Global Instance unfold_has_results_error E A err : + UnfoldHasResults (Error err : t E A) False. +Proof. sauto. Qed. + +Lemma has_results_error E A err: has_results (Error err : t E A) <-> False. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite has_results_error : exec. + +Global Instance unfold_elem_of_error E A x err : + UnfoldElemOf x (Error err : t E A) False. +Proof. sauto. Qed. + +Lemma elem_of_error E A (err : E) (x : A) : x ∈ (Error err) <-> False. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite elem_of_error : exec. + +Global Instance unfold_elem_of_discard E A x : + UnfoldElemOf x (discard : t E A) False. +Proof. sauto. Qed. + +Lemma elem_of_discard E A (x : A) : x ∈ (discard : t E A) <-> False. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite elem_of_discard: exec. + +Global Instance unfold_has_results_results E A l : + UnfoldHasResults (Results l : t E A) True. +Proof. sauto. Qed. + +Lemma has_results_results E A l : has_results (Results l : t E A). +Proof. by exec_unfold. Qed. +#[global] Hint Resolve has_results_results : exec. +#[global] Hint Rewrite (fun E A l => Prop_for_rewrite $ has_results_results E A l) : exec. + +Global Instance unfold_elem_of_results E A x l Q : + SetUnfoldElemOf x l Q -> UnfoldElemOf x (Results l : t E A) Q. +Proof. sauto lq:on. Qed. + +Lemma elem_of_results E A (x : A) l : x ∈ (Results l : t E A) <-> x ∈ l. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite elem_of_results : exec. + +Global Instance unfold_has_results_merge E A (e e' : t E A) Q Q' : + UnfoldHasResults e Q -> UnfoldHasResults e' Q' -> + UnfoldHasResults (merge e e') (Q /\ Q'). +Proof. + tcclean. + destruct e; destruct e'; hauto inv:has_results db:list simp+:exec_unfold. +Qed. + +Lemma has_results_merge E A (e e' : t E A) : + has_results (merge e e') <-> has_results e /\ has_results e'. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite has_results_merge : exec. + +Global Instance unfold_elem_of_merge E A (e e' : t E A) x P P' Q Q' : + UnfoldHasResults e P -> UnfoldElemOf x e Q -> + UnfoldHasResults e' P' -> UnfoldElemOf x e' Q' -> + UnfoldElemOf x (merge e e') (P' /\ Q \/ P /\ Q'). +Proof. + tcclean. + destruct e; destruct e'; cbn in *; exec_unfold; firstorder. +Qed. + +Lemma elem_of_merge E A (e e' : t E A) x : + x ∈ (merge e e') <-> + (x ∈ e /\ has_results e') \/ (has_results e /\ x ∈ e'). +Proof. exec_unfold; firstorder. Qed. +#[global] Hint Rewrite elem_of_merge : exec. + +Global Instance unfold_has_result_ret E A (y : A) : + UnfoldHasResults (ret y : t E A) True. +Proof. sauto. Qed. + +Global Instance unfold_elem_of_ret E A (x y : A) : + UnfoldElemOf x (ret y : t E A) (x = y). +Proof. sauto. Qed. + +Lemma elem_of_ret E A (x y :A) : x ∈ (ret y : t E A) <-> x = y. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite elem_of_ret : exec. + +Global Instance unfold_has_result_error_none E A (err : E) (opt : option A) : + UnfoldHasResults (error_none err opt) (is_Some opt). +Proof. sauto lq:on rew:off. Qed. + +Lemma has_results_error_none E A (err : E) opt : + has_results (error_none err opt) <-> exists x : A, opt = Some x. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite has_results_error_none : exec. + +Global Instance unfold_elem_error_none E A (err : E) (x : A) (opt : option A) : + UnfoldElemOf x (error_none err opt) (opt = Some x). +Proof. sauto lq:on rew:off. Qed. + +Lemma elem_of_error_none E A (x : A) (err : E) opt : + x ∈ (error_none err opt) <-> opt = Some x. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite elem_of_error_none : exec. + +Global Instance unfold_has_result_map_error E E' A (f : E -> E') (e : t E A) Q : + UnfoldHasResults e Q -> UnfoldHasResults (map_error f e) Q. +Proof. destruct e; sauto lq:on. Qed. + +Lemma has_results_map_error E E' A (e : t E A) (f : E -> E') : + has_results (map_error f e) <-> has_results e. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite has_results_map_error : exec. + +Global Instance unfold_elem_of_map_error E E' A (f : E -> E') (e : t E A) x Q : + UnfoldElemOf x e Q -> UnfoldElemOf x (map_error f e) Q. +Proof. destruct e; sauto lq:on. Qed. + +Lemma elem_of_map_error E E' A (x : A) (e : t E A) (f : E -> E') : + x ∈ (map_error f e) <-> x ∈ e. +Proof. by exec_unfold. Qed. +#[global] Hint Rewrite elem_of_map_error : exec. + +Global Instance unfold_has_result_choose E A `{Finite A} : + UnfoldHasResults (choose A : t E A) True. +Proof. sfirstorder. Qed. + +Lemma has_results_choose E A `{Finite A}: + has_results (choose A : t E A). +Proof. by exec_unfold. Qed. +#[global] Hint Resolve has_results_choose : exec. +#[global] Hint Rewrite (fun E A `{Finite A} => Prop_for_rewrite (has_results_choose E A)) : exec. + +Global Instance unfold_elem_of_choose E A `{Finite A} x : + UnfoldElemOf x (choose A : t E A) True. +Proof. sauto lq:on. Qed. + +Lemma elem_of_choose E A `{Finite A} x: + x ∈ (choose A : t E A). +Proof. by exec_unfold. Qed. +#[global] Hint Resolve elem_of_choose : exec. +#[global] Hint Rewrite (fun E A `{Finite A} x => Prop_for_rewrite (elem_of_choose E A x)) : exec. + + +Global Instance unfold_has_result_fail_if E (b : bool) (e : E) : + UnfoldHasResults (fail_if b e : t E ()) (¬b). +Proof. tcclean. sauto lq:on rew:off. Qed. + +Global Instance unfold_elem_of_fail_if E x (b : bool) (e : E) : + UnfoldElemOf x (fail_if b e : t E ()) (¬b). +Proof. tcclean. sauto lq:on rew:off. Qed. + + +Global Instance unfold_has_result_assert E (b : bool) (e : E) : + UnfoldHasResults (assert b : t E ()) True. +Proof. tcclean. sauto lq:on rew:off. Qed. + +Global Instance unfold_elem_of_assert E x (b : bool) (e : E) : + UnfoldElemOf x (assert b : t E ()) b. +Proof. tcclean. sauto lq:on rew:off. Qed. + + +Lemma has_results_results_mbind E A B (l : list A) (f : A -> t E B): + has_results (Results l ≫= f) <-> ∀'z ∈ l, has_results (f z). +Proof. + induction l; hauto simp+:set_unfold l:on db:exec. +Qed. + + +Lemma has_results_results_mbind' E A B (l : list A) (f : A -> t E B): + has_results (Results l ≫= f) <-> ∀'z ∈ l, has_results (f z). +Proof. + induction l; hauto lq:on db:execc simp+:set_unfold. +Qed. + +Local Instance unfold_has_results_results_mbind E A B l (f : A -> t E B) P Q: + (forall z, SetUnfoldElemOf z l (P z)) -> (forall z, UnfoldHasResults (f z) (Q z)) -> + UnfoldHasResults (Results l ≫= f) (forall z, P z -> Q z). +Proof. tcclean. apply has_results_results_mbind. Qed. + +Lemma elem_of_results_mbind E A B (x : B) (l : list A) (f: A -> t E B) : + x ∈ (Results l ≫= f) <-> (∃'y ∈ l, x ∈ (f y)) /\ ∀'z ∈ l, has_results (f z). +Proof. + induction l. + - hauto inv:elem_of_list lq:on db:exec. + - exec_simp. + rewrite has_results_results_mbind. + hauto + inv:elem_of_list ctrs:elem_of_list lq:on hint:db:exec. +Qed. + + +Lemma elem_of_results_mbind' E A B (x : B) (l : list A) (f: A -> t E B) : + x ∈ (Results l ≫= f) <-> (∃'y ∈ l, x ∈ (f y)) /\ ∀'z ∈ l, has_results (f z). +Proof. + induction l. + - autorewrite with execc. + set_solver. + - autorewrite with execc. + set_unfold. + hauto lq:on hint:db:execc. +Qed. + + + +Global Instance unfold_elem_of_results_mbind E A B x l (f : A -> t E B) P Q R: + (forall z, SetUnfoldElemOf z l (P z)) -> + (forall z, UnfoldHasResults (f z) (Q z)) -> + (forall z, UnfoldElemOf x (f z) (R z)) -> + UnfoldElemOf x (Results l ≫= f) ((exists z, P z /\ R z) /\ forall z, P z -> Q z). +Proof. tcclean. apply elem_of_results_mbind. Qed. + + + +Lemma has_results_mbind E A B (e : t E A) (f : A -> t E B): + has_results (e ≫= f) <-> + has_results e /\ ∀'z ∈ e, has_results (f z). +Proof. + destruct e. + - hauto inv:has_results. + - rewrite has_results_results_mbind. + hauto lq:on db:list simp+:exec_simp. +Qed. +#[global] Hint Rewrite has_results_mbind : exec. + +Lemma has_results_mbind' E A B (e : t E A) (f : A -> t E B): + has_results (e ≫= f) <-> + has_results e /\ ∀'z ∈ e, has_results (f z). +Proof. + destruct e; hauto l:on simp+:exec_unfold db:execc. +Qed. + +Global Instance unfold_has_results_mbind E A B e (f : A -> t E B) P Q R: + UnfoldHasResults e P -> + (forall z, UnfoldElemOf z e (Q z)) -> + (forall z, UnfoldHasResults (f z) (R z)) -> + UnfoldHasResults (e ≫= f) (P /\ forall z, Q z -> R z). +Proof. tcclean. apply has_results_mbind. Qed. + +Lemma elem_of_mbind E A B (x : B) e (f: A -> t E B) : + x ∈ (e ≫= f) <-> (∃'y ∈ e, x ∈ (f y)) /\ (∀'z ∈ e, has_results (f z)). +Proof. + destruct e. + - hauto inv:elem_of. + - rewrite elem_of_results_mbind. + hauto db:list simp+:exec_simp. +Qed. +#[global] Hint Rewrite elem_of_mbind : exec. + +Lemma elem_of_mbind' E A B (x : B) e (f: A -> t E B) : + x ∈ (e ≫= f) <-> (∃'y ∈ e, x ∈ (f y)) /\ (∀'z ∈ e, has_results (f z)). +Proof. + destruct e; hauto l:on simp+:exec_unfold db:execc. +Qed. + +Global Instance unfold_elem_of_mbind E A B x e (f : A -> t E B) P Q R: + (forall z, UnfoldElemOf z e (P z)) -> + (forall z, UnfoldHasResults (f z) (Q z)) -> + (forall z, UnfoldElemOf x (f z) (R z)) -> + UnfoldElemOf x (e ≫= f) ((exists z, P z /\ R z) /\ (forall z, P z -> Q z)). +Proof. tcclean. apply elem_of_mbind. Qed. + +(* This is an optimisation of the previous rewriting rules *) +Lemma elem_of_error_none_mbind E A B (x : B) (f: A -> t E B) err opt : + x ∈ (error_none err opt ≫= f) <-> exists y, opt = Some y /\ x ∈ (f y). +Proof. + hauto db:execc simp+:exec_unfold. Qed. +#[global] Hint Rewrite elem_of_error_none_mbind : exec. + +Global Instance unfold_elem_of_error_none_mbind + E A B (x : B) (f: A -> t E B) err opt P: + (forall z, UnfoldElemOf x (f z) (P z)) -> + UnfoldElemOf x (error_none err opt ≫= f) (exists y, opt = Some y /\ P y). +Proof. tcclean. apply elem_of_error_none_mbind. Qed. + +Ltac dest_unit := + match goal with + | u : () |- _ => destruct u + end. + +Global Instance unfold_elem_of_fail_if_mbind + E B (x : B) (f: () -> t E B) b e P: + UnfoldElemOf x (f ()) P -> + UnfoldElemOf x (fail_if b e ≫= f) (¬ b /\ P). +Proof. tcclean. sauto simp+:dest_unit simp+:exec_unfold. Qed. + +Global Instance unfold_elem_of_assert_mbind + E B (x : B) (f: () -> t E B) b P: + UnfoldElemOf x (f ()) P -> + UnfoldElemOf x (assert b ≫= f) (b /\ P). +Proof. + tcclean. + unfold assert. + case_split; autorewrite with execc; set_solver. +Qed. + + + + + +(********** Inclusion of execution **********) + +(** A execution being included in another means that a success in the + first implies a success in the second and all elements in the first + are also in the second *) +Definition Incl {E E' A B} (f : A -> B) (e : t E A) (e' : t E' B) : Prop := + (has_results e -> has_results e') /\ + ∀'x ∈ e, (f x) ∈ e'. + +Lemma Incl_elem_of E A B (e : t E A) (e' : t E B) x f : + Incl f e e' -> x ∈ e -> (f x) ∈ e'. +Proof. firstorder. Qed. + +Lemma Incl_has_results E A (e e' : t E A) f : + Incl f e e' -> has_results e -> has_results e'. +Proof. firstorder. Qed. + +End Exec. + +(* Copy paste of the tactics: delete in Coq 8.15 and import tactics instead *) + +Tactic Notation "exec_unfold" := + let rec unfold_hyps := + try match goal with + | H : ?P |- _ => + lazymatch type of P with + | Prop => + apply Exec.exec_unfold_1 in H; revert H; + first [unfold_hyps; intros H | intros H; fail 1] + | _ => fail + end + end in + apply Exec.exec_unfold_2; unfold_hyps; csimpl in *. + +Tactic Notation "exec_unfold" "in" ident(H) := + let P := type of H in + lazymatch type of P with + | Prop => apply Exec.exec_unfold_1 in H; csimpl in H + | _ => fail "hypothesis" H "is not a proposition" + end. diff --git a/system-semantics/Common/GRel.v b/system-semantics/Common/GRel.v new file mode 100644 index 0000000..d7fb5d2 --- /dev/null +++ b/system-semantics/Common/GRel.v @@ -0,0 +1,890 @@ +(** This file define a relation using a gset from stdpp that is entirely + computable and whose standard relational operators are also computable. The + type is [grel A] + + All relations in this file are finite, which means that any notions in this + file related to reflexivity require the type on which we are doing relations + to also be finite. For that reason, this library prefer to define a + transitive closure (r⁺) but no reflexive transitive closure. If the type if + finite (implement the Finite typeclass from stdpp), there is a reflexive + closure (r?) and thus the reflexive transitive closure can be obtained with: + r?⁺ + + Since relation are just gset of pair, the usual && and | operation on + relation can just be obtained with the standard ∪ and ∩. + + Sequence is obtained with r⨾r' and a set s is converted to a diagonal + relation with ⦗s⦘. *) + +Require Import Wellfounded. + +From stdpp Require Export option. +Require Import Common. + +(* For some reason some typeclass instance defined in CSets is missing even if + Common export CSets *) +Require Import CSets. + +Import SetUnfoldPair. + + +(* Obviously not complete but useful *) +Lemma iff_forall_swap A P Q : + (forall a : A, P a <-> Q a) -> (forall a, P a) <-> (forall a, Q a). +Proof. sfirstorder. Qed. +#[global] Hint Resolve iff_forall_swap : core. + + +(*** Maps of sets utilities ***) + +(** Union of set options, that merge two options, using the union in case of two +Some. Useful for map of set merging *) +Definition option_union `{Union A} (ov1 ov2 : option A) : option A := + match ov1 with + | None => ov2 + | Some v1 => + match ov2 with + | None => Some v1 + | Some v2 => Some (v1 ∪ v2) + end + end. + +Infix "∪ₒ" := option_union (at level 50, left associativity) : stdpp_scope. +Notation "(∪ₒ)" := option_union (only parsing) : stdpp_scope. +Notation "( x ∪ₒ.)" := (option_union x) (only parsing) : stdpp_scope. +Notation "(.∪ₒ x )" := (λ y, option_union y x) (only parsing) : stdpp_scope. + + +(** Define a pointwise union of map of sets. If both maps contains a set for a given key, then the + result contains the unions of the sets for that key. *) +Definition pointwise_union `{FinMap K M} `{Union A} : M A -> M A -> M A := + merge (∪ₒ). + +Infix "∪ₘ" := pointwise_union (at level 50, left associativity) : stdpp_scope. +Notation "(∪ₘ)" := pointwise_union (only parsing) : stdpp_scope. +Notation "( x ∪ₘ.)" := (pointwise_union x) (only parsing) : stdpp_scope. +Notation "(.∪ₘ x )" := (λ y, pointwise_union y x) (only parsing) : stdpp_scope. + +Global Instance lookup_unfold_pointwise_union `{FinMap K M} `{Union A} + (k : K) (m1 m2 : M A) (o1 o2 : option A) : + LookupUnfold k m1 o1 -> LookupUnfold k m2 o2 -> + LookupUnfold k (m1 ∪ₘ m2) (o1 ∪ₒ o2). +Proof. tcclean. rewrite lookup_unfold. reflexivity. Qed. + +Global Instance lookup_total_unfold_pointwise_union `{FinMap K M} `{SemiSet A C} + {lei : LeibnizEquiv C} (k : K) (m1 m2 : M C) (s1 s2 : C) : + LookupTotalUnfold k m1 s1 -> LookupTotalUnfold k m2 s2 -> + LookupTotalUnfold k (m1 ∪ₘ m2) (s1 ∪ s2). +Proof. + tcclean. + setoid_rewrite lookup_total_lookup. + rewrite lookup_unfold. + cbn. + unfold option_union. + case_splitting; set_solver. +Qed. + +(** Import this module to make set_unfold use the LookupTotalUnfold typeclass + when unfolding a set that is the result of a total lookup. *) +Module SetUnfoldLookupTotal. + #[export] Instance set_unfold_lookup_total `{ElemOf A C} `{LookupTotal K C M} + x a (m : M) (s : C) Q: + LookupTotalUnfold a m s -> + Unconvertible C (m !!! a) s -> + SetUnfoldElemOf x s Q -> + SetUnfoldElemOf x (m !!! a) Q. + Proof. tcclean. reflexivity. Qed. + +End SetUnfoldLookupTotal. + +(* This is not automatically imported by any file importing this file but might +be useful *) +Import SetUnfoldLookupTotal. + + + +(*** Grels ***) + +Section GRel. + Context {A : Type}. + Context {eqA : EqDecision A}. + Context {countA : Countable A}. + + Definition grel := gset (A * A). + + Definition grel_to_relation (r : grel) : relation A := fun x y => (x, y) ∈ r. + + Definition grel_map := gmap A (gset A). + + Definition grel_to_map (r : grel) : grel_map := + set_fold (fun '(e1, e2) res => res ∪ₘ {[e1 := {[e2]}]}) ∅ r. + + Definition gmap_to_rel (rm : grel_map) : grel := + map_fold (fun e1 se2 res => res ∪ (set_map (e1,.) se2)) ∅ rm. + + Definition grel_map_wf (rm : grel_map) := forall a : A, rm !! a ≠ Some ∅. + + (** Hack to add to sauto when rewrite just fails for no reason *) + Local Ltac auto_setoid_rewrite := + repeat (match goal with | H : _ = _ |- _ => setoid_rewrite H end). + + + (* Set Printing All. *) + + Lemma grel_map_eq_wf (rm rm' : grel_map): + grel_map_wf rm -> grel_map_wf rm' -> (forall a : A, rm !!! a = rm' !!! a) -> rm = rm'. + Proof using. + intros WF WF' P. + apply map_eq. + intro i. + pose proof (P i) as P. + unfold grel_map_wf in *. + setoid_rewrite lookup_total_lookup in P. + unfold default in *. + case_splitting; naive_solver. + Qed. + + Lemma grel_to_map_spec r e1 e2: + e2 ∈ (grel_to_map r !!! e1) <-> (e1, e2) ∈ r. + Proof using. + unfold grel_to_map. + cinduction r using set_fold_cind_L. + - set_solver. + - destruct x as [e3 e4]. + set_unfold. + case_split; naive_solver. + Qed. + Hint Rewrite @grel_to_map_spec : grel. + + Global Instance set_unfold_elem_of_grel_to_map r x y P : + SetUnfoldElemOf (y, x) r P -> + SetUnfoldElemOf x (grel_to_map r !!! y) P. + Proof using. tcclean. apply grel_to_map_spec. Qed. + + Lemma grel_to_map_wf r: grel_map_wf (grel_to_map r). + Proof using. + unfold grel_map_wf. + intro a. + unfold grel_to_map. + cinduction r using set_fold_cind_L. + - rewrite lookup_unfold. congruence. + - destruct x as [e3 e4]. + rewrite lookup_unfold. + unfold option_union. + unfold grel_map in *. + case_splitting; (congruence || set_solver). + Qed. + Hint Resolve grel_to_map_wf : grel. + + + Lemma grel_map_wf_union rm rm': + grel_map_wf rm -> grel_map_wf rm' -> grel_map_wf (rm ∪ₘ rm'). + Proof using. + intros H H' a Hc. + setoid_rewrite lookup_unfold in Hc. + unfold option_union in Hc. + unfold grel_map_wf in *. + hauto db:set lq:on. + Qed. + Hint Resolve grel_map_wf_union : grel. + + Lemma gmap_to_rel_spec rm e1 e2: + (e1, e2) ∈ gmap_to_rel rm <-> e2 ∈ (rm !!! e1). + Proof using. + unfold gmap_to_rel. + cinduction rm using map_fold_cind. + - rewrite lookup_total_unfold. + set_solver. + - assert (m !!! i = ∅). {rewrite lookup_total_lookup. hauto lq:on. } + setoid_rewrite lookup_total_unfold. + set_unfold. hauto q:on. + Qed. + Hint Rewrite gmap_to_rel_spec : grel. + + Global Instance set_unfold_elem_of_gmap_to_rel rm x s P : + LookupTotalUnfold x.1 rm s -> + SetUnfoldElemOf x.2 s P -> + SetUnfoldElemOf x (gmap_to_rel rm) P. + Proof using. tcclean. apply gmap_to_rel_spec. Qed. + + + Lemma grel_to_map_empty : + grel_to_map ∅ = ∅. + Proof using. sfirstorder. Qed. + Hint Rewrite grel_to_map_empty : grel. + + Lemma grel_to_map_union (r1 r2 : grel) : + grel_to_map (r1 ∪ r2) = grel_to_map r1 ∪ₘ grel_to_map r2. + Proof using. + apply grel_map_eq_wf; [auto with grel .. |]. + intro a. + setoid_rewrite lookup_total_unfold. + set_unfold. + hauto lq:on db:grel. + Qed. + Hint Rewrite grel_to_map_union : grel. + + Lemma grel_to_map_to_rel (r : grel) : + r |> grel_to_map |> gmap_to_rel = r. + Proof using. set_unfold. hauto lq:on. Qed. + Hint Rewrite grel_to_map_to_rel : grel. + + + Lemma gmap_to_rel_to_map (rm : grel_map) : + grel_map_wf rm -> rm |> gmap_to_rel |> grel_to_map = rm. + Proof using. + intro H. + apply grel_map_eq_wf; [auto with grel .. |]. + set_solver. + Qed. + Hint Rewrite gmap_to_rel_to_map using auto with grel : grel. + + (*** Sequence ***) + + Definition grel_dom (r : grel) : gset A := set_map fst r. + Definition grel_rng (r : grel) : gset A := set_map snd r. + + Global Instance set_unfold_elem_of_grel_dom (r : grel) (x : A) P: + (forall y, SetUnfoldElemOf (x, y) r (P y)) -> + SetUnfoldElemOf x (grel_dom r) (exists z, P z). + Proof using. tcclean. set_unfold. hauto db:core. Qed. + + Global Instance set_unfold_elem_of_grel_rng (r : grel) (x : A) P: + (forall y, SetUnfoldElemOf (y, x) r (P y)) -> + SetUnfoldElemOf x (grel_rng r) (exists z, P z). + Proof using. tcclean. set_unfold. hauto db:core. Qed. + + Lemma grel_dom_union r r': + grel_dom (r ∪ r') = grel_dom r ∪ grel_dom r'. + Proof. set_unfold. hauto. Qed. + Hint Rewrite grel_dom_union : grel. + + Lemma grel_rng_union r r': + grel_rng (r ∪ r') = grel_rng r ∪ grel_rng r'. + Proof. set_unfold. hauto. Qed. + Hint Rewrite grel_rng_union : grel. + + + Typeclasses Opaque grel_dom. + Typeclasses Opaque grel_rng. + + (*** Sequence ***) + + Definition grel_seq (r r' : grel) : grel := + let rm := grel_to_map r' in + set_fold (fun '(e1, e2) res => res ∪ set_map (e1,.) (rm !!! e2)) ∅ r. + Infix "⨾" := grel_seq (at level 44, left associativity) : stdpp_scope. + + Lemma grel_seq_spec r r' e1 e2 : + (e1, e2) ∈ (r ⨾ r') <-> exists e3, (e1, e3) ∈ r /\ (e3, e2) ∈ r'. + Proof using. + unfold grel_seq. + cinduction r using set_fold_cind_L. + - set_solver. + - destruct x. + set_unfold. + hauto q:on. + Qed. + + Global Instance set_unfold_elem_of_grel_seq r r' x P Q: + (forall z, SetUnfoldElemOf (x.1, z) r (P z)) -> + (forall z, SetUnfoldElemOf (z, x.2) r' (Q z)) -> + SetUnfoldElemOf x (r ⨾ r') (exists z, P z /\ Q z). + Proof using. tcclean. apply grel_seq_spec. Qed. + + Lemma grel_seq_dom r r' : + grel_dom (r ⨾ r') ⊆ grel_dom r. + Proof. set_unfold. hauto. Qed. + + Lemma grel_seq_rng r r' : + grel_rng (r ⨾ r') ⊆ grel_rng r'. + Proof. set_unfold. hauto. Qed. + + (*** Inversion ***) + + Definition grel_inv : grel -> grel := set_map (fun x => (x.2, x.1)). + Notation "r ⁻¹" := (grel_inv r) (at level 1) : stdpp_scope. + + Lemma grel_inv_spec r e1 e2 : (e1, e2) ∈ r⁻¹ <-> (e2, e1) ∈ r. + Proof using. unfold grel_inv. set_unfold. hauto db:core. Qed. + + Global Instance set_unfold_elem_of_grel_inv r x P: + SetUnfoldElemOf (x.2, x.1) r P -> SetUnfoldElemOf x r⁻¹ P. + Proof using. tcclean. apply grel_inv_spec. Qed. + + Lemma grel_inv_inv (r : grel) : (r⁻¹)⁻¹ = r. + Proof using. set_solver. Qed. + Hint Rewrite grel_inv_inv : grel. + + Lemma grel_inv_dom r : + grel_dom (r⁻¹) = grel_rng r. + Proof. set_unfold. hauto. Qed. + Hint Rewrite grel_inv_dom : grel. + + Lemma grel_inv_rng r : + grel_rng (r⁻¹) = grel_dom r. + Proof. set_unfold. hauto. Qed. + Hint Rewrite grel_inv_rng : grel. + + Typeclasses Opaque grel_inv. + + + (*** Set into rel ***) + + Definition grel_from_set (s : gset A) : grel := set_map (fun x => (x, x)) s. + + Notation "⦗ a ⦘" := (grel_from_set a) (format "⦗ a ⦘") : stdpp_scope. + + Lemma grel_from_set_spec (s : gset A) x y : (x, y) ∈ ⦗s⦘ <-> x ∈ s /\ x = y. + Proof using. unfold grel_from_set. set_solver. Qed. + + Global Instance set_unfold_elem_of_grel_from_set s x P: + SetUnfoldElemOf x.1 s P -> + SetUnfoldElemOf x ⦗s⦘ (P /\ x.1 = x.2). + Proof using. tcclean. apply grel_from_set_spec. Qed. + + Typeclasses Opaque grel_from_set. + + + (*** Transitive closure ***) + + (** Decides if there exists a path between x and y in r that goes only through + points in l. x and y themselves don't need to be in l *) + Fixpoint exists_path (r : grel) (l : list A) (x y : A) : bool := + match l with + | [] => bool_decide ((x,y) ∈ r) + | a :: t => + exists_path r t x y || (exists_path r t x a && exists_path r t a y) + end. + + (** State that l is a path between x and y in r *) + Fixpoint is_path (r : grel) (x y : A) (l : list A) : Prop := + match l with + | [] => (x, y) ∈ r + | a :: t => (x, a) ∈ r /\ is_path r a y t + end. + + (* Existence of a path implies being in the transitive closure *) + Lemma is_path_tc r x y path : + is_path r x y path -> tc (grel_to_relation r) x y. + Proof using. + generalize dependent x. + induction path; sauto lq:on rew:off. + Qed. + + (** Equivalent definition of exists_path using is_path, and in Prop *) + Definition exists_path' (r : grel) (l : list A) (x y : A) := + exists path : list A, + is_path r x y path /\ NoDup path /\ ∀' p ∈ path, p ∈ l. + + (* If a list contains an element it can be splitted on that element *) + Lemma list_split (l : list A) x : + x ∈ l -> exists left right, l = left ++ [x] ++ right. + Proof using. + intros H. + induction l. { set_solver. } + set_unfold in H. + destruct H as [H | H]. + - exists []. + exists l. + set_solver. + - apply IHl in H as [left [right H]]. + clear IHl. + exists (a :: left). + exists right. + set_solver. + Qed. + + (* Split a path on a point *) + Lemma is_path_split r x y a left right : + is_path r x y (left ++ [a] ++ right) <-> + is_path r x a left /\ is_path r a y right. + Proof using. + generalize dependent x. + induction left. + - naive_solver. + - cbn in *. + intro x. + rewrite IHleft. + naive_solver. + Qed. + + (* Induction on list length, very convenient *) + Definition length_ind := (well_founded_ind + (wf_inverse_image (list A) nat _ (@length _) + lt_wf)). + + (* If there is a path, there a path without duplicate that is a subpath. + Technically this asserts only subset *) + Lemma is_path_NoDup r x y path : + is_path r x y path -> exists npath, is_path r x y npath /\ NoDup npath /\ npath ⊆ path. + Proof using. + generalize dependent x. + induction path using length_ind. + intros x IP. + destruct path. {exists []. sauto lq:on simp+:set_unfold. } + cbn in *. + destruct (decide (a ∈ path)). + - apply list_split in e as (left & right & ->). + rewrite is_path_split in IP. + feed pose proof (H (a :: right)) as H'. {rewrite app_length. cbn. lia. } + feed destruct (H' x) as [npath H'']. naive_solver. + exists npath. set_solver. + - feed pose proof (H path) as H'; [lia |]. + feed destruct (H' a) as [npath H'']; [set_solver .. |]. + exists (a :: npath). + rewrite NoDup_cons. + set_solver. + Qed. + + + + (* Proof that exists_path' satisfies the equation defining exists_path *) + Lemma exists_path'_add_one r l a x y : + exists_path' r (a :: l) x y <-> + exists_path' r l x y \/ (exists_path' r l x a /\ exists_path' r l a y). + Proof using. + split. + - intros [path [Hip [HND Hl]]]. + destruct (decide (a ∈ path)). + + right. + destruct (list_split _ _ e) as (left & right & ->). + rewrite is_path_split in *. + rewrite NoDup_app in HND. cbn in HND. rewrite NoDup_cons in HND. + split. + * exists left. set_unfold. sfirstorder. + * exists right. set_solver. + + left. + exists path. set_solver. + - intros [[path H] | [[left Hl] [right Hr]]]. + + exists path. set_solver. + + feed destruct (is_path_NoDup r x y (left ++ [a] ++ right)) as [npath H]. + { rewrite is_path_split. naive_solver. } + exists npath. set_solver. + Qed. + + (* Equivalence between the two exists_path versions *) + Lemma exists_path_spec (r : grel) (l : list A) (x y : A) : + exists_path r l x y <-> exists_path' r l x y. + Proof using. + generalize dependent y. + generalize dependent x. + induction l. + - cbn. setoid_rewrite bool_unfold. + split. + + sfirstorder. + + intros [[] H]; set_solver. + - cbn. setoid_rewrite bool_unfold. + repeat setoid_rewrite IHl. + setoid_rewrite exists_path'_add_one. + reflexivity. + Qed. + + + Lemma exists_path_dom_rng_l r l x y: + exists_path r l x y -> x ∉ grel_dom r -> x ∉ grel_rng r -> False. + Proof using. + generalize x y. + induction l; cbn; setoid_rewrite bool_unfold; set_unfold; naive_solver. + Qed. + + Lemma exists_path_dom_rng_r r l x y: + exists_path r l x y -> y ∉ grel_dom r -> y ∉ grel_rng r -> False. + Proof using. + generalize x y. + induction l; cbn; setoid_rewrite bool_unfold; set_unfold; naive_solver. + Qed. + + (* Implementation of computation transitive closure using Floyd-Warshall + algorithm *) + Definition grel_plus (r : grel) := + let lA := elements (grel_dom r ∪ grel_rng r) in + foldr + (fun k => + fold_left + (fun s i => + fold_left + (fun s j => + if bool_decide ((i, k) ∈ s /\ (k, j) ∈ s) + then s ∪ {[(i, j)]} + else s + ) lA s + ) lA + ) r lA. + Notation "a ⁺" := (grel_plus a) (at level 1, format "a ⁺") : stdpp_scope. + + + (* Proofs along fold_left using an invariant *) + Lemma fold_left_inv {C B} (I : C -> list B -> Prop) (f : C -> B -> C) (l : list B) (i : C) : + (I i l) -> (forall a : C, forall x : B, forall t : list B, I a (x :: t) -> I (f a x) t) + -> I (fold_left f l i) []. + generalize dependent i. + induction l; sfirstorder. + Qed. + Lemma fold_left_inv_ND {C B} (I : C -> list B -> Prop) (f : C -> B -> C) + (l : list B) (i : C) : + NoDup l -> (I i l) -> + (forall a : C, forall x : B, forall t : list B, x ∉ t -> I a (x :: t) -> I (f a x) t) + -> I (fold_left f l i) []. + generalize dependent i. + induction l; sauto lq:on. + Qed. + + + Tactic Notation "feed" "rewrite" constr(H) := + feed_core H using (fun p => let H':=fresh in pose proof p as H'; rewrite H'). + Tactic Notation "efeed" "rewrite" constr(H) := + efeed_core H using (fun p => let H':=fresh in pose proof p as H'; rewrite H'). + + Lemma grel_plus_spec' x y r : + (x, y) ∈ r⁺ <-> exists_path r (elements (grel_dom r ∪ grel_rng r)) x y. + Proof using. + unfold grel_plus. + set (lA := (elements (grel_dom r ∪ grel_rng r))). + generalize dependent y. + generalize dependent x. + generalize lA at 3 4 as l. + induction l. { cbn. setoid_rewrite bool_unfold. reflexivity. } + intros x y. + cbn - [exists_path]. + efeed rewrite (fold_left_inv_ND + (fun (c : grel) (t : list A) => + forall i j, (i,j) ∈ c <-> + exists_path r (a :: l) i j /\ + (i ∈ t -> exists_path r l i j))). + - apply NoDup_elements. + - clear x y. intros x y. + rewrite IHl. clear IHl. + destruct (decide (x ∈ lA)). + + set_solver. + + cbn. + setoid_rewrite bool_unfold. + pose proof exists_path_dom_rng_l. + set_unfold. + hauto lq:on. + - clear x y IHl. + intros ri i ti Hti Hri x y. + cbn - [exists_path]. + efeed rewrite (fold_left_inv_ND + (fun (c : grel) (tj : list A) => + forall i' j, (i',j) ∈ c <-> + exists_path r (a :: l) i' j /\ + (i' ∈ ti -> exists_path r l i' j) /\ + (i' = i -> j ∈ tj -> exists_path r l i j))). + + apply NoDup_elements. + + clear x y. intros x y. + rewrite Hri. clear ri Hri. + destruct (decide (y ∈ lA)). + * set_solver. + * cbn. + setoid_rewrite bool_unfold. + pose proof exists_path_dom_rng_r. + set_solver. + + clear x y Hri ri. + intros rj j tj Htj Hrj x y. + cbn in *. + setoid_rewrite bool_unfold. + setoid_rewrite bool_unfold in Hrj. + destruct (decide (x = i)) as [-> | Hx]. + * destruct (decide (y = j)) as [-> | Hy]. + ++ case_split. + ** set_unfold. + destruct H as [Hia Haj]. + rewrite Hrj in *. + naive_solver. + ** rewrite Hrj in *. + naive_solver. + ++ case_split; set_unfold; naive_solver. + * case_split; set_unfold; naive_solver. + + set_solver. + - set_solver. + Qed. + + Lemma grel_plus_spec (r : grel) x y : + (x, y) ∈ r⁺ <-> tc (grel_to_relation r) x y. + Proof using. + rewrite grel_plus_spec'. + rewrite exists_path_spec. + split. + - intros (? & ? & _). + eapply is_path_tc. + eassumption. + - induction 1. + + exists []. set_unfold. sauto lq:on. + + destruct IHtc as [path ?]. + feed destruct (is_path_NoDup r x z (y :: path)) as [npath ?]. + * set_solver. + * exists npath. set_unfold. qauto. + Qed. + + + Typeclasses Opaque grel_plus. + Opaque grel_plus. + + Lemma grel_plus_once (r : grel) x y : (x, y) ∈ r -> (x, y) ∈ r⁺. + Proof using. rewrite grel_plus_spec. sauto lq:on. Qed. + Hint Resolve grel_plus_once: grel. + + Lemma grel_plus_trans (r : grel) x y z : + (x, y) ∈ r⁺ -> (y, z) ∈ r⁺ -> (x, z) ∈ r⁺. + Proof using. + setoid_rewrite grel_plus_spec. + sauto lq:on use:tc_transitive. + Qed. + Hint Resolve grel_plus_trans: grel. + + Lemma grel_plus_ind (r : grel) (P : A -> A -> Prop) + (RPOnce : forall x y : A, (x, y) ∈ r -> P x y) + (RPStep : forall x y z : A, (x, y) ∈ r -> (y, z) ∈ r⁺ -> P y z -> P x z) : + forall x y, (x, y) ∈ r⁺ -> P x y. + Proof using. + intros x y H. + rewrite grel_plus_spec in H. + induction H. + - naive_solver. + - eapply RPStep. + + apply H. + + rewrite grel_plus_spec. assumption. + + assumption. + Qed. + + Program Global Instance grel_plus_cind (r : grel) (x y : A) (H : (x, y) ∈ r⁺) + (P : A -> A -> Prop) : CInduction H (P x y) := + {| + induction_requirement := + (forall x y : A, (x, y) ∈ r -> P x y) /\ + (forall x y z : A, (x, y) ∈ r -> (y, z) ∈ r⁺ -> P y z -> P x z) + |}. + Solve All Obligations with intros; eapply grel_plus_ind; hauto. + + + Lemma grel_plus_inv (r : grel) : (r⁻¹)⁺ = (r⁺)⁻¹. + Proof using. + set_unfold. + intros x y. + #[local] Hint Extern 4 => set_unfold : setu. + split; intro H; cinduction H; eauto with grel setu. + Qed. + + Lemma grel_plus_ind_r (r : grel) (P : A -> A -> Prop) + (RPOnce : forall x y : A, (x, y) ∈ r -> P x y) + (RPStep : forall x y z : A, (x, y) ∈ r⁺ -> (y, z) ∈ r -> P x y -> P x z) : + forall x y, (x, y) ∈ r⁺ -> P x y. + Proof using. + intros x y H. + rewrite <- grel_inv_inv in H. + rewrite <- grel_plus_inv in H. + set_unfold in H; simpl in H. + cinduction H. + - hauto db:grel simp+:set_unfold. + - rewrite grel_plus_inv in *. + hauto db:grel simp+:set_unfold. + Qed. + + Program Definition grel_plus_cind_r (r : grel) (x y : A) (H : (x, y) ∈ r⁺) + (P : A -> A -> Prop) : CInduction H (P x y) := + {| + induction_requirement := + (forall x y : A, (x, y) ∈ r -> P x y) /\ + (forall x y z : A, (x, y) ∈ r⁺ -> (y, z) ∈ r -> P x y -> P x z) + |}. + Solve All Obligations with intros; eapply grel_plus_ind_r; hauto. + + Lemma grel_plus_plus (r : grel) : (r⁺)⁺ = r⁺. + Proof using. + set_unfold. + intros x y. + split. + - intro H; cinduction H; qauto db:grel. + - hauto db:grel. + Qed. + Hint Rewrite grel_plus_plus: grel. + + Lemma grel_dom_plus (r : grel) : grel_dom r⁺ = grel_dom r. + Proof using. + set_unfold. + intro. + split. + - intros [? H]. + cinduction H; naive_solver. + - hauto lq:on db:grel. + Qed. + Hint Rewrite grel_dom_plus: grel. + + Lemma grel_rng_plus (r : grel) : grel_rng r⁺ = grel_rng r. + Proof using. + set_unfold. + intro. + split. + - intros [? H]. + cinduction H; naive_solver. + - hauto lq:on db:grel. + Qed. + Hint Rewrite grel_rng_plus: grel. + + + (*** Symmetric ***) + + Definition grel_symmetric (r : grel) : bool := r =? r⁻¹. + + Definition grel_symmetric_rew (r : grel) : + grel_symmetric r -> r⁻¹ = r. + Proof using. unfold grel_symmetric. hauto b:on. Qed. + + Definition grel_symmetric_spec (r : grel) : + grel_symmetric r -> forall x y, (x, y) ∈ r -> (y, x) ∈ r. + Proof using. + unfold grel_symmetric. + rewrite bool_unfold. + set_solver. + Qed. + + (*** Irreflexive ***) + + Definition grel_irreflexive (r : grel) : bool := + forallb (fun x : A * A => negb (x.1 =? x.2)) (elements r). + + Lemma grel_irreflexive_spec (r : grel) : + grel_irreflexive r <-> ∀''(x, y) ∈ r, x ≠ y. + Proof using. + unfold grel_irreflexive. + rewrite bool_unfold. + set_unfold. + hauto db:core. + Qed. + + Lemma grel_irreflexive_spec' (r : grel) : + grel_irreflexive r <-> ∀ x : A, (x, x) ∉ r. + Proof using. + rewrite grel_irreflexive_spec. + hauto db:core. + Qed. + + Global Instance set_unfold_grel_irreflexive (r : grel) P : + (forall x y, SetUnfoldElemOf (x, y) r (P x y)) -> + SetUnfold (grel_irreflexive r) (forall x y, P x y -> x ≠ y). + Proof using. tcclean. hauto use:grel_irreflexive_spec db:core. Qed. + + Definition grel_acyclic (r : grel) := grel_irreflexive (r⁺). + + + (*** Transitive ***) + + Definition grel_transitive (r : grel) : bool := r =? r⁺. + + Lemma grel_transitive_spec (r : grel) : + grel_transitive r <-> forall x y z, (x, y) ∈ r -> (y, z) ∈ r -> (x, z) ∈ r. + Proof using. + unfold grel_transitive. + rewrite bool_unfold. + split; intro H. + - rewrite H. hauto lq:on db:grel. + - set_unfold. + intros x y. + split; intro Hr. + + hauto db:grel. + + cinduction Hr; hauto db:grel. + Qed. + + Lemma grel_transitive_rew (r : grel) : + grel_transitive r -> r⁺ = r. + Proof using. hauto qb:on unfold:grel_transitive. Qed. + Hint Rewrite grel_transitive_rew using done : grel. + + Lemma grel_transitive_relation_spec (r : grel) : + grel_transitive r <-> transitive A (grel_to_relation r). + Proof using. + unfold transitive. + unfold grel_to_relation. + apply grel_transitive_spec. + Qed. + + Lemma grel_transitive_plus (r : grel) : grel_transitive (r⁺). + Proof using. + apply <- grel_transitive_spec. + hauto db:grel. + Qed. + Hint Resolve grel_transitive_plus : grel. + + (*** Functional ***) + + Definition grel_map_functional (rm : grel_map) : bool := + map_fold (fun k s b => b && bool_decide (set_size s <= 1)) true rm. + + Lemma grel_map_functional_basic_spec (rm : grel_map) : + grel_map_functional rm <-> forall a : A, set_size (rm !!! a) <= 1. + Proof using. + unfold grel_map_functional. + cinduction rm using map_fold_cind with [> | intros i s m r Hi Hr]. + - sauto lq:on. + - rewrite bool_unfold. + rewrite Hr; clear Hr. + setoid_rewrite lookup_total_unfold. + assert (set_size (m !!! i) <= 1). + { rewrite lookup_total_lookup. hauto. } + hfcrush. + Qed. + + Lemma grel_map_functional_spec (rm : grel_map) : + grel_map_functional rm <-> + forall a y z : A, y ∈ (rm !!! a) -> z ∈ (rm !!! a) -> y = z. + Proof using. + rewrite grel_map_functional_basic_spec. + setoid_rewrite set_size_le1. + reflexivity. + Qed. + + Definition grel_functional (r : grel) := + grel_map_functional (grel_to_map r). + + Lemma grel_functional_spec (r : grel) : + grel_functional r <-> + forall x y z : A, (x, y) ∈ r -> (x, z) ∈ r -> y = z. + Proof using. + unfold grel_functional. + rewrite grel_map_functional_spec. + set_solver. + Qed. + + (*** Equivalence ***) + + Definition grel_equiv_on (s : gset A) (r : grel) := + grel_symmetric r && grel_transitive r && bool_decide (⦗s⦘ ⊆ r). + + (*** Reflexivivity ***) + + (** We need to know that A is finite do deal with reflexivity. **) + Context {finA : Finite A}. + + Definition grel_rc (r : grel) : grel := r ∪ ⦗fin_to_set A⦘. + Notation "a ?" := (grel_rc a) (at level 1, format "a ?") : stdpp_scope. + + Lemma grel_rc_spec (r : grel) x y : (x, y) ∈ r? <-> (x, y) ∈ r \/ x = y. + Proof using. unfold grel_rc. set_solver. Qed. + + Definition grel_reflexive (r : grel) := r =? r?. + + Lemma grel_reflexive_spec (r : grel) : + grel_reflexive r <-> forall x : A, (x, x) ∈ r. + Proof using. + unfold grel_reflexive. + rewrite bool_unfold. + split; intro H. + - rewrite H. hauto lq:on use:grel_rc_spec. + - set_unfold. hauto lq:on. + Qed. + +End GRel. + + +Arguments grel _ {_ _}. +Arguments grel_plus_cind : clear implicits. +Arguments grel_plus_cind_r : clear implicits. + + +(* Notations need to be redefined out of the section. *) +Infix "⨾" := grel_seq (at level 44, left associativity) : stdpp_scope. +Notation "r ⁻¹" := (grel_inv r) (at level 1) : stdpp_scope. +Notation "⦗ a ⦘" := (grel_from_set a) (format "⦗ a ⦘") : stdpp_scope. +Notation "a ⁺" := (grel_plus a) (at level 1, format "a ⁺") : stdpp_scope. +Notation "a ?" := (grel_rc a) (at level 1, format "a ?") : stdpp_scope. diff --git a/system-semantics/Common/README.md b/system-semantics/Common/README.md new file mode 100644 index 0000000..421c77c --- /dev/null +++ b/system-semantics/Common/README.md @@ -0,0 +1,15 @@ +This folder contain a small Coq library `SSCCommon` (for System Semantic Coq +Common), that is intended to be a small extra standard library for this project. + +The goal is that all generic lemmas that are not specific to a model end-up +here, as well as all generic proof-automation, notations, and type classes. + +This could either things that could be exported to one of the used library like +stdpp, bbv, bitvectors, hahn, hammer-tactics ... or things required to make +multiple libraries interact together. + +System-Semantic-Coq aim to be easily interoperable with the Iris ecosystem, that +is why stdpp is intended to be the main focus, in particular when there is two +version of a concept in multiple sources we will try to use the stdpp one. In +such a case SSCCommon will try to define lemmas and proof-automation to get as +smooth as possible interoperability with the other version of the concept. diff --git a/system-semantics/Common/_CoqProject b/system-semantics/Common/_CoqProject new file mode 100644 index 0000000..0ecb5f4 --- /dev/null +++ b/system-semantics/Common/_CoqProject @@ -0,0 +1 @@ +-R ../_build/default/Common SSCCommon diff --git a/system-semantics/Common/dune b/system-semantics/Common/dune new file mode 100644 index 0000000..7563843 --- /dev/null +++ b/system-semantics/Common/dune @@ -0,0 +1,23 @@ +(coq.theory + (name SSCCommon) + (package coq-system-semantics) + (modules + Common + CBase + CList + CBool + CBitvector + CInduction + CMaps + CSets + GRel + Exec) + (theories + Ltac2 + stdpp + RecordUpdate + Hammer.Tactics + bbv + Sail + ) +) diff --git a/system-semantics/INSTALL.md b/system-semantics/INSTALL.md new file mode 100644 index 0000000..e8ac96b --- /dev/null +++ b/system-semantics/INSTALL.md @@ -0,0 +1,17 @@ +## Software Dependencies + +### Coq libraries + +#### Coq Sail + +``` +git clone https://github.com/rems-project/coq-sail +``` + +Then (optionally), in that repository, if you want the version used for development, do: +``` +git checkout aeca2c5 +``` + +Then you can install `coq-sail` with `opam pin .` in the repository. It should +install its own dependencies such as `coq-bbv`. diff --git a/system-semantics/ISASem/ArmInst.v b/system-semantics/ISASem/ArmInst.v new file mode 100644 index 0000000..efd0c3d --- /dev/null +++ b/system-semantics/ISASem/ArmInst.v @@ -0,0 +1,106 @@ +Require Import Strings.String. +Require Import stdpp.unstable.bitvector. +Require Import stdpp.strings. +Require Import stdpp.base. +Require Import stdpp.countable. +Require Import Interface. +Require Import Sail.Base. +Require Export SailArmInstTypes. +Require Import Coq.Reals.Reals. +From RecordUpdate Require Import RecordSet. + +Require Import stdpp.decidable. + +Inductive regval := + | Regval_unknown : regval + | Regval_vector : list regval -> regval + | Regval_list : list regval -> regval + | Regval_option : option regval -> regval + | Regval_bool : bool -> regval + | Regval_int : Z -> regval + | Regval_real : R -> regval + | Regval_string : string -> regval + | Regval_bitvector z : bv z -> regval + | Regval_struct : list (string * regval) -> regval. + +Definition regval_bv (n : N) (rv : regval) : option (bv n). +Proof. + destruct rv. + exact None. + exact None. + exact None. + exact None. + exact None. + exact None. + exact None. + exact None. + destruct (decide (n = z)). + destruct e. + exact (Some b). + exact None. + exact None. +Qed. + +#[global] Instance FullAddress_eta : Settable _ := + settable! Build_FullAddress . + +#[global] Instance PASpace_eq_dec : EqDecision PASpace. +Proof. solve_decision. Qed. +#[global] Instance FullAddress_eq_dec : EqDecision FullAddress. +Proof. solve_decision. Qed. + +Definition PASpace_to_nat (pa : PASpace) : nat := + match pa with + | PAS_NonSecure => 0 + | PAS_Secure => 1 + | PAS_Root => 2 + | PAS_Realm => 3 + end. + +Definition PASpace_from_nat (pa : nat) := + match pa with + | 0%nat => Some PAS_NonSecure + | 1%nat => Some PAS_Secure + | 2%nat => Some PAS_Root + | 3%nat => Some PAS_Realm + | _ => None + end. + +Lemma PASpace_from_nat_to_nat (pa : PASpace) : + PASpace_from_nat (PASpace_to_nat pa) = Some pa. +Proof. by destruct pa. Qed. + +#[global] Instance PASpace_countable : Countable PASpace. +Proof. + apply (inj_countable PASpace_to_nat PASpace_from_nat PASpace_from_nat_to_nat). +Qed. + +#[global] Instance FullAddress_countable : Countable FullAddress. +Proof. + eapply (inj_countable (fun fa => (FullAddress_paspace fa, FullAddress_address fa)) + (fun x => Some (Build_FullAddress x.1 x.2))). + intro x. by destruct x. +Qed. + +Module Arm <: Arch. + Definition reg := string. + Definition reg_eq : EqDecision reg := _. + Definition reg_countable : Countable reg := _. + Definition reg_type := regval. + Definition va_size := 64%N. + Definition pa := FullAddress. + Definition pa_eq : EqDecision pa := _. + Definition pa_countable : Countable pa := _. + Definition arch_ak := arm_acc_type. + Definition translation := TranslationInfo. + Definition abort := PhysMemRetStatus. + Definition barrier := Barrier. + Definition cache_op := CacheRecord. + Definition tlb_op := TLBI. + Definition fault := Exn. +End Arm. +Bind Scope string_scope with Arm.reg. + +Module Inst := Interface Arm. + +Export Inst. diff --git a/system-semantics/ISASem/Interface.v b/system-semantics/ISASem/Interface.v new file mode 100644 index 0000000..53d4e4d --- /dev/null +++ b/system-semantics/ISASem/Interface.v @@ -0,0 +1,303 @@ + +Require Import Strings.String. +Require Import stdpp.unstable.bitvector. +Require Import stdpp.countable. + +(* This is needed because sail cannot export into multiple Coq files *) +Require Import SailArmInstTypes. + +Local Open Scope stdpp_scope. +Local Open Scope Z_scope. + +Inductive empOutcome (R : Type) :=. + +(** The architecture parameters that must be provided to the interface *) +Module Type Arch. + + (** The type of registers, most likely string, but may be more fancy *) + Parameter reg : Type. + + (** We need to implement a gmap indexed by registers *) + Parameter reg_eq : EqDecision reg. + #[export] Existing Instance reg_eq. + Parameter reg_countable : @Countable reg reg_eq. + #[export] Existing Instance reg_countable. + + (** The type of registers. This needs to be a type generic enough to contain + the value of any register *) + Parameter reg_type : Type. + + (** Virtual address size *) + Parameter va_size : N. + + (** Physical addresses type. Since models are expected to be architecture + specific in this, there is no need for a generic way to extract a + bitvector from it*) + Parameter pa : Type. + + (** We need to implement a gmap indexed by pa *) + Parameter pa_eq : EqDecision pa. + #[export] Existing Instance pa_eq. + Parameter pa_countable : @Countable pa pa_eq. + #[export] Existing Instance pa_countable. + + + + (** Parameter for extra architecture specific access types. Can be an empty + type if not used *) + Parameter arch_ak : Type. + + (** Translation summary *) + Parameter translation : Type. + + (** Abort description. This represent physical memory aborts on memory + accesses, for example when trying to access outside of physical memory + range. Those aborts are generated by the model*) + Parameter abort : Type. + + (** Barrier types *) + Parameter barrier : Type. + + (** Cache operations (data and instruction caches) *) + Parameter cache_op : Type. + + (** TLB operation *) + Parameter tlb_op : Type. + + (** Fault type for a fault raised by the instruction (not by the model) *) + Parameter fault : Type. +End Arch. + +Module Interface (A : Arch). + Include A. + + Definition va := bv va_size. + Definition accessKind := Access_kind arch_ak. + + Module DepOn. + Record t := + make + { + (** The list of registers the effect depends on. *) + regs : list reg; + (** The list of memory access the effect depends on. The number + corresponds to the memory reads done by the instruction in the + order specified by the instruction semantics. The indexing starts + at 0. *) + mem_reads : list N + }. + End DepOn. + + Module ReadReq. + Record t {n : N} := + make + { pa : pa; + access_kind : accessKind; + va : option va; + translation : translation; + tag : bool; + (** The address dependency. If unspecified, it can be interpreted as + depending on all previous registers and memory values that were read + *) + addr_dep_on : option DepOn.t; + }. + Arguments t : clear implicits. + End ReadReq. + + Module WriteReq. + Record t {n : N} := + make + { pa : pa; + access_kind : accessKind; + value : bv (8 * n); + va : option va; + translation : A.translation; + tag : bool; + (** The address dependency. If unspecified, it can be interpreted as + depending on all previous registers and memory values that were read + *) + addr_dep_on : option DepOn.t; + (** The data dependency. If unspecified, it can be interpreted as + depending on all previous registers and memory values that were read + *) + data_dep_on : option DepOn.t; + }. + Arguments t : clear implicits. + End WriteReq. + + Section T. + Context {aOutcome : Type -> Type}. + + Inductive outcome : Type -> Type := + (** The direct or indirect flag is to specify how much coherence is required + for relaxed registers *) + | RegRead (reg : reg) (direct : bool) : outcome reg_type + + (** The direct or indirect flag is to specify how much coherence is required + for relaxed registers. + + The dep_on would be the dependency of the register write. + + Generally, writing the PC introduces no dependency because control + dependencies are specified by the branch announce *) + | RegWrite (reg : reg) (direct : bool) (dep_on : option DepOn.t) + : reg_type -> outcome unit + | MemRead (n : N) : ReadReq.t n -> + outcome (bv (8 * n) * option bool + abort) + | MemWrite (n : N) : WriteReq.t n -> outcome (option bool + abort) + | MemWriteAnnounce (n : N) : pa -> outcome unit + (** The deps here specify the control dependency *) + | BranchAnnounce (pa : pa) (dep_on : option DepOn.t) : outcome unit + | Barrier : barrier -> outcome unit + | CacheOp : cache_op -> outcome unit + | TlbOp : tlb_op -> outcome unit + | FaultAnnounce : fault -> outcome unit + | EretAnnounce : outcome unit + + (** Architecture specific outcome *) + | ArchOutcome {A} : aOutcome A -> outcome A + + (** Bail out when something went wrong; this may be refined in the future *) + | GenericFail (msg : string) : outcome False + + (** The next two outcomes are for handling non-determinism. Choose will branch + the possible executions non-deterministically for every bitvector of + size n. *) + | Choose (n : N) : outcome (bv n) + (** Discard means that the instruction could never have made the previous + non-deterministic choices and the current execution can be silently + discarded. *) + | Discard : outcome False. + + + + (********** Monad instance **********) + + (** This is a naive but inefficient implementation of the instruction monad. + It might be replaced by an more efficient version later. *) + Inductive iMon {A : Type} := + | Ret : A -> iMon + | Next {T : Type} : outcome T -> (T -> iMon) -> iMon. + Arguments iMon : clear implicits. + + Global Instance iMon_mret_inst : MRet iMon := { mret a := Ret }. + + Fixpoint iMon_bind {a b : Type} (ma : iMon a) (f : a -> iMon b) := + match ma with + | Ret x => f x + | Next oc k => Next oc (fun x => iMon_bind (k x) f) end. + Global Instance iMon_mbind_inst : MBind iMon := + { mbind _ _ f x := iMon_bind x f}. + + Fixpoint iMon_fmap {a b : Type} (ma : iMon a) (f : a -> b) := + match ma with + | Ret x => Ret (f x) + | Next oc k => Next oc (fun x => iMon_fmap (k x) f) + end. + Global Instance iMon_fmap_inst : FMap iMon := + { fmap _ _ f x := iMon_fmap x f}. + + + + + + + (********** Instruction semantics and traces **********) + + (** The semantics of an complete instruction. A full definition of instruction + semantics is allowed to have an internal state that gets passed from one + instruction to the next. This is useful to handle pre-computed instruction + semantics (e.g. Isla). For complete instruction semantics, we expect that + A will be unit.*) + Record iSem := + { + (** The instruction model internal state *) + isa_state : Type; + (** The instruction model initial state for a thread with a specific Tid + *) + init_state : nat -> isa_state; + semantic : isa_state -> iMon isa_state + }. + + (** A single event in an instruction execution. As implied by the definition + events cannot contain termination outcome (outcomes of type + `outcome False`) *) + Inductive iEvent := + | IEvent {T : Type} : outcome T -> T -> iEvent. + + (** An execution trace for a single instruction. + If the result is an A, it means a successful execution that returned A + If the result is a string, it means a GenericFail *) + Definition iTrace (A : Type) : Type := list iEvent * (A + string). + + (** A trace is pure if it only contains external events. That means it must not + contain control-flow event. The name "pure" is WIP.*) + Fixpoint pure_iTrace_aux (tr : list iEvent) : Prop := + match tr with + | (IEvent (Choose _) _) :: _ => False + | _ :: t => pure_iTrace_aux t + | [] => True + end. + Definition pure_iTrace {A : Type} (tr : iTrace A) := + let '(t,r) := tr in pure_iTrace_aux t. + + (** Definition of a trace semantics matching a trace. A trace is allowed to + omit control-flow outcomes such as Choose and still be considered + matching. *) + Inductive iTrace_match {A : Type} : iMon A -> iTrace A -> Prop := + | TMNext T (oc : outcome T) (f : T -> iMon A) (obj : T) tl res : + iTrace_match (f obj) (tl, res) -> + iTrace_match (Next oc f) ((IEvent oc obj) :: tl, res) + | TMChoose n f (v : bv n) tr : + iTrace_match (f v) tr -> iTrace_match (Next (Choose n) f) tr + | TMSuccess a : iTrace_match (Ret a) ([], inl a) + | TMFailure f s : iTrace_match (Next (GenericFail s) f) ([], inr s). + + (** Semantic equivalence for instructions *) + Definition iMon_equiv `{Equiv A} (i1 i2 : iMon A) : Prop := + forall trace : iTrace A, + pure_iTrace trace -> (iTrace_match i1 trace <-> iTrace_match i2 trace). + + End T. + Arguments outcome : clear implicits. + Arguments iMon : clear implicits. + Arguments iSem : clear implicits. + Arguments iTrace : clear implicits. + Arguments iEvent : clear implicits. + + Definition iMonArchMap (out1 out2 : Type -> Type) + := forall (A : Type), out1 A -> iMon out2 A. + + (** Suppose we can simulate the outcome of out1 in the instruction monad with + architecture outcomes out2. Then *) + Fixpoint map_arch_iMon {out1 out2 : Type -> Type} {B : Type} + (f : iMonArchMap out1 out2) (mon : iMon out1 B) : iMon out2 B := + match mon in iMon _ _ return iMon out2 _ with + | Ret b => Ret b + | Next oc k0 => + let k := fun x => map_arch_iMon f (k0 x) in + match oc in outcome _ T return (T -> iMon out2 B) -> iMon out2 B with + | RegRead reg direct => Next (RegRead reg direct) + | RegWrite reg direct dep_on val => + Next (RegWrite reg direct dep_on val) + | MemRead n readreq => Next (MemRead n readreq) + | MemWrite n writereq => Next (MemWrite n writereq) + | MemWriteAnnounce n pa => Next (MemWriteAnnounce n pa) + | BranchAnnounce pa dep_on => Next (BranchAnnounce pa dep_on) + | Barrier barrier => Next (Barrier barrier) + | CacheOp cache_op => Next (CacheOp cache_op) + | TlbOp tlb_op => Next (TlbOp tlb_op) + | FaultAnnounce fault => Next (FaultAnnounce fault) + | EretAnnounce => Next EretAnnounce + | ArchOutcome aout => iMon_bind (f _ aout) + | GenericFail msg => Next (GenericFail msg) + | Choose n => Next (Choose n) + | Discard => Next (Discard) + end k + end. + +End Interface. + +Module Type InterfaceT (A : Arch). + Include Interface A. +End InterfaceT. diff --git a/system-semantics/ISASem/README.md b/system-semantics/ISASem/README.md new file mode 100644 index 0000000..2b2d86c --- /dev/null +++ b/system-semantics/ISASem/README.md @@ -0,0 +1,4 @@ +# ISA semantics in Coq + +This folder is intended to contain all definitions needed to define the semantics +of an Instruction Set Architecture (ISA) in Coq diff --git a/system-semantics/ISASem/SailArmInstTypes.v b/system-semantics/ISASem/SailArmInstTypes.v new file mode 100644 index 0000000..98682b4 --- /dev/null +++ b/system-semantics/ISASem/SailArmInstTypes.v @@ -0,0 +1,1091 @@ +Require Import Sail.Base. +Require Import Sail.Real. +Require Import stdpp.unstable.bitvector. +Import ListNotations. +Open Scope string. +Open Scope bool. +Open Scope Z. + +Inductive Access_strength := AS_normal | AS_rel_or_acq | AS_acq_rcpc. +Scheme Equality for Access_strength. +#[export] Instance Decidable_eq_Access_strength : +forall (x y : Access_strength), Decidable (x = y) := +Decidable_eq_from_dec Access_strength_eq_dec. + +Inductive Access_variety := AV_plain | AV_exclusive | AV_atomic_rmw. +Scheme Equality for Access_variety. +#[export] Instance Decidable_eq_Access_variety : +forall (x y : Access_variety), Decidable (x = y) := +Decidable_eq_from_dec Access_variety_eq_dec. + +Definition bits (n : Z) := + match n with + | Zneg _ => bv 0 + | Z0 => bv 0 + | Zpos p => bv (Npos p) + end. + +Inductive result {a : Type} {b : Type} := | Ok : a -> result | Err : b -> result. +Arguments result : clear implicits. + +Record Explicit_access_kind := + { Explicit_access_kind_variety : Access_variety; Explicit_access_kind_strength : Access_strength; }. +Arguments Explicit_access_kind : clear implicits. +Notation "{[ r 'with' 'Explicit_access_kind_variety' := e ]}" := + match r with Build_Explicit_access_kind _ f1 => Build_Explicit_access_kind e f1 end. +Notation "{[ r 'with' 'Explicit_access_kind_strength' := e ]}" := + match r with Build_Explicit_access_kind f0 _ => Build_Explicit_access_kind f0 e end. + +Inductive Access_kind {arch_ak : Type} := + | AK_explicit : Explicit_access_kind -> Access_kind + | AK_ifetch : unit -> Access_kind + | AK_ttw : unit -> Access_kind + | AK_arch : arch_ak -> Access_kind. +Arguments Access_kind : clear implicits. + +Record Mem_read_request {n : Z} {vasize : Z} {pa : Type} {ts : Type} {arch_ak : Type}`{ArithFact (n >? + 0)} := + { Mem_read_request_access_kind : Access_kind arch_ak; + Mem_read_request_va : option (bits vasize); + Mem_read_request_pa : pa; + Mem_read_request_translation : ts; + Mem_read_request_size : Z; + Mem_read_request_tag : bool; }. +Arguments Mem_read_request _ _ _ _ _ {_}. +Notation "{[ r 'with' 'Mem_read_request_access_kind' := e ]}" := + match r with Build_Mem_read_request _ _ _ _ _ _ _ f1 f2 f3 f4 f5 => + Build_Mem_read_request _ _ _ _ _ e f1 f2 f3 f4 f5 end. +Notation "{[ r 'with' 'Mem_read_request_va' := e ]}" := + match r with Build_Mem_read_request _ _ _ _ _ _ f0 _ f2 f3 f4 f5 => + Build_Mem_read_request _ _ _ _ _ f0 e f2 f3 f4 f5 end. +Notation "{[ r 'with' 'Mem_read_request_pa' := e ]}" := + match r with Build_Mem_read_request _ _ _ _ _ _ f0 f1 _ f3 f4 f5 => + Build_Mem_read_request _ _ _ _ _ f0 f1 e f3 f4 f5 end. +Notation "{[ r 'with' 'Mem_read_request_translation' := e ]}" := + match r with Build_Mem_read_request _ _ _ _ _ _ f0 f1 f2 _ f4 f5 => + Build_Mem_read_request _ _ _ _ _ f0 f1 f2 e f4 f5 end. +Notation "{[ r 'with' 'Mem_read_request_size' := e ]}" := + match r with Build_Mem_read_request _ _ _ _ _ _ f0 f1 f2 f3 _ f5 => + Build_Mem_read_request _ _ _ _ _ f0 f1 f2 f3 e f5 end. +Notation "{[ r 'with' 'Mem_read_request_tag' := e ]}" := + match r with Build_Mem_read_request _ _ _ _ _ _ f0 f1 f2 f3 f4 _ => + Build_Mem_read_request _ _ _ _ _ f0 f1 f2 f3 f4 e end. + +Record Mem_write_request {n : Z} {vasize : Z} {pa : Type} {ts : Type} {arch_ak : Type}`{ArithFact (n >? + 0)} := + { Mem_write_request_access_kind : Access_kind arch_ak; + Mem_write_request_va : option (bits vasize); + Mem_write_request_pa : pa; + Mem_write_request_translation : ts; + Mem_write_request_size : Z; + Mem_write_request_value : option (bits (8 * n)); + Mem_write_request_tag : option bool; }. +Arguments Mem_write_request _ _ _ _ _ {_}. +Notation "{[ r 'with' 'Mem_write_request_access_kind' := e ]}" := + match r with Build_Mem_write_request _ _ _ _ _ _ _ f1 f2 f3 f4 f5 f6 => + Build_Mem_write_request _ _ _ _ _ e f1 f2 f3 f4 f5 f6 end. +Notation "{[ r 'with' 'Mem_write_request_va' := e ]}" := + match r with Build_Mem_write_request _ _ _ _ _ _ f0 _ f2 f3 f4 f5 f6 => + Build_Mem_write_request _ _ _ _ _ f0 e f2 f3 f4 f5 f6 end. +Notation "{[ r 'with' 'Mem_write_request_pa' := e ]}" := + match r with Build_Mem_write_request _ _ _ _ _ _ f0 f1 _ f3 f4 f5 f6 => + Build_Mem_write_request _ _ _ _ _ f0 f1 e f3 f4 f5 f6 end. +Notation "{[ r 'with' 'Mem_write_request_translation' := e ]}" := + match r with Build_Mem_write_request _ _ _ _ _ _ f0 f1 f2 _ f4 f5 f6 => + Build_Mem_write_request _ _ _ _ _ f0 f1 f2 e f4 f5 f6 end. +Notation "{[ r 'with' 'Mem_write_request_size' := e ]}" := + match r with Build_Mem_write_request _ _ _ _ _ _ f0 f1 f2 f3 _ f5 f6 => + Build_Mem_write_request _ _ _ _ _ f0 f1 f2 f3 e f5 f6 end. +Notation "{[ r 'with' 'Mem_write_request_value' := e ]}" := + match r with Build_Mem_write_request _ _ _ _ _ _ f0 f1 f2 f3 f4 _ f6 => + Build_Mem_write_request _ _ _ _ _ f0 f1 f2 f3 f4 e f6 end. +Notation "{[ r 'with' 'Mem_write_request_tag' := e ]}" := + match r with Build_Mem_write_request _ _ _ _ _ _ f0 f1 f2 f3 f4 f5 _ => + Build_Mem_write_request _ _ _ _ _ f0 f1 f2 f3 f4 f5 e end. + +Record Mem_write_announce_address {n : Z} {vasize : Z} {pa : Type} := + { Mem_write_announce_address_pa : pa; Mem_write_announce_address_size : Z; }. +Arguments Mem_write_announce_address : clear implicits. +Notation "{[ r 'with' 'Mem_write_announce_address_pa' := e ]}" := + match r with Build_Mem_write_announce_address _ _ _ _ f1 => + Build_Mem_write_announce_address _ _ _ e f1 end. +Notation "{[ r 'with' 'Mem_write_announce_address_size' := e ]}" := + match r with Build_Mem_write_announce_address _ _ _ f0 _ => + Build_Mem_write_announce_address _ _ _ f0 e end. + +Inductive Exception := + Exception_Uncategorized + | Exception_WFxTrap + | Exception_CP15RTTrap + | Exception_CP15RRTTrap + | Exception_CP14RTTrap + | Exception_CP14DTTrap + | Exception_CP14RRTTrap + | Exception_AdvSIMDFPAccessTrap + | Exception_FPIDTrap + | Exception_LDST64BTrap + | Exception_PACTrap + | Exception_IllegalState + | Exception_SupervisorCall + | Exception_HypervisorCall + | Exception_MonitorCall + | Exception_SystemRegisterTrap + | Exception_ERetTrap + | Exception_InstructionAbort + | Exception_PCAlignment + | Exception_DataAbort + | Exception_NV2DataAbort + | Exception_PACFail + | Exception_SPAlignment + | Exception_FPTrappedException + | Exception_SError + | Exception_Breakpoint + | Exception_SoftwareStep + | Exception_Watchpoint + | Exception_NV2Watchpoint + | Exception_SoftwareBreakpoint + | Exception_VectorCatch + | Exception_IRQ + | Exception_SVEAccessTrap + | Exception_SMEAccessTrap + | Exception_TSTARTAccessTrap + | Exception_GPC + | Exception_BranchTarget + | Exception_MemCpyMemSet + | Exception_FIQ. +Scheme Equality for Exception. +#[export] Instance Decidable_eq_Exception : +forall (x y : Exception), Decidable (x = y) := +Decidable_eq_from_dec Exception_eq_dec. + +Inductive PASpace := PAS_NonSecure | PAS_Secure | PAS_Root | PAS_Realm. +Scheme Equality for PASpace. +#[export] Instance Decidable_eq_PASpace : +forall (x y : PASpace), Decidable (x = y) := +Decidable_eq_from_dec PASpace_eq_dec. + +Record FullAddress := { FullAddress_paspace : PASpace; FullAddress_address : bits 52; }. +Arguments FullAddress : clear implicits. +Notation "{[ r 'with' 'FullAddress_paspace' := e ]}" := + match r with Build_FullAddress _ f1 => Build_FullAddress e f1 end. +Notation "{[ r 'with' 'FullAddress_address' := e ]}" := + match r with Build_FullAddress f0 _ => Build_FullAddress f0 e end. + +Record ExceptionRecord := + { ExceptionRecord_exceptype : Exception; + ExceptionRecord_syndrome : bits 25; + ExceptionRecord_syndrome2 : bits 5; + ExceptionRecord_paddress : FullAddress; + ExceptionRecord_vaddress : bits 64; + ExceptionRecord_ipavalid : bool; + ExceptionRecord_NS : bits 1; + ExceptionRecord_ipaddress : bits 52; + ExceptionRecord_trappedsyscallinst : bool; }. +Arguments ExceptionRecord : clear implicits. +Notation "{[ r 'with' 'ExceptionRecord_exceptype' := e ]}" := + match r with Build_ExceptionRecord _ f1 f2 f3 f4 f5 f6 f7 f8 => + Build_ExceptionRecord e f1 f2 f3 f4 f5 f6 f7 f8 end. +Notation "{[ r 'with' 'ExceptionRecord_syndrome' := e ]}" := + match r with Build_ExceptionRecord f0 _ f2 f3 f4 f5 f6 f7 f8 => + Build_ExceptionRecord f0 e f2 f3 f4 f5 f6 f7 f8 end. +Notation "{[ r 'with' 'ExceptionRecord_syndrome2' := e ]}" := + match r with Build_ExceptionRecord f0 f1 _ f3 f4 f5 f6 f7 f8 => + Build_ExceptionRecord f0 f1 e f3 f4 f5 f6 f7 f8 end. +Notation "{[ r 'with' 'ExceptionRecord_paddress' := e ]}" := + match r with Build_ExceptionRecord f0 f1 f2 _ f4 f5 f6 f7 f8 => + Build_ExceptionRecord f0 f1 f2 e f4 f5 f6 f7 f8 end. +Notation "{[ r 'with' 'ExceptionRecord_vaddress' := e ]}" := + match r with Build_ExceptionRecord f0 f1 f2 f3 _ f5 f6 f7 f8 => + Build_ExceptionRecord f0 f1 f2 f3 e f5 f6 f7 f8 end. +Notation "{[ r 'with' 'ExceptionRecord_ipavalid' := e ]}" := + match r with Build_ExceptionRecord f0 f1 f2 f3 f4 _ f6 f7 f8 => + Build_ExceptionRecord f0 f1 f2 f3 f4 e f6 f7 f8 end. +Notation "{[ r 'with' 'ExceptionRecord_NS' := e ]}" := + match r with Build_ExceptionRecord f0 f1 f2 f3 f4 f5 _ f7 f8 => + Build_ExceptionRecord f0 f1 f2 f3 f4 f5 e f7 f8 end. +Notation "{[ r 'with' 'ExceptionRecord_ipaddress' := e ]}" := + match r with Build_ExceptionRecord f0 f1 f2 f3 f4 f5 f6 _ f8 => + Build_ExceptionRecord f0 f1 f2 f3 f4 f5 f6 e f8 end. +Notation "{[ r 'with' 'ExceptionRecord_trappedsyscallinst' := e ]}" := + match r with Build_ExceptionRecord f0 f1 f2 f3 f4 f5 f6 f7 _ => + Build_ExceptionRecord f0 f1 f2 f3 f4 f5 f6 f7 e end. + +Inductive SecurityState := SS_NonSecure | SS_Root | SS_Realm | SS_Secure. +Scheme Equality for SecurityState. +#[export] Instance Decidable_eq_SecurityState : +forall (x y : SecurityState), Decidable (x = y) := +Decidable_eq_from_dec SecurityState_eq_dec. + +Inductive AccType := + AccType_NORMAL + | AccType_STREAM + | AccType_VEC + | AccType_VECSTREAM + | AccType_SVE + | AccType_SVESTREAM + | AccType_SME + | AccType_SMESTREAM + | AccType_UNPRIVSTREAM + | AccType_A32LSMD + | AccType_ATOMIC + | AccType_ATOMICRW + | AccType_ORDERED + | AccType_ORDEREDRW + | AccType_ORDEREDATOMIC + | AccType_ORDEREDATOMICRW + | AccType_ATOMICLS64 + | AccType_LIMITEDORDERED + | AccType_UNPRIV + | AccType_IFETCH + | AccType_TTW + | AccType_NONFAULT + | AccType_CNOTFIRST + | AccType_NV2REGISTER + | AccType_DC + | AccType_IC + | AccType_DCZVA + | AccType_ATPAN + | AccType_AT. +Scheme Equality for AccType. +#[export] Instance Decidable_eq_AccType : +forall (x y : AccType), Decidable (x = y) := +Decidable_eq_from_dec AccType_eq_dec. + +Inductive Fault := + Fault_None + | Fault_AccessFlag + | Fault_Alignment + | Fault_Background + | Fault_Domain + | Fault_Permission + | Fault_Translation + | Fault_AddressSize + | Fault_SyncExternal + | Fault_SyncExternalOnWalk + | Fault_SyncParity + | Fault_SyncParityOnWalk + | Fault_GPCFOnWalk + | Fault_GPCFOnOutput + | Fault_AsyncParity + | Fault_AsyncExternal + | Fault_Debug + | Fault_TLBConflict + | Fault_BranchTarget + | Fault_HWUpdateAccessFlag + | Fault_Lockdown + | Fault_Exclusive + | Fault_ICacheMaint. +Scheme Equality for Fault. +#[export] Instance Decidable_eq_Fault : +forall (x y : Fault), Decidable (x = y) := +Decidable_eq_from_dec Fault_eq_dec. + +Inductive GPCF := GPCF_None | GPCF_AddressSize | GPCF_Walk | GPCF_EABT | GPCF_Fail. +Scheme Equality for GPCF. +#[export] Instance Decidable_eq_GPCF : +forall (x y : GPCF), Decidable (x = y) := +Decidable_eq_from_dec GPCF_eq_dec. + +Record GPCFRecord := { GPCFRecord_gpf : GPCF; GPCFRecord_level : Z; }. +Arguments GPCFRecord : clear implicits. +Notation "{[ r 'with' 'GPCFRecord_gpf' := e ]}" := + match r with Build_GPCFRecord _ f1 => Build_GPCFRecord e f1 end. +Notation "{[ r 'with' 'GPCFRecord_level' := e ]}" := + match r with Build_GPCFRecord f0 _ => Build_GPCFRecord f0 e end. + +Record FaultRecord := + { FaultRecord_statuscode : Fault; + FaultRecord_acctype : AccType; + FaultRecord_ipaddress : FullAddress; + FaultRecord_gpcf : GPCFRecord; + FaultRecord_paddress : FullAddress; + FaultRecord_gpcfs2walk : bool; + FaultRecord_s2fs1walk : bool; + FaultRecord_write : bool; + FaultRecord_level : Z; + FaultRecord_extflag : bits 1; + FaultRecord_secondstage : bool; + FaultRecord_domain : bits 4; + FaultRecord_errortype : bits 2; + FaultRecord_debugmoe : bits 4; }. +Arguments FaultRecord : clear implicits. +Notation "{[ r 'with' 'FaultRecord_statuscode' := e ]}" := + match r with Build_FaultRecord _ f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 => + Build_FaultRecord e f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_acctype' := e ]}" := + match r with Build_FaultRecord f0 _ f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 => + Build_FaultRecord f0 e f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_ipaddress' := e ]}" := + match r with Build_FaultRecord f0 f1 _ f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 => + Build_FaultRecord f0 f1 e f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_gpcf' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 _ f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 => + Build_FaultRecord f0 f1 f2 e f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_paddress' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 _ f5 f6 f7 f8 f9 f10 f11 f12 f13 => + Build_FaultRecord f0 f1 f2 f3 e f5 f6 f7 f8 f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_gpcfs2walk' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 _ f6 f7 f8 f9 f10 f11 f12 f13 => + Build_FaultRecord f0 f1 f2 f3 f4 e f6 f7 f8 f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_s2fs1walk' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 f5 _ f7 f8 f9 f10 f11 f12 f13 => + Build_FaultRecord f0 f1 f2 f3 f4 f5 e f7 f8 f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_write' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 _ f8 f9 f10 f11 f12 f13 => + Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 e f8 f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_level' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 _ f9 f10 f11 f12 f13 => + Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 e f9 f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_extflag' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 _ f10 f11 f12 f13 => + Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 e f10 f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_secondstage' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 _ f11 f12 f13 => + Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 e f11 f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_domain' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 _ f12 f13 => + Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 e f12 f13 end. +Notation "{[ r 'with' 'FaultRecord_errortype' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 _ f13 => + Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 e f13 end. +Notation "{[ r 'with' 'FaultRecord_debugmoe' := e ]}" := + match r with Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 _ => + Build_FaultRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 e end. + +Inductive DeviceType := DeviceType_GRE | DeviceType_nGRE | DeviceType_nGnRE | DeviceType_nGnRnE. +Scheme Equality for DeviceType. +#[export] Instance Decidable_eq_DeviceType : +forall (x y : DeviceType), Decidable (x = y) := +Decidable_eq_from_dec DeviceType_eq_dec. + +Record MemAttrHints := + { MemAttrHints_attrs : bits 2; MemAttrHints_hints : bits 2; MemAttrHints_transient : bool; }. +Arguments MemAttrHints : clear implicits. +Notation "{[ r 'with' 'MemAttrHints_attrs' := e ]}" := + match r with Build_MemAttrHints _ f1 f2 => Build_MemAttrHints e f1 f2 end. +Notation "{[ r 'with' 'MemAttrHints_hints' := e ]}" := + match r with Build_MemAttrHints f0 _ f2 => Build_MemAttrHints f0 e f2 end. +Notation "{[ r 'with' 'MemAttrHints_transient' := e ]}" := + match r with Build_MemAttrHints f0 f1 _ => Build_MemAttrHints f0 f1 e end. + +Inductive MemType := MemType_Normal | MemType_Device. +Scheme Equality for MemType. +#[export] Instance Decidable_eq_MemType : +forall (x y : MemType), Decidable (x = y) := +Decidable_eq_from_dec MemType_eq_dec. + +Inductive Shareability := Shareability_NSH | Shareability_ISH | Shareability_OSH. +Scheme Equality for Shareability. +#[export] Instance Decidable_eq_Shareability : +forall (x y : Shareability), Decidable (x = y) := +Decidable_eq_from_dec Shareability_eq_dec. + +Record MemoryAttributes := + { MemoryAttributes_memtype : MemType; + MemoryAttributes_device : DeviceType; + MemoryAttributes_inner : MemAttrHints; + MemoryAttributes_outer : MemAttrHints; + MemoryAttributes_shareability : Shareability; + MemoryAttributes_tagged : bool; + MemoryAttributes_xs : bits 1; }. +Arguments MemoryAttributes : clear implicits. +Notation "{[ r 'with' 'MemoryAttributes_memtype' := e ]}" := + match r with Build_MemoryAttributes _ f1 f2 f3 f4 f5 f6 => + Build_MemoryAttributes e f1 f2 f3 f4 f5 f6 end. +Notation "{[ r 'with' 'MemoryAttributes_device' := e ]}" := + match r with Build_MemoryAttributes f0 _ f2 f3 f4 f5 f6 => + Build_MemoryAttributes f0 e f2 f3 f4 f5 f6 end. +Notation "{[ r 'with' 'MemoryAttributes_inner' := e ]}" := + match r with Build_MemoryAttributes f0 f1 _ f3 f4 f5 f6 => + Build_MemoryAttributes f0 f1 e f3 f4 f5 f6 end. +Notation "{[ r 'with' 'MemoryAttributes_outer' := e ]}" := + match r with Build_MemoryAttributes f0 f1 f2 _ f4 f5 f6 => + Build_MemoryAttributes f0 f1 f2 e f4 f5 f6 end. +Notation "{[ r 'with' 'MemoryAttributes_shareability' := e ]}" := + match r with Build_MemoryAttributes f0 f1 f2 f3 _ f5 f6 => + Build_MemoryAttributes f0 f1 f2 f3 e f5 f6 end. +Notation "{[ r 'with' 'MemoryAttributes_tagged' := e ]}" := + match r with Build_MemoryAttributes f0 f1 f2 f3 f4 _ f6 => + Build_MemoryAttributes f0 f1 f2 f3 f4 e f6 end. +Notation "{[ r 'with' 'MemoryAttributes_xs' := e ]}" := + match r with Build_MemoryAttributes f0 f1 f2 f3 f4 f5 _ => + Build_MemoryAttributes f0 f1 f2 f3 f4 f5 e end. + +Inductive Regime := Regime_EL3 | Regime_EL30 | Regime_EL2 | Regime_EL20 | Regime_EL10. +Scheme Equality for Regime. +#[export] Instance Decidable_eq_Regime : +forall (x y : Regime), Decidable (x = y) := +Decidable_eq_from_dec Regime_eq_dec. + +Inductive TGx := TGx_4KB | TGx_16KB | TGx_64KB. +Scheme Equality for TGx. +#[export] Instance Decidable_eq_TGx : +forall (x y : TGx), Decidable (x = y) := +Decidable_eq_from_dec TGx_eq_dec. + +Record PhysMemRetStatus := + { PhysMemRetStatus_statuscode : Fault; + PhysMemRetStatus_extflag : bits 1; + PhysMemRetStatus_errortype : bits 2; + PhysMemRetStatus_store64bstatus : bits 64; + PhysMemRetStatus_acctype : AccType; }. +Arguments PhysMemRetStatus : clear implicits. +Notation "{[ r 'with' 'PhysMemRetStatus_statuscode' := e ]}" := + match r with Build_PhysMemRetStatus _ f1 f2 f3 f4 => Build_PhysMemRetStatus e f1 f2 f3 f4 end. +Notation "{[ r 'with' 'PhysMemRetStatus_extflag' := e ]}" := + match r with Build_PhysMemRetStatus f0 _ f2 f3 f4 => Build_PhysMemRetStatus f0 e f2 f3 f4 end. +Notation "{[ r 'with' 'PhysMemRetStatus_errortype' := e ]}" := + match r with Build_PhysMemRetStatus f0 f1 _ f3 f4 => Build_PhysMemRetStatus f0 f1 e f3 f4 end. +Notation "{[ r 'with' 'PhysMemRetStatus_store64bstatus' := e ]}" := + match r with Build_PhysMemRetStatus f0 f1 f2 _ f4 => Build_PhysMemRetStatus f0 f1 f2 e f4 end. +Notation "{[ r 'with' 'PhysMemRetStatus_acctype' := e ]}" := + match r with Build_PhysMemRetStatus f0 f1 f2 f3 _ => Build_PhysMemRetStatus f0 f1 f2 f3 e end. + +Record S1TTWParams := + { S1TTWParams_ha : bits 1; + S1TTWParams_hd : bits 1; + S1TTWParams_tbi : bits 1; + S1TTWParams_tbid : bits 1; + S1TTWParams_nfd : bits 1; + S1TTWParams_e0pd : bits 1; + S1TTWParams_ds : bits 1; + S1TTWParams_ps : bits 3; + S1TTWParams_txsz : bits 6; + S1TTWParams_epan : bits 1; + S1TTWParams_dct : bits 1; + S1TTWParams_nv1 : bits 1; + S1TTWParams_cmow : bits 1; + S1TTWParams_t0sz : bits 3; + S1TTWParams_t1sz : bits 3; + S1TTWParams_uwxn : bits 1; + S1TTWParams_tgx : TGx; + S1TTWParams_irgn : bits 2; + S1TTWParams_orgn : bits 2; + S1TTWParams_sh : bits 2; + S1TTWParams_hpd : bits 1; + S1TTWParams_ee : bits 1; + S1TTWParams_wxn : bits 1; + S1TTWParams_ntlsmd : bits 1; + S1TTWParams_dc : bits 1; + S1TTWParams_sif : bits 1; + S1TTWParams_mair : bits 64; }. +Arguments S1TTWParams : clear implicits. +Notation "{[ r 'with' 'S1TTWParams_ha' := e ]}" := + match r with Build_S1TTWParams _ f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams e f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_hd' := e ]}" := + match r with Build_S1TTWParams f0 _ f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 e f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_tbi' := e ]}" := + match r with Build_S1TTWParams f0 f1 _ f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 e f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_tbid' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 _ f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 e f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_nfd' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 _ f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 e f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_e0pd' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 _ f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 e f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_ds' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 _ f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 e f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_ps' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 _ f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 e f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_txsz' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 _ f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 e f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_epan' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 _ f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 e f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_dct' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 _ f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 e f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_nv1' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 _ f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 e f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_cmow' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 _ f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 e f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_t0sz' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 _ f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 e f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_t1sz' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 _ f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 e f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_uwxn' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 _ f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 e f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_tgx' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 _ f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 e f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_irgn' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 _ f18 f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 e f18 f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_orgn' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 _ f19 f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 e f19 f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_sh' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 _ f20 f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 e f20 f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_hpd' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 _ f21 f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 e f21 f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_ee' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 _ f22 f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 e f22 f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_wxn' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 _ f23 f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 e f23 f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_ntlsmd' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 _ f24 f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 e f24 f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_dc' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 _ f25 f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 e f25 f26 + end. +Notation "{[ r 'with' 'S1TTWParams_sif' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 _ f26 => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 e f26 + end. +Notation "{[ r 'with' 'S1TTWParams_mair' := e ]}" := + match r with Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 _ => + Build_S1TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 e + end. + +Record S2TTWParams := + { S2TTWParams_ha : bits 1; + S2TTWParams_hd : bits 1; + S2TTWParams_sl2 : bits 1; + S2TTWParams_ds : bits 1; + S2TTWParams_sw : bits 1; + S2TTWParams_nsw : bits 1; + S2TTWParams_sa : bits 1; + S2TTWParams_nsa : bits 1; + S2TTWParams_ps : bits 3; + S2TTWParams_txsz : bits 6; + S2TTWParams_fwb : bits 1; + S2TTWParams_cmow : bits 1; + S2TTWParams_s : bits 1; + S2TTWParams_t0sz : bits 4; + S2TTWParams_tgx : TGx; + S2TTWParams_sl0 : bits 2; + S2TTWParams_irgn : bits 2; + S2TTWParams_orgn : bits 2; + S2TTWParams_sh : bits 2; + S2TTWParams_ee : bits 1; + S2TTWParams_ptw : bits 1; + S2TTWParams_vm : bits 1; }. +Arguments S2TTWParams : clear implicits. +Notation "{[ r 'with' 'S2TTWParams_ha' := e ]}" := + match r with Build_S2TTWParams _ f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams e f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_hd' := e ]}" := + match r with Build_S2TTWParams f0 _ f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 e f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_sl2' := e ]}" := + match r with Build_S2TTWParams f0 f1 _ f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 e f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_ds' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 _ f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 e f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_sw' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 _ f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 e f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_nsw' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 _ f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 e f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_sa' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 _ f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 e f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_nsa' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 _ f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 e f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_ps' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 _ f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 e f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_txsz' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 _ f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 e f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_fwb' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 _ f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 e f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_cmow' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 _ f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 e f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_s' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 _ f13 f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 e f13 f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_t0sz' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 _ f14 f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 e f14 f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_tgx' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 _ f15 f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 e f15 f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_sl0' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 _ f16 f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 e f16 f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_irgn' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 _ f17 f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 e f17 f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_orgn' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 _ f18 f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 e f18 f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_sh' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 _ f19 f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 e f19 f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_ee' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 _ f20 f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 e f20 f21 + end. +Notation "{[ r 'with' 'S2TTWParams_ptw' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 _ f21 => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 e f21 + end. +Notation "{[ r 'with' 'S2TTWParams_vm' := e ]}" := + match r with Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 _ => + Build_S2TTWParams f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 e + end. + +Inductive CacheOp := CacheOp_Clean | CacheOp_Invalidate | CacheOp_CleanInvalidate. +Scheme Equality for CacheOp. +#[export] Instance Decidable_eq_CacheOp : +forall (x y : CacheOp), Decidable (x = y) := +Decidable_eq_from_dec CacheOp_eq_dec. + +Inductive CacheOpScope := + CacheOpScope_SetWay + | CacheOpScope_PoU + | CacheOpScope_PoC + | CacheOpScope_PoP + | CacheOpScope_PoDP + | CacheOpScope_ALLU + | CacheOpScope_ALLUIS. +Scheme Equality for CacheOpScope. +#[export] Instance Decidable_eq_CacheOpScope : +forall (x y : CacheOpScope), Decidable (x = y) := +Decidable_eq_from_dec CacheOpScope_eq_dec. + +Inductive CachePASpace := + CPAS_NonSecure + | CPAS_Any + | CPAS_RealmNonSecure + | CPAS_Realm + | CPAS_Root + | CPAS_SecureNonSecure + | CPAS_Secure. +Scheme Equality for CachePASpace. +#[export] Instance Decidable_eq_CachePASpace : +forall (x y : CachePASpace), Decidable (x = y) := +Decidable_eq_from_dec CachePASpace_eq_dec. + +Inductive CacheType := CacheType_Data | CacheType_Tag | CacheType_Data_Tag | CacheType_Instruction. +Scheme Equality for CacheType. +#[export] Instance Decidable_eq_CacheType : +forall (x y : CacheType), Decidable (x = y) := +Decidable_eq_from_dec CacheType_eq_dec. + +Record CacheRecord := + { CacheRecord_acctype : AccType; + CacheRecord_cacheop : CacheOp; + CacheRecord_opscope : CacheOpScope; + CacheRecord_cachetype : CacheType; + CacheRecord_regval : bits 64; + CacheRecord_paddress : FullAddress; + CacheRecord_vaddress : bits 64; + CacheRecord_set : Z; + CacheRecord_way : Z; + CacheRecord_level : Z; + CacheRecord_shareability : Shareability; + CacheRecord_translated : bool; + CacheRecord_is_vmid_valid : bool; + CacheRecord_vmid : bits 16; + CacheRecord_is_asid_valid : bool; + CacheRecord_asid : bits 16; + CacheRecord_security : SecurityState; + CacheRecord_cpas : CachePASpace; }. +Arguments CacheRecord : clear implicits. +Notation "{[ r 'with' 'CacheRecord_acctype' := e ]}" := + match r with Build_CacheRecord _ f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord e f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_cacheop' := e ]}" := + match r with Build_CacheRecord f0 _ f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 e f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_opscope' := e ]}" := + match r with Build_CacheRecord f0 f1 _ f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 e f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_cachetype' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 _ f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 e f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_regval' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 _ f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 e f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_paddress' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 _ f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 e f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_vaddress' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 _ f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 e f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_set' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 _ f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 e f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_way' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 _ f9 f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 e f9 f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_level' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 _ f10 f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 e f10 f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_shareability' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 _ f11 f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 e f11 f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_translated' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 _ f12 f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 e f12 f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_is_vmid_valid' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 _ f13 f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 e f13 f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_vmid' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 _ f14 f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 e f14 f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_is_asid_valid' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 _ f15 f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 e f15 f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_asid' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 _ f16 f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 e f16 f17 end. +Notation "{[ r 'with' 'CacheRecord_security' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 _ f17 => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 e f17 end. +Notation "{[ r 'with' 'CacheRecord_cpas' := e ]}" := + match r with Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 _ => + Build_CacheRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 e end. + +Inductive TLBILevel := TLBILevel_Any | TLBILevel_Last. +Scheme Equality for TLBILevel. +#[export] Instance Decidable_eq_TLBILevel : +forall (x y : TLBILevel), Decidable (x = y) := +Decidable_eq_from_dec TLBILevel_eq_dec. + +Inductive TLBIMemAttr := TLBI_AllAttr | TLBI_ExcludeXS. +Scheme Equality for TLBIMemAttr. +#[export] Instance Decidable_eq_TLBIMemAttr : +forall (x y : TLBIMemAttr), Decidable (x = y) := +Decidable_eq_from_dec TLBIMemAttr_eq_dec. + +Inductive TLBIOp := + TLBIOp_DALL + | TLBIOp_DASID + | TLBIOp_DVA + | TLBIOp_IALL + | TLBIOp_IASID + | TLBIOp_IVA + | TLBIOp_ALL + | TLBIOp_ASID + | TLBIOp_IPAS2 + | TLBIOp_VAA + | TLBIOp_VA + | TLBIOp_VMALL + | TLBIOp_VMALLS12 + | TLBIOp_RIPAS2 + | TLBIOp_RVAA + | TLBIOp_RVA + | TLBIOp_RPA + | TLBIOp_PAALL. +Scheme Equality for TLBIOp. +#[export] Instance Decidable_eq_TLBIOp : +forall (x y : TLBIOp), Decidable (x = y) := +Decidable_eq_from_dec TLBIOp_eq_dec. + +Record TLBIRecord := + { TLBIRecord_op : TLBIOp; + TLBIRecord_from_aarch64 : bool; + TLBIRecord_security : SecurityState; + TLBIRecord_regime : Regime; + TLBIRecord_vmid : bits 16; + TLBIRecord_asid : bits 16; + TLBIRecord_level : TLBILevel; + TLBIRecord_attr : TLBIMemAttr; + TLBIRecord_ipaspace : PASpace; + TLBIRecord_address : bits 64; + TLBIRecord_end_address_name : bits 64; + TLBIRecord_tg : bits 2; }. +Arguments TLBIRecord : clear implicits. +Notation "{[ r 'with' 'TLBIRecord_op' := e ]}" := + match r with Build_TLBIRecord _ f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 => + Build_TLBIRecord e f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_from_aarch64' := e ]}" := + match r with Build_TLBIRecord f0 _ f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 => + Build_TLBIRecord f0 e f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_security' := e ]}" := + match r with Build_TLBIRecord f0 f1 _ f3 f4 f5 f6 f7 f8 f9 f10 f11 => + Build_TLBIRecord f0 f1 e f3 f4 f5 f6 f7 f8 f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_regime' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 _ f4 f5 f6 f7 f8 f9 f10 f11 => + Build_TLBIRecord f0 f1 f2 e f4 f5 f6 f7 f8 f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_vmid' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 f3 _ f5 f6 f7 f8 f9 f10 f11 => + Build_TLBIRecord f0 f1 f2 f3 e f5 f6 f7 f8 f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_asid' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 f3 f4 _ f6 f7 f8 f9 f10 f11 => + Build_TLBIRecord f0 f1 f2 f3 f4 e f6 f7 f8 f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_level' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 f3 f4 f5 _ f7 f8 f9 f10 f11 => + Build_TLBIRecord f0 f1 f2 f3 f4 f5 e f7 f8 f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_attr' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 _ f8 f9 f10 f11 => + Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 e f8 f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_ipaspace' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 f7 _ f9 f10 f11 => + Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 f7 e f9 f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_address' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 _ f10 f11 => + Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 e f10 f11 end. +Notation "{[ r 'with' 'TLBIRecord_end_address_name' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 _ f11 => + Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 e f11 end. +Notation "{[ r 'with' 'TLBIRecord_tg' := e ]}" := + match r with Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 _ => + Build_TLBIRecord f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 e end. + +Inductive MBReqDomain := + MBReqDomain_Nonshareable + | MBReqDomain_InnerShareable + | MBReqDomain_OuterShareable + | MBReqDomain_FullSystem. +Scheme Equality for MBReqDomain. +#[export] Instance Decidable_eq_MBReqDomain : +forall (x y : MBReqDomain), Decidable (x = y) := +Decidable_eq_from_dec MBReqDomain_eq_dec. + +Inductive MBReqTypes := MBReqTypes_Reads | MBReqTypes_Writes | MBReqTypes_All. +Scheme Equality for MBReqTypes. +#[export] Instance Decidable_eq_MBReqTypes : +forall (x y : MBReqTypes), Decidable (x = y) := +Decidable_eq_from_dec MBReqTypes_eq_dec. + +Inductive MemBarrierOp := + MemBarrierOp_DSB + | MemBarrierOp_DMB + | MemBarrierOp_ISB + | MemBarrierOp_SSBB + | MemBarrierOp_PSSBB + | MemBarrierOp_SB. +Scheme Equality for MemBarrierOp. +#[export] Instance Decidable_eq_MemBarrierOp : +forall (x y : MemBarrierOp), Decidable (x = y) := +Decidable_eq_from_dec MemBarrierOp_eq_dec. + +Definition Level : Type := {rangevar : Z & ArithFact ((-1 <=? rangevar) && (rangevar <=? 4))}. + +Record TranslationInfo := + { TranslationInfo_regime : Regime; + TranslationInfo_vmid : option (bits 16); + TranslationInfo_asid : option (bits 16); + TranslationInfo_va : bits 64; + TranslationInfo_s1level : option Level; + TranslationInfo_s2info : option ((bits 64 * Level)); + TranslationInfo_s1params : option S1TTWParams; + TranslationInfo_s2params : option S2TTWParams; + TranslationInfo_memattr : MemoryAttributes; }. +Arguments TranslationInfo : clear implicits. +Notation "{[ r 'with' 'TranslationInfo_regime' := e ]}" := + match r with Build_TranslationInfo _ f1 f2 f3 f4 f5 f6 f7 f8 => + Build_TranslationInfo e f1 f2 f3 f4 f5 f6 f7 f8 end. +Notation "{[ r 'with' 'TranslationInfo_vmid' := e ]}" := + match r with Build_TranslationInfo f0 _ f2 f3 f4 f5 f6 f7 f8 => + Build_TranslationInfo f0 e f2 f3 f4 f5 f6 f7 f8 end. +Notation "{[ r 'with' 'TranslationInfo_asid' := e ]}" := + match r with Build_TranslationInfo f0 f1 _ f3 f4 f5 f6 f7 f8 => + Build_TranslationInfo f0 f1 e f3 f4 f5 f6 f7 f8 end. +Notation "{[ r 'with' 'TranslationInfo_va' := e ]}" := + match r with Build_TranslationInfo f0 f1 f2 _ f4 f5 f6 f7 f8 => + Build_TranslationInfo f0 f1 f2 e f4 f5 f6 f7 f8 end. +Notation "{[ r 'with' 'TranslationInfo_s1level' := e ]}" := + match r with Build_TranslationInfo f0 f1 f2 f3 _ f5 f6 f7 f8 => + Build_TranslationInfo f0 f1 f2 f3 e f5 f6 f7 f8 end. +Notation "{[ r 'with' 'TranslationInfo_s2info' := e ]}" := + match r with Build_TranslationInfo f0 f1 f2 f3 f4 _ f6 f7 f8 => + Build_TranslationInfo f0 f1 f2 f3 f4 e f6 f7 f8 end. +Notation "{[ r 'with' 'TranslationInfo_s1params' := e ]}" := + match r with Build_TranslationInfo f0 f1 f2 f3 f4 f5 _ f7 f8 => + Build_TranslationInfo f0 f1 f2 f3 f4 f5 e f7 f8 end. +Notation "{[ r 'with' 'TranslationInfo_s2params' := e ]}" := + match r with Build_TranslationInfo f0 f1 f2 f3 f4 f5 f6 _ f8 => + Build_TranslationInfo f0 f1 f2 f3 f4 f5 f6 e f8 end. +Notation "{[ r 'with' 'TranslationInfo_memattr' := e ]}" := + match r with Build_TranslationInfo f0 f1 f2 f3 f4 f5 f6 f7 _ => + Build_TranslationInfo f0 f1 f2 f3 f4 f5 f6 f7 e end. + +Record DxB := { DxB_domain : MBReqDomain; DxB_types : MBReqTypes; DxB_nXS : bool; }. +Arguments DxB : clear implicits. +Notation "{[ r 'with' 'DxB_domain' := e ]}" := + match r with Build_DxB _ f1 f2 => Build_DxB e f1 f2 end. +Notation "{[ r 'with' 'DxB_types' := e ]}" := + match r with Build_DxB f0 _ f2 => Build_DxB f0 e f2 end. +Notation "{[ r 'with' 'DxB_nXS' := e ]}" := match r with Build_DxB f0 f1 _ => Build_DxB f0 f1 e end. + +Inductive Barrier := + | Barrier_DSB : DxB -> Barrier + | Barrier_DMB : DxB -> Barrier + | Barrier_ISB : unit -> Barrier + | Barrier_SSBB : unit -> Barrier + | Barrier_PSSBB : unit -> Barrier + | Barrier_SB : unit -> Barrier. +Arguments Barrier : clear implicits. + +Record TLBI := { TLBI_rec : TLBIRecord; TLBI_shareability : Shareability; }. +Arguments TLBI : clear implicits. +Notation "{[ r 'with' 'TLBI_rec' := e ]}" := match r with Build_TLBI _ f1 => Build_TLBI e f1 end. +Notation "{[ r 'with' 'TLBI_shareability' := e ]}" := + match r with Build_TLBI f0 _ => Build_TLBI f0 e end. + +Record Exn := { Exn_rec : ExceptionRecord; Exn_fault : option FaultRecord; }. +Arguments Exn : clear implicits. +Notation "{[ r 'with' 'Exn_rec' := e ]}" := match r with Build_Exn _ f1 => Build_Exn e f1 end. +Notation "{[ r 'with' 'Exn_fault' := e ]}" := match r with Build_Exn f0 _ => Build_Exn f0 e end. + +Inductive arm_acc_type := + | SAcc_STREAM : unit -> arm_acc_type + | SAcc_VEC : bool -> arm_acc_type + | SAcc_SVE : bool -> arm_acc_type + | SAcc_SME : bool -> arm_acc_type + | SAcc_UNPRIV : bool -> arm_acc_type + | SAcc_A32LSMD : unit -> arm_acc_type + | SAcc_ATOMICLS64 : unit -> arm_acc_type + | SAcc_LIMITEDORDERED : unit -> arm_acc_type + | SAcc_NONFAULT : unit -> arm_acc_type + | SAcc_CNOTFIRST : unit -> arm_acc_type + | SAcc_NV2REGISTER : unit -> arm_acc_type + | SAcc_DC : unit -> arm_acc_type + | SAcc_IC : unit -> arm_acc_type + | SAcc_DCZVA : unit -> arm_acc_type + | SAcc_ATPAN : unit -> arm_acc_type + | SAcc_AT : unit -> arm_acc_type. +Arguments arm_acc_type : clear implicits. + +Inductive register_value := + | Regval_vector : list register_value -> register_value + | Regval_list : list register_value -> register_value + | Regval_option : option register_value -> register_value + | Regval_bool : bool -> register_value + | Regval_int : Z -> register_value + | Regval_real : R -> register_value + | Regval_string : string -> register_value + | Regval_bit : bitU -> register_value. +Arguments register_value : clear implicits. + +Definition regstate : Type := unit. + + + +Definition bit_of_regval (merge_var : register_value) : option bitU := + match merge_var with | Regval_bit v => Some v | _ => None end. + +Definition regval_of_bit (v : bitU) : register_value := Regval_bit v. + + + +Definition bool_of_regval (merge_var : register_value) : option bool := + match merge_var with | Regval_bool v => Some v | _ => None end. + +Definition regval_of_bool (v : bool) : register_value := Regval_bool v. + +Definition int_of_regval (merge_var : register_value) : option Z := + match merge_var with | Regval_int v => Some v | _ => None end. + +Definition regval_of_int (v : Z) : register_value := Regval_int v. + +Definition real_of_regval (merge_var : register_value) : option R := + match merge_var with | Regval_real v => Some v | _ => None end. + +Definition regval_of_real (v : R) : register_value := Regval_real v. + +Definition string_of_regval (merge_var : register_value) : option string := + match merge_var with | Regval_string v => Some v | _ => None end. + +Definition regval_of_string (v : string) : register_value := Regval_string v. + +Definition vector_of_regval {a} n (of_regval : register_value -> option a) (rv : register_value) : option (vec a n) := match rv with + | Regval_vector v => if n =? length_list v then map_bind (vec_of_list n) (just_list (List.map of_regval v)) else None + | _ => None +end. + +Definition regval_of_vector {a size} (regval_of : a -> register_value) (xs : vec a size) : register_value := Regval_vector (List.map regval_of (list_of_vec xs)). + +Definition list_of_regval {a} (of_regval : register_value -> option a) (rv : register_value) : option (list a) := match rv with + | Regval_list v => just_list (List.map of_regval v) + | _ => None +end. + +Definition regval_of_list {a} (regval_of : a -> register_value) (xs : list a) : register_value := Regval_list (List.map regval_of xs). + +Definition option_of_regval {a} (of_regval : register_value -> option a) (rv : register_value) : option (option a) := match rv with + | Regval_option v => option_map of_regval v + | _ => None +end. + +Definition regval_of_option {a} (regval_of : a -> register_value) (v : option a) := Regval_option (option_map regval_of v). + + + +Local Open Scope string. +Definition get_regval (reg_name : string) (s : regstate) : option register_value := + + None. + +Definition set_regval (reg_name : string) (v : register_value) (s : regstate) : option regstate := + + None. + +Definition register_accessors := (get_regval, set_regval). + + +Definition MR a r := monadR register_value a r unit. +Definition M a := monad register_value a unit. +Definition returnM {A:Type} := @returnm register_value A unit. +Definition returnR {A:Type} (R:Type) := @returnm register_value A (R + unit). diff --git a/system-semantics/ISASem/dune b/system-semantics/ISASem/dune new file mode 100644 index 0000000..9041b01 --- /dev/null +++ b/system-semantics/ISASem/dune @@ -0,0 +1,24 @@ +(coq.theory + (name ISASem) + (package coq-system-semantics) + (modules + Interface + SailArmInstTypes + ArmInst) + (stdlib yes) + (theories + Ltac2 + stdpp + RecordUpdate + Hammer.Tactics + bbv + Sail + SSCCommon + ) +) + +; (rule +; (targets SailArmInst.v SailArmInst_types.v) +; (deps armtypes.sail ../armv9-instantiation-types/interfacetypes.sail) +; (action (run sail -coq armtypes.sail -o SailArmInst)) +; ) diff --git a/system-semantics/LICENSE b/system-semantics/LICENSE new file mode 100644 index 0000000..b98742b --- /dev/null +++ b/system-semantics/LICENSE @@ -0,0 +1,36 @@ +BSD 2-clause License + +This applies to all files in this archive except where +specified otherwise. + +Copyright (c) 2022 + Thibaut Pérami + Jean Pichon-Pharabod + Brian Campbell + Alasdair Armstrong + Ben Simner + Peter Sewell + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/system-semantics/coq-system-semantics.opam b/system-semantics/coq-system-semantics.opam new file mode 100644 index 0000000..6658c51 --- /dev/null +++ b/system-semantics/coq-system-semantics.opam @@ -0,0 +1,25 @@ +opam-version: "0.1" +name: "coq-system-semantics" +maintainer: "Thibaut Pérami " +authors: "Thibaut Pérami " +license: "BSD-3-Clause" +homepage: "https://github.com/rems-project/system-semantics-coq" +bug-reports: "https://github.com/rems-project/system-semantics-coq/issues" +dev-repo: "git+https://github.com/rems-project/system-semantics-coq.git" + +synopsis: "Coq infrastructure to reason about hardware system semantics" + +depends: [ + "coq" { (>= "8.14.0") | (= "dev") } + "dune" {>= "3.0"} + "coq-stdpp" + "coq-stdpp-unstable" + "coq-record-update" {>= "0.3.0"} + "coq-sail" {>= "0.15"} + "coq-hammer-tactics" {>= "1.3.2"} +] + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] diff --git a/system-semantics/dune b/system-semantics/dune new file mode 100644 index 0000000..a2233a8 --- /dev/null +++ b/system-semantics/dune @@ -0,0 +1,3 @@ +(alias + (name default) + (deps (alias_rec install))) diff --git a/system-semantics/dune-project b/system-semantics/dune-project new file mode 100644 index 0000000..f47d5e0 --- /dev/null +++ b/system-semantics/dune-project @@ -0,0 +1,2 @@ +(lang dune 3.9) +(using coq 0.8) diff --git a/theories/CandidateExecutions.v b/theories/CandidateExecutions.v new file mode 100644 index 0000000..4da7115 --- /dev/null +++ b/theories/CandidateExecutions.v @@ -0,0 +1,1033 @@ +(* Simplified version of [CandidateExecutions.v] of [system-semantics-coq]. *) + +(** This file provide a common type for representing candidate executions + for all memory models to use *) + +Require Import Ensembles. + +Require Import Strings.String. + +From stdpp Require Export listset. +From stdpp Require Export gmap. + +Require Import SSCCommon.Common. +Require Import SSCCommon.Exec. +Require Import SSCCommon.GRel. + +Require Import ISASem.Interface. +Require Import ISASem.SailArmInstTypes. + + +Open Scope Z_scope. +Open Scope stdpp_scope. + +(* event ID *) +Module EID. + Record t := + make { + (* thread ID *) + tid : nat; + (* Instruction ID *) + iid : nat; + (* event number *) + num : nat + }. + + #[global] Instance eta : Settable _ := + settable! make . + + #[global] Instance eq_dec : EqDecision t. + Proof. solve_decision. Defined. + + #[global] Instance countable : Countable t. + Proof. + eapply (inj_countable' (fun eid => (tid eid, iid eid, num eid)) + (fun x => make x.1.1 x.1.2 x.2)). + sauto. + Qed. +End EID. + +Module CandidateExecutions (Arch : Arch) (IA : InterfaceT Arch). (* to be imported *) + Import Arch. + Import IA. + Notation outcome := (IA.outcome empOutcome). + Notation iMon := (IA.iMon empOutcome). + Notation iSem := (IA.iSem empOutcome). + Notation iEvent := (IA.iEvent empOutcome). + Notation iTrace := (IA.iTrace empOutcome). + + + Module Candidate. + + Record t := + make { + (** Each thread is a list of instruction, which each have a trace. + We force the return type to be unit, but it just means we + forget the actual value. *) + events : list (list (iTrace ())); + (** Program order. The per-thread order of all events in the trace + po can be deduced by the order of events in the trace *) + po : grel EID.t; + (** Memory read-from *) + rf : grel EID.t; + (** Memory coherence: for each pa, list of writes in order *) + co : grel EID.t; + (** Register read from (needed because of potentially relaxed register) *) + rrf : grel EID.t; + (** rmw *) + rmw : grel EID.t; + (** Same instruction, should be an equivalence relation. + can be deduced from trace structure *) + si : grel EID.t; + (** intra-instruction address dependencies (to memory events) *) + iio_addr : grel EID.t; + (** intra-instruction data dependencies (to memory and register writes) *) + iio_data : grel EID.t; + (** intra-instruction control dependencies (to branches) *) + iio_ctrl : grel EID.t; + }. + + (** NOTE: we assume initial writes are in the traces of thread 0, one trace contains only one such write*) + + (** Get an event at a given event ID in a candidate *) + Global Instance lookup_eid : Lookup EID.t iEvent t := + fun eid cd => + traces ← cd.(events) !! eid.(EID.tid); + '(trace, result) ← traces !! eid.(EID.iid); + trace !! eid.(EID.num). + + (** This is true if one of the thread had an ISA model failure + like a Sail assertion or an Isla assumption that failed *) + Definition failed (cd : t) : bool := + existsb (fun traces => + let '(trace, trace_end) := List.last traces ([], inl ()) in + match trace_end with | inr _ => true | inl _ => false end) + cd.(events). + + Definition event_list (cd : t) : list (EID.t*iEvent) := + '(tid, traces) ← enumerate cd.(events); + '(iid, (trace, trace_end)) ← enumerate traces; + '(num, event) ← enumerate trace; + [(EID.make tid iid num, event)]. + + Global Typeclasses Opaque event_list. + + Import SetUnfoldPair. + + Lemma event_list_match cd eid ev : + cd !! eid = Some ev ↔ (eid, ev) ∈ event_list cd. + Proof. + (* Unfold everything properly on both side, and naive_solver does it. *) + unfold lookup at 1. + unfold lookup_eid. + repeat setoid_rewrite bind_Some. + unfold event_list. + destruct eid. + set_unfold. + repeat setoid_rewrite exists_pair. + naive_solver. + Qed. + + Global Instance set_unfold_elem_of_event_list cd x : + SetUnfoldElemOf x (event_list cd) (cd !! x.1 = Some x.2). + Proof. tcclean. destruct x. symmetry. apply event_list_match. Qed. + + Lemma event_list_NoDup1 cd : NoDup (event_list cd).*1. + Proof. + unfold event_list. + rewrite fmap_unfold. + cbn. + apply NoDup_bind; + [set_unfold; hauto lq:on rew:off | idtac | apply NoDup_enumerate]. + intros [? ?] ?. + apply NoDup_bind; + [set_unfold; hauto lq:on rew:off | idtac | apply NoDup_enumerate]. + intros [? [? ?]] ?. + apply NoDup_bind; + [set_unfold; hauto lq:on rew:off | idtac | apply NoDup_enumerate]. + intros [? [? ?]] ?. + auto with nodup. + Qed. + + Lemma event_list_NoDup cd : NoDup (event_list cd). + Proof. eapply NoDup_fmap_1. apply event_list_NoDup1. Qed. + + Definition event_map (cd : t) : gmap EID.t iEvent := + event_list cd |> list_to_map. + + Lemma event_map_match cd eid : (event_map cd) !! eid = cd !! eid. + Proof. + unfold event_map. + destruct (cd !! eid) eqn: Heq. + - apply elem_of_list_to_map. + + apply event_list_NoDup1. + + set_solver. + - apply not_elem_of_list_to_map_1. + set_solver. + Qed. + + Global Instance lookup_unfold_event_map x cd R : + LookupUnfold x cd R → LookupUnfold x (event_map cd) R. + Proof. tcclean. apply event_map_match. Qed. + + (** Accessors *) + + Definition collect_all (P : iEvent -> bool) (cd : t) : gset EID.t := + filter (fun '(eid, event) => P event) (event_list cd) + |> map fst |> list_to_set. + + Global Instance set_unfold_elem_of_filter `{FinSet A B} + `{∀ x : A, Decision (P x)} x (a : B) Q: + SetUnfoldElemOf x a Q -> + SetUnfoldElemOf x (filter P a) (P x ∧ Q). + Proof. tcclean. apply elem_of_filter. Qed. + + Global Instance set_unfold_elem_of_filter_list A + `{∀ x : A, Decision (P x)} x (a : list A) Q: + SetUnfoldElemOf x a Q -> + SetUnfoldElemOf x (filter P a) (P x ∧ Q). + Proof. tcclean. apply elem_of_list_filter. Qed. + + Global Instance set_elem_of_collect_all eid P cd : + SetUnfoldElemOf eid (collect_all P cd) (∃x, cd !! eid = Some x ∧ P x). + Proof. tcclean. set_unfold. hauto db:core. Qed. + Global Typeclasses Opaque collect_all. + + (** Get the set of all valid EID for that candidate *) + Definition valid_eid (cd : t) := + collect_all (fun event => true) cd. + + (** Get the set of all register reads *) + Definition reg_reads (cd : t) := + collect_all + (fun event => + match event with + | IEvent (RegRead _ _) _ => true + | _ => false end) + cd. + + Global Instance set_elem_of_reg_read eid cd : + SetUnfoldElemOf eid (reg_reads cd) + (∃ reg reg_acc res, + cd !! eid = Some (IEvent (RegRead reg reg_acc) res)). + Proof. tcclean. set_unfold. hauto l:on. Qed. + Global Typeclasses Opaque reg_reads. + + (** Get the set of all register writes *) + Definition reg_writes (cd : t) := + collect_all + (fun event => + match event with + | IEvent (RegWrite _ _ _ _) _ => true + | _ => false end) + cd. + + Global Instance set_elem_of_reg_writes eid cd : + SetUnfoldElemOf eid (reg_writes cd) + (∃ reg reg_acc dep val, + cd !! eid = Some (IEvent (RegWrite reg reg_acc dep val) ())). + Proof. tcclean. set_unfold. sauto dep:on. Qed. + Global Typeclasses Opaque reg_writes. + + Definition wreq_is_valid {n} (r: WriteReq.t n) := + match r.(WriteReq.access_kind) with + | AK_explicit _ => true + | _ => false + end. + + Definition wresp_is_valid (o : option bool + abort) := + match o with + | inl None | inl (Some true) => true + | _ => false + end. + + Definition rresp_is_valid {n} (o : bitvector.bv (8 * n) * option bool + abort) := + match o with + | inl _ => true + | _ => false + end. + + Definition rreq_is_valid {n} (r : ReadReq.t n) := + match r.(ReadReq.access_kind) with + | AK_explicit _ => true + | _ => false + end. + + (** Get the set of all memory reads *) + Definition mem_reads (cd : t) := + collect_all + (fun event => + match event with + (* | IEvent (MemRead _ rreq) rresp => rreq_is_valid rreq && rresp_is_valid rresp *) + | IEvent (MemRead _ _) _ => true + | _ => false end) + cd. + + Global Instance set_elem_of_mem_reads eid cd : + SetUnfoldElemOf eid (mem_reads cd) + (* (∃ n rr res, cd !! eid = Some (IEvent (MemRead n rr) res) ∧ (rreq_is_valid rr && rresp_is_valid res)). *) + (∃ n rr res, cd !! eid = Some (IEvent (MemRead n rr) res)). + Proof. tcclean. set_unfold. hauto l:on. Qed. + Global Typeclasses Opaque mem_reads. + + (** Get the set of all memory writes *) + Definition mem_writes (cd : t) := + collect_all + (fun event => + match event with + (* | IEvent (MemWrite _ wreq) wresp => wreq_is_valid wreq && wresp_is_valid wresp *) + | IEvent (MemWrite _ _) _ => true + | _ => false end) + cd. + + Global Instance set_elem_of_mem_writes eid cd : + SetUnfoldElemOf eid (mem_writes cd) + (* (∃ n wr res, cd !! eid = Some (IEvent (MemWrite n wr) res) ∧ (wreq_is_valid wr && wresp_is_valid res)). *) + (∃ n wr res, cd !! eid = Some (IEvent (MemWrite n wr) res)). + Proof. tcclean. set_unfold. hauto l:on. Qed. + Global Typeclasses Opaque mem_writes. + + (** Get the set of all memory writes *) + Definition mem_events (cd : t) := + collect_all + (fun event => + match event with + (* | IEvent (MemRead _ rreq) rresp => rreq_is_valid rreq && rresp_is_valid rresp *) + (* | IEvent (MemWrite _ wreq) wresp => wreq_is_valid wreq && wresp_is_valid wresp *) + | IEvent (MemRead _ _) _ => true + | IEvent (MemWrite _ _) _ => true + | _ => false end) + cd. + + (** Get the set of all barriers *) + Definition branches (cd : t) := + collect_all + (fun event => + match event with + | IEvent (BranchAnnounce _ _) _ => true + | _ => false end) + cd. + + (** Get the set of all barriers *) + Definition barriers (cd : t) := + collect_all + (fun event => + match event with + | IEvent (Barrier _) _ => true + | _ => false end) + cd. + + + #[global] Instance access_strength_eqdec : (EqDecision Access_strength). + Proof. intros ??. destruct x, y; try (left;done);right;done. Qed. + #[global] Instance access_variety_eqdec : (EqDecision Access_variety). + Proof. intros ??. destruct x, y; try (left;done);right;done. Qed. + #[global] Instance explicit_access_kind_eqdec : (EqDecision Explicit_access_kind). + Proof. + intros ??. destruct x as [x1 x2], y as [y1 y2]. + unfold Decision. decide equality;decide equality. + Qed. + + + (** Get the content of a barrier, returns none if not a barrier (or is an + invalid EID) *) + Definition get_barrier (cd : t) (eid : EID.t) : option barrier:= + match cd !! eid with + | Some (IEvent (Barrier b) ()) => Some b + | _ => None + end. + + Definition kind_of_wreq_P{n} (req: WriteReq.t n) (P: Explicit_access_kind -> bool) := + match req.(WriteReq.access_kind) with + | AK_explicit eaκ=> P eaκ + | _ => false + end. + + Definition kind_of_wreq{n} (req: WriteReq.t n) := + kind_of_wreq_P req (λ _, true). + + Definition kind_of_rreq_P {n} (req: ReadReq.t n) (P: Explicit_access_kind -> bool):= + match req.(ReadReq.access_kind) with + | AK_explicit eaκ=> P eaκ + | _ => false + end. + + Definition kind_of_rreq {n} (req: ReadReq.t n) := + kind_of_rreq_P req (λ _, true). + + Definition kind_of_rreq_is_atomic {n} (rreq : ReadReq.t n) := + kind_of_rreq_P rreq (λ eaκ, bool_decide (eaκ.(Explicit_access_kind_variety) = AV_exclusive) || + bool_decide (eaκ.(Explicit_access_kind_variety) = AV_atomic_rmw)). + + Definition kind_of_wreq_is_atomic {n} (wreq : WriteReq.t n) := + kind_of_wreq_P wreq (λ eaκ, bool_decide (eaκ.(Explicit_access_kind_variety) = AV_exclusive) || + bool_decide (eaκ.(Explicit_access_kind_variety) = AV_atomic_rmw)). + + Definition mem_writes_pln_zero (cd : t) : gset EID.t := + collect_all + (fun event => + match event : iEvent with + | IEvent (MemWrite _ wr) wresp => + (bool_decide (wr.(WriteReq.value) = (bv_0 _))) + && (negb (kind_of_wreq_is_atomic wr)) + && wreq_is_valid wr + && wresp_is_valid wresp + | _ => false + end) + cd. + + Definition mem_writes_atomic (cd : t) : gset EID.t := + collect_all + (fun event => + match event : iEvent with + | IEvent (MemWrite _ wr) wresp => + kind_of_wreq_is_atomic wr && wresp_is_valid wresp + | _ => false + end) + cd. + + Definition mem_reads_atomic (cd : t) : gset EID.t := + collect_all + (fun event => + match event : iEvent with + | IEvent (MemRead _ rr) rresp => + kind_of_rreq_is_atomic rr && rresp_is_valid rresp + | _ => false + end) + cd. + + (** Utility relations *) + Definition addr (cd : t) := + ⦗mem_reads cd⦘⨾ + (⦗mem_reads cd⦘ ∪ (iio_data cd ⨾ (rrf cd ∪ ⦗reg_writes cd⦘))⁺)⨾ + iio_addr cd⨾ + ⦗mem_events cd⦘. + + Definition data (cd : t) := + ⦗mem_reads cd⦘⨾ + (⦗mem_reads cd⦘ ∪ (iio_data cd ⨾ (rrf cd ∪ ⦗reg_writes cd⦘))⁺)⨾ + iio_data cd⨾ + ⦗mem_events cd⦘. + + Definition ctrl (cd : t) := + ⦗mem_reads cd⦘⨾ + (⦗mem_reads cd⦘ ∪ (iio_data cd ⨾ (rrf cd ∪ ⦗reg_writes cd⦘))⁺)⨾ + iio_ctrl cd⨾ + ⦗branches cd⦘⨾ + (po cd ∖ si cd). + + + Definition incoming_of (r : grel EID.t) (e : EID.t) := + filter (fun '(_, e_tgt) => e_tgt = e) r. + + Definition outgoing_of (r : grel EID.t) (e : EID.t) := + filter (fun '(e_src, _) => e_src = e) r. + + Definition external_of (r: grel EID.t) := + filter (fun '(e_src,e_tgt) => e_src.(EID.tid) ≠ e_tgt.(EID.tid)) r. + + Definition internal_of (r: grel EID.t) := + filter (fun '(e_src,e_tgt) => e_src.(EID.tid) = e_tgt.(EID.tid)) r. + + + (* In this version, [P] takes an extra [EID.t] which makes this definition more useful for stating some lemmas *) + Definition collect_all' (P : EID.t -> iEvent -> bool) (cd : t) : gset EID.t := + filter (fun '(eid, event) => P eid event) (event_list cd) + |> map fst |> list_to_set. + Global Instance set_elem_of_collect_all' eid P cd : + SetUnfoldElemOf eid (collect_all' P cd) (∃x, cd !! eid = Some x ∧ P eid x). + Proof. tcclean. set_unfold. hauto db:core. Qed. + Global Typeclasses Opaque collect_all'. + + (** A folding and filtering helper that returns a gmap from some [K] to sets of EIDs *) + Definition event_list_fold `{Countable K} (cd : t) (b : gmap K (gset EID.t)) (P : EID.t -> iEvent -> option K) := + fold_left (λ acc '(eid, event), (match (P eid event) with + | Some k => {[ k := {[eid]}]} + | None => ∅ + end) ∪ₘ acc) (event_list cd) b. + + Lemma lookup_total_unfold_event_list_fold `{Countable K} (cd : t) (P : EID.t -> iEvent -> option K) (b : gmap K (gset EID.t)) (k: K): + (forall k, b !!! k ## collect_all' (λ _ _, true) cd) -> + LookupTotalUnfold k (event_list_fold cd b P) (b !!! k ∪ collect_all' (λ eid event, match (P eid event) with + | Some k' => k' =? k + | None => false + end) cd). + Proof. + unfold event_list_fold, valid_eid, collect_all'. + tcclean. + revert b H0. + pose proof (event_list_NoDup1 cd) as Hdup. + induction (event_list cd). + set_solver. + assert (map fst (filter (λ '(_, _), True) l) = l.*1) as Heql. + { clear. induction l;first done. rewrite filter_cons_True. rewrite map_cons. hauto. hauto. } + + destruct a as [eid event]. + rewrite fmap_cons in Hdup. + specialize (IHl (NoDup_cons_1_2 _ _ Hdup)). + apply NoDup_cons_1_1 in Hdup. + rewrite filter_cons. simpl. + rewrite filter_cons. simpl. case_decide as HP. + - destruct (P eid event);[|contradiction]. + rewrite bool_unfold in HP;subst;intros;simpl. + rewrite IHl. + assert ( ({[k := {[eid]}]} ∪ₘ b) !!! k = {[eid]} ∪ b !!! k) as ->. + apply lookup_total_unfold_pointwise_union; apply _. + set_solver + H0. + intros. destruct (decide (k = k0)). + subst k0. assert ( ({[k := {[eid]}]} ∪ₘ b) !!! k = {[eid]} ∪ b !!! k) as ->. + apply lookup_total_unfold_pointwise_union; apply _. + rewrite Heql. rewrite Heql in H0. set_solver + H0 Hdup. + assert ( ({[k := {[eid]}]} ∪ₘ b) !!! k0 = ∅ ∪ b !!! k0) as ->. + apply lookup_total_unfold_pointwise_union; apply _. + set_solver + H0. + - destruct (P eid event); rewrite bool_unfold in HP;subst;intros;simpl. + + rewrite IHl. + assert ( (({[k0 := {[eid]}]}) ∪ₘ b) !!! k = ∅ ∪ b !!! k) as ->. + apply lookup_total_unfold_pointwise_union; apply _. + set_solver + H0. + intros. + destruct (decide (k0 = k1)). + * assert ( (({[k0 := {[eid]}]}) ∪ₘ b) !!! k1 = {[eid]} ∪ b !!! k1) as ->. + apply lookup_total_unfold_pointwise_union. + rewrite e. apply _. apply _. + rewrite Heql. rewrite Heql in H0. set_solver + H0 Hdup. + * assert ( (({[k0 := {[eid]}]}) ∪ₘ b) !!! k1 = ∅ ∪ b !!! k1) as ->. + apply lookup_total_unfold_pointwise_union. + apply _. apply _. + set_solver + H0. + + rewrite IHl. + assert ( (∅ ∪ₘ b) !!! k = ∅ ∪ b !!! k) as ->. + apply lookup_total_unfold_pointwise_union; apply _. + set_solver +. + intros. assert ( (∅ ∪ₘ b) !!! k0 = ∅ ∪ b !!! k0) as ->. + apply lookup_total_unfold_pointwise_union; apply _. + set_solver + H0. + Qed. + + Lemma event_list_fold_is_Some `{Countable K} (cd : t) (P : EID.t -> iEvent -> option K) (k: K) b: + (is_Some (b !! k) ∨ ∃ eid event, (eid, event) ∈ event_list cd ∧ P eid event = Some k) -> + is_Some((event_list_fold cd b P) !! k). + Proof. + unfold event_list_fold. revert b. + induction (event_list cd) ;intros ; first set_solver. + simpl. destruct a as [eid event]. destruct H0. + apply IHl. destruct H0. left. case_match. destruct (decide (k = k0)). + subst k0. exists ({[eid]} ∪ x). assert (Some {[eid]} ∪ₒ Some x = Some ({[eid]} ∪ x)) as <-. done. + apply lookup_unfold_pointwise_union. tcclean. rewrite lookup_singleton_Some;hauto. done. + + exists x. assert (None ∪ₒ Some x = Some x) as <-. done. + apply lookup_unfold_pointwise_union. tcclean. rewrite lookup_singleton_None;hauto. done. + + exists x. assert (None ∪ₒ Some x = Some x) as <-. done. + apply lookup_unfold_pointwise_union. tcclean. rewrite lookup_empty;hauto. done. + + destruct H0 as (?&?&?&?). + rewrite elem_of_cons in H0. + destruct H0 as [H0 | Hin]. inversion H0;subst. + * rewrite H1. apply IHl. left. + destruct (b !! k) eqn:Hb. + exists ({[eid]} ∪ g). assert (Some {[eid]} ∪ₒ Some g = Some ({[eid]} ∪ g)) as <-. done. + apply lookup_unfold_pointwise_union. tcclean. rewrite lookup_singleton_Some;hauto. done. + exists {[eid]}. assert (Some {[eid]} ∪ₒ None = Some {[eid]}) as <-. done. + apply lookup_unfold_pointwise_union. tcclean. rewrite lookup_singleton_Some;hauto. done. + * apply IHl. right. do 2 eexists. naive_solver. + Qed. + + Definition get_pa (e : iEvent) : option (Arch.pa):= + match e with + | IEvent (MemRead _ rr) _ => Some (rr.(ReadReq.pa)) + | IEvent (MemWrite n rr) _ => Some (rr.(WriteReq.pa)) + | _ => None + end. + + (** Symmetry relation referring to events having the same address. + Might need to be updated for mixed-size *) + Definition loc (cd : t) : grel EID.t := + let pa_map : gmap pa (gset EID.t) := + event_list_fold cd ∅ (λ _ event, get_pa event)in + map_fold (fun (k : pa) (s : gset EID.t) (r : grel EID.t) => r ∪ (s × s)) + ∅ pa_map. + + #[export] Instance set_elem_of_map_fold_set_union `{Countable K, Countable K'} {V} (m : gmap K V) b e (f : K -> V -> gset K') : + SetUnfoldElemOf (e) (map_fold (fun (k: K) (v : V) (r : gset K') => r ∪ (f k v)) b m) + (e ∈ b ∨ ∃ k v, m !! k = Some v ∧ e ∈ (f k v)). + Proof. + tcclean. cinduction m using map_fold_cind. + hauto lq:on use:lookup_empty_Some. + set_unfold. setoid_rewrite H2; clear H2. + split. + - intros [[| (?&?&?&?)]|];first hauto lq:on; + (destruct (decide (e ∈ b));[hauto lq:on | right; do 2 eexists; rewrite lookup_insert_Some; sauto lq:on]). + - intros [|(?&?&Hlk&?)];first hauto lq:on; + rewrite lookup_insert_Some in Hlk; hauto lq:on. + Qed. + + Global Instance set_elem_of_loc eid1 eid2 cd : + SetUnfoldElemOf (eid1, eid2) (loc cd) + (∃ E1 E2 l, cd !! eid1 = Some E1 ∧ get_pa E1 = Some l ∧ + cd !! eid2 = Some E2 ∧ get_pa E2 = Some l). + Proof. + tcclean. unfold loc. set_unfold. + split. + - intros [|(?&?&Hfold&?)];first done. + pose proof (lookup_total_unfold_event_list_fold cd (λ _ event, get_pa event) ∅ x). + feed specialize H0. + intros. rewrite lookup_total_empty. + set_solver +. + rewrite lookup_total_empty, union_empty_l_L in H0. + tcclean_hyp H0. + rewrite lookup_total_alt in H0. + rewrite Hfold in H0. simpl in H0. + set_unfold. + pose proof (H0 eid1) as [(E1 & Hlk1 & Heq1) _];first set_solver. + pose proof (H0 eid2) as [(E2 & Hlk2 & Heq2) _];first set_solver. + case_match;last done. case_match;last done;simplify_map_eq /=. + repeat rewrite bool_unfold in *. + hauto lq:on. + - intros (?&?&?&?&Hloc1&?&Hloc2);right. + exists x1. eexists. + split. + + pose proof (lookup_total_unfold_event_list_fold cd (λ _ event, get_pa event) ∅ x1). + feed specialize H1. + intros. rewrite lookup_total_empty. + set_solver +. + rewrite lookup_total_empty, union_empty_l_L in H1. + tcclean_hyp H1. + rewrite lookup_total_alt in H1. + pose proof (event_list_fold_is_Some cd (λ _ event, get_pa event) x1 ∅) as [? HSome]. + right. do 2 eexists. rewrite event_list_match in H. hauto. + hauto. + + set_unfold. + split;eexists;(split;first eassumption;hauto). + Qed. + Global Typeclasses Opaque loc. + + (* same thread, excluding thread 0 (initial writes) *) + Definition sthd (cd : t) : grel EID.t := + let tid_map : gmap nat (gset EID.t) := + event_list_fold cd ∅ (λ eid _, Some (eid.(EID.tid))) in + map_fold (fun _ (s : gset EID.t) (r : grel EID.t) => r ∪ (s × s)) + ∅ tid_map. + + Global Instance set_elem_of_sthd eid1 eid2 cd : + SetUnfoldElemOf (eid1, eid2) (sthd cd) + (∃ E1 E2 tid, cd !! eid1 = Some E1 ∧ eid1.(EID.tid) = tid ∧ + cd !! eid2 = Some E2 ∧ eid2.(EID.tid) = tid). + Proof. + tcclean. unfold sthd. set_unfold. + split. + - intros [|(?&?&Hfold&?)];first done. + pose proof (lookup_total_unfold_event_list_fold cd (λ eid _, Some (eid.(EID.tid))) ∅ x). + feed specialize H0. + intros. rewrite lookup_total_empty. + set_solver +. + rewrite lookup_total_empty, union_empty_l_L in H0. + tcclean_hyp H0. + rewrite lookup_total_alt in H0. + rewrite Hfold in H0. simpl in H0. + set_unfold. + pose proof (H0 eid1) as [(E1 & Hlk1 & Heq1) _];first set_solver. + pose proof (H0 eid2) as [(E2 & Hlk2 & Heq2) _];first set_solver. + repeat rewrite bool_unfold in *. + hauto lq:on. + - intros (?&?&?&Hlk1&?&Hlk2&?);right. + exists x1. eexists. + split. + + pose proof (lookup_total_unfold_event_list_fold cd (λ eid _, Some (eid.(EID.tid))) ∅ x1). + feed specialize H1. + intros. rewrite lookup_total_empty. + set_solver +. + rewrite lookup_total_empty, union_empty_l_L in H1. + tcclean_hyp H1. + rewrite lookup_total_alt in H1. + pose proof (event_list_fold_is_Some cd (λ eid _, Some (eid.(EID.tid))) x1 ∅) as [? HSome]. + right. do 2 eexists. rewrite event_list_match in Hlk1. hauto. + hauto. + + set_unfold. + split;eexists;(split;first eassumption;hauto). + Qed. + Global Typeclasses Opaque sthd. + + Definition fr (cd : t) : grel EID.t := + (rf cd)⁻¹⨾ (co cd). + + (* including initials *) + Definition num_of_thd (cd : t) := + length (events cd). + + Lemma num_of_thd_spec gr eid: + eid ∈ valid_eid gr -> + ((EID.tid eid) < num_of_thd gr)%nat. + Proof. + intros. + set_unfold. + destruct H as [? [? _]]. + rewrite event_list_match in H. + unfold event_list in H. + destruct eid. + set_unfold. + repeat setoid_rewrite exists_pair in H. + destruct H as (?&?&(?&?&?&((?&?&?&?)&?))&?). + destruct H;last contradiction. + simpl in H. inversion H. subst. + simpl in H2. + apply list_lookup_alt in H2. + destruct H2;done. + Qed. + + Definition non_initial_eids (gr : Candidate.t) := + Candidate.collect_all' (λ eid _, bool_decide (eid.(EID.tid) ≠ 0))%nat gr. + + (* the union of events in non-zero threads is equal to the set all of non-initial events, + given the well-formedness which assumes thread 0 contains and only contains initial writes of all locations *) + Lemma non_initial_eids_fold' {gr : Candidate.t} (k b n : nat) x: + (b <= n)%nat -> + x = Candidate.collect_all' (λ eid _, bool_decide (eid.(EID.tid) ∈ (seq k b)))%nat gr -> + foldl (λ (s : gset _) (idx : nat), + filter (λ eid, eid.(EID.tid) = idx) (Candidate.valid_eid gr) ∪ s) x (seq (b+k) (n-b)) + = Candidate.collect_all' (λ eid _, bool_decide (eid.(EID.tid) ∈ (seq k n)))%nat gr. + Proof. + unfold collect_all'. + revert b x. + induction n. + - simpl. + intros. + destruct b. + simpl in H0. done. + lia. + - intros. + simpl. + rewrite Nat.le_lteq in H. + destruct H. + + assert (S n - b = S (n - b))%nat as ->. lia. + rewrite seq_end. rewrite foldl_snoc. + rewrite IHn. + 2:lia. 2: done. + set_unfold. + intros. + assert (b + k + (n - b)= k + n)%nat as ->. lia. + clear IHn H0. + assert (k%nat :: seq (S k) n = seq k n ++ [(k+n)%nat])%list as ->. + rewrite <-seq_end. simpl. done. + split. + intros [[? [? ?]]| (?&?&?&?)]. + exists (x0,x1). rewrite bool_unfold. sauto use:elem_of_app. + exists x1. destruct x1. rewrite bool_unfold in H1. rewrite bool_unfold. sauto use:elem_of_app. + intros (?&?&?&?). destruct x1. + rewrite bool_unfold in H1. apply elem_of_app in H1. + destruct H1. + right. exists (t0,i). rewrite bool_unfold. sauto. + left. sauto. + + subst b. + assert (S n - S n = 0)%nat as ->. lia. + simpl. + rewrite H0. + done. + Qed. + + Lemma non_initial_eids_fold_aux (gr : Candidate.t) (n : nat): + foldl (λ (s : gset _) (idx : nat), + filter (λ eid, eid.(EID.tid) = idx) (Candidate.valid_eid gr) ∪ s) ∅ (seq (0+1) (n-0)) + = Candidate.collect_all' (λ eid _, bool_decide (eid.(EID.tid) ∈ (seq 1 n)))%nat gr. + Proof. + eapply non_initial_eids_fold'. + lia. + simpl. unfold collect_all'. set_unfold. sauto. + Qed. + + Lemma non_initial_eids_fold {gr : Candidate.t} (n : nat): + S n = num_of_thd gr -> + foldl (λ (s : gset _) (idx : nat), + filter (λ eid, eid.(EID.tid) = S idx) (Candidate.valid_eid gr) ∪ s) ∅ (seq 0 n) + = non_initial_eids gr. + Proof. + pose proof (non_initial_eids_fold_aux gr n). + assert (S <$> (seq 0 n) = seq (0+1) (n-0)) as Heq. + { + rewrite fmap_S_seq. assert (0 + 1 =1)%nat as -> by lia. + assert (n - 0 = n)%nat as -> by lia. done. + } + rewrite <-Heq in H. + + rewrite foldl_fmap in H. + rewrite H. + unfold non_initial_eids. + unfold collect_all'. + set_unfold. + intros Hsz. + intros. + split. + intros (?&?&?&?). + eexists x0. + destruct x0. rewrite bool_unfold in H1. + rewrite bool_unfold. set_unfold. + rewrite elem_of_seq in H1. + assert (EID.tid t0 ≠ 0%nat) by lia. + sauto. + intros (?&?&?&?). + eexists x0. + destruct x0. rewrite bool_unfold in H1. + rewrite bool_unfold. set_unfold. + split;first done. + split;last done. + rewrite elem_of_seq. + pose proof (num_of_thd_spec gr t0). + feed specialize H3. + set_unfold. hauto. + rewrite <- Hsz in H3. + lia. + Qed. + + Global Instance set_unfold_non_initial_eids e gr: + SetUnfoldElemOf (e) (non_initial_eids gr) (e ∈ valid_eid gr ∧ (EID.tid e) ≠ 0%nat). + Proof. tcclean. unfold non_initial_eids. + set_unfold. hauto. Qed. + + (* tid of any non-initial event is greater than 0, and smaller than the number of normal threads plus thread 0 *) + Lemma non_initial_tid_inv gr e: + e ∈ non_initial_eids gr -> + (0 < e.(EID.tid) ∧ e.(EID.tid) < Candidate.num_of_thd gr)%nat. + Proof. + intros. set_unfold. destruct H. + apply num_of_thd_spec in H. + lia. + Qed. + + (* tid 0 is reserved for initial writes *) + Definition initials (cd : t) : gset EID.t := + collect_all' (fun e _=> e.(EID.tid) =? 0%nat) cd. + + Global Instance set_unfold_initial_eids e gr: + SetUnfoldElemOf (e) (initials gr) (e ∈ valid_eid gr ∧ (EID.tid e) = 0%nat). + Proof. tcclean. unfold initials. + set_unfold. + split;intros [? ?]. + rewrite bool_unfold in H. hauto. + destruct H. eexists. rewrite bool_unfold. hauto. + Qed. + + Lemma valid_eid_disjoint_union gr : + initials gr ∪ non_initial_eids gr = valid_eid gr + ∧ initials gr ## non_initial_eids gr. + Proof. + unfold initials. unfold non_initial_eids. + split. + apply set_eq. intros. repeat rewrite elem_of_filter. + set_unfold. set_unfold. + split. intros [?|?];hauto. + intros. destruct (decide (EID.tid x = 0%nat));hauto. + set_unfold. + intros. hauto. + Qed. + + Global Opaque non_initial_eids. + Global Opaque initials. + + End Candidate. + + (** Non-mixed size well-formedness *) + Module NMSWF. + Import Candidate. + + (** This is only correct for 8 bytes values*) + Definition get_val (event : iEvent) := + match event : iEvent with + | IEvent (MemRead 8 rr) (inl (val, _)) => + Some val + | IEvent (MemWrite 8 rr) _ => + Some (rr.(WriteReq.value)) + | _ => None + end. + + (** This relation only make sense for 8-bytes non-mixed-size models. + It relates events with the same values *) + Definition val (cd : t) : grel EID.t := + let val_map : gmap (bv 64) (gset EID.t) := + event_list_fold cd ∅ (λ _ event, get_val event) in + map_fold + (fun (_ : bv 64) (s : gset EID.t) (r : grel EID.t) => r ∪ (s × s)) + ∅ val_map. + + Global Instance set_elem_of_val eid1 eid2 cd : + SetUnfoldElemOf (eid1, eid2) (val cd) + (∃ E1 E2 val, cd !! eid1 = Some E1 ∧ get_val E1 = Some val ∧ + cd !! eid2 = Some E2 ∧ get_val E2 = Some val). + Proof. + tcclean. unfold val. set_unfold. + split. + - intros [|(?&?&Hfold&?)];first done. + pose proof (lookup_total_unfold_event_list_fold cd (λ _ event, get_val event) ∅ x). + feed specialize H0. + intros. rewrite lookup_total_empty. + set_solver +. + rewrite lookup_total_empty, union_empty_l_L in H0. + tcclean_hyp H0. + rewrite lookup_total_alt in H0. + rewrite Hfold in H0. simpl in H0. + set_unfold. + pose proof (H0 eid1) as [(E1 & Hlk1 & Heq1) _];first set_solver. + pose proof (H0 eid2) as [(E2 & Hlk2 & Heq2) _];first set_solver. + case_match;last done. case_match;last done;simplify_map_eq /=. + repeat rewrite bool_unfold in *. + hauto lq:on. + - intros (?&?&?&Hlk1&?&Hlk2&?);right. + exists x1. eexists. + split. + + pose proof (lookup_total_unfold_event_list_fold cd (λ _ event, get_val event) ∅ x1). + feed specialize H1. + intros. rewrite lookup_total_empty. + set_solver +. + rewrite lookup_total_empty, union_empty_l_L in H1. + tcclean_hyp H1. + rewrite lookup_total_alt in H1. + pose proof (event_list_fold_is_Some cd (λ _ event, get_val event) x1 ∅) as [? HSome]. + right. do 2 eexists. rewrite event_list_match in Hlk1. hauto. + hauto. + + set_unfold. + split;eexists;(split;first eassumption;hauto). + Qed. + Global Typeclasses Opaque val. + + (** Check that all memory accesses have size 8. Alignment checking need to + know how pa work and thus need to be architecture specific*) + Definition size8_wf (cd : t) : bool := + collect_all + (fun event => + match event with + | IEvent (MemRead 8 _) _ => false + | IEvent (MemRead _ _) _ => true + | IEvent (MemWrite 8 _) _ => false + | IEvent (MemWrite _ _) _ => true + | _ => false + end) cd =? ∅. + + Definition co_wf (cd : t) : bool := + let co := co cd in + let loc := loc cd in + let writes := mem_writes cd in + grel_irreflexive co && + grel_transitive co && + bool_decide (co ⊆ loc) && + bool_decide (grel_dom co ⊆ writes) && + bool_decide (grel_rng co ⊆ writes) && + (loc ∩ (writes × writes) =? co ∪ co⁻¹ ∪ ⦗writes⦘) + (* initials are the minimum elements *) + && bool_decide(co⨾⦗initials cd⦘= ∅). + + Definition rf_wf (cd : t) : bool := + let rf := rf cd in + let loc := loc cd in + let val := val cd in + let reads := mem_reads cd in + let writes := mem_writes cd in + bool_decide (grel_dom rf ⊆ writes) && + bool_decide (grel_rng rf = reads) && + grel_functional (rf⁻¹) && + bool_decide (rf ⊆ loc ∩ val). + (* NOTE: It is only complete for user Arm *) + + Definition po_wf (cd : t) : bool := + let po := po cd in + let init := initials cd in + let lt := (λ '(e, e'), ((EID.iid e)= (EID.iid e') ∧ (EID.num e) < (EID.num e')) + ∨ ((EID.iid e)< (EID.iid e')))%nat in + grel_irreflexive po && + grel_transitive po && + (* only between nodes of same threads, but not between initial writes even if they reside in thread 0 *) + bool_decide (po ∪ po⁻¹ ∪ (init × init) = (sthd cd)) && + bool_decide (po ∩ (init × init) = ∅) && + bool_decide (set_Forall lt po) && + bool_decide (set_Forall (λ (r : EID.t * EID.t), ((lt r) ∧ r ∉ (init × init)) -> r ∈ po) (sthd cd)) + . + + Definition addr_wf (cd : t) : bool := + let addr := addr cd in + let po := po cd in + let reads := mem_reads cd in + let mem := mem_events cd in + bool_decide (grel_dom addr ⊆ reads) && + bool_decide (grel_rng addr ⊆ mem) && + bool_decide (addr ⊆ po). + + Definition data_wf (cd : t) : bool := + let data := data cd in + let po := po cd in + let reads := mem_reads cd in + let writes := mem_writes cd in + bool_decide (grel_dom data ⊆ reads) && + bool_decide (grel_rng data ⊆ writes) && + bool_decide (data ⊆ po). + + Definition ctrl_wf (cd : t) : bool := + let ctrl := ctrl cd in + let po := po cd in + let reads := mem_reads cd in + bool_decide (grel_dom ctrl ⊆ reads) && + bool_decide (ctrl ⊆ po) && + bool_decide (ctrl⨾po ⊆ ctrl). + + Definition rmw_wf (cd : t) : bool := + let rmw := rmw cd in + let loc := loc cd in + let po := po cd in + let writes := mem_writes_atomic cd in + let reads := mem_reads_atomic cd in + grel_functional rmw && + grel_functional (rmw⁻¹) && + bool_decide (rmw ⊆ loc) && + bool_decide (rmw ⊆ po) && + bool_decide (grel_dom rmw ⊆ reads) && + bool_decide (grel_rng rmw ⊆ writes) && + bool_decide (rmw ∩ (⦗reads⦘⨾po ⨾⦗writes⦘⨾ po ⨾⦗writes⦘) =? ∅) && + bool_decide (rmw ∩ (⦗reads⦘⨾po ⨾⦗reads⦘⨾ po ⨾⦗writes⦘) =? ∅). + + Definition initial_writes (cd : t) := + filter (λ e, ¬ ∃ e', e' ∈ (mem_writes cd) ∧ (e', e) ∈ (co cd) ) (mem_writes cd). + + Definition initial_wf (cd : t) : bool := + let pa_set := + fold_left + (fun pa_set '(eid, event) => + if (bool_decide (eid.(EID.tid) = 0%nat)) && (bool_decide (eid.(EID.num) = 0%nat)) then + pa_set + else + match event : iEvent with + | IEvent (MemRead _ rr) _ => {[rr.(ReadReq.pa)]} ∪ pa_set + | IEvent (MemWrite n rr) _ => {[rr.(WriteReq.pa)]} ∪ pa_set + | _ => pa_set + end) (event_list cd) (∅:gset pa) in + let pa_init_set := + fold_left + (fun pa_init_set '(eid, event) => + if (bool_decide (eid.(EID.tid) = 0%nat)) && (bool_decide (eid.(EID.num) = 0%nat)) then + match event : iEvent with + | IEvent (MemWrite n rr) _ => {[rr.(WriteReq.pa)]} ∪ pa_init_set + | _ => pa_init_set + end + else pa_init_set) (event_list cd) (∅:gset pa) in + (* number of locations = number of initial nodes, i.e. one node per location *) + (* and they are all the only event in a trace *) + bool_decide ((size pa_init_set) = size (initials cd)) + (* initial nodes are all write 0 *) + && bool_decide ((initials cd) ⊆ (mem_writes_pln_zero cd)) + (* locations appear in the program = locations for with an initial write exists *) + && bool_decide (pa_set = pa_init_set) + && bool_decide ((initials cd) = (initial_writes cd)) + && bool_decide (set_Forall (λ e, e.(EID.num) = 0%nat) (initials cd)) + . + + (* Check if all memory events have explicit access strength, variaty, and their responds are valid *) + Definition mem_wf (cd : t) : bool := + collect_all + (fun event => + match event with + | IEvent (MemRead _ rreq) rresp => negb (rreq_is_valid rreq && rresp_is_valid rresp) + | IEvent (MemWrite _ wreq) wresp => negb (wreq_is_valid wreq && wresp_is_valid wresp) + | _ => false + end) cd =? ∅. + + (* Check that a candidate is self consistent *) + Definition wf (cd : t) : bool := + size8_wf cd && rf_wf cd && co_wf cd && po_wf cd && addr_wf cd && data_wf cd && ctrl_wf cd && rmw_wf cd && initial_wf cd && mem_wf cd. + + End NMSWF. + +End CandidateExecutions. diff --git a/theories/algebra/base.v b/theories/algebra/base.v new file mode 100644 index 0000000..9d5c650 --- /dev/null +++ b/theories/algebra/base.v @@ -0,0 +1,116 @@ +(** This file contains construction of basic RAs *) +(* From stdpp Require Export namespaces. *) + +From iris.algebra Require Export agree gmap gset csum lib.dfrac_agree. +From iris.base_logic.lib Require Export ghost_map saved_prop. +From iris.proofmode Require Export tactics. +From iris_named_props Require Export named_props. + +From self Require Export cmra. +From self.lang Require Export mm instrs. +From self.algebra Require Export ghost_map_ag mono_pg. + +Class AABaseInG `{CMRA Σ} := { + AAInGBaseEdge :> inG Σ (agreeR (leibnizO Graph.t)); + (* node_annotation *) + AAInGNodeAnnot :> ghost_map_agG Σ Eid gname; + AAInGNodeAnnotGnames :> inG Σ (authR (gset_disjUR gname)); + AAInGSavedProp :> savedPropG Σ; + AAInGInstrMem :> inG Σ (agreeR (gmapO Addr (leibnizO Instruction))); + AAInGLocalWriteMap :> ghost_mapG Σ Addr (option Eid); + AAInGPoSrcMono :> inG Σ (mono_pgR); + AAInGPoSrcOneShot :> inG Σ (csumR (dfrac_agreeR unitO) (agreeR (prodO gnameO natO))); + AAInGRmwSrc :> inG Σ (authR (gset_disjUR Eid)); +}. + +Section genAABaseG. + Class AABaseG `{CMRA Σ} := + GenAABaseG{ + AAIn :> AABaseInG; + AAGraphN : gname; + AANodeAnnotN: gname; + AAInstrN : gname; + AARmwTokenN : gname; + }. + + #[global] Arguments AAGraphN {Σ _ _}. + #[global] Arguments AANodeAnnotN {Σ _ _}. + #[global] Arguments AAInstrN {Σ _ _}. + #[global] Arguments AARmwTokenN {Σ _ _}. + + Definition AABaseΣ : gFunctors := + #[ GFunctor (agreeR (leibnizO Graph.t)); + savedPropΣ; + ghost_map_agΣ Eid gname; + GFunctor (authR (gset_disjUR gname)); + GFunctor (agreeR (gmapO Addr (leibnizO Instruction))); + ghost_mapΣ Addr (option Eid); + GFunctor mono_pgR; + GFunctor (csumR (dfrac_agreeR unitO) (agreeR (prodO gnameO natO))); + GFunctor (authR (gset_disjUR Eid)) + ]. + + #[global] Instance subG_AABasepreG `{CMRA Σ}: subG AABaseΣ Σ -> AABaseInG. + Proof. solve_inG. Qed. + +End genAABaseG. + +Section definition. + Context `{CMRA Σ} `{!AABaseG}. + + (** Graph facts, including edges and nodes *) + Definition graph_agree_def (gr : Graph.t) : iProp Σ := + own AAGraphN ((to_agree gr) : (agreeR (leibnizO Graph.t))). + Definition graph_agree_aux : seal (@graph_agree_def). Proof. by eexists. Qed. + Definition graph_agree := graph_agree_aux.(unseal). + Definition graph_agree_eq : @graph_agree = @graph_agree_def := graph_agree_aux.(seal_eq). + + #[global] Instance graph_agree_persist gr: Persistent(graph_agree gr). + Proof. rewrite graph_agree_eq /graph_agree_def. apply _. Qed. + + Lemma graph_agree_agree gr gr': + graph_agree gr -∗ graph_agree gr' -∗ ⌜gr = gr'⌝. + Proof. + iIntros "He Hξ". rewrite graph_agree_eq /graph_agree_def. + iDestruct (own.own_valid_2 with "He Hξ") as "%Hvalid". + rewrite to_agree_op_valid_L in Hvalid. done. + Qed. + + (** node anotation *) + Definition node_annot_agmap_def (eid : Eid) (N : gname) : iProp Σ := + ghost_map_ag_elem AANodeAnnotN eid N. + Definition node_annot_agmap_aux : seal (@node_annot_agmap_def). Proof. by eexists. Qed. + Definition node_annot_agmap := node_annot_agmap_aux.(unseal). + Definition node_annot_agmap_eq : @node_annot_agmap = @node_annot_agmap_def := node_annot_agmap_aux.(seal_eq). + + #[global] Instance node_annot_agmap_persist eid e: Persistent(node_annot_agmap eid e). + Proof. rewrite node_annot_agmap_eq /node_annot_agmap_def. apply _. Qed. + + Lemma node_annot_agmap_both_agree n E m: + node_annot_agmap n E -∗ ghost_map_ag_auth AANodeAnnotN m -∗ ⌜m !! n = Some E⌝. + Proof. + iIntros "He Hauth". rewrite node_annot_agmap_eq /node_annot_agmap_def. + iApply (ghost_map_ag.ghost_map_ag_lookup with "Hauth He"). + Qed. + + (** instructions *) + Definition instr_table_agree_def (gi : gmap Addr Instruction) : iProp Σ := + own AAInstrN (to_agree (gi: gmapO Addr (leibnizO Instruction))). + Definition instr_table_agree_aux : seal (@instr_table_agree_def). Proof. by eexists. Qed. + Definition instr_table_agree := instr_table_agree_aux.(unseal). + Definition instr_table_agree_eq : @instr_table_agree = @instr_table_agree_def := instr_table_agree_aux.(seal_eq). + + #[global] Instance instr_table_persist gi: Persistent (instr_table_agree gi). + Proof. + rewrite instr_table_agree_eq /instr_table_agree_def. apply _. + Qed. + + Lemma instr_table_agree_agree tb tb': + instr_table_agree tb -∗ instr_table_agree tb' -∗ ⌜tb = tb'⌝. + Proof. + iIntros "He Hξ". rewrite instr_table_agree_eq /instr_table_agree_def. + iDestruct (own.own_valid_2 with "He Hξ") as "%Hvalid". + rewrite to_agree_op_valid_L in Hvalid. done. + Qed. + +End definition. diff --git a/theories/algebra/ghost_map_ag.v b/theories/algebra/ghost_map_ag.v new file mode 100644 index 0000000..b090392 --- /dev/null +++ b/theories/algebra/ghost_map_ag.v @@ -0,0 +1,156 @@ +(** This file contains the RA of construction gmap K (agree V)*) +From iris.base_logic.lib Require Export own. +From iris.proofmode Require Import tactics. + +Require Export self.algebra.lib.gmap_view_ag. + +Class ghost_map_agG Σ (K V : Type) `{Countable K} := GhostMapAgG { + ghost_map_ag_inG : inG Σ (gmap_view_agR K (leibnizO V)); +}. + +Local Existing Instance ghost_map_ag_inG. + +Definition ghost_map_agΣ (K V : Type) `{Countable K} : gFunctors := + #[ GFunctor (gmap_view_agR K (leibnizO V)) ]. + +Global Instance subG_ghost_map_agΣ Σ (K V : Type) `{Countable K} : + subG (ghost_map_agΣ K V) Σ → ghost_map_agG Σ K V. +Proof. solve_inG. Qed. + +Section definitions. + Context `{ghost_map_agG Σ K V}. + + Local Definition ghost_map_ag_auth_def + (γ : gname) (m : gmap K V) : iProp Σ := + own γ (gmap_view_ag_auth (V:=leibnizO V) m). + Local Definition ghost_map_ag_auth_aux : seal (@ghost_map_ag_auth_def). + Proof. by eexists. Qed. + Definition ghost_map_ag_auth := ghost_map_ag_auth_aux.(unseal). + Local Definition ghost_map_ag_auth_unseal : + @ghost_map_ag_auth = @ghost_map_ag_auth_def := ghost_map_ag_auth_aux.(seal_eq). + + Local Definition ghost_map_ag_elem_def + (γ : gname) (k : K) (v : V) : iProp Σ := + own γ (gmap_view_ag_frag (V:=leibnizO V) k v). + Local Definition ghost_map_ag_elem_aux : seal (@ghost_map_ag_elem_def). + Proof. by eexists. Qed. + Definition ghost_map_ag_elem := ghost_map_ag_elem_aux.(unseal). + Local Definition ghost_map_ag_elem_unseal : + @ghost_map_ag_elem = @ghost_map_ag_elem_def := ghost_map_ag_elem_aux.(seal_eq). +End definitions. + +Notation "k ↪[ γ ]ag v" := (ghost_map_ag_elem γ k v) + (at level 20, γ at level 50, format "k ↪[ γ ]ag v") : bi_scope. + +Local Ltac unseal := rewrite + ?ghost_map_ag_auth_unseal /ghost_map_ag_auth_def + ?ghost_map_ag_elem_unseal /ghost_map_ag_elem_def. + +Section lemmas. + Context `{ghost_map_agG Σ K V}. + Implicit Types (m : gmap K V) (k : K) (q : Qp) (v : V). + + Global Instance ghost_map_ag_elem_timeless k γ v : Timeless (k ↪[γ]ag v). + Proof. unseal. apply _. Qed. + Global Instance ghost_map_ag_elem_persistent k γ v : Persistent (k ↪[γ]ag v). + Proof. unseal. apply _. Qed. + + Lemma ghost_map_ag_elem_agree k γ v1 v2 : + k ↪[γ]ag v1 -∗ k ↪[γ]ag v2 -∗ ⌜v1 = v2⌝. + Proof. + unseal. iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as %?%gmap_view_ag_frag_op_valid_L. + done. + Qed. + + Lemma ghost_map_ag_alloc_strong P m : + pred_infinite P → + ⊢ |==> ∃ γ, ⌜P γ⌝ ∗ ghost_map_ag_auth γ m ∗ [∗ map] k ↦ v ∈ m, k ↪[γ]ag v. + Proof. + unseal. intros. + iMod (own_alloc_strong (gmap_view_ag_auth (V:=leibnizO V) m) P) + as (γ) "[% Hauth]"; first done. + { apply gmap_view_ag_auth_valid. } + iExists γ. iSplitR; first done. + iDestruct (own_update with "Hauth") as ">Hauth". + apply gmap_view_ag_alloc_lookup_big. + reflexivity. + rewrite -big_opM_own_1 -own_op //. + Qed. + Lemma ghost_map_ag_alloc_strong_empty P : + pred_infinite P → + ⊢ |==> ∃ γ, ⌜P γ⌝ ∗ ghost_map_ag_auth γ (∅ : gmap K V). + Proof. + intros. iMod (ghost_map_ag_alloc_strong P ∅) as (γ) "(% & Hauth & _)"; eauto. + Qed. + Lemma ghost_map_ag_alloc m : + ⊢ |==> ∃ γ, ghost_map_ag_auth γ m ∗ [∗ map] k ↦ v ∈ m, k ↪[γ]ag v. + Proof. + iMod (ghost_map_ag_alloc_strong (λ _, True) m) as (γ) "[_ Hmap]". + - by apply pred_infinite_True. + - eauto. + Qed. + Lemma ghost_map_ag_alloc_empty : + ⊢ |==> ∃ γ, ghost_map_ag_auth γ (∅ : gmap K V). + Proof. + intros. iMod (ghost_map_ag_alloc ∅) as (γ) "(Hauth & _)"; eauto. + Qed. + + Global Instance ghost_map_ag_auth_timeless γ m : Timeless (ghost_map_ag_auth γ m). + Proof. unseal. apply _. Qed. + + (* Lemmas about the interaction of [ghost_map_auth] with the elements *) + Lemma ghost_map_ag_lookup {γ m k v} : + ghost_map_ag_auth γ m -∗ k ↪[γ]ag v -∗ ⌜m !! k = Some v⌝. + Proof. + unseal. iIntros "Hauth Hel". + iDestruct (own_valid_2 with "Hauth Hel") as %?%gmap_view_ag_both_valid_L. + eauto. + Qed. + + Lemma ghost_map_ag_insert {γ m} k v : + m !! k = None → + ghost_map_ag_auth γ m ==∗ ghost_map_ag_auth γ (<[k := v]> m) ∗ k ↪[γ]ag v. + Proof. unseal. intros ?. rewrite -own_op. + iApply own_update. apply: gmap_view_ag_alloc; done. + Qed. + + Lemma ghost_map_extract {γ m} k v : + m !! k = Some v → + ghost_map_ag_auth γ m ==∗ ghost_map_ag_auth γ m ∗ k ↪[γ]ag v. + Proof. + unseal. intros ?. rewrite -own_op. + iApply own_update. apply: gmap_view_ag_alloc_lookup; done. + Qed. + + (* Big-op versions of above lemmas *) + Lemma ghost_map_ag_lookup_big {γ m} m0 : + ghost_map_ag_auth γ m -∗ + ([∗ map] k↦v ∈ m0, k ↪[γ]ag v) -∗ + ⌜m0 ⊆ m⌝. + Proof. + iIntros "Hauth Hfrag". rewrite map_subseteq_spec. iIntros (k v Hm0). + iDestruct (ghost_map_ag_lookup with "Hauth [Hfrag]") as %->. + { rewrite big_sepM_lookup; done. } + done. + Qed. + + Lemma ghost_map_ag_insert_big {γ m} m' : + m' ##ₘ m → + ghost_map_ag_auth γ m ==∗ + ghost_map_ag_auth γ (m' ∪ m) ∗ ([∗ map] k ↦ v ∈ m', k ↪[γ]ag v). + Proof. + unseal. intros ?. rewrite -big_opM_own_1 -own_op. + iApply own_update. apply: gmap_view_ag_alloc_big; done. + Qed. + + Lemma ghost_map_ag_extract_big {γ m} m' : + m' ⊆ m → + ghost_map_ag_auth γ m ==∗ + ghost_map_ag_auth γ m ∗ ([∗ map] k ↦ v ∈ m', k ↪[γ]ag v). + Proof. + unseal. intros ?. rewrite -big_opM_own_1 -own_op. + iApply own_update. apply: gmap_view_ag_alloc_lookup_big; done. + Qed. + +End lemmas. diff --git a/theories/algebra/lib/gmap_view_ag.v b/theories/algebra/lib/gmap_view_ag.v new file mode 100644 index 0000000..d0dff64 --- /dev/null +++ b/theories/algebra/lib/gmap_view_ag.v @@ -0,0 +1,391 @@ +(** This file contains a variant of [gmap_view]: gmap K (agree V) *) +(** Most of lemmas are their proofs are copied from [iris.algebra/lib/gmap_view] and tweaked *) +From iris.algebra Require Export view gmap. +From iris.algebra Require Import proofmode_classes. + +From iris.proofmode Require Import tactics. + +Local Definition gmap_view_ag_fragUR (K : Type) `{Countable K} (V : ofe) : ucmra := + gmapUR K (agreeR V). + +Section rel. + Context (K : Type) `{Countable K} (V : ofe). + Implicit Types (m : gmap K V) (k : K) (v : V) (n : nat). + Implicit Types (f : gmap K (agree V)). + + Local Definition gmap_view_ag_rel_raw n m f : Prop := + map_Forall (λ k (v: agree V), ∃ v', v ≡{n}≡ to_agree v' ∧ m !! k = Some v') f. + + Local Lemma gmap_view_ag_rel_raw_mono n1 n2 m1 m2 f1 f2 : + gmap_view_ag_rel_raw n1 m1 f1 → + m1 ≡{n2}≡ m2 → + f2 ≼{n2} f1 → + n2 ≤ n1 → + gmap_view_ag_rel_raw n2 m2 f2. + Proof. + intros Hrel Hm Hf Hn k va Hk. + (* For some reason applying the lemma in [Hf] does not work... *) + destruct (lookup_includedN n2 f2 f1) as [Hf' _]. specialize (Hf' Hf). clear Hf. + specialize (Hf' k). rewrite Hk in Hf'. + apply option_includedN in Hf'. + destruct Hf' as [[=]|(? & va' & [= <-] & Hf1 & Hincl)]. + specialize (Hrel _ _ Hf1) as (v & Hagree & Hm1). simpl in *. + specialize (Hm k). + edestruct (dist_Some_inv_l _ _ _ _ Hm Hm1) as (v' & Hm2 & Hv). + exists v'. split; last done. + rewrite -Hv. + destruct Hincl as [Heqva|Hinclva]. + - simpl in *. rewrite Heqva. eapply dist_le; last eassumption. done. + - etrans; last first. + { eapply dist_le; last eassumption. done. } + eapply agree_valid_includedN; last done. + eapply cmra_validN_le; last eassumption. + rewrite Hagree. done. + Qed. + + Local Lemma gmap_view_ag_rel_raw_valid n m f : + gmap_view_ag_rel_raw n m f → ✓{n} f. + Proof. + intros Hrel k. destruct (f !! k) as [va|] eqn:Hf; rewrite Hf; last done. + specialize (Hrel _ _ Hf) as (v & Hagree & Hm1). simpl in *. + rewrite Hagree. done. + Qed. + + Local Lemma gmap_view_ag_rel_raw_unit n : + ∃ m, gmap_view_ag_rel_raw n m ε. + Proof. exists ∅. apply: map_Forall_empty. Qed. + + Local Canonical Structure gmap_view_ag_rel : view_rel (gmapO K V) (gmap_view_ag_fragUR K V) := + ViewRel gmap_view_ag_rel_raw gmap_view_ag_rel_raw_mono + gmap_view_ag_rel_raw_valid gmap_view_ag_rel_raw_unit. + + Local Lemma gmap_view_ag_rel_exists n (f : gmap K (agreeR V)) : + (∃ m, gmap_view_ag_rel n m f) ↔ ✓{n} f. + Proof. + split. + { intros [m Hrel]. eapply gmap_view_ag_rel_raw_valid, Hrel. } + intros Hf. + cut (∃ m, gmap_view_ag_rel n m f ∧ ∀ k, f !! k = None → m !! k = None). + { naive_solver. } + induction f as [|k ag f Hk' IH] using map_ind. + { exists ∅. split; [|done]. apply: map_Forall_empty. } + move: (Hf k). rewrite lookup_insert=> [/= ?]. + destruct (to_agree_uninjN n ag) as [v ?]; [done|]. + destruct IH as (m & Hm & Hdom). + { intros k'. destruct (decide (k = k')) as [->|?]; [by rewrite Hk'|]. + move: (Hf k'). by rewrite lookup_insert_ne. } + exists (<[k:=v]> m). + rewrite /gmap_view_ag_rel /= /gmap_view_ag_rel_raw map_Forall_insert //=. split_and!. + - exists v. by rewrite lookup_insert. + - eapply map_Forall_impl; [apply Hm|]; simpl. + intros k' ag' (v'&?&?). exists v'. + rewrite lookup_insert_ne; naive_solver. + - intros k'. rewrite !lookup_insert_None. naive_solver. + Qed. + + Local Lemma gmap_view_ag_rel_unit n m : gmap_view_ag_rel n m ε. + Proof. apply: map_Forall_empty. Qed. + + Local Lemma gmap_view_ag_rel_discrete : + OfeDiscrete V → ViewRelDiscrete gmap_view_ag_rel. + Proof. + intros ? n m f Hrel k va Hk. + destruct (Hrel _ _ Hk) as (v & Hagree & Hm). + exists v. split; last by auto. + eapply discrete_iff; first by apply _. + eapply discrete_iff; first by apply _. + done. + Qed. +End rel. + +Local Existing Instance gmap_view_ag_rel_discrete. +Notation gmap_view_ag K V := (view (@gmap_view_ag_rel_raw K _ _ V)). +Definition gmap_view_agO (K : Type) `{Countable K} (V : ofe) : ofe := + viewO (gmap_view_ag_rel K V). +Definition gmap_view_agR (K : Type) `{Countable K} (V : ofe) : cmra := + viewR (gmap_view_ag_rel K V). +Definition gmap_view_agUR (K : Type) `{Countable K} (V : ofe) : ucmra := + viewUR (gmap_view_ag_rel K V). + +Section definitions. + Context {K : Type} `{Countable K} {V : ofe}. + + Definition gmap_view_ag_auth (m : gmap K V) : gmap_view_agR K V := + ●V m. + Definition gmap_view_ag_frag (k : K) (v : V) : gmap_view_agR K V := + ◯V {[k := (to_agree v)]}. +End definitions. + +Section lemmas. + Context {K : Type} `{Countable K} {V : ofe}. + Implicit Types (m : gmap K V) (k : K) (v : V). + + Global Instance : Params (@gmap_view_ag_auth) 4 := {}. + Global Instance gmap_view_ag_auth_ne : NonExpansive (gmap_view_ag_auth (K:=K) (V:=V)). + Proof. solve_proper. Qed. + Global Instance gmap_view_ag_auth_proper : Proper ((≡) ==> (≡)) (gmap_view_ag_auth (K:=K) (V:=V)). + Proof. apply ne_proper, _. Qed. + + Global Instance : Params (@gmap_view_ag_frag) 5 := {}. + Global Instance gmap_view_ag_frag_ne k : NonExpansive (gmap_view_ag_frag (V:=V) k). + Proof. solve_proper. Qed. + Global Instance gmap_view_ag_frag_proper k : Proper ((≡) ==> (≡)) (gmap_view_ag_frag (V:=V) k). + Proof. apply ne_proper, _. Qed. + + + (* Helper lemmas *) + Local Lemma gmap_view_ag_rel_lookup n m k v : + gmap_view_ag_rel K V n m {[k := to_agree v]} ↔ m !! k ≡{n}≡ Some v. + Proof. + split. + - intros Hrel. + edestruct (Hrel k) as (v' & Hagree & ->). + { rewrite lookup_singleton. done. } + simpl in *. apply (inj _) in Hagree. rewrite Hagree. + done. + - intros (v' & Hm & Hv')%dist_Some_inv_r' j va. + destruct (decide (k = j)) as [<-|Hne]; last by rewrite lookup_singleton_ne. + rewrite lookup_singleton. intros [= <-]. simpl. + exists v'. split_and!; by rewrite ?Hv'. + Qed. + + (** Composition and validity *) + Lemma gmap_view_ag_auth_valid m : ✓ gmap_view_ag_auth m. + Proof. + rewrite view_auth_dfrac_valid. by intuition eauto using gmap_view_ag_rel_unit. + Qed. + + Lemma gmap_view_ag_frag_validN n k v : ✓{n} gmap_view_ag_frag k v. + Proof. + rewrite view_frag_validN gmap_view_ag_rel_exists singleton_validN. + naive_solver. + Qed. + Lemma gmap_view_ag_frag_valid k v : ✓ gmap_view_ag_frag k v. + Proof. + rewrite cmra_valid_validN. + intros. apply gmap_view_ag_frag_validN. + Qed. + + Lemma gmap_view_ag_frag_op k v : + gmap_view_ag_frag k v ≡ gmap_view_ag_frag k v ⋅ gmap_view_ag_frag k v. + Proof. rewrite -view_frag_op singleton_op agree_idemp //. Qed. + + Lemma gmap_view_ag_frag_op_validN n k v1 v2 : + ✓{n} (gmap_view_ag_frag k v1 ⋅ gmap_view_ag_frag k v2) ↔ + v1 ≡{n}≡ v2. + Proof. + rewrite view_frag_validN gmap_view_ag_rel_exists singleton_op singleton_validN. + by rewrite to_agree_op_validN. + Qed. + + Lemma gmap_view_ag_frag_op_valid k v1 v2 : + ✓ (gmap_view_ag_frag k v1 ⋅ gmap_view_ag_frag k v2) ↔ v1 ≡ v2. + Proof. + rewrite view_frag_valid. setoid_rewrite gmap_view_ag_rel_exists. + rewrite -cmra_valid_validN singleton_op singleton_valid. + by rewrite to_agree_op_valid. + Qed. + + Lemma gmap_view_ag_frag_op_valid_L `{!LeibnizEquiv V} k v1 v2 : + ✓ (gmap_view_ag_frag k v1 ⋅ gmap_view_ag_frag k v2) ↔ v1 = v2. + Proof. unfold_leibniz. apply gmap_view_ag_frag_op_valid. Qed. + + Lemma gmap_view_ag_both_validN n m k v : + ✓{n} (gmap_view_ag_auth m ⋅ gmap_view_ag_frag k v) ↔ + m !! k ≡{n}≡ Some v. + Proof. + rewrite /gmap_view_ag_auth /gmap_view_ag_frag. + rewrite view_both_dfrac_validN gmap_view_ag_rel_lookup. + split; first naive_solver. + intro; split;done. + Qed. + Lemma gmap_view_ag_both_valid m k v : + ✓ (gmap_view_ag_auth m ⋅ gmap_view_ag_frag k v) ↔ + m !! k ≡ Some v. + Proof. + rewrite /gmap_view_ag_auth /gmap_view_ag_frag. + rewrite view_both_dfrac_valid. setoid_rewrite gmap_view_ag_rel_lookup. + split=>[[_ Hm]|Hm]. + - apply equiv_dist=>n. apply Hm. + - split; first done. intros n. + revert n. apply equiv_dist. apply Hm. + Qed. + Lemma gmap_view_ag_both_valid_L `{!LeibnizEquiv V} m k v : + ✓ (gmap_view_ag_auth m ⋅ gmap_view_ag_frag k v) ↔ + m !! k = Some v. + Proof. unfold_leibniz. apply gmap_view_ag_both_valid. Qed. + +(** Frame-preserving updates *) + Lemma gmap_view_ag_alloc m k v : + m !! k = None → + gmap_view_ag_auth m ~~> gmap_view_ag_auth (<[k := v]> m) ⋅ gmap_view_ag_frag k v. + Proof. + intros Hfresh Hdq. apply view_update_alloc=>n bf Hrel j ag /=. + rewrite lookup_op. destruct (decide (j = k)) as [->|Hne]. + - assert (bf !! k = None) as Hbf. + { destruct (bf !! k) as [ag'|] eqn:Hbf; last done. + specialize (Hrel _ _ Hbf). destruct Hrel as (v' & _ & Hm). + exfalso. rewrite Hm in Hfresh. done. } + rewrite lookup_singleton Hbf right_id. + intros [= <-]. eexists. split; first done. + rewrite lookup_insert. done. + - rewrite lookup_singleton_ne; last done. + rewrite left_id=>Hbf. + specialize (Hrel _ _ Hbf). destruct Hrel as (v' & ? & Hm). + eexists. split; first done. + rewrite lookup_insert_ne //. + Qed. + + Lemma gmap_view_ag_alloc_big m m' : + m' ##ₘ m → + gmap_view_ag_auth m ~~> + gmap_view_ag_auth (m' ∪ m) ⋅ ([^op map] k↦v ∈ m', gmap_view_ag_frag k v). + Proof. + intros. induction m' as [|k v m' ? IH] using map_ind; decompose_map_disjoint. + { rewrite big_opM_empty left_id_L right_id. done. } + rewrite IH //. + rewrite big_opM_insert // assoc. + apply cmra_update_op; last done. + rewrite -insert_union_l. apply (gmap_view_ag_alloc _ k). + by apply lookup_union_None. + Qed. + + Lemma gmap_view_ag_alloc_lookup m k v : + m !! k = Some v → + gmap_view_ag_auth m ~~> gmap_view_ag_auth m ⋅ gmap_view_ag_frag k v. + Proof. + intros Hfresh Hdq. apply view_update_alloc=>n bf Hrel j ag /=. + rewrite lookup_op. destruct (decide (j = k)) as [->|Hne]. + - destruct (bf !! k) as [ag'|] eqn:Hbf. + + specialize (Hrel _ _ Hbf). destruct Hrel as (v' & Hag' & Hm). + rewrite Hm in Hfresh. inversion Hfresh;subst v';clear Hfresh. + rewrite Hbf. + rewrite lookup_singleton. + rewrite -Some_op. + intro Hsome. inversion Hsome;subst ag;clear Hsome. + exists v. + rewrite Hag'. split;last done. + symmetry. + apply agree_valid_includedN. + by rewrite agree_idemp. + eexists _. reflexivity. + + rewrite lookup_singleton Hbf right_id. + intros [= <-]. eexists. split; done. + - rewrite lookup_singleton_ne; last done. + rewrite left_id=>Hbf. + specialize (Hrel _ _ Hbf). destruct Hrel as (v' & ? & Hm). + eexists. split; done. + Qed. + + Lemma gmap_view_ag_alloc_lookup_big m m0 : + m0 ⊆ m → + gmap_view_ag_auth m ~~> + gmap_view_ag_auth m ⋅ ([^op map] k↦v ∈ m0, gmap_view_ag_frag k v). + Proof. + intros Hsub. revert Hsub. + induction m0 as [|k v m0 Hnotdom IH] using map_ind; intros Hsub. + { rewrite big_opM_empty /=. + rewrite ucmra_unit_right_id //. } + assert (m !! k = Some v) as Hlk. + rewrite map_subseteq_spec in Hsub. + apply Hsub. apply lookup_insert_Some; left; done. + rewrite big_opM_insert //. + rewrite [gmap_view_ag_frag _ _ ⋅ _]comm assoc. + etrans. + apply IH. etrans; last exact Hsub. by apply insert_subseteq. + rewrite -assoc [ _ ⋅ gmap_view_ag_frag _ _]comm assoc . + apply cmra_update_op;last done. + by apply gmap_view_ag_alloc_lookup. + Qed. + + (* Typeclass instances *) + Global Instance gmap_view_ag_frag_core_id k v :CoreId (gmap_view_ag_frag k v). + Proof. apply _. Qed. + + Global Instance gmap_view_ag_cmra_discrete : OfeDiscrete V → CmraDiscrete (gmap_view_agR K V). + Proof. apply _. Qed. + + Global Instance gmap_view_ag_frag_mut_is_op k v : + IsOp' (gmap_view_ag_frag k v) (gmap_view_ag_frag k v) (gmap_view_ag_frag k v). + Proof. rewrite /IsOp'. apply gmap_view_ag_frag_op. Qed. + +End lemmas. + +Program Definition gmap_view_agURF (K : Type) `{Countable K} (F : oFunctor) : urFunctor := {| + urFunctor_car A _ B _ := gmap_view_agUR K (oFunctor_car F A B); + urFunctor_map A1 _ A2 _ B1 _ B2 _ fg := + viewO_map (rel:=gmap_view_ag_rel K (oFunctor_car F A1 B1)) + (rel':=gmap_view_ag_rel K (oFunctor_car F A2 B2)) + (gmapO_map (K:=K) (oFunctor_map F fg)) + (gmapO_map (K:=K) (agreeO_map (oFunctor_map F fg))) +|}. +Next Obligation. + intros K ?? F A1 ? A2 ? B1 ? B2 ? n f g Hfg. + apply viewO_map_ne. + - apply gmapO_map_ne, oFunctor_map_ne. done. + - apply gmapO_map_ne. apply agreeO_map_ne, oFunctor_map_ne. done. +Qed. +Next Obligation. + intros K ?? F A ? B ? x;simpl in *. rewrite -{2}(view_map_id x). + apply (view_map_ext _ _ _ _)=> y. + - rewrite /= -{2}(map_fmap_id y). + apply map_fmap_equiv_ext=>k ??. + apply oFunctor_map_id. + - rewrite /= -{2}(map_fmap_id y). + apply map_fmap_equiv_ext=>k ag ?. + simpl. rewrite -{2}(agree_map_id ag). + eapply agree_map_ext; first by apply _. + apply oFunctor_map_id. +Qed. +Next Obligation. + intros K ?? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl in *. + rewrite -view_map_compose. + apply (view_map_ext _ _ _ _)=> y. + - rewrite /= -map_fmap_compose. + apply map_fmap_equiv_ext=>k ??. + apply oFunctor_map_compose. + - rewrite /= -map_fmap_compose. + apply map_fmap_equiv_ext=>k [df va] ?. + simpl. rewrite -agree_map_compose. + eapply agree_map_ext; first by apply _. + apply oFunctor_map_compose. +Qed. +Next Obligation. + intros K ?? F A1 ? A2 ? B1 ? B2 ? fg; simpl. + (* [apply] does not work, probably the usual unification probem (Coq #6294) *) + apply: view_map_cmra_morphism; [apply _..|]=> n m f. + intros Hrel k ag Hf. move: Hf. + rewrite !lookup_fmap. + destruct (f !! k) as [ag'|] eqn:Hfk; rewrite Hfk; last done. + simpl=> [= <-]. + specialize (Hrel _ _ Hfk). simpl in Hrel. destruct Hrel as (v & Hagree & Hm). + exists (oFunctor_map F fg v). + rewrite Hm. split; last by auto. + rewrite Hagree. rewrite agree_map_to_agree. done. +Qed. + +Global Instance gmap_view_agURF_contractive (K : Type) `{Countable K} F : + oFunctorContractive F → urFunctorContractive (gmap_view_agURF K F). +Proof. + intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg. + apply viewO_map_ne. + - apply gmapO_map_ne. apply oFunctor_map_contractive. done. + - apply gmapO_map_ne. + apply agreeO_map_ne, oFunctor_map_contractive. done. +Qed. + +Program Definition gmap_view_agRF (K : Type) `{Countable K} (F : oFunctor) : rFunctor := {| + rFunctor_car A _ B _ := gmap_view_agR K (oFunctor_car F A B); + rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := + viewO_map (rel:=gmap_view_ag_rel K (oFunctor_car F A1 B1)) + (rel':=gmap_view_ag_rel K (oFunctor_car F A2 B2)) + (gmapO_map (K:=K) (oFunctor_map F fg)) + (gmapO_map (K:=K) (agreeO_map (oFunctor_map F fg))) +|}. +Solve Obligations with apply gmap_view_agURF. + +Global Instance gmap_view_agRF_contractive (K : Type) `{Countable K} F : + oFunctorContractive F → rFunctorContractive (gmap_view_agRF K F). +Proof. apply gmap_view_agURF_contractive. Qed. + +#[export] Typeclasses Opaque gmap_view_ag_auth gmap_view_ag_frag. diff --git a/theories/algebra/mono_pg.v b/theories/algebra/mono_pg.v new file mode 100644 index 0000000..a7eba2b --- /dev/null +++ b/theories/algebra/mono_pg.v @@ -0,0 +1,233 @@ +From iris.algebra Require Export auth. +From iris.algebra Require Import numbers updates. +From iris.prelude Require Import options. + +(** ** Progresses with [max] as the operation. *) +Record max_pg := MaxPg { max_pg_car : nat * nat}. +Add Printing Constructor max_pg. + +Definition pg_max := λ (n m : nat * nat), + (if bool_decide (n.1 < m.1) then m + else if bool_decide (n.1 = m.1) + then (n.1, (n.2 `max` m.2)) + else n). + +Definition pg_le := λ (n m : nat * nat), n.1 < m.1 ∨ n.1 = m.1 ∧ n.2 <= m.2. +#[global] Hint Unfold pg_le : core. + +Lemma pg_le_max_r x y : pg_le x (pg_max x y). +Proof. + unfold pg_le, pg_max. destruct x,y;simpl. + case_bool_decide. + { left; simpl;lia. } + { case_bool_decide; right;simpl;lia. } +Qed. + +Lemma pg_max_le x y : pg_le x y -> y = pg_max x y. +Proof. + unfold pg_max. intros [| [? ?]];case_bool_decide;try done. + case_bool_decide;try lia. destruct x,y;simpl in *. subst. + rewrite Nat.max_r;auto. +Qed. + +Lemma pg_max_assoc x y z: pg_max x (pg_max y z) = pg_max (pg_max x y) z. +Proof. + unfold pg_max. destruct x,y,z. repeat case_bool_decide;simpl in *; subst;try done;try lia. + rewrite Nat.max_assoc. done. +Qed. + +Lemma pg_max_comm x y : pg_max x y = pg_max y x. +Proof. + unfold pg_max. destruct x,y. repeat case_bool_decide;simpl in *; subst;try done;try lia. + rewrite Nat.max_comm. done. +Qed. + +Lemma pg_max_id x : pg_max x x = x. +Proof. + unfold pg_max. destruct x. repeat case_bool_decide;simpl in *; subst;try done;try lia. + rewrite Nat.max_id. done. +Qed. + +Canonical Structure max_pgO := leibnizO max_pg. + + +Section max_pg. + Local Instance max_pg_unit_instance : Unit max_pg := MaxPg (0,0). + Local Instance max_pg_valid_instance : Valid max_pg := λ x, True. + Local Instance max_pg_validN_instance : ValidN max_pg := λ n x, True. + Local Instance max_pg_pcore_instance : PCore max_pg := Some. + Local Instance max_pg_op_instance : Op max_pg := λ n m, MaxPg (pg_max (max_pg_car n) (max_pg_car m)). + Definition max_pg_op x y : MaxPg x ⋅ MaxPg y = MaxPg (pg_max x y) := eq_refl. + + Lemma max_pg_included x y : x ≼ y ↔ pg_le (max_pg_car x) (max_pg_car y). + Proof. + split. + - intros [z ->]. simpl. apply pg_le_max_r. + - exists y. rewrite /op /max_pg_op_instance. rewrite -pg_max_le;auto. by destruct y. + Qed. + Lemma max_pg_ra_mixin : RAMixin max_pg. + Proof. + apply ra_total_mixin; apply _ || eauto. + - intros [x] [y] [z]. repeat rewrite max_pg_op. by rewrite pg_max_assoc. + - intros [x] [y]. by rewrite max_pg_op pg_max_comm. + - intros [x]. by rewrite max_pg_op pg_max_id. + Qed. + Canonical Structure max_pgR : cmra := discreteR max_pg max_pg_ra_mixin. + + Global Instance max_pg_cmra_discrete : CmraDiscrete max_pgR. + Proof. apply discrete_cmra_discrete. Qed. + + Lemma max_pg_ucmra_mixin : UcmraMixin max_pg. + Proof. split; try apply _ || done. intros [x]. + rewrite /op /max_pg_op_instance /max_pg_unit_instance /=. + f_equiv. rewrite /pg_max /=. destruct x; repeat case_bool_decide;simpl in *; subst;try done;try lia. + Qed. + Canonical Structure max_pgUR : ucmra := Ucmra max_pg max_pg_ucmra_mixin. + + Global Instance max_pg_core_id (x : max_pg) : CoreId x. + Proof. by constructor. Qed. + + Lemma max_pg_local_update (x y x' : max_pg) : + pg_le (max_pg_car x) (max_pg_car x') → (x,y) ~l~> (x',x'). + Proof. + move: x y x' => [x] [y] [y'] /= H. + rewrite local_update_unital_discrete=> [[z]] _. + rewrite 2!max_pg_op. intros [= ?]. + split; first done. apply f_equal. subst. + rewrite /pg_max /pg_le. + rewrite /pg_max /pg_le in H. + destruct y',y,z. simpl in *. + destruct H as [|[? ?]]; repeat case_bool_decide;simpl in *; subst;try lia;try done;f_equal; lia. + Qed. + + Global Instance : IdemP (=@{max_pg}) (⋅). + Proof. intros [x]. rewrite max_pg_op. apply f_equal. rewrite pg_max_id //. Qed. + + Global Instance max_pg_is_op (x y : (nat * nat)) : + IsOp (MaxPg (pg_max x y)) (MaxPg x) (MaxPg y). + Proof. done. Qed. +End max_pg. + +(** Authoritative CMRA over [max_pg]. The authoritative element is a +monotonically increasing [pg], while a fragment is a lower bound. *) + +Definition mono_pg := auth max_pgUR. +Definition mono_pgR := authR max_pgUR. +Definition mono_pgUR := authUR max_pgUR. + +(** [mono_pg_auth] is the authoritative element. The definition includes the +fragment at the same value so that lemma [mono_pg_included], which states that +[mono_pg_lb n ≼ mono_pg_auth dq n], holds. Without this trick, a +frame-preserving update lemma would be required instead. *) +Notation pg := (nat * nat)%type. + +Definition mono_pg_auth (dq : dfrac) (n : pg) : mono_pg := + ●{dq} MaxPg n ⋅ ◯ MaxPg n. +Definition mono_pg_lb (n : pg) : mono_pg := ◯ MaxPg n. + +Notation "●MN dq a" := (mono_pg_auth dq a) + (at level 20, dq custom dfrac at level 1, format "●MN dq a"). +Notation "◯MN a" := (mono_pg_lb a) (at level 20). + +Section mono_pg. + Implicit Types (n : pg). + + Global Instance mono_pg_lb_core_id n : CoreId (◯MN n). + Proof. apply _. Qed. + Global Instance mono_pg_auth_core_id l : CoreId (●MN□ l). + Proof. apply _. Qed. + + Lemma mono_pg_auth_dfrac_op dq1 dq2 n : + ●MN{dq1 ⋅ dq2} n ≡ ●MN{dq1} n ⋅ ●MN{dq2} n. + Proof. + rewrite /mono_pg_auth auth_auth_dfrac_op. + rewrite (comm _ (●{dq2} _)) -!assoc (assoc _ (◯ _)). + by rewrite -core_id_dup (comm _ (◯ _)). + Qed. + + Lemma mono_pg_lb_op n1 n2 : + ◯MN (pg_max n1 n2) = ◯MN n1 ⋅ ◯MN n2. + Proof. rewrite -auth_frag_op max_pg_op //. Qed. + + Lemma mono_pg_auth_lb_op dq n : + ●MN{dq} n ≡ ●MN{dq} n ⋅ ◯MN n. + Proof. + rewrite /mono_pg_auth /mono_pg_lb. + rewrite -!assoc -auth_frag_op max_pg_op. + rewrite pg_max_id //. + Qed. + + Global Instance mono_pg_auth_dfrac_is_op dq dq1 dq2 n : + IsOp dq dq1 dq2 → IsOp' (●MN{dq} n) (●MN{dq1} n) (●MN{dq2} n). + Proof. rewrite /IsOp' /IsOp=> ->. rewrite mono_pg_auth_dfrac_op //. Qed. + Global Instance mono_pg_lb_max_is_op n n1 n2 : + IsOp (MaxPg n) (MaxPg n1) (MaxPg n2) → IsOp' (◯MN n) (◯MN n1) (◯MN n2). + Proof. rewrite /IsOp' /IsOp /mono_pg_lb=> ->. done. Qed. + + (** rephrasing of [mono_pg_lb_op] useful for weakening a fragment to a + smaller lower-bound *) + Lemma mono_pg_lb_op_le_l n n' : + pg_le n' n → + ◯MN n = ◯MN n' ⋅ ◯MN n. + Proof. intros. rewrite -mono_pg_lb_op -pg_max_le //. Qed. + + Lemma mono_pg_auth_dfrac_valid dq n : (✓ ●MN{dq} n) ↔ ✓ dq. + Proof. + rewrite /mono_pg_auth auth_both_dfrac_valid_discrete /=. naive_solver. + Qed. + Lemma mono_pg_auth_valid n : ✓ ●MN n. + Proof. by apply auth_both_valid. Qed. + + Lemma mono_pg_auth_dfrac_op_valid dq1 dq2 n1 n2 : + ✓ (●MN{dq1} n1 ⋅ ●MN{dq2} n2) ↔ ✓ (dq1 ⋅ dq2) ∧ n1 = n2. + Proof. + rewrite /mono_pg_auth (comm _ (●{dq2} _)) -!assoc (assoc _ (◯ _)). + rewrite -auth_frag_op (comm _ (◯ _)) assoc. split. + - move=> /cmra_valid_op_l /auth_auth_dfrac_op_valid. naive_solver. + - intros [? ->]. rewrite -core_id_dup -auth_auth_dfrac_op. + by apply auth_both_dfrac_valid_discrete. + Qed. + Lemma mono_pg_auth_op_valid n1 n2 : + ✓ (●MN n1 ⋅ ●MN n2) ↔ False. + Proof. rewrite mono_pg_auth_dfrac_op_valid. naive_solver. Qed. + + Lemma mono_pg_both_dfrac_valid dq n m : + ✓ (●MN{dq} n ⋅ ◯MN m) ↔ ✓ dq ∧ pg_le m n. + Proof. + rewrite /mono_pg_auth /mono_pg_lb -assoc -auth_frag_op. + rewrite auth_both_dfrac_valid_discrete max_pg_included /=. + split;[intros [? [? ?]]| intros [? ?]];split;auto. + - rewrite /pg_le. rewrite /pg_le /pg_max in H0. + destruct m,n. simpl in *. destruct H0 as [|[? ?]]; repeat case_bool_decide;simpl in *; subst;try lia;try done;f_equal. + - split;auto. + + rewrite /pg_le /pg_max. rewrite /pg_le /pg_max in H0. + destruct m,n. simpl in *. destruct H0 as [|[? ?]]; repeat case_bool_decide;simpl in *; subst;try lia;try done;f_equal. + + naive_solver. + Qed. + Lemma mono_pg_both_valid n m : + ✓ (●MN n ⋅ ◯MN m) ↔ pg_le m n. + Proof. rewrite mono_pg_both_dfrac_valid dfrac_valid_own. naive_solver. Qed. + + Lemma mono_pg_lb_mono n1 n2 : pg_le n1 n2 → ◯MN n1 ≼ ◯MN n2. + Proof. intros. by apply auth_frag_mono, max_pg_included. Qed. + + Lemma mono_pg_included dq n : ◯MN n ≼ ●MN{dq} n. + Proof. apply cmra_included_r. Qed. + + Lemma mono_pg_update {n} n' : + pg_le n n' → ●MN n ~~> ●MN n'. + Proof. + intros. rewrite /mono_pg_auth /mono_pg_lb. + by apply auth_update, max_pg_local_update. + Qed. + + Lemma mono_pg_auth_persist n dq : + ●MN{dq} n ~~> ●MN□ n. + Proof. + intros. rewrite /mono_pg_auth /mono_pg_lb. + eapply cmra_update_op_proper; last done. + eapply auth_update_auth_persist. + Qed. +End mono_pg. + +Global Typeclasses Opaque mono_pg_auth mono_pg_lb. diff --git a/theories/cmra.v b/theories/cmra.v new file mode 100644 index 0000000..8a023ef --- /dev/null +++ b/theories/cmra.v @@ -0,0 +1,5 @@ +(* This file contains the [CMRA] typeclass that is used by both the logic construction and the RAs *) +From iris.base_logic.lib Require Export iprop. + +(* Make Coq aware of Σ with type class search *) +Class CMRA `{Σ: !gFunctors} := {}. diff --git a/theories/dune b/theories/dune new file mode 100644 index 0000000..edf4c02 --- /dev/null +++ b/theories/dune @@ -0,0 +1,17 @@ +(include_subdirs qualified) +(coq.theory + (name self) + (stdlib yes) + (theories + Ltac2 + stdpp + iris + iris_named_props + RecordUpdate + Hammer.Tactics + bbv + Sail + SSCCommon + ISASem + ) +) diff --git a/theories/examples/co/corr.v b/theories/examples/co/corr.v new file mode 100644 index 0000000..6810b29 --- /dev/null +++ b/theories/examples/co/corr.v @@ -0,0 +1,221 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +From self.low Require Import instantiation. +From self.low.lib Require Import edge event. +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition addr := (BV 64 0x10). +Definition data := (BV 64 0x11). + +Definition write : Instruction := + (IStore AS_normal AV_plain "r0" (AEval data) (AEval addr)). +Definition read reg : Instruction := + (ILoad AS_normal AV_plain reg (AEval addr)). + +Section proof. + Context `{AAIrisG}. + + Definition addr_prot (v : Val) (e : Eid) : iProp Σ := + (⌜v= data⌝ ∗ ⌜EID.tid e = 1%nat⌝) ∨ ⌜EID.tid e = 0%nat⌝. + + Definition instrs_writer : iProp Σ := + (BV 64 0x1000) ↦ᵢ write ∗ + (BV 64 0x1004) ↦ᵢ -. + + Definition instrs_reader : iProp Σ := + (BV 64 0x2000) ↦ᵢ read "r1" ∗ + (BV 64 0x2004) ↦ᵢ read "r2" ∗ + (BV 64 0x2008) ↦ᵢ -. + + Definition protocol : UserProt := + Build_UserProt _ _ (λ a v e, + if bool_decide (a = addr) then addr_prot v e + else True)%I. + + #[local] Instance userprot : UserProt := protocol. + + Context `{!AAThreadG} `{ThreadGN}. + + Lemma writer ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + last_local_write 1 addr None -∗ + instrs_writer -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ 1 {{ λ lts', ⌜lts' = (LTSI.Done, (BV 64 0x1004))⌝}}. + Proof. + iIntros "Hpo_src Hctrl_src Hlocalw Hinstrs". + iDestruct "Hinstrs" as "(#? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw]"). + { + iApply (istore_pln (λ _, emp)%I ∅ ∅ with "[$Hpo_src $Hctrl_src $Hlocalw]"). iFrame "#∗". + rewrite big_sepS_empty big_sepM_empty //. + + iIntros (?). iSplitL. + - iIntros "_ _ _". done. + - iIntros "#HE % #Hpo _". iModIntro. iSplit;first done. simpl. rewrite /addr_prot. iLeft;done. + } + iIntros (?) "(-> &[% (#Hwrite&%Htid1&Hpo&_&Hlocal&Hctrl&HeidP)])". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv) by bv_solve. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4100)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ ∅); auto. rewrite dom_empty_L //. + Qed. + + (* Ad-hoc internal lemma for CoRR *) + Lemma po_loc_fr_rf_acyclic addr eid eid' eid'' : + eid -{Edge.Po}> eid' -∗ + eid' -{Edge.Fr}> eid'' -∗ + eid'' -{Edge.Rf}> eid -∗ + (∃ kinds kindv val, eid -{E}> (Event.R kinds kindv addr val)) -∗ + (∃ kinds kindv val, eid' -{E}> (Event.R kinds kindv addr val)) -∗ + False%I. + Proof. + rewrite event_eq /event_def. rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)] [% (Hg2&_&_&%)] [% (Hg3&_&_&%)] + (%&%&%&[% (Hg4&_&_&%HE1)]) (%&%&%&[% (Hg5&_&_&%HE2)])". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iDestruct (graph_agree_agree with "Hg1 Hg3") as %->. + iDestruct (graph_agree_agree with "Hg1 Hg4") as %->. + iDestruct (graph_agree_agree with "Hg1 Hg5") as %->. + exfalso. + simpl in *. + assert ((eid,eid') ∈ AACandExec.Candidate.loc gr3). + { + rewrite /Event.event_interp in HE1. + rewrite /Event.event_interp in HE2. + clear -HE1 HE2. + set_unfold. + destruct HE1 as (?&Hlk1&HE1). + destruct HE2 as (?&Hlk2&HE2). + exists x, x0, addr. split;first assumption. + split. + { + rewrite /AAConsistent.event_is_read_with in HE1. + set_unfold. + clear HE2 Hlk2 Hlk1. + destruct x;destruct o;simpl in *;try contradiction. + f_equal. + rewrite CBool.bool_unfold in HE1. + destruct HE1 as [_ [[_ Haddr1] _]]. + destruct t0. simpl in *. done. + } + split;first assumption. + { + rewrite /AAConsistent.event_is_read_with in HE2. + set_unfold. + clear HE1 Hlk2 Hlk1. + destruct x0;destruct o;simpl in *;try contradiction. + f_equal. + rewrite CBool.bool_unfold in HE2. + destruct HE2 as [_ [[_ Haddr2] _]]. + destruct t0. simpl in *. done. + } + } + destruct H3. + rewrite GRel.grel_irreflexive_spec in internal. + specialize (internal (eid, eid)). + apply internal. + eapply (GRel.grel_plus_trans _ _ eid'). + apply GRel.grel_plus_once. { set_solver + H8 H5. } + eapply (GRel.grel_plus_trans _ _ eid''). + apply GRel.grel_plus_once. { set_solver + H6. } + apply GRel.grel_plus_once. { set_solver + H7. } + done. + Qed. + + Definition reader ctrl : + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + None -{Rmw}> -∗ + last_local_write 2 addr None -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + instrs_reader -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ 2 {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x2008))⌝ ∗ + ∃ r1 r2, "r1" ↦ᵣ r1 ∗ "r2" ↦ᵣ r2 ∗ + (⌜r1.(reg_val) = (BV 64 0) ∧ (r2.(reg_val) = (BV 64 0) ∨ r2.(reg_val) = data)⌝ + ∨ ⌜r1.(reg_val) = data ∧ r2.(reg_val) = data⌝) + }}. + Proof. + iIntros "Hlpo Hctrl Hrmw Hlocalw [% Hr1] [% Hr2] Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hlpo Hctrl Hrmw Hlocalw]"). + { + iApply (iload_pln _ ∅ ∅ with "[$Hr1 $Hlpo $Hctrl $Hrmw $Hlocalw]"). iFrame "∗#". + rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _". rewrite big_sepM_empty //. + - iIntros (??) "_ _ _ _ _ _ #Hprot". iModIntro. iExact "Hprot". + } + iIntros (?) "(-> & %&%&%& #He_r1 & %Htid_r1 & Hr1 & Hannot & (% & % & #He_w1) & #Hrf1 & Hlpo & _ & Hctrl & Hrmw & Hlocalw)". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + + iDestruct (lpo_to_po with "Hlpo") as "[Hlpo #Hpo_r1]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr2 Hlpo Hctrl Hrmw Hlocalw]"). + { + iApply (iload_pln _ {[eid]} ∅ with "[$Hr2 $Hlpo $Hctrl $Hrmw $Hlocalw]"). iFrame "∗#". + { rewrite big_sepM_empty big_sepS_singleton. by iFrame "#". } + iIntros (?). iSplitR. + - iIntros "_ _". rewrite big_sepM_empty //. + - iIntros (??) "_ _ _ _ _ _ #Hprot". iModIntro. iExact "Hprot". + } + iIntros (?) "(-> & % & % & % & #He_r2 & %Htid_r2 & Hr2 & Hannot2 & (%&%&#He_w2) & #Hrf2 & Hlpo & #Hpo_r1_r2 & Hctrl & Hrmw & _)". + subst. clear G. assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve|]. rewrite G. + rewrite big_sepS_singleton. + iAssert (⌜eid ≠ eid0⌝%I) as "%Hneq". + { iIntros (->). iApply (po_irrefl with "Hpo_r1_r2"). } + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8200)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid0 := _;eid := _]} with "[Hannot Hannot2]"); auto. + { + simpl. rewrite 2!dom_insert_L. rewrite dom_empty_L union_empty_r_L. + apply set_Forall_union;rewrite set_Forall_singleton;lia. + } + { + rewrite big_sepM_insert. iFrame. + rewrite big_sepM_singleton. iFrame. + rewrite lookup_singleton_None //. + } + iIntros "HP". + rewrite big_sepM_insert. rewrite big_sepM_singleton. + 2:{ rewrite lookup_singleton_None //. } + iModIntro. + iSplit;first done. + iExists _, _. iFrame "Hr1 Hr2". + rewrite /prot /= /addr_prot. + iDestruct "HP" as "[[[-> %]|%] [[-> %]|%]]". + { iRight;done. } + { + iDestruct (initial_write_zero with "He_w1") as %->;first lia. + iLeft. iSplit;[done|iRight;done]. + } + { + (* impossible, by coh *) + iExFalso. + iApply po_loc_fr_rf_acyclic;iFrame "#". + iDestruct (initial_write_co with "He_w2 He_w1") as "#Hco";first lia. + rewrite H4. lia. + iApply (rf_co_to_fr with "Hrf2 Hco"). + iExists _,_,_. iFrame "#". + iExists _,_,_. iFrame "#". + } + { + iDestruct (initial_write_zero with "He_w1") as %<-;first lia. + iDestruct (initial_write_zero with "He_w2") as %<-;first lia. + iLeft. iSplit;[done|iLeft;done]. + } + Qed. + +End proof. diff --git a/theories/examples/co/coww.v b/theories/examples/co/coww.v new file mode 100644 index 0000000..401b503 --- /dev/null +++ b/theories/examples/co/coww.v @@ -0,0 +1,187 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +From self.low Require Import instantiation. +From self.low.lib Require Import edge event. +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition write addr data : Instruction := + (IStore AS_normal AV_plain "r0" (AEval data) (AEval addr)). + +Section Proof. + Context `{AAIrisG}. + Context `{!AAThreadG} `{ThreadGN}. + + Context (addr data data' : bv 64). + + Definition instrs : iProp Σ := + (BV 64 0x1000) ↦ᵢ (write addr data) ∗ + (BV 64 0x1004) ↦ᵢ (write addr data') ∗ + (BV 64 0x1008) ↦ᵢ -. + + Definition protocol : UserProt := + Build_UserProt _ _ (λ a v e, True)%I. + + #[local] Instance userprot : UserProt := protocol. + + Lemma loc_of_writes {gr ks kv ks' kv' a v v'} eid eid' : + Event.event_interp gr (Event.W ks kv a v) eid -> + Event.event_interp gr (Event.W ks' kv' a v') eid' -> + (eid, eid') ∈ AACandExec.Candidate.loc gr. + Proof. + intros HE1 HE2. + unfold Event.event_interp in *. + clear -HE1 HE2. + destruct HE1 as (E1&HE1gr&HE1). + destruct HE2 as (E2&HE2gr&HE2). + set_unfold. + unfold AAConsistent.event_is_write_with, AAConsistent.event_is_write_with_P in HE1. + exists E1, E2, a. + split; [assumption|]. + split. + { + destruct E1. destruct o; try contradiction. rewrite CBool.bool_unfold in HE1. simpl. + f_equal. + destruct HE1 as (_&_&HE1). + unfold AAConsistent.addr_and_value_of_wreq in HE1. + destruct (decide (n = AAArch.val_size)); [| destruct t0; congruence]. + destruct t0. unfold eq_rec_r, eq_rec in HE1. subst. simpl. inversion HE1. reflexivity. + } + split; [assumption|]. + destruct E2. destruct o; try contradiction. rewrite CBool.bool_unfold in HE2. simpl. + f_equal. + destruct HE2 as (_&_&HE2). + unfold AAConsistent.addr_and_value_of_wreq in HE2. + destruct (decide (n = AAArch.val_size)); [| destruct t0; congruence]. + destruct t0. unfold eq_rec_r, eq_rec in HE2. subst. simpl. inversion HE2. reflexivity. + Qed. + + (* Instead of these ad hoc lemmas we should just expose the notion + of "internal" edges in the ghost state and give a lemma that it's + acyclic *) + Lemma po_loc_co_acyclic eid eid' : + eid -{Edge.Po}> eid' -∗ + eid' -{Edge.Co}> eid -∗ + (∃ ks kv v, eid -{E}> (Event.W ks kv addr v)) -∗ + (∃ ks kv v, eid' -{E}> (Event.W ks kv addr v)) -∗ + False%I. + Proof. + rewrite event_eq /event_def. rewrite edge_eq /edge_def. + iIntros "(%gr & Hgr1 & %Hgraph_co & % & %Hpo) (% & Hgr2 & _ & _ & %Hco) + (% & % & % & % & Hgr3 & _ & _ & %HE1) (% & % & % & % & Hgr4 & _ & _ & %HE2)". + iDestruct (graph_agree_agree with "Hgr2 Hgr1") as %->. + iDestruct (graph_agree_agree with "Hgr3 Hgr1") as %->. + iDestruct (graph_agree_agree with "Hgr4 Hgr1") as %->. + exfalso. + assert(Hloc : (eid, eid') ∈ AACandExec.Candidate.loc gr). + { apply (loc_of_writes _ _ HE1 HE2). } + destruct Hgraph_co as [Hinternal _ _]. + unfold Edge.ef_edge_interp in Hpo, Hco. + set(internal := AACandExec.Candidate.po gr ∩ AACandExec.Candidate.loc gr ∪ AAConsistent.ca gr ∪ AACandExec.Candidate.rf gr). + assert (Hint1 : (eid, eid') ∈ internal). { set_solver + internal Hpo Hloc. } + assert (Hint2 : (eid', eid) ∈ internal). { set_solver + internal Hco. } + assert (Hcyc : (eid, eid) ∈ GRel.grel_plus internal). + { eapply GRel.grel_plus_trans; apply GRel.grel_plus_once; eassumption. } + rewrite GRel.grel_irreflexive_spec in Hinternal. + specialize (Hinternal (eid, eid)). + by apply Hinternal. + Qed. + + Lemma po_to_co eid eid' : + eid -{Edge.Po}> eid' -∗ + (∃ ks kv v, eid -{E}> (Event.W ks kv addr v)) -∗ + (∃ ks kv v, eid' -{E}> (Event.W ks kv addr v)) -∗ + eid -{Edge.Co}> eid'. + Proof. + rewrite event_eq /event_def. rewrite edge_eq /edge_def. + iIntros "(%gr & Hgr1 & %Hgraph_co & % & %Hpo) + (%ks & %kv & %v & % & Hgr2 & _ & _ & %HE1) (%ks' & %kv' & %v' & % & Hgr3 & _ & _ & %HE2)". + iDestruct (graph_agree_agree with "Hgr2 Hgr1") as %->. + iDestruct (graph_agree_agree with "Hgr3 Hgr1") as %->. + iExists gr. + iFrame "%∗". + iPureIntro. + unfold Edge.ef_edge_interp. + apply Graph.wf_coi_inv; try assumption. + + apply (loc_of_writes _ _ HE1 HE2). + + assert (G : eid ∈ AACandExec.Candidate.mem_writes gr). + { + unfold Event.event_interp in HE1. + destruct HE1 as (E1 & HE1gr & HE1). + apply (AAConsistent.event_is_write_with_elem_of_mem_writes eid E1 ks kv addr v); assumption. + } + assert (G' : eid' ∈ AACandExec.Candidate.mem_writes gr). + { + unfold Event.event_interp in HE2. + destruct HE2 as (E2 & HE2gr & HE2). + apply (AAConsistent.event_is_write_with_elem_of_mem_writes eid' E2 ks' kv' addr v'); assumption. + } + set_solver + G G'. + Qed. + + Lemma prog ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + last_local_write 1 addr None -∗ + instrs -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ 1 {{ λ lts', ⌜lts' = (LTSI.Done, (BV 64 0x1008))⌝ ∗ + ∃ eid eid', + eid -{E}> Event.W AS_normal AV_plain addr data ∗ + eid' -{E}> Event.W AS_normal AV_plain addr data' ∗ + eid -{Edge.Co}> eid'}}. + Proof. + iIntros "Hpo_src Hctrl_src Hlast_write Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlast_write]"). + { + iApply (istore_pln (λ _, emp)%I ∅ ∅ with "[$Hpo_src $Hctrl_src $Hlast_write]"). + { iFrame "#". by rewrite big_sepS_empty big_sepM_empty. } + + iIntros (?). iSplitL. + - by iIntros "_ _ _". + - iIntros "#HE %Htid #Hpo _". by iModIntro. + } + + iIntros (?) "(-> & %eid1 & #Heid1 & %Htid1 & Hpo_src & _ & Hlast_write & Hctrl_src & _)". + + assert(G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv) by bv_solve. rewrite G. clear G. + + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlast_write Hpo]"). + { + iApply (istore_pln (λ _, emp)%I {[eid1]} ∅ with "[$Hpo_src $Hctrl_src $Hlast_write]"). + { iFrame "#". rewrite big_sepS_singleton big_sepM_empty. by iFrame "#". } + + iIntros (?). iSplitL. + + by iIntros "_ _ _". + + iIntros "#HE %Htid #Hpo' _". by iModIntro. + } + + iIntros (?) "{Hpo} (-> & %eid2 & #Heid2 & %Htid2 & Hpo_src & #Hpo & Hlast_write & Hctrl_src & _)". + iEval (rewrite big_sepS_singleton) in "Hpo". + + assert(G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv) by bv_solve. rewrite G. clear G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4104)⌝))%I. + { by iApply idone. } + + iIntros (? ->). + iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ ∅); [done|done|]. + iIntros "_ !>". + iSplitL; [done|]. + iExists eid1, eid2. + iFrame "#". + + iApply po_to_co; [done| |]. + + by iExists AS_normal, AV_plain, data. + + by iExists AS_normal, AV_plain, data'. + Qed. + +End Proof. diff --git a/theories/examples/isa2/isa2.v b/theories/examples/isa2/isa2.v new file mode 100644 index 0000000..8e96940 --- /dev/null +++ b/theories/examples/isa2/isa2.v @@ -0,0 +1,317 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +From self.low Require Export instantiation. +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 0x10). +Definition flag1 := (BV 64 0x18). +Definition flag2 := (BV 64 0x20). + +Definition data_write : Instruction := + (IStore AS_normal AV_plain "r0" (AEval (BV 64 42)) (AEval data)). +Definition flag1_write : Instruction := + (IStore AS_rel_or_acq AV_plain "r0" (AEval (BV 64 1)) (AEval flag1)). + +Definition flag1_read kind := + (ILoad kind AV_plain "r1" (AEval flag1)). +Definition flag2_write := + (IStore AS_normal AV_plain "r0" (AEreg "r1") (AEval flag2)). + +Definition flag2_read kind := + (ILoad kind AV_plain "r1" (AEval flag2)). +Definition data_read := + (ILoad AS_normal AV_plain "r2" (AEval data)). + +Section proof. + Context `{AAIrisG}. + + Context (tid1 tid2 tid3 : Tid). + Context (Htid_ne12 : tid1 ≠ tid2). + Context (Htid_ne13 : tid1 ≠ tid3). + Context (Htid_ne23 : tid2 ≠ tid3). + + Definition data_prot (v : Val) (e : Eid) : iProp Σ := + (⌜v = (BV 64 42)⌝ ∗ ⌜EID.tid e = tid1⌝) ∨ ⌜EID.tid e = 0%nat⌝. + + Definition t1_prop w_data w_flag : iProp Σ := + ⌜EID.tid w_data = tid1⌝ ∗ ⌜EID.tid w_flag = tid1⌝ ∗ + w_data -{Edge.Po}> w_flag ∗ + w_data -{E}> (Event.W AS_normal AV_plain data (BV 64 42)) ∗ + w_flag -{E}> (Event.W AS_rel_or_acq AV_plain flag1 (BV 64 1)). + + Definition flag1_prot (e : Eid) : iProp Σ := + ⌜EID.tid e = 0%nat⌝ ∨ ∃ d, t1_prop d e. + + (* Need to constrain both thread 2 events to tid2 *) + Definition t2_prop w_data w_flag1 r_flag1 w_flag2 : iProp Σ := + t1_prop w_data w_flag1 ∗ + ⌜EID.tid r_flag1 = tid2⌝ ∗ ⌜EID.tid w_flag2 = tid2⌝ ∗ + w_flag1 -{Edge.Rf}> r_flag1 ∗ + r_flag1 -{Edge.Data}> w_flag2 ∗ + w_flag2 -{E}> (Event.W AS_normal AV_plain flag2 (BV 64 1)). + + Definition flag2_prot (v : Val) (e : Eid) : iProp Σ := + ⌜EID.tid e = 0%nat⌝ ∨ + ⌜ v = (BV 64 0) ⌝ ∨ + ∃ wd wf1 rf1, + t2_prop wd wf1 rf1 e. + + Definition t1_instrs : iProp Σ := + (BV 64 0x1000 ↦ᵢ data_write) ∗ + (BV 64 0x1004 ↦ᵢ flag1_write) ∗ + (BV 64 0x1008 ↦ᵢ -). + + Definition t2_instrs : iProp Σ := + (BV 64 0x2000 ↦ᵢ flag1_read AS_normal) ∗ + (BV 64 0x2004 ↦ᵢ flag2_write) ∗ + (BV 64 0x2008 ↦ᵢ -). + + Definition t3_instrs : iProp Σ := + (BV 64 0x3000 ↦ᵢ flag2_read AS_rel_or_acq) ∗ + (BV 64 0x3004 ↦ᵢ data_read) ∗ + (BV 64 0x3008 ↦ᵢ -). + + Definition protocol : UserProt := + Build_UserProt _ _ (λ a v e, + if bool_decide (a = data) then data_prot v e + else if bool_decide (a = flag1) then flag1_prot e + else if bool_decide (a = flag2) then flag2_prot v e + else (⌜EID.tid e = 0%nat⌝))%I. + + #[local] Instance userprot : UserProt := protocol. + + Context `{!AAThreadG} `{ThreadGN}. + + Lemma t1 ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + last_local_write tid1 data None -∗ + last_local_write tid1 flag1 None -∗ + t1_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid1 {{ λ lts', ⌜lts' = (LTSI.Done, (BV 64 0x1008)) ⌝}}. + Proof. + iIntros "Hpo_src Hctrl_src Hlocalw_data Hlocalw_flag Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_data]"). + { + iApply (istore_pln (λ _, emp)%I ∅ ∅ with "[Hpo_src Hctrl_src Hlocalw_data]"). iFrame "#∗". + { rewrite big_sepS_empty big_sepM_empty //. } + + iIntros (?). iSplitL. + - by iIntros "_ _ _". + - iIntros "#HE % #Hpo _". iModIntro. iSplit; [done|]. simpl. unfold data_prot. by iLeft. + } + + iIntros (?) "(-> & [% (#Hwrite & %Htid1 & Hpo & _ & Hlocalw_data & Hctrl & HeidP)])". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv) by bv_solve. rewrite G. clear G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_flag Hwrite Hpo Hctrl HeidP]"). + { + iDestruct (lpo_to_po with "Hpo") as "[Hlpo #Hpo]". + iApply (istore_rel emp {[eid := emp%I]}). iFrame "#∗". + + iSplit; [by rewrite big_sepM_singleton|]. + iSplitL; [by rewrite big_sepM_singleton|]. + + iIntros (eid') "#Hfwrite %Htid1' #Hpo' HeidP'". + iModIntro. iSplit; [done|]. + + simpl. unfold flag1_prot. iModIntro. + iRight. iExists eid. unfold t1_prop. iFrame "#%". + by iEval (rewrite big_sepM_singleton) in "Hpo'". + } + iIntros (?) "(-> & [% (? & ? & ?)])". + assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. rewrite G. clear G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4104)⌝)%I). + { + by iApply idone. + } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ ∅); auto. + rewrite dom_empty_L //. + Qed. + + Lemma t2 ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + None -{Rmw}> -∗ + last_local_write tid2 flag1 None -∗ + last_local_write tid2 flag2 None -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + t2_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid2 {{ λ lts', ⌜lts' = (LTSI.Done, (BV 64 0x2008)) ⌝}}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw Hlocalw_flag1 Hlocalw_flag2 [% Hr1] Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hpo_src Hctrl_src Hrmw Hlocalw_flag1]"). + { + iApply (iload_pln _ ∅ ∅ with "[$Hr1 $Hpo_src $Hctrl_src $Hrmw Hlocalw_flag1]"). + { + iFrame "#∗". + rewrite big_sepS_empty big_sepM_empty //. + } + + iIntros (?). iSplitR. + - iIntros "_ _". done. + - iIntros (??) "_ _ _ _ _ _ #Hprot". iModIntro. iExact "Hprot". + } + + iIntros (?) "(-> & % & % & % & #Hf1read & %Hfread_tid & Hr1 & Hannot & (% & % & #Hwrite) & #Hrf & Hpo_src & _ & Hctrl_src & Hrmw & _)". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv) by bv_solve. rewrite G. clear G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_flag2 Hr1 Hannot Hwrite Hrf Hpo_src Hctrl_src]"). + { + iApply (istore_pln_single_data with "[$Hpo_src $Hctrl_src $Hlocalw_flag2 $Hr1 $Hannot]"). + iFrame "#". + iIntros (eidf2) "#Hf2write %Hfwrite_tid #Ht2po #Ht2data #Hflag1_prot". + iModIntro. + simpl. + unfold flag2_prot. + iRight. + destruct (decide (v = (BV 64 0))); [iLeft; done|]. + iRight. + unfold flag1_prot. + iDestruct "Hflag1_prot" as "[%Htid_eid' | [%wd Hflag1_prot]]". + { + by iDestruct (initial_write_zero _ _ _ _ _ Htid_eid' with "Hwrite") as "<-". + } + iExists wd, eid', eid. + unfold t2_prop. + iAssert(⌜v = (BV 64 1)⌝)%I as "->". + { + unfold t1_prop. + iDestruct "Hflag1_prot" as "(_ & _ & _ & _ & Hwrite')". + iDestruct (event_agree with "Hwrite Hwrite'") as "%Heq". + iPureIntro. + by injection Heq. + } + + iFrame "#%". + } + + iIntros (?) "(-> & _ & [% (_ & _ & _ & _)])". + assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv) by bv_solve. rewrite G. clear G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, (BV 64 8200))⌝)%I). + { by iApply idone. } + + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ ∅); auto. + rewrite dom_empty_L //. + Qed. + + Lemma t3 ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + None -{Rmw}> -∗ + last_local_write tid3 flag2 None -∗ + last_local_write tid3 data None -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + t3_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x3000)) @ tid3 {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x3008)) ⌝ ∗ + ∃ r1 r2, "r1" ↦ᵣ r1 ∗ "r2" ↦ᵣ r2 ∗ + (⌜r1.(reg_val) = (BV 64 1)⌝ -∗ ⌜r2.(reg_val) = (BV 64 42)⌝) + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw Hlastw_flag2 Hlastw_data [% Hr1] [% Hr2] Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hpo_src Hctrl_src Hrmw Hlastw_flag2]"). + { + iApply (iload_pln _ ∅ ∅ with "[$Hr1 $Hpo_src $Hctrl_src $Hrmw $Hlastw_flag2]"). + { + iFrame "∗#". + rewrite big_sepM_empty big_sepS_empty //. + } + + iIntros (?). iSplitR. + - iIntros "_ _"; done. + - iIntros (??) "_ _ _ _ _ _ #Hprot". iModIntro. iExact "Hprot". + } + + iIntros (?) "(-> & % & % & % & #Hf2read & %Hf2read_tid & Hr1 & Hannot & (% & % & #Hf2write) & #Hrf & Hpo_src & _ & Hctrl_src & Hrmw & _)". + + assert (G: ((BV 64 12288) `+Z` 4 = (BV 64 12292))%bv) by bv_solve. rewrite G. clear G. + + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr2 Hpo_src Hannot Hctrl_src Hrmw Hlastw_data]"). + { + iApply (iload_pln (λ e v', ⌜v = (BV 64 1)⌝ -∗ ⌜v' = (BV 64 42)⌝)%I {[eid]} {[eid := prot flag2 v eid']} with "[$Hr2 $Hpo_src $Hctrl_src $Hrmw $Hlastw_data Hannot]"). + { + iFrame "#∗". + rewrite big_sepM_singleton big_sepS_singleton. iFrame "#∗". + } + iIntros (data_read). iSplitR. + - iIntros "Hdata_read HPo". rewrite big_sepM_singleton big_sepS_singleton. + iApply (acq_po_is_lob with "[Hf2read] HPo"). iDestruct (event_node with "Hf2read") as "$". + - iIntros (data_write v') "#Hdata_read %Hdata_read_tid #HPo (% & % & #Hdata_write) #Hdata_rf Hannot". + rewrite big_sepM_singleton big_sepS_singleton. + iIntros "#Hdata_prot". iModIntro. iIntros (->). + simpl. + + iDestruct "Hdata_prot" as "[(% & %)|%Hdata_prot]"; [done|]. + unfold flag2_prot. + iDestruct "Hannot" as "[%Hannot|[%Hannot|Hannot]]". + { + iDestruct (initial_write_zero _ _ _ _ _ Hannot with "Hf2write") as "%F". + contradict F. bv_solve. + } + { + contradict Hannot. + (* Unfold some hidden constructors that seem to trip up bv_solve *) + unfold Val, AAArch.val, AAval, AAArch.val_size. + bv_solve. + } + + iDestruct "Hannot" as "(%data_write' & %flag1_write & %flag1_read & #Ht1 & #Ht2)". + remember eid' as flag2_write. + remember eid as flag2_read. + + iDestruct "Ht1" as "(% & % & Ht1_po & Hdata_write' & Hflag1_write)". + iDestruct "Ht2" as "(% & % & Hflag1_rf & Ht2_data & Hflag2_write)". + + iDestruct (initial_write_co with "Hdata_write Hdata_write'") as "Hco"; [ done | | ]. + { subst. pose proof tid_nz_nz. lia. } + iDestruct (rf_co_to_fr with "Hdata_rf Hco") as "Hfr". + iDestruct (fre_is_ob with "Hfr") as "Hob1"; [lia|]. + iDestruct (po_rel_is_lob with "Ht1_po [Hflag1_write]") as "Hlob2". + { iDestruct (event_node with "Hflag1_write") as "$". } + iDestruct (lob_is_ob with "Hlob2") as "Hob2". + iDestruct (rfe_is_ob with "Hflag1_rf") as "Hob3"; [lia|]. + iDestruct (data_is_lob with "Ht2_data") as "Hlob4". + iDestruct (lob_is_ob with "Hlob4") as "Hob4". + iDestruct (rfe_is_ob with "Hrf") as "Hob5"; [lia|]. + iDestruct (acq_po_is_lob with "[Hf2read] HPo") as "Hlob6". + { iDestruct (event_node with "Hf2read") as "$". } + iDestruct (lob_is_ob with "Hlob6") as "Hob6". + + + iDestruct (ob_trans with "Hob1 Hob2") as "Hob". + iDestruct (ob_trans with "Hob Hob3") as "{Hob} Hob". + iDestruct (ob_trans with "Hob Hob4") as "{Hob} Hob". + iDestruct (ob_trans with "Hob Hob5") as "{Hob} Hob". + iDestruct (ob_trans with "Hob Hob6") as "{Hob} Hob". + iDestruct (ob_acyclic with "Hob") as "[]". + } + iIntros (?) "(-> & % & % & % & Hdread & % & Hr2 & Hdannot & _ & _ & Hlpo & _ & Hctrl & Hrmw & _)". + subst. assert (G: ((BV 64 12292) `+Z` 4 = (BV 64 12296))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 12296)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ {[eid0 := _]} with "[Hdannot]"); auto. + { simpl. rewrite dom_singleton_L. set_solver. } + { rewrite big_sepM_singleton. iExact "Hdannot". } + rewrite big_sepM_singleton. + iIntros "% !>". iSplit;first done. + iExists _, _. iFrame. auto. + Qed. +End proof. diff --git a/theories/examples/lb/adequacy.v b/theories/examples/lb/adequacy.v new file mode 100644 index 0000000..10e2809 --- /dev/null +++ b/theories/examples/lb/adequacy.v @@ -0,0 +1,189 @@ +(* This file contains an application of adequacy theorem on the [data_data1] example *) +From iris.proofmode Require Import tactics. + +From self.low Require Import adequacy. +From self.middle Require Import weakestpre. + +From self.lang Require Import mm opsem. +From self.examples.lb Require Import data_data1. + +Require Import ISASem.SailArmInstTypes. + +Lemma progress_zero_is_init gr tid: + ThreadState.progress_is_init gr tid (0%nat, 0%nat). +Proof. + intros ??. destruct (ThreadState.progress_of_node x). + destruct n. right;simpl;lia. left;simpl;lia. +Qed. + +Section adequacy. + Context (g : Graph.t). + + Definition global_state := + GlobalState.make g + {[ + (BV 64 0x1000) := read "r1" addr_x; + (BV 64 0x1004) := write "r1" addr_y; + (BV 64 0x2000) := read "r2" addr_y; + (BV 64 0x2004) := write "r2" addr_x + ]}. + + Notation ts1 := (ThreadState.mk_ts + {["pc" := mk_regval (BV 64 0x1000) ∅; "r1" := mk_regval (BV 64 0) ∅]} + instrs.EmptyInterp). + + Notation ts2 := (ThreadState.mk_ts + {["pc" := mk_regval (BV 64 0x2000) ∅; "r2" := mk_regval (BV 64 0) ∅]} + instrs.EmptyInterp). + + Definition lts := + [LThreadState.LTSNormal ts1 ; LThreadState.LTSNormal ts2]. + + Definition Φs := + [ + (λ lts, ∃ ts, lts = LThreadState.LTSDone ts ∧ ∃ rv, ts.(ThreadState.ts_regs)!! "r1" = Some rv ∧ rv.(reg_val) = (BV 64 0)) + ; + (λ lts, ∃ ts, lts = LThreadState.LTSDone ts ∧ ∃ rv, ts.(ThreadState.ts_regs)!! "r2" = Some rv ∧ rv.(reg_val) = (BV 64 0)) + ]. + + Lemma application `{CMRA Σ} `{!invGpreS Σ} `{!base.AABaseInG} `{!instantiation.AAThreadInG} lts': + AAConsistent.t g -> + AACandExec.NMSWF.wf g -> + S (length lts) = AACandExec.Candidate.num_of_thd g -> + (length lts = length lts' + ∧ ∀ idx σ σ', lts !! idx = Some σ → lts' !! idx = Some σ' → (∃ n, nsteps (LThreadStep.t global_state (idx_to_tid idx)) (S n) σ σ')) -> + (∀ (k:nat) σ, lts' !! k = Some σ → Terminated σ) -> + (forall (idx: nat) σ' (Φ: _ -> Prop), lts' !! idx = Some σ' → Φs !! idx = Some Φ → Φ σ'). + Proof. + intros Hcons Hwf Hnum Htsteps Hterm. + apply (adequacy_pure global_state lts lts' Φs Hcons Hwf Hnum Htsteps). + { + intros ?? Hlk. eexists. split;eauto. simpl. destruct idx;simpl in Hlk. + { inversion Hlk;subst. rewrite /ThreadState.mk_ts /ThreadState.get_progress /=. apply progress_zero_is_init. } + { apply list_lookup_singleton_Some in Hlk. destruct Hlk as [-> <-]. + rewrite /ThreadState.mk_ts /ThreadState.get_progress /=. apply progress_zero_is_init. } + } + { done. } + { + intros. + (* allocate all resources *) + iMod (instantiation.interp_alloc global_state) as "(%Hbase & ?&#Hgs &#Hgr&#Hinst)". + iDestruct (instantiation.my_local_interp_alloc global_state (0,0)%nat (Pos.of_nat 1) {[addr_x;addr_y]} with "Hgr") as ">[%Htgl1 Hinterp_ll1]". + { apply progress_zero_is_init. } + iDestruct (instantiation.my_local_interp_alloc global_state (0,0)%nat (Pos.of_nat 2) {[addr_x;addr_y]} with "Hgr") as ">[%Htgl2 Hinterp_ll2]". + { apply progress_zero_is_init. } + pose (instantiation.GenAALThreadG Σ H _) as HaathreadG. + + iDestruct (@instantiation.thread_local_interp_alloc Σ H HaathreadG Htgl1 ts1) as ">[%Htgn1 Hinterp_tl1]". + { eexists. simpl. simplify_map_eq /=. done. } + iDestruct (@instantiation.thread_local_interp_alloc Σ H HaathreadG Htgl2 ts2) as ">[%Htgn2 Hinterp_tl2]". + { eexists. simpl. simplify_map_eq /=. done. } + + iModIntro. + pose (instantiation.Build_AAIrisG Σ _ Hinv Hbase) as HaairisG. + pose (@instantiation.instantiation_irisG Σ _ Hinv Hbase HaairisG) as HirisG. + pose ((@instantiation.user_prot_to_prot Σ _ Hbase data_data1.protocol)) as Hprot. + iExists HirisG, Hprot. + iFrame. iFrame "Hgs". + iSplitR. + { (* show the protocol holds on initials *) + iApply big_sepS_forall. + iIntros (e Hin). iModIntro. iIntros (ks kv a v) "Hinit". simpl. + case_bool_decide; simpl. rewrite /lb_prot. + iDestruct (instantiation.graph_event_agree with "Hgs Hinit") as "%Hinit". + iPureIntro. rewrite /event.Event.event_interp in Hinit. destruct Hinit as (? &?&?). + set_unfold in Hin. destruct Hin as [Hvalid Hzero]. + feed pose proof (Graph.init_zero g e Hwf Hzero v) as Heq. + repeat eexists. eauto. eauto. rewrite Heq //. + case_bool_decide; simpl. rewrite /lb_prot. + iDestruct (instantiation.graph_event_agree with "Hgs Hinit") as "%Hinit". + iPureIntro. rewrite /event.Event.event_interp in Hinit. destruct Hinit as (? &?&?). + set_unfold in Hin. destruct Hin as [Hvalid Hzero]. + feed pose proof (Graph.init_zero g e Hwf Hzero v) as Heq. + repeat eexists. eassumption. eassumption. rewrite Heq //. + auto. + } + iSplitL "Hinterp_ll1 Hinterp_tl1". + { (* instantiate WP1 *) + pose (@instantiation.instantiation_irisGL Σ H Hinv Hbase HaairisG Htgl1) as HirisGL. + iExists HirisGL, _. + simpl. rewrite /ThreadState.get_progress /= /idx_to_tid. + iDestruct "Hinterp_ll1" as "[$ [Hlocs Hpo]]". + iDestruct "Hinterp_tl1" as "(Hinterp_thd & Hregs & Hctrl & Hrmw)". + iApply (@wp_strong_mono Σ H Hinv HirisG HirisGL Hprot (Pos.of_nat 1) (LThreadState.LTSNormal ts1) _ + (λ σ', ⌜∃ ts : ThreadState.t, + σ' = LThreadState.LTSDone ts + ∧ (∃ rv : RegVal, ThreadState.ts_regs ts !! "r1" = Some rv ∧ reg_val rv = BV 64 0)⌝)%I + + with "[-] []"). + rewrite /instrs.RNPC. rewrite delete_insert //. + rewrite big_sepM_singleton. rewrite big_sepS_union. + 2:{ assert (addr_x ≠ addr_y) as Hneq. bitvector_tactics.bv_solve. set_solver + Hneq. } + + rewrite 2!big_sepS_singleton. iDestruct "Hlocs" as "[Hx Hy]". + + iDestruct (@write_reg_thread_1 Σ H Hinv Hbase HaairisG HaathreadG Htgl1 Htgn1 with "Hpo Hctrl Hrmw [Hregs] Hx Hy []") as "WP". + { iExists _. done. } + { rewrite /instrs instantiation.instr_eq /instantiation.instr_def. + repeat (iSplit;first (iExists _;iFrame "Hinst";done)). + iExists _;iFrame "Hinst";done. + } + rewrite wpi_eq /wpi_def. + iDestruct ("WP" with "[] Hinterp_thd") as "WP". + { + simpl. iPureIntro;split. done. + simplify_map_eq /=. done. + } + iExact "WP". + iIntros (?) "Hpost". + rewrite /to_lts_Phi /=. + destruct k; iDestruct "Hpost" as "(Hinterp&(% &%&%Hinv'&[% [Hr1 %]]))";inversion Hinv';subst. + iNamed "Hinterp". + iDestruct (instantiation.reg_interp_agree with "Hinterp_reg Hr1") as %Hr1. + iModIntro. iPureIntro. + exists ts. split;auto. eexists. split;eauto. + } + { (* instantiate WP2 *) + simpl. iSplitL;last done. + pose (@instantiation.instantiation_irisGL Σ H Hinv Hbase HaairisG Htgl2) as HirisGL. + iExists HirisGL, _. + simpl. rewrite /ThreadState.get_progress /= /idx_to_tid. + iDestruct "Hinterp_ll2" as "[$ [Hlocs Hpo]]". + iDestruct "Hinterp_tl2" as "(Hinterp_thd & Hregs & Hctrl & Hrmw)". + iApply (@wp_strong_mono Σ H Hinv HirisG HirisGL Hprot (Pos.of_nat 2) (LThreadState.LTSNormal ts2) _ + (λ σ', ⌜∃ ts : ThreadState.t, + σ' = LThreadState.LTSDone ts + ∧ (∃ rv : RegVal, ThreadState.ts_regs ts !! "r2" = Some rv ∧ reg_val rv = BV 64 0)⌝)%I + + with "[-] []"). + rewrite /instrs.RNPC. rewrite delete_insert //. + rewrite big_sepM_singleton. rewrite big_sepS_union. + 2:{ assert (addr_x ≠ addr_y) as Hneq. bitvector_tactics.bv_solve. set_solver + Hneq. } + + rewrite 2!big_sepS_singleton. iDestruct "Hlocs" as "[Hx Hy]". + + iDestruct (@write_reg_thread_2 Σ H Hinv Hbase HaairisG HaathreadG Htgl2 Htgn2 with "Hpo Hctrl Hrmw [Hregs] Hx Hy []") as "WP". + { iExists _. done. } + { rewrite /instrs instantiation.instr_eq /instantiation.instr_def. + repeat (iSplit;first (iExists _;iFrame "Hinst";done)). + iExists _;iFrame "Hinst";done. + } + rewrite wpi_eq /wpi_def. + iDestruct ("WP" with "[] Hinterp_thd") as "WP". + { + simpl. iPureIntro;split. done. + simplify_map_eq /=. done. + } + iExact "WP". + iIntros (?) "Hpost". + rewrite /to_lts_Phi /=. + destruct k; iDestruct "Hpost" as "(Hinterp&(% &%&%Hinv'&[% [Hr1 %]]))";inversion Hinv';subst. + iNamed "Hinterp". + iDestruct (instantiation.reg_interp_agree with "Hinterp_reg Hr1") as %Hr1. + iModIntro. iPureIntro. + exists ts. split;auto. eexists. split;eauto. + } + } + Qed. + +End adequacy. diff --git a/theories/examples/lb/ctrls.v b/theories/examples/lb/ctrls.v new file mode 100644 index 0000000..cbc7dce --- /dev/null +++ b/theories/examples/lb/ctrls.v @@ -0,0 +1,315 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. +From iris.algebra Require Import excl. + +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 1). +Definition addr_x := (BV 64 0x11). +Definition addr_y := (BV 64 0x10). + +Notation read reg addr := (ILoad AS_normal AV_plain reg (AEval addr)). +Notation write_val addr := (IStore AS_normal AV_plain "r1" (AEval data) (AEval addr)). +Notation branch reg val addr := (IBne (AEbinop AOminus (AEreg reg) (AEval val)) addr). + +(* the token ghost state *) +Class LbInPreG `{CMRA Σ} := { + LbDatasOneShot :> inG Σ (csumR (exclO unitO) + (agreeR (leibnizO Val))); + }. + +Class LbInG `{CMRA Σ} := { + LbIn :> LbInPreG; + LbOneShotN : gname; + }. + +#[global] Arguments LbOneShotN {Σ _ _}. + +Definition LbΣ : gFunctors := + #[ GFunctor (csumR (exclO unitO) + (agreeR (leibnizO Val)))]. + +#[global] Instance subG_LbInPreG `{CMRA Σ}: subG LbΣ Σ -> LbInPreG. +Proof. solve_inG. Qed. + +Section one_shot. + Context `{CMRA Σ} `{!LbInG}. + + Definition pending := own LbOneShotN (Cinl (Excl ())). + + Definition shot v := own LbOneShotN (Cinr (to_agree v)). + + Lemma pending_shot v: pending -∗ shot v -∗ False. + Proof. + rewrite /pending /shot. iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI //=. + Qed. + + Lemma shoot v: pending ==∗ shot v. + Proof. + rewrite /pending /shot. iIntros "H". + iApply (own_update with "H"). + apply cmra_update_exclusive. + rewrite Cinr_valid. done. + Qed. + + #[global] Instance shot_persist v: Persistent (shot v). + Proof. + rewrite /shot. apply _. + Qed. + +End one_shot. + +Section ctrls. + Context `{AAIrisG} `{!AAThreadG} `{ThreadGN}. + Context `{!LbInG}. + + Definition instrs : iProp Σ := + (BV 64 0x1000) ↦ᵢ read "r1" addr_x ∗ + (BV 64 0x1004) ↦ᵢ branch "r1" (BV 64 0) (BV 64 0x1008) ∗ + (BV 64 0x1008) ↦ᵢ write_val addr_y ∗ + (BV 64 0x100C) ↦ᵢ - ∗ + (BV 64 0x2000) ↦ᵢ read "r2" addr_y ∗ + (BV 64 0x2004) ↦ᵢ branch "r2" data (BV 64 0x200C) ∗ + (BV 64 0x2008) ↦ᵢ write_val addr_x ∗ + (BV 64 0x200C) ↦ᵢ -. + + Definition lb_prot_val (v : Val) : iProp Σ := + ⌜v = bv_0 _⌝ ∨ (⌜ v = data ⌝ ∗ shot v). + + #[local] Instance userprot_val : UserProt := + Build_UserProt _ _(λ a v e, + if (bool_decide (a = addr_x)) || (bool_decide (a = addr_y)) + then lb_prot_val v + else False%I + ). + + Definition thread_1 tid : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + pending -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + last_local_write tid addr_x None -∗ + last_local_write tid addr_y None -∗ + instrs -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid + {{ λ lts', + (⌜lts' = (LTSI.Done, (BV 64 0x100C))⌝ ∗ + ∃ rv, "r1" ↦ᵣ rv ∗ ⌜rv.(reg_val) = bv_0 _⌝) + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw Hpending [% Hreg] Hlocalw_x Hlocalw_y Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #? & #? & _)". + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_x Hrmw Hreg Hpending]"). + { + iApply (iload_pln (λ _ v, ⌜v = bv_0 _⌝ ∗ (⌜v = bv_0 _⌝ ∗ pending))%I ∅ ∅ with "[-Hpending] [Hpending]"). + iFrame "#∗". rewrite big_sepS_empty big_sepM_empty //. + + iIntros (?). iSplitR. + iIntros "_ _". done. + iIntros (??) "_ _ _ _ _ _ [#H1|#[H2 Hshot]]". + iFrame "Hpending". by iFrame "H1". + iExFalso. iApply (pending_shot with "Hpending Hshot"). + } + iIntros (?) "(-> &(%&%&%&(#Hwrite&%&Hreg&Hna&_&Hrfe&Hlpo&_&Hctrl&Hrmw&_)))". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv); [bv_solve|]. rewrite G;clear G. + iDestruct (annot_split_iupd with "Hna") as ">[Hna1 Hna2]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hreg Hctrl]"). + { + iApply (ibne {["r1" := _ ]} with "[] [Hctrl]" ); [ | | iFrame "#" | iFrame | ]. + set_solver. + 2: { by rewrite big_sepM_singleton. } + + simpl. rewrite lookup_insert /=. reflexivity. + } + iIntros (?) "(Hreg & Hctrl & [[-> _]|[-> %]])". + { + assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. rewrite G. + + rewrite big_sepM_singleton. + rewrite (@map_fold_singleton _ _ _ _ _ _ _ _ _ _ _ RegVal) /=. + rewrite union_empty_r_L. rewrite union_empty_r_L. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_y Hwrite Hlpo Hctrl Hna2]"). + { + iApply (istore_pln (λ _, emp)%I ∅ {[eid := _]} with "[Hlpo Hctrl Hlocalw_y Hna2]"). iFrame "#∗". + iSplitR;first done. rewrite big_sepM_singleton. iFrame "Hna2". + iIntros (eid''). + iSplitR. + - iIntros "HE _ Hctrls". rewrite big_sepM_singleton /=. rewrite big_sepS_singleton. + iApply (ctrl_w_is_lob with "HE Hctrls"). + - iIntros "#Hwrite' % #Hpo''' P". + rewrite big_sepM_singleton. iDestruct "P" as "[% Hpending]". + iDestruct (shoot data with "Hpending") as ">#Hshot". + iModIntro. iSplitR;first done. iModIntro. iRight. iFrame "Hshot". done. + } + iIntros (?) "(->& (% &?&?&?&?&?&?&?))". + subst. clear G. assert (G: ((BV 64 4104) `+Z` 4 = (BV 64 4108))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4108)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= ⌜v = bv_0 _⌝%I]} with "[Hna1]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros. iModIntro. + iSplit;first done. iExists _. iFrame. simpl. done. + } + { + rewrite big_sepM_singleton. + rewrite (@map_fold_singleton _ _ _ _ _ _ _ _ _ _ _ RegVal) /=. + rewrite union_empty_r_L. rewrite union_empty_r_L. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_y Hwrite Hlpo Hctrl Hna2]"). + { + iApply (istore_pln (λ _, emp)%I ∅ {[eid := _]} with "[Hlpo Hctrl Hlocalw_y Hna2]"). iFrame "#∗". + iSplitR;first done. rewrite big_sepM_singleton. iFrame "Hna2". + iIntros (eid''). + iSplitR. + - iIntros "HE _ Hctrls". rewrite big_sepM_singleton /=. rewrite big_sepS_singleton. + iApply (ctrl_w_is_lob with "HE Hctrls"). + - iIntros "#Hwrite' % #Hpo''' P". + rewrite big_sepM_singleton. iDestruct "P" as "[% Hpending]". + iDestruct (shoot data with "Hpending") as ">#Hshot". + iModIntro. iSplitR;first done. iModIntro. iRight. iFrame "Hshot". done. + } + iIntros (?) "(->& (% &?&?&?&?&?&?&?))". + subst. assert (G: ((BV 64 4104) `+Z` 4 = (BV 64 4108))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4108)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= ⌜v = bv_0 _⌝%I]} with "[Hna1]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros. iModIntro. + iSplit;first done. iExists _. iFrame. simpl. done. + } + Qed. + + Definition thread_2 tid : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + last_local_write tid addr_x None -∗ + last_local_write tid addr_y None -∗ + instrs -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x200C))⌝ ∗ + ∃ rv, "r2" ↦ᵣ rv ∗ ⌜rv.(reg_val) = bv_0 _ ∨ rv.(reg_val) = data ⌝ + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw [% Hreg] Hlocalw_x Hlocalw_y Hinstrs". + iDestruct "Hinstrs" as "(_ & _ & _ & _ & #? & #? & #? & #?)". + iApply sswpi_wpi. + iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_y Hrmw Hreg]"). + { + iApply (iload_pln (λ _ v, lb_prot_val v ∗ lb_prot_val v)%I ∅ ∅ with "[-] []"). + iFrame "#∗". rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _". done. + - iIntros (??) "_ _ _ _ _ _ #?". by iFrame "#". + } + iIntros (?) "(->&(%&%&%&(#Hwrite&%&Hreg&Hna&_&Hrfe&Hpo&_&Hctrl&Hrmw&_)))". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + iDestruct (annot_split_iupd with "Hna") as ">[Hna1 Hna2]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hreg Hctrl]"). + { + iApply (ibne {["r2" := _ ]} with "[] [Hctrl]" ); [ | | iFrame "#" | iFrame | ]. + set_solver. + 2: { by rewrite big_sepM_singleton. } + + simpl. rewrite lookup_insert /=. reflexivity. + } + iIntros (?) "(Hreg & Hctrl & [[-> %]|[-> %]])". + { + clear G. assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve|]. rewrite G. + + rewrite big_sepM_singleton. + rewrite (@map_fold_singleton _ _ _ _ _ _ _ _ _ _ _ RegVal) /=. + rewrite union_empty_r_L. rewrite union_empty_r_L. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_x Hwrite Hpo Hctrl Hna1]"). + { + iApply (istore_pln (λ _, emp)%I ∅ {[eid := _]} with "[Hpo Hctrl Hlocalw_x Hna1]"). iFrame "#∗". + iSplitR;first done. rewrite big_sepM_singleton. iFrame "Hna1". + iIntros (eid''). + iSplitR. + - iIntros "HE _ Hctrls". rewrite big_sepM_singleton /=. rewrite big_sepS_singleton. + iApply (ctrl_w_is_lob with "HE Hctrls"). + - iIntros "#Hwrite' % #Hpo''' P". + rewrite big_sepM_singleton. + iDestruct "P" as "#P". + iModIntro. iSplitR;first done. iModIntro. simpl. + rewrite /lb_prot_val. + assert (v = data)%bv as Heq. + { + clear -H5. + rewrite /data in H5. rewrite /data. + destruct (bool_decide (v = BV 64 1)) eqn:Heqn. + rewrite bool_decide_eq_true in Heqn. done. + rewrite bool_decide_eq_false in Heqn. + unfold Val in v. unfold AAArch.val in v. unfold AAval in v. unfold AAArch.val_size in v. + assert ((v - BV 64 1)%bv = (v `-Z` 1)%bv). bv_solve. + rewrite H in H5. clear H. + assert (bv_unsigned v ≠ 1). + { intro Heq. apply Heqn. apply bv_eq. rewrite Heq. done. } + apply bv_eq in H5. + rewrite bv_sub_Z_unsigned /= in H5. + rewrite bv_unsigned_BV in H5. + bv_simplify_arith. bv_saturate_unsigned; bv_solve_unfold_tac. + unfold bv_signed, bv_swrap, bv_wrap, bv_half_modulus, bv_modulus, bv_unsigned in *. + simpl in *. destruct v. lia. + } + iDestruct "P" as "[-> | [-> Hshot]]". + { + rewrite /data in Heq. + assert (bv_0 64 = BV 64 0)%bv. bv_solve. + rewrite H7 in Heq. inversion Heq. + } + { + iRight. iFrame "Hshot". done. + } + } + iIntros (?) "(->& (% &?&?&?&?&?&?&?))". + subst. clear G. assert (G: ((BV 64 8200) `+Z` 4 = (BV 64 8204))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8204)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= (lb_prot_val v)]} with "[Hna2]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros "#Hprot". iModIntro. + iSplit;first done. iExists _. iFrame. simpl. iDestruct "Hprot" as "[#? | [#? _]]". + + iLeft. done. iRight. done. + } + { + rewrite big_sepM_singleton. + rewrite (@map_fold_singleton _ _ _ _ _ _ _ _ _ _ _ RegVal) /=. + rewrite union_empty_r_L. rewrite union_empty_r_L. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8204)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= (lb_prot_val v)]} with "[Hna2]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros "#Hprot". iModIntro. + iSplit;first done. iExists _. iFrame. simpl. iDestruct "Hprot" as "[#? | [#? _]]". + + iLeft. done. iRight. done. + } + Qed. + +End ctrls. diff --git a/theories/examples/lb/data_data1.v b/theories/examples/lb/data_data1.v new file mode 100644 index 0000000..6b660c2 --- /dev/null +++ b/theories/examples/lb/data_data1.v @@ -0,0 +1,145 @@ +From stdpp.unstable Require Export bitvector. +From stdpp.unstable Require Import bitvector_tactics. + +From iris.proofmode Require Import tactics. +From iris.algebra Require Import excl. + +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 1). +Definition addr_x := (BV 64 0x11). +Definition addr_y := (BV 64 0x10). + +Notation write reg addr := (IStore AS_normal AV_plain "r0" (AEreg reg) (AEval addr)). +Notation read reg addr := (ILoad AS_normal AV_plain reg (AEval addr)). + +Ltac fold_continuation := + match goal with | |- context [AAInter.Next _ ?cont] => set(ctx:=cont) end. + +Section write_reg. + Context `{AAIrisG} `{!AAThreadG} `{ThreadGN}. + + (* for this thin-air version we can only show that the outcome must be [00] *) + Definition instrs : iProp Σ := + (BV 64 0x1000) ↦ᵢ read "r1" addr_x ∗ + (BV 64 0x1004) ↦ᵢ write "r1" addr_y ∗ + (BV 64 0x1008) ↦ᵢ - ∗ + (BV 64 0x2000) ↦ᵢ read "r2" addr_y ∗ + (BV 64 0x2004) ↦ᵢ write "r2" addr_x ∗ + (BV 64 0x2008) ↦ᵢ -. + + Definition lb_prot (v : Val) : iProp Σ := + ⌜v = BV 64 0⌝. + + Definition protocol : UserProt := + Build_UserProt _ _(λ a v e, + if (bool_decide (a = addr_x)) || (bool_decide (a = addr_y)) + then lb_prot v + else True%I + ). + + Local Instance userprot : UserProt := protocol. + + Definition write_reg_thread_1 tid : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + last_local_write tid addr_x None -∗ + last_local_write tid addr_y None -∗ + instrs -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x1008))⌝ ∗ + ∃ rv, "r1" ↦ᵣ rv ∗ ⌜rv.(reg_val) = BV 64 0⌝ + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw [% Hreg] Hlocalw_x Hlocalw_y Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #? & _ & _)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_x Hrmw Hreg]"). + { + iApply (iload_pln (λ _ v, lb_prot v ∗ lb_prot v)%I ∅ ∅ with "[-] []"). + iFrame "#∗". rewrite big_sepM_empty big_sepS_empty //. + + iIntros. iSplitL. + - iIntros "_ _". rewrite big_sepM_empty //. + - iIntros (??) "_ _ _ _ _ _ %". iPureIntro. done. + } + iIntros (?) "(->&(%&%&%&(#Hwrite&%&Hreg&Hna&_&Hrfe&Hpo&_&Hctrl&Hrmw&_)))". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv); [bv_solve|]. rewrite G. + + iDestruct (annot_split_iupd with "Hna") as ">[Hna1 Hna2]". + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_y Hwrite Hpo Hctrl Hrmw Hreg Hna1]"). + { + iApply istore_pln_single_data. iFrame "#∗". + iIntros (eid'') "#Hwrite' _ #Hpo #Hdata %Hprot". + iModIntro. simpl. done. + } + iIntros (?) "(%&[? (%&?&?&?&?)])". + subst. clear G. assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. + rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4104)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= (lb_prot v)]} with "[Hna2]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros. iModIntro. + iSplit;first done. iExists _. iFrame. simpl. done. + Qed. + + Definition write_reg_thread_2 tid : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + last_local_write tid addr_x None -∗ + last_local_write tid addr_y None -∗ + instrs -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x2008))⌝ ∗ + ∃ rv, "r2" ↦ᵣ rv ∗ ⌜rv.(reg_val) = BV 64 0⌝ + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw [% Hreg] Hlocalw_x Hlocalw_y Hinstrs". + iDestruct "Hinstrs" as "(_ & _ & _ & #? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_y Hrmw Hreg]"). + { + iApply (iload_pln (λ _ v, lb_prot v ∗ lb_prot v)%I ∅ ∅ with "[-] []"). + iFrame "#∗". rewrite big_sepM_empty big_sepS_empty //. + + iIntros. iSplitL. + - iIntros "_ _". rewrite big_sepM_empty //. + - iIntros (??) "_ _ _ _ _ _ %". iPureIntro. done. + } + iIntros (?) "(->&(%&%&%&(#Hwrite&%&Hreg&Hna&_&Hrfe&Hpo&_&Hctrl&Hrmw&_)))". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + iDestruct (annot_split_iupd with "Hna") as ">[Hna1 Hna2]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_x Hwrite Hpo Hctrl Hreg Hna1]"). + { + iApply istore_pln_single_data. iFrame "#∗". + iIntros (eid'') "#Hwrite' _ #Hpo #Hdata %Hprot". + iModIntro. simpl. done. + } + iIntros (?) "(%&[? (%&?&?&?&?)])". + subst. clear G. assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8200)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= (lb_prot v)]} with "[Hna2]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros. iModIntro. + iSplit;first done. iExists _. iFrame. simpl. done. + Qed. + +End write_reg. diff --git a/theories/examples/lb/data_data2.v b/theories/examples/lb/data_data2.v new file mode 100644 index 0000000..ac28494 --- /dev/null +++ b/theories/examples/lb/data_data2.v @@ -0,0 +1,197 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. +From iris.algebra Require Import excl. + +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 1). +Definition addr_x := (BV 64 0x11). +Definition addr_y := (BV 64 0x10). + +Notation read reg addr := (ILoad AS_normal AV_plain reg (AEval addr)). +Notation write reg addr := (IStore AS_normal AV_plain "r0" (AEreg reg) (AEval addr)). +Notation write_val reg addr := + (IStore AS_normal AV_plain + "r1" (AEbinop AOplus (AEval data) (AEbinop AOminus (AEreg reg) (AEreg reg))) + (AEval addr)). + +(* the token ghost state *) +Class LbInPreG `{CMRA Σ} := { + LbDatasOneShot :> inG Σ (csumR (exclO unitO) + (agreeR (leibnizO Val))); + }. + +Class LbInG `{CMRA Σ} := { + LbIn :> LbInPreG; + LbOneShotN : gname; + }. + +#[global] Arguments LbOneShotN {Σ _ _}. + +Definition LbΣ : gFunctors := + #[ GFunctor (csumR (exclO unitO) + (agreeR (leibnizO Val)))]. + +#[global] Instance subG_LbInPreG `{CMRA Σ}: subG LbΣ Σ -> LbInPreG. +Proof. solve_inG. Qed. + +Section one_shot. + Context `{CMRA Σ} `{!LbInG}. + + Definition pending := own LbOneShotN (Cinl (Excl ())). + + Definition shot v := own LbOneShotN (Cinr (to_agree v)). + + Lemma pending_shot v: pending -∗ shot v -∗ False. + Proof. + rewrite /pending /shot. iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI //=. + Qed. + + Lemma shoot v: pending ==∗ shot v. + Proof. + rewrite /pending /shot. iIntros "H". + iApply (own_update with "H"). + apply cmra_update_exclusive. + rewrite Cinr_valid. done. + Qed. + + #[global] Instance shot_persist v: Persistent (shot v). + Proof. + rewrite /shot. apply _. + Qed. + +End one_shot. + +Section write_val. + Context `{AAIrisG} `{!AAThreadG} `{ThreadGN}. + Context `{!LbInG}. + + (* for this thin-air version we can only show that the outcome must be [00] *) + Definition instrs_val : iProp Σ := + (BV 64 0x1000) ↦ᵢ read "r1" addr_x ∗ + (BV 64 0x1004) ↦ᵢ write_val "r1" addr_y ∗ + (BV 64 0x1008) ↦ᵢ - ∗ + (BV 64 0x2000) ↦ᵢ read "r2" addr_y ∗ + (BV 64 0x2004) ↦ᵢ write "r2" addr_x ∗ + (BV 64 0x2008) ↦ᵢ -. + + Definition lb_prot_val (v : Val) : iProp Σ := + ⌜v = bv_0 _⌝ ∨ (⌜ v = data ⌝ ∗ shot v). + + #[local] Instance userprot_val : UserProt := + Build_UserProt _ _(λ a v e, + if (bool_decide (a = addr_x)) || (bool_decide (a = addr_y)) + then lb_prot_val v + else False%I + ). + + Definition write_val_thread_1 tid : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + pending -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + last_local_write tid addr_x None -∗ + last_local_write tid addr_y None -∗ + instrs_val -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x1008))⌝ ∗ + ∃ rv, "r1" ↦ᵣ rv ∗ ⌜rv.(reg_val) = bv_0 _⌝ + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw Hpending [% Hreg] Hlocalw_x Hlocalw_y Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #? & _ & _)". + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_x Hrmw Hreg Hpending]"). + { + iApply (iload_pln (λ _ v, ⌜v = bv_0 _⌝ ∗ (⌜v = bv_0 _⌝ ∗ pending))%I ∅ ∅ with "[-Hpending] [Hpending]"). + iFrame "#∗". rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _". done. + - iIntros (??) "_ _ _ _ _ _ [#H1|#[H2 Hshot]]". + iFrame "Hpending". by iFrame "H1". + iExFalso. iApply (pending_shot with "Hpending Hshot"). + } + iIntros (?) "(->&(%&%&%&(#Hwrite&%&Hreg&Hna&_&Hrfe&Hpo&_&Hctrl&Hrmw&_)))". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv); [bv_solve|]. rewrite G. + iDestruct (annot_split_iupd with "Hna") as ">[Hna1 Hna2]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_y Hwrite Hpo Hctrl Hreg Hna2]"). + { + iApply istore_pln_fake_data. iFrame "#∗". + iIntros (eid'') "#Hwrite' #Hpo #Hdata [% Hpending]". + iDestruct (shoot data with "Hpending") as ">#Hshot". + iModIntro. iModIntro. + iRight. iFrame "Hshot". done. + } + iIntros (?) "(->&[? (%&?&?&?&?)])". + clear G. assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4104)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= ⌜v = bv_0 _⌝%I]} with "[Hna1]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros. iModIntro. + iSplit;first done. iExists _. iFrame. simpl. done. + Qed. + + Definition write_val_thread_2 tid : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + last_local_write tid addr_x None -∗ + last_local_write tid addr_y None -∗ + instrs_val -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x2008))⌝ ∗ + ∃ rv, "r2" ↦ᵣ rv ∗ ⌜rv.(reg_val) = bv_0 _ ∨ rv.(reg_val) = data ⌝ + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw [% Hreg] Hlocalw_x Hlocalw_y Hinstrs". + iDestruct "Hinstrs" as "(_ & _ & _ & #? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_y Hrmw Hreg]"). + { + iApply (iload_pln (λ _ v, lb_prot_val v ∗ lb_prot_val v)%I ∅ ∅ with "[-] []"). + iFrame "#∗". rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _". done. + - iIntros (??) "_ _ _ _ _ _ #?". by iFrame "#". + } + iIntros (?) "(->&(%&%&%&(#Hwrite&%&Hreg&Hna&_&Hrfe&Hpo&_&Hctrl&Hrmw&_)))". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + iDestruct (annot_split_iupd with "Hna") as ">[Hna1 Hna2]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_x Hwrite Hpo Hctrl Hreg Hna1]"). + { + iApply istore_pln_single_data. iFrame "#∗". + iIntros (eid'') "#Hwrite' _ #Hpo #Hdata #Hprot". + iModIntro. simpl. done. + } + iIntros (?) "(->&[? (%&?&?&?&?)])". + clear G. assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8200)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= (lb_prot_val v)]} with "[Hna2]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros "#Hprot". iModIntro. + iSplit;first done. iExists _. iFrame. simpl. iDestruct "Hprot" as "[#? | [#? _]]". + iLeft. done. iRight. done. + Qed. + +End write_val. diff --git a/theories/examples/lb/data_dmbsy.v b/theories/examples/lb/data_dmbsy.v new file mode 100644 index 0000000..a3427bf --- /dev/null +++ b/theories/examples/lb/data_dmbsy.v @@ -0,0 +1,212 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. +From iris.algebra Require Import excl. + +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 1). +Definition addr_x := (BV 64 0x11). +Definition addr_y := (BV 64 0x10). + +Notation read reg addr := (ILoad AS_normal AV_plain reg (AEval addr)). +Notation write reg addr := (IStore AS_normal AV_plain "r0" (AEreg reg) (AEval addr)). +Notation write_val addr := (IStore AS_normal AV_plain "r1" (AEval data) (AEval addr)). +Notation dmb_sy := (IDmb AAArch.Sy). + +(* the token ghost state *) +Class LbInPreG `{CMRA Σ} := { + LbDatasOneShot :> inG Σ (csumR (exclO unitO) + (agreeR (leibnizO Val))); + }. + +Class LbInG `{CMRA Σ} := { + LbIn :> LbInPreG; + LbOneShotN : gname; + }. + +#[global] Arguments LbOneShotN {Σ _ _}. + +Definition LbΣ : gFunctors := + #[ GFunctor (csumR (exclO unitO) + (agreeR (leibnizO Val)))]. + +#[global] Instance subG_LbInPreG `{CMRA Σ}: subG LbΣ Σ -> LbInPreG. +Proof. solve_inG. Qed. + +Section one_shot. + Context `{CMRA Σ} `{!LbInG}. + + Definition pending := own LbOneShotN (Cinl (Excl ())). + + Definition shot v := own LbOneShotN (Cinr (to_agree v)). + + Lemma pending_shot v: pending -∗ shot v -∗ False. + Proof. + rewrite /pending /shot. iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI //=. + Qed. + + Lemma shoot v: pending ==∗ shot v. + Proof. + rewrite /pending /shot. iIntros "H". + iApply (own_update with "H"). + apply cmra_update_exclusive. + rewrite Cinr_valid. done. + Qed. + + #[global] Instance shot_persist v: Persistent (shot v). + Proof. + rewrite /shot. apply _. + Qed. + +End one_shot. + +Section write_val. + Context `{AAIrisG} `{!AAThreadG} `{ThreadGN}. + Context `{!LbInG}. + + (* for this thin-air version we can only show that the outcome must be [00] *) + Definition instrs_val : iProp Σ := + (BV 64 0x1000) ↦ᵢ read "r1" addr_x ∗ + (BV 64 0x1004) ↦ᵢ dmb_sy ∗ + (BV 64 0x1008) ↦ᵢ write_val addr_y ∗ + (BV 64 0x100C) ↦ᵢ - ∗ + (BV 64 0x2000) ↦ᵢ read "r2" addr_y ∗ + (BV 64 0x2004) ↦ᵢ write "r2" addr_x ∗ + (BV 64 0x2008) ↦ᵢ -. + + Definition lb_prot_val (v : Val) : iProp Σ := + ⌜v = bv_0 _⌝ ∨ (⌜ v = data ⌝ ∗ shot v). + + #[local] Instance userprot_val : UserProt := + Build_UserProt _ _(λ a v e, + if (bool_decide (a = addr_x)) || (bool_decide (a = addr_y)) + then lb_prot_val v + else False%I + ). + + Definition write_val_thread_1 tid : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + pending -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + last_local_write tid addr_x None -∗ + last_local_write tid addr_y None -∗ + instrs_val -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x100C))⌝ ∗ + ∃ rv, "r1" ↦ᵣ rv ∗ ⌜rv.(reg_val) = bv_0 _⌝ + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw Hpending [% Hreg] Hlocalw_x Hlocalw_y Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #? & #? & _)". + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_x Hrmw Hreg Hpending]"). + { + iApply (iload_pln (λ _ v, ⌜v = bv_0 _⌝ ∗ (⌜v = bv_0 _⌝ ∗ pending))%I ∅ ∅ with "[-Hpending] [Hpending]"). + iFrame "#∗". rewrite big_sepS_empty big_sepM_empty //. + + iIntros (?). iSplitR. + iIntros "_ _". done. + iIntros (??) "_ _ _ _ _ _ [#H1|#[H2 Hshot]]". + iFrame "Hpending". by iFrame "H1". + iExFalso. iApply (pending_shot with "Hpending Hshot"). + } + iIntros (?) "(-> &(%&%&%&(#Hwrite&%&Hreg&Hna&_&Hrfe&Hlpo&_&Hctrl&Hrmw&_)))". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv); [bv_solve|]. rewrite G. + iDestruct (annot_split_iupd with "Hna") as ">[Hna1 Hna2]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlpo]"). + { + iApply idmb;eauto. + } + iIntros (?) "(-> & %& #Hdmb & #Hpo & Hlpo)". + subst. clear G. assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. rewrite G. + + iDestruct (lpo_to_po with "Hlpo") as "[Hlpo #Hpo']". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_y Hwrite Hlpo Hctrl Hna2]"). + { + iApply (istore_pln (λ _, emp)%I {[eid0]} {[eid := _]} with "[Hlpo Hctrl Hlocalw_y Hna2]"). iFrame "#∗". + rewrite big_sepS_singleton. rewrite big_sepM_singleton. iFrame "# Hna2". + iIntros (eid''). + iSplitR. + - iIntros "HE Hpo'' _". rewrite big_sepS_singleton. rewrite big_sepM_singleton /=. + iApply (po_dmbsy_po_is_lob with "Hpo [Hdmb] Hpo''"). + { iDestruct (event_node with "Hdmb") as "$". } + - iIntros "#Hwrite' % #Hpo''' P". + rewrite big_sepM_singleton. iDestruct "P" as "[% Hpending]". + iDestruct (shoot data with "Hpending") as ">#Hshot". + iModIntro. iSplitR;first done. iModIntro. iRight. iFrame "Hshot". done. + } + iIntros (?) "(->& (% &?&?&?&?&?&?&?))". + subst. clear G. assert (G: ((BV 64 4104) `+Z` 4 = (BV 64 4108))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4108)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= ⌜v = bv_0 _⌝%I]} with "[Hna1]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros. iModIntro. + iSplit;first done. iExists _. iFrame. simpl. done. + Qed. + + Definition write_val_thread_2 tid : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + last_local_write tid addr_x None -∗ + last_local_write tid addr_y None -∗ + instrs_val -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x2008))⌝ ∗ + ∃ rv, "r2" ↦ᵣ rv ∗ ⌜rv.(reg_val) = bv_0 _ ∨ rv.(reg_val) = data ⌝ + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw [% Hreg] Hlocalw_x Hlocalw_y Hinstrs". + iDestruct "Hinstrs" as "(_ & _ & _ & _ & #? & #? & #?)". + iApply sswpi_wpi. + iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_y Hrmw Hreg]"). + { + iApply (iload_pln (λ _ v, lb_prot_val v ∗ lb_prot_val v)%I ∅ ∅ with "[-] []"). + iFrame "#∗". rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _". done. + - iIntros (??) "_ _ _ _ _ _ #?". by iFrame "#". + } + iIntros (?) "(->&(%&%&%&(#Hwrite&%&Hreg&Hna&_&Hrfe&Hpo&_&Hctrl&Hrmw&_)))". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + iDestruct (annot_split_iupd with "Hna") as ">[Hna1 Hna2]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_x Hwrite Hpo Hctrl Hreg Hna1]"). + { + iApply istore_pln_single_data. iFrame "#∗". + iIntros (eid'') "#Hwrite' _ #Hpo #Hdata #Hprot". + iModIntro. simpl. done. + } + iIntros (?) "(%&[? (%&?&?&?&?)])". + subst. clear G. assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve|]. + rewrite G. + iApply sswpi_wpi. + iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8200)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid:= (lb_prot_val v)]} with "[Hna2]"). + rewrite dom_singleton_L set_Forall_singleton //. + rewrite big_sepM_singleton //. + rewrite big_sepM_singleton //. iIntros "#Hprot". iModIntro. + iSplit;first done. iExists _. iFrame. simpl. iDestruct "Hprot" as "[#? | [#? _]]". + iLeft. done. iRight. done. + Qed. + +End write_val. diff --git a/theories/examples/mp/rel_acq.v b/theories/examples/mp/rel_acq.v new file mode 100644 index 0000000..eae86d7 --- /dev/null +++ b/theories/examples/mp/rel_acq.v @@ -0,0 +1,190 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +From self.low Require Export instantiation. +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 0x10). +Definition flag := (BV 64 0x18). + +Definition data_write : Instruction := + (IStore AS_normal AV_plain "r0" (AEval (BV 64 42)) (AEval data)). +Definition flag_write : Instruction := + (IStore AS_rel_or_acq AV_plain "r0" (AEval (BV 64 1)) (AEval flag)). + +Definition flag_read kind:= + (ILoad kind AV_plain "r1" (AEval flag)). +Definition data_read := + (ILoad AS_normal AV_plain "r2" (AEval data)). + +Definition dep_data_read := + (ILoad AS_normal AV_plain "r2" (AEbinop AOplus (AEval data) (AEbinop AOminus (AEreg "r1") (AEreg "r1")))). + +Section proof. + Context `{AAIrisG}. + + Context (tid1 tid2: Tid). + Context (Htid_ne :tid1 ≠ tid2). + + Definition data_prot (v : Val) (e : Eid) : iProp Σ := + (⌜v= (BV 64 42)⌝ ∗ ⌜EID.tid e = tid1⌝) ∨ ⌜EID.tid e = 0%nat⌝. + + Definition flag_prot (e : Eid) : iProp Σ := + ⌜EID.tid e = 0%nat⌝ + ∨ ∃ d, + ⌜EID.tid e = tid1 ⌝ ∗ ⌜EID.tid d = tid1⌝ ∗ + d -{Edge.Po}> e ∗ + d -{E}> (Event.W AS_normal AV_plain data (BV 64 42)) ∗ + e -{E}> (Event.W AS_rel_or_acq AV_plain flag (BV 64 1)). + + Definition send_instrs : iProp Σ := + (BV 64 0x1000) ↦ᵢ data_write ∗ + (BV 64 0x1004) ↦ᵢ flag_write ∗ + (BV 64 0x1008) ↦ᵢ -. + + Definition receive_instrs : iProp Σ := + (BV 64 0x2000) ↦ᵢ flag_read AS_rel_or_acq ∗ + (BV 64 0x2004) ↦ᵢ data_read ∗ + (BV 64 0x2008) ↦ᵢ -. + + Definition dep_receive_instrs : iProp Σ := + (BV 64 0x2000) ↦ᵢ flag_read AS_normal ∗ + (BV 64 0x2004) ↦ᵢ dep_data_read ∗ + (BV 64 0x2008) ↦ᵢ -. + + Definition protocol : UserProt := + Build_UserProt _ _(λ a v e, + if bool_decide (a = data) then data_prot v e + else if bool_decide (a = flag) then flag_prot e + else (⌜EID.tid e = 0%nat⌝)%I + ). + + #[local] Instance userprot : UserProt := protocol. + + Context `{!AAThreadG} `{ThreadGN}. + + Lemma send ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + last_local_write tid1 data None -∗ + last_local_write tid1 flag None -∗ + send_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid1 {{ λ lts', ⌜lts' = (LTSI.Done, (BV 64 0x1008))⌝}}. + Proof. + iIntros "Hpo_src Hctrl_src Hlocalw_data Hlocalw_flag Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_data]"). + { + iApply (istore_pln (λ _, emp)%I ∅ ∅ with "[$Hpo_src $Hctrl_src $Hlocalw_data]"). iFrame "#∗". + rewrite big_sepS_empty big_sepM_empty //. + + iIntros (?). iSplitL. + - iIntros "_ _ _". done. + - iIntros "#HE % #Hpo _". iModIntro. iSplit;first done. simpl. rewrite /data_prot. iLeft;done. + } + iIntros (?) "(-> &[% (#Hwrite&%Htid1&Hpo&_&Hlocal&Hctrl&HeidP)])". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv) by bv_solve. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_flag Hwrite Hpo Hctrl HeidP]"). + { + iDestruct (lpo_to_po with "Hpo") as "[Hlpo #Hpo]". + iApply (istore_rel emp {[eid := emp%I]}). iFrame "#∗". + + iSplit;first rewrite big_sepM_singleton //. + iSplitL;first rewrite big_sepM_singleton //. + + iIntros (eid') "#Hwrite' %Htid2 #Hpo' HeidP'". + iModIntro. iSplit;first done. iModIntro. + iRight. iExists eid. rewrite big_sepM_singleton. by iFrame "#". + } + iIntros (?) "(-> &[% (?&?&?)])". + clear G. assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4104)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ ∅); auto. rewrite dom_empty_L //. + Qed. + + + Definition receive ctrl : + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + None -{Rmw}> -∗ + last_local_write tid2 data None -∗ + last_local_write tid2 flag None -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + receive_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid2 {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x2008))⌝ ∗ + ∃ r1 r2, "r1" ↦ᵣ r1 ∗ "r2" ↦ᵣ r2 ∗ + (⌜r1.(reg_val) = (BV 64 1)⌝ -∗ ⌜r2.(reg_val) = (BV 64 42)⌝) + }}. + Proof. + iIntros "Hlpo Hctrl Hrmw Hllwd Hllwf [% Hr1] [% Hr2] Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hlpo Hctrl Hrmw Hllwf]"). + { + iApply (iload_pln _ ∅ ∅ with "[$Hr1 $Hlpo $Hctrl $Hrmw $Hllwf]"). iFrame "∗#". + rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _". rewrite big_sepM_empty //. + - iIntros (??) "_ _ _ _ _ _ #Hprot". iModIntro. iExact "Hprot". + } + iIntros (?) "(-> & %&%&%& #Hfread & %Hfread_tid & Hr1 & Hannot & (% & % & #Hwrite) & #Hrf & Hlpo & _ & Hctrl & Hrmw & _)". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + + iDestruct (lpo_to_po with "Hlpo") as "[Hlpo #Hpo]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr2 Hlpo Hannot Hctrl Hrmw Hllwd]"). + { + iApply (iload_pln (λ e v', ⌜v = (BV 64 1)⌝ -∗ ⌜v' = (BV 64 42)⌝)%I {[eid]} {[eid := prot flag v eid']} with "[$Hr2 $Hlpo $Hctrl $Hrmw $Hllwd Hannot]"). iFrame "∗#". + { rewrite big_sepM_singleton big_sepS_singleton. by iFrame "#". } + iIntros (?). iSplitR. + - iIntros "HN HPo". rewrite big_sepM_singleton big_sepS_singleton. + iApply (acq_po_is_lob with "[Hfread] HPo"). iDestruct (event_node with "Hfread") as "$". + - iIntros (??) "#Hdread % #HPo (% &% &#Hwrite') #Hrf' Hannot". rewrite big_sepM_singleton big_sepS_singleton. + iIntros "#Hdata". iModIntro. iIntros (->). + rewrite /prot /= /data_prot /flag_prot. + iDestruct "Hdata" as "[(% & %)|%Hdata]"; [done|]. + iDestruct (write_of_read with "Hfread Hrf") as "(% & % & Hfw)". + iDestruct "Hannot" as "[%Hannot|Hannot]". + { iDestruct (initial_write_zero _ _ _ _ _ Hannot with "Hfw") as "%F". contradict F. bv_solve. } + iClear "Hfw". + iDestruct "Hannot" as "(%d & %Hfwrite_tid & %Hd_tid & #Hsendpo & #Hd & #Hfw)". + iDestruct (initial_write_co with "Hwrite' Hd") as "Hco"; [done| |]. + { rewrite Hd_tid. pose proof tid_nz_nz. lia. } + iDestruct (po_rel_is_lob with "Hsendpo [Hfw]") as "Hsendob". + { iDestruct (event_node with "Hfw") as "$". } + iDestruct (acq_po_is_lob with "[Hfread] HPo") as "Hreadob". + { iDestruct (event_node with "Hfread") as "$". } + iDestruct (rf_co_to_fr with "Hrf' Hco") as "Hfr". + iDestruct (rfe_is_ob with "Hrf") as "Hob2"; [lia|]. + iDestruct (fre_is_ob with "Hfr") as "Hob4"; [lia|]. + iDestruct (lob_is_ob with "Hsendob") as "Hob1". + iDestruct (lob_is_ob with "Hreadob") as "Hob3". + iDestruct (ob_trans with "Hob1 Hob2") as "Hob". + iDestruct (ob_trans with "Hob Hob3") as "Hob'". + iDestruct (ob_trans with "Hob' Hob4") as "Hob''". + iDestruct (ob_acyclic with "Hob''") as "[]". + } + iIntros (?) "(-> & % & % & % & Hdread & % & Hr2 & Hdannot & _ & _ & Hlpo & _ & Hctrl & Hrmw & _)". + subst. clear G. assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8200)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ {[eid0 := _]} with "[Hdannot]"); auto. + { simpl. rewrite dom_singleton_L. set_solver. } + { rewrite big_sepM_singleton. iExact "Hdannot". } + rewrite big_sepM_singleton. + iIntros "% !>". iSplit;first done. + iExists _, _. iFrame. auto. + Qed. + +End proof. diff --git a/theories/examples/mp/rel_addr.v b/theories/examples/mp/rel_addr.v new file mode 100644 index 0000000..c9fe128 --- /dev/null +++ b/theories/examples/mp/rel_addr.v @@ -0,0 +1,177 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +From self.low Require Export instantiation. +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 0x10). +Definition flag := (BV 64 0x18). + +Definition data_write : Instruction := + (IStore AS_normal AV_plain "r0" (AEval (BV 64 42)) (AEval data)). +Definition flag_write : Instruction := + (IStore AS_rel_or_acq AV_plain "r0" (AEval (BV 64 1)) (AEval flag)). + +Definition flag_read kind:= + (ILoad kind AV_plain "r1" (AEval flag)). +Definition dep_data_read := + (ILoad AS_normal AV_plain "r2" (AEbinop AOplus (AEval data) (AEbinop AOminus (AEreg "r1") (AEreg "r1")))). + +Section proof. + Context `{AAIrisG}. + + Context (tid1 tid2: Tid). + Context (Htid_ne :tid1 ≠ tid2). + + Definition data_prot (v : Val) (e : Eid) : iProp Σ := + (⌜v= (BV 64 42)⌝ ∗ ⌜EID.tid e = tid1⌝) ∨ ⌜EID.tid e = 0%nat⌝. + + Definition flag_prot (e : Eid) : iProp Σ := + ⌜EID.tid e = 0%nat⌝ + ∨ ∃ d, + ⌜EID.tid e = tid1 ⌝ ∗ ⌜EID.tid d = tid1⌝ ∗ + d -{Edge.Po}> e ∗ + d -{E}> (Event.W AS_normal AV_plain data (BV 64 42)) ∗ + e -{E}> (Event.W AS_rel_or_acq AV_plain flag (BV 64 1)). + + Definition send_instrs : iProp Σ := + (BV 64 0x1000) ↦ᵢ data_write ∗ + (BV 64 0x1004) ↦ᵢ flag_write ∗ + (BV 64 0x1008) ↦ᵢ -. + + Definition dep_receive_instrs : iProp Σ := + (BV 64 0x2000) ↦ᵢ flag_read AS_normal ∗ + (BV 64 0x2004) ↦ᵢ dep_data_read ∗ + (BV 64 0x2008) ↦ᵢ -. + + Definition protocol : UserProt := + Build_UserProt _ _(λ a v e, + if bool_decide (a = data) then data_prot v e + else if bool_decide (a = flag) then flag_prot e + else (⌜EID.tid e = 0%nat⌝)%I + ). + + #[local] Instance userprot : UserProt := protocol. + + Context `{!AAThreadG} `{ThreadGN}. + + (* NOTE: the sender proof is identical to that in [rel_acq.v] *) + Lemma send ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + last_local_write tid1 data None -∗ + last_local_write tid1 flag None -∗ + send_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid1 {{ λ lts', ⌜lts' = (LTSI.Done, (BV 64 0x1008))⌝}}. + Proof. + iIntros "Hpo_src Hctrl_src Hlocalw_data Hlocalw_flag Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_data]"). + { + iApply (istore_pln (λ _, emp)%I ∅ ∅ with "[$Hpo_src $Hctrl_src $Hlocalw_data]"). iFrame "#∗". + rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitL. + - iIntros "_ _ _";done. + - iIntros "#HE % #Hpo _". iModIntro. iSplit;first done. simpl. rewrite /data_prot. iLeft;done. + } + iIntros (?) "(-> &[% (#Hwrite&%Htid1&Hpo&_&Hlocal&Hctrl&HeidP)])". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv) by bv_solve. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_flag Hwrite Hpo Hctrl HeidP]"). + { + iDestruct (lpo_to_po with "Hpo") as "[Hlpo #Hpo]". + iApply (istore_rel emp {[eid := emp%I]}). iFrame "#∗". + + iSplit;first rewrite big_sepM_singleton //. + iSplitL;first rewrite big_sepM_singleton //. + + iIntros (eid') "#Hwrite' %Htid2 #Hpo' HeidP'". + iModIntro. iSplit;first done. iModIntro. + iRight. iExists eid. rewrite big_sepM_singleton. by iFrame "#". + } + iIntros (?) "(-> &[% (?&?&?)])". + clear G. assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4104)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ ∅); auto. rewrite dom_empty_L //. + Qed. + + Lemma receive_addr ctrl : + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + None -{Rmw}> -∗ + last_local_write tid2 data None -∗ + last_local_write tid2 flag None -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + dep_receive_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid2 {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x2008))⌝ ∗ + ∃ r1 r2, "r1" ↦ᵣ r1 ∗ "r2" ↦ᵣ r2 ∗ + (⌜r1.(reg_val) = (BV 64 1)⌝ -∗ ⌜r2.(reg_val) = (BV 64 42)⌝) + }}. + Proof. + iIntros "Hlpo Hctrl Hrmw Hllwd Hllwf [% Hr1] [% Hr2] Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hlpo Hctrl Hrmw Hllwf]"). + { + iApply (iload_pln _ ∅ ∅ with "[$Hr1 $Hlpo $Hctrl $Hrmw $Hllwf]"). iFrame "∗#". + rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _";done. + - iIntros (??) "_ _ _ _ _ _ #Hprot". iModIntro. iExact "Hprot". + } + iIntros (?) "(-> & %&%&%& #Hfread & %Hfread_tid & Hr1 & Hannot & (% & % & #Hwrite) & #Hrf & Hlpo & _ & Hctrl & Hrmw & _)". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + + iDestruct (lpo_to_po with "Hlpo") as "[Hlpo #Hpo]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hr2 Hlpo Hannot Hctrl Hrmw Hllwd]"). + { + iApply (iload_pln_fake_addr (λ e v', ⌜v = (BV 64 1)⌝ -∗ ⌜v' = (BV 64 42)⌝)%I with "[$Hr2 Hr1 $Hlpo $Hctrl $Hrmw $Hllwd Hannot]"). iFrame "∗#". + iIntros (???) "#Hdread % (% &% &#Hwrite') #Hrf' #Haddr Hannot #Hdata". iModIntro. iIntros (->). + rewrite /prot /= /data_prot /flag_prot. + iDestruct "Hdata" as "[(% & %)|%Hdata]"; [done|]. + iDestruct (write_of_read with "Hfread Hrf") as "(% & % & Hfw)". + iDestruct "Hannot" as "[%Hannot|Hannot]". + { iDestruct (initial_write_zero _ _ _ _ _ Hannot with "Hfw") as "%F". contradict F. bv_solve. } + iClear "Hfw". + iDestruct "Hannot" as "(%d & %Hfwrite_tid & %Hd_tid & #Hsendpo & #Hd & #Hfw)". + iDestruct (initial_write_co with "Hwrite' Hd") as "Hco"; [done| |]. + { rewrite Hd_tid. pose proof tid_nz_nz. lia. } + iDestruct (po_rel_is_lob with "Hsendpo [Hfw]") as "Hsendob". + { iDestruct (event_node with "Hfw") as "$". } + iDestruct (addr_is_lob with "Haddr") as "Hreadob". + iDestruct (rf_co_to_fr with "Hrf' Hco") as "Hfr". + iDestruct (rfe_is_ob with "Hrf") as "Hob2"; [lia|]. + iDestruct (fre_is_ob with "Hfr") as "Hob4"; [lia|]. + iDestruct (lob_is_ob with "Hsendob") as "Hob1". + iDestruct (lob_is_ob with "Hreadob") as "Hob3". + iDestruct (ob_trans with "Hob1 Hob2") as "Hob". + iDestruct (ob_trans with "Hob Hob3") as "Hob'". + iDestruct (ob_trans with "Hob' Hob4") as "Hob''". + iDestruct (ob_acyclic with "Hob''") as "[]". + } + iIntros (?) "(-> & Hr1 & % & % & % & Hdread & % & Hr2 & Hdannot & _ & _ & Hlpo & Hctrl & Hrmw)". + subst. clear G. assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8200)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ {[eid0 := _ ]} with "[Hdannot]"); auto. + { rewrite dom_singleton_L //. set_solver. } + { rewrite big_sepM_singleton. iFrame. } + iIntros "? !>". rewrite big_sepM_singleton. + iSplit;first done. + iExists _, _. iFrame. done. + Qed. + +End proof. diff --git a/theories/examples/mp/rel_ctrl.v b/theories/examples/mp/rel_ctrl.v new file mode 100644 index 0000000..ad4e8a1 --- /dev/null +++ b/theories/examples/mp/rel_ctrl.v @@ -0,0 +1,240 @@ + +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +From self.low Require Export instantiation. +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 0x10). +Definition flag := (BV 64 0x18). + +Definition data_write : Instruction := + (IStore AS_normal AV_plain "r0" (AEval (BV 64 42)) (AEval data)). +Definition flag_write : Instruction := + (IStore AS_rel_or_acq AV_plain "r0" (AEval (BV 64 1)) (AEval flag)). + +Definition flag_read kind:= + (ILoad kind AV_plain "r1" (AEval flag)). +Definition receive_branch:= + (IBne (AEbinop AOminus (AEreg "r1") (AEval (BV 64 1))) (BV 64 0x3000)). +Definition isb_instr := IIsb. +Definition data_read := + (ILoad AS_normal AV_plain "r2" (AEval data)). + +Section proof. + Context `{AAIrisG}. + + Context (tid1 tid2: Tid). + Context (Htid_ne :tid1 ≠ tid2). + + Definition data_prot (v : Val) (e : Eid) : iProp Σ := + (⌜v= (BV 64 42)⌝ ∗ ⌜EID.tid e = tid1⌝) ∨ ⌜EID.tid e = 0%nat⌝. + + Definition flag_prot (e : Eid) : iProp Σ := + ⌜EID.tid e = 0%nat⌝ + ∨ ∃ d, + ⌜EID.tid e = tid1 ⌝ ∗ ⌜EID.tid d = tid1⌝ ∗ + d -{Edge.Po}> e ∗ + d -{E}> (Event.W AS_normal AV_plain data (BV 64 42)) ∗ + e -{E}> (Event.W AS_rel_or_acq AV_plain flag (BV 64 1)). + + Definition send_instrs : iProp Σ := + (BV 64 0x1000) ↦ᵢ data_write ∗ + (BV 64 0x1004) ↦ᵢ flag_write ∗ + (BV 64 0x1008) ↦ᵢ -. + + Definition receive_instrs : iProp Σ := + (BV 64 0x2000) ↦ᵢ flag_read AS_rel_or_acq ∗ + (BV 64 0x2004) ↦ᵢ receive_branch ∗ + (BV 64 0x2008) ↦ᵢ isb_instr ∗ + (BV 64 0x200c) ↦ᵢ data_read ∗ + (BV 64 0x2010) ↦ᵢ - ∗ + (BV 64 0x3000) ↦ᵢ -. + + Definition protocol : UserProt := + Build_UserProt _ _(λ a v e, + if bool_decide (a = data) then data_prot v e + else if bool_decide (a = flag) then flag_prot e + else (⌜EID.tid e = 0%nat⌝)%I + ). + + #[local] Instance userprot : UserProt := protocol. + + Context `{!AAThreadG} `{ThreadGN}. + + (* Note this is the same proof as in rel_acq *) + Lemma send ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + last_local_write tid1 data None -∗ + last_local_write tid1 flag None -∗ + send_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid1 {{ λ lts', ⌜lts' = (LTSI.Done, (BV 64 0x1008))⌝}}. + Proof. + iIntros "Hpo_src Hctrl_src Hlocalw_data Hlocalw_flag Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_data]"). + { + iApply (istore_pln (λ _, emp)%I ∅ ∅ with "[$Hpo_src $Hctrl_src $Hlocalw_data]"). iFrame "#∗". + rewrite big_sepS_empty big_sepM_empty //. + + iIntros (?). iSplitL. + - iIntros "_ _ _". done. + - iIntros "#HE % #Hpo _". iModIntro. iSplit;first done. simpl. rewrite /data_prot. iLeft;done. + } + iIntros (?) "(-> &[% (#Hwrite&%Htid1&Hpo&_&Hlocal&Hctrl&HeidP)])". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv) by bv_solve. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_flag Hwrite Hpo Hctrl HeidP]"). + { + iDestruct (lpo_to_po with "Hpo") as "[Hlpo #Hpo]". + iApply (istore_rel emp {[eid := emp%I]}). iFrame "#∗". + + iSplit;first rewrite big_sepM_singleton //. + iSplitL;first rewrite big_sepM_singleton //. + + iIntros (eid') "#Hwrite' %Htid2 #Hpo' HeidP'". + iModIntro. iSplit;first done. iModIntro. + iRight. iExists eid. rewrite big_sepM_singleton. by iFrame "#". + } + iIntros (?) "(-> &[% (?&?&?)])". + clear G. assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4104)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ ∅); auto. rewrite dom_empty_L //. + Qed. + + Definition receive : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + last_local_write tid2 data None -∗ + last_local_write tid2 flag None -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + receive_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid2 {{ λ lts', + ∃ r1 r2, "r1" ↦ᵣ r1 ∗ "r2" ↦ᵣ r2 ∗ + (⌜lts' = (LTSI.Done, (BV 64 0x2010))⌝ ∗ ⌜r2.(reg_val) = (BV 64 42)⌝ + ∨ + ⌜lts' = (LTSI.Done, (BV 64 0x3000))⌝) + }}. + Proof. + iIntros "Hlpo Hctrl Hrmw Hllwd Hllwf [% Hr1] [% Hr2] Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #? & #? & #? & #?)". + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hlpo Hctrl Hrmw Hllwf]"). + { + iApply (iload_pln _ ∅ ∅ with "[$Hr1 $Hlpo $Hctrl $Hrmw $Hllwf]"). iFrame "∗#". + rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _". rewrite big_sepM_empty //. + - iIntros (??) "_ _ _ _ _ _ #Hprot". iModIntro. iExact "Hprot". + } + iIntros (?) "(-> & %eid_fr & %eid_fw & % & #Hfread & %Hfread_tid & Hr1 & Hannot & (% & % & #Hfwrite) & #Hrf & Hlpo & _ & Hctrl & Hrmw & _)". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + + iDestruct (lpo_to_po with "Hlpo") as "[Hlpo #Hpo]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hctrl]"). + { + iApply (ibne {["r1" := {| reg_val := v; reg_dep := {[eid_fr]} |} ]} with "[] [Hctrl]" ); [ | | iFrame "#" | iFrame | ]. + + set_solver. + + unfold eval_ae_val. + rewrite lookup_insert. + simpl. + reflexivity. + + by rewrite big_sepM_singleton. + } + iIntros (?). + subst. simpl. + iIntros "(Hr1 & Hctrl & Hsplit)". + iEval (rewrite (big_sepM_singleton)) in "Hr1". + iEval (rewrite (@map_fold_singleton _ _ _ _ _ _ _ _ _ _ _ RegVal) /=) in "Hctrl". + iDestruct "Hsplit" as "[(-> & %Hf)|(-> & Hf)]"; first last. + { + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 12288)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ ∅); auto. { rewrite dom_empty_L //. } + iIntros "_ !>". + iExists {| reg_val := v; reg_dep := {[eid_fr]} |}, rv0; iFrame. + by iRight. + } + + clear G. assert (G: ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hctrl Hlpo]"). + { + iApply (iisb with "[] [Hlpo]"); iFrame "#∗". + } + + iIntros (?) "(-> & %eid_isb & #Hisb & #Hpo1 & Hlpo & #Hctrl1 & Hctrl)". + + iDestruct (lpo_to_po with "Hlpo") as "[Hlpo #Hpo_isb]". + + clear G. assert (G: ((BV 64 8200) `+Z` 4 = (BV 64 8204))%bv); [bv_solve|]. rewrite G. + iEval (simpl) in "Hpo1". + iEval (rewrite !union_empty_r_L) in "Hctrl1". + iEval (rewrite big_sepS_singleton) in "Hctrl1". + + iDestruct (event_node with "Hfread") as "?". + iDestruct (event_node with "Hisb") as "?". + iApply sswpi_wpi. iApply (sswpi_mono with "[-Hr1]"). + { + iApply (iload_pln (λ e v', ⌜v' = (BV 64 42)⌝)%I {[eid_isb]} {[eid_fr := prot flag v eid_fw]} with "[$Hr2 $Hlpo $Hctrl $Hrmw $Hllwd Hannot]"). + + iFrame "#∗". iSplitR. { by rewrite big_sepS_singleton. } + by rewrite big_sepM_singleton. + + iIntros (eid). iSplitR. + - iIntros "#HN #HPo". rewrite big_sepM_singleton big_sepS_singleton. + iApply (ctrl_isb_po_is_lob eid_fr eid_isb eid); iFrame "#". + - iIntros (eid_data_w v') "#Heid %Htid #HPo (% & % & #Hdata_write) #Hrf_data Hannot". + rewrite big_sepM_singleton big_sepS_singleton. + iIntros "#Hdata". iModIntro. + rewrite /prot /= /data_prot /flag_prot. + iDestruct "Hdata" as "[(% & %)|%Hdata]"; [done|]. + iDestruct (write_of_read with "Hfread Hrf") as "(% & % & Hfw)". + iDestruct "Hannot" as "[%Hannot|Hannot]". + { iDestruct (initial_write_zero _ _ _ _ _ Hannot with "Hfw") as "%F". rewrite -F in Hf. contradict Hf. unfold Val, AAArch.val, AAval. bv_solve. } + iClear "Hfw". + iDestruct "Hannot" as "(%d & %Hfwrite_tid & %Hd_tid & #Hsendpo & #Hd & #Hfw)". + iDestruct (initial_write_co with "Hdata_write Hd") as "Hco"; [ done | | ]. + { rewrite Hd_tid. pose proof tid_nz_nz. lia. } + iDestruct (po_rel_is_lob with "Hsendpo [Hfw]") as "Hsendob". + { iDestruct (event_node with "Hfw") as "$". } + iDestruct (event_node with "Heid") as "#Heid'". + iDestruct (ctrl_isb_po_is_lob eid_fr eid_isb eid with "[] [] [] [] []") as "Hreadob"; iFrame "#". + iDestruct (rf_co_to_fr with "Hrf_data Hco") as "Hfr". + iDestruct (rfe_is_ob with "Hrf") as "Hob2"; [lia|]. + iDestruct (fre_is_ob with "Hfr") as "Hob4"; [lia|]. + iDestruct (lob_is_ob with "Hsendob") as "Hob1". + iDestruct (lob_is_ob with "Hreadob") as "Hob3". + iDestruct (ob_trans with "Hob1 Hob2") as "Hob". + iDestruct (ob_trans with "Hob Hob3") as "Hob'". + iDestruct (ob_trans with "Hob' Hob4") as "Hob''". + iDestruct (ob_acyclic with "Hob''") as "[]". + } + + iIntros (?) "(-> & % & % & % & Hdread & % & Hr2 & Hdannot & _ & _ & Hlpo & _ & Hctrl & Hrmw & _)". + subst. assert (G'': ((BV 64 8204) `+Z` 4 = (BV 64 8208))%bv); [bv_solve|]. rewrite G''. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8208)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ {[eid := _]} with "[Hdannot]"); auto. + { simpl. rewrite dom_singleton_L. set_solver. } + { rewrite big_sepM_singleton. iExact "Hdannot". } + rewrite big_sepM_singleton. + iIntros "% !>". + iExists {| reg_val := v; reg_dep := {[eid_fr]} |}, {| reg_val := v0; reg_dep := {[eid]} |}. + iFrame. + iLeft. + iSplit;first done. + by rewrite H4. + Qed. + +End proof. diff --git a/theories/examples/mp/rel_dmb.v b/theories/examples/mp/rel_dmb.v new file mode 100644 index 0000000..e0ed9aa --- /dev/null +++ b/theories/examples/mp/rel_dmb.v @@ -0,0 +1,197 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +From self.low Require Export instantiation. +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition data := (BV 64 0x10). +Definition flag := (BV 64 0x18). + +Definition data_write : Instruction := + (IStore AS_normal AV_plain "r0" (AEval (BV 64 42)) (AEval data)). +Definition flag_write : Instruction := + (IStore AS_rel_or_acq AV_plain "r0" (AEval (BV 64 1)) (AEval flag)). + +Definition flag_read kind:= + (ILoad kind AV_plain "r1" (AEval flag)). +Definition receive_barrier:= + (IDmb AAArch.Sy). +Definition data_read := + (ILoad AS_normal AV_plain "r2" (AEval data)). + +Section proof. + Context `{AAIrisG}. + + Context (tid1 tid2: Tid). + Context (Htid_ne :tid1 ≠ tid2). + + Definition data_prot (v : Val) (e : Eid) : iProp Σ := + (⌜v= (BV 64 42)⌝ ∗ ⌜EID.tid e = tid1⌝) ∨ ⌜EID.tid e = 0%nat⌝. + + Definition flag_prot (e : Eid) : iProp Σ := + ⌜EID.tid e = 0%nat⌝ + ∨ ∃ d, + ⌜EID.tid e = tid1 ⌝ ∗ ⌜EID.tid d = tid1⌝ ∗ + d -{Edge.Po}> e ∗ + d -{E}> (Event.W AS_normal AV_plain data (BV 64 42)) ∗ + e -{E}> (Event.W AS_rel_or_acq AV_plain flag (BV 64 1)). + + Definition send_instrs : iProp Σ := + (BV 64 0x1000) ↦ᵢ data_write ∗ + (BV 64 0x1004) ↦ᵢ flag_write ∗ + (BV 64 0x1008) ↦ᵢ -. + + Definition receive_instrs : iProp Σ := + (BV 64 0x2000) ↦ᵢ flag_read AS_rel_or_acq ∗ + (BV 64 0x2004) ↦ᵢ receive_barrier ∗ + (BV 64 0x2008) ↦ᵢ data_read ∗ + (BV 64 0x200c) ↦ᵢ -. + + Definition protocol : UserProt := + Build_UserProt _ _(λ a v e, + if bool_decide (a = data) then data_prot v e + else if bool_decide (a = flag) then flag_prot e + else (⌜EID.tid e = 0%nat⌝)%I + ). + + #[local] Instance userprot : UserProt := protocol. + + Context `{!AAThreadG} `{ThreadGN}. + + (* Note this is the same proof as in rel_acq *) + Lemma send ctrl: + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + last_local_write tid1 data None -∗ + last_local_write tid1 flag None -∗ + send_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ tid1 {{ λ lts', ⌜lts' = (LTSI.Done, (BV 64 0x1008))⌝}}. + Proof. + iIntros "Hpo_src Hctrl_src Hlocalw_data Hlocalw_flag Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocalw_data]"). + { + iApply (istore_pln (λ _, emp)%I ∅ ∅ with "[$Hpo_src $Hctrl_src $Hlocalw_data]"). iFrame "#∗". + rewrite big_sepS_empty big_sepM_empty //. + + iIntros (?). iSplitL. + - iIntros "_ _ _". done. + - iIntros "#HE % #Hpo _". iModIntro. iSplit;first done. simpl. rewrite /data_prot. iLeft;done. + } + iIntros (?) "(-> &[% (#Hwrite&%Htid1&Hpo&_&Hlocal&Hctrl&HeidP)])". + assert (G: ((BV 64 4096) `+Z` 4 = (BV 64 4100))%bv) by bv_solve. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_flag Hwrite Hpo Hctrl HeidP]"). + { + iDestruct (lpo_to_po with "Hpo") as "[Hlpo #Hpo]". + iApply (istore_rel emp {[eid := emp%I]}). iFrame "#∗". + + iSplit;first rewrite big_sepM_singleton //. + iSplitL;first rewrite big_sepM_singleton //. + + iIntros (eid') "#Hwrite' %Htid2 #Hpo' HeidP'". + iModIntro. iSplit;first done. iModIntro. + iRight. iExists eid. rewrite big_sepM_singleton. by iFrame "#". + } + iIntros (?) "(-> &[% (?&?&?)])". + clear G. assert (G: ((BV 64 4100) `+Z` 4 = (BV 64 4104))%bv); [bv_solve|]. rewrite G. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 4104)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ ∅); auto. rewrite dom_empty_L //. + Qed. + + Definition receive ctrl : + None -{LPo}> -∗ + ctrl -{Ctrl}> -∗ + None -{Rmw}> -∗ + last_local_write tid2 data None -∗ + last_local_write tid2 flag None -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + receive_instrs -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ tid2 {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x200c))⌝ ∗ + ∃ r1 r2, "r1" ↦ᵣ r1 ∗ "r2" ↦ᵣ r2 ∗ + (⌜r1.(reg_val) = (BV 64 1)⌝ -∗ ⌜r2.(reg_val) = (BV 64 42)⌝) + }}. + Proof. + iIntros "Hlpo Hctrl Hrmw Hllwd Hllwf [% Hr1] [% Hr2] Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #? & #?)". + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr1 Hlpo Hctrl Hrmw Hllwf]"). + { + iApply (iload_pln _ ∅ ∅ with "[$Hr1 $Hlpo $Hctrl $Hrmw $Hllwf]"). iFrame "∗#". + rewrite big_sepM_empty big_sepS_empty //. + + iIntros (?). iSplitR. + - iIntros "_ _". rewrite big_sepM_empty //. + - iIntros (??) "_ _ _ _ _ _ #Hprot". iModIntro. iExact "Hprot". + } + iIntros (?) "(-> & %eid_fr & %eid_fw & % & #Hfread & %Hfread_tid & Hr1 & Hannot & (% & % & #Hfwrite) & #Hrf & Hlpo & _ & Hctrl & Hrmw & _)". + assert (G: ((BV 64 8192) `+Z` 4 = (BV 64 8196))%bv); [bv_solve|]. rewrite G. + + iDestruct (lpo_to_po with "Hlpo") as "[Hlpo #Hpo]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlpo]"). + { + iApply idmb; [iFrame "#" | iExact "Hlpo"]. + } + + iIntros (?) "(-> & %eid_dmb & #Hdmb & #Hpo1 & Hlpo)". + simpl. + assert (G' : ((BV 64 8196) `+Z` 4 = (BV 64 8200))%bv); [bv_solve |]. rewrite G'. + + iClear "Hpo". + iDestruct (lpo_to_po with "Hlpo") as "[Hlpo #Hpo]". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hr2 Hlpo Hannot Hctrl Hrmw Hllwd]"). + { + iApply (iload_pln (λ e v', ⌜v = (BV 64 1)⌝ -∗ ⌜v' = (BV 64 42)⌝)%I {[eid_dmb]} {[eid_fr := prot flag v eid_fw]} with "[$Hr2 $Hlpo $Hctrl $Hrmw $Hllwd Hannot]"). iFrame "∗#". + { rewrite big_sepM_singleton big_sepS_singleton. iFrame "#∗". } + iIntros (?). iSplitR. + - iIntros "HN HPo". rewrite big_sepM_singleton big_sepS_singleton. + iApply (po_dmbsy_po_is_lob with "Hpo1 [Hdmb] HPo"). + { iDestruct (event_node with "Hdmb") as "$". } + - iIntros (??) "#Hdread % #HPo (% &% &#Hwrite') #Hrf' Hannot". rewrite big_sepM_singleton big_sepS_singleton. + iIntros "#Hdata". iModIntro. iIntros (->). + rewrite /prot /= /data_prot /flag_prot. + iDestruct "Hdata" as "[(% & %)|%Hdata]"; [done|]. + iDestruct (write_of_read with "Hfread Hrf") as "(% & % & Hfw)". + iDestruct "Hannot" as "[%Hannot|Hannot]". + { iDestruct (initial_write_zero _ _ _ _ _ Hannot with "Hfw") as "%F". contradict F. bv_solve. } + iClear "Hfw". + iDestruct "Hannot" as "(%d & %Hfwrite_tid & %Hd_tid & #Hsendpo & #Hd & #Hfw)". + iDestruct (initial_write_co with "Hwrite' Hd") as "Hco"; [done| |]. + { rewrite Hd_tid. pose proof tid_nz_nz. lia. } + iDestruct (po_rel_is_lob with "Hsendpo [Hfw]") as "Hsendob". + { iDestruct (event_node with "Hfw") as "$". } + iDestruct (po_dmbsy_po_is_lob with "Hpo1 [Hdmb] HPo") as "Hreadob". + { iDestruct (event_node with "Hdmb") as "$". } + iDestruct (rf_co_to_fr with "Hrf' Hco") as "Hfr". + iDestruct (rfe_is_ob with "Hrf") as "Hob2"; [lia|]. + iDestruct (fre_is_ob with "Hfr") as "Hob4"; [lia|]. + iDestruct (lob_is_ob with "Hsendob") as "Hob1". + iDestruct (lob_is_ob with "Hreadob") as "Hob3". + iDestruct (ob_trans with "Hob1 Hob2") as "Hob". + iDestruct (ob_trans with "Hob Hob3") as "Hob'". + iDestruct (ob_trans with "Hob' Hob4") as "Hob''". + iDestruct (ob_acyclic with "Hob''") as "[]". + } + iIntros (?) "(-> & % & % & % & Hdread & % & Hr2 & Hdannot & _ & _ & Hlpo & _ & Hctrl & Hrmw & _)". + subst. assert (G'': ((BV 64 8200) `+Z` 4 = (BV 64 8204))%bv); [bv_solve|]. rewrite G''. + + iApply sswpi_wpi. iApply (sswpi_mono _ _ _ (λ s', ⌜s' = (LTSI.Done, BV 64 8204)⌝)%I). + { by iApply idone. } + iIntros (? ->). iApply wpi_terminated. iApply (inst_post_lifting_lifting _ _ _ {[eid := _]} with "[Hdannot]"); auto. + { simpl. rewrite dom_singleton_L. set_solver. } + { rewrite big_sepM_singleton. iExact "Hdannot". } + rewrite big_sepM_singleton. + iIntros "% !>". iSplit;first done. + iExists _, _. iFrame. auto. + Qed. +End proof. diff --git a/theories/examples/try_lock/implementation.v b/theories/examples/try_lock/implementation.v new file mode 100644 index 0000000..acc3dd1 --- /dev/null +++ b/theories/examples/try_lock/implementation.v @@ -0,0 +1,252 @@ +From stdpp.unstable Require Export bitvector. +From stdpp.unstable Require Import bitvector_tactics. + +From iris.proofmode Require Import tactics. +From iris.algebra Require Import excl. + +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +Import uPred. + +Definition locked := (BV 64 1). +Definition unlocked := (BV 64 0). + +Notation read_xcl reg addr := (ILoad AS_normal AV_exclusive reg (AEval addr)). +Notation write_xcl reg_res addr := (IStore AS_rel_or_acq AV_exclusive reg_res (AEval locked) (AEval addr)). +Notation write_rel reg_res addr := (IStore AS_rel_or_acq AV_plain reg_res (AEval unlocked) (AEval addr)). +Notation dmb_sy := (IDmb AAArch.Sy). +Notation bne reg addr:= (IBne (AEreg reg) addr). + +(* The protocol at the given location is used to implement a try-lock *) +Class IsLockAt `{CMRA Σ} `{!AABaseG} `{!invGS_gen HasNoLc Σ} `{!UserProt} (a : Addr) (P : Eid -> iProp Σ) := + { + lock_prot_def val eid := (if bool_decide (val = unlocked) then excl_inv eid P + else + if bool_decide (val = locked) then True + else False)%I; + lock_prot_spec : forall (val:Val) eid, prot a val eid ⊣⊢ lock_prot_def val eid ; + }. + + +Section implementation. + Context `{AAIrisG} `{!AAThreadG} `{ThreadGN}. + Context `{!UserProt}. + Context (lock_addr : Addr). + Context `{!IsLockAt lock_addr P}. + + Context (inst_addr_start : Addr). + Context (r1 r2 : RegName). + + (* the aquaire implmentation *) + (* XXX: do we need release? *) + Definition instrs_aquire : iProp Σ := + (inst_addr_start) ↦ᵢ read_xcl r1 lock_addr ∗ + (inst_addr_start `+Z` 4)%bv ↦ᵢ bne r1 (inst_addr_start `+Z` 16)%bv ∗ + (inst_addr_start `+Z` 8)%bv ↦ᵢ write_xcl r2 lock_addr ∗ + (inst_addr_start `+Z` 12)%bv ↦ᵢ dmb_sy. + + Definition acquire {tid Φ} P': + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + (∃ rv, r1 ↦ᵣ rv) -∗ + (∃ rv, r2 ↦ᵣ rv) -∗ + last_local_write tid lock_addr None -∗ + instrs_aquire -∗ + (∀ eid, P eid ==∗ P' eid) -∗ + (* continuation *) + ( + ( + ∃ eid_xr, + ∃ v1 v2 d, r1 ↦ᵣ (mk_regval v1 {[eid_xr]}) ∗ r2 ↦ᵣ (mk_regval v2 d) ∗ + ∃ po_src ctrl_src rmw_src, po_src -{LPo}> ∗ ctrl_src -{Ctrl}> ∗ rmw_src -{Rmw}> ∗ + ( + (⌜v1 = unlocked ∧ v2 = locked⌝) -∗ + ( + ⌜d = ∅⌝ ∗ + ∃ eid_lw eid_xw eid_b, + ⌜po_src = (Some eid_b)⌝ ∗ + ⌜ctrl_src = {[eid_xr]}⌝ ∗ + ⌜rmw_src = Some eid_xr⌝ ∗ + last_local_write tid lock_addr (Some eid_xw) ∗ + eid_xw ↦ₐ P' eid_lw ∗ + eid_lw -{Edge.Ob}> eid_xw ∗ + eid_b -{E}> (Event.B (AAArch.DMB AAArch.Sy)) ∗ + eid_xw -{Edge.Po}> eid_b + ) + ) + ) -∗ + WPi (LTSI.Normal , (inst_addr_start `+Z` 16)%bv) @ tid {{ lts, Φ lts }} + )-∗ + WPi (LTSI.Normal, inst_addr_start) @ tid + {{ λ lts', Φ lts'}}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw [% Hr1] [% Hr2] Hlocal Hinstrs Himpl Hcont". + iDestruct "Hinstrs" as "(#? & #? & #? & #?)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocal Hrmw Hr1]"). + { + iApply (iload_excl (λ eid_w v, lock_prot_def v eid_w)%I ∅ ∅ with "[-] []"). + iFrame "#∗". rewrite big_sepM_empty big_sepS_empty //. + + iIntros. iSplitL. + - iIntros "_ _". rewrite big_sepM_empty //. + - iIntros (??) "_ _ _ _ _ _ #H !>". + by iApply lock_prot_spec. + } + iIntros (?) "(->&(%&%&%&(#HRX&%&Hr1&Hna&_&#Hrfe&#Hext&Hpo_src&Hctrl_src&Hrmw&Hlocal)))". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hctrl_src Hr1]"). + { + iApply (ibne {[r1 := {| reg_val := v; reg_dep := {[eid]} |}]} with "[] Hctrl_src [Hr1]");auto. + - simpl. rewrite dom_singleton_L. set_solver +. + - simpl. rewrite lookup_singleton /=. reflexivity. + - rewrite big_sepM_singleton. done. + } + iIntros (?) "(Hr1&Hctrl_src&Hcases)". + rewrite union_empty_r_L. rewrite map_fold_singleton /=. rewrite union_empty_r_L. + rewrite big_sepM_singleton. + + (* two cases *) + iDestruct "Hcases" as "[[-> ->]|[-> %Hlocked]]". + { + (* interesting case *) + assert ((((inst_addr_start `+Z` 4) `+Z` 4)%bv) =((inst_addr_start `+Z` 8)%bv)) as ->; [bv_solve|]. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hctrl_src Hlocal Hrmw Hr2 Hna Himpl]"). + { + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo]". + iApply (istore_rel_excl P P' emp {[eid := lock_prot_def (BV 64 0) eid']} _ _ r2 with "[- ]"). + { + iFrame "#∗". rewrite !big_sepM_singleton. iFrame "#". iFrame. + iIntros "Hlock". rewrite /lock_prot_def. + case_bool_decide. done. case_bool_decide. rewrite /locked in H6. inversion H6. + iExFalso. done. + } + { + iIntros (?) "_ _ _". + iApply fupd_mask_intro. set_solver +. + iIntros "Hmod". iNext. iMod "Hmod". iModIntro. + iSplit;first done. + iModIntro. iApply lock_prot_spec. rewrite /lock_prot_def. + case_bool_decide. inversion H5. case_bool_decide;done. + } + } + simpl. iIntros (?) "(->&(%&Hr2&Hctrl&Hrmw&Hpost))". + + assert ((((inst_addr_start `+Z` 8) `+Z` 4)%bv) =((inst_addr_start `+Z` 12)%bv)) as ->; [bv_solve|]. + destruct b_succ. + { + iDestruct "Hpost" as "(%&HXW&%Htid&#Hpo&Hpo_src&Hlocal&Hna)". + iMod (annot_split_iupd with "Hna") as "[Hna _]". + rewrite dom_singleton_L. rewrite big_sepS_singleton. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src]"). + { + iApply idmb; [iFrame "#" | iExact "Hpo_src"]. + } + + iIntros (?) "(-> & %eid_dmb & #Hdmb & #Hpo' & Hpo_src)". + simpl. + assert ((((inst_addr_start `+Z` 12) `+Z` 4)%bv) =((inst_addr_start `+Z` 16)%bv)) as ->; [bv_solve|]. + + iApply "Hcont". + iExists eid, (BV 64 0), (bool_to_bv 64 true),∅. iFrame. + iExists _,_,_. iFrame. + iIntros "_". iSplit;first done. + iExists eid', eid0, eid_dmb. iFrame. iFrame "#". + do 3 (iSplit;first done). + iDestruct "Hext" as "%". + iDestruct (rfe_is_ob with "Hrfe") as "Hob"; [lia|]. + iDestruct (po_rel_is_lob with "Hpo [HXW]") as "Hob'". + { iDestruct (event_node with "HXW") as "$". } + iDestruct (lob_is_ob with "Hob'") as "Hob'". + iApply (ob_trans with "Hob Hob'"). + } + { + iDestruct "Hpost" as "(Hpo_src&Hlocal&Hna)". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src]"). + { + iApply idmb; [iFrame "#" | iExact "Hpo_src"]. + } + + iIntros (?) "(-> & %eid_dmb & #Hdmb & #Hpo & Hpo_src)". + simpl. + assert ((((inst_addr_start `+Z` 12) `+Z` 4)%bv) =((inst_addr_start `+Z` 16)%bv)) as ->; [bv_solve|]. + + iApply "Hcont". + iExists eid, (BV 64 0), (bool_to_bv 64 false), ∅. + iFrame. iExists _,_,_. iFrame. + iIntros "[_ %HH]". + exfalso. simpl in HH. rewrite /locked in HH. simpl. + destruct (bool_decide ((bv_unsigned (bool_to_bv 64 false)) = 0)) eqn:Heqn;rewrite HH /= in Heqn;done. + } + } + + iApply "Hcont". destruct rv0. iExists eid, v, _, _. iFrame. + iExists _,_,_. iFrame. + iIntros "[%HH _]". exfalso. simpl in HH. rewrite HH in Hlocked. rewrite /unlocked in Hlocked. contradiction. + Qed. + + (* the release implmentation *) + Definition instrs_release : iProp Σ := + (inst_addr_start) ↦ᵢ write_rel "r0" lock_addr. + + Definition release {tid o_po_src o_lw o_rmw ctrl_src Φ} po_priors lob_priors R: + po_priors ⊆ dom lob_priors -> + o_po_src -{LPo}> -∗ + ([∗ set] po_src ∈ po_priors, po_src -{Po}>) -∗ + ctrl_src -{Ctrl}> -∗ + o_rmw -{Rmw}> -∗ + last_local_write tid lock_addr o_lw -∗ + instrs_release -∗ + ([∗ map] lob_pred ↦ P ∈ lob_priors, lob_pred ↦ₐ P) -∗ + ( + ∀ eid, + (eid -{N}> Edge.W AS_rel_or_acq AV_plain -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Edge.Po}> eid) -∗ + [∗ set] lob_pred ∈ (dom lob_priors ∖ po_priors), lob_pred -{Edge.Lob}> eid) ∗ + ((eid -{E}> (Event.W AS_rel_or_acq AV_plain lock_addr unlocked) ∗ + ([∗ set] po_src ∈ po_priors, po_src -{Edge.Po}> eid) ∗ + [∗ map] _ ↦ P ∈ lob_priors, P) ==∗ P eid ∗ R) + ) -∗ + (* continuation *) + ( + ( + ∃ eid, eid -{E}> (Event.W AS_rel_or_acq AV_plain lock_addr unlocked) ∗ + ⌜(EID.tid eid) = tid⌝ ∗ + Some eid -{LPo}> ∗ + ctrl_src -{Ctrl}> ∗ + last_local_write tid lock_addr (Some eid) ∗ + eid ↦ₐ R + ) -∗ + WPi (LTSI.Normal , (inst_addr_start `+Z` 4)%bv) @ tid {{ lts, Φ lts }} + )-∗ + WPi (LTSI.Normal, inst_addr_start) @ tid {{ λ lts, Φ lts}}. + Proof. + iIntros (Hsub) "Hpo_src Hpo_srcs Hctrl_src Hrmw Hlocal Hinstrs Hannot Himpl Hcont". + iDestruct "Hinstrs" as "#?". + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hpo_src Hpo_srcs Hctrl_src Hlocal Hrmw Hannot Himpl]"). + { + iApply (istore_rel_raw R po_priors lob_priors _ _ Hsub with "[-]"). + iFrame "#∗". + + iIntros (?). iDestruct ("Himpl" $! eid) as "[$ Himpl]". + iIntros "HW _ Hpo HP". + iSpecialize ("Himpl" with "[$HW $Hpo $HP]"). + iMod "Himpl" as "[HP HR]". + iDestruct (excl_inv_alloc eid P with "HP") as ">#Hexcl_inv". + iModIntro. iSplit;first done. iModIntro. + iApply lock_prot_spec. + rewrite /lock_prot_def. + case_bool_decide; done. + } + iIntros (?) "(->&(%&#HE&?&?&?&?&?))". + + iApply "Hcont". iExists _. iFrame. iFrame "#". + Qed. + +End implementation. diff --git a/theories/examples/try_lock/mutual_exclusion.v b/theories/examples/try_lock/mutual_exclusion.v new file mode 100644 index 0000000..c94f371 --- /dev/null +++ b/theories/examples/try_lock/mutual_exclusion.v @@ -0,0 +1,844 @@ +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. +From iris.algebra Require Import excl. + +From self.middle Require Import rules specialised_rules. +Require Import ISASem.SailArmInstTypes. + +From self.examples.try_lock Require Import implementation. + +Import uPred. + +(* ghost states *) +Class MeInPreG `{CMRA Σ} := { + MeOneShot :> inG Σ (csumR (dfrac_agreeR unitO) + (agreeR (leibnizO Eid))); + MeOneShot' :> inG Σ (csumR (exclR unitO) + (agreeR unitO)); + }. + +Class MeInG `{CMRA Σ} := { + MeIn :> MeInPreG; + MeOneShotNx : gname; + MeOneShotNy : gname; + MeOneShotNl : gname; + }. + +#[global] Arguments MeOneShotNx {Σ _ _}. +#[global] Arguments MeOneShotNy {Σ _ _}. +#[global] Arguments MeOneShotNl {Σ _ _}. + +Definition MeΣ : gFunctors := + #[ GFunctor (csumR (dfrac_agreeR unitO) (agreeR (leibnizO Eid))); + GFunctor (csumR (exclR unitO) (agreeR unitO))]. + +#[global] Instance subG_MeInPreG `{CMRA Σ}: subG MeΣ Σ -> MeInPreG. +Proof. solve_inG. Qed. + +Section one_shot. + Context `{CMRA Σ} `{!MeInG}. + + Definition pending_l := own MeOneShotNl (Cinl (Excl ())). + + Definition pending γ q := own γ (Cinl (to_dfrac_agree (DfracOwn q) ())). + + Lemma pending_split γ q: + pending γ q ⊣⊢ + pending γ (q/2) ∗ pending γ (q/2). + Proof. + rewrite /pending. + rewrite -own_op. + rewrite -Cinl_op. + rewrite -dfrac_agree_op. + rewrite dfrac_op_own. + rewrite Qp.div_2. done. + Qed. + + Definition shot γ (v: Eid) := own γ (Cinr (to_agree (v :(leibnizO Eid)))). + + Lemma pending_shot γ q v: pending γ q -∗ shot γ v -∗ False. + Proof. + rewrite /pending /shot. iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI //=. + Qed. + + Definition shot_l := own MeOneShotNl (Cinr (to_agree ())). + + Lemma pending_l_shot : pending_l -∗ shot_l -∗ False. + Proof. + rewrite /pending_l /shot_l. iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI //=. + Qed. + + Lemma shot_shot γ v v': shot γ v -∗ shot γ v' -∗ ⌜v = v'⌝. + Proof. + rewrite /shot. iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI //=. + iDestruct "Hvalid" as %Hvalid. + rewrite to_agree_op_valid_L in Hvalid. + done. + Qed. + + Lemma shoot γ v: pending γ 1%Qp ==∗ shot γ v. + Proof. + rewrite /pending /shot. iIntros "H". + iApply (own_update with "H"). + apply cmra_update_exclusive. + rewrite Cinr_valid. done. + Qed. + + Lemma shoot_l : pending_l ==∗ shot_l. + Proof. + rewrite /pending_l /shot_l. iIntros "H". + iApply (own_update with "H"). + apply cmra_update_exclusive. + rewrite Cinr_valid. done. + Qed. + + #[global] Instance shot_persist γ v: Persistent (shot γ v). + Proof. + rewrite /shot. apply _. + Qed. + + #[global] Instance shot_l_persist : Persistent (shot_l). + Proof. + rewrite /shot_l. apply _. + Qed. + + Definition pending_x q := pending MeOneShotNx q. + Definition shot_x v := shot MeOneShotNx v. + Definition pending_y q := pending MeOneShotNy q. + Definition shot_y v := shot MeOneShotNy v. + +End one_shot. + +Definition addr_x := (BV 64 0x10). +Definition addr_y := (BV 64 0x11). +Definition addr_lock := (BV 64 0x12). +Definition data_flag := (BV 64 0x01). +Definition data_init := (BV 64 0). + +Section mutual_exclusion. + Context `{AAIrisG} `{!AAThreadG} `{ThreadGN}. + Context `{!MeInG}. + + Definition me_prot_x (eid : Eid) (v : Val) : iProp Σ := + if (bool_decide (v = data_init)) then + (⌜eid.(EID.tid) = 0%nat⌝)%I + else if (bool_decide (v = data_flag)) then + (shot_x eid)%I + else False%I. + + Definition me_prot_y (eid : Eid) (v : Val) : iProp Σ := + if (bool_decide (v = data_init)) then + (⌜eid.(EID.tid) = 0%nat⌝)%I + else if (bool_decide (v = data_flag)) then + (shot_y eid)%I + else False%I. + + Definition protected q (eid : Eid) : iProp Σ := + ((pending_x q ∗ pending_y q) + ∨ (shot_l + ∗ ∃ eid_x eid_y, (shot_x eid_x) ∗ ⌜eid_x.(EID.tid) = 1%nat⌝ + ∗ (shot_y eid_y)∗ ⌜eid_y.(EID.tid) = 1%nat⌝ + ∗ eid_x -{E}> (Event.W AS_normal AV_plain addr_x data_flag) + ∗ eid_y -{E}> (Event.W AS_normal AV_plain addr_y data_flag) + ∗ eid_x -{Edge.Ob}> eid + ∗ eid_y -{Edge.Ob}> eid)). + + Definition me_prot_lock (eid : Eid) (v: Val) := + if bool_decide (v = unlocked) then excl_inv eid (protected 1%Qp) + else + if bool_decide (v = locked) then True%I + else False%I. + + Definition protocol : UserProt := + Build_UserProt _ _(λ a v e, + if (bool_decide (a = addr_x)) then + me_prot_x e v + else if (bool_decide (a = addr_y)) then + me_prot_y e v + else if (bool_decide (a = addr_lock)) then + me_prot_lock e v + else True%I + ). + + Local Instance userprot : UserProt := protocol. + + Local Instance lock_is_lock : IsLockAt addr_lock (protected 1%Qp). + Proof. + split. intros. simpl. done. + Qed. + + Notation bne reg addr:= (IBne (AEreg reg) addr). + Notation bne_neg reg addr:= (IBne (AEbinop AOminus (AEreg reg) (AEval (BV 64 1))) addr). + Notation read reg addr := (ILoad AS_normal AV_plain reg (AEval addr)). + Notation write val addr := (IStore AS_normal AV_plain "r0" (AEval val) (AEval addr)). + + Definition instrs_reader : iProp Σ := + instrs_aquire addr_lock (BV 64 0x2000) "r1" "r2" ∗ + (BV 64 0x2010) ↦ᵢ bne "r1" (BV 64 0x2024) ∗ + (BV 64 0x2014) ↦ᵢ bne_neg "r2" (BV 64 0x2024) ∗ + (* obtained the lock *) + (BV 64 0x2018) ↦ᵢ read "r3" addr_x ∗ + (BV 64 0x201C) ↦ᵢ read "r4" addr_y ∗ + instrs_release addr_lock (BV 64 0x2020) ∗ + (BV 64 0x2024) ↦ᵢ -. + + Lemma reader : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + (∃ rv, "r3" ↦ᵣ rv) -∗ + (∃ rv, "r4" ↦ᵣ rv) -∗ + last_local_write 2 addr_x None -∗ + last_local_write 2 addr_y None -∗ + last_local_write 2 addr_lock None -∗ + instrs_reader -∗ + WPi (LTSI.Normal, (BV 64 0x2000)) @ 2 + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x2024))⌝ ∗ + ∃ rv1 rv2 rv3 rv4, ("r1" ↦ᵣ rv1 ∗ "r2" ↦ᵣ rv2 ∗ "r3" ↦ᵣ rv3 ∗ "r4" ↦ᵣ rv4) ∗ + (⌜rv1.(reg_val) = unlocked ∧ rv2.(reg_val) = (BV 64 1)⌝ -∗ + ⌜(rv3.(reg_val) = data_init ∧ rv4.(reg_val) = data_init) + ∨ (rv3.(reg_val) = data_flag ∧ rv4.(reg_val) = data_flag)⌝ + ) + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw Hreg1 Hreg2 Hreg3 Hreg4 Hlocalw_x Hlocalw_y Hlocalw_l Hinstrs". + iDestruct "Hinstrs" as "(#? & #? & #? & #? & #? & #? & #?)". + + iApply (acquire _ _ _ _ (λ eid, (protected (1/2)%Qp eid ∗ protected (1/2)%Qp eid))%I + with "Hpo_src Hctrl_src Hrmw Hreg1 Hreg2 Hlocalw_l [#$]"). + { + iIntros (?) "[Hl|#Hr]". + { + iModIntro. + iFrame. rewrite /pending_x /pending_y. + rewrite (pending_split MeOneShotNx). + rewrite (pending_split MeOneShotNy). + iDestruct "Hl" as "([Hpending_x1 Hpending_x2] & Hpending_y1 & Hpending_y2)". + iSplitL "Hpending_x1 Hpending_y1"; iLeft; iFrame. + } + { + iModIntro. + iSplitL;iRight;iFrame "Hr". + } + } + + iIntros "(%eid_lxr & %v1 & %v2 & %d2 & Hreg1 & Hreg2 & %po_src & %ctrl_src & %rmw_src & Hpo_src + & Hctrl_src & Hrmw_src & Hpost)". + + iDestruct "Hreg3" as "[%rv3 Hreg3]". iDestruct "Hreg4" as "[%rv4 Hreg4]". + + assert (G: (BV 64 8192 `+Z` 16)%bv = (BV 64 8208)%bv); [bv_solve|]. rewrite G;clear G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hctrl_src Hreg1]"). + { + iApply (ibne {["r1" := _]} with "[#] Hctrl_src [Hreg1]"). + 4:{ rewrite big_sepM_singleton. iExact "Hreg1". } + 3:{ iFrame "#". } + - rewrite dom_singleton_L. set_solver +. + - simpl. rewrite lookup_singleton /=. reflexivity. + } + iIntros (?) "(Hreg1 & Hctrl_src & %Hbranch)". + rewrite map_fold_singleton /=. rewrite union_empty_r_L. + rewrite big_sepM_singleton. + + (* Obtained the lock or not, first branching *) + destruct Hbranch as [[-> ->]|[-> ?]]. + 2:{ + iApply sswpi_wpi. + iApply idone. iFrame "#". + iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ ∅). + rewrite dom_empty_L //. + rewrite big_sepM_empty //. + iIntros "_ !>". + iSplit;first done. + iExists _,_,_,_. iFrame. simpl. + iIntros "[-> ->]". rewrite /unlocked in H4. done. + } + + assert (G: (BV 64 8208 `+Z` 4)%bv = (BV 64 8212)%bv); [bv_solve|]. rewrite G;clear G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hctrl_src Hreg2]"). + { + iApply (ibne {["r2" := _]} with "[#] Hctrl_src [Hreg2]"). + 4:{ rewrite big_sepM_singleton. iExact "Hreg2". } + 3:{ iFrame "#". } + - rewrite dom_singleton_L. set_solver +. + - simpl. rewrite lookup_singleton /=. reflexivity. + } + iIntros (?) "(Hreg2 & Hctrl_src & %Hbranch)". + rewrite map_fold_singleton /=. rewrite union_empty_r_L. + rewrite big_sepM_singleton. + + (* Obtained the lock or not, second branching *) + destruct Hbranch as [[-> Heq_v2]|[-> ?]]. + 2:{ + iApply sswpi_wpi. + iApply idone. iFrame "#". + iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ ∅). + rewrite dom_empty_L //. + rewrite big_sepM_empty //. + iIntros "_ !>". + iSplit;first done. + iExists _,_,_,_. iFrame. simpl. + iIntros "[-> ->]". + exfalso. + assert ((BV 64 1 - BV 64 1) = BV 64 0)%bv. bv_solve. + rewrite H5 in H4. done. + } + + (* Obtained the lock *) + assert (v2 = locked) as ->. + { + (* XXX: bv_solve is not working - unfolding is not smart enough! *) + rewrite /locked. + destruct (bool_decide (v2 = BV 64 1)) eqn:Heqn. + rewrite bool_decide_eq_true in Heqn. done. + rewrite bool_decide_eq_false in Heqn. + clear -Heq_v2 Heqn. + unfold AAInter.reg_type in v2. unfold AAArch.val in v2. unfold AAval in v2. unfold AAArch.val_size in v2. + assert ((v2 - BV 64 1)%bv = (v2 `-Z` 1)%bv). bv_solve. + rewrite H in Heq_v2. clear H. + assert (bv_unsigned v2 ≠ 1). + { intro Heq. apply Heqn. apply bv_eq. rewrite Heq. done. } + apply bv_eq in Heq_v2. + rewrite bv_sub_Z_unsigned /= in Heq_v2. + rewrite bv_unsigned_BV in Heq_v2. + bv_simplify_arith. bv_saturate_unsigned; bv_solve_unfold_tac. + unfold bv_signed, bv_swrap, bv_wrap, bv_half_modulus, bv_modulus, bv_unsigned in *. + simpl in *. destruct v2. simpl. lia. + } + iDestruct ("Hpost" with "[//]") as "(-> & %eid_lw & %eid_lw' & %eid_b & -> & -> & -> & Hlocalw_l + & Hna_lw' & #Hob_lwlw' & #He_b & #Hpo_lw'b)". + rewrite union_empty_l_L. + + iDestruct (annot_split_iupd with "Hna_lw'") as ">[Hna_lw'_x Hna_lw'_y]". + assert (G: (BV 64 8212 `+Z` 4)%bv = (BV 64 8216)%bv); [bv_solve|]. rewrite G;clear G. + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo_src_b]". + + (* Read x *) + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_x Hpo_src Hctrl_src Hna_lw'_x Hreg3 Hrmw_src]"). + { + iApply (iload_pln (λ eid_x v, + ((⌜v = data_init⌝ ∗ ⌜eid_x.(EID.tid) = 0%nat⌝ ∗ protected (1/2)%Qp eid_lw) + ∨ (⌜v = data_flag⌝ ∗ shot_x eid_x ∗ shot_l ∗ eid_x -{Edge.Ob}> eid_lw + ∗ eid_x -{E}> (Event.W AS_normal AV_plain addr_x data_flag) + ∗ ∃ eid_y, (shot_y eid_y) ∗ ⌜eid_y.(EID.tid) = 1%nat⌝ ∗ eid_y -{Edge.Ob}> eid_lw + ∗ eid_y -{E}> (Event.W AS_normal AV_plain addr_y data_flag))))%I + {[eid_b]} {[eid_lw' := protected (1/2)%Qp eid_lw]} + with "[$Hpo_src $Hctrl_src $Hlocalw_x Hna_lw'_x $Hreg3 $Hrmw_src]"). + { iFrame "#∗". rewrite big_sepS_singleton big_sepM_singleton. iFrame "#∗". } + iIntros (eid_r_x). iSplitR. + { + iIntros "HE Hpo_b". + rewrite big_sepS_singleton big_sepM_singleton. + iApply po_dmbsy_po_is_lob;iFrame "#∗". + iDestruct (event_node with "He_b") as "$". + } + { + iIntros (eid_w_x v_x) "He_r_x Htid_r_x Hpo_r_x He_w_x Hrf_x HP #Hprot". + rewrite big_sepM_singleton. rewrite /prot /= /me_prot_x. + iModIntro. + case_bool_decide. + { iLeft; iFrame "#∗". done. } + { + case_bool_decide;last done. + { + iRight. iSplit;first done. + iDestruct "HP" as "[[Hx _]|(?& %&%&Hshot_x &?& Hshot_y & ?&?&?&?&?)]". + { + iExFalso. + iApply (pending_shot with "Hx Hprot"). + } + { + iDestruct (shot_shot with "Hprot Hshot_x") as %->. + iFrame "#∗". iExists _. iFrame. + } + } + } + } + } + + iIntros (?) "(-> & (%eid_r_x & %eid_w_x & %val_x & He_r_x & #Htid_w_x & Hreg3 & Hna_r_x & #He_w_x & #Hrf_x + & Hpo_src & #Hpo_b_r_x & Hctrl_src & Hrmw_src & _))". + rewrite big_sepS_singleton. + iAssert (⌜eid_b ≠ eid_r_x⌝%I) as "%Hneq_eid_r_x". + { iIntros (->). iApply (po_irrefl with "Hpo_b_r_x"). } + + assert (G: (BV 64 8216 `+Z` 4)%bv = (BV 64 8220)%bv); [bv_solve|]. rewrite G;clear G. + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo_src_r_x]". + + (* Read y *) + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_y Hpo_src Hctrl_src Hna_lw'_y Hreg4 Hrmw_src]"). + { + iApply (iload_pln (λ eid_y v, + ((⌜v = data_init⌝ ∗ ⌜eid_y.(EID.tid) = 0%nat⌝ ∗ protected (1/2)%Qp eid_lw) + ∨ (⌜v = data_flag⌝ ∗ shot_y eid_y ∗ shot_l ∗ eid_y -{Edge.Ob}> eid_lw + ∗ eid_y -{E}> (Event.W AS_normal AV_plain addr_y data_flag) + ∗ ∃ eid_x, (shot_x eid_x) ∗ ⌜eid_x.(EID.tid) = 1%nat⌝ ∗ eid_x -{Edge.Ob}> eid_lw + ∗ eid_x -{E}> (Event.W AS_normal AV_plain addr_x data_flag))))%I + {[eid_b;eid_r_x]} {[eid_lw' := protected (1/2)%Qp eid_lw]} + with "[$Hpo_src $Hctrl_src $Hlocalw_y Hna_lw'_y $Hreg4 $Hrmw_src]"). + { + iFrame "#∗". rewrite big_sepS_union. rewrite 2!big_sepS_singleton big_sepM_singleton. iFrame "#∗". + set_solver + Hneq_eid_r_x. + } + iIntros (eid_r_y). iSplitR. + { + iIntros "HE Hpo_b". + rewrite big_sepS_union. rewrite 2!big_sepS_singleton big_sepM_singleton. + iDestruct "Hpo_b" as "[Hpo_b _]". + iApply po_dmbsy_po_is_lob;iFrame "#∗". + iDestruct (event_node with "He_b") as "$". + set_solver + Hneq_eid_r_x. + } + { + iIntros (eid_w_y v_y) "He_r_y Htid_r_y Hpo_r_y He_w_y Hrf_y HP #Hprot". + rewrite big_sepM_singleton. + rewrite /prot /= /me_prot_y. + iModIntro. + case_bool_decide. + { iLeft; iFrame "#∗". done. } + { + case_bool_decide;last done. + { + iRight. iSplit;first done. + iDestruct "HP" as "[[_ Hy]|(?& %&%&Hshot_x&? & Hshot_y &?& ?&?&?&?)]". + { + iExFalso. iApply (pending_shot with "Hy Hprot"). + } + { + iDestruct (shot_shot with "Hprot Hshot_y") as %->. + iFrame "#∗". iExists _. iFrame. + } + } + } + } + } + + iIntros (?) "(-> & (%eid_r_y & %eid_w_y & %val_y & He_r_y & #Htid_w_y & Hreg4 & Hna_r_y & #He_w_y & #Hrf_y + & Hpo_src & Hpos & Hctrl_src & Hrmw_src & _))". + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo_src_r_y]". + + assert (G: (BV 64 8220 `+Z` 4)%bv = (BV 64 8224)%bv); [bv_solve|]. rewrite G;clear G. + + rewrite big_sepS_union. rewrite 2!big_sepS_singleton. iDestruct "Hpos" as "[#Hpo_b_r_y #Hpo_r_x_r_y]". + iAssert (⌜eid_r_x ≠ eid_r_y⌝%I) as "%Hneq_eid_r_x_y". + { iIntros (->). iApply (po_irrefl with "Hpo_r_x_r_y"). } + + iApply (release _ _ {[eid_r_x; eid_r_y]} {[eid_r_x := _; eid_r_y := _]} + (⌜val_x = data_init ∧ val_y = data_init⌝ ∨ ⌜val_x = data_flag ∧ val_y = data_flag⌝)%I + with "Hpo_src [] Hctrl_src Hrmw_src Hlocalw_l [#$] [Hna_r_x Hna_r_y]"). + { + rewrite 2!dom_insert_L. set_solver +. + } + { + rewrite big_sepS_union. rewrite 2!big_sepS_singleton. iFrame "#". + set_solver + Hneq_eid_r_x_y. + } + { + iApply (big_sepM_insert_2 with "Hna_r_x"). + by iApply (big_sepM_insert_2 with "Hna_r_y"). + } + { + iIntros (eid_r). + iSplitR. + { + iIntros "_ _". rewrite 2!dom_insert_L. rewrite dom_empty_L. rewrite union_empty_r_L. + rewrite difference_diag_L. done. + } + { + iIntros "(#He_r&Hpos&HP)". + rewrite big_sepS_union. 2: set_solver + Hneq_eid_r_x_y. + rewrite 2!big_sepS_singleton. rewrite big_sepM_insert. + 2:{ rewrite lookup_singleton_None //. } + rewrite big_sepM_singleton. iModIntro. + iDestruct "HP" as "[[Hz_x | Hf_x] [Hz_y | Hf_y]]". + { + (* case x=0, y=0 *) + iDestruct "Hz_x" as "(-> & %Hinit_x & Hz_x)". iDestruct "Hz_y" as "(-> & %Hinit_y & Hz_y)". + iSplit;last (iLeft;done). + + iDestruct "Hpos" as "[#Hpo_r_x_r #Hpo_r_y_r]". + iDestruct (po_trans with "Hpo_lw'b Hpo_b_r_x") as "Hpo_x_1". + iDestruct (po_trans with "Hpo_x_1 Hpo_r_x_r") as "Hpo_x_2". + iAssert (eid_lw' -{Edge.Ob}> eid_r)%I as "Hob_r". + { + iApply lob_is_ob. + iApply (po_rel_is_lob with "Hpo_x_2 []"). + iApply (event_node with "He_r"). + } + + iDestruct "Hz_x" as "[[HN_x HN_y] | (#Hshot_l& %&%&HS_x & HS_y & #(Hx1&Hx2&Hx3&Hx4&Hx5&Hx6))]"; + iDestruct "Hz_y" as "[[HN_x' HN_y'] | (#Hshot_l'& %&%&HS_x' & HS_y' & #(Hy1&Hy2&Hy3&Hy4&Hy5&Hy6))]". + { + iLeft. iDestruct (pending_split with "[$HN_x $HN_x']") as "$". + iDestruct (pending_split with "[$HN_y $HN_y']") as "$". + } + { iExFalso. iApply (pending_shot with "HN_x HS_x'"). } + { iExFalso. iApply (pending_shot with "HN_x' HS_x"). } + { + iRight. iFrame "Hshot_l". + iDestruct (shot_shot with "HS_x HS_x'") as %->. + iExists _,_. iFrame "#∗". + iDestruct (ob_trans with "Hy5 Hob_lwlw'") as "Hob_x". + iDestruct (ob_trans with "Hy6 Hob_lwlw'") as "Hob_y". + iSplit. + { iApply (ob_trans with "Hob_x Hob_r"). } + { iApply (ob_trans with "Hob_y Hob_r"). } + } + } + { + (* case x = 0, y = 1, impossible *) + iDestruct "Hz_x" as "(-> & % & _)". + iDestruct "He_w_x" as "(%&%&He_w_x)". + iDestruct "Hf_y" as "(_ &_&_&_&_&%eid_w_x'&_&%Htid_x&#Hob_x&#He_w')". + iDestruct (initial_write_co with "He_w_x He_w'") as "Hco_x". done. + { rewrite Htid_x. lia. } + iDestruct (rf_co_to_fr with "Hrf_x Hco_x") as "Hfr_x". + iDestruct "Htid_w_x" as %Htid_r_x. + iDestruct (fre_is_ob with "Hfr_x") as "Hob_x'". lia. + iDestruct (ob_trans with "Hob_x' Hob_x") as "Hob_x''". + iDestruct (ob_trans with "Hob_x'' Hob_lwlw'") as "Hob_x'''". + iDestruct (po_dmbsy_po_is_lob with "Hpo_lw'b [] Hpo_b_r_x") as "Hlob_x". + { iApply (event_node with "He_b"). } + iDestruct (lob_is_ob with "Hlob_x") as "Hob_x''''". + iDestruct (ob_trans with "Hob_x''' Hob_x''''") as "Hob_cycle". + iExFalso. iApply (ob_acyclic with "Hob_cycle"). + } + { + (* case x = 1, y = 0, impossible *) + iDestruct "Hz_y" as "(-> & % & _)". + iDestruct "He_w_y" as "(%&%&He_w_y)". + iDestruct "Hf_x" as "(_ &_&_&_&_&%eid_w_y'&_&%Htid_y&#Hob_y&#He_w')". + iDestruct (initial_write_co with "He_w_y He_w'") as "Hco_y". done. + { rewrite Htid_y. lia. } + iDestruct (rf_co_to_fr with "Hrf_y Hco_y") as "Hfr_y". + iDestruct "Htid_w_y" as %Htid_r_y. + iDestruct (fre_is_ob with "Hfr_y") as "Hob_y'". lia. + iDestruct (ob_trans with "Hob_y' Hob_y") as "Hob_y''". + iDestruct (ob_trans with "Hob_y'' Hob_lwlw'") as "Hob_y'''". + iDestruct (po_dmbsy_po_is_lob with "Hpo_lw'b [] Hpo_b_r_y") as "Hlob_y". + { iApply (event_node with "He_b"). } + iDestruct (lob_is_ob with "Hlob_y") as "Hob_y''''". + iDestruct (ob_trans with "Hob_y''' Hob_y''''") as "Hob_cycle". + iExFalso. iApply (ob_acyclic with "Hob_cycle"). + } + { + (* case x = 1, y = 1 *) + iDestruct "Hf_y" as "(%v_y & #shot_y & #shot_l & #Hob_w_y_l &#He_w_y'&%eid_w_x' + &shot_x'&%Htid_x&#Hob_x&#He_w')". + iDestruct "Hf_x" as "(%v_x & #shot_x & _ & #Hob_w_x_l &#He_w_x'&%eid_w_y'&shot_y' + &%Htid_y&#Hob_y&#He_w'')". + iSplit. + iRight. iFrame "shot_l". + iDestruct (shot_shot with "shot_x shot_x'") as %->. + iDestruct (shot_shot with "shot_y shot_y'") as %->. + iExists _,_. iFrame "#". iSplit;first done. iSplit;first done. + + iDestruct (ob_trans with "Hob_w_x_l Hob_lwlw'") as "Hob_x'". + iDestruct (ob_trans with "Hob_w_y_l Hob_lwlw'") as "Hob_y'". + iDestruct "Hpos" as "[#Hpo_r_x_r #Hpo_r_y_r]". + iDestruct (po_trans with "Hpo_lw'b Hpo_b_r_x") as "Hpo_x_1". + iDestruct (po_trans with "Hpo_x_1 Hpo_r_x_r") as "Hpo_x_2". + iAssert (eid_lw' -{Edge.Ob}> eid_r)%I as "Hob_r". + { + iApply lob_is_ob. + iApply (po_rel_is_lob with "Hpo_x_2 []"). + iApply (event_node with "He_r"). + } + iSplit. + { iApply (ob_trans with "Hob_x' Hob_r"). } + { iApply (ob_trans with "Hob_y' Hob_r"). } + iRight;done. + } + } + } + iIntros "(%&?&%HHH&?&?&?&Hna)". + + assert (G: ((BV 64 8224) `+Z` 4 = (BV 64 8228))%bv); [bv_solve|]. rewrite G. clear G. + iApply sswpi_wpi. iApply idone;auto. + iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ {[eid := _]} with "[Hna]");auto. + rewrite dom_singleton_L. apply set_Forall_singleton. done. + rewrite big_sepM_singleton. iFrame. + rewrite big_sepM_singleton. + iIntros "%HH". iModIntro. iSplit;first done. + iExists _,_,_,_. iFrame. simpl. iIntros "_". iPureIntro. done. + set_solver + Hneq_eid_r_x. + Qed. + + Definition instrs_writer : iProp Σ := + instrs_aquire addr_lock (BV 64 0x1000) "r1" "r2" ∗ + (BV 64 0x1010) ↦ᵢ bne "r1" (BV 64 0x1024) ∗ + (BV 64 0x1014) ↦ᵢ bne_neg "r2" (BV 64 0x1024) ∗ + (* obtained the lock *) + (BV 64 0x1018) ↦ᵢ write data_flag addr_x ∗ + (BV 64 0x101C) ↦ᵢ write data_flag addr_y ∗ + instrs_release addr_lock (BV 64 0x1020) ∗ + (BV 64 0x1024) ↦ᵢ -. + + Lemma writer : + None -{LPo}> -∗ + ∅ -{Ctrl}> -∗ + None -{Rmw}> -∗ + (∃ rv, "r1" ↦ᵣ rv) -∗ + (∃ rv, "r2" ↦ᵣ rv) -∗ + last_local_write 1 addr_x None -∗ + last_local_write 1 addr_y None -∗ + last_local_write 1 addr_lock None -∗ + instrs_writer -∗ + pending_l -∗ + WPi (LTSI.Normal, (BV 64 0x1000)) @ 1 + {{ λ lts', + ⌜lts' = (LTSI.Done, (BV 64 0x1024))⌝ + }}. + Proof. + iIntros "Hpo_src Hctrl_src Hrmw Hreg1 Hreg2 Hlocalw_x Hlocalw_y Hlocalw_l Hinstrs Hpending_l". + iDestruct "Hinstrs" as "(#? & #? & #? & #? & #? & #? & #?)". + + iApply (acquire _ _ _ _ (λ _, pending_l ∗ pending_x 1%Qp ∗ pending_y 1%Qp)%I + with "Hpo_src Hctrl_src Hrmw Hreg1 Hreg2 Hlocalw_l [#$] [Hpending_l]"). + { + iIntros (?) "[Hl|[Hshot_l Hr]]". + { iModIntro. iDestruct "Hl" as "[$ $]". iFrame. } + { iExFalso. iApply (pending_l_shot with "Hpending_l Hshot_l"). } + } + + iIntros "(%eid_lxr & %v1 & %v2 & %d2 & Hreg1 & Hreg2 & %po_src & %ctrl_src & %rmw_src & Hpo_src + & Hctrl_src & Hrmw_src & Hpost)". + + assert (G: (BV 64 4096 `+Z` 16)%bv = (BV 64 4112)%bv); [bv_solve|]. rewrite G;clear G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hctrl_src Hreg1]"). + { + iApply (ibne {["r1" := _]} with "[#] Hctrl_src [Hreg1]"). + 4:{ rewrite big_sepM_singleton. iExact "Hreg1". } + 3:{ iFrame "#". } + - rewrite dom_singleton_L. set_solver +. + - simpl. rewrite lookup_singleton /=. reflexivity. + } + iIntros (?) "(Hreg1 & Hctrl_src & %Hbranch)". + rewrite map_fold_singleton /=. rewrite union_empty_r_L. rewrite big_sepM_singleton. + + (* Obtained the lock or not, first branching *) + destruct Hbranch as [[-> ->]|[-> ?]]. + 2:{ + iApply sswpi_wpi. iApply idone. iFrame "#". + iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ ∅). + rewrite dom_empty_L //. + rewrite big_sepM_empty //. + iIntros "_ !>". done. + } + + assert (G: (BV 64 4112 `+Z` 4)%bv = (BV 64 4116)%bv); [bv_solve|]. rewrite G;clear G. + + iApply sswpi_wpi. iApply (sswpi_mono with "[Hctrl_src Hreg2]"). + { + iApply (ibne {["r2" := _]} with "[#] Hctrl_src [Hreg2]"). + 4:{ rewrite big_sepM_singleton. iExact "Hreg2". } + 3:{ iFrame "#". } + - rewrite dom_singleton_L. set_solver +. + - simpl. rewrite lookup_singleton /=. reflexivity. + } + iIntros (?) "(Hreg2 & Hctrl_src & %Hbranch)". + rewrite map_fold_singleton /=. rewrite union_empty_r_L. rewrite big_sepM_singleton. + + (* Obtained the lock or not, second branching *) + destruct Hbranch as [[-> Heq_v2]|[-> ?]]. + 2:{ + iApply sswpi_wpi. iApply idone. iFrame "#". + iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ _ ∅). + rewrite dom_empty_L //. + rewrite big_sepM_empty //. + iIntros "_ !>". done. + } + + (* Obtained the lock *) + assert (v2 = locked) as ->. + { + (* XXX: bv_solve is not working - unfolding is not smart enough! *) + rewrite /locked. + destruct (bool_decide (v2 = BV 64 1)) eqn:Heqn. + rewrite bool_decide_eq_true in Heqn. done. + rewrite bool_decide_eq_false in Heqn. + clear -Heq_v2 Heqn. + unfold AAInter.reg_type in v2. unfold AAArch.val in v2. unfold AAval in v2. unfold AAArch.val_size in v2. + assert ((v2 - BV 64 1)%bv = (v2 `-Z` 1)%bv). bv_solve. + rewrite H in Heq_v2. clear H. + assert (bv_unsigned v2 ≠ 1). + { intro Heq. apply Heqn. apply bv_eq. rewrite Heq. done. } + apply bv_eq in Heq_v2. + rewrite bv_sub_Z_unsigned /= in Heq_v2. + rewrite bv_unsigned_BV in Heq_v2. + bv_simplify_arith. bv_saturate_unsigned; bv_solve_unfold_tac. + unfold bv_signed, bv_swrap, bv_wrap, bv_half_modulus, bv_modulus, bv_unsigned in *. + simpl in *. destruct v2. simpl. lia. + } + iDestruct ("Hpost" with "[//]") as "(-> & %eid_lw & %eid_lw' & %eid_b & -> & -> & -> & Hlocalw_l + & Hna_lw' & #Hob_lwlw' & #He_b & #Hpo_lw'b)". + rewrite union_empty_l_L. + + iDestruct (annot_split_iupd with "Hna_lw'") as ">[Hna_lw'_l Hna_lw']". + iDestruct (annot_split_iupd with "Hna_lw'") as ">[Hna_lw'_x Hna_lw'_y]". + assert (G: (BV 64 4116 `+Z` 4)%bv = (BV 64 4120)%bv); [bv_solve|]. rewrite G;clear G. + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo_src_b]". + + (* Write x *) + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_x Hpo_src Hctrl_src Hna_lw'_x]"). + { + iApply (istore_pln (λ eid, shot_x eid) {[eid_b]} {[eid_lw' := pending_x 1]} with "[$Hpo_src $Hctrl_src $Hlocalw_x Hna_lw'_x]"). + { iFrame "#∗". rewrite big_sepS_singleton big_sepM_singleton. iFrame "#∗". } + iIntros (eid_w_x). iSplitR. + { + iIntros "HE Hpo_b _". + rewrite big_sepS_singleton big_sepM_singleton. + iApply po_dmbsy_po_is_lob;iFrame "#∗". + iDestruct (event_node with "He_b") as "$". + } + { + rewrite big_sepS_singleton big_sepM_singleton. + iIntros "HE Htid_w_x Hpo_w_x Hpending_x". + iDestruct (shoot _ eid_w_x with "Hpending_x") as ">#Hshot_x". + iModIntro. iSplit;first done. + iModIntro. simpl. rewrite /me_prot_x. + case_bool_decide. inversion H4. + case_bool_decide;last done. iFrame "Hshot_x". + } + } + iIntros (?) "(-> & (%eid_w_x & #He_w_x& #Htid_w_x & Hpo_src & #Hpo_b_w_x & Hlocalw_x & Hctrl_src & Hna_w_x))". + rewrite big_sepS_singleton. + iAssert (⌜eid_b ≠ eid_w_x⌝%I) as "%Hneq_eid_w_x". + { + iIntros (->). iApply (po_irrefl with "Hpo_b_w_x"). + } + + assert (G: ((BV 64 4120) `+Z` 4 = (BV 64 4124))%bv); [bv_solve|]. rewrite G. clear G. + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo_src_w_x]". + + (* Write y *) + iApply sswpi_wpi. iApply (sswpi_mono with "[Hlocalw_y Hpo_src Hctrl_src Hna_lw'_y]"). + { + iApply (istore_pln (λ eid, shot_y eid) {[eid_b;eid_w_x]} + {[eid_lw' := pending_y 1]} with "[$Hpo_src $Hctrl_src $Hlocalw_y Hna_lw'_y]"). + { + iFrame "#∗". rewrite big_sepM_singleton. iFrame "#∗". + rewrite big_sepS_union. rewrite 2!big_sepS_singleton. iFrame "#". set_solver + Hneq_eid_w_x. + } + iIntros (eid_w_y). iSplitR. + { + rewrite big_sepS_union; last set_solver + Hneq_eid_w_x. + iIntros "HE [Hpo_b _] _". + rewrite big_sepM_singleton. + iApply po_dmbsy_po_is_lob;iFrame "#∗". + iDestruct (event_node with "He_b") as "$". + rewrite big_sepS_singleton. iFrame "Hpo_b". + } + { + rewrite big_sepM_singleton. + iIntros "HE Htid_w_y Hpos Hpending_y". + iDestruct (shoot _ eid_w_y with "Hpending_y") as ">#Hshot_y". + iModIntro. iFrame "#∗". + } + } + iIntros (?) "(-> & (%eid_w_y & #He_w_y & #Htid_w_y & Hpo_src & Hpos & Hlocalw_y & Hctrl_src & Hna_w_y))". + + rewrite big_sepS_union; last set_solver + Hneq_eid_w_x. + rewrite 2!big_sepS_singleton. + iDestruct "Hpos" as "[#Hpo_b_w_y #Hpo_w_x_w_y]". + + iAssert (⌜eid_w_x ≠ eid_w_y⌝%I) as "%Hneq_eid_w_y". + { + iIntros (->). iApply (po_irrefl with "Hpo_w_x_w_y"). + } + + assert (G: ((BV 64 4124) `+Z` 4 = (BV 64 4128))%bv); [bv_solve|]. rewrite G. clear G. + iDestruct (lpo_to_po with "Hpo_src") as "[Hpo_src #Hpo_src_w_y]". + + iApply (release _ _ {[eid_w_x; eid_w_y]} + {[eid_w_x := shot_x eid_w_x; eid_w_y := shot_y eid_w_y ; eid_lw' := pending_l]} emp + with "Hpo_src [] Hctrl_src Hrmw_src Hlocalw_l [#$] [Hna_w_x Hna_w_y Hna_lw'_l]"). + { + rewrite 3!dom_insert_L. set_solver +. + } + { + rewrite big_sepS_union. rewrite 2!big_sepS_singleton. iFrame "#". + set_solver + Hneq_eid_w_y. + } + { + iApply (big_sepM_insert_2 with "Hna_w_x"). + iApply (big_sepM_insert_2 with "Hna_w_y"). + iApply (big_sepM_singleton with "Hna_lw'_l"). + } + { + iIntros (?). + + iDestruct (po_trans with "Hpo_lw'b Hpo_b_w_y") as "#Hpo_lw'_w_y". + iDestruct (po_trans with "Hpo_lw'b Hpo_b_w_x") as "#Hpo_lw'_w_x". + iAssert (⌜eid_lw' ≠ eid_w_x⌝%I) as "%Hneq_eid_w_x'". + { iIntros (->). iApply (po_irrefl with "Hpo_lw'_w_x"). } + iAssert (⌜eid_lw' ≠ eid_w_y⌝%I) as "%Hneq_eid_w_y'". + { iIntros (->). iApply (po_irrefl with "Hpo_lw'_w_y"). } + iSplitL. + { + (* graph reasoning *) + rewrite 3!dom_insert_L. + iIntros "_ Hpo". + rewrite big_sepS_union;last set_solver + Hneq_eid_w_y. + rewrite 2!big_sepS_singleton. + iDestruct "Hpo" as "[#Hpo_w_x_r #Hpo_w_y_r]". + rewrite dom_empty_L. rewrite union_empty_r_L. + assert ((({[eid_w_x]} ∪ {[eid_w_y; eid_lw']}) + ∖ {[eid_w_x; eid_w_y]}) = ({[eid_lw']}: gset Eid)) as ->. + { set_solver + Hneq_eid_w_x' Hneq_eid_w_y'. } + rewrite big_sepS_singleton. + iApply (po_dmbsy_po_is_lob with "Hpo_lw'b [] []"). + { iApply (event_node with "He_b"). } + { iApply (po_trans with "Hpo_b_w_y Hpo_w_y_r"). } + } + iIntros "(#He_r&Hpos&HP)". + rewrite big_sepM_insert. + 2: { rewrite 2!lookup_insert_None. set_solver. } + rewrite big_sepM_insert. + 2: { rewrite lookup_insert_None. set_solver. } + rewrite big_sepM_singleton. + iDestruct "HP" as "(Hshot_x & Hshot_y & Hpending_l)". + iMod (shoot_l with "Hpending_l") as "Hshot_l". + iModIntro. iSplit;last done. iRight. iFrame "Hshot_l". + iExists eid_w_x, eid_w_y. iFrame. + rewrite big_sepS_union;last set_solver. + rewrite 2!big_sepS_singleton. + iDestruct "Hpos" as "[Hpo1 Hpo2]". + iDestruct "Htid_w_x" as %Htid_x. iDestruct "Htid_w_y" as %Htid_y. + iSplit; first (iPureIntro;lia). iSplit; first (iPureIntro;lia). + iFrame "#". iSplitL "Hpo1". + iApply lob_is_ob. + iApply (po_rel_is_lob with "Hpo1"). + { iApply (event_node with "He_r"). } + iApply lob_is_ob. + iApply (po_rel_is_lob with "Hpo2"). + { iApply (event_node with "He_r"). } + } + iIntros "_". + + assert (G: ((BV 64 4128) `+Z` 4 = (BV 64 4132))%bv); [bv_solve|]. rewrite G. clear G. + + iApply sswpi_wpi. iApply idone;auto. + iApply wpi_terminated. + iApply (inst_post_lifting_lifting _ _ ∅ ∅);auto. set_solver. + Qed. + +End mutual_exclusion. diff --git a/theories/iris_extra.v b/theories/iris_extra.v new file mode 100644 index 0000000..f0f3d85 --- /dev/null +++ b/theories/iris_extra.v @@ -0,0 +1,171 @@ +From iris.bi Require Import big_op. +From iris.prelude Require Import options. +From iris.bi Require Import telescopes derived_laws_later. +From iris.proofmode Require Import base modality_instances classes classes_make. +From iris.proofmode Require Import ltac_tactics. +From stdpp Require Import countable fin_sets functions. +From iris.algebra Require Import list gmap. +Import interface.bi derived_laws.bi derived_laws_later.bi. +Require Import self.stdpp_extra. +Import bi. + +(* upstream to [iris/proofmode/class_instances.v] *) +Section class_instances. + +Context {PROP : bi}. +Implicit Types P Q R : PROP. + +#[global] Instance into_pure_big_sepM2 `{Countable K} {A B} + (Φ : K → A -> B → PROP) (φ : K → A -> B → Prop) (m1 : gmap K A) (m2 : gmap K B): + (∀ k x y, IntoPure (Φ k x y) (φ k x y)) → + IntoPure ([∗ map] k↦x;y ∈ m1;m2, Φ k x y) ((∀ k : K, is_Some (m1 !! k) ↔ is_Some (m2 !! k)) ∧ + (∀ k y1 y2, m1 !! k = Some y1 → m2 !! k = Some y2 → φ k y1 y2)). +Proof. + rewrite /IntoPure. intros HΦ. setoid_rewrite HΦ. + rewrite pure_and. apply and_intro. + - apply big_sepM2_lookup_iff. + - apply big_sepM2_pure_1. +Qed. + +#[global] Instance into_pure_big_sepL2 `{!BiAffine PROP} {A B} + (Φ : nat → A -> B → PROP) (φ : nat → A -> B → Prop) (l1 : list A) (l2 : list B): + (∀ k x y, IntoPure (Φ k x y) (φ k x y)) → + IntoPure ([∗ list] k↦x;y ∈ l1;l2, Φ k x y) (length l1 = length l2 ∧ ∀ k y1 y2, l1 !! k = Some y1 → l2 !! k = Some y2 → φ k y1 y2). +Proof. + rewrite /IntoPure. intros HΦ. + setoid_rewrite HΦ. + rewrite big_sepL2_pure. + done. +Qed. + +End class_instances. + +Section big_op. + + Import bi. + Context {PROP : bi}. + Implicit Types P Q : PROP. + Implicit Types Ps Qs : list PROP. + Implicit Types A : Type. + + Lemma big_sepL2_bupd `{!BiBUpd PROP} {A B} (Φ : nat → A → B → PROP) l1 l2 : + ([∗ list] k↦x;y ∈ l1;l2, |==> Φ k x y) ⊢ |==> [∗ list] k↦x;y ∈ l1;l2, Φ k x y. + Proof. + rewrite !big_sepL2_alt !persistent_and_affinely_sep_l. + etrans; [| by apply bupd_frame_l]. apply sep_mono_r. apply big_sepL_bupd. + Qed. + +Section sep_list2. + (* upstream *) + Context {A B : Type}. + Implicit Types Φ Ψ : nat → A → B → PROP. + + + (* very ugly but I've tried my best.. *) + Lemma big_sepL2_snoc_inv_l Φ x1 l1 l2 : + ([∗ list] k↦y1;y2 ∈ l1++ [x1]; l2, Φ k y1 y2) ⊢ + ∃ x2 l2', (⌜l2 = l2'++[x2] ⌝ ∧ + Φ (length l1) x1 x2) ∗ [∗ list] k↦y1;y2 ∈ l1;l2', Φ k y1 y2. + Proof. + rewrite big_sepL2_app_inv_l. + apply bi.exist_elim. intro. + apply bi.exist_elim. intro. + apply bi.pure_elim_l. intro. + rewrite bi.sep_comm. + rewrite big_sepL2_alt. + rewrite bi.exist_exist. + rewrite -(bi.exist_intro a). + rewrite -bi.sep_exist_r. + apply bi.sep_mono. 2 : done. + apply bi.pure_elim_l. intro Hl. + assert (∃ x0, [x0] = a0) as [x0 <-]. + - simpl in Hl. + destruct a0. + + simpl in Hl. lia. + + destruct a0. + * exists b. done. + * simpl in Hl;lia. + - simpl. rewrite -(bi.exist_intro x0). + apply bi.and_intro. + + apply bi.pure_intro. done. + + assert (length l1 + 0 = length l1) as -> by lia. + simpl. apply bi.sep_elim_l. apply _. + Qed. + +End sep_list2. + +Section gmap. +(* + From stdpp Require Import countable fin_sets functions. + From iris.algebra Require Import list gmap. + From iris.bi Require Import derived_laws_later. + From iris.prelude Require Import options. + Import interface.bi derived_laws.bi derived_laws_later.bi. + Require Import self.stdpp_extra. +*) + Lemma big_sepS_to_map `{Countable K} {A : Type} (m: gmap K A) (s: gset K) (f: A -> PROP) : + dom m ⊆ s -> + ([∗ set] x ∈ s, from_option f emp (m !! x))%I ⊣⊢ + ([∗ map] _ ↦ y ∈ m, f y)%I. + Proof. + revert s. induction m as [|?? m Hlk] using map_ind; intros s Hdom. + - rewrite -(big_sepS_proper (λ _, emp)%I). + 2:{ intros. simpl. rewrite lookup_empty //=. } + rewrite big_sepS_emp. rewrite big_sepM_empty //. + - rewrite dom_insert_L in Hdom. + rewrite (union_difference_singleton_L i s). 2:set_solver + Hdom. + rewrite big_sepS_union. 2:set_solver +. rewrite big_sepS_singleton. + rewrite lookup_insert /=. + rewrite big_sepM_insert;auto. + rewrite -(big_sepS_proper (λ y, from_option f emp (m !! y))%I). + 2:{ intros ? Hin. rewrite lookup_insert_ne //. set_solver + Hin. } + rewrite (IHm (s ∖ {[i]})) //. + apply not_elem_of_dom in Hlk. + set_solver + Hlk Hdom. + Qed. + + Lemma big_sepS_fold_to_gmap `{Countable A} (X : gset A) (f : A -> PROP): + ([∗ map] _ ↦ y ∈ ((set_fold (λ e acc, <[e:=f e]> acc) ∅ X)), y) ⊣⊢ + [∗ set] x ∈ X, f x. + Proof. + rewrite set_fold_to_gmap_imap //. rewrite map_union_empty. + rewrite -(big_sepS_to_map _ X). + 2: rewrite map_imap_dom_Some dom_gset_to_gmap //. + rewrite big_sepS_proper. + - reflexivity. + - intros x Hin. + rewrite map_lookup_imap lookup_gset_to_gmap. case_option_guard;done. + Qed. + + Lemma big_sepM_sepM2_zip `{Countable K} {A B} (m1: gmap K A) (m2: gmap K B) (f: K-> A->B->PROP) : + dom m1 = dom m2 -> + ([∗ map] k↦v ∈ m1, from_option (λ v', f k v v') emp (m2 !! k)) ⊣⊢ + [∗ map] k↦v;v' ∈ m1;m2, f k v v'. + Proof. + revert m1. + induction m2 as [|k v' m2 Hlk'] using map_ind. + { + intros ? Hdom. rewrite dom_empty_L in Hdom. apply dom_empty_inv_L in Hdom. subst m1. + rewrite big_sepM_empty big_sepM2_empty //. + } + { + intros ? Heq. + assert (is_Some (m1 !! k)) as [v Hlk]. + { apply elem_of_dom. rewrite Heq. rewrite dom_insert_L. set_solver +. } + rewrite (big_sepM_delete _ _ k);eauto. + rewrite -(insert_id m1 k v) //. rewrite (big_sepM2_delete _ _ _ k v v'). + 2:{ apply lookup_insert_Some;auto. } + 2:{ apply lookup_insert_Some;auto. } + rewrite lookup_insert /=. rewrite delete_insert_delete. rewrite delete_insert //. + specialize (IHm2 (delete k m1)). feed specialize IHm2. + - rewrite dom_delete_L. rewrite Heq. rewrite dom_insert_L. apply not_elem_of_dom in Hlk'. set_solver + Hlk'. + - rewrite -IHm2. + f_equiv. apply big_sepM_proper. + intros ?? Hlk''. + assert (k ≠ k0). { apply lookup_delete_Some in Hlk''. destruct Hlk'';done. } + f_equiv. rewrite lookup_insert_ne //. + } + Qed. + +End gmap. +End big_op. diff --git a/theories/lang/instrs.v b/theories/lang/instrs.v new file mode 100644 index 0000000..4fd0122 --- /dev/null +++ b/theories/lang/instrs.v @@ -0,0 +1,149 @@ +(* This file contains the instruction semantics *) +Require Import Strings.String. +(* to use monad notations *) +Require Import stdpp.base. +Require Import stdpp.gmap. +Require Import stdpp.unstable.bitvector. + +Require Import ISASem.Interface. + +Require Import self.lang.machine. + +Local Open Scope stdpp_scope. + +Section instructions. + Implicit Type r : RegName. + Implicit Type w : Val. + + Definition AccessStrength := Access_strength. + Definition AccessVariety := Access_variety. + + Inductive ArithOp := + | AOplus | AOminus | AOtimes. + + Inductive ArithExp := + | AEval w + | AEreg r + | AEbinop (op: ArithOp) (ae1: ArithExp) (ae2: ArithExp). + + Implicit Type ae : ArithExp. + Implicit Type dκ : DmbKind. + Implicit Type addr : Addr. + Implicit Type kv : AccessVariety. + Implicit Type ks : AccessStrength. + + Inductive Instruction := + | ILoad ks kv r ae + | IStore ks kv r ae1 ae2 (* src, dst *) + | IDmb dκ + | IIsb + | IAssign r ae + | IBr addr + | IBne ae addr + | INop. + +End instructions. + +Section interpretation. + + Import AAInter. + Import AACandExec. + + (* interp of expressions *) + Fixpoint AEInterp ae : iMon Val := + match ae with + | AEval w => Ret w + | AEreg r => Next (RegRead r true) (fun w => mret w) + | AEbinop op ae1 ae2 => w1 ← (AEInterp ae1); + w2 ← (AEInterp ae2); + Ret (match op with + | AOplus => w1 + w2 + | AOminus => w1 - w2 + | AOtimes => w1 * w2 + end)%bv + end. + + Definition RNPC : string := "pc". + + (* increment PC *) + Definition IncPCInterp : iMon unit := + w ← Next (RegRead RNPC true) (fun w => mret w); + (* We don't track dependencies for the PC, since it's not a GPR *) + Next (RegWrite RNPC true None (w `+Z` 4)%bv) (fun _ => Ret tt). + + (* computing dependencies of an expression *) + Fixpoint dep_of_AE_aux ae := + match ae with + | AEval _ => [] + | AEreg r => [r] + | AEbinop _ ae1 ae2 => app (dep_of_AE_aux ae1) (dep_of_AE_aux ae2) + end. + + (* lifting dependencies to [DepOn], with memory dependencies [l] *) + Definition dep_of_AE_with_m ae l:= DepOn.make (dep_of_AE_aux ae) l. + + (* lifting with no memory dependencies *) + Definition dep_of_AE ae := DepOn.make (dep_of_AE_aux ae) []. + + (* lifting access kinds to [accessKind] *) + Definition access_kind_of_AK kind_strength kind_variety : accessKind := + AK_explicit (Build_Explicit_access_kind kind_variety kind_strength). + + (* making [WriteReq] *) + Definition writereq_of_store {n} kind_strength kind_variety w addr dep_a dep_d : WriteReq.t n:= + WriteReq.make _ addr (access_kind_of_AK kind_strength kind_variety) w None tt false (Some dep_a) (Some dep_d). + + (* making [ReadReq] *) + Definition readreq_of_store {n} kind_strength kind_variety addr dep_a : ReadReq.t n:= + ReadReq.make _ addr (access_kind_of_AK kind_strength kind_variety) None tt false (Some dep_a). + + Definition empty_depon := Some (DepOn.make [] []). + + (* interp of instructions *) + Definition InstrInterp (i : Instruction) : iMon () := + match i with + | ILoad ks kv r ae => + addr ← AEInterp ae; + Next (MemRead AAArch.val_size (readreq_of_store ks kv addr (dep_of_AE ae))) + (* bool is for cheri tags *) + (fun (out: (bv _ * option bool + abort)) => + match out with + | inl (w, _) => Next (RegWrite r true (Some (DepOn.make [] [0%N])) w) (fun _ => Ret tt) + (* Unreachable, since abort is empty *) + | inr _ => Ret tt end);; + IncPCInterp + | IStore ks kv r ae1 ae2 => + w ← AEInterp ae1; + addr ← AEInterp ae2; + Next (MemWrite _ (writereq_of_store ks kv w addr (dep_of_AE ae2) (dep_of_AE ae1))) + (* bool is for atomic write success *) + (fun (out: option bool + abort) => + match out with + | inl None => Ret tt + (* NOTE: No dependencies on result bit *) + | inl (Some b) => Next (RegWrite r true empty_depon (bool_to_bv _ b)) (fun _ => Ret tt) + (* Unreachable, since abort is empty *) + | _ => Ret tt end);; + IncPCInterp + | IDmb dκ => Next (Barrier (AAArch.DMB dκ)) (fun _ => Ret tt);; + IncPCInterp + | IIsb => Next (Barrier AAArch.ISB) (fun _ => Ret tt);; + IncPCInterp + | IAssign r ae => + w ← AEInterp ae; + Next (RegWrite r true (Some (dep_of_AE ae)) w) (fun _ => Ret tt);; + IncPCInterp + | IBr addr => Next (RegWrite RNPC true empty_depon addr) (fun _ => Ret tt) + | IBne ae addr => + w ← AEInterp ae; + (* NOTE: This is not how [BranchAnnounce] is supposed to be used *) + Next (BranchAnnounce addr (Some (dep_of_AE ae))) (fun _ => Ret tt);; + if (bool_decide (w = Z_to_bv _ 0)) + then IncPCInterp + else Next (RegWrite RNPC true empty_depon addr) (fun _ => Ret tt) + | INop => IncPCInterp + end. + + Definition EmptyInterp : iMon () := Ret tt. + +End interpretation. diff --git a/theories/lang/machine.v b/theories/lang/machine.v new file mode 100644 index 0000000..b5b2d62 --- /dev/null +++ b/theories/lang/machine.v @@ -0,0 +1,55 @@ +(** This file includes our instantiation of [CandidateExecutions], + and wrappers for types of [system-semantics-coq] *) +Require Import stdpp.strings. +Require Import stdpp.unstable.bitvector. + +Require Export self.CandidateExecutions. +Require Import ISASem.Interface. +Require Export ISASem.SailArmInstTypes. +Require Import SSCCommon.Common. + +Open Scope stdpp_scope. +Definition AAval (n : N):= bv (8 * n). + + +Module AAArch <: Arch. + Definition reg := string. + Definition reg_eq : EqDecision reg := _. + Definition reg_countable : @Countable reg reg_eq := _. + Definition val_size : N := 8. + Definition val := AAval val_size. + Definition reg_type := val. + (* addresses and registers are of the same length for simplicity *) + Definition va_size := 64%N. + Definition pa := val. + Definition pa_eq : EqDecision pa := _. + Definition pa_countable : @Countable pa pa_eq := _. + Definition arch_ak := unit. + Definition translation := unit. + Inductive dmb_kind := | Sy | Ld | St. + Inductive barrier_type := + | DMB (k : dmb_kind) | ISB. + Definition barrier := barrier_type. + (* below are not used, so empty *) + Definition abort := False. + Definition cache_op := False. + Definition tlb_op := False. + Definition fault := False. +End AAArch. + +Module AAInter <: InterfaceT AAArch := Interface AAArch. +Module AACandExec := CandidateExecutions AAArch AAInter. + +Definition Val := AAArch.val. +Definition Addr := AAArch.val. +Definition RegName := AAInter.reg. +Definition DmbKind := AAArch.dmb_kind. +Definition BarrierKind := AAArch.barrier. + +Definition InstTrace := AACandExec.iTrace (). +Definition InstSem := AACandExec.iMon (). +Definition Event := AACandExec.iEvent. +Notation Eid := EID.t. + +Require Import SSCCommon.GRel. +Notation Rel := (grel Eid) (only parsing). diff --git a/theories/lang/mm.v b/theories/lang/mm.v new file mode 100644 index 0000000..80378c7 --- /dev/null +++ b/theories/lang/mm.v @@ -0,0 +1,2506 @@ +(* This file contains the memory model *) + + +From SSCCommon Require Import Common CSets GRel. + +Require Import ISASem.SailArmInstTypes. + +Require Import stdpp.prelude. +Require Import stdpp.unstable.bitvector. + +Require Export self.lang.machine. + +Require Import ssreflect. + +Open Scope stdpp_scope. + + +Ltac match_inversion := + repeat (match goal with + | [ HH : Some _ = None |- _ ] => inversion HH + | [ HH : None = Some _ |- _ ] => inversion HH + | [ HH : false |- _ ] => inversion HH + | [ HH : Some ?x = Some _ |- _ ] => inversion HH;subst x;clear HH + | _ => case_match + end). + +Module AAConsistent. + + Import AACandExec. + Import AACandExec.Candidate. + Export ISASem.SailArmInstTypes. + + Definition event_is_isb (event: Event) := + match event with + | AAInter.IEvent (AAInter.Barrier AAArch.ISB) _ => true + | _ => false end. + + Definition isbs (cd : t) := + collect_all event_is_isb cd. + + #[local] Instance dmb_kind_eqdec : (EqDecision AAArch.dmb_kind). + Proof. intros ??. destruct x, y; try (left;done);right;done. Qed. + + Definition event_is_dmb (κ: AAArch.dmb_kind) (event: Event) := + match event with + | AAInter.IEvent (AAInter.Barrier (AAArch.DMB κ')) _ => (bool_decide (κ=κ')) + | _ => false end. + + Definition dmbs (cd : t) (κ: AAArch.dmb_kind) := + collect_all (event_is_dmb κ) cd. + + Definition value_of_wreq {n} (req: AAInter.WriteReq.t n) := + req.(AAInter.WriteReq.value). + + Definition addr_of_wreq {n} (req: AAInter.WriteReq.t n) := + req.(AAInter.WriteReq.pa). + + (* This is annoying since the interface allows writing arbitraty bytes to memory, we have + to make sure the number of bytes is [AAArch.val_size]*) + Program Definition addr_and_value_of_wreq {n} (req: AAInter.WriteReq.t n) : + option (Addr * Val). + destruct req as []. + destruct (decide (n = AAArch.val_size)). + { + subst n. + exact (Some (pa,value)). + } + exact None. + Defined. + + Definition addr_of_rreq {n} (req: AAInter.ReadReq.t n) : Addr := req.(AAInter.ReadReq.pa). + + Program Definition value_of_read (event : Event) : option Val. + destruct event as [? []]. + exact None. + exact None. + destruct t1; last exact None. + destruct p. + destruct (decide (n = AAArch.val_size)). + { + subst n. + exact (Some b). + } + all : exact None. + Defined. + + (** write *) + Definition event_is_write_with_P (event : Event) (P : ∀ n : N, AAInter.WriteReq.t n -> bool) := + match event with + | AAInter.IEvent (AAInter.MemWrite n wreq) wresp => wreq_is_valid wreq && wresp_is_valid wresp && P n wreq + | _ => false end. + #[global] Hint Unfold event_is_write_with_P : all. + + Definition event_is_pln_write (event : Event) := + event_is_write_with_P event (λ _ wreq, kind_of_wreq_P wreq + (λ κ, bool_decide (κ = (Build_Explicit_access_kind AV_plain AS_normal)))). + #[global] Hint Unfold event_is_pln_write : all. + + Definition event_is_rel (event : Event) := + event_is_write_with_P event (λ _ wreq, kind_of_wreq_P wreq + (λ κ, bool_decide (κ.(Explicit_access_kind_strength) = AS_rel_or_acq))). + #[global] Hint Unfold event_is_rel : all. + + Definition event_is_xcl_write (event : Event) := + event_is_write_with_P event (λ _ wreq, + (* kind_of_wreq_P wreq *) + (* (λ κ, bool_decide (Explicit_access_kind_strength κ= AS_normal)) *) + (* && *) + kind_of_wreq_is_atomic wreq). + #[global] Hint Unfold event_is_xcl_write : all. + + Definition event_is_write_with (event : Event) (ks : Access_strength) (kv : Access_variety) (a : Addr) (v : Val) := + event_is_write_with_P event (λ _ wreq, kind_of_wreq_P wreq + (λ κ, bool_decide (κ = (Build_Explicit_access_kind kv ks))) && + bool_decide (addr_and_value_of_wreq wreq = Some (a,v))). + #[global] Hint Unfold event_is_write_with : all. + + Definition event_is_write_with_addr (event : Event) (a : Addr) := + event_is_write_with_P event (λ _ wreq, bool_decide (addr_of_wreq wreq = a)). + #[global] Hint Unfold event_is_write_with_addr : all. + + Definition event_is_write_with_kind (event : Event) (ks : Access_strength) (kv : Access_variety) := + event_is_write_with_P event (λ _ wreq, + kind_of_wreq_P wreq (λ κ, bool_decide (κ = (Build_Explicit_access_kind kv ks)))). + #[global] Hint Unfold event_is_write_with_kind : all. + + Definition event_is_write (event : Event) := + event_is_write_with_P event (λ _ _, true). + #[global] Hint Unfold event_is_write : all. + + Lemma event_is_write_with_elem_of_mem_writes {gr} (e : Eid) (event : Event) (ks : Access_strength) + (kv : Access_variety) (a : Addr) (v : Val) : + gr !! e = Some event -> + event_is_write_with event ks kv a v -> + e ∈ AACandExec.Candidate.mem_writes gr. + Proof. + intros Hlk Hw. set_unfold. unfold event_is_write_with in Hw. + unfold event_is_write_with_P in Hw. + case_match;case_match; try contradiction. + rewrite bool_unfold in Hw. + destruct_and? Hw. + unfold wreq_is_valid. unfold kind_of_wreq_P in H1. + sauto. + Qed. + + Lemma event_is_write_elem_of_mem_writes {gr} (e : Eid) (event : Event) (a : Addr) : + gr !! e = Some event -> + event_is_write_with_addr event a -> + e ∈ AACandExec.Candidate.mem_writes gr. + Proof. + intros Hlk Hw. set_unfold. unfold event_is_write_with in Hw. + unfold event_is_write_with_addr, event_is_write_with_P in Hw. + case_match;case_match; try contradiction. + rewrite bool_unfold in Hw. + destruct_and? Hw. + unfold wreq_is_valid. + sauto. + Qed. + + Lemma mem_wf_spec_write gr: + NMSWF.mem_wf gr -> + forall eid event, + gr !! eid = Some event -> + eid ∈ mem_writes gr -> + event_is_write event. + Proof. + intros Hwf ?? Hlk Hw. + unfold event_is_write, event_is_write_with_P. + set_unfold. destruct Hw as (?&?&?&?). + rewrite Hlk in H. + match_inversion;subst. + rewrite /NMSWF.mem_wf in Hwf. + rewrite bool_unfold in Hwf. + set_unfold. + specialize (Hwf eid). + rewrite bool_unfold. left. + eapply (Classical_Pred_Type.not_ex_all_not _ _ ) in Hwf. + Unshelve. 2: exact ((AAInter.IEvent (AAInter.MemWrite x x0) x1)). + eapply not_and_l in Hwf. + Unshelve. 2:{ left. done. } + destruct Hwf. done. + rewrite bool_unfold in H. + destruct (decide ((wreq_is_valid x0 ∧ wresp_is_valid x1))). + done. apply H in n. done. + Qed. + + + Lemma event_is_write_elem_of_mem_writes2 {gr} (e : Eid) : + NMSWF.wf gr -> + e ∈ AACandExec.Candidate.mem_writes gr -> + ∃ (event : Event), gr !! e = Some event ∧ event_is_write event. + Proof. + intros Hwf Hin. set_unfold. + assert (NMSWF.mem_wf gr). + { rewrite /NMSWF.wf in Hwf. naive_solver. } + + destruct Hin as [? [? [? HE]]]. + + pose proof (mem_wf_spec_write gr H e _ HE). + feed specialize H0. + set_unfold. do 3 eexists. eassumption. + eexists. split;eauto. + Qed. + + Lemma event_is_write_with_addr_elem_of_mem_writes {gr} (e : Eid) (event : Event) (a : Addr) : + gr !! e = Some event -> + event_is_write_with_addr event a -> + e ∈ AACandExec.Candidate.mem_writes gr. + Proof. + intros Hlk Hw. set_unfold. + destruct event;auto;destruct o;auto;try inversion Hw. + simpl in Hw. repeat eexists;eauto. + Qed. + + Lemma event_is_write_with_addr_elem_of_mem_writes2 {gr} (e : Eid) : + NMSWF.wf gr -> + e ∈ AACandExec.Candidate.mem_writes gr -> + ∃ (event : Event) (a : Addr), gr !! e = Some event ∧ event_is_write_with_addr event a. + Proof. + intros Hwf Hin. set_unfold. + assert (NMSWF.mem_wf gr). + { rewrite /NMSWF.wf in Hwf. naive_solver. } + destruct Hin as [? [? [? HE]]]. + pose proof (mem_wf_spec_write gr H e _ HE). feed specialize H0. set_unfold. do 3 eexists. eassumption. + eexists. exists (addr_of_wreq x0). split;eauto. + simpl. rewrite bool_unfold. simpl in H0. rewrite bool_unfold in H0. clear H HE. + naive_solver. + Qed. + + Lemma event_is_write_with_P_impl (event : Event) (P Q : ∀ n : N, AAInter.WriteReq.t n -> bool) : + (forall n wreq, P n wreq -> Q n wreq) -> + event_is_write_with_P event P -> event_is_write_with_P event Q. + Proof. + intros Himp HP. destruct event;auto;destruct o;auto. simpl in *. + rewrite ->bool_unfold in *; split; naive_solver. + Qed. + + Lemma event_is_write_with_impl_addr (event : Event) (ks : Access_strength) (kv : Access_variety) + (a : Addr) (v : Val) : + event_is_write_with event ks kv a v -> event_is_write_with_addr event a. + Proof. + apply event_is_write_with_P_impl. + intros. + repeat rewrite ->bool_unfold in *. + simpl. unfold addr_and_value_of_wreq in H. destruct H as [_ H]. + case_match;auto. + case_match;auto. + unfold eq_rec_r, eq_rec in H. subst n. + rewrite <-Classical_Prop.Eq_rect_eq.eq_rect_eq in H. + inversion H. done. done. + Qed. + + Lemma event_is_write_with_impl_kind (e : Eid) (event : Event) (ks : Access_strength) (kv : Access_variety) (a : Addr) (v : Val) : + event_is_write_with event ks kv a v -> event_is_write_with_kind event ks kv. + Proof. + apply event_is_write_with_P_impl. + intros. unfold kind_of_wreq_P in *. + rewrite -> bool_unfold in *. + hauto lq:on. + Qed. + + (** read *) + Definition event_is_read_with_P (event : Event) (P : ∀ n : N, AAInter.ReadReq.t n -> bool) := + match event with + | AAInter.IEvent (AAInter.MemRead n rreq) rresp => rreq_is_valid rreq && rresp_is_valid rresp && P n rreq + | _ => false end. + #[global] Hint Transparent event_is_read_with_P : all. + + Definition event_is_read (event : Event) := + event_is_read_with_P event (λ _ _, true). + + Definition event_is_pln_read (event : Event) := + event_is_read_with_P event (λ _ rreq, kind_of_rreq_P rreq (λ κ, bool_decide (κ = (Build_Explicit_access_kind AV_plain AS_normal)))). + + Definition event_is_acq (event : Event) := + event_is_read_with_P event (λ _ rreq, kind_of_rreq_P rreq (λ κ, bool_decide (κ = (Build_Explicit_access_kind AV_plain AS_rel_or_acq)))). + + Definition event_is_xcl_read (event : Event) := + event_is_read_with_P event (λ _ rreq, kind_of_rreq_P rreq (λ κ, bool_decide ((Explicit_access_kind_strength κ = AS_normal))) + && kind_of_rreq_is_atomic rreq). + + Definition event_is_wacq (event : Event) := + event_is_read_with_P event (λ _ rreq, kind_of_rreq_P rreq (λ κ, bool_decide (κ = (Build_Explicit_access_kind AV_plain AS_acq_rcpc)))). + + Definition event_is_read_with (event : Event) (ks : Access_strength) (kv : Access_variety) (a : Addr) (v : Val) := + event_is_read_with_P event (λ _ rreq, + kind_of_rreq_P rreq (λ κ, bool_decide (κ = (Build_Explicit_access_kind kv ks))) && + bool_decide (addr_of_rreq rreq = a) && + bool_decide (value_of_read event = Some v) + ). + + Definition event_is_read_with_kind (event : Event) (ks : Access_strength) (kv : Access_variety) := + event_is_read_with_P event (λ _ rreq, + bool_decide(kind_of_rreq_P rreq (λ κ, bool_decide (κ = Build_Explicit_access_kind kv ks)))). + + Definition event_is_read_with_addr (event : Event) (a : Addr) := + event_is_read_with_P event (λ _ rreq, bool_decide (addr_of_rreq rreq = a)). + + Lemma mem_wf_spec_read gr: + NMSWF.mem_wf gr -> + forall eid event, + gr !! eid = Some event -> + eid ∈ mem_reads gr -> + event_is_read event. + Proof. + intros Hwf ?? Hlk Hw. + unfold event_is_read, event_is_read_with_P. + set_unfold. destruct Hw as (?&?&?&?). + rewrite Hlk in H. + match_inversion;subst. + rewrite /NMSWF.mem_wf in Hwf. + rewrite bool_unfold in Hwf. + set_unfold. + specialize (Hwf eid). + rewrite bool_unfold. left. + eapply (Classical_Pred_Type.not_ex_all_not _ _ ) in Hwf. + Unshelve. 2: exact ((AAInter.IEvent (AAInter.MemRead x x0) x1)). + eapply not_and_l in Hwf. + Unshelve. 2:{ left. done. } + destruct Hwf. done. + rewrite bool_unfold in H. + destruct (decide ((rreq_is_valid x0 ∧ rresp_is_valid x1))). + done. apply H in n. done. + Qed. + + Lemma event_is_read_with_P_impl (event : Event) (P Q : ∀ n : N, AAInter.ReadReq.t n -> bool) : + (forall n rreq, P n rreq -> Q n rreq) -> + event_is_read_with_P event P -> event_is_read_with_P event Q. + Proof. + intros Himp HP. destruct event;auto;destruct o;auto. simpl in *. + rewrite ->bool_unfold in *; split; naive_solver. + Qed. + + Lemma event_is_read_with_impl_addr (e : Eid) (event : Event) (ks : Access_strength) (kv : Access_variety) (a : Addr) (v : Val) : + event_is_read_with event ks kv a v -> event_is_read_with_addr event a. + Proof. + apply event_is_read_with_P_impl. + intros. unfold kind_of_wreq_P in *. + repeat rewrite -> bool_unfold in *. + hauto lq:on. + Qed. + + + Lemma event_is_read_with_impl_kind (e : Eid) (event : Event) (ks : Access_strength) (kv : Access_variety) (a : Addr) (v : Val) : + event_is_read_with event ks kv a v -> event_is_read_with_kind event ks kv. + Proof. + apply event_is_read_with_P_impl. + intros. unfold kind_of_wreq_P in *. + repeat rewrite ->bool_unfold in *. + hauto lq:on. + Qed. + + Definition rel_writes (cd : t) := + collect_all event_is_rel cd. + + Definition acq_reads (cd : t) := + collect_all event_is_acq cd. + + Definition wacq_reads (cd : t) := + collect_all event_is_wacq cd. + + Definition pln_writes (cd : t) := + collect_all event_is_pln_write cd. + + Definition pln_reads (cd : t) := + collect_all event_is_pln_read cd. + + Definition xcl_reads (cd : t) := + collect_all event_is_xcl_read cd. + + Definition xcl_writes (cd : t) := + collect_all event_is_xcl_write cd. + + Definition dob (cd : t) : Rel := + let writes := mem_writes cd in + let reads := mem_reads cd in + let isb := isbs cd in + let addr := addr cd in + let data := data cd in + let ctrl := ctrl cd in + let po := cd.(po) in + let coi := internal_of cd.(co) in + let rfi := internal_of cd.(rf) in + data + ∪ addr + ∪ (ctrl⨾⦗writes⦘) + ∪ ((ctrl ∪ (addr ⨾ po))⨾⦗isb⦘⨾po⨾⦗reads⦘) + ∪ (addr⨾po⨾⦗writes⦘) + ∪ ((ctrl ∪ data)⨾ coi) + ∪ ((addr ∪ data)⨾ rfi). + + Definition bob (cd : t) : Rel := + let po := cd.(po) in + let dmb_sy := dmbs cd (AAArch.Sy) in + let dmb_ld := dmbs cd (AAArch.Ld) in + let dmb_st := dmbs cd (AAArch.St) in + let rel := rel_writes cd in + let acq := acq_reads cd in + let wacq := wacq_reads cd in + let writes := mem_writes cd in + let reads := mem_reads cd in + let coi := internal_of cd.(co) in + (po⨾⦗dmb_sy⦘⨾po) + ∪ (⦗rel⦘⨾po⨾⦗acq⦘) + ∪ (⦗reads⦘⨾po⨾⦗dmb_ld⦘⨾po) + ∪ ((⦗wacq⦘∪⦗acq⦘)⨾ po) + ∪ (⦗writes⦘⨾po⨾⦗dmb_st⦘⨾po⨾⦗writes⦘) + ∪ (po⨾⦗rel⦘) + ∪ (po⨾⦗rel⦘⨾coi). + + Definition obs (cd : t) : Rel := + external_of (cd.(rf)) ∪ external_of (cd.(co)) ∪ external_of (fr cd). + + Definition aob (cd : t) : Rel := + let rfi := internal_of cd.(rf) in + let rmw := (rmw cd) in + let acq := acq_reads cd in + let wacq := wacq_reads cd in + rmw ∪ (⦗grel_rng rmw⦘⨾ rfi⨾ (⦗wacq⦘∪⦗acq⦘)). + + Definition lob (cd : t) : Rel := (dob cd) ∪ (aob cd) ∪ (bob cd). + + Definition ob (cd : t) : Rel := ((obs cd) ∪ (lob cd))⁺. + + Definition ind_lob (cd : t) : Rel := (internal_of (ob cd)). + + Definition ca (cd : t) : Rel := (fr cd) ∪ (co cd). + + Record t cd := { + internal : grel_acyclic (((po cd) ∩ (loc cd)) ∪ (ca cd) ∪ (rf cd)); + external : grel_irreflexive (ob cd); + atomic : bool_decide (((rmw cd) ∩ ((external_of (fr cd))⨾(external_of (co cd)))) = ∅); + }. + +End AAConsistent. + +(* memory graph *) +Module Graph. + Export AACandExec. + Export AAConsistent. + Export NMSWF. + + (** helper notations and definitions *) + Definition t := Candidate.t. + + Definition iids_of (eids : gset Eid) : gset nat := + set_map (fun eid => eid.(EID.iid)) eids. + + Definition is_po gr oe_src e_tgt := + from_option (λ e_src, (e_src, e_tgt) ∈ gr.(Candidate.po)) True oe_src. + + Notation is_local_edge_of tid := (fun '(es,et) => es.(EID.tid) = tid ∧ et.(EID.tid) = tid). + Notation is_external_edge_of := (fun '(es,et) => es.(EID.tid) ≠ et.(EID.tid)). + + Notation is_local_node_of tid := (fun e => e.(EID.tid) = tid). + Definition local_eids (gr : Candidate.t) (tid : nat) := + filter (is_local_node_of tid) (Candidate.valid_eid gr). + + Notation is_rf gr e_src e_tgt := ((e_src, e_tgt) ∈ gr.(Candidate.rf)). + + Definition lob_pred_of (gr : Candidate.t) (e : Eid) := + grel_dom (filter (fun '(es,et) => et = e) (lob gr)). + + Definition lob_succ_of (gr : Candidate.t) (e : Eid) := + grel_rng (filter (fun '(es,et) => es = e) (lob gr)). + + Definition ind_lob_pred_of (gr : Candidate.t) (e : Eid) := + grel_dom (filter (fun '(es,et) => et = e) (ind_lob gr)). + + Definition ind_lob_succ_of (gr : Candidate.t) (e : Eid) := + grel_rng (filter (fun '(es,et) => es = e) (ind_lob gr)). + + Definition obs_pred_of (gr : Candidate.t) (e : Eid) := + grel_dom (filter (fun '(es,et) => et = e) (obs gr)). + + Definition ob_pred_of (gr : Candidate.t) (e : Eid) := + grel_dom (filter (fun '(es,et) => et = e) (ob gr)). + + Definition obs_succ_of (gr : Candidate.t) (e : Eid) := + grel_rng (filter (fun '(es,et) => es = e) (obs gr)). + + Definition ob_succ_of (gr : Candidate.t) (e : Eid) := + grel_rng (filter (fun '(es,et) => es = e) (ob gr)). + + Definition po_pred_of (gr : Candidate.t) (e : Eid) := + grel_dom (filter (fun '(es,et) => et = e) (gr.(Candidate.po))). + + Ltac pattern_evar := + match goal with | |- context G [?x] => is_evar x; pattern x end. + + Ltac match_inversion := + repeat (match goal with + | [ HH : Some _ = None |- _ ] => inversion HH + | [ HH : None = Some _ |- _ ] => inversion HH + | [ HH : false |- _ ] => inversion HH + | [ HH : Some ?x = Some _ |- _ ] => inversion HH;subst x;clear HH + | _ => case_match + end). + (** Below are axiomised results about the consistency and well-formedness of execution graphs *) + + (** well-formedness *) + (* if two events are related by the auxilary [loc] relation and one is a write on [addr], + then the other must be a read or write on [addr] as well *) + Lemma wf_loc_inv_writes {gr} eid_w eid addr: + NMSWF.wf gr -> + (exists E1, gr !! eid_w = Some E1 ∧ event_is_write_with_addr E1 addr) -> + (eid_w, eid) ∈ AACandExec.Candidate.loc gr -> + (exists E2, gr !! eid = Some E2 ∧ (event_is_write_with_addr E2 addr ∨ event_is_read_with_addr E2 addr)). + Proof. + rewrite /event_is_write_with_addr /event_is_read_with_addr /wf. + intros Hwf Hlk Hloc. + assert (NMSWF.mem_wf gr) as Hmwf by naive_solver. clear Hwf. + + destruct Hlk as (?&Hlk&?). + set_unfold. + destruct Hloc as (?&?&?&Hlk'&?&?&?). + rewrite Hlk in Hlk'. inversion Hlk';subst;clear Hlk'. + eexists. split;first eassumption. + + rewrite /event_is_write_with_P in H. + match_inversion;try contradiction;rewrite bool_unfold in H;subst;simpl in H2;match_inversion. + + destruct_and ? H. + simpl in H0. inversion H0;subst x2. rewrite /addr_of_wreq in H4. rewrite H4 in H2. clear H4 H5 H Hlk H0. + + rewrite /Candidate.get_pa in H2. + match_inversion;try contradiction;subst;simpl. + pose proof (mem_wf_spec_read _ Hmwf eid _ H1). + feed specialize H. set_unfold. do 3 eexists. eassumption. + right. rewrite bool_unfold. inversion H2;subst addr. + simpl in H. rewrite bool_unfold in H. naive_solver. + + left. rewrite bool_unfold. inversion H2;subst addr. + pose proof (mem_wf_spec_write _ Hmwf eid _ H1). + feed specialize H. set_unfold. do 3 eexists. eassumption. + simpl in H. rewrite bool_unfold in H. naive_solver. + Qed. + + (* two writes on the same address are ordered by [loc] *) + Lemma wf_loc_inv_writes2 {gr} eid_w eid: + (exists addr E1 E2, gr !! eid_w = Some E1 ∧ event_is_write_with_addr E1 addr ∧ gr !! eid = Some E2 ∧ event_is_write_with_addr E2 addr) -> + (eid_w, eid) ∈ AACandExec.Candidate.loc gr. + Proof. + rewrite /event_is_write_with_addr /event_is_write_with_P. + intros (?&?&?&?&?&?&?). + set_unfold. + match_inversion;try contradiction;rewrite bool_unfold in H0;subst;simpl in H2;match_inversion. + rewrite bool_unfold in H2. destruct H0,H2. + do 2 eexists. exists x. + rewrite /Candidate.get_pa. + rewrite /addr_of_wreq in H3. rewrite /addr_of_wreq in H4. + split;first eassumption. + simpl. split. f_equal. done. split;first eassumption. + simpl. f_equal. done. + Qed. + + (* in a well-formed graph, a read event [e] must read the value [val] from a write event on the same address [addr], + (is ordered by [rf]) *) + Lemma wf_read_inv gr e E addr kind_s kind_v val: + wf gr -> + gr !! e = Some E -> + AAConsistent.event_is_read_with E kind_s kind_v addr val -> + ∃ eid_w kind_s_w kind_s_v E_w, + gr !! eid_w = Some E_w ∧ + AAConsistent.event_is_write_with E_w kind_s_w kind_s_v addr val ∧ + (eid_w, e) ∈ AACandExec.Candidate.rf gr. + Proof. + rewrite /event_is_read_with /event_is_read_with_P /wf. + intros Hwf Hlk Hread. + assert (rf_wf gr) as Hwf_rf by naive_solver;rewrite /rf_wf in Hwf_rf. + assert (mem_wf gr) as Hwf_mem by naive_solver;clear Hwf. + rewrite bool_unfold in Hwf_rf. + destruct_and ? Hwf_rf. + + repeat case_match;try contradiction. + destruct_and ? Hread. + assert (Hin : e ∈ grel_rng (Candidate.rf gr)). + { rewrite H3. set_unfold. repeat eexists. eassumption. } + set_unfold in Hin. destruct Hin as [e_w Hrf]. + exists e_w. specialize (H e_w). feed specialize H. set_solver + Hrf. + set_unfold in H. destruct H as (?&?&?&?). + (* rewrite bool_unfold in H5. destruct H5 as [? ?]. rewrite /Candidate.wreq_is_valid in H5. *) + (* case_match; try contradiction. destruct e0. *) + specialize (H0 (e_w,e) Hrf). + set_unfold in H0. + + + destruct H0 as [(?&?&?&Hlk1&?&Hlk2&?) (?&?&?&Hlk1'&?&Hlk2'&?)]. + rewrite Hlk1 in Hlk1'. rewrite Hlk2 in Hlk2'. + inversion Hlk1';subst x5;clear Hlk1'. + inversion Hlk2';subst x6;clear Hlk2'. + rewrite Hlk1 in H. rewrite Hlk2 in Hlk. + inversion H;subst x2;clear H. inversion Hlk;subst x3;clear Hlk. + + pose proof (mem_wf_spec_write _ Hwf_mem _ _ Hlk1). + feed specialize H. + set_unfold. do 3 eexists. eassumption. simpl in H. rewrite bool_unfold in H. destruct H as [[ ? ?] |];last done. + rewrite /Candidate.wreq_is_valid in H. + match_inversion;[| contradiction | contradiction | contradiction ]. + destruct e0. + + + repeat eexists. eassumption. rewrite /event_is_write_with /event_is_write_with_P. + do 2 pattern_evar. setoid_rewrite bool_unfold. + split;auto. split;auto. rewrite /Candidate.wreq_is_valid. hauto lq:on. + split. rewrite /Candidate.kind_of_wreq_P. rewrite H14. + do 2 pattern_evar. setoid_rewrite bool_unfold. reflexivity. + rewrite /addr_and_value_of_wreq. + + case_match eqn:HE. + + 2:assumption. + + (* reasoning about val_size is painful, also there seems to be redundant conditions *) + destruct (decide (x = AAArch.val_size)). + { + rewrite /eq_rec_r. rewrite /eq_rec. subst. simpl. + f_equal. + + destruct t0. destruct p. simpl in H9. + simpl in H12. + simpl in H5. simpl in H0. + + + match_inversion. + inversion H5;subst x4. + apply pair_eq. + rewrite /addr_of_rreq. + split;first reflexivity. + + rewrite /eq_rect_r in H9. + rewrite <-Classical_Prop.Eq_rect_eq.eq_rect_eq in H9. + match_inversion. + simpl in H11. + inversion H11;done. + simpl in H9. + match_inversion. + } + { + destruct t0. destruct p. simpl in H11. + match_inversion. + rewrite /AAArch.val_size in n0. lia. + simpl in H11. + match_inversion. + rewrite /AAArch.val_size in n0. lia. + } + Qed. + + (* in a well formed graph, a read reads from only one write *) + Lemma wf_read_single gr w w' r: + wf gr -> + Graph.is_rf gr w r -> + Graph.is_rf gr w' r -> + w = w'. + Proof. + intros Hwf Hrf1 Hrf2. + rewrite /wf in Hwf. + assert (rf_wf gr) as Hwf_rf by naive_solver;rewrite /rf_wf in Hwf_rf. + rewrite bool_unfold in Hwf_rf. + destruct_and ? Hwf_rf. + set_unfold. + rewrite grel_functional_spec in H2. + eapply H2. + rewrite grel_inv_spec. eassumption. + rewrite grel_inv_spec. eassumption. + Qed. + + + (* well-formed [rfi] is included in [po] *) + Lemma wf_rfi_inv {gr} eid_w eid: + wf gr -> + AAConsistent.t gr -> + Graph.is_rf gr eid_w eid -> + (EID.tid eid_w) = (EID.tid eid) -> + (eid_w, eid) ∈ AACandExec.Candidate.po gr. + Proof. + intros Hwf Hcs Hrf Hsth. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. destruct_and ? Hpo_wf. + assert (rf_wf gr) as Hrf_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rf_wf in Hrf_wf. destruct_and ? Hrf_wf. + assert (initial_wf gr) as Hinitial_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /initial_wf in Hinitial_wf. destruct_and ? Hinitial_wf. + assert (eid_w ∈ Candidate.mem_writes gr) as Hw. set_solver + Hrf H1. + assert (eid ∈ Candidate.non_initial_eids gr). + { + clear H11 H13 H10 H2 H8. + assert (eid ∈ Candidate.mem_reads gr). rewrite -H9. set_solver + Hrf. + assert (eid ∉ Candidate.mem_writes_pln_zero gr). + clear -H2. set_unfold. destruct H2 as (?&?&?&?). + apply Classical_Pred_Type.all_not_not_ex. + intros. intros []. + rewrite H in H0;inversion H0;subst n. contradiction. + clear - H7 H14 H2. + set_unfold. + split. set_unfold. sauto lq:on. + intros Heq. + set_unfold. + specialize (H14 eid). feed specialize H14. sauto lq:on. + clear H2. + sauto. + } + assert ((eid_w, eid) ∈ Candidate.sthd gr). + { clear - Hsth H7 Hw. set_unfold. set_unfold. sauto. } + rewrite -H4 in H15. + apply elem_of_union in H15. destruct H15. + 2:{ + clear - H7 H15. exfalso. set_unfold. hauto lq:on. + } + apply elem_of_union in H15. destruct H15. assumption. + exfalso. + assert ((eid_w,eid) ∈ Candidate.loc gr). apply H6 in Hrf. set_solver + Hrf. + assert ((eid,eid_w) ∈ Candidate.loc gr). set_solver + H16. + assert ((eid,eid_w) ∈ Candidate.po gr ∩ Candidate.loc gr). set_solver + H15 H17. + destruct Hcs. + exfalso. + rewrite grel_irreflexive_spec in internal0. + clear - H18 Hrf internal0. + specialize (internal0 (eid, eid)). simpl in internal0. + apply internal0;last reflexivity. + apply (grel_plus_trans _ _ eid_w); + apply grel_plus_once. + + set_solver + H18. + set_solver + Hrf. + Qed. + + Lemma wf_coi_inv' {gr} eid_w eid: + wf gr -> + AAConsistent.t gr -> + (eid_w, eid) ∈ Candidate.co gr -> + (EID.tid eid_w) = (EID.tid eid) -> + (eid_w, eid) ∈ Candidate.po gr. + Proof. + intros Hwf Hcs Hco Hsth. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. destruct_and ? Hpo_wf. + assert (co_wf gr) as Hco_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /co_wf in Hco_wf. destruct_and ? Hco_wf. + assert (initial_wf gr) as Hinitial_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /initial_wf in Hinitial_wf. destruct_and ? Hinitial_wf. + assert (eid_w ∈ Candidate.mem_writes gr) as Hw. set_solver + Hco H10. + assert (eid ∈ Candidate.non_initial_eids gr). + { + clear -Hco H6 H9. + assert (eid ∈ Candidate.mem_writes gr). set_solver + Hco H9. + set_unfold. + split. + set_unfold. sauto lq:on. + intros Heq. + set_unfold. + specialize (H6 (eid_w,eid)). + sauto lq:on. + } + assert ((eid_w, eid) ∈ Candidate.sthd gr). + { clear - Hsth H1 Hw. set_unfold. set_unfold. sauto. } + rewrite -H4 in H18. + apply elem_of_union in H18. destruct H18. + 2:{ + clear - H1 H18. exfalso. set_unfold. hauto lq:on. + } + apply elem_of_union in H18. destruct H18. assumption. + exfalso. + assert ((eid_w,eid) ∈ Candidate.co gr ∪ (Candidate.co gr) ⁻¹ ∪ ⦗Candidate.mem_writes gr⦘). + set_solver + Hco. + rewrite -H8 in H19. + assert ((eid_w,eid) ∈ Candidate.loc gr). set_solver + H19. + assert ((eid,eid_w) ∈ Candidate.loc gr). set_solver + H20. + assert ((eid,eid_w) ∈ Candidate.po gr ∩ Candidate.loc gr). set_solver + H18 H21. + destruct Hcs. + exfalso. + rewrite grel_irreflexive_spec in internal0. + clear - H22 Hco internal0. + specialize (internal0 (eid, eid)). simpl in internal0. + apply internal0;last reflexivity. + apply (grel_plus_trans _ _ eid_w); + apply grel_plus_once. + + set_solver + H22. + set_solver + Hco. + Qed. + + + (* two writes on the same location are ordered by [coi] if ordered by [po] *) + Lemma wf_coi_inv {gr} eid_w eid: + wf gr -> + AAConsistent.t gr -> + (eid_w, eid) ∈ AACandExec.Candidate.loc gr -> + {[eid_w; eid]} ⊆ AACandExec.Candidate.mem_writes gr -> + (eid_w, eid) ∈ AACandExec.Candidate.po gr -> + (eid_w, eid) ∈ AACandExec.Candidate.co gr. + Proof. + intros Hwf Hcs Hloc Hw Hpo. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. destruct_and ? Hpo_wf. + assert (co_wf gr) as Hco_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /co_wf in Hco_wf. destruct_and ? Hco_wf. + assert ((eid_w, eid) ∈ Candidate.loc gr ∩ (Candidate.mem_writes gr × Candidate.mem_writes gr)). + set_solver + Hw Hloc. + rewrite H8 in H1. + apply elem_of_union in H1. + destruct H1. + 2:{ + exfalso. apply H2 in Hpo. clear - H1 Hpo. set_unfold. destruct H1 as [_ ?]. + destruct eid_w, eid. simpl in *. inversion H. subst. lia. + } + apply elem_of_union in H1. + destruct H1;first assumption. + assert ((eid_w,eid) ∈ Candidate.po gr ∩ Candidate.loc gr). set_solver + Hpo Hloc. + destruct Hcs. exfalso. + rewrite grel_irreflexive_spec in internal0. + clear - H13 H1 internal0. + specialize (internal0 (eid_w, eid_w)). simpl in internal0. + apply internal0;last reflexivity. + apply (grel_plus_trans _ _ eid); + apply grel_plus_once. + + set_solver + H13. + set_solver + H1. + Qed. + + Lemma rfi_subseteq_po gr: + wf gr -> + AAConsistent.t gr -> + Candidate.internal_of (Candidate.rf gr) ⊆ Candidate.po gr. + Proof. + intros Hwf Hcs. intros r Hin. + pose proof (wf_rfi_inv r.1 r.2 Hwf Hcs). + set_unfold in Hin. + apply H;hauto lq:on. + Qed. + + Lemma aob_subseteq_po (gr : Candidate.t): + NMSWF.wf gr -> + AAConsistent.t gr -> + aob gr ⊆ Candidate.po gr. + Proof. + intros Hwf Hcs. + rewrite /aob. + assert (rmw_wf gr) as Hrmw_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rmw_wf in Hrmw_wf. + destruct_and ? Hrmw_wf. + + apply union_subseteq. + split. assumption. + pose proof (rfi_subseteq_po _ Hwf Hcs). + clear - H1. + intros ??. + assert (x ∈ Candidate.internal_of (Candidate.rf gr)). + clear H1. + apply grel_seq_spec in H. + destruct H as (?&?&?). destruct x. assert (x0 = t1) as ->. set_solver + H0. + apply grel_seq_spec in H. + destruct H as (?&?&?). assert (t0 = x) as ->. set_solver + H. + done. + set_solver + H0 H1. + Qed. + + Lemma coi_subseteq_po gr: + wf gr -> + AAConsistent.t gr -> + Candidate.internal_of (Candidate.co gr) ⊆ Candidate.po gr. + Proof. + intros Hwf Hcs. intros r Hin. + pose proof (wf_coi_inv' r.1 r.2 Hwf Hcs). + set_unfold in Hin. + apply H;hauto lq:on. + Qed. + + Lemma bob_subseteq_po (gr : Candidate.t): + NMSWF.wf gr -> + AAConsistent.t gr -> + bob gr ⊆ Candidate.po gr. + Proof. + intros Hwf Hcs. + rewrite /bob. + + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. destruct_and ? Hpo_wf. + clear H0 H2 H3 H4 H. + rewrite grel_transitive_spec in H5. + rewrite !union_subseteq. + repeat split. + - set_unfold. intros ? H. sauto lq:on. + - set_unfold. intros ? H ;sauto lq:on. + - set_unfold. intros ? H. sauto lq:on. + - set_unfold. intros ? H. destruct H as (?&[|]&?);sauto lq:on. + - set_unfold. intros ? H. sauto lq:on. + - set_unfold. intros ? H. sauto lq:on. + - pose proof (coi_subseteq_po _ Hwf Hcs). + set_unfold. intros ? ?. sauto lq:on. + Qed. + + Lemma addr_subseteq_po (gr : Candidate.t): + NMSWF.wf gr -> + Candidate.addr gr ⊆ Candidate.po gr. + Proof. + intros Hwf. + assert (addr_wf gr) as Haddr_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /addr_wf in Haddr_wf. destruct_and ? Haddr_wf. + assumption. + Qed. + + Lemma data_subseteq_po (gr : Candidate.t): + NMSWF.wf gr -> + Candidate.data gr ⊆ Candidate.po gr. + Proof. + intros Hwf. + assert (data_wf gr) as Hdata_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /data_wf in Hdata_wf. destruct_and ? Hdata_wf. + assumption. + Qed. + + Lemma ctrl_subseteq_po (gr : Candidate.t): + NMSWF.wf gr -> + Candidate.ctrl gr ⊆ Candidate.po gr. + Proof. + intros Hwf. + assert (ctrl_wf gr) as Hctrl_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /ctrl_wf in Hctrl_wf. destruct_and ? Hctrl_wf. + assumption. + Qed. + + Opaque Candidate.addr Candidate.data Candidate.ctrl. + + Lemma dob_subseteq_po (gr : Candidate.t): + NMSWF.wf gr -> + AAConsistent.t gr -> + dob gr ⊆ Candidate.po gr. + Proof. + intros Hwf Hcs. + rewrite /dob. + + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. destruct_and ? Hpo_wf. + clear H0 H2 H3 H4 H. + rewrite grel_transitive_spec in H5. + rewrite !union_subseteq. + pose proof (addr_subseteq_po _ Hwf) as Haddr. + pose proof (data_subseteq_po _ Hwf) as Hdata. + pose proof (ctrl_subseteq_po _ Hwf) as Hctrl. + pose proof (coi_subseteq_po _ Hwf Hcs) as Hcoi. + pose proof (rfi_subseteq_po _ Hwf Hcs) as Hrfi. + clear Hwf Hcs. + + repeat split. + - assumption. + - assumption. + - set_unfold. intros ? H. sauto lq:on. + - clear Hdata. set_unfold. intros ? H. destruct H as (?&(?&(?&[|]&?)&?)&?). sauto lq: on rew: off l: on q: on. qblast l: on q: on. + - set_unfold. intros ? H. sauto lq:on. + - set_unfold. intros ? H. destruct H as (?&[|]&?);sauto lq:on. + - set_unfold. intros ? H. destruct H as (?&[|]&?);sauto lq:on. + Qed. + + + (* [lob] is in [po] *) + Lemma lob_subseteq_po (gr : Candidate.t): + NMSWF.wf gr -> + AAConsistent.t gr -> + lob gr ⊆ Candidate.po gr. + Proof. + intros Hwf Hcs. + rewrite /lob. + + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. destruct_and ? Hpo_wf. + clear H0 H2 H3 H4 H. + pose proof (aob_subseteq_po _ Hwf Hcs). + pose proof (dob_subseteq_po _ Hwf Hcs). + pose proof (bob_subseteq_po _ Hwf Hcs). + rewrite 2!union_subseteq. + repeat split; assumption. + Qed. + + (* if two events are ordered by [po], then they are in the same (normal) thread *) + Lemma po_valid_eids gr e1 e2: + NMSWF.wf gr -> + (e1, e2) ∈ gr.(Candidate.po) -> + ({[e1; e2]} ⊆ local_eids gr e1.(EID.tid) ∧ e1.(EID.tid) = e2.(EID.tid) )%nat. + Proof. + intros Hwf Hpo. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + rewrite bool_unfold in Hpo_wf. + destruct_and ? Hpo_wf. + assert ((e1, e2)∈ Candidate.sthd gr). + { rewrite -H4. set_solver + Hpo. } + set_unfold in H1. + clear H H2 H3 H4 H5 Hwf. + set_unfold. + destruct H1 as (?&?&?&?&?&?&?). + split;last sauto. + intros. destruct H4 as [<-|<-]; hauto. + Qed. + + Lemma po_valid_eids' gr e1 e2: + NMSWF.wf gr -> + (e1, e2) ∈ gr.(Candidate.po) -> + e1 ∈ Candidate.valid_eid gr ∧ e2 ∈ Candidate.valid_eid gr. + Proof. + intros Hwf Hpo. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + rewrite bool_unfold in Hpo_wf. + destruct_and ? Hpo_wf. + assert ((e1, e2)∈ Candidate.sthd gr). + { rewrite -H4. set_solver + Hpo. } + set_unfold in H1. + clear H H2 H3 H4 H5 Hwf. + set_unfold. + destruct H1 as (?&?&?&?&?&?&?). + sauto. + Qed. + + (* if two events are ordered by po, the po earlier has a lower event id *) + Lemma po_to_pg_lt gr e1 e2: + NMSWF.wf gr -> + (e1, e2) ∈ gr.(Candidate.po) -> + (e1.(EID.iid) < e2.(EID.iid))%nat ∨ (e1.(EID.iid) = e2.(EID.iid) ∧ e1.(EID.num) < e2.(EID.num))%nat. + Proof. + intros Hwf Hpo. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + rewrite bool_unfold in Hpo_wf. + destruct_and ? Hpo_wf. + assert ((e1, e2)∈ Candidate.sthd gr). + { rewrite -H4. set_solver + Hpo. } + set_unfold in H1. + specialize (H2 _ Hpo). + clear H0 H H3 H4 H1 Hwf. + destruct H2; hauto. + Qed. + + (* for two events on the same thread, the one with the lower event id is po before the other *) + Lemma pg_lt_to_po gr e1 e2: + NMSWF.wf gr -> + e1 ∈ Candidate.valid_eid gr -> + e2 ∈ Candidate.valid_eid gr -> + e1.(EID.tid) ≠ 0%nat -> + e1.(EID.tid) = e2.(EID.tid) -> + (e1.(EID.iid) < e2.(EID.iid))%nat ∨ (e1.(EID.iid) = e2.(EID.iid) ∧ e1.(EID.num) < e2.(EID.num))%nat -> + (e1, e2) ∈ gr.(Candidate.po). + Proof. + intros Hwf He1 He2 Hnz Hsth Hpo. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + rewrite bool_unfold in Hpo_wf. + destruct_and ? Hpo_wf. + assert ((e1, e2)∈ Candidate.sthd gr). + { set_unfold. hauto lq:on. } + rewrite -H4 in H1. + set_unfold in H1. + destruct H1. + destruct H1. assumption. + apply H2 in H1. simpl in H1. lia. + simpl in H1. destruct H1 as (?&?&?). lia. + Qed. + + (* [po] is irreflexive *) + Lemma po_irreflexive gr e1 e2: + NMSWF.wf gr -> + (e1, e2) ∈ gr.(Candidate.po) -> + (e2, e1) ∈ gr.(Candidate.po) -> False. + Proof. + intros Hwf Hpo1 Hpo2. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + rewrite bool_unfold in Hpo_wf. + destruct_and ? Hpo_wf. + apply H2 in Hpo1. + apply H2 in Hpo2. + destruct Hpo1, Hpo2; + lia. + Qed. + + (* [po] is transitive *) + Lemma po_transitive gr e1 e2 e3: + NMSWF.wf gr -> + (e1, e2) ∈ gr.(Candidate.po) -> + (e2, e3) ∈ gr.(Candidate.po) -> + (e1, e3) ∈ gr.(Candidate.po). + Proof. + intros Hwf Hpo1 Hpo2. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + rewrite bool_unfold in Hpo_wf. + destruct_and ? Hpo_wf. + rewrite H5. + eapply grel_plus_trans. + apply grel_plus_once. eassumption. + apply grel_plus_once. eassumption. + Qed. + + Lemma rf_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (Candidate.rf gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (rf_wf gr) as Hrf_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rf_wf in Hrf_wf. + rewrite bool_unfold in Hrf_wf. + destruct_and ? Hrf_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma rf_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (Candidate.rf gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (rf_wf gr) as Hrf_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rf_wf in Hrf_wf. + rewrite bool_unfold in Hrf_wf. + destruct_and ? Hrf_wf. + etransitivity. rewrite H3. reflexivity. + set_solver +. + Qed. + + Lemma co_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (Candidate.co gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (co_wf gr) as Hco_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /co_wf in Hco_wf. + rewrite bool_unfold in Hco_wf. + destruct_and ? Hco_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma co_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (Candidate.co gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (co_wf gr) as Hco_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /co_wf in Hco_wf. + rewrite bool_unfold in Hco_wf. + destruct_and ? Hco_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma fr_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (Candidate.fr gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + rewrite /Candidate.fr. + pose proof (rf_rng_valid gr Hwf). + set_solver + H. + Qed. + + Lemma fr_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (Candidate.fr gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + rewrite /Candidate.fr. + pose proof (co_rng_valid gr Hwf). + set_solver + H. + Qed. + + Lemma obs_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (obs gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + pose proof (rf_dom_valid gr Hwf). + pose proof (fr_dom_valid gr Hwf). + pose proof (co_dom_valid gr Hwf). + rewrite /obs. + set_solver - Hwf. + Qed. + + Lemma obs_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (obs gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + pose proof (rf_rng_valid gr Hwf). + pose proof (fr_rng_valid gr Hwf). + pose proof (co_rng_valid gr Hwf). + rewrite /obs. + set_solver - Hwf. + Qed. + + Lemma rmw_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (Candidate.rmw gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (rmw_wf gr) as Hrmw_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rmw_wf in Hrmw_wf. + rewrite bool_unfold in Hrmw_wf. + destruct_and ? Hrmw_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma rmw_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (Candidate.rmw gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (rmw_wf gr) as Hrmw_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rmw_wf in Hrmw_wf. + rewrite bool_unfold in Hrmw_wf. + destruct_and ? Hrmw_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma aob_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (aob gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + rewrite /aob. + pose proof (rmw_rng_valid gr Hwf). + pose proof (rmw_dom_valid gr Hwf). + set_solver - Hwf. + Qed. + + Lemma aob_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (aob gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + rewrite /aob. + pose proof (rmw_rng_valid gr Hwf). + pose proof (rmw_dom_valid gr Hwf). + set_solver - Hwf. + Qed. + + Lemma data_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (Candidate.data gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (data_wf gr) as Hdata_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /data_wf in Hdata_wf. + rewrite bool_unfold in Hdata_wf. + destruct_and ? Hdata_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma data_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (Candidate.data gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (data_wf gr) as Hdata_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /data_wf in Hdata_wf. + rewrite bool_unfold in Hdata_wf. + destruct_and ? Hdata_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma addr_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (Candidate.addr gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (addr_wf gr) as Haddr_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /addr_wf in Haddr_wf. + rewrite bool_unfold in Haddr_wf. + destruct_and ? Haddr_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma addr_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (Candidate.addr gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (addr_wf gr) as Haddr_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /addr_wf in Haddr_wf. + rewrite bool_unfold in Haddr_wf. + destruct_and ? Haddr_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma ctrl_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (Candidate.ctrl gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (ctrl_wf gr) as Hctrl_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /ctrl_wf in Hctrl_wf. + rewrite bool_unfold in Hctrl_wf. + destruct_and ? Hctrl_wf. + etransitivity. eassumption. + set_solver +. + Qed. + + Lemma po_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (Candidate.po gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + rewrite bool_unfold in Hpo_wf. + destruct_and ? Hpo_wf. + trans (grel_rng (Candidate.sthd gr)). rewrite -H4. set_solver +. + set_solver +. + Qed. + + Lemma po_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (Candidate.po gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + rewrite bool_unfold in Hpo_wf. + destruct_and ? Hpo_wf. + trans (grel_rng (Candidate.sthd gr)). rewrite -H4. set_solver +. + set_solver +. + Qed. + + Lemma ctrl_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (Candidate.ctrl gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + assert (ctrl_wf gr) as Hctrl_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /ctrl_wf in Hctrl_wf. + rewrite bool_unfold in Hctrl_wf. + destruct_and ? Hctrl_wf. + pose proof (po_rng_valid gr Hwf). + etransitivity. + 2: eassumption. + intro. clear Hwf H1 H0 H. + set_unfold;hauto. + Qed. + + Lemma dob_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (dob gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + rewrite /dob. + pose proof (data_dom_valid gr Hwf). + pose proof (ctrl_dom_valid gr Hwf). + pose proof (addr_dom_valid gr Hwf). + rewrite !grel_dom_union. + rewrite !union_subseteq. + split. 2: etrans;[apply grel_seq_dom|]. + split. 2: etrans;[apply grel_seq_dom|]. + split. 2: etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|]]. + split. 2: etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|]]]. + split. 2: etrans;[apply grel_seq_dom|]. + split. all: rewrite ?grel_dom_union. + all: try assumption. + rewrite !union_subseteq. + split. 2: etrans;[apply grel_seq_dom|]. + all: try assumption; rewrite !union_subseteq;split;try assumption. + Qed. + + Lemma dob_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (dob gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + rewrite /dob. + pose proof (co_rng_valid gr Hwf). + pose proof (rf_rng_valid gr Hwf). + pose proof (data_rng_valid gr Hwf). + pose proof (addr_rng_valid gr Hwf). + rewrite !grel_rng_union. + rewrite !union_subseteq. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + split. all: set_solver - Hwf. + Qed. + + Lemma bob_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (bob gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + rewrite /bob. + pose proof (po_dom_valid gr Hwf). + rewrite !grel_dom_union. + rewrite !union_subseteq. + split. 2: etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|]]. + split. 2: etrans;[apply grel_seq_dom|]. + split. 2: etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|]]]]. + split. 2: etrans;[apply grel_seq_dom|]. + split. 2: etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|]]]. + split. 2: etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|]]. + etrans;[apply grel_seq_dom|etrans;[apply grel_seq_dom|]]. + + all: rewrite ?grel_dom_union. + all: try assumption. + all: rewrite ?union_subseteq;try split. + all: set_solver - Hwf. + Qed. + + Lemma bob_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (bob gr) ⊆ (Candidate.valid_eid gr). + Proof. + intros Hwf. + rewrite /bob. + pose proof (co_rng_valid gr Hwf). + pose proof (po_rng_valid gr Hwf). + rewrite !grel_rng_union. + rewrite !union_subseteq. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + split. 2: etrans;[apply grel_seq_rng|]. + etrans;[apply grel_seq_rng|]. + all: set_solver - Hwf. + Qed. + + (* domain of [lob] are valid nodes of the graph *) + Lemma lob_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (lob gr) ⊆ (Candidate.valid_eid gr). + Proof. + rewrite /lob. + intros Hwf. + pose proof (dob_dom_valid gr Hwf). + pose proof (aob_dom_valid gr Hwf). + pose proof (bob_dom_valid gr Hwf). + rewrite 2!grel_dom_union. + rewrite !union_subseteq. + set_solver - Hwf. + Qed. + + (* range of [lob] are valid nodes of the graph *) + Lemma lob_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (lob gr) ⊆ (Candidate.valid_eid gr). + Proof. + rewrite /lob. + intros Hwf. + pose proof (dob_rng_valid gr Hwf). + pose proof (aob_rng_valid gr Hwf). + pose proof (bob_rng_valid gr Hwf). + + rewrite 2!grel_rng_union. + rewrite !union_subseteq. + set_solver - Hwf. + Qed. + + (* domain of [ob] are valid nodes of the graph *) + Lemma ob_dom_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_dom (ob gr) ⊆ (Candidate.valid_eid gr). + Proof. + rewrite /ob. + rewrite grel_dom_plus. + intros Hwf. + pose proof (obs_dom_valid gr Hwf). + pose proof (lob_dom_valid gr Hwf). + rewrite grel_dom_union. + rewrite union_subseteq. + set_solver - Hwf. + Qed. + + (* range of [ob] are valid nodes of the graph *) + Lemma ob_rng_valid (gr : Candidate.t): + NMSWF.wf gr -> + grel_rng (ob gr) ⊆ (Candidate.valid_eid gr). + Proof. + rewrite /ob. + rewrite grel_rng_plus. + intros Hwf. + pose proof (obs_rng_valid gr Hwf). + pose proof (lob_rng_valid gr Hwf). + + rewrite grel_rng_union. + rewrite union_subseteq. + set_solver - Hwf. + Qed. + + (* [acq ; po] is in [lob] *) + Lemma acq_po_subseteq_lob (gr : Candidate.t) e e': + e ∈ acq_reads gr -> + (e, e') ∈ Candidate.po gr -> + (e, e') ∈ lob gr. + Proof. + intros. + rewrite /lob. + apply elem_of_union_r. + rewrite /bob. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_r. + set_unfold. + hauto. + Qed. + + + (* [po ; rel] is in [lob] *) + Lemma po_rel_subseteq_lob (gr : Candidate.t) e e': + (e, e') ∈ Candidate.po gr -> + e' ∈ rel_writes gr -> + (e, e') ∈ lob gr. + Proof. + intros. + rewrite /lob. + apply elem_of_union_r. + rewrite /bob. + apply elem_of_union_l. + apply elem_of_union_r. + set_unfold. + hauto. + Qed. + + + (* [po ; [dmb_sy]; po] is in [lob] *) + Lemma po_dmbsy_po_subseteq_lob (gr : Candidate.t) e e' e'': + (e, e') ∈ Candidate.po gr -> + e' ∈ dmbs gr AAArch.Sy -> + (e', e'') ∈ Candidate.po gr -> + (e, e'') ∈ lob gr. + Proof. + intros. + rewrite /lob. + apply elem_of_union_r. + rewrite /bob. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + set_unfold. + hauto. + Qed. + + (* [ctrl; [w]] is in [lob] *) + Lemma ctrl_w_subseteq_lob (gr : Candidate.t) e e': + (e, e') ∈ Candidate.ctrl gr -> + e' ∈ AACandExec.Candidate.mem_writes gr -> + (e, e') ∈ lob gr. + Proof. + intros. + unfold lob. + do 2 apply elem_of_union_l. + unfold dob. + do 4 apply elem_of_union_l. + apply elem_of_union_r. + set_unfold. + hauto lq: on. + Qed. + + (* [ctrl; [isb]; po] is in [lob] *) + Lemma ctrl_isb_po_subseteq_lob (gr : Candidate.t) e e' e'': + (e, e') ∈ Candidate.ctrl gr -> + e' ∈ isbs gr -> + (e', e'') ∈ Candidate.po gr -> + e'' ∈ Candidate.mem_reads gr -> + (e, e'') ∈ lob gr. + Proof. + intros. + unfold lob. + do 2 apply elem_of_union_l. + unfold dob. + do 3 apply elem_of_union_l. + apply elem_of_union_r. + set_unfold. + hauto lq: on. + Qed. + + (* [addr] is in [lob] *) + Lemma addr_subseteq_lob (gr : Candidate.t): + Candidate.addr gr ⊆ lob gr. + Proof. + intros ??. + rewrite /lob. + apply elem_of_union_l. + apply elem_of_union_l. + rewrite /dob. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_r. + done. + Qed. + + (* [data] is in [lob] *) + Lemma data_subseteq_lob (gr : Candidate.t): + Candidate.data gr ⊆ lob gr. + Proof. + intros ??. + rewrite /lob. + apply elem_of_union_l. + apply elem_of_union_l. + rewrite /dob. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + apply elem_of_union_l. + done. + Qed. + + (* [fre] is in [ob] *) + Lemma fre_subseteq_ob (gr : Candidate.t) (e e': Eid): + EID.tid e ≠ EID.tid e' -> + (e, e') ∈ Candidate.fr gr-> + (e, e') ∈ ob gr. + Proof. + intros ??. + rewrite /ob. + apply grel_plus_once. + apply elem_of_union_l. + rewrite /obs. + apply elem_of_union_r. + set_solver. + Qed. + + (* [rfe] is in [ob] *) + Lemma rfe_subseteq_ob (gr : Candidate.t) (e e': Eid): + EID.tid e ≠ EID.tid e' -> + (e, e') ∈ Candidate.rf gr-> + (e, e') ∈ ob gr. + Proof. + intros ??. + rewrite /ob. + apply grel_plus_once. + apply elem_of_union_l. + rewrite /obs. + apply elem_of_union_l. + apply elem_of_union_l. + set_solver. + Qed. + + Lemma obs_valid gr e e': + (e, e') ∈ obs gr -> + (EID.tid e) ≠ (EID.tid e'). + Proof. set_unfold. sauto. Qed. + + (* initial writes has no [lob] successors *) + Lemma no_lob_succ_initial gr e: + NMSWF.wf gr -> + AAConsistent.t gr -> + e ∈ Candidate.initials gr -> lob_succ_of gr e = ∅. + Proof. + intros Hwf Hcs ?. + assert (initial_wf gr) as Hinit by (rewrite /wf in Hwf;naive_solver). + rewrite /initial_wf in Hinit. + destruct_and ? Hinit. + rewrite /lob_succ_of. + assert (po_wf gr) as Hpo by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo. + destruct_and ? Hpo. + clear H8 H11 H0 H1 H3 H4 H5 H6 H2. + + + assert (grel_rng (filter (λ '(es, _), es = e) (Candidate.po gr)) = ∅). + { + clear Hwf. + set_unfold. + intros. apply Classical_Pred_Type.all_not_not_ex. + intros. intro. + destruct H0 as [<- ?]. + assert ((n, x) ∈ Candidate.sthd gr). + { + apply H10. simpl. left. left;done. + } + set_unfold. + sauto lq:on. + } + + pose proof (lob_subseteq_po _ Hwf Hcs). + Local Opaque lob. + set_unfold. + set_solver + H0 H1. + Qed. + + + (* [ob] predecessors of [e] is its [lob] predecessors disjoint union its [obs] predecessors *) + Lemma ob_pred_of_disj_union (gr : Candidate.t) (e : Eid): + NMSWF.wf gr -> + AAConsistent.t gr -> + lob_pred_of gr e ∪ obs_pred_of gr e ⊆ ob_pred_of gr e + ∧ lob_pred_of gr e ## obs_pred_of gr e. + Proof. + intros Hwf Hcs. + rewrite /ob_pred_of /lob_pred_of /obs_pred_of. + rewrite -grel_dom_union. rewrite -filter_union_L. + Local Opaque obs. + rewrite /ob. rewrite union_comm_L. set_unfold. + split. + - intros ? []. + eexists. split;first reflexivity. + apply grel_plus_once. + clear Hwf. + set_unfold. hauto. + - intros ? [? [-> ?]] [? [-> ?]]. + apply (lob_subseteq_po _ Hwf Hcs) in H. + apply (po_valid_eids _ _ _ Hwf) in H. + destruct H. + apply obs_valid in H0. + contradiction. + Qed. + + + (* [ob] successors of [e] is its [lob] successors disjoint union its [obs] successors *) + Lemma ob_succ_of_disj_union (gr : Candidate.t) (e : Eid): + NMSWF.wf gr -> + AAConsistent.t gr -> + lob_succ_of gr e ∪ obs_succ_of gr e ⊆ ob_succ_of gr e + ∧ lob_succ_of gr e ## obs_succ_of gr e. + Proof. + intros Hwf Hcs. + rewrite /ob_succ_of /lob_succ_of /obs_succ_of. + rewrite -grel_rng_union. rewrite -filter_union_L. + rewrite /ob. rewrite union_comm_L. set_unfold. + split. + - intros ? []. + eexists. split;first reflexivity. + apply grel_plus_once. + clear Hwf. + set_unfold. hauto. + - intros ? [? [-> ?]] [? [-> ?]]. + apply (lob_subseteq_po _ Hwf Hcs) in H. + apply (po_valid_eids _ _ _ Hwf) in H. + destruct H. + apply obs_valid in H0. + contradiction. + Qed. + + (* [ob] is acyclic *) + Lemma ob_acyclic (gr : Candidate.t) (e : Eid): + AAConsistent.t gr -> (e, e) ∉ ob gr. + Proof. intros [_ ?]. set_solver. Qed. + + (* initial events are writes with value 0 *) + Lemma init_zero (gr : Candidate.t) (e : Eid): + NMSWF.wf gr -> + e.(EID.tid) = 0%nat -> + ∀ v, (exists E addr ks kv , gr !! e = Some E ∧ event_is_write_with E ks kv addr v) -> v = (BV _ 0). + Proof. + intros Hwf ???. + assert (initial_wf gr) as Hinit_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /initial_wf in Hinit_wf. + rewrite bool_unfold in Hinit_wf. + destruct_and ? Hinit_wf. + clear H3 H5. + assert (e ∈ Candidate.initials gr). set_unfold. set_solver + H0 H. + apply H6 in H1. set_unfold in H1. + destruct H1 as [? [? ?]]. + destruct H0 as (?&?&?&?&?&?). + rewrite H1 in H0. match_inversion;try contradiction. + rewrite bool_unfold in H3. + destruct_and ? H3. + simpl in H5. + rewrite bool_unfold in H5. + destruct_and ? H5. + rewrite /addr_and_value_of_wreq in H14. + (* clear H6 H7 H10 H11 H12 H14. *) + match_inversion;try contradiction. + subst n. + unfold eq_rec_r, eq_rec in H14. + rewrite <-Classical_Prop.Eq_rect_eq.eq_rect_eq in H14. + inversion H14. subst. simpl in H8. + rewrite H8. + unfold Val. unfold AAArch.val. unfold AAval. bv_solve. + Qed. + + (* initial writes are [co] initial *) + Lemma init_co (gr : Candidate.t) (e e': Eid) (a : Addr): + NMSWF.wf gr -> + e.(EID.tid) = 0%nat -> + e'.(EID.tid) ≠ 0%nat -> + (exists E, gr !! e = Some E ∧ event_is_write_with_addr E a) -> + (exists E, gr !! e' = Some E ∧ event_is_write_with_addr E a) -> + (e, e') ∈ Candidate.co gr. + Proof. + intros Hwf ? Hnz [?[]] [?[]]. + assert (initial_wf gr) as Hinit_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /initial_wf in Hinit_wf. + rewrite bool_unfold in Hinit_wf. + destruct_and ? Hinit_wf. + assert (e ∈ Candidate.initials gr). set_unfold. set_solver + H0 H. + rewrite H7 in H4. set_unfold in H4. + destruct H4 as [? (?&?&?&?)]. + + pose proof (Classical_Pred_Type.not_ex_all_not _ _ H4 e'). simpl in H11. + apply not_and_l in H11. + destruct H11. + - exfalso. clear H5 H6 H9 H7 H8 H0 H1 H10 H. + set_unfold in H11. + rewrite /event_is_write_with_addr in H3. rewrite /event_is_write_with_P in H3. + match_inversion;try contradiction. + eapply (Classical_Pred_Type.not_ex_all_not) in H11. + eapply (Classical_Pred_Type.not_ex_all_not) in H11. + eapply (Classical_Pred_Type.not_ex_all_not) in H11. + rewrite H2 in H11. + contradiction. + - assert ((e, e') ∈ Candidate.loc gr) as Hloc. + { + clear H8 H6 H4 H9 H5. set_unfold. + exists x. exists x0. exists a. rewrite /Candidate.get_pa. + split;first assumption. + rewrite /event_is_write_with_addr /event_is_write_with_P in H1. + rewrite /event_is_write_with_addr /event_is_write_with_P in H3. + match_inversion;try contradiction. + rewrite bool_unfold in H1. + rewrite bool_unfold in H3. + destruct_and ? H1. + destruct_and ? H3. + rewrite /addr_of_wreq in H12. rewrite /addr_of_wreq in H14. + rewrite H12. rewrite H14. + hauto lq:on. + } + assert (co_wf gr) as Hco_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /co_wf in Hco_wf. rewrite bool_unfold in Hco_wf. + destruct_and ? Hco_wf. + assert ((e, e') ∈ Candidate.loc gr ∩ (Candidate.mem_writes gr × Candidate.mem_writes gr)). + { + clear H13 H14 H15 H16 H17 H18 H19 H11 H4 H6 H7 H8 H9. + apply elem_of_intersection. + split;first assumption. + eapply event_is_write_elem_of_mem_writes in H3;last eassumption. + set_unfold. + sauto lq:on. + } + rewrite H15 in H12. + apply elem_of_union in H12. + destruct H12. + 2:{ set_unfold in H12. set_solver + H12 H Hnz. } + apply elem_of_union in H12. + destruct H12. assumption. + set_unfold in H12. set_solver + H12 H11. + Qed. + + Lemma rf_rmw_co (gr : Candidate.t) (eid_w eid_xr eid_xw : EID.t): + NMSWF.wf gr -> + AAConsistent.t gr -> + (eid_w, eid_xr) ∈ Candidate.rf gr -> + (eid_xr, eid_xw) ∈ Candidate.rmw gr -> + (eid_w, eid_xw) ∈ Candidate.co gr. + Proof. + intros Hwf Hcs Hrf Hrmw. + assert (co_wf gr) as Hco_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /co_wf in Hco_wf. + destruct_and ? Hco_wf. + assert (rf_wf gr) as Hrf_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rf_wf in Hrf_wf. + destruct_and ? Hrf_wf. + assert (rmw_wf gr) as Hrmw_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rmw_wf in Hrmw_wf. + destruct_and ? Hrmw_wf. + assert ((eid_w, eid_xr) ∈ Candidate.loc gr). apply H7 in Hrf. set_solver + Hrf. + assert ((eid_xr, eid_xw) ∈ Candidate.loc gr). apply H17 in Hrmw. set_solver + Hrmw. + assert ((eid_w, eid_xw) ∈ Candidate.loc gr). set_solver + H12 H19. + assert (eid_w ∈ Candidate.mem_writes gr). apply H. set_solver + Hrf. + assert (eid_xw ∈ Candidate.mem_writes_atomic gr). apply H14. set_solver + Hrmw. + assert (eid_xw ∈ Candidate.mem_writes gr). clear - H22. + set_unfold. destruct H22 as (?&?&?). match_inversion;try contradiction. hauto. + assert ((eid_w, eid_xw) ∈ Candidate.loc gr + ∩ (Candidate.mem_writes gr × Candidate.mem_writes gr)). + clear - H20 H21 H23. set_unfold. hauto. + rewrite H2 in H24. apply elem_of_union in H24. + assert ((eid_xr, eid_xw) ∈ Candidate.po gr ∩ Candidate.loc gr). + { + apply elem_of_intersection. + split. apply H16. assumption. apply H17. assumption. + } + destruct Hcs. + rewrite grel_irreflexive_spec in internal0. + destruct H24. + { + apply elem_of_union in H24. destruct H24. assumption. + exfalso. + clear - H25 Hrf H24 internal0. + specialize (internal0 (eid_w, eid_w)). simpl in internal0. + apply internal0;last reflexivity. + apply (grel_plus_trans _ _ eid_xr). + apply grel_plus_once. set_solver + Hrf. + apply (grel_plus_trans _ _ eid_xw). + apply grel_plus_once. set_solver + H25. + apply grel_plus_once. set_solver + H24. + } + { + exfalso. + clear - H25 Hrf H24 internal0. + specialize (internal0 (eid_w, eid_w)). simpl in internal0. + apply internal0;last reflexivity. + apply (grel_plus_trans _ _ eid_xr). + apply grel_plus_once. set_solver + Hrf. + apply grel_plus_once. set_solver + H24 H25. + } + Qed. + + (* There can only be a single successful rmw read from any write *) + Lemma rmw_rmw (gr : Candidate.t) (eid_w eid_xr eid_xr' eid_xw eid_xw' : Eid): + NMSWF.wf gr -> + AAConsistent.t gr -> + eid_xr ≠ eid_xr' -> + (eid_w, eid_xr) ∈ Candidate.rf gr -> + (eid_xr, eid_xw) ∈ Candidate.rmw gr -> + (eid_w, eid_xr') ∈ Candidate.rf gr -> + (eid_xr', eid_xw') ∈ Candidate.rmw gr -> + False. + Proof. + intros Hwf Hcs Hnst Hrf Hrmw Hrf' Hrmw'. + assert (co_wf gr) as Hco_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /co_wf in Hco_wf. + destruct_and ? Hco_wf. + assert (rf_wf gr) as Hrf_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rf_wf in Hrf_wf. + destruct_and ? Hrf_wf. + assert (rmw_wf gr) as Hrmw_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /rmw_wf in Hrmw_wf. + destruct_and ? Hrmw_wf. + assert (po_wf gr) as Hpo_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo_wf. + destruct_and ? Hpo_wf. + assert ((eid_w, eid_xw) ∈ Candidate.co gr) as Hco. + { + eapply (rf_rmw_co _ eid_w eid_xr); eassumption. + } + assert ((eid_w, eid_xw') ∈ Candidate.co gr) as Hco'. + { + eapply (rf_rmw_co _ eid_w eid_xr'); eassumption. + } + assert (EID.tid eid_xr ≠ EID.tid eid_xr'). + { + intros Hst. + assert ((eid_xr', eid_xw') ∈ Candidate.po gr). apply H16. assumption. + assert ((eid_xr, eid_xw) ∈ Candidate.po gr). apply H16. assumption. + assert (eid_xr ∈ Candidate.mem_reads_atomic gr) as Hxr. apply H15. set_solver + Hrmw. + assert (eid_xr' ∈ Candidate.mem_reads_atomic gr) as Hxr'. apply H15. set_solver + Hrmw'. + assert ((eid_xr, eid_xr') ∈ Candidate.sthd gr). set_solver + Hst Hxr Hxr'. + + assert (eid_xw ∈ Candidate.mem_writes_atomic gr) as Hxw. apply H14. set_solver + Hrmw. + assert (eid_xw' ∈ Candidate.mem_writes_atomic gr) as Hxw'. apply H14. set_solver + Hrmw'. + assert ((eid_xw, eid_xr') ∈ Candidate.sthd gr). + { + assert ((eid_xr, eid_xw) ∈ Candidate.sthd gr). rewrite -H23. set_solver + H25. + clear - H27 H26. set_unfold. sauto. + } + assert ((eid_xw', eid_xr) ∈ Candidate.sthd gr). + { + assert ((eid_xr', eid_xw') ∈ Candidate.sthd gr). rewrite -H23. set_solver + H20. + clear - H26 H28. set_unfold. sauto. + } + rewrite -H23 in H26. + rewrite -H23 in H27. + rewrite -H23 in H28. + (* set_solver + Hst Hxr Hxr'. *) + apply elem_of_union in H26. destruct H26. + 2:{ + assert (eid_xr ∈ Candidate.initials gr). set_solver + H26. + assert (initial_wf gr) as Hinitial_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /initial_wf in Hinitial_wf. + destruct_and ? Hinitial_wf. + apply H35 in H29. + clear -H29 Hxr. + set_unfold. destruct H29 as (?&?&?). destruct Hxr as (?&?&?). rewrite H in H1. inversion H1;subst x0. + match_inversion;try contradiction. + } + apply elem_of_union in H27. destruct H27. + 2:{ + assert (eid_xw ∈ Candidate.initials gr). set_solver + H27. + assert (initial_wf gr) as Hinitial_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /initial_wf in Hinitial_wf. + destruct_and ? Hinitial_wf. + apply H35 in H29. + clear -H29 Hxw. + set_unfold. destruct H29 as (?&?&?). destruct Hxw as (?&?&?). rewrite H in H1. inversion H1;subst x0. + match_inversion;try contradiction. + destruct_and ? H2. + destruct_and ? H0. + rewrite bool_unfold in H5. + rewrite bool_unfold in H9. + contradiction. + } + apply elem_of_union in H28. destruct H28. + 2:{ + assert (eid_xr ∈ Candidate.initials gr). set_solver + H28. + assert (initial_wf gr) as Hinitial_wf by (rewrite /wf in Hwf;naive_solver). + rewrite /initial_wf in Hinitial_wf. + destruct_and ? Hinitial_wf. + apply H35 in H29. + clear -H29 Hxr. + set_unfold. destruct H29 as (?&?&?). destruct Hxr as (?&?&?). rewrite H in H1. inversion H1;subst x0. + match_inversion;try contradiction. + } + apply elem_of_union in H26. destruct H26. + { + apply elem_of_union in H27. destruct H27. + { + (* internal *) + assert ((eid_xr', eid_xw) ∈ Candidate.fr gr). + set_solver + Hrf' Hco. + assert ((eid_xw, eid_xr') ∈ Candidate.po gr ∩ Candidate.loc gr). + apply elem_of_intersection. split. assumption. + apply H7 in Hrf'. + apply H5 in Hco. + set_solver + Hrf' Hco. + destruct Hcs. + rewrite grel_irreflexive_spec in internal0. + clear - H30 H29 internal0. + specialize (internal0 (eid_xw, eid_xw)). simpl in internal0. + apply internal0;last reflexivity. + apply (grel_plus_trans _ _ eid_xr'). + apply grel_plus_once. set_solver + H30. + apply grel_plus_once. set_solver + H29. + } + { + assert ((eid_xr, eid_xw) ∈ ⦗Candidate.mem_reads_atomic gr⦘ ⨾ Candidate.po gr ⨾ ⦗Candidate.mem_reads_atomic gr⦘ ⨾ Candidate.po gr + ⨾ ⦗Candidate.mem_writes_atomic gr⦘). + clear - H26 H27 Hxr Hxr' Hxw. + set_unfold. sauto lq:on. + set_solver + H29 Hrmw H11. + } + } + { + apply elem_of_union in H28. destruct H28. + { + (* internal *) + assert ((eid_xr, eid_xw') ∈ Candidate.fr gr). + set_solver + Hrf Hco'. + assert ((eid_xw', eid_xr) ∈ Candidate.po gr ∩ Candidate.loc gr). + apply elem_of_intersection. split. assumption. + apply H7 in Hrf. + apply H5 in Hco'. + set_solver + Hrf Hco'. + destruct Hcs. + rewrite grel_irreflexive_spec in internal0. + clear - H30 H29 internal0. + specialize (internal0 (eid_xw', eid_xw')). simpl in internal0. + apply internal0;last reflexivity. + apply (grel_plus_trans _ _ eid_xr). + apply grel_plus_once. set_solver + H30. + apply grel_plus_once. set_solver + H29. + } + { + assert ((eid_xr', eid_xw') ∈ ⦗Candidate.mem_reads_atomic gr⦘ ⨾ Candidate.po gr ⨾ ⦗Candidate.mem_reads_atomic gr⦘ ⨾ Candidate.po gr + ⨾ ⦗Candidate.mem_writes_atomic gr⦘). + clear - H26 H28 Hxr Hxr' Hxw'. + set_unfold. sauto lq:on. + set_solver + H29 Hrmw' H11. + } + } + } + + assert ((eid_xr', eid_xw) ∈ Candidate.external_of (Candidate.fr gr)) as Hfr. + { + assert ((eid_xr, eid_xw) ∈ Candidate.po gr). apply H16. assumption. + assert ((eid_xr, eid_xw) ∈ Candidate.sthd gr). rewrite -H23. set_solver + H25. + clear - Hco Hrf' H26 H20. + set_unfold. sauto. + } + assert ((eid_xr, eid_xw') ∈ Candidate.external_of (Candidate.fr gr)) as Hfr'. + { + assert ((eid_xr', eid_xw') ∈ Candidate.po gr). apply H16. assumption. + assert ((eid_xr', eid_xw') ∈ Candidate.sthd gr). rewrite -H23. set_solver + H25. + clear - Hco' Hrf H26 H20. + set_unfold. sauto. + } + assert ((eid_xw, eid_xw') ∈ Candidate.loc gr) as Hloc. + { + apply H17 in Hrmw'. + apply H7 in Hrf'. + assert ((eid_w, eid_xw) ∈ Candidate.loc gr). + { + assert ((eid_w, eid_xw) ∈ Candidate.co gr ∪ (Candidate.co gr) ⁻¹ ∪ ⦗Candidate.mem_writes gr⦘). set_solver + Hco. + rewrite -H2 in H25. + set_solver + H25. + } + set_solver + H25 Hrmw' Hrf'. + } + assert ((eid_xw, eid_xw') ∈ Candidate.co gr ∪ (Candidate.co gr) ⁻¹ ∪ ⦗Candidate.mem_writes gr⦘). + { + rewrite -H2. + apply elem_of_intersection. + split. set_solver + Hloc. + clear - Hco Hco' H3. + set_unfold. pose proof (H3 eid_xw). + pose proof (H3 eid_xw'). clear H3. + hauto lq:on. + } + assert (EID.tid (eid_xw) ≠ EID.tid (eid_xw')). + { + intros Heq. + assert ((eid_xr, eid_xw) ∈ Candidate.po gr). apply H16. assumption. + assert ((eid_xr, eid_xw) ∈ Candidate.sthd gr). rewrite -H23. set_solver + H26. + assert ((eid_xr', eid_xw') ∈ Candidate.po gr). apply H16. assumption. + assert ((eid_xr', eid_xw') ∈ Candidate.sthd gr). rewrite -H23. set_solver + H28. + clear - H27 H29 H20 Heq. + set_unfold. sauto lq:on. + } + apply elem_of_union in H25. + destruct H25. + 2:{ + set_solver + H25 H26. + } + apply elem_of_union in H25. + destruct Hcs. + destruct H25. + { + assert ((eid_xw, eid_xw') ∈ Candidate.external_of (Candidate.co gr)). set_solver + H26 H25. + assert ((eid_xr', eid_xw') ∈ (Candidate.external_of (Candidate.fr gr))⨾(Candidate.external_of (Candidate.co gr))). set_solver + H27 Hfr. + rewrite bool_unfold in atomic0. + set_solver + atomic0 H28 Hrmw'. + } + { + assert ((eid_xw', eid_xw) ∈ Candidate.external_of (Candidate.co gr)). + set_solver + H25 H26. + assert ((eid_xr, eid_xw) ∈ (Candidate.external_of (Candidate.fr gr))⨾(Candidate.external_of (Candidate.co gr))). + { + set_solver + H27 Hfr'. + } + rewrite bool_unfold in atomic0. + set_solver + atomic0 H28 Hrmw. + } + Qed. + + (** End of axioms *) + + Lemma lob_acyclic (gr : Candidate.t) (e : Eid): + AAConsistent.t gr -> (e, e) ∉ lob gr. + Proof. + intros Hcs. pose proof (ob_acyclic _ e Hcs). + clear Hcs. + rewrite /ob in H. + intro. + apply H. + apply grel_plus_once. + set_solver. + Qed. + + Lemma lob_subseteq_ob(gr : Candidate.t): + lob gr ⊆ ob gr. + Proof. + intros. + rewrite /ob. + set_unfold. + intros. + apply grel_plus_once. + destruct x. + set_solver. + Qed. + + Lemma lob_pred_of_subseteq_po (gr : Candidate.t) (e : Eid) : + NMSWF.wf gr -> + AAConsistent.t gr -> + lob_pred_of gr e ⊆ po_pred_of gr e. + Proof. + rewrite /lob_pred_of /po_pred_of. + intros Hwf Hcs e' Hin. + pose proof (lob_subseteq_po _ Hwf Hcs). + set_solver - Hwf Hcs. + Qed. + + Lemma collect_all_subseteq gr P Q: + (∀ e, P e = true -> Q e = true) -> + Candidate.collect_all P gr ⊆ Candidate.collect_all Q gr. + Proof. + intros Himpl e Hin. set_unfold. + destruct Hin as [? [? ?]]. + eexists. split;eauto. + rewrite Is_true_true. apply Himpl. + rewrite -Is_true_true //. + Qed. + + Lemma not_elem_of_lob_pred_of (gr : Candidate.t) (e : Eid): + AAConsistent.t gr -> e ∉ lob_pred_of gr e. + Proof. + intro Hcs. pose proof (lob_acyclic _ e Hcs). set_solver. + Qed. + + Lemma not_elem_of_lob_succ_of (gr : Candidate.t) (e : Eid) : + AAConsistent.t gr -> + e ∉ lob_succ_of gr e. + Proof. + intro Hcs. pose proof (lob_acyclic _ e Hcs). set_solver. + Qed. + + Lemma elem_of_lob_pred_of_po (gr : Candidate.t) (e1 e2 : Eid) : + NMSWF.wf gr -> + AAConsistent.t gr -> + e2 ∈ lob_pred_of gr e1 -> + (e2, e1) ∈ gr.(Candidate.po). + Proof. + intros Hwf Hcs Hpred. epose proof (lob_pred_of_subseteq_po _ e1 Hwf Hcs). set_solver - Hwf Hcs. + Qed. + + (** Some helpers *) + Lemma elem_of_lob_pred_of_lob (gr : Candidate.t) (e1 e2 : Eid) : + e2 ∈ lob_pred_of gr e1 -> + (e2, e1) ∈ (lob gr). + Proof. + intros. rewrite /lob_pred_of in H. set_solver. + Qed. + + Lemma elem_of_ob_pred_of (gr : Candidate.t) (e e': Eid) : + e' ∈ ob_pred_of gr e -> (e', e) ∈ (ob gr). + Proof. set_solver. Qed. + + Lemma ob_pred_of_valid (gr : Candidate.t) (e : Eid) : + NMSWF.wf gr -> + ob_pred_of gr e ⊆ Candidate.valid_eid gr. + Proof. + intros Hwf. + rewrite /ob_pred_of. pose proof (ob_dom_valid _ Hwf). + set_solver - Hwf. + Qed. + + Lemma elem_of_obs_pred_of_succ (gr : Candidate.t) (e e': Eid) : + e' ∈ obs_pred_of gr e <-> e ∈ obs_succ_of gr e'. + Proof. set_solver. Qed. + + Lemma elem_of_lob_pred_of_succ (gr : Candidate.t) (e e': Eid) : + e' ∈ lob_pred_of gr e <-> e ∈ lob_succ_of gr e'. + Proof. set_solver. Qed. + + Lemma elem_of_ob_pred_of_succ (gr : Candidate.t) (e e': Eid) : + e' ∈ ob_pred_of gr e <-> e ∈ ob_succ_of gr e'. + Proof. set_solver. Qed. + + Lemma lob_succ_of_subseteq_ob (gr : Candidate.t) (e : Eid): + lob_succ_of gr e ⊆ ob_succ_of gr e. + Proof. + intros. pose proof lob_subseteq_ob. set_solver. + Qed. + + Lemma elem_of_ob_succ_of_valid (gr : Candidate.t) (e e': Eid) : + NMSWF.wf gr -> + e' ∈ ob_succ_of gr e -> {[e'; e]} ⊆ Candidate.valid_eid gr. + Proof. + intros Hwf. + pose proof (ob_dom_valid _ Hwf). pose proof (ob_rng_valid _ Hwf). + rewrite -elem_of_ob_pred_of_succ. + intro. assert ((e,e') ∈ ob gr). set_solver - Hwf. + set_solver - Hwf. + Qed. + + Lemma elem_of_lob_succ_of_valid (gr : Candidate.t) (e e': Eid) : + NMSWF.wf gr -> + e' ∈ lob_succ_of gr e -> {[e'; e]} ⊆ Candidate.valid_eid gr. + Proof. + intros Hwf. + pose proof lob_subseteq_ob. + intro. assert ((e,e') ∈ ob gr). set_solver - Hwf. + pose proof (ob_dom_valid _ Hwf). pose proof (ob_rng_valid _ Hwf). + set_solver - Hwf. + Qed. + + Lemma elem_of_ob_succ_of_ne gr e e': + AAConsistent.t gr -> + e' ∈ ob_succ_of gr e -> e ≠ e'. + Proof. + pose proof ob_acyclic. set_solver. + Qed. + + Lemma elem_of_ob_pred_of_ne gr e e': + AAConsistent.t gr -> + e' ∈ ob_pred_of gr e -> e ≠ e'. + Proof. + pose proof ob_acyclic. set_solver. + Qed. + + Lemma lob_same_thd gr e e': + AAConsistent.t gr → + wf gr -> + e' ∈ lob_succ_of gr e -> e' ∈ Candidate.non_initial_eids gr. + Proof. + rewrite -elem_of_lob_pred_of_succ. + intros Hc Hwf ?. + assert ((e,e') ∈ lob gr). set_solver - Hwf. + assert ((e,e') ∈ Candidate.po gr). + pose proof (lob_subseteq_po _ Hwf). set_solver - Hwf. + assert (po_wf gr) as Hpo by (rewrite /wf in Hwf;naive_solver). + rewrite /po_wf in Hpo. + destruct_and ? Hpo. + assert ((e, e')∈ Candidate.sthd gr). + { rewrite -H7. set_solver + H1. } + clear H3 H5 H7 Hwf. + + set_unfold. specialize (H6 (e,e')). + destruct H4 as (?&?&?&?&?&?&?). + set_unfold. + split;first sauto lq:on. + intro. + subst. + clear H8 H0 H Hc. + apply not_and_l in H6. destruct H6;first contradiction. + rewrite -H7 in H. rewrite H9 in H. + hauto lq:on. + Qed. + + (** Induction scheme*) + (* This is weaker in the sense that nodes in [s] can be ordered *) + Definition ob_semi_last_set gr (s s' : gset Eid) := + set_Forall (λ e_last, set_Forall (λ e, (e_last, e) ∉ (AAConsistent.ob gr)) (s' ∖ s)) s. + + Definition ob_subset gr (s' s : gset Eid) : Prop := s' ⊂ s ∧ ob_semi_last_set gr s' s. + + Lemma ob_semi_last_set_mono gr (s s' s'' : gset Eid) : + s ⊂ s' -> s' ⊆ s'' -> + ob_semi_last_set gr s s' -> ob_semi_last_set gr s' s'' -> ob_semi_last_set gr s s''. + Proof. + intros Hsub Hsub' Hob Hob'. + apply set_subseteq_inv_L in Hsub'. + destruct Hsub' as [Hsub'| ->];last done. + intros x Hin. + specialize (Hob x Hin). simpl in Hob. + intros x'' Hin''. + destruct (decide (x'' ∈ s')). + - intro. + specialize (Hob x''). + feed specialize Hob. set_solver + e Hin'' Hsub Hsub'. + done. done. + - rewrite /ob_semi_last_set in Hob'. + destruct (decide (x ∈ s')). + + specialize (Hob' x). + feed specialize Hob'. set_solver + e. + simpl in Hob'. + apply Hob'. + set_solver + Hin'' n. + + set_solver + Hsub n0 Hin. + Qed. + + Lemma ob_subset_wf gr : well_founded.wf (ob_subset gr). + Proof. + apply (wf_projected (<)%nat size). + - intros ?? (? & _). + by apply subset_size. + - apply lt_wf. + Qed. + + Definition get_ob_first gr (s : gset Eid) := + filter (λ e, set_Forall (λ e', (e', e) ∉ (AAConsistent.ob gr)) s) s. + + Lemma get_ob_first_subseteq gr s : + get_ob_first gr s ⊆ s. + Proof. + intros ? Hin. + apply elem_of_filter in Hin. + destruct Hin;done. + Qed. + + Lemma get_ob_first_non_empty gr s : + AAConsistent.t gr -> + s ⊆ Candidate.valid_eid gr -> + (exists x, x ∈ s) -> + exists x, x ∈ get_ob_first gr s. + Proof. + intros Hcs. + eapply (well_founded_induction _ + (λ s, s ⊆ Candidate.valid_eid gr → (∃ x : Eid, x ∈ s) → ∃ x : Eid, x ∈ get_ob_first gr s)). + Unshelve. + 2: { exact (⊂). } + 2 : { + eapply (wf_projected (<)%nat size). + - intros ??. apply subset_size. + - apply lt_wf. + } + clear s. intros s IH Hsub Hnem. + destruct Hnem as [x Hin]. + destruct (decide (x ∈ get_ob_first gr s));[exists x;done|]. + rewrite /get_ob_first elem_of_filter in n. rewrite not_and_l in n. + destruct n; last set_solver + H Hin Hsub. + apply not_set_Forall_Exists in H. 2: apply _. + destruct H as [x0 [Hin' Hob]]. + assert (x0 ≠ x). + { + intros ->. destruct Hcs as [_ Hac]. + rewrite grel_irreflexive_spec in Hac. + simpl in Hob. apply Hob. + intro Hxx. specialize (Hac (x, x) Hxx). done. + } + specialize (IH (s∖ {[x]})). feed specialize IH. + set_solver + Hin. + set_solver + Hsub. + exists x0. set_solver + H Hin Hin'. + destruct IH as [x2 ?]. + destruct (decide ((x, x2) ∈ (ob gr))). + { + apply elem_of_filter in H0. + destruct H0. + assert (x0 ∈ s ∖ {[x]}) by set_solver + H Hin'. + specialize (H0 x0 H2). + simpl in H0. simpl in Hob. + assert ((x0, x) ∈ ob gr). + destruct (decide ((x0, x) ∈ ob gr)). done. + exfalso. apply Hob. done. + exfalso. apply H0. + pose proof (grel_transitive_spec (ob gr)) as [Htran _]. + feed specialize Htran. + apply grel_transitive_plus. eapply Htran;eauto. + } + { + exists x2. apply elem_of_filter. + split. 2:{ apply elem_of_filter in H0. destruct H0. set_solver + H1. } + rewrite (union_difference_L {[x]} s); first set_solver + Hin. + apply set_Forall_union. + apply set_Forall_singleton. done. + apply elem_of_filter in H0. destruct H0. done. + } + Qed. + + Lemma ob_semi_last_set_choose_or_empty gr s: + AAConsistent.t gr -> + s ⊆ Candidate.valid_eid gr -> + (∃ x, x ∈ s ∧ ob_semi_last_set gr (s ∖ {[x]}) s) ∨ s ≡ ∅. + Proof. + intros Hcs Hsub. + destruct (set_choose_or_empty (get_ob_first gr s)) as [[x Hx_in]|HX]. + - left. exists x. + apply elem_of_filter in Hx_in. + destruct Hx_in as (Hlast & Hin ). + split;first done. + intros y Hy_in. + assert (Hy_in' : y ∈ s) by set_solver + Hy_in. + specialize (Hlast y Hy_in'). + assert ((s ∖ (s ∖ {[x]})) = {[x]}) as ->. + rewrite difference_difference_r_L. + set_solver + Hin. + apply set_Forall_singleton. done. + - destruct (set_choose_or_empty s) as [[y Hy_in]|HY]. + + exfalso. + pose proof (get_ob_first_non_empty gr s Hcs Hsub) as Hnem. + feed specialize Hnem. exists y;done. + set_solver + Hnem HX. + + right;done. + Qed. + + Lemma ob_set_ind (gr : Graph.t) (s_all : gset Eid) (P : gset Eid → Prop) : + Proper ((≡) ==> iff) P → + AAConsistent.t gr -> + s_all ⊆ (Candidate.valid_eid gr) -> + P ∅ → + (∀ (x : Eid) (X : gset Eid), x ∉ X -> x ∈ s_all -> + ob_subset gr X s_all -> + set_Forall (λ x', (x', x) ∉ (AAConsistent.ob gr)) ({[x]} ∪ X) → + P X → P ({[ x ]} ∪ X)) → + ∀ X, X ⊆ s_all -> ob_semi_last_set gr X s_all -> P X. + Proof. + intros ? Hcs Hall_valid Hemp Hadd. + eapply (well_founded_induction _ (λ X, X ⊆ s_all -> ob_semi_last_set gr X s_all → P X)). + Unshelve. + 2:{ exact (ob_subset gr). } + 2:{ apply ob_subset_wf. } + intros X IH HX_subeq HX_semi_first. + assert (HX_valid: X ⊆ Candidate.valid_eid gr) by set_solver + HX_subeq Hall_valid. + destruct (ob_semi_last_set_choose_or_empty gr X Hcs HX_valid) as [[x [Hx_in HX_x_semi_first]]|HX]. + - rewrite (union_difference {[x]} X);[set_solver + Hx_in|]. + apply Hadd;[set_solver + | set_solver + Hx_in HX_subeq | | |]. + { + split. set_solver + Hx_in HX_subeq. + eapply ob_semi_last_set_mono;eauto. + set_solver + Hx_in HX_subeq. + } + { + apply set_Forall_union. + { + rewrite set_Forall_singleton. + destruct Hcs as [_ Hac]. + rewrite grel_irreflexive_spec in Hac. + intro Hxx. specialize (Hac (x, x) Hxx). done. + } + { + intros x0 Hx0_in. + apply (HX_x_semi_first x0 Hx0_in). + set_solver + Hx_in. + } + } + apply IH. + split. set_solver + Hx_in. done. + set_solver + HX_subeq. + eapply ob_semi_last_set_mono;eauto. + set_solver + Hx_in. + - by rewrite HX. + Qed. + + Lemma ob_set_ind_L (gr : Graph.t) (s_all : gset Eid) (P : gset Eid → Prop) : + AAConsistent.t gr -> + s_all ⊆ (Candidate.valid_eid gr) -> + P ∅ → (∀ (x : Eid) (X : gset Eid), x ∉ X -> x ∈ s_all -> + ob_subset gr X s_all -> + set_Forall (λ x', (x', x) ∉ (AAConsistent.ob gr)) ({[x]} ∪ X) → + P X → P ({[ x ]} ∪ X)) → ∀ X, X ⊆ s_all -> ob_semi_last_set gr X s_all -> P X. + Proof. apply ob_set_ind. by intros ?? ->%leibniz_equiv_iff. Qed. + +End Graph. diff --git a/theories/lang/opsem.v b/theories/lang/opsem.v new file mode 100644 index 0000000..ead7ab9 --- /dev/null +++ b/theories/lang/opsem.v @@ -0,0 +1,1167 @@ +(** This file contains the definition of the operational semantics *) +From Coq Require Import ssreflect. +From stdpp Require Import numbers unstable.bitvector. + +From RecordUpdate Require Export RecordSet. +Export RecordSetNotations. + +From SSCCommon Require Import CSets GRel. + +From self Require Import stdpp_extra. +From self.lang Require Export mm. +From self.lang Require Import instrs. + +Record RegVal := mk_regval { + reg_val : AAInter.reg_type; (* Val *) + reg_dep : gset Eid; +}. + +Notation RegFile := (gmap RegName RegVal) (only parsing). +Notation Tid := positive. + +(* nodes whose eids start with tid 0 are initial writes *) +Definition tid0 := 0. +Coercion Pos.to_nat : Tid >-> nat. + +Lemma iter_op_plus_mono t (n n': nat): + (n <= n')%nat -> + (Pos.iter_op plus t n <= Pos.iter_op plus t n')%nat. +Proof. + revert n n'. + induction t ;simpl;try lia. + intros. specialize (IHt (n+n) (n' + n'))%nat. + feed specialize IHt. lia. + lia. + intros. specialize (IHt (n+n) (n' + n'))%nat. + feed specialize IHt. lia. + lia. +Qed. + +Lemma tid_nz_aux (t : Tid) : (0%nat < t)%nat. +Proof. + rewrite /Pos.to_nat. + induction t ;simpl. + lia. + pose proof (iter_op_plus_mono t 1 2). feed specialize H;first lia. + lia. + lia. +Qed. + +Lemma tid_nz_nz (t : Tid) : (0%nat ≠ t)%nat. +Proof. pose proof (tid_nz_aux t). lia. Qed. + + +(* instruction memory of all threads *) +Module GInstrMem. + + Definition t := gmap Addr Instruction. + +End GInstrMem. + + +(* thread state *) +Module ThreadState. + Import AACandExec. + Definition progress : Type := (nat * nat). + + Module IntraInstrState. + + Record t := mk_l { + iis_iid : nat; + iis_cntr : nat; + iis_mem_reads : list nat; + }. + + #[global] Instance eta : Settable _ := settable! mk_l . + + Definition mk_iis iid := {| iis_iid := iid; iis_cntr := 0; iis_mem_reads := [] |}. + End IntraInstrState. + + Record t := mk_l { + ts_regs : RegFile; + ts_reqs : InstSem; + ts_ctrl_srcs : gset Eid; + ts_iis : IntraInstrState.t; + ts_rmw_pred : option Eid; + }. + + (* instance for record update *) + #[global] Instance eta : Settable _ := settable! mk_l . + + Export IntraInstrState. + Definition mk_ts regs fst_instr_sem := + {| + ts_regs := regs; + ts_reqs := fst_instr_sem; + ts_ctrl_srcs := ∅; + ts_iis := mk_iis 0; + ts_rmw_pred := None; + |}. + + Definition reqs_done ts := ts.(ts_reqs) = EmptyInterp. + Definition next_req_is{T} ts (req: outcome T) k := ts.(ts_reqs) = (AAInter.Next req k). + + Definition mk_eid_ii ts tid := + EID.make tid ts.(ts_iis).(iis_iid) ts.(ts_iis).(iis_cntr). + + Definition mk_iis_ni ts := mk_iis (ts.(ts_iis).(iis_iid) + 1). + + Definition incr_cntr ts : ThreadState.t := + ts <| ts_iis := (ts.(ts_iis) <|iis_cntr := ((ts.(ts_iis).(iis_cntr)) + 1)%nat |>) |>. + Definition reset_cntr ts : ThreadState.t := + ts <| ts_iis := mk_iis_ni ts |>. + + (* A local progress is (iid, num), it returns the latest one *) + Definition get_progress ts : progress := + (ts.(ThreadState.ts_iis).(iis_iid), ts.(ThreadState.ts_iis).(iis_cntr)). + + Definition progress_of_node e : progress := (e.(EID.iid), e.(EID.num)). + Definition progress_to_node ρ tid : Eid := (EID.make tid ρ.1 ρ.2). + + Lemma progress_to_node_of_node tid e : + e.(EID.tid) = tid -> + progress_to_node (progress_of_node e) tid = e. + Proof. + rewrite /progress_to_node /progress_of_node /=. + intros <-. destruct e;cbn; done. + Qed. + + Lemma progress_of_node_to_node tid pg: + progress_of_node (progress_to_node pg tid) = pg. + Proof. + rewrite /progress_to_node /progress_of_node /=. + destruct pg; done. + Qed. + + Definition progress_is_valid gr (tid : Tid) pg := + progress_to_node pg tid ∈ Candidate.valid_eid gr. + + #[global] Instance progress_is_valid_dec gr tid pg : Decision (progress_is_valid gr tid pg). + Proof. rewrite /progress_is_valid. apply _. Qed. + + Definition progress_lt (pg1 pg2 : progress) := (pg1.1 < pg2.1 ∨ (pg1.1 = pg2.1 ∧ pg1.2 < pg2.2))%nat. + + #[global] Instance progress_lt_dec pg1 pg2 : Decision (progress_lt pg1 pg2). + Proof. rewrite /progress_lt. apply _. Qed. + + Lemma progress_lt_gt_False pg1 pg2 : progress_lt pg1 pg2 ∧ progress_lt pg2 pg1 -> False. + Proof. intros [[|] [|]];lia. Qed. + + Lemma progress_lt_refl_False pg : progress_lt pg pg -> False. + Proof. intros [|];lia. Qed. + + Lemma progress_lt_trans pg1 pg2 pg3 : + progress_lt pg1 pg2 -> + progress_lt pg2 pg3 -> progress_lt pg1 pg3. + Proof. + destruct pg1, pg2, pg3;intros [];intros [];simpl in *;[left|left|left|right];simpl;lia. + Qed. + + Lemma progress_lt_neq pg pg': progress_lt pg pg' -> pg ≠ pg'. + Proof. intros [|] ->;lia. Qed. + + (* It is used in the lifting proofs *) + (* Maybe we can get rid of this by proving a similar property + (but without WF) for [step] *) + Lemma progress_lt_po gr (tid : Tid) (pg pg' : progress): + (* not true for initial writes *) + AACandExec.NMSWF.wf gr -> + (ThreadState.progress_lt pg pg' + ∧ ThreadState.progress_is_valid gr tid pg + ∧ ThreadState.progress_is_valid gr tid pg') + <-> ((ThreadState.progress_to_node pg tid), + (ThreadState.progress_to_node pg' tid)) ∈ gr.(AACandExec.Candidate.po). + Proof. + intros Hwf. + split. + + intros. + unfold progress_is_valid, progress_lt in *. + destruct H as [Hlt [Hvalid1 Hvalid2]]. + apply Graph.pg_lt_to_po. + - assumption. + - by simpl. + - by simpl. + - pose proof (tid_nz_nz tid). simpl. lia. + - by simpl. + - by simpl. + + intros. + split. + - unfold progress_lt. + set (e1 := progress_to_node pg tid). + set (e2 := progress_to_node pg' tid). + apply (Graph.po_to_pg_lt gr e1 e2); assumption. + - by apply Graph.po_valid_eids'. + Qed. + + Definition progress_le (pg1 pg2 : progress) := (pg1.1 < pg2.1 ∨ (pg1.1 = pg2.1 ∧ pg1.2 <= pg2.2))%nat. + + #[global] Instance progress_le_dec p1 p2 : Decision (progress_le p1 p2). + Proof. rewrite /progress_le. apply _. Qed. + + Lemma progress_lt_le pg1 pg2 : + progress_lt pg1 pg2 -> progress_le pg1 pg2. + Proof. + destruct pg1,pg2. intros [];simpl in *. + left;simpl;lia. + right;simpl;lia. + Qed. + + Lemma progress_le_inv pg1 pg2 : progress_le pg1 pg2 <-> progress_lt pg1 pg2 ∨ pg1 = pg2. + Proof. + destruct pg1,pg2. split;intros [];simpl in *. + left;left;simpl; lia. + destruct (decide (n0 < n2)%nat). + left;right;simpl;lia. + right;simpl. destruct H as [-> ?]. f_equal. lia. + by apply progress_lt_le. + right;simpl. inversion H. lia. + Qed. + + Lemma progress_le_gt_False pg1 pg2 : progress_le pg1 pg2 -> + progress_lt pg2 pg1 -> False. + Proof. intros [Hlt | Heq] [H1| H2];try lia. Qed. + + Lemma progress_le_ge_eq pg1 pg2 : + progress_le pg1 pg2 -> progress_le pg2 pg1 -> pg1 = pg2. + Proof. + intros Hle Hle'. rewrite progress_le_inv in Hle. + destruct Hle;last done. exfalso;eapply progress_le_gt_False;eauto. + Qed. + + Lemma progress_le_refl pg : progress_le pg pg. + Proof. right;split;lia. Qed. + + Lemma progress_lt_trans'1 pg1 pg2 pg3 : + progress_lt pg1 pg2 -> + progress_le pg2 pg3 -> progress_lt pg1 pg3. + Proof. + intros Hlt Hle. rewrite progress_le_inv in Hle. + destruct Hle as [Hlt'|[]]. + eapply progress_lt_trans;eauto. + done. + Qed. + + Lemma progress_lt_trans'2 pg1 pg2 pg3 : + progress_le pg1 pg2 -> + progress_lt pg2 pg3 -> progress_lt pg1 pg3. + Proof. + intros Hle Hlt. rewrite progress_le_inv in Hle. + destruct Hle as [Hlt'| ->]. + eapply progress_lt_trans;eauto. + done. + Qed. + + Lemma progress_le_trans pg1 pg2 pg3 : + progress_le pg1 pg2 -> + progress_le pg2 pg3 -> progress_le pg1 pg3. + Proof. + intros Hle Hlt. rewrite progress_le_inv in Hle. + destruct Hle as [Hlt'| ->]. rewrite progress_le_inv. + left. eapply progress_lt_trans'1;eauto. + done. + Qed. + + Lemma progress_nle_gt pg1 pg2 : (progress_le pg1 pg2 -> False) -> + progress_lt pg2 pg1. + Proof. + intros Hnle. destruct pg1; destruct pg2;subst;simpl in *. + destruct n1. + intros. destruct (decide (n = 0)%nat). right;simpl. + destruct (decide (n2 < n0)%nat). lia. exfalso. apply Hnle. + right;simpl;lia. + left;simpl;lia. + intros. destruct n. exfalso. apply Hnle. left;simpl;lia. + destruct (decide (n < n1)%nat). exfalso. apply Hnle. left;simpl;lia. + destruct (decide (n1 < n)%nat). left;simpl;lia. + assert (n1 = n) as -> by lia. right;simpl. split;first done. + destruct (decide (n2 < n0)%nat). done. + exfalso. apply Hnle. right;simpl. split;lia. + Qed. + + Lemma progress_nlt_ge pg1 pg2 : (progress_lt pg1 pg2 -> False) -> + progress_le pg2 pg1. + Proof. + intros Hnlt. destruct pg1; destruct pg2;subst;simpl in *. + destruct n1. + intros. destruct (decide (n = 0)%nat). right;simpl. + destruct (decide (n2 <= n0)%nat). lia. exfalso. apply Hnlt. + right;simpl;lia. + left;simpl;lia. + intros. destruct n. exfalso. apply Hnlt. left;simpl;lia. + destruct (decide (n < n1)%nat). exfalso. apply Hnlt. left;simpl; lia. + destruct (decide (n1 < n)%nat). left;simpl;lia. + assert (n1 = n) as -> by lia. right;simpl. split;first done. + destruct (decide (n2 <= n0)%nat). done. + exfalso. apply Hnlt. right;simpl. split;lia. + Qed. + + Lemma progress_iid_le_next_instr ts: + let iis := (mk_iis_ni ts) in + forall pg, progress_lt pg (iis_iid iis, iis_cntr iis) -> + (pg.1 <= (get_progress ts).1)%nat. + Proof. + intros iis pg Hlt. + rewrite /iis /= /mk_iis_ni /= in Hlt. + destruct pg as [iid eid];rewrite /get_progress /=. + destruct (decide ((iis_iid (ts_iis ts)) < iid)%nat);[|lia]. + destruct Hlt as [Hlt | [Heq Hlt ]];simpl in *;lia. + Qed. + + Lemma progress_iid_le_same_instr ts: + let pg' := (iis_iid (ts_iis ts), iis_cntr (ts_iis ts) + 1)%nat in + forall pg, progress_lt pg pg' -> + (pg.1 <= (get_progress ts).1)%nat. + Proof. + intros iis pg Hlt. + rewrite /iis /= in Hlt. + destruct pg as [iid eid];rewrite /=. + destruct (decide ((iis_iid (ts_iis ts)) < iid)%nat);[|lia]. + destruct Hlt as [Hlt | [Heq Hlt ]];simpl in *;lia. + Qed. + + Lemma progress_adjacent_incr_cntr ts pg' pg'': + progress_le (get_progress ts) pg'' -> + progress_lt pg'' pg' -> + pg' = (get_progress (incr_cntr ts)) -> + (get_progress ts) = pg''. + Proof. + rewrite /incr_cntr /get_progress /=. + intros Hle Hlt ->. + efeed pose proof (progress_iid_le_same_instr ts) as Hiid_le;eauto. + rewrite Nat.le_lteq in Hiid_le; destruct Hiid_le as [Hiid_lt | Hiid_eq]. + - exfalso. rewrite progress_le_inv in Hle. destruct pg'';simpl in *. destruct Hle as [Hlt' | Heq]. + destruct Hlt' as [H1|H1];simpl in H1;try lia. inversion Heq;lia. + - destruct pg'';simpl in *. + subst n. destruct Hlt as [?|[_ Hlt]];simpl in *; [lia|]. + destruct Hle as [?|[_ Hle]];simpl in *; [lia|]. + by assert (n0 = iis_cntr (ts_iis ts)) as -> by lia. + Qed. + + Definition ts_is_done_instr gr (tid : Tid) ts := + let instr_pg := get_progress ts in + let instr_eids := + (filter (fun e => bool_decide (e.(EID.tid) = tid) && bool_decide (e.(EID.iid) = instr_pg.1 )) (Candidate.valid_eid gr)) in + set_Forall (λ e, progress_lt (progress_of_node e) instr_pg) instr_eids. + + Lemma ts_is_done_instr_inv gr (tid : Tid) ts: + let instr_pg := get_progress ts in + ts_is_done_instr gr tid ts -> + forall pg, + progress_is_valid gr tid pg -> + instr_pg.1 = pg.1 -> + progress_lt pg instr_pg. + Proof. + rewrite /ts_is_done_instr /=. + intros Hdone pg Hvalid Hiid_eq. + specialize (Hdone (EID.make tid pg.1 pg.2)). + rewrite /progress_of_node /= in Hdone. + apply Hdone. + rewrite elem_of_filter /=. + split. case_bool_decide;[case_bool_decide;done|done]. + apply Hvalid. + Qed. + + Lemma ts_is_done_instr_progress_invalid gr (tid : Tid) ts: + let instr_pg := get_progress ts in + ts_is_done_instr gr tid ts -> + ¬ progress_is_valid gr tid instr_pg. + Proof. + intros ? Hdone Hvalid. + eapply progress_lt_refl_False. + eapply ts_is_done_instr_inv;eauto. + Qed. + + (* progress of any local event is behind the latest progress *) + Definition ts_is_done_thd gr (tid : Tid) ts := + set_Forall (λ e, progress_lt (progress_of_node e) (get_progress ts)) (Graph.local_eids gr tid). + + Lemma ts_is_done_thd_inv gr (tid : Tid) ts: + let last_pg := get_progress ts in + ts_is_done_thd gr tid ts -> + forall pg, + progress_is_valid gr tid pg -> + progress_lt pg last_pg. + Proof. + rewrite /ts_is_done_thd /=. + intros Hdone pg Hvalid. + specialize (Hdone (EID.make tid pg.1 pg.2)). + rewrite /progress_of_node /= in Hdone. + apply Hdone. + rewrite elem_of_filter /=. + split; [done|apply Hvalid]. + Qed. + + Lemma ts_is_done_thd_progress_invalid gr (tid : Tid) ts: + let last_pg := get_progress ts in + ts_is_done_thd gr tid ts -> + ¬ progress_is_valid gr tid last_pg. + Proof. + intros ? Hdone Hvalid. + eapply progress_lt_refl_False. + eapply ts_is_done_thd_inv;eauto. + Qed. + + Lemma progress_to_node_mk_eid_ii tid ts pg: + get_progress ts = pg -> + progress_to_node pg tid = mk_eid_ii ts tid. + Proof. + intros Hpg. rewrite /progress_to_node /mk_eid_ii. + rewrite -Hpg. destruct pg;done. + Qed. + + Lemma progress_adjacent_incr_cntr' ts pg: + progress_lt pg (get_progress (incr_cntr ts)) <-> + progress_le pg (get_progress ts). + Proof. + rewrite /incr_cntr /get_progress /=. + split. + { + intros Hlt. + efeed pose proof (progress_iid_le_same_instr ts) as Hiid_le;eauto. + rewrite Nat.le_lteq in Hiid_le; destruct Hiid_le as [Hiid_lt | Hiid_eq]. + - left;done. + - destruct pg;simpl in *. + subst n. destruct Hlt as [?|[_ Hlt]];simpl in *; [lia|]. + right;split. done. simpl;lia. + } + { + intros Hle. rewrite progress_le_inv in Hle. + destruct Hle as [Hlt | ->]. + eapply progress_lt_trans;eauto. + right. split; simpl;lia. + right. split; simpl;lia. + } + Qed. + + (* progress of any local event is after or equal to the initial progress, + this combined with above and some others can give us that all thread local events are checked if we have a complete local execution *) + Definition progress_is_init gr (tid : Tid) pg := + set_Forall (λ e, progress_le pg (progress_of_node e)) (Graph.local_eids gr tid). + +End ThreadState. + +Notation "p1 ' true + | LTSNormal _ => false + end. + + Notation is_terminated := is_done. + + Definition get_progress lts := + match lts with + | LTSNormal ts => get_progress ts + | LTSDone ts => get_progress ts + end. + + (* Prop version *) + Notation at_progress lts pg := (LThreadState.get_progress lts = pg). + + Lemma progress_unique s pg pg': + at_progress s pg -> + at_progress s pg' -> pg = pg'. + Proof. + intros H1 H2. destruct s;try done; + rewrite H1 in H2; inversion_clear H2; done. + Qed. + +End LThreadState. + +Section machine_mixin. + Context {local_state global_const id : Type}. + Context (terminated : local_state → bool). + + Context (prim_step : global_const -> id → local_state → local_state → Prop). + + Record MachineMixin := { + mixin_terminated_stuck g i σ σ' : + prim_step g i σ σ' → terminated σ = false; + }. +End machine_mixin. + +Module LThreadStep. + Import GInstrMem. + Import AAInter. + Import GlobalState. + Export LThreadState. + + (* union of all register dependencies + memory dependencies *) + Definition deps_of_depon tid ts dep := + match dep with + (* None is not reachable, but we might need to fix it. Since [None] is interpreted as + "depending on all previous registers and memory values that were read" in the Interface *) + | None => ∅ + | Some depon => + (* union of all register dependencies + memory dependencies *) + fold_right (fun r acc => from_option (λ rd, rd.(reg_dep) ∪ acc) acc (ts.(ts_regs) !! r)) ∅ depon.(DepOn.regs) + ∪ + fold_right (fun idx acc => from_option (λ md, {[EID.make tid ts.(ts_iis).(iis_iid) md]} ∪ acc) acc (ts.(ts_iis).(iis_mem_reads) !! idx)) ∅ depon.(DepOn.mem_reads) + end. + + Inductive t (gs: GlobalState.t) (tid: Tid) : LThreadState.t -> LThreadState.t -> Prop := + | TStepReload ts rv instr: + (* current instruction is done *) + reqs_done ts -> + (* all events of current instructions are checked *) + ts_is_done_instr gs.(gs_graph) tid ts -> + (* val of PC is [rv] *) + ts.(ts_regs) !! RNPC = Some rv -> + (* next instruction is [instr] *) + gs.(gs_gimem) !! rv.(reg_val) = Some instr -> + (* update [ts] with new trace *) + t gs tid (LTSNormal ts) (LTSNormal ((reset_cntr ts) <| ts_reqs := (InstrInterp instr) |>)) + | TStepTerm ts rv : + (* current instruction is done, address of the next instruction is [iaddr] *) + reqs_done ts -> + (* val of PC is [rv] *) + ts.(ts_regs) !! RNPC = Some rv -> + (* no more instructions to run *) + gs.(gs_gimem) !! rv.(reg_val) = None -> + (* fulfillment check *) + ts_is_done_thd gs.(gs_graph) tid ts -> + (* this thread is done *) + t gs tid (LTSNormal ts) (LTSDone ts) + | TStepRegRead ts r v ctxt : + let req := (RegRead r true) in + (* current request is RegRead, [ctxt] is the continuation *) + next_req_is ts req ctxt -> + (* we can find an event with same request in graph, the response is [v] *) + gs.(gs_graph) !! (mk_eid_ii ts tid) = Some (IEvent req v) -> + (* local reg has same value *) + (∃ rv, ts.(ts_regs) !! r = Some rv ∧ rv.(reg_val) = v) -> + (* increment [iis_cntr] and set [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr ts) + <| ts_reqs := (ctxt v) |>)) + | TStepRegWrite ts r dep v ctxt : + let req := (RegWrite r true dep v) in + (* current request is RegWrite, [ctxt] is the continuation *) + next_req_is ts req ctxt -> + (* we can find an event with same request in graph, no response is expected*) + gs.(gs_graph) !! (mk_eid_ii ts tid) = Some (IEvent req tt) -> + (* computing the dependencies *) + let reg_dep := deps_of_depon tid ts dep in + (* incrementing [iis_cntr], updating register, setting [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr ts) + <| ts_regs := <[r := mk_regval v reg_dep]>(ts.(ts_regs)) |> + <| ts_reqs := (ctxt tt) |>)) + | TStepBranch ts baddr dep ctxt: + let req := (BranchAnnounce baddr dep) in + (* current request is RegWrite, [ctxt] is the continuation *) + next_req_is ts req ctxt -> + let eid := (mk_eid_ii ts tid) in + (* we can find an event with same request in graph, no response is expected*) + gs.(gs_graph) !! (mk_eid_ii ts tid) = Some (IEvent req tt) -> + (* computing the dependencies *) + let cond_dep := deps_of_depon tid ts dep in + (* incrementing [iis_cntr], updating [ts_ctrl_srcs], setting [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr ts) <| ts_ctrl_srcs := cond_dep ∪ ts.(ts_ctrl_srcs) |> + <| ts_reqs := (ctxt tt) |>)) + | TStepBarrierDmb ts dκ ctxt: + let req := (AAInter.Barrier (AAArch.DMB dκ)) in + (* current request is RegWrite, [ctxt] is the continuation *) + next_req_is ts req ctxt -> + let eid := (mk_eid_ii ts tid) in + (* we can find an event with same request in graph, no response is expected*) + gs.(gs_graph) !! eid = Some (IEvent req tt) -> + (* there are e_ctrl_src -ctrl-> eid *) + ((ts.(ts_ctrl_srcs)) × ({[eid]})) ⊆ (Candidate.ctrl gs.(gs_graph)) -> + (* incrementing [iis_cntr], updating [ts_po_src], setting [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr ts) <| ts_reqs := (ctxt tt) |>)) + | TStepBarrierIsb ts ctxt: + let req := (AAInter.Barrier AAArch.ISB) in + (* current request is RegWrite, [ctxt] is the continuation *) + next_req_is ts req ctxt -> + let eid := (mk_eid_ii ts tid) in + (* we can find an event with same request in graph, no response is expected*) + gs.(gs_graph) !! eid = Some (IEvent req tt) -> + (* there are e_ctrl_src -ctrl-> eid *) + ((ts.(ts_ctrl_srcs)) × ({[eid]})) ⊆ (Candidate.ctrl gs.(gs_graph)) -> + (* incrementing [iis_cntr], updating [ts_po_src], setting [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr ts) <| ts_reqs := (ctxt tt) |>)) + | TStepReadMem ts sz rreq mv ctxt: + let req := (MemRead sz rreq) in + (* current request is RegWrite, [ctxt] is the continuation *) + next_req_is ts req ctxt -> + let eid := (mk_eid_ii ts tid) in + let resp := (inl (mv, None)) in + (* we can find an event with same request in graph *) + gs.(gs_graph) !! eid = Some (IEvent req resp) -> + (* there are e_addr_src -addr-> eid *) + ((deps_of_depon tid ts rreq.(ReadReq.addr_dep_on)) × ({[eid]})) ⊆ (Candidate.addr gs.(gs_graph)) -> + (* there are e_ctrl_src -ctrl-> eid *) + ((ts.(ts_ctrl_srcs)) × ({[eid]})) ⊆ (Candidate.ctrl gs.(gs_graph)) -> + (* incrementing [iis_cntr], updating [ts_po_src], setting [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr (ts <| ts_iis := (ts.(ts_iis) <| iis_mem_reads := ((ts.(ts_iis).(iis_mem_reads)) ++ [ts.(ts_iis).(iis_cntr)] )|>)|>)) + <| ts_reqs := (ctxt resp) |> + <| ts_rmw_pred := if AACandExec.Candidate.kind_of_rreq_is_atomic rreq then Some eid else ts.(ts_rmw_pred) |>)) + | TStepWriteMem ts sz wreq ctxt: + AACandExec.Candidate.kind_of_wreq_is_atomic wreq = false -> + let req := (MemWrite sz wreq) in + (* current request is MemWrite, [ctxt] is the continuation *) + next_req_is ts req ctxt -> + let eid := (mk_eid_ii ts tid) in + let resp := (inl None) in + (* we can find an event with same request in graph, no response is expected*) + gs.(gs_graph) !! eid = Some (IEvent req resp) -> + (* there are e_addr_src -addr-> eid *) + ((deps_of_depon tid ts wreq.(WriteReq.addr_dep_on)) × ({[eid]})) ⊆ (Candidate.addr gs.(gs_graph)) -> + (* there are e_data_src -data-> eid *) + ((deps_of_depon tid ts wreq.(WriteReq.data_dep_on)) × ({[eid]})) ⊆ (Candidate.data gs.(gs_graph)) -> + (* there are e_ctrl_src -ctrl-> eid *) + ((ts.(ts_ctrl_srcs)) × ({[eid]})) ⊆ (Candidate.ctrl gs.(gs_graph)) -> + (* incrementing [iis_cntr], updating [ts_po_src], setting [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr ts) <| ts_reqs := (ctxt resp) |>)) + | TStepWriteMemAtomicSucc ts sz wreq ctxt rmw_pred: + AACandExec.Candidate.kind_of_wreq_is_atomic wreq = true -> + ts.(ts_rmw_pred) = Some rmw_pred -> + let req := (MemWrite sz wreq) in + (* current request is MemWrite, [ctxt] is the continuation *) + next_req_is ts req ctxt -> + let eid := (mk_eid_ii ts tid) in + let resp := (inl (Some true)) in + (* we can find an event with same request in graph, respond with succuss*) + gs.(gs_graph) !! eid = Some (IEvent req resp) -> + (rmw_pred, eid) ∈ (Candidate.rmw gs.(gs_graph)) -> + (* there are e_addr_src -addr-> eid *) + ((deps_of_depon tid ts wreq.(WriteReq.addr_dep_on)) × ({[eid]})) ⊆ (Candidate.addr gs.(gs_graph)) -> + (* there are e_data_src -data-> eid *) + ((deps_of_depon tid ts wreq.(WriteReq.data_dep_on)) × ({[eid]})) ⊆ (Candidate.data gs.(gs_graph)) -> + (* there are e_ctrl_src -ctrl-> eid *) + ((ts.(ts_ctrl_srcs)) × ({[eid]})) ⊆ (Candidate.ctrl gs.(gs_graph)) -> + (* incrementing [iis_cntr], updating [ts_po_src], setting [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr ts) <| ts_reqs := (ctxt resp) |>)) + | TStepWriteMemAtomicFail ts sz wreq ctxt: + AACandExec.Candidate.kind_of_wreq_is_atomic wreq = true -> + let req := (MemWrite sz wreq) in + next_req_is ts req ctxt -> + let eid := (mk_eid_ii ts tid) in + let resp := (inl (Some false)) in + (* we can find an event with same request in graph, respond with failure*) + gs.(gs_graph) !! eid = Some (IEvent req resp) -> + (* incrementing [iis_cntr], updating [ts_po_src], setting [ctxt] as the new [ts_reqs] *) + t gs tid (LTSNormal ts) (LTSNormal ((incr_cntr ts) <| ts_reqs := (ctxt resp) |>)) + . + + Lemma step_not_terminated gs tid lts lts' : + t gs tid lts lts' → is_terminated lts = false. + Proof. intros [];reflexivity. Qed. + + Lemma steps_not_terminated {gs tid lts} lts' n : + nsteps (t gs tid) (S n) lts lts' -> + is_terminated lts = false. + Proof. inversion 1. by eapply step_not_terminated. Qed. + + Lemma machine_mixin : MachineMixin is_terminated t. + Proof. + refine {| mixin_terminated_stuck := step_not_terminated |}. + Qed. + + Lemma step_progress_mono {gs tid lts lts'} : + t gs tid lts lts' -> + is_terminated lts' = false -> + (get_progress lts)

+ (get_progress lts) <=p (get_progress lts'). + Proof. + inversion 1; + subst;rewrite /reset_cntr /incr_cntr /ThreadState.get_progress /=;try (right;simpl;split;lia). + left. simpl;lia. + Qed. + + Lemma steps_progress_mono {gs tid lts lts'} n : + nsteps (t gs tid) (S n) lts lts' -> + is_terminated lts' = false -> + (get_progress lts)

+ (get_progress lts) <=p (get_progress lts'). + Proof. + revert lts lts'. induction n; intros ?? Hsteps. + - inversion Hsteps;subst. + apply progress_le_refl. + - inversion Hsteps as [|???lts''??Hstep?Hsteps'];subst. + set pg'' := (get_progress lts''). + eapply (progress_le_trans). + eapply step_progress_mono';eauto. + eapply IHn;eauto. + Qed. + + Lemma step_progress_ne {gs tid} lts lts': + t gs tid lts lts' -> + is_terminated lts' = false -> + (get_progress lts) ≠ (get_progress lts'). + Proof. intros. apply progress_lt_neq. eapply LThreadStep.step_progress_mono;eauto. Qed. + + Lemma step_progress_done_invalid {gs tid lts lts'} pg: + t gs tid lts lts' -> + is_done lts' -> + at_progress lts pg -> + ¬ progress_is_valid (gs_graph gs) tid pg. + Proof. + inversion 1 as [ |??????Hdone| | | | | | | | |];inversion 1;subst. + inversion 1. intros ?. + specialize (Hdone (progress_to_node pg tid)). + subst pg. feed specialize Hdone. + apply elem_of_filter. split;done. + rewrite /progress_of_node /progress_to_node /= in Hdone. + eapply progress_lt_refl_False. apply Hdone. + Qed. + + (* NOTE it is not true! *) + (* Lemma step_progress_valid {gs tid} s s' pg: *) + (* t gs tid s s' -> *) + (* at_progress s pg -> *) + (* progress_is_valid gs.(GlobalState.gs_graph) tid pg. *) + + (* This is the key helper for showing that we don't skip events *) + Lemma step_progress_adjacent {gs tid} s s': + t gs tid s s' -> + (* if there is another valid event between the two, it has to be pg *) + forall pg'', progress_is_valid gs.(GlobalState.gs_graph) tid pg'' -> + (get_progress s) <=p pg'' -> pg''

+ (get_progress s) = pg''. + Proof. + intros Hstep pg'' Hvalid Hge Hlt. + inversion Hstep;subst. + - epose proof ts_is_done_instr_inv as Hinv. + feed specialize Hinv. eauto. + epose proof (progress_iid_le_next_instr _ _ Hlt) as Hiid_le. + rewrite Nat.le_lteq in Hiid_le; destruct Hiid_le as [Hiid_lt | Hiid_eq] + + exfalso. rewrite progress_le_inv in Hge. destruct pg'';simpl in *. destruct Hge as [Hlt' | Hlt'];try lia. + destruct Hlt' as [Hlt' | Hlt']; simpl in Hlt';lia. inversion Hlt';lia. + + efeed specialize Hinv;eauto. exfalso. eapply progress_le_gt_False;eauto. + - exfalso. epose proof ts_is_done_thd_inv as Hinv. + efeed specialize Hinv; eauto. eapply progress_le_gt_False;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + - eapply progress_adjacent_incr_cntr;eauto. + Qed. + + Lemma step_progress_valid_is_reqs_nonempty gs tid s' ts pg: + ThreadState.get_progress ts = pg -> + t gs tid (LTSNormal ts) s' -> + (ThreadState.progress_is_valid (GlobalState.gs_graph gs) tid pg) + <-> + (ThreadState.ts_reqs ts ≠ EmptyInterp). + Proof. + intros Hpg Hstep. + inversion Hstep;subst; + match goal with + | [ Hreq_eq : ThreadState.reqs_done ?ts |- _ ] => rewrite /ThreadState.reqs_done in Hreq_eq; + rewrite Hreq_eq;split;last done;intros + | [ Hreq_eq : next_req_is ?ts ?req ?ctxt |- _ ] => + rewrite /next_req_is in Hreq_eq; + rewrite Hreq_eq;split;first done;intros _; + rewrite /progress_is_valid; + (erewrite progress_to_node_mk_eid_ii;eauto); + set_unfold;eauto + | _ => idtac + end. + eapply ts_is_done_instr_inv in H1;eauto; exfalso;eapply ThreadState.progress_lt_refl_False;eauto. + eapply ts_is_done_thd_inv in H3;eauto; exfalso;eapply ThreadState.progress_lt_refl_False;eauto. + Qed. + + Lemma steps_traverse_all_eids {gs tid} n lts lts' : + nsteps (t gs tid) n lts lts' → + is_terminated lts' = false -> + ∀ pg'', progress_is_valid (gs.(gs_graph)) tid pg'' -> + (exists n1 n2 lts'', n1 + n2 = n ∧ n2 > 0 ∧ + get_progress lts'' = pg'' ∧ + nsteps (t gs tid) n1 lts lts'' ∧ + nsteps (t gs tid) n2 lts'' lts')%nat + <-> (get_progress lts <=p pg'' ∧ pg''

lts lts' /=. + - inversion_clear 1. + intros Hnotgs ? Hvalid. split. + + intros (n1 & n2 & lts'' & Heqn & Hgtz & Hpg'' & Hsteps1 & Hsteps2). lia. + + intros (Hge & Hlt'); exfalso. by eapply progress_le_gt_False. + - intros Hsteps Hngs ? Hvalid. split. + + intros (n1 & n2 & lts'' & Hsum & Hgtz& Hpg'' & Hsteps1 & Hsteps2). + destruct n1. + * inversion Hsteps1;subst. + split; first apply progress_le_refl. eapply steps_progress_mono;eauto. + * inversion_clear Hsteps1 as [|? ? lts''' ? Hfststep Hsteps1']. + assert (n1 + n2 = n)%nat as Hsum' by lia. + specialize (IH lts''' lts'). + feed specialize IH. rewrite -Hsum'. by eapply nsteps_trans. done. + specialize (IH pg'' Hvalid). destruct IH as [IH _]. feed specialize IH. + exists n1, n2, lts''. repeat (split;first done). done. + destruct IH as (Hge & Hlt). split;last done. + epose proof (step_progress_mono Hfststep) as Hlts. efeed specialize Hlts;eauto. + destruct n;first lia. eapply (steps_not_terminated lts' n);eauto. + rewrite -Hsum'. eapply nsteps_trans;eauto. + epose proof (steps_progress_mono' _ Hsteps1') as Hle';auto. + efeed specialize Hle';eauto. eapply progress_le_trans;eauto. apply progress_lt_le;auto. + + intros (Hge & Hlt). + inversion_clear Hsteps as [|? ? lts''' ? Hfststep Hsteps']. + destruct n. + * specialize (IH lts''' lts'). + feed specialize IH; auto. + inversion Hsteps';subst. + epose proof (step_progress_adjacent _ _) as Hpgeq;eauto. + feed specialize Hpgeq;eauto. + efeed specialize Hpgeq;eauto. subst pg''. + exists 0%nat,1%nat, lts. split;[lia|split;[lia|]]. repeat (split;first done). + split. constructor. by apply nsteps_once. + * inversion_clear Hsteps'. + destruct (decide ((get_progress lts''') = pg'')). + -- specialize (IH lts''' lts'). + feed specialize IH;auto. eapply nsteps_l;eauto. + specialize (IH _ Hvalid). destruct IH as [_ IH]. feed specialize IH. + split;auto. subst pg''. apply progress_le_refl. + exists 1%nat, (S n), lts'''. split;first lia. + split;first lia. repeat (split;first done). + split. econstructor;eauto. constructor. eapply nsteps_l;eauto. + -- destruct (decide (pg'' <=p (get_progress lts'''))) as [Hle'|Hnle']. + rewrite progress_le_inv in Hle'. + destruct Hle';last done. + efeed pose proof (step_progress_adjacent lts lts''' Hfststep);eauto. + subst pg''. + exists 0%nat, (S (S n)), lts. + split;first done. split;first lia. split;first done. + split. constructor. econstructor;eauto. eapply nsteps_l;eauto. + specialize (IH lts''' lts'). + feed specialize IH; auto. eapply nsteps_l;eauto. + specialize (IH _ Hvalid). destruct IH as [_ IH]. feed specialize IH. + split;last done. apply progress_nle_gt in Hnle'. rewrite progress_le_inv. left;done. + destruct IH as (n1 & n2 & lts'' & Hsum & Hnz & ? & ? & ?). destruct n1. + inversion H2. subst. done. + exists (S (S n1)), n2, lts''. split;first lia. + split;first lia. repeat (split;first done). + split. econstructor. exact Hfststep. done. done. + Qed. + + Definition eids_between gr tid lts lts' := + let (pg, pg') := (get_progress lts, get_progress lts') in + let all_po_pre := filter (λ e : Eid, (progress_of_node e)

+ e.(EID.tid) = tid. + Proof. + rewrite /eids_between. destruct (get_progress lts);destruct (get_progress lts');intro;set_solver. + Qed. + + Lemma eids_between_inv gr tid lts lts' : + forall pg'', + ( progress_is_valid gr tid pg'' ∧ get_progress lts <=p pg'' ∧ pg'' (progress_to_node pg'' tid) ∈ (eids_between gr tid lts lts'). + Proof. + intros ?. split. + - intros (Hvalid & Hge & Hlt). + rewrite /eids_between /=. + rewrite elem_of_difference;rewrite /progress_of_node /=;split. + + apply elem_of_filter. split;first done. + rewrite /local_eids /=. apply elem_of_filter. split;done. + + intro Hf. rewrite elem_of_filter /= in Hf. destruct Hf as [Hlt' _]. + eapply progress_le_gt_False;eauto. + - intros Helem. + destruct (decide (eids_between gr tid lts lts' = ∅)) as [|Hnept];first set_solver. + rewrite /eids_between in Helem. + rewrite elem_of_difference elem_of_filter /progress_of_node /= in Helem. + destruct Helem as [[Hlt Hvalid] Hnelem];split. + + rewrite /local_eids elem_of_filter /= in Hvalid. destruct Hvalid as [_ ?];done. + + split;last done. destruct (decide ((get_progress lts)

+ (progress_is_valid gr tid pg). + Proof. + rewrite /eids_between. destruct (get_progress lts);destruct (get_progress lts');intro;set_solver. + Qed. + + Lemma steps_traversed_eids {gs tid} n lts lts' : + nsteps (t gs tid) n lts lts' → + is_terminated lts' = false -> + ∀ pg'', progress_is_valid (gs.(gs_graph)) tid pg'' -> + (exists n1 n2 lts'', n1 + n2 = n ∧ n2 > 0 ∧ + get_progress lts'' = pg'' ∧ + nsteps (t gs tid) n1 lts lts'' ∧ + nsteps (t gs tid) n2 lts'' lts')%nat + <-> (progress_to_node pg'' tid) ∈ (eids_between (gs.(gs_graph)) tid lts lts'). + Proof. + intros. rewrite -eids_between_inv. epose proof steps_traverse_all_eids as Heq. + efeed specialize Heq;eauto. rewrite Heq. + split;intros (?&?);repeat destruct Hpg as [? Hpg];eauto. + Qed. + + Lemma traversed_eids_empty {gs tid} lts : + (eids_between (gs.(GlobalState.gs_graph)) tid lts lts) = ∅. + Proof. rewrite /eids_between /=. rewrite difference_diag_L //. Qed. + + Lemma step_traversed_eids_valid_singleton {gs tid} lts lts' : + t gs tid lts lts' → + progress_is_valid (gs.(gs_graph)) tid (get_progress lts) -> + (eids_between (gs.(GlobalState.gs_graph)) tid lts lts') = {[progress_to_node (get_progress lts) tid]}. + Proof. + intros Hstep Hvalid. + destruct lts'. + - apply set_eq. intros e. rewrite elem_of_singleton. + split. + + intro Hin. + assert (e = (progress_to_node (progress_of_node e) tid)) as Heqe. + { + rewrite /progress_to_node /progress_of_node /=. + destruct e eqn:Heqn. simpl. + efeed pose proof elem_of_eids_between_in_thd as Htid;eauto. + rewrite -Htid //. + } + rewrite Heqe in Hin. + eapply (steps_traversed_eids 1) in Hin;eauto. + destruct Hin as (n1 & n2 & lts'' & Hsum & Hgt & Hpg'' & Hstep1 & _). + assert (n1 = 0)%nat as -> by lia. + inversion Hstep1. subst. inversion Hpg''. rewrite Heqe. f_equal. eapply progress_unique;eauto. + by apply nsteps_once. + eapply eids_between_inv_pg_valid;eauto. + + intros ->. + eapply eids_between_inv. + repeat split;try done. eapply progress_le_refl. + eapply step_progress_mono;eauto. + - exfalso. eapply step_progress_done_invalid;eauto. + Qed. + + Lemma step_traversed_eids_done_empty {gs tid} lts lts' : + t gs tid lts lts' → + is_done lts' = true -> + (eids_between (gs.(GlobalState.gs_graph)) tid lts lts') = ∅. + Proof. + inversion 1; inversion 1. + rewrite /eids_between /=. set_solver +. + Qed. + + Lemma step_traversed_eids_invalid_empty {gs tid} lts lts' : + t gs tid lts lts' → + forall pg, at_progress lts pg -> + ¬ progress_is_valid (gs.(gs_graph)) tid pg -> + (eids_between (gs.(GlobalState.gs_graph)) tid lts lts') = ∅. + Proof. + intros Hstep ? Hpg Hnvalid. + destruct lts'. + - apply set_eq. intros e. rewrite elem_of_empty. + split;[|intro;exfalso;auto]. + intro Hin. + assert (e = (progress_to_node (progress_of_node e) tid)) as Heqe. + { + rewrite /progress_to_node /progress_of_node /=. + destruct e eqn:Heqn. simpl. + efeed pose proof elem_of_eids_between_in_thd as Htid;eauto. + rewrite -Htid //. + } + rewrite Heqe in Hin. pose proof Hin. + eapply (steps_traversed_eids 1) in Hin;eauto. + destruct Hin as (n1 & n2 & lts'' & Hsum & Hgt & Hpg'' & Hstep1 & _). + assert (n1 = 0)%nat as -> by lia. + inversion Hstep1. subst. + subst. apply Hnvalid. + eapply eids_between_inv_pg_valid;eauto. rewrite Hpg'' //. + by apply nsteps_once. + eapply eids_between_inv_pg_valid;eauto. + - apply step_traversed_eids_done_empty;auto. + Qed. + + Lemma progress_le_eids_subseteq gr tid pg pg' : + pg <=p pg' -> + filter (λ e : Eid, (progress_of_node e)

];last done. + eapply progress_lt_trans;eauto. + Qed. + + (* This is the key lemma used in the induction case of the nsteps lifting lemma. *) + Lemma steps_traversed_eids_union {gs tid} n lts lts'' lts' : + t gs tid lts lts'' → + nsteps (t gs tid) n lts'' lts' → + (eids_between (gs.(gs_graph)) tid lts lts') + = (if (bool_decide (progress_is_valid (gs.(gs_graph)) tid (get_progress lts))) + then {[progress_to_node (get_progress lts) tid]} else ∅) ∪ (eids_between (gs.(gs_graph)) tid lts'' lts'). + Proof. + intros Hstep Hsteps. rewrite /eids_between. + destruct n. + - inversion Hsteps. subst. + rewrite difference_diag_L union_empty_r_L. + case_bool_decide. + erewrite <-(step_traversed_eids_valid_singleton lts lts');eauto. rewrite /eids_between //. + erewrite <-(step_traversed_eids_invalid_empty lts lts');eauto. + - inversion Hsteps as [|???? Hstep']. subst. + set (B := filter (λ e : Eid, progress_of_node e

+ eids_from_init gr tid pg = ∅. + Proof. + intro Hinit. rewrite /eids_from_init. + apply set_eq. split;last done. + rewrite elem_of_filter. + intros [Hlt Hin]. exfalso. + specialize (Hinit _ Hin). + eapply ThreadState.progress_le_gt_False;eauto. exact Hinit. + Qed. + + Lemma eids_from_init_po_pred_of gr (tid : Tid) pg: + AACandExec.NMSWF.wf gr -> + progress_is_valid gr tid pg -> + po_pred_of gr (ThreadState.progress_to_node pg tid) = eids_from_init gr tid pg. + Proof. + intros Hwf Hvalid. apply set_eq. + intros e. rewrite elem_of_filter. rewrite /po_pred_of. + split. + - intro Hpo. + set_unfold in Hpo. + destruct Hpo as [e' [-> Hpo]]. + assert(Heid : EID.tid e = tid). { pose (G:= Graph.po_valid_eids gr e (progress_to_node pg tid) Hwf Hpo). destruct G as [_ ->]. by simpl. } + pose proof (progress_lt_po _ tid (progress_of_node e) pg Hwf) as [_ Himp]. + feed specialize Himp. rewrite progress_to_node_of_node //. + destruct Himp as [Hlt [Hvalide Hvalid']]. + split;first auto. + apply elem_of_filter. split;first assumption. + by rewrite /progress_is_valid progress_to_node_of_node in Hvalide. + - intros [Hlt Hlc]. + rewrite elem_of_filter in Hlc. + destruct Hlc as [Htid Hvalid']. + pose proof (progress_lt_po _ tid (progress_of_node e) pg Hwf) as [Himp _]. + feed specialize Himp. + split;auto. split;auto. rewrite /progress_is_valid. + rewrite progress_to_node_of_node //. + set_unfold. exists (progress_to_node pg tid). + split;auto. rewrite progress_to_node_of_node // in Himp. + Qed. + + Lemma step_traversed_eids_from_init_union {gs tid} lts lts' : + t gs tid lts lts' → + (eids_from_init (gs.(gs_graph)) tid (get_progress lts')) + = (if (bool_decide (progress_is_valid (gs.(gs_graph)) tid (get_progress lts))) + then {[progress_to_node (get_progress lts) tid]} else ∅) ∪ (eids_from_init (gs.(gs_graph)) tid (get_progress lts)). + Proof. + intros Hstep. + rewrite /eids_from_init. + efeed pose proof (LThreadStep.step_progress_mono' Hstep) as Hle;eauto. + case_bool_decide as Hpg_valid. + - erewrite <-(step_traversed_eids_valid_singleton lts lts');eauto. rewrite /eids_between //. + epose proof (progress_le_eids_subseteq (gs_graph gs) tid (get_progress lts) (get_progress lts') Hle) as Hsub. + rewrite difference_union_L. set_solver + Hsub. + - rewrite union_empty_l_L. symmetry. + pose proof (LThreadStep.step_progress_mono' Hstep). + apply set_eq. intros x. rewrite 2!elem_of_filter. split. + intros [Hlt Hvalid]. split;last auto. + eapply ThreadState.progress_lt_trans'1;eauto. + intros [Hlt Hvalid]. split;last auto. + destruct (decide (ThreadState.progress_of_node x

+ e.(EID.tid) = tid. + Proof. + rewrite /eids_between. + destruct (LThreadState.get_progress lts);destruct (LThreadState.get_progress lts');intro;set_solver. + Qed. + + Lemma eids_between_full gs tid lts lts': + ThreadState.progress_is_init (gs.(GlobalState.gs_graph)) tid (LThreadState.get_progress lts) -> + is_terminated lts' = true -> + (* NOTE: the equality holds only if we take at least a step to Done, it proprogate to [tpsteps] *) + (∃ n, nsteps (LThreadStep.t gs tid) (S n) lts lts') -> + filter (Graph.is_local_node_of tid) (Candidate.valid_eid (gs.(GlobalState.gs_graph))) + = LThreadStep.eids_between (gs.(GlobalState.gs_graph)) tid lts lts'. + Proof. + intros Hinit Hterm [n Hstep]. + rewrite /eids_between. + epose proof (eids_from_init_empty (LThreadState.get_progress lts)) as Hept. + feed specialize Hept; eauto. + rewrite /eids_from_init in Hept. rewrite Hept. + rewrite difference_empty_L. + apply nsteps_inv_r in Hstep. destruct Hstep as [? [? Hstep]]. + inversion Hstep as [ | ? ? ? ? ? Hdone | | | | | | | | | ];subst;try inversion Hterm. + apply set_eq. intro. rewrite /local_eids 3!elem_of_filter. + split. + - intros [Htid Hin]. split;last done. + specialize (Hdone x); feed specialize Hdone. + rewrite /local_eids elem_of_filter //. done. + - intros [? ?]. done. + Qed. + +End LThreadStep. diff --git a/theories/low/adequacy.v b/theories/low/adequacy.v new file mode 100644 index 0000000..ba14a72 --- /dev/null +++ b/theories/low/adequacy.v @@ -0,0 +1,630 @@ +From iris.proofmode Require Import tactics. +From iris.base_logic.lib Require Import wsat. +From self.low Require Export weakestpre. +From self.low Require Import lifting. +Import uPred. + +Section adequacy. + Context `{CMRA Σ}. + Context `{!invGS_gen HasNoLc Σ}. + Context `{!irisG}. + Context `{!Protocol}. + Implicit Types σ : LThreadState.t. + Implicit Types P Q : iProp Σ. + Implicit Types Φ : LThreadState.t → iProp Σ. + Implicit Types Φs : list (LThreadState.t → iProp Σ). + + Definition idx_to_tid (n : nat) : Tid := Pos.of_nat (S n). + Lemma idx_to_tid_eq (n : nat) : (idx_to_tid n) =@{nat} S n. + Proof. rewrite /idx_to_tid. lia. Qed. + + Import Graph. + + (* if all [wp]s terminiate with the [LTSDone] state *) + Notation tpwp gs σs Φs := ([∗ list] idx ↦ σ;Φ ∈ σs;Φs, + ∃ `(_ : !irisGL) lσ, + (local_interp gs (idx_to_tid idx) (LThreadState.get_progress σ) lσ) ∗ + WP σ @ (idx_to_tid idx) {{ σ', (Φ σ') }})%I. + + Notation tpsteps gs σs σs' := ("#Htpstep" ∷ [∗ list] idx ↦ σ;σ'∈σs;σs', + ∃ n, ⌜nsteps (LThreadStep.t gs (idx_to_tid idx)) (S n) σ σ'⌝)%I. + + Notation tpstate_done σs := ([∗ list] σ ∈ σs, ⌜Terminated σ⌝)%I. + + Notation tpstate_init gr σs := ([∗ list] idx ↦ σ ∈ σs, + ∃ pg, ⌜LThreadState.at_progress σ pg⌝ ∗ + ⌜ThreadState.progress_is_init gr (idx_to_tid idx) pg⌝)%I. + + Notation tppost_lifting σs Φs := ([∗ list] idx ↦ σ;Φ∈σs;Φs, post_lifting Φ (idx_to_tid idx) σ)%I. + + Notation tpnode_annot_full gr σs na na_full := + (⌜dom na ∪ + foldl (λ s idx, filter (Graph.is_local_node_of (idx_to_tid idx)) (Candidate.valid_eid gr) ∪ s) + ∅ (seq 0 (length σs)) = dom na_full⌝)%I. + + + (** Phase one *) + Lemma adequacy_po_aux gs σs σs' node_annot edge_annot Φs: + AAConsistent.t gs.(GlobalState.gs_graph) -> + AACandExec.NMSWF.wf gs.(GlobalState.gs_graph) -> + "#Htpstep" ∷ tpsteps gs σs σs' -∗ + "#Htpinit" ∷ tpstate_init gs.(GlobalState.gs_graph) σs -∗ + "#Htpdone" ∷ tpstate_done σs' -∗ + "#Hgs" ∷ □ gconst_interp gs -∗ + "Hannot_interp" ∷ annot_interp node_annot -∗ + (* none of the nodes has been checked *) + "#Hna_dom" ∷ ([∗ list] idx ↦ _ ∈ σs, ⌜filter (Graph.is_local_node_of (idx_to_tid idx)) (dom node_annot) = ∅⌝) -∗ + "#Hea_wf" ∷ ea_lob_wf (gs.(GlobalState.gs_graph)) edge_annot node_annot -∗ + "Htpwp" ∷ tpwp gs σs Φs ==∗ + ∃ (node_annot' : mea Σ) (edge_annot' : sra Σ), + annot_interp node_annot' ∗ + tpnode_annot_full (gs.(GlobalState.gs_graph)) σs node_annot node_annot' ∗ + ea_lob_wf (gs.(GlobalState.gs_graph)) edge_annot' node_annot' ∗ + tppost_lifting σs' Φs. + Proof. + intros Hgr_cs Hgr_wf. + revert σs σs' Φs node_annot edge_annot. + induction σs as [|σs_pre σs Hσs_pre] using prefix_strict_ind; + intros σs' Φs node_annot edge_annot;simpl; repeat iNamed 1; iNamed "Htpstep". + { (* empty case *) + iDestruct (big_sepL2_nil_inv_l with "Htpstep") as %->. + iDestruct (big_sepL2_nil_inv_l with "Htpwp") as %->. + iModIntro. iExists node_annot, edge_annot. iFrame. + iSplit. rewrite union_empty_r_L //. iSplit;[iPureIntro|];done. + } + (* induction case *) + destruct Hσs_pre as [σ ->]. + + iDestruct (big_sepL2_snoc_inv_l with "Htpstep") as (σ' σs_pre') "([-> [% %Hstep]] & Htpstep')". + iDestruct (big_sepL2_length with "Htpstep'") as "%Hlen_eq". + iDestruct (big_sepL_snoc with "Htpinit") as "(Htpinit' & [%pg [%Hpg %Hinit]])". + iDestruct (big_sepL_snoc with "Htpdone") as "(Htpdone' & %Hterm)". + iDestruct (big_sepL_snoc with "Hna_dom") as "(Hna_dom' & %Hna_ept)". + iClear "Htpstep". + iDestruct (big_sepL2_snoc_inv_l with "Htpwp") as (Φ Φs') "([-> (%&%&Hlocal_interp &Hwp)] & Htpwp)". + rewrite Hpg /=. + iDestruct (wp_steps with "Hlocal_interp Hgs Hwp") as "H";eauto. + { + iMod ("H" $! node_annot edge_annot with "[$Hannot_interp Hea_fe]") as "(%node_annot'&%edge_annot'&%lσ'&Hannot_interp&Hea_wf&Hlocal_interp'&%Hna_dom&Hpost)". + iSplitR. iPureIntro. rewrite Hna_ept. symmetry. by apply LThreadStep.eids_from_init_empty. + iSplit; [|iSplit]; done. + specialize (IHσs1 σs_pre' Φs'). + iDestruct(IHσs1 with "Htpstep' Htpinit' Htpdone' Hgs Hannot_interp [] Hea_wf Htpwp") + as ">(%node_annot_full&%edge_annot_full&Hannot_interp&Hna_full&Hea_wf&Hposts)". + { + iDestruct "Hna_dom'" as %Hna_dom'. iPureIntro. + intros k ? Hlk;simpl. + rewrite -Hna_dom. rewrite filter_union_L. + erewrite Hna_dom';eauto. rewrite union_empty_r_L. + apply set_eq. split;last done. rewrite elem_of_filter. + intros [Htid_eq Hin]. + exfalso. apply LThreadStep.eids_between_inv_tid_eq in Hin. + rewrite Hin in Htid_eq. apply lookup_lt_Some in Hlk. + rewrite /idx_to_tid in Htid_eq. lia. + } + iModIntro. iExists node_annot_full,edge_annot_full. + iFrame "Hea_wf". + rewrite big_sepL2_snoc. rewrite Hlen_eq. iFrame. + rewrite -Hna_dom. iDestruct "Hna_full" as %Hna_full. + iPureIntro. rewrite app_length /=. rewrite seq_app /=. + rewrite foldl_snoc. + rewrite (LThreadStep.eids_between_full gs (idx_to_tid (length σs_pre)) σ σ') //. + rewrite -Hna_full. rewrite -Hlen_eq. set_solver +. + subst pg;done. eexists. eauto. + } + Qed. + + Lemma adequacy_po gs σs σs' Φs: + AAConsistent.t gs.(GlobalState.gs_graph) -> + AACandExec.NMSWF.wf gs.(GlobalState.gs_graph) -> + "#Htpstep" ∷ tpsteps gs σs σs' -∗ + "#Htpinit" ∷ tpstate_init gs.(GlobalState.gs_graph) σs -∗ + "#Htpdone" ∷ tpstate_done σs' -∗ + "#Hgs" ∷ □ gconst_interp gs -∗ + "Hannot_interp" ∷ annot_interp ∅ -∗ + (* ensure that we checked events of all threads *) + "%Hnum_thd" ∷ ⌜S (length σs) = Candidate.num_of_thd gs.(GlobalState.gs_graph)⌝ -∗ + "Htpwp" ∷ tpwp gs σs Φs ==∗ + ∃ (node_annot' : mea Σ) (edge_annot' : sra Σ), + "Hannot_interp" ∷ annot_interp node_annot' ∗ + "%Hannot_full" ∷ na_full gs.(GlobalState.gs_graph) node_annot' ∗ + "Hea" ∷ ea_lob_wf (gs.(GlobalState.gs_graph)) edge_annot' node_annot' ∗ + "Hlifting" ∷ tppost_lifting σs' Φs. + Proof. + iIntros (??). repeat iNamed 1. + iDestruct (adequacy_po_aux _ _ _ _ ∅ ∅ + with "Htpstep Htpinit Htpdone Hgs Hannot_interp [] [] Htpwp") + as ">(%node_annot & %edge_annot & Hannot_interp & %Hna_dom & Hea_wf & Hpost)";auto. + iModIntro. iExists node_annot, edge_annot. + iFrame. iPureIntro. rewrite -Hna_dom. rewrite dom_empty_L union_empty_l_L. + erewrite <-Candidate.non_initial_eids_fold;eauto. clear Hna_dom. + induction (seq 0 (length σs)) as [|? ? Hpre] using prefix_strict_ind;first done. + destruct Hpre. subst. rewrite 2!foldl_snoc. rewrite -idx_to_tid_eq. rewrite IHl1 //. + Qed. + + (** Some notations for phase two *) + (* used as the conclusion of FSL style adequacy *) + Notation tppost_hold node_annot σs Φs := + ("R" ∷ ([∗ map] _ ↦ R ∈ node_annot, R) -∗ |==> ▷ |==> [∗ list] s;Φ ∈ σs;Φs, Φ s)%I. + + (* used as the conclusion in the Iris version *) + Notation tppost σs Φs := ([∗ list] idx ↦ σ;Φ∈σs;Φs, Φ σ)%I. + + (** Phase two (FSL and Iris flavours) *) + + (* RSL/FSL flavour *) + Lemma ea_obs_saturation gr node_annot edge_annot σs Φs: + NMSWF.wf gr -> + AAConsistent.t gr -> + (* Conclusion of phase-1 *) + "%Hna_full" ∷ na_full gr node_annot -∗ + "Hea" ∷ ea_lob_wf gr edge_annot node_annot -∗ + (* Initial resources, used to establish FE for initial nodes *) + "#R_init" ∷ ([∗ set] e ∈ Candidate.initials gr, □ prot_node e) -∗ + "Hpost_hold" ∷ tppost_hold node_annot σs Φs -∗ + ∃ node_annot' edge_annot', + "Hna_complete" ∷ ⌜dom node_annot' = Candidate.valid_eid gr⌝ ∗ + "Hea" ∷ ea_ob_wf gr edge_annot' node_annot' ∗ + "Hpost_hold" ∷ tppost_hold node_annot' σs Φs. + Proof. + iIntros (Hwf Hcs). repeat iNamed 1. + iDestruct (ea_init_extend with "[//] Hea R_init") as "Hea";auto. + iNamed "Hea". + iDestruct (ea_lob_wf_impl_ind with "Hea") as "[Hea %Hdom_eq]". + iDestruct (ea_obs_saturation_aux2 with "Hea") as "Hea";auto. + rewrite Hdom_eq //. + iDestruct (ea_ob_wf_ind_equiv gr _ _) as "[Heq _]". + iDestruct ("Heq" with "[Hea]") as "Hea". + iSplit. 2:iExact "Hea". rewrite -Hdom_eq. rewrite map_imap_dom_Some //. + (* show the goal *) + iExists _, _. iSplit;[|iSplitL "Hea";[iExact "Hea"|]]. done. + iNamed 1. iApply "Hpost_hold". rewrite big_sepM_union. + iDestruct "R" as "[_ $]". apply map_disjoint_dom. + rewrite Hna_full. rewrite dom_gset_to_gmap. pose proof (Candidate.valid_eid_disjoint_union gr) as [_ ?];done. + Qed. + + Lemma tppost_lifting_hold_aux node_annot σs Φs: + "Hannot" ∷ annot_interp node_annot -∗ + "Hlifting" ∷ tppost_lifting σs Φs -∗ + ("R" ∷ ([∗ list] i ∈ (seq 0 (length σs)), + [∗ map] _ ↦ R ∈ filter (λ '(e, _) , e.(EID.tid) = S i) node_annot, R) + -∗ |==> ▷ |==> [∗ list] s;Φ ∈ σs;Φs, Φ s)%I. + Proof. + revert Φs node_annot. + induction σs as [|σs_pre σs Hσs_pre] using prefix_strict_ind; intros Φs node_annot; repeat iNamed 1. + { (* empty case *) + rewrite big_sepL2_nil_inv_l. + iDestruct "Hlifting" as %->. + rewrite big_sepL2_nil //. + } + (* induction case *) + destruct Hσs_pre as [σ ->]. + iDestruct (big_sepL2_snoc_inv_l with "Hlifting") as (Φ Φs_pre) "([-> Hpl] & Hlifting)". + iDestruct ("Hpl" with "Hannot") as ">[Hannot Hpl]". + rewrite big_sepL2_snoc. rewrite app_length. simpl. + assert ((length σs_pre + 1) = S (length σs_pre))%nat as -> by lia. + rewrite seq_S /=. rewrite big_sepL_snoc. + iDestruct "R" as "[R Rσ]". + iDestruct ("Hpl" with "[Rσ]") as "?". + rewrite big_sepM_filter. + iApply (big_sepM_impl with "Rσ"). + iModIntro. iIntros (???) "R". + case_bool_decide as Htid;last done. iApply "R". rewrite Htid idx_to_tid_eq //. + iDestruct (IHσs1 Φs_pre with "Hannot Hlifting R") as ">IH". + iModIntro. iNext. iMod "IH" as "$". done. + Qed. + + Lemma tppost_lifting_hold gr node_annot σs Φs: + dom node_annot = Candidate.non_initial_eids gr -> + "%Hnum_thd" ∷ ⌜S (length σs) = Candidate.num_of_thd gr⌝ -∗ + "Hannot" ∷ annot_interp node_annot -∗ + "Hlifting" ∷ tppost_lifting σs Φs -∗ + tppost_hold node_annot σs Φs. + Proof. + iIntros (Hdom_eq). repeat iNamed 1. + iApply (tppost_lifting_hold_aux with "Hannot Hlifting [R]"). + iApply big_sepL_proper. + iIntros. iApply big_sepM_filter. + simpl. rewrite big_sepL_sepM. + iApply (big_sepM_impl with "R"). + iModIntro. iIntros (?? Hlk) "R". + rewrite (big_sepL_delete _ _ (EID.tid k - 1)). + iSplitL "R". iIntros. done. + 2: { + rewrite lookup_seq. split. simpl. reflexivity. + apply elem_of_dom_2 in Hlk. rewrite Hdom_eq in Hlk. + apply Candidate.non_initial_tid_inv in Hlk. lia. + } + iApply (big_sepL_impl). iApply big_sepL_emp. done. + iModIntro. iIntros (?? Hlk') "_". + case_decide as Htid;first done. apply lookup_seq in Hlk'. + destruct Hlk' as [-> Hlt]. iIntros (Heq). exfalso. apply Htid. lia. + Qed. + + (* Iris flavour *) + Lemma step_fupdN_mono n P Q E1 E2: + (P -∗ Q) ⊢ (|={E1}[E2]▷=>^ n P) -∗ |={E1}[E2]▷=>^ n Q. + Proof. + iIntros "Himp P". + iInduction n as [|] "IH" . by iApply "Himp". + rewrite 2!Nat.iter_succ. iApply (step_fupd_mono with "[Himp] P"). by iApply "IH". + Qed. + + Lemma adequacy_ob_aux gr node_annot edge_annot: + NMSWF.wf gr -> + AAConsistent.t gr -> + dom edge_annot = Candidate.valid_eid gr -> + dom edge_annot = dom node_annot -> + forall edge_annot_last, + ob_semi_last_set gr (dom edge_annot_last) (dom edge_annot) -> + edge_annot_last ⊆ edge_annot -> + ea_ob_wf_ind gr edge_annot_last node_annot -∗ + (* We have resources of ob_first nodes in [edge_annot] *) + ([∗ set] e_first ∈ (dom edge_annot) ∖ (dom edge_annot_last), + let s_ob := (Graph.ob_succ_of gr e_first) in + ([∗ set] e_out ∈ s_ob, + from_option (λ gm, from_option id emp (gm !! e_first)) emp (edge_annot_last !! e_out))) -∗ + |={⊤}[∅]▷=>^ (size (dom edge_annot_last)) + ([∗ set] e_first ∈ (dom edge_annot_last), + "R_na" ∷ from_option id emp (node_annot !! e_first)). + Proof. + intros Hwf Hcs Hea_full Hea_dom_eq. + match goal with + | [ |- forall x, ?G ] => + set (P := (λ (X : gset Eid), forall (x: sra Σ), dom x = X -> G)) + end. + intros eal Heal_last Heal_sub. + eapply (ob_set_ind_L gr (dom edge_annot) P Hcs). + { + rewrite Hea_full //. + } + { + clear eal Heal_last Heal_sub. + rewrite /P. intros eal Heal_dom Heal_last Heal_sub. + iIntros "Hea R_init". iNamed "Hea". rewrite Heal_dom size_empty /=. + apply dom_empty_inv_L in Heal_dom; subst eal. rewrite big_sepS_empty //. + } + { + clear eal Heal_last Heal_sub. + intros ef sl Hef_nv Hef_elem Hsl_last Hef_first IHsl. rewrite /P in IHsl. + rewrite /P /=. + intros eal Heal_dom Heal_last Heal_sub. iIntros "Hea R_init". iNamed "Hea". + + (* split FEs into current FE and the rest *) + assert (is_Some (eal !! ef)) as [gmf Heal_lk]. + { apply elem_of_dom. rewrite Heal_dom. set_solver +. } + rewrite -{2}(insert_id _ ef gmf Heal_lk). + rewrite big_sepM_insert_delete. iDestruct "Hea_fe" as "[FE Hea_fe]". + assert (is_Some (node_annot !! ef)) as [R Hna_lk]. + { apply elem_of_dom. rewrite -Hea_dom_eq. set_solver + Hef_elem. } + rewrite Hna_lk /=. + + (* split resources of ob first nodes into the part satisfy premises of FE, and the rest *) + (* first show that ob-first nodes of [ef] are in all ob-first node *) + assert ((dom edge_annot ∖ dom eal) = + (ob_pred_of gr ef) ∪ ((dom edge_annot ∖ dom eal) ∖ (ob_pred_of gr ef))) as Hsplit. + { + apply union_difference_L. + apply subseteq_difference_r. + intros ep Hpred Hnpred. + rewrite -Heal_dom in Hef_first. apply (Hef_first _ Hnpred). + by apply elem_of_ob_pred_of. + rewrite Hea_full. + apply ob_pred_of_valid. assumption. + } + rewrite Hsplit big_sepS_union. 2:set_solver +. iDestruct "R_init" as "[R_ob_pred R_rest_out]". + (* then preparation for applying FE *) + + (* get resources flowing in *) + iAssert ((([∗ set] y ∈ ob_pred_of gr ef, + "R_ob_out" ∷ ([∗ set] e_out ∈ ob_succ_of gr y ∖ {[ef]}, + from_option (λ gm : mea Σ, default emp (gm !! y)) emp (eal !! e_out))) ∗ + [∗ set] y ∈ ob_pred_of gr ef, from_option id emp (gmf !! y))%I + ) with "[R_ob_pred]" as "[R_ob_pred_out R_ob_in]". + { + iDestruct (big_sepS_impl _ (λ e, ([∗ set] e_out ∈ (ob_succ_of gr e ∖ {[ef]}), + from_option (λ gm : mea Σ, default emp (gm !! e)) emp (eal !! e_out)) + ∗ from_option (λ gm : mea Σ, default emp (gm !! e)) emp (eal !! ef))%I + with "R_ob_pred []") as "R_split". + { iModIntro. iIntros (??) "H". + rewrite {1}(union_difference_singleton_L ef (ob_succ_of gr x)). + 2: { by apply elem_of_ob_pred_of_succ. } + rewrite big_sepS_union. 2: set_solver +. iDestruct "H" as "[H $]". + rewrite big_sepS_singleton //. + } + iDestruct (big_sepS_sep with "R_split") as "[$ R_right]". + iApply (big_sepS_impl with "R_right"). + iModIntro. iIntros (??) "?". rewrite Heal_lk //. + } + (* move ulu *) + rewrite {2}Heal_dom. rewrite size_union. 2: set_solver + Hef_nv. rewrite size_singleton Nat.iter_succ. + + (* apply FE *) + iDestruct ("FE" with "[R_ob_in]") as "R_ef". + { + specialize (Hea_ob_wf ef gmf Heal_lk). + iApply big_sepS_to_map. exact Hea_ob_wf. done. + } + iApply (step_fupd_mono with "[-R_ef] R_ef"). iNamed 1. + (* apply IH *) + assert (dom (delete ef eal) = sl) as Hsl_dom. + { rewrite dom_delete_L Heal_dom. set_solver + Hef_nv. } + + specialize (IHsl (delete ef eal)). feed specialize IHsl. + exact Hsl_dom. + rewrite Hsl_dom. destruct Hsl_last;done. + etransitivity;last exact Heal_sub. apply delete_subseteq. + iDestruct (IHsl with "[Hea_fe] [R_ob_pred_out R_rest_out R_out]") as "IH". + { + iSplit. + { iPureIntro. by apply map_Forall_delete. } + iApply (big_sepM_impl with "Hea_fe"). + iModIntro. iIntros (e_sl gm_sl Heal_lk_sl) "FE_sl". + destruct (decide (is_Some(node_annot !! e_sl))) as [[R_sl Hna_lk_sl]|Hn]. + 2:{ + assert (node_annot !! e_sl = None) as ->;auto. + apply not_elem_of_dom. intro. apply Hn. by apply elem_of_dom. + } + rewrite Hna_lk_sl. iIntros "R_in". iDestruct ("FE_sl" with "R_in") as "R_out". + iApply (step_fupd_mono with "[] R_out"). + iNamed 1. iFrame. + iApply (big_sepS_impl with "R_out"). + iModIntro. iIntros (e_succ Hsucc) "R". + rewrite lookup_delete_ne //. + { + (* e_succ ≠ ef *) + destruct (decide (e_succ ∈ sl)) as [Hx_in | Hx_nin]. set_solver + Hx_in Hsl_dom. + assert (e_succ ∈ dom edge_annot) as Hx_in_all. + { rewrite Hea_full. pose proof (elem_of_ob_succ_of_valid _ _ _ Hwf Hsucc) as Hsub. set_solver + Hsub. } + destruct Hsl_last as [_ Hsl_last]. + specialize (Hsl_last e_sl). feed specialize Hsl_last. + rewrite lookup_delete_Some in Heal_lk_sl. destruct Heal_lk_sl as [Hneq Hlk]. + apply elem_of_dom_2 in Hlk. + set_solver + Hlk Hneq Hsl_dom. + simpl in Hsl_last. exfalso. eapply (Hsl_last e_succ). set_solver + Hx_nin Hx_in_all. + apply elem_of_ob_pred_of. + rewrite elem_of_ob_pred_of_succ //. + } + } + { + (* split the goal *) + rewrite dom_delete_L. rewrite difference_difference_r_L. + assert (dom edge_annot ∩ {[ef]} = {[ef]}) as -> by set_solver + Hef_elem. + rewrite big_sepS_union. 2: set_solver + Heal_dom. + rewrite big_sepS_singleton. + iSplitR "R_out". + { + rewrite {2}Hsplit. rewrite big_sepS_union. 2: set_solver +. + iSplitL "R_ob_pred_out". + { + iApply (big_sepS_impl with "R_ob_pred_out"). iModIntro. iIntros (? Hpred) "R". + rewrite {2}(union_difference_singleton_L ef (ob_succ_of gr x)). + 2:{ rewrite -elem_of_ob_pred_of_succ //. } + rewrite big_sepS_union. 2:set_solver +. + rewrite big_sepS_singleton. + rewrite lookup_delete. iSplitR;first done. + iApply (big_sepS_impl with "R"). iModIntro. iIntros (? Hsucc) "R". + rewrite lookup_delete_ne //. set_solver + Hsucc. + } + { + iApply (big_sepS_impl with "R_rest_out"). iModIntro. iIntros (? Hin) "R". + iApply (big_sepS_impl with "R"). iModIntro. iIntros (? Hsucc) "R". + rewrite lookup_delete_ne //. + intros <-. rewrite -elem_of_ob_pred_of_succ in Hsucc. + set_solver + Hin Hsucc. + } + } + { + iApply (big_sepS_impl with "R_out"). iModIntro. iIntros (? Hsucc) "R". + rewrite lookup_delete_ne //. by apply elem_of_ob_succ_of_ne in Hsucc. + } + } + rewrite Hsl_dom. iApply (step_fupdN_mono with "[-IH] IH"). iIntros "R_sl". + rewrite Heal_dom big_sepS_union. 2: set_solver + Hef_nv. rewrite big_sepS_singleton. + rewrite Hna_lk. iFrame. + } + 2:{ exact Heal_last. } + { by apply subseteq_dom. } + { reflexivity. } + { done. } + { done. } + Qed. + + + Lemma adequacy_ob gr node_annot edge_annot: + NMSWF.wf gr -> + AAConsistent.t gr -> + dom edge_annot = Candidate.valid_eid gr -> + ea_ob_wf gr edge_annot node_annot -∗ + |={⊤}[∅]▷=>^ (size (Candidate.valid_eid gr)) + ([∗ set] e_first ∈ (dom edge_annot), + "R_na" ∷ from_option id emp (node_annot !! e_first)). + Proof. + iIntros (Hwf Hcs Hdom) "Hea_fe". + iDestruct (ea_ob_wf_ind_equiv with "Hea_fe") as "[% Hea_fe]". + assert (size (Candidate.valid_eid gr) = size (dom edge_annot)) as ->. rewrite Hdom //. + iApply (adequacy_ob_aux with "Hea_fe []");eauto. + rewrite /ob_semi_last_set difference_diag_L. intros ??. apply set_Forall_empty. + rewrite difference_diag_L. rewrite big_sepS_empty //. + Qed. + + (** Full adequacy*) + + (* RSL/FSL version *) + Lemma adequacy_post_hold gs σs σs' Φs: + AAConsistent.t gs.(GlobalState.gs_graph) -> + AACandExec.NMSWF.wf gs.(GlobalState.gs_graph) -> + "#Htpstep" ∷ tpsteps gs σs σs' -∗ + "Htpinit" ∷ tpstate_init gs.(GlobalState.gs_graph) σs -∗ + "Htpdone" ∷ tpstate_done σs' -∗ + "Hgs" ∷ □ gconst_interp gs -∗ + (* Initial resources, used to establish FE for initial nodes *) + "#R_init" ∷ ([∗ set] e ∈ Candidate.initials gs.(GlobalState.gs_graph), □ prot_node e) -∗ + "Hannot_interp" ∷ annot_interp ∅ -∗ + "#Hnum_thd" ∷ ⌜S (length σs) = Candidate.num_of_thd gs.(GlobalState.gs_graph)⌝ -∗ + "Htpwp" ∷ tpwp gs σs Φs ==∗ + ∃ (node_annot : mea Σ) (edge_annot : sra Σ), + ea_ob_wf (gs.(GlobalState.gs_graph)) edge_annot node_annot ∗ + ⌜dom node_annot = Candidate.valid_eid gs.(GlobalState.gs_graph)⌝ ∗ + tppost_hold node_annot σs' Φs. + Proof. + iIntros (??). repeat iNamed 1. + iDestruct (adequacy_po with "Htpstep Htpinit Htpdone Hgs Hannot_interp Hnum_thd Htpwp") + as ">(% &%&H1)";auto. + iNamed "H1". + rewrite big_sepL2_alt. iDestruct "Htpstep" as "[-> _]". + iDestruct (tppost_lifting_hold with "Hnum_thd Hannot_interp Hlifting") as "Hpost_hold";auto. + iDestruct (ea_obs_saturation with "[//] Hea R_init Hpost_hold") as "(% &%& [Heq H2])";auto. + iNamed "H2". + iModIntro. iExists _, _. iFrame "Hea". iFrame. + Qed. + + Lemma bupd_step_fupdN_bupd n P: + (|==> |={⊤}[∅]▷=>^n |==> P) ⊢ |={⊤}[∅]▷=>^n |==> P. + Proof. + iIntros "H". + destruct n. simpl. iMod "H" as "$". + simpl. + iApply (fupd_elim _ ⊤). done. + iApply bupd_fupd. done. + Qed. + + (* Iris version (depends on FSL vesion) *) + Lemma adequacy_post gs σs σs' Φs: + AAConsistent.t gs.(GlobalState.gs_graph) -> + AACandExec.NMSWF.wf gs.(GlobalState.gs_graph) -> + S (length σs) = Candidate.num_of_thd gs.(GlobalState.gs_graph) -> + (length σs = length σs' ∧ + ∀ idx σ σ', σs !! idx = Some σ → σs' !! idx = Some σ' → (∃ n, nsteps (LThreadStep.t gs (idx_to_tid idx)) (S n) σ σ')) -> + (∀ idx σ, σs !! idx = Some σ → (∃ pg, LThreadState.at_progress σ pg ∧ + ThreadState.progress_is_init gs.(GlobalState.gs_graph) (idx_to_tid idx) pg)) -> + (∀ (k:nat) σ, σs' !! k = Some σ → Terminated σ) -> + (* WPs + initial interpretations *) + ⊢ ((|==> "#R_init" ∷ ([∗ set] e ∈ Candidate.initials gs.(GlobalState.gs_graph), □ prot_node e) + ∗ "Hgs" ∷ □ gconst_interp gs + ∗ "Hannot_interp" ∷ annot_interp ∅ + ∗ "Htpwp" ∷ tpwp gs σs Φs) + -∗ |={⊤}[∅]▷=>^ (size (Candidate.valid_eid gs.(GlobalState.gs_graph))) |==> ▷ |==> tppost σs' Φs)%I. + Proof. + iIntros (?? Hnum_thd Htpstep Htpinit Htpdone). iIntros "H". + iApply bupd_step_fupdN_bupd. iMod "H". iNamed "H". + iMod (adequacy_post_hold gs σs σs' Φs with "[] [] [] Hgs R_init Hannot_interp [//] Htpwp") + as "(%&%&Hea&%Hdom&Hpost_hold)". + done. done. + iApply (big_sepL2_impl (λ idx σ σ', ⌜∃ n, nsteps (LThreadStep.t gs (idx_to_tid idx)) (S n) σ σ'⌝%I)). + rewrite big_sepL2_pure. done. iModIntro. iIntros (? ? ? ? ? [? ?]). iExists _. done. + iApply (big_sepL_impl (λ idx σ , ⌜∃ pg, LThreadState.at_progress σ pg ∧ + ThreadState.progress_is_init gs.(GlobalState.gs_graph) (idx_to_tid idx) pg⌝%I)). + rewrite big_sepL_pure. done. iModIntro. iIntros (? ? ? [? ?]). iExists _. done. + done. + iModIntro. iNamed "Hea". + iDestruct (adequacy_ob with "[Hea_fe]") as "Hna";eauto. + rewrite -Hea_dom_eq in Hdom. exact Hdom. + iSplit;first iPureIntro;eauto. + iApply (step_fupdN_mono with "[-Hna] Hna"). iIntros "Hna". + rewrite big_sepS_to_map. 2: set_solver + Hea_dom_eq. + iMod ("Hpost_hold" with "Hna"). done. + Qed. + + (* Iris version with pure post conditions *) + Lemma adequacy_post_pure gs σs σs' (Φps : list (_ -> Prop)) : + AAConsistent.t gs.(GlobalState.gs_graph) -> + AACandExec.NMSWF.wf gs.(GlobalState.gs_graph) -> + S (length σs) = Candidate.num_of_thd gs.(GlobalState.gs_graph) -> + (length σs = length σs' ∧ + ∀ idx σ σ', σs !! idx = Some σ → σs' !! idx = Some σ' → (∃ n, nsteps (LThreadStep.t gs (idx_to_tid idx)) (S n) σ σ')) -> + (∀ idx σ, σs !! idx = Some σ → (∃ pg, LThreadState.at_progress σ pg ∧ + ThreadState.progress_is_init gs.(GlobalState.gs_graph) (idx_to_tid idx) pg)) -> + (∀ (k:nat) σ, σs' !! k = Some σ → Terminated σ) -> + (* WPs + initial interpretations *) + ⊢ ((|==> "#R_init" ∷ ([∗ set] e ∈ Candidate.initials gs.(GlobalState.gs_graph), □ prot_node e) + ∗ "Hgs" ∷ □ gconst_interp gs + ∗ "Hannot_interp" ∷ annot_interp ∅ + ∗ "Htpwp" ∷ ([∗ list] idx ↦ σ;Φp ∈ σs;Φps, + ∃ `(_ : !irisGL) lσ, local_interp gs (idx_to_tid idx) (LThreadState.get_progress σ) lσ ∗ + WP σ @ (idx_to_tid idx) {{ σ', ⌜Φp σ'⌝ }})) + -∗ |={⊤}[∅]▷=>^ (size (Candidate.valid_eid gs.(GlobalState.gs_graph))) |==> ▷ |==> + ⌜length σs' = length Φps ∧ ∀ (idx: nat) σ' (Φ: _ -> Prop), σs' !! idx = Some σ' → Φps !! idx = Some Φ + → Φ σ'⌝). + Proof. + iIntros (?? Hnum_thd Htpstep Htpinit Htpdone). iIntros "H". + iApply bupd_step_fupdN_bupd. iMod "H". iNamed "H". + iAssert (tpwp gs σs ((λ Φp, (λ v, ⌜Φp v⌝)%I) <$> Φps))%I with "[Htpwp]" as "Htpwp". + { + iDestruct (big_sepL2_impl _ (λ idx σ Φp, ∃ `(_ : !irisGL) lσ, + local_interp gs (idx_to_tid idx) (LThreadState.get_progress σ) lσ ∗ + WP σ @ (idx_to_tid idx) {{ σ', ⌜Φp σ'⌝ }})%I with "Htpwp []") as "Htpwp". + { + iModIntro. iIntros (?????) "[%GL wps]". + iExists GL. iFrame. + } + rewrite big_sepL2_fmap_r. + iApply (big_sepL2_impl with "Htpwp"). + iModIntro. iIntros (?????) "[% [% H]]". + iExists _,_. done. + } + iMod (adequacy_post_hold gs σs σs' ((λ Φp, (λ v, ⌜Φp v⌝)%I) <$> Φps) with "[] [] [] Hgs R_init Hannot_interp [//] Htpwp") + as "(%&%&Hea&%Hdom&Hpost_hold)". + done. done. + iApply (big_sepL2_impl (λ idx σ σ', ⌜∃ n, nsteps (LThreadStep.t gs (idx_to_tid idx)) (S n) σ σ'⌝%I)). + rewrite big_sepL2_pure. done. iModIntro. iIntros (? ? ? ? ? [? ?]). iExists _. done. + iApply (big_sepL_impl (λ idx σ , ⌜∃ pg, LThreadState.at_progress σ pg ∧ + ThreadState.progress_is_init gs.(GlobalState.gs_graph) (idx_to_tid idx) pg⌝%I)). + rewrite big_sepL_pure. done. iModIntro. iIntros (? ? ? [? ?]). iExists _. done. + done. + + iModIntro. iNamed "Hea". + iDestruct (adequacy_ob with "[Hea_fe]") as "Hna";eauto. + rewrite -Hea_dom_eq in Hdom. exact Hdom. + iSplit;first iPureIntro;eauto. + iDestruct (step_fupdN_mono _ _ (|==> ▷ |==> ⌜ + length σs' = length Φps + ∧ (∀ (k : nat) (y1 : LThreadState.t) (y2 : LThreadState.t → Prop), σs' !! k = Some y1 → Φps !! k = Some y2 → y2 y1)⌝) with "[-Hna] Hna") as "H". iIntros "Hna". + rewrite big_sepS_to_map. + 2: set_solver + Hea_dom_eq. + iMod ("Hpost_hold" with "Hna") as "H". + rewrite big_sepL2_fmap_r. rewrite big_sepL2_pure. + iModIntro. iExact "H". done. + Qed. + +End adequacy. + +(* Final Coq level adequacy *) +Lemma adequacy_pure `{CMRA Σ} `{!invGpreS Σ} gs σs σs' (Φps : list (_ -> Prop)) : + AAConsistent.t gs.(GlobalState.gs_graph) -> + AACandExec.NMSWF.wf gs.(GlobalState.gs_graph) -> + S (length σs) = AACandExec.Candidate.num_of_thd gs.(GlobalState.gs_graph) -> + (length σs = length σs' ∧ + ∀ idx σ σ', σs !! idx = Some σ → σs' !! idx = Some σ' → (∃ n, nsteps (LThreadStep.t gs (idx_to_tid idx)) (S n) σ σ')) -> + (∀ idx σ, σs !! idx = Some σ → (∃ pg, LThreadState.at_progress σ pg ∧ + ThreadState.progress_is_init gs.(GlobalState.gs_graph) (idx_to_tid idx) pg)) -> + (∀ (k:nat) σ, σs' !! k = Some σ → Terminated σ) -> + (forall `{Hinv : !invGS_gen HasNoLc Σ}, + ⊢@{iProp Σ} |==> ∃ `{!irisG} `{!Protocol}, + ("#R_init" ∷ ([∗ set] e ∈ AACandExec.Candidate.initials gs.(GlobalState.gs_graph), □ prot_node e) + ∗ "Hgs" ∷ □ gconst_interp gs + ∗ "Hannot_interp" ∷ annot_interp ∅ + ∗ "Htpwp" ∷ ([∗ list] idx ↦ σ;Φp ∈ σs;Φps, ∃ `(_ : !irisGL) lσ, local_interp gs (idx_to_tid idx) (LThreadState.get_progress σ) lσ + ∗ WP σ @ (idx_to_tid idx) {{ σ', ⌜Φp σ'⌝ }}))) -> + length σs' = length Φps ∧ forall (idx: nat) σ' (Φ: _ -> Prop), σs' !! idx = Some σ' → Φps !! idx = Some Φ → Φ σ'. +Proof. + intros ?????? HH. + eapply pure_soundness. + eapply (step_fupdN_soundness_no_lc' _ + (size (AACandExec.Candidate.valid_eid gs.(GlobalState.gs_graph)) + 1) + (size (AACandExec.Candidate.valid_eid gs.(GlobalState.gs_graph)) + 1)). + intros. specialize (HH Hinv). + + iIntros "_". + rewrite comm. rewrite (step_fupdN_add 1) /=. iMod HH as "(%Hiris & %Hprot & H)". + + iDestruct (@adequacy_post_pure Σ H Hinv Hiris Hprot gs σs σs' Φps with "[H]") as "H";try done. + + assert (Hfold:∀ P, (|={⊤}[∅]▷=>^1 P) ⊢@{iProp Σ} |={⊤}[∅]▷=> P) by done. iApply Hfold. + rewrite -step_fupdN_add. rewrite Nat.add_comm /=. rewrite step_fupdN_add. + iApply (step_fupdN_mono with "[] H"). + + iIntros "H'". iMod "H'". + iApply fupd_mask_intro. set_solver +. + iIntros "Hclose". iNext. iMod "Hclose" as "_". by iMod "H'" as "$". +Qed. diff --git a/theories/low/instantiation.v b/theories/low/instantiation.v new file mode 100644 index 0000000..2e81547 --- /dev/null +++ b/theories/low/instantiation.v @@ -0,0 +1,1320 @@ +(** This file contains the instantiation of the low-level logic, + this is the file that all helper files import*) +From iris_named_props Require Export named_props. +From iris.bi Require Import derived_laws. + +From self.lang Require Import mm opsem. +From self.algebra Require Export base. +From self.low Require Export edge event weakestpre interp_mod. + +Class ThreadGNL := { + AALocalMapN : gname; + AAPoSrcN : gname; + }. + +#[global] Arguments AALocalMapN {_}. +#[global] Arguments AAPoSrcN {_}. + +Section interp. + Context `{CMRA Σ} `{!AABaseG}. + + (** Graph *) + Import AACandExec. + Definition global_interp (gs : GlobalState.t) := + ("Hgr_ag" ∷ graph_agree gs.(GlobalState.gs_graph) ∗ + "Hinstr_ag" ∷ instr_table_agree gs.(GlobalState.gs_gimem))%I. + + Definition annot_interp (m : gmap Eid (iProp Σ)) : iProp Σ := + ∃ (annot : gmap Eid gname), + ghost_map_ag_auth AANodeAnnotN annot ∗ + ⌜dom annot = dom m⌝ ∗ + ([∗ map] eid ↦ gn;P ∈ annot;m, + ∃ (res : gmap gname (iProp Σ)), + own gn (● (GSet (dom res))) ∗ + ([∗ map] gnp ↦ R ∈ res, saved_prop_own gnp (DfracOwn (1/2)) R)∗ + ▷ ■ (([∗ map] _ ↦ R ∈ res, R) ∗-∗ P)). + + Definition token_interp (s : gset Eid) : iProp Σ := + own AARmwTokenN (● (GSet s)). + + Definition my_annot_interp (m : gmap Eid (iProp Σ)) : iProp Σ := + "Hinterp_annot" ∷ annot_interp m ∗ + "Hinterp_token" ∷ token_interp (dom m). + + Record LogicalLocalState := mk_lls{ + lls_lws : gmap Addr (option Eid); + lls_pop : option Eid; + }. + + #[global] Instance eta : Settable _ := settable! mk_lls . + + Context `{!ThreadGNL}. + Definition last_write_interp (gs : GlobalState.t) (tid : Tid) (pg : ThreadState.progress) + (ls : gmap Addr (option Eid)) : iProp Σ := + let gr := gs.(GlobalState.gs_graph) in + let local_writes := + filter (λ '(e, _), + (Graph.is_local_node_of tid) e ∧ ThreadState.progress_of_node e

+ ThreadState.progress_of_node e' <=p ThreadState.progress_of_node e) + local_writes) local_writes in + ⌜ ∀ (a : Addr) (e : Eid), ls !! a = Some (Some e) <-> (∃ E, last_local_writes !! e = Some E ∧ + AAConsistent.event_is_write_with_addr E a )⌝ ∗ + ⌜ ∀ (a : Addr), ls !! a = Some None -> (map_Forall (λ e E, + (AAConsistent.event_is_write_with_addr E a = false)) local_writes)⌝ ∗ + ghost_map_auth AALocalMapN 1%Qp ls. + + Definition lpo_src_def o_eid := + from_option (λ eid, + ((∃ gr, graph_agree gr ∗ ⌜is_Some (gr !! eid)⌝) ∗ + ∃ gn, own AAPoSrcN (Cinr (to_agree (gn, (EID.tid eid)))) ∗ own gn (●MN{DfracOwn (1/2)%Qp} (ThreadState.progress_of_node eid)) + )%I) ((own AAPoSrcN (Cinl (to_dfrac_agree (DfracOwn (1/2)%Qp) ())))%I) o_eid. + + Definition po_src_def eid := + ((∃ gr, graph_agree gr ∗ ⌜is_Some (gr !! eid)⌝) ∗ ∃ gn, own AAPoSrcN (Cinr (to_agree (gn, (EID.tid eid)))) ∗ own gn (◯MN (ThreadState.progress_of_node eid)))%I. + + Definition po_pred_interp (gs : GlobalState.t) (tid : Tid) (pg : ThreadState.progress) + (ls : option Eid) : iProp Σ := + let gr := gs.(GlobalState.gs_graph) in + graph_agree gr ∗ + from_option (λ e', + ∃ gn, own AAPoSrcN (Cinr (to_agree (gn, (EID.tid e')) )) ∗ + own gn (●MN{DfracOwn (1/2)%Qp} (ThreadState.progress_of_node e')) ∗ ⌜ EID.tid e' = tid ∧ ThreadState.progress_of_node e'

'" := (lpo_src e) (at level 20) : bi_scope. + +Definition po_src_aux : seal (@po_src_def). Proof. by eexists. Qed. +Definition po_src := po_src_aux.(unseal). +Arguments po_src {Σ _ _ _}. +Definition po_src_eq : @po_src = @po_src_def := po_src_aux.(seal_eq). +Notation "e '-{Po}>'" := (po_src e) (at level 20) : bi_scope. + +Definition last_local_write `{CMRA Σ} `{!AABaseG} `{!ThreadGNL} (tid : Tid) (addr : Addr) (w : option Eid) : iProp Σ := + addr ↪[AALocalMapN]{DfracOwn 1} w. + +Lemma annot_interp_alloc `{CMRA Σ} `{!AABaseInG}: + ⊢ |==> ∃ GN, (∃ (annot : gmap Eid gname), + ghost_map_ag_auth GN annot ∗ + ⌜dom annot = dom (∅ : gmap Eid (iProp Σ))⌝ ∗ + ([∗ map] eid ↦ gn;P ∈ annot;(∅ : gmap Eid (iProp _)), + ∃ (res : gmap gname (iProp Σ)), + own gn (● (GSet (dom res))) ∗ + ([∗ map] gnp ↦ R ∈ res, saved_prop_own gnp (DfracOwn (1/2)) R)∗ + ▷ ■ (([∗ map] _ ↦ R ∈ res, R) ∗-∗ P))). +Proof. + iDestruct (ghost_map_ag_alloc_empty) as ">[% ?]". + iModIntro. iExists _. iExists ∅. iFrame. + iSplit;first done. + done. +Qed. + +Lemma token_interp_alloc `{CMRA Σ} `{!AABaseInG}: + ⊢ |==> ∃ GN, (own GN (● (GSet (∅ : gset Eid)))). +Proof. + iDestruct (own_alloc (● (GSet (∅ : gset Eid)))) as ">[% ?]". + apply auth_auth_valid. done. + iModIntro. iExists _. iFrame. +Qed. + +Lemma graph_agree_alloc `{CMRA Σ} `{!AABaseInG} gr: + ⊢ |==> ∃ GN, own GN ((to_agree gr) : (agreeR (leibnizO Graph.t))). +Proof. + iDestruct (own_alloc (to_agree gr)) as ">[% ?]". done. + iModIntro. iExists _. iFrame. +Qed. + +Lemma instr_table_agree_alloc `{CMRA Σ} `{!AABaseInG} gi: + ⊢ |==> ∃ GN, own GN (to_agree (gi: gmapO Addr (leibnizO Instruction))). +Proof. + iDestruct (own_alloc (to_agree gi)) as ">[% ?]". done. + iModIntro. iExists _. iFrame. +Qed. + +Lemma interp_alloc `{CMRA Σ} `{!AABaseInG} gs: + ⊢ |==> ∃ `{!AABaseG}, my_annot_interp ∅ ∗ global_interp gs ∗ graph_agree (gs.(GlobalState.gs_graph)) ∗ instr_table_agree (gs.(GlobalState.gs_gimem)). +Proof. + iStartProof. + rewrite /my_annot_interp. + iDestruct (annot_interp_alloc) as ">[%g1 H1]". + iDestruct (token_interp_alloc) as ">[%g2 H2]". + iDestruct (graph_agree_alloc (GlobalState.gs_graph gs)) as ">[%g3 #H3]". + iDestruct (instr_table_agree_alloc (GlobalState.gs_gimem gs)) as ">[%g4 #H4]". + iModIntro. + iExists (GenAABaseG Σ _ _ g3 g1 g4 g2). + iFrame. rewrite /global_interp. + rewrite graph_agree_eq;iFrame. + rewrite instr_table_agree_eq;iFrame. + iFrame "#". +Qed. + +Lemma my_local_interp_alloc `{CMRA Σ} `{!AABaseG} gs pg (i:Tid) locs: + ThreadState.progress_is_init (GlobalState.gs_graph gs) i pg -> + graph_agree (gs.(GlobalState.gs_graph)) ⊢ |==> ∃ `{!ThreadGNL}, + my_local_interp gs i pg (mk_lls (gset_to_gmap None locs) None) ∗ + ([∗ set] k ∈ locs, k ↪[AALocalMapN] None) ∗ + None -{LPo}>. +Proof. + iIntros (Hinit). rewrite /my_local_interp. iIntros "?". + iDestruct (ghost_map_alloc (gset_to_gmap None locs)) as ">[%g1 [? ?]]". + rewrite /po_pred_interp /=. rewrite lpo_src_eq. + iDestruct (own_alloc ((Cinl (to_dfrac_agree (DfracOwn (1/2)%Qp) ())) ⋅ (Cinl (to_dfrac_agree (DfracOwn (1/2)%Qp) ())) )) as ">[%g2 H]". done. + iExists (Build_ThreadGNL g1 g2). + rewrite own_op. iDestruct "H" as "[$ $]". iFrame. + iModIntro. rewrite big_sepM_gset_to_gmap. iFrame. + iPureIntro. split. + { + intros. split. + intros Hlk. rewrite lookup_gset_to_gmap_Some /= in Hlk. destruct Hlk;done. + intros [? [Hlk ?]]. exfalso. rewrite map_filter_lookup_Some in Hlk. + destruct Hlk as [Hlk ?]. + rewrite map_filter_lookup_Some in Hlk. + destruct Hlk as (?&?&?&?). + rewrite /ThreadState.progress_is_init in Hinit. + specialize (Hinit e). feed specialize Hinit. + apply elem_of_filter. split;auto. + set_unfold. eexists;eauto. split;eauto. + rewrite -AACandExec.Candidate.event_map_match //. + simpl in Hinit. eapply ThreadState.progress_le_gt_False;eauto. + } + { + intro. rewrite lookup_gset_to_gmap_Some. + intros _. intros e E Hfilter. + rewrite map_filter_lookup_Some in Hfilter. + rewrite /ThreadState.progress_is_init in Hinit. + destruct Hfilter as [? [? [? ?]]]. + specialize (Hinit e). feed specialize Hinit. + apply elem_of_filter. split;auto. + set_unfold. eexists;eauto. split;eauto. + rewrite -AACandExec.Candidate.event_map_match //. + simpl in Hinit. exfalso. eapply ThreadState.progress_le_gt_False;eauto. + } +Qed. + +Section lemma. + Context `{CMRA Σ}. + Context `{!AABaseG}. + + + #[global] Instance instr_persis a i: Persistent (a ↦ᵢ i). + Proof. + rewrite instr_eq /instr_def. apply _. + Qed. + + #[global] Instance instr_persis' a: Persistent (a ↦ᵢ -). + Proof. + rewrite instr_eq /instr_def. apply _. + Qed. + + Lemma instr_agree_Some gs a i: + global_interp gs -∗ + a ↦ᵢ i -∗ + ⌜gs.(GlobalState.gs_gimem) !! a = Some i⌝. + Proof. + iIntros "[_ Hinstr] Hi". rewrite instr_eq /instr_def. + iDestruct "Hi" as "[% [Hag %Hlk]]". + iDestruct (instr_table_agree_agree with "Hinstr Hag") as %->. + done. + Qed. + + Lemma instr_agree_None gs a: + global_interp gs -∗ + a ↦ᵢ - -∗ + ⌜gs.(GlobalState.gs_gimem) !! a = None⌝. + Proof. + iIntros "[_ Hinstr] Hi". rewrite instr_eq /instr_def. + iDestruct "Hi" as "[% [Hag %Hlk]]". + iDestruct (instr_table_agree_agree with "Hinstr Hag") as %->. + done. + Qed. + + Lemma graph_edge_agree gs e1 e2 E: + global_interp gs -∗ + e1 -{ E }> e2 -∗ + ⌜Edge.ef_edge_interp gs.(GlobalState.gs_graph) E e1 e2 ⌝. + Proof. + iIntros "[Hgr _] He". rewrite edge_eq /edge_def. + iNamed "He". iDestruct (graph_agree_agree with "Hgr Hgr_interp_e") as %->. + done. + Qed. + + Lemma graph_event_agree gs e E: + global_interp gs -∗ + e -{E}> E -∗ + ⌜ Event.event_interp gs.(GlobalState.gs_graph) E e⌝. + Proof. + iIntros "[Hgr _] He". rewrite event_eq /event_def. + iNamed "He". iDestruct (graph_agree_agree with "Hgr Hgr_interp_e") as %->. + done. + Qed. + + Lemma graph_edge_agree_big_pred gs s e E: + global_interp gs -∗ + ([∗ set] e1 ∈ s, e1 -{ E }> e) -∗ + [∗ set] e1 ∈ s, ⌜Edge.ef_edge_interp gs.(GlobalState.gs_graph) E e1 e⌝. + Proof. + iInduction s as [|??] "IH" using set_ind_L. + iIntros. rewrite big_sepS_empty //. + iIntros "Hgr Hs". + rewrite !big_sepS_union; try set_solver. + iDestruct "Hs" as "[He Hs]". + rewrite !big_sepS_singleton. + iDestruct (graph_edge_agree with "Hgr He") as %?. + iSplit. done. iApply ("IH" with "Hgr Hs"). + Qed. + + Lemma token_excl a b: + Tok{a} -∗ Tok{b} -∗ ⌜a ≠ b⌝. + Proof. + rewrite rmw_token_eq /rmw_token_def. + iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as %Hvalid. + iPureIntro. rewrite auth_frag_op_valid in Hvalid. + rewrite gset_disj_valid_op in Hvalid. + set_solver + Hvalid. + Qed. + + Lemma token_alloc {gs tid pg na}: + na_at_progress (GlobalState.gs_graph gs) tid pg na ∗ + token_interp (dom na) ==∗ + let eid := ThreadState.progress_to_node pg tid in + token_interp ({[eid]} ∪ (dom na)) ∗ Tok{ eid }. + Proof. + iIntros "[Hnin Hint]". + iDestruct (na_at_progress_not_elem_of with "Hnin") as %Hnin. + rewrite rmw_token_eq /rmw_token_def /token_interp. + rewrite -own_op. iApply (own_update with "Hint"). + apply auth_update_alloc. + apply gset_disj_alloc_empty_local_update. + set_solver + Hnin. + Qed. + + Lemma annot_merge n P Q : + n ↦ₐ P -∗ n ↦ₐ Q -∗ (∀ na, annot_interp na ==∗ (n ↦ₐ (P ∗ Q)) ∗ annot_interp na). + Proof. + iIntros "Heid Heid'". rewrite annot_own_eq /annot_interp /annot_own_def. + iDestruct "Heid" as "[%name [%gn (Hname_mapped & Hset & Hprop)]]". + iDestruct "Heid'" as "[%name' [%gn' (Hname_mapped' & Hset' & Hprop')]]". + iDestruct (ghost_map_ag_elem_agree with "Hname_mapped Hname_mapped'") as %->. iClear "Hname_mapped'". + iIntros (?) "[%name_map (map_auth & %Hdom & Hmap)]". + iDestruct (ghost_map_ag_lookup with "map_auth Hname_mapped") as "%Hlk_nm". + assert (is_Some (na !! n)) as [? Hlk_na]. + { apply elem_of_dom. rewrite -Hdom. eapply elem_of_dom_2;eauto. } + iDestruct (big_sepM2_delete with "Hmap") as "[(%&Hset_a &Hres_map&#Hsep) Hmap]";eauto. + iDestruct (own_valid_2 with "Hset_a Hset") as %Hset_v. + rewrite auth_both_valid_discrete in Hset_v. destruct Hset_v as [Hset_v _]. + assert (is_Some (res !! gn)) as [R Hlk_res]. + { apply elem_of_dom. rewrite gset_disj_included in Hset_v. set_solver. } + iDestruct (own_valid_2 with "Hset_a Hset'") as %Hset_v'. + rewrite auth_both_valid_discrete in Hset_v'. destruct Hset_v' as [Hset_v' _]. + assert (is_Some (res !! gn')) as [R' Hlk_res']. + { apply elem_of_dom. rewrite gset_disj_included in Hset_v'. set_solver. } + iDestruct (own_valid_2 with "Hset Hset'") as %Hset_vv. + rewrite auth_frag_op_valid in Hset_vv. rewrite gset_disj_valid_op in Hset_vv. + + iDestruct (big_sepM_delete with "Hres_map") as "[Hsp' Hres_map]";eauto. + iDestruct (saved_prop_agree with "Hprop' Hsp'") as "#Hequiv'". + iDestruct (big_sepM_delete with "Hres_map") as "[Hsp Hres_map]";eauto. + { rewrite (lookup_delete_ne _ gn'). exact Hlk_res. set_solver + Hset_vv. } + iDestruct (saved_prop_agree with "Hprop Hsp") as "#Hequiv". + + iMod (saved_prop_update_halves (P ∗ Q) gn with "Hprop Hsp") as "[Hprop1 Hprop2]". + iMod (saved_prop_update_halves emp gn' with "Hprop' Hsp'") as "[Hprop1' Hprop2']". + + iModIntro. + iSplitR "map_auth Hset_a Hprop1 Hprop1' Hmap Hres_map". + { iExists name',gn. iFrame. } + iExists name_map. iFrame. iSplit;first done. + iApply big_sepM2_delete;eauto. iFrame. + iExists (<[gn' := emp%I]>(<[gn := (P ∗ Q)%I]> res)). + assert (dom (<[gn' := emp%I]>(<[gn := (P ∗ Q)%I]> res)) = dom res) as ->. + { apply elem_of_dom_2 in Hlk_res,Hlk_res'. rewrite !dom_insert_L. set_solver + Hlk_res Hlk_res'. } + iFrame. rewrite 2!big_sepM_insert_delete. iFrame. + rewrite delete_insert_ne. 2:{ apply elem_of_dom_2 in Hlk_res. set_solver + Hset_vv. } + rewrite 2!big_sepM_insert_delete. iFrame. + iNext. rewrite (bi.sep_comm P Q). + rewrite -bi.sep_assoc. iRewrite "Hequiv". iRewrite "Hequiv'". + rewrite -!big_sepM_delete //. rewrite bi.emp_sep //. + rewrite lookup_delete_ne //. set_solver + Hset_vv. + Qed. + + Definition annot_agree m eid P : + annot_interp m -∗ eid ↦ₐ P -∗ + ⌜eid ∈ dom m⌝ ∗ ∃ R, from_option (λ P', ▷ ■ (P' ∗-∗ P ∗ R)) emp (m !! eid). + Proof. + iIntros "Hint Heid". + rewrite annot_own_eq /annot_interp /annot_own_def. + iDestruct "Hint" as "[%name_map (map_auth & %Hdom & Hmap)]". + iDestruct "Heid" as "[%name [%gn (Hname_mapped & Hset & Hprop)]]". + iDestruct (ghost_map_ag_lookup with "map_auth Hname_mapped") as "%H'". + assert (is_Some (m !! eid)) as [? Hlk]. + { apply elem_of_dom. rewrite -Hdom. eapply elem_of_dom_2;eauto. } + iDestruct (big_sepM2_lookup with "Hmap") as "(%&Hset_a &Hmap&#Hsep)";eauto. + iDestruct (own_valid_2 with "Hset_a Hset") as %Hset_v. + rewrite auth_both_valid_discrete in Hset_v. destruct Hset_v as [Hset_v _]. + assert (is_Some (res !! gn)) as [R Hlk_res]. + { apply elem_of_dom. rewrite gset_disj_included in Hset_v. set_solver. } + iDestruct (big_sepM_lookup with "Hmap") as "Hsp";eauto. + iDestruct (saved_prop_agree with "Hprop Hsp") as "Hequiv". + iSplit. iPureIntro. apply elem_of_dom. eexists;eauto. + rewrite Hlk /=. rewrite big_sepM_delete //. + iExists _. iNext. iRewrite "Hequiv". + rewrite bi.wand_iff_sym. iExact "Hsep". + Qed. + + Definition annot_agree_big m m': + annot_interp m -∗ + ([∗ map] eid ↦ P ∈ m', eid ↦ₐ P) -∗ + ⌜dom m' ⊆ dom m ⌝ ∗ + ∃ m'', [∗ map] eid ↦ R;R' ∈ m';m'', from_option (λ P', ▷ ■ (P' ∗-∗ R ∗ R')) emp (m !! eid). + Proof. + iIntros "Hannot Hm". + iInduction m' as [|] "IH" using map_ind. + iSplit. iPureIntro. rewrite dom_empty_L //. iExists ∅. done. + rewrite !big_sepM_insert //. iDestruct "Hm" as "[H Hm]". + iDestruct (annot_agree with "Hannot H") as "#[% [%R Hequiv]]". + iDestruct ("IH" with "Hannot Hm") as "[%Hdom [%m' IH']]". + iSplit. iPureIntro. rewrite dom_insert_L. set_solver. + iExists (<[i := R]> m'). iDestruct (big_sepM2_dom with "IH'") as %Hdom'. + rewrite big_sepM2_insert //. + 2:{ apply not_elem_of_dom. rewrite -Hdom'. by apply not_elem_of_dom. } + iFrame. iFrame "Hequiv". + Qed. + + Definition annot_update m eid P : + annot_interp m -∗ + eid ↦ₐ P ==∗ + ∃R, annot_interp (<[eid:=R]>m) ∗ from_option(λ P', ▷ ■ (P' ∗-∗ P ∗ R)) emp (m !! eid). + Proof. + iIntros "Hint Heid". + iDestruct (annot_agree with "Hint Heid") as "[%Hdom #_]". + rewrite elem_of_dom in Hdom. destruct Hdom as [? Hlk]. rewrite Hlk /=. + rewrite annot_own_eq /annot_interp /annot_own_def. + iDestruct "Hint" as "[%name_map (map_auth & %Hdom & Hmap)]". + iDestruct "Heid" as "[%name [%gn (Hname_mapped & Hset & Hprop)]]". + iDestruct (ghost_map_ag_lookup with "map_auth Hname_mapped") as "%H'". + iDestruct (big_sepM2_delete with "Hmap") as "[(%&Hset_a &Hmap'&#Hsep) Hmap]";eauto. + iDestruct (own_valid_2 with "Hset_a Hset") as %Hset_v. + rewrite auth_both_valid_discrete in Hset_v. destruct Hset_v as [Hset_v _]. + assert (is_Some (res !! gn)) as [R' Hlk_res]. + { apply elem_of_dom. rewrite gset_disj_included in Hset_v. set_solver. } + iDestruct (big_sepM_delete with "Hmap'") as "[Hsp Hmap']";eauto. + iDestruct (saved_prop_agree with "Hprop Hsp") as "#Hequiv". + iMod (saved_prop_update_halves emp%I gn _ _ with "Hprop Hsp") as "(Hprop1 & Hprop2)". + iModIntro. + rewrite big_sepM_delete //. + iExists ([∗ map] y ∈ delete gn res, y)%I. + iSplitL. 2:{ iNext. iRewrite "Hequiv". rewrite bi.wand_iff_sym //. } + iExists _. iFrame. + iSplitR. rewrite dom_insert_L. iPureIntro. + assert (eid ∈ dom m). apply elem_of_dom. eexists;done. + set_solver + H1 Hdom. + iApply big_sepM2_delete;eauto. + rewrite lookup_insert_Some. left;split;eauto. + rewrite delete_insert_delete. iFrame. + iExists (<[gn := emp%I]>res). + rewrite dom_insert_L. + assert (({[gn]} ∪ dom res) = dom res) as ->. + { assert (gn ∈ dom res). apply elem_of_dom. eexists;done. + set_solver + H1. } + rewrite big_sepM_insert_delete //. iFrame. + iNext. iModIntro. rewrite big_sepM_insert_delete //. iSplit;[iIntros "[_ $]"|iIntros "$"]. + Qed. + + Definition annot_update_big {m m'}: + annot_interp m -∗ + ([∗ map] eid ↦ P ∈ m', eid ↦ₐ P) ==∗ + ∃m'', ⌜dom m'' = dom m'⌝ ∗ + annot_interp (m'' ∪ m) ∗ + ([∗ map] eid ↦ R; R' ∈ m'; m'', from_option(λ P',▷ ■ (P' ∗-∗ R ∗ R')) emp (m !! eid)). + Proof. + iIntros "Hannot Hm". + iInduction m' as [|] "IH" using map_ind. + iModIntro. iExists ∅. iSplitR;first done. rewrite map_empty_union. iFrame. done. + rewrite big_sepM_insert //. iDestruct "Hm" as "[Hi Hm]". + iDestruct ("IH" with "Hannot Hm") as ">[% (%Hdom & Hannot & Hequiv)]". + iDestruct (annot_update _ _ x with "Hannot Hi") as ">[% [Hannot Hi]]". + iModIntro. iExists (<[i := R]> m''). + iSplitR. { iPureIntro. rewrite !dom_insert_L. rewrite Hdom //. } + rewrite !insert_union_l. iFrame. + iApply (big_sepM2_insert_2 with "[Hi]"). + { rewrite lookup_union_r //. + apply not_elem_of_dom. rewrite Hdom. by apply not_elem_of_dom. } + done. + Qed. + + Definition annot_alloc na pg tid gs P : + annot_interp na ∗ na_at_progress (GlobalState.gs_graph gs) tid pg na + ==∗ + let eid := ThreadState.progress_to_node pg tid in + annot_interp (<[eid:=P]>na) ∗ + eid ↦ₐ P. + Proof. + iIntros "(Hannot & Hpg)". unfold na_at_progress. iDestruct (na_at_progress_not_elem_of with "Hpg") as %H'. + unfold annot_interp. iDestruct "Hannot" as "[%name_map (map_auth & %Hdom & Hmap)]". + iMod (saved_prop_alloc P (DfracOwn 1)) as "[%γ new_prop]". { done. } + iMod (own_alloc ((● GSet {[γ]}) ⋅ ◯ (GSet {[γ]}))) as "[%gn Hset]". + { rewrite auth_both_valid_discrete. + split;last done. apply gset_disj_included. set_solver +. } + rewrite own_op. iDestruct "Hset" as "[Hset_a Hset_f]". + iMod (ghost_map_ag_insert (ThreadState.progress_to_node pg tid) gn with "map_auth") as "(map_auth & Hname_mapped)". + { rewrite -not_elem_of_dom Hdom //. } + iModIntro. + iDestruct "new_prop" as "(new_prop1 & new_prop2)". + iSplitR "Hname_mapped Hset_f new_prop2". + - iExists _. iFrame. iSplitR. { iPureIntro. set_solver + Hdom. } + rewrite big_sepM2_insert;eauto. + 2: { apply not_elem_of_dom. rewrite Hdom //. } + 2: { by apply not_elem_of_dom. } + iSplitL "Hset_a new_prop1". + { iExists {[γ := P]}. rewrite dom_singleton_L. rewrite !big_sepM_singleton. iFrame. iNext. rewrite -bi.wand_iff_refl //. } + done. + - rewrite annot_own_eq /annot_own_def. + iExists gn, γ. iFrame. + Qed. + + Lemma annot_split n P Q: + n ↦ₐ (P ∗ Q) -∗ (∀ na, annot_interp na ==∗ (n ↦ₐ P ∗ n ↦ₐ Q) ∗ annot_interp na). + Proof. + iIntros "Heid". rewrite annot_own_eq /annot_own_def. + rewrite /annot_interp. iIntros (?) "Hint". + iDestruct "Heid" as "[%name [%gn (#Hname_mapped & Hset & Hprop)]]". + iDestruct "Hint" as "[%name_map (map_auth & %Hdom & Hmap)]". + iDestruct (ghost_map_ag_lookup with "map_auth Hname_mapped") as "%H'". + assert (is_Some (na !! n)) as [? Hlk]. + { apply elem_of_dom. rewrite -Hdom. eapply elem_of_dom_2;eauto. } + iDestruct (big_sepM2_delete with "Hmap") as "[(%&Hset_a &Hres_map&#Hsep) Hmap]";eauto. + iDestruct (own_valid_2 with "Hset_a Hset") as %Hset_v. + rewrite auth_both_valid_discrete in Hset_v. destruct Hset_v as [Hset_v _]. + assert (is_Some (res !! gn)) as [R Hlk_res]. + { apply elem_of_dom. rewrite gset_disj_included in Hset_v. set_solver. } + iDestruct (big_sepM_delete with "Hres_map") as "[Hsp Hres_map]";eauto. + iDestruct (saved_prop_agree with "Hprop Hsp") as "#Hequiv". + iMod (saved_prop_alloc_cofinite (dom res) P (DfracOwn 1)) as "[%gnp [%Hnin new_prop]]". { done. } + iMod (saved_prop_update_halves Q gn with "Hprop Hsp") as "[Hprop1 Hprop2]". + iDestruct "new_prop" as "[Hprop1' Hprop2']". + iMod (own_update _ _ (● GSet ({[gnp]}∪ (dom res)) ⋅ (◯ GSet {[gnp]})) with "Hset_a") as "Hset_a". + apply auth_update_alloc. apply gset_disj_alloc_empty_local_update. set_solver + Hnin. + iDestruct (own_op with "Hset_a") as "[Hset_a Hset']". + iModIntro. + iSplitR "map_auth Hset_a Hprop1 Hprop1' Hmap Hres_map". + { iSplitL "Hset' Hprop2'". iExists name,gnp. by iFrame. iExists name, gn. by iFrame. } + iExists name_map. iFrame. iSplit;first done. + iApply big_sepM2_delete;eauto. iFrame. + iExists (<[gnp := P]>(<[gn := Q]> res)). + assert (dom (<[gnp:=P]> (<[gn:=Q]> res)) = {[gnp]}∪ dom res) as ->. + { apply elem_of_dom_2 in Hlk_res. rewrite !dom_insert_L. set_solver + Hlk_res. } + iFrame. rewrite 2!big_sepM_insert_delete. iFrame. + rewrite delete_insert_ne. 2:{ apply elem_of_dom_2 in Hlk_res. set_solver + Hlk_res Hnin. } + assert ((delete gnp res) = res) as ->. rewrite delete_notin //. by apply not_elem_of_dom. + rewrite 2!big_sepM_insert_delete. iFrame. + iNext. iClear "Hname_mapped". iModIntro. + rewrite bi.sep_assoc. iRewrite "Hequiv". + rewrite -big_sepM_delete //. + Qed. + + (** [my_local_interp] *) + + Import ThreadState. + + Context `{HH: !ThreadGNL}. + + Lemma lpo_to_po eid : + Some eid -{LPo}> -∗ + Some eid -{LPo}> ∗ + eid -{Po}>. + Proof. + iIntros "Hlpo". + rewrite po_src_eq /po_src_def lpo_src_eq /lpo_src_def /=. + iDestruct "Hlpo" as "[#Hgr [% (#Hag & Hown)]]". + iEval (rewrite mono_pg_auth_lb_op) in "Hown". + iDestruct "Hown" as "(Hown & Hown')". + iFrame "Hgr". iSplitL "Hown"; iExists gn; iFrame "#∗". + Qed. + + #[global] Instance persistent_po_src `{CMRA Σ} `{!AABaseG} `{!ThreadGNL} eid : Persistent (eid -{Po}>). + Proof. rewrite po_src_eq /po_src_def. apply _. Qed. + + Lemma po_pred_interp_agree gs {tid : Tid} pg ls o_e: + po_pred_interp gs tid pg ls -∗ + o_e -{LPo}> -∗ + ⌜ from_option (λ e, EID.tid e = tid ∧ ThreadState.progress_of_node e

]. + done. + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI /=. iExFalso;done. + Qed. + + Lemma po_pred_interp_agree' gs {tid : Tid} pg ls e: + po_pred_interp gs tid pg ls -∗ + e -{Po}> -∗ + ⌜EID.tid e = tid ∧ ThreadState.progress_of_node e

) -∗ + [∗ set] e ∈ s, ⌜EID.tid e = tid ∧ ThreadState.progress_of_node e

+ po_pred_interp gs tid (get_progress ts) ls -∗ + po_pred_interp gs tid (get_progress (incr_cntr ts')) ls. + Proof. + rewrite /po_pred_interp. + iIntros (Heq) "[$ H]". + destruct ls;last iFrame. + simpl. iDestruct "H" as "[% (?&?&?&%&?)]". + iExists _. iFrame. iSplit;first done. + iSplit;last done. + iPureIntro. + eapply progress_lt_trans. eauto. + rewrite Heq. apply progress_adjacent_incr_cntr'. + rewrite progress_le_inv. right;done. + Qed. + + Lemma po_pred_interp_skip' gs {tid : Tid} ts ts' ls : + get_progress ts = get_progress ts' -> + po_pred_interp gs tid (get_progress ts) ls -∗ + po_pred_interp gs tid (get_progress (reset_cntr ts')) ls. + Proof. + rewrite /po_pred_interp. + iIntros (Heq) "[$ H]". + destruct ls;last iFrame. + simpl. iDestruct "H" as "[% (?&?&?&%&?)]". + iExists _. iFrame. iSplit;first done. + iSplit;last done. + iPureIntro. + eapply progress_lt_trans. eauto. + rewrite Heq. left. simpl;lia. + Qed. + + Lemma po_pred_interp_update gs {tid : Tid} ts ts' ls ls': + get_progress ts = get_progress ts' -> + progress_is_valid (GlobalState.gs_graph gs) tid (get_progress ts) -> + po_pred_interp gs tid (get_progress ts) ls -∗ + ls' -{LPo}> ==∗ + po_pred_interp gs tid (get_progress (incr_cntr ts')) (Some (progress_to_node (get_progress ts) tid)) ∗ + Some (progress_to_node (get_progress ts) tid) -{LPo}>. + Proof. + iIntros (Heq Hv) "[Hgr H1] H2". + rewrite lpo_src_eq /lpo_src_def. + destruct ls';simpl. + { + iDestruct "H2" as "[[% [Hgr' ?]] [% [H2 H3]]]". + iDestruct (graph_agree_agree with "Hgr Hgr'") as %<-. + rewrite /po_pred_interp. destruct ls;simpl. + iDestruct "H1" as "[% [H1 [H1' H1'']]]". + iDestruct (own_valid_2 with "H1 H2") as %Hvalid. + rewrite -Cinr_op in Hvalid. rewrite Cinr_valid in Hvalid. + rewrite to_agree_op_valid_L in Hvalid. inversion_clear Hvalid. iFrame. + iDestruct (own_valid_2 with "H1' H3") as %Hvalid. + rewrite mono_pg_auth_dfrac_op_valid in Hvalid. + destruct Hvalid as [_ ->]. + iDestruct "H1''" as %Ht0. destruct Ht0 as [Htid [Hle ?]]. + iDestruct (own_update_2 _ _ _ (●MN (progress_of_node (progress_to_node (get_progress ts) tid))) with "H1' H3") as ">[H1' H3]". + rewrite -mono_pg_auth_dfrac_op. rewrite dfrac_op_own. + assert (1 / 2 + 1 / 2 = 1)%Qp as ->. apply (bool_decide_unpack _). by compute. + apply mono_pg_update. + destruct Hle as [|];simpl in *. + left;simpl;lia. right;simpl;lia. + iModIntro. rewrite progress_of_node_to_node. iSplitL "H1 H1'". + iExists _. rewrite Htid. iSplitL "H1". iExact "H1". iFrame. + iPureIntro. split;auto. split;auto. apply progress_adjacent_incr_cntr'. + rewrite progress_le_inv;right;done. + iSplitL "Hgr". iExists _. iSplitL. iFrame "Hgr". + iPureIntro. rewrite /progress_is_valid in Hv. + set_unfold. destruct Hv as [? [? _]]. eexists. eauto. + iExists _. rewrite Htid. iFrame. + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI /=. iExFalso;done. + } + { + rewrite /po_pred_interp. destruct ls;simpl. + { + iDestruct "H1" as "[% [H1 [H1' H1'']]]". + iDestruct (own_valid_2 with "H1 H2") as "Hvalid". + rewrite csum_validI /=. iExFalso;done. + } + iDestruct (own_alloc (●MN (progress_of_node (progress_to_node (get_progress ts) tid)))) as ">[%gn [H3 H3']]". + apply mono_pg_auth_valid. + iDestruct (own_update_2 AAPoSrcN _ _ (Cinr ((to_agree ((gn, (tid : nat) ): (prodO gnameO natO) ) )) ) with "H1 H2") as ">H1". + rewrite -Cinl_op. rewrite -dfrac_agree_op. rewrite dfrac_op_own. + assert (1 / 2 + 1 / 2 = 1)%Qp as ->. apply (bool_decide_unpack _). by compute. + apply cmra_update_exclusive. + rewrite Cinr_valid. done. + iModIntro. rewrite progress_of_node_to_node. + iDestruct "Hgr" as "#?". iDestruct "H1" as "#?". + iFrame "#". iSplitL "H3". + iExists _. iSplitR. iFrame "#". iFrame "H3". iPureIntro. split;auto. split;auto. apply progress_adjacent_incr_cntr'. + rewrite progress_le_inv;right;done. + iSplitR. iExists _. iSplitL. iFrame "#". + iPureIntro. rewrite /progress_is_valid in Hv. + set_unfold. destruct Hv as [? [? _]]. eexists. eauto. + iExists _. iSplitR. iFrame "#". done. + } + Qed. + + Lemma last_write_interp_agree_None {gs} {tid : Tid} pg ls addr: + "Hinterp_local" ∷ last_write_interp gs tid pg ls -∗ + "Hlocal" ∷ last_local_write tid addr None -∗ + ⌜ forall eid_w E_w , (gs.(GlobalState.gs_graph)) !! eid_w = Some E_w -> + AAConsistent.event_is_write_with_addr E_w addr -> + (¬ (Graph.is_local_node_of tid eid_w)) ∨ (Graph.is_local_node_of tid eid_w) ∧ pg <=p ThreadState.progress_of_node eid_w ⌝. + Proof. + repeat iNamed 1. + iDestruct "Hinterp_local" as "[%Hft_Some [%Hft_None Hauth]]". + iCombine "Hauth Hlocal" gives %Hlk. + iPureIntro. intros eid E Heid_lk Hw. + destruct (decide (EID.tid eid = tid)) as [Htid|];[right|left; done]. + destruct (decide (pg <=p ThreadState.progress_of_node eid)) as [|Hnle];[done|exfalso]. + + assert (ThreadState.progress_of_node eid

+ AAConsistent.event_is_write_with_addr E_w' addr -> + (¬ (Graph.is_local_node_of tid eid_w') ∨ + (pg <=p ThreadState.progress_of_node eid_w' ∧ Graph.is_local_node_of tid eid_w') ∨ + (ThreadState.progress_of_node eid_w' <=p ThreadState.progress_of_node eid_w ∧ Graph.is_local_node_of tid eid_w')))⌝. + Proof. + repeat iNamed 1. + iDestruct "Hinterp_local" as "[%Hft_Some [%Hft_None Hauth]]". + iCombine "Hauth Hlocal" gives %Hlk. iPureIntro. + rewrite Hft_Some in Hlk. destruct Hlk as (?&Hft&HW). + apply map_filter_lookup_Some in Hft. destruct Hft as [Hft Hforall]. + apply map_filter_lookup_Some in Hft. destruct Hft as (?&?&?&?). + repeat eexists;eauto. { rewrite -AACandExec.Candidate.event_map_match //. } + intros eid_w' E_w' Hevent Hwrite. + destruct (decide (EID.tid eid_w' = tid)) as [Htid|];[right|left; done]. + destruct (decide (pg <=p ThreadState.progress_of_node eid_w')) as [|Hnle]; [left;done|right]. + rewrite map_Forall_lookup in Hforall. + split; [|done]. + apply (Hforall _ E_w'). + + apply map_filter_lookup_Some. + rewrite AACandExec.Candidate.event_map_match. + split; [done|]. + split; [done|]. + split. + { by apply progress_nle_gt. } + by eapply AAConsistent.event_is_write_with_addr_elem_of_mem_writes. + + eapply Graph.wf_loc_inv_writes2. + exists addr, x, E_w'. + split; [by rewrite -AACandExec.Candidate.event_map_match |]. + split; [done|]. + by split; [done|]. + Qed. + + Lemma last_write_interp_progress_write {gs ls} {tid : Tid} ts ts' addr ot : + AACandExec.NMSWF.wf (gs.(GlobalState.gs_graph)) -> + get_progress ts = get_progress ts' -> + (exists E, gs.(GlobalState.gs_graph) !! progress_to_node (get_progress ts) tid = Some E ∧ AAConsistent.event_is_write_with_addr E addr) -> + last_write_interp gs tid (get_progress ts) ls -∗ + last_local_write tid addr ot -∗ + |==> + last_write_interp gs tid (get_progress (incr_cntr ts')) (<[addr := (Some (progress_to_node (get_progress ts) tid))]> ls) ∗ + last_local_write tid addr (Some (progress_to_node (get_progress ts) tid)). + Proof. + iIntros (Hwf Hpg HW) "HL Hl". + destruct ot;simpl. + - iDestruct (last_write_interp_agree_Some with "HL Hl") as %(?&?&?&?&?). + iDestruct "HL" as "[%Hft_Some [%Hft_None Hauth]]". + iCombine "Hauth Hl" gives %Hlk. + iDestruct (ghost_map_update with "Hauth Hl") as ">[$ $]". iModIntro. iPureIntro. + split. + { + intros. + destruct (decide(addr = a)). + { + subst a. rewrite lookup_insert_Some. + split. + { + intros [[_ Hinv]| []];last done. inversion Hinv;subst e. clear Hinv. + destruct HW as [W [Hlk_w HW]]. + exists W. split;auto. + rewrite map_filter_lookup_Some. split. + rewrite map_filter_lookup_Some. split;auto. + rewrite AACandExec.Candidate.event_map_match //. + + split;auto;split;auto. + clear Hft_None. + apply progress_adjacent_incr_cntr'. + rewrite progress_le_inv. right. rewrite progress_of_node_to_node //. + set_unfold. + destruct W;destruct o;try inversion HW. + eexists;eexists;eexists;eauto. + intros ?? Hft. + rewrite map_filter_lookup_Some in Hft. + intro. + destruct Hft as (?&?&Hlt&?). + apply progress_adjacent_incr_cntr' in Hlt. + rewrite progress_of_node_to_node. rewrite Hpg //. + } + { + intros [W Hft]. + rewrite map_filter_lookup_Some in Hft. destruct Hft as [[Hft Hforall] HW']. + rewrite map_filter_lookup_Some in Hft. destruct Hft as (?&?&Hlt&?). + apply progress_adjacent_incr_cntr' in Hlt. rewrite progress_le_inv in Hlt. + destruct Hlt as [|Hq]. + 2:{ + left. split;auto. f_equal. rewrite Hpg -Hq. apply progress_to_node_of_node. done. + } + exfalso. + destruct HW as [W' [Hlk' HW'']]. + specialize (Hforall (progress_to_node (get_progress ts') tid) W'). + feed specialize Hforall. + apply map_filter_lookup_Some_2. + rewrite AACandExec.Candidate.event_map_match. + rewrite Hpg in Hlk'. done. + split. rewrite -Hpg //. + split. rewrite progress_of_node_to_node. + apply progress_adjacent_incr_cntr'. rewrite progress_le_inv;right;done. + rewrite -Hpg. + set_unfold. + + destruct W';destruct o;try inversion HW''. + simpl in HW''. + eexists;eexists;eexists. eauto. + eapply Graph.wf_loc_inv_writes2. + repeat eexists. rewrite -AACandExec.Candidate.event_map_match. eauto. + eauto. rewrite -Hpg. eauto. auto. + rewrite progress_of_node_to_node in Hforall. + eapply progress_le_gt_False;done. + } + } + { + rewrite lookup_insert_ne //. clear Hft_None. + rewrite Hft_Some. clear Hft_Some. + do 2 f_equiv. + rewrite !map_filter_lookup_Some. + { + split; intros [[(Hlk_e & Htid & Hlt & Hin) Hforall] Haddr]; split;auto;split;auto. + split;auto;split;auto;split;auto. + - eapply progress_lt_trans;eauto. rewrite /incr_cntr;right. do 2 destruct (get_progress _) eqn:?; simpl;inversion Hpg. lia. + - intros i ? Hlk_i ?. + rewrite map_filter_lookup_Some in Hlk_i. + destruct Hlk_i as (Hlk_i & Htid' & Hlt' & Hw_i). + specialize (Hforall i x0). + feed specialize Hforall;auto. + apply map_filter_lookup_Some. + split;auto;split;auto; split;auto;eauto. + eapply Graph.wf_loc_inv_writes in H5. + 2: assumption. + 2:{ exists a0. split. rewrite -AACandExec.Candidate.event_map_match //. exact Haddr. } + destruct H5 as (?&Hlk_i'&[Hw_i'|?]). + 2:{ rewrite AACandExec.Candidate.event_map_match in Hlk_i. + rewrite Hlk_i in Hlk_i'. inversion Hlk_i';subst x1. + set_unfold. destruct Hw_i as [? [? [? ?]]]. + rewrite Hlk_i in H6. inversion H6;subst. + destruct x; destruct o;simpl in H5; contradiction. + } + rewrite AACandExec.Candidate.event_map_match in Hlk_e. + rewrite AACandExec.Candidate.event_map_match in Hlk_i. + rewrite Hlk_i in Hlk_i'. inversion Hlk_i';subst x1. + apply progress_adjacent_incr_cntr' in Hlt'. rewrite progress_le_inv in Hlt'. + destruct Hlt' as [|Heq];[rewrite Hpg //|exfalso]. + + assert (i = progress_to_node (get_progress ts) tid). + { + rewrite -Hpg in Heq. rewrite -Heq. + rewrite progress_to_node_of_node //. + } + subst i. + destruct HW as [? Hlk_w]. + rewrite Hlk_i in Hlk_w. + destruct Hlk_w as [Heq' Haddr']. inversion Heq';subst x1. + destruct x0;destruct o;auto. + simpl in Hw_i'. simpl in Haddr'. + rewrite Is_true_true in Haddr'. rewrite andb_true_iff in Haddr'. destruct Haddr' as [_ Haddr']. + rewrite Is_true_true in Hw_i'. rewrite andb_true_iff in Hw_i'. destruct Hw_i' as [_ H8]. + case_bool_decide;last done. + case_bool_decide;last done. + rewrite H5 in H6. done. + - split;auto;split;auto. split;auto. + apply progress_adjacent_incr_cntr' in Hlt. rewrite progress_le_inv in Hlt. + destruct Hlt as [|Heq];[rewrite Hpg //|exfalso]. + + assert (e = progress_to_node (get_progress ts) tid). + { + rewrite -Hpg in Heq. rewrite -Heq. + rewrite progress_to_node_of_node //. + } + subst e. + (* cannot be on the same address *) + destruct HW as [? Hlk_w]. + rewrite AACandExec.Candidate.event_map_match in Hlk_e. + rewrite Hlk_e in Hlk_w. + destruct Hlk_w as [Heq' Haddr']. inversion Heq';subst. + destruct x0;destruct o;auto. simpl in Haddr. simpl in Haddr'. + rewrite Is_true_true in Haddr'. rewrite andb_true_iff in Haddr'. destruct Haddr' as [_ Haddr']. + rewrite Is_true_true in Haddr. rewrite andb_true_iff in Haddr. destruct Haddr as [_ Haddr]. + case_bool_decide;last done. + case_bool_decide;last done. rewrite H5 // in H6. + - intros i ? Hlk_i ?. + rewrite map_filter_lookup_Some in Hlk_i. + destruct Hlk_i as [Hlk_i [Htid' [Hlt' Hw_i]]]. + specialize (Hforall i x0). + feed specialize Hforall;auto. + apply map_filter_lookup_Some. + split;auto;split;auto; split;auto. + eapply progress_lt_trans;eauto. + apply progress_adjacent_incr_cntr'. rewrite progress_le_inv;right;done. + } + } + } + { + intro. + destruct (decide(addr = a)). + { + subst a. rewrite lookup_insert_Some. + intros [[_ Hinv]|[]];[inversion Hinv|done]. + } + { + rewrite lookup_insert_ne //. + intro HHlk. specialize (Hft_None a HHlk). + clear Hft_Some. + + intros i ? Hlk_i. + rewrite map_filter_lookup_Some in Hlk_i. + destruct Hlk_i as [Hlk_i [Htid' [Hlt' Hw_i]]]. + + apply progress_adjacent_incr_cntr' in Hlt'. rewrite progress_le_inv in Hlt'. + destruct Hlt' as [|Heq];[|]. + eapply (Hft_None i). + rewrite map_filter_lookup_Some. + split;auto; split;auto; split;auto. + rewrite Hpg //. + (* cannot on same address *) + assert (i = progress_to_node (get_progress ts) tid). + { + rewrite -Hpg in Heq. rewrite -Heq. + rewrite progress_to_node_of_node //. + } + subst i. + + destruct HW as [? Hlk_w]. + rewrite AACandExec.Candidate.event_map_match in Hlk_i. + rewrite Hlk_i in Hlk_w. + destruct Hlk_w as [Heq' Haddr']. inversion Heq';subst. + destruct x1;destruct o;auto. simpl in Haddr'. + rewrite Is_true_true in Haddr'. rewrite andb_true_iff in Haddr'. destruct Haddr' as [_ Haddr']. + case_bool_decide;last done. simpl. + rewrite H5. + case_bool_decide. done. apply andb_false_r. + } + } + (* ot = None *) + - destruct HW as [W [Hlk_w HW]]. + iDestruct (last_write_interp_agree_None with "HL Hl") as %[Htid|_];eauto. + { (* in another thread *) + iDestruct "HL" as "[%Hft_Some [%Hft_None Hauth]]". + iCombine "Hauth Hl" gives %Hlk. + iDestruct (ghost_map_update with "Hauth Hl") as ">[$ $]". iModIntro. iPureIntro. + simpl in Htid. done. + } + { (* in same thread, but later *) + iDestruct "HL" as "[%Hft_Some [%Hft_None Hauth]]". + iCombine "Hauth Hl" gives %Hlk. + iDestruct (ghost_map_update with "Hauth Hl") as ">[$ $]". iModIntro. iPureIntro. + + split. + { + intros. + destruct (decide(addr = a)). + { + subst a. rewrite lookup_insert_Some. + split. + { + intros [[_ Hinv]| []];last done. inversion Hinv;subst e. clear Hinv. + exists W. split;auto. + rewrite map_filter_lookup_Some. split. + rewrite map_filter_lookup_Some. split;auto. + rewrite AACandExec.Candidate.event_map_match //. + + split;auto;split;auto. + clear Hft_None. + apply progress_adjacent_incr_cntr'. + rewrite progress_le_inv. right. rewrite progress_of_node_to_node //. + set_unfold. destruct W;destruct o;try inversion HW. + simpl in HW. rewrite Is_true_true in HW. rewrite andb_true_iff in HW. destruct HW as [? _]. + eexists;eexists;eexists. eassumption. + intros ?? Hft. + rewrite map_filter_lookup_Some in Hft. + intro. + destruct Hft as (?&?&Hlt&?). + apply progress_adjacent_incr_cntr' in Hlt. + rewrite progress_of_node_to_node. rewrite Hpg //. + } + { intros [W' Hft]. + rewrite map_filter_lookup_Some in Hft. destruct Hft as [[Hft Hforall] HW']. + rewrite map_filter_lookup_Some in Hft. destruct Hft as (?&?&Hlt&?). + apply progress_adjacent_incr_cntr' in Hlt. rewrite progress_le_inv in Hlt. + destruct Hlt as [|Hq]. + 2:{ + left. split;auto. f_equal. rewrite Hpg -Hq. apply progress_to_node_of_node. done. + } + exfalso. + specialize (Hforall (progress_to_node (get_progress ts') tid) W). + feed specialize Hforall. + apply map_filter_lookup_Some_2. + rewrite AACandExec.Candidate.event_map_match. + rewrite Hpg in Hlk_w. done. + split. rewrite -Hpg //. + split. rewrite progress_of_node_to_node. + apply progress_adjacent_incr_cntr'. rewrite progress_le_inv;right;done. + rewrite -Hpg. + set_unfold. destruct W;destruct o;try inversion HW. + simpl in HW. rewrite Is_true_true in HW. rewrite andb_true_iff in HW. destruct HW as [? _]. + eexists;eexists;eexists. eassumption. + eapply Graph.wf_loc_inv_writes2. + repeat eexists. rewrite -AACandExec.Candidate.event_map_match. eauto. + eauto. rewrite -Hpg. eauto. auto. + rewrite progress_of_node_to_node in Hforall. + eapply progress_le_gt_False;done. + } + } + { rewrite lookup_insert_ne //. clear Hft_None. + rewrite Hft_Some. clear Hft_Some. + do 2 f_equiv. + rewrite !map_filter_lookup_Some. + { + split; intros [[(Hlk_e & Htid & Hlt & Hin) Hforall] Haddr]; split;auto;split;auto. + split;auto;split;auto;split;auto. + - eapply progress_lt_trans;eauto. rewrite /incr_cntr;right. do 2 destruct (get_progress _) eqn:?; simpl;inversion Hpg. lia. + - intros i ? Hlk_i ?. + rewrite map_filter_lookup_Some in Hlk_i. + destruct Hlk_i as (Hlk_i & Htid' & Hlt' & Hw_i). + specialize (Hforall i x). + feed specialize Hforall;auto. + apply map_filter_lookup_Some. + split;auto;split;auto; split;auto. + eapply Graph.wf_loc_inv_writes in H1. + 2: assumption. + 2:{ exists a0. split. rewrite -AACandExec.Candidate.event_map_match //. exact Haddr. } + destruct H1 as (?&Hlk_i'&[Hw_i'|?]). + 2:{ rewrite AACandExec.Candidate.event_map_match in Hlk_i. + rewrite Hlk_i in Hlk_i'. inversion Hlk_i';subst x0. + set_unfold. destruct Hw_i as [? [? [? ?]]]. + rewrite Hlk_i in H2. inversion H2;subst. + destruct a0; destruct o;simpl in H1; contradiction. + } + rewrite AACandExec.Candidate.event_map_match in Hlk_e. + rewrite AACandExec.Candidate.event_map_match in Hlk_i. + rewrite Hlk_i in Hlk_i'. inversion Hlk_i';subst x0. + apply progress_adjacent_incr_cntr' in Hlt'. rewrite progress_le_inv in Hlt'. + destruct Hlt' as [|Heq];[rewrite Hpg //|exfalso]. + + assert (i = progress_to_node (get_progress ts) tid). + { + rewrite -Hpg in Heq. rewrite -Heq. + rewrite progress_to_node_of_node //. + } + subst i. + rewrite Hlk_i in Hlk_w. + inversion Hlk_w;subst x. + destruct W;destruct o;auto. + simpl in Hw_i'. simpl in HW. + rewrite Is_true_true in HW. rewrite andb_true_iff in HW. destruct HW as [_ HW]. + rewrite Is_true_true in Hw_i'. rewrite andb_true_iff in Hw_i'. destruct Hw_i' as [_ H4]. + case_bool_decide;last done. + case_bool_decide;last done. + rewrite H1 in H2. done. + - split;auto;split;auto. split;auto. + apply progress_adjacent_incr_cntr' in Hlt. rewrite progress_le_inv in Hlt. + destruct Hlt as [|Heq];[rewrite Hpg //|exfalso]. + + assert (e = progress_to_node (get_progress ts) tid). + { + rewrite -Hpg in Heq. rewrite -Heq. + rewrite progress_to_node_of_node //. + } + subst e. + (* cannot be on the same address *) + rewrite AACandExec.Candidate.event_map_match in Hlk_e. + rewrite Hlk_e in Hlk_w. + inversion Hlk_w ;subst. + destruct W;destruct o;auto. simpl in Haddr. simpl in HW. + rewrite Is_true_true in HW. rewrite andb_true_iff in HW. destruct HW as [_ HW]. + rewrite Is_true_true in Haddr. rewrite andb_true_iff in Haddr. destruct Haddr as [_ Haddr]. + case_bool_decide;last done. + case_bool_decide;last done. rewrite H1 // in H2. + - intros i ? Hlk_i ?. + rewrite map_filter_lookup_Some in Hlk_i. + destruct Hlk_i as [Hlk_i [Htid' [Hlt' Hw_i]]]. + specialize (Hforall i x). + feed specialize Hforall;auto. + apply map_filter_lookup_Some. + split;auto;split;auto; split;auto. + eapply progress_lt_trans;eauto. + apply progress_adjacent_incr_cntr'. rewrite progress_le_inv;right;done. + } + } + } + { + intro. + destruct (decide(addr = a)). + { + subst a. rewrite lookup_insert_Some. + intros [[_ Hinv]|[]];[inversion Hinv|done]. + } + { rewrite lookup_insert_ne //. intros HHlk. + specialize (Hft_None a HHlk). + + clear Hft_Some. + intros i ? Hlk_i. + rewrite map_filter_lookup_Some in Hlk_i. + destruct Hlk_i as [Hlk_i [Htid' [Hlt' Hw_i]]]. + + apply progress_adjacent_incr_cntr' in Hlt'. rewrite progress_le_inv in Hlt'. + destruct Hlt' as [|Heq];[|]. + eapply (Hft_None i). + rewrite map_filter_lookup_Some. + split;auto; split;auto; split;auto. + rewrite Hpg //. + (* cannot on same address *) + assert (i = progress_to_node (get_progress ts) tid). + { + rewrite -Hpg in Heq. rewrite -Heq. + rewrite progress_to_node_of_node //. + } + subst i. + rewrite AACandExec.Candidate.event_map_match in Hlk_i. + rewrite Hlk_i in Hlk_w. + inversion Hlk_w;subst. + destruct W;destruct o;auto. simpl in HW. + rewrite Is_true_true in HW. rewrite andb_true_iff in HW. destruct HW as [_ HW]. + case_bool_decide;last done. simpl. + rewrite H1. + case_bool_decide; first done. apply andb_false_r. + } + } + } + Qed. + + Lemma last_write_interp_progress_non_write {gs ls} {tid : Tid} ts ts' : + get_progress ts = get_progress ts' -> + (progress_to_node (get_progress ts) tid) ∉ AACandExec.Candidate.mem_writes gs.(GlobalState.gs_graph) -> + last_write_interp gs tid (get_progress ts) ls -∗ + last_write_interp gs tid (get_progress (incr_cntr ts')) ls. + Proof. + iIntros (Hpg Hnw) "[%Hft_Some [%Hft_None $]]". iPureIntro. + assert (Hequiv:forall i, EID.tid i = tid ∧ progress_of_node i

+ ts_is_done_instr (gs.(GlobalState.gs_graph)) tid ts -> + last_write_interp gs tid (get_progress ts) ls -∗ + last_write_interp gs tid (get_progress (reset_cntr ts')) ls. + Proof. + iIntros (Hpg Hnw) "[%Hft_Some [%Hft_None $]]". iPureIntro. + (* this proof is different, the rest is identical *) + assert (Hequiv: forall i, EID.tid i = tid ∧ progress_of_node i

Protocol] *) +#[global] Instance user_prot_to_prot `{CMRA Σ} `{!AABaseG} `{!UserProt} : Protocol := + Build_Protocol _ _ (λ e, + ∀ kind_s kind_v addr val, e -{E}> (Event.W kind_s kind_v addr val) -∗ + prot addr val e)%I. + +(* The final CMRA typeclass to be assumed *) +Class AAIrisG `{CMRA Σ} `{aairis_inv : !invGS_gen HasNoLc Σ} `{aairis_base : !AABaseG}:= {}. + +(* Instantiation of low-level logic *) +#[global] Instance instantiation_irisG `{AAIrisG} : irisG := { + annot_interp := my_annot_interp; + gconst_interp := global_interp; + }. + +#[global] Instance instantiation_irisGL `{AAIrisG} `{!ThreadGNL} : irisGL := { + local_interp := my_local_interp; + }. diff --git a/theories/low/interp_mod.v b/theories/low/interp_mod.v new file mode 100644 index 0000000..cfa5543 --- /dev/null +++ b/theories/low/interp_mod.v @@ -0,0 +1,307 @@ +(* The file contains the [interp_mod] modality, which allows one to access + [annot_interp] with a basic update modality *) +From iris.proofmode Require Import base tactics classes. +From self.low Require Import iris. + +Definition interp_mod_def `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} (P : iProp Σ) : iProp Σ := + ∀ na, annot_interp na ==∗ P ∗ annot_interp na. + +Definition interp_mod_aux : seal (@interp_mod_def). Proof. by eexists. Qed. +Definition interp_mod := interp_mod_aux.(unseal). +Arguments interp_mod {Σ _ _ _}. +Definition interp_mod_eq : @interp_mod = @interp_mod_def := interp_mod_aux.(seal_eq). +Notation "|=i=> P" := (interp_mod P) (at level 20) : bi_scope. + +Section lemma. + Context `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG}. + + Lemma interp_mod_mono P Q : + (P -∗ Q) + ⊢ + (|=i=> P) -∗ |=i=> Q. + Proof. + iIntros "H". + rewrite interp_mod_eq /interp_mod_def. + iIntros "P". iIntros (?) "Hannot". + iMod ("P" with "Hannot") as "[P $]". iModIntro. + by iApply "H". + Qed. + + Lemma interp_mod_strong_mono P Q : + (P ==∗ Q) + ⊢ + (|=i=> P) -∗ |=i=> Q. + Proof. + iIntros "H". + rewrite interp_mod_eq /interp_mod_def. + iIntros "P". iIntros (?) "Hannot". + iMod ("P" with "Hannot") as "[P $]". + by iApply "H". + Qed. + + Lemma interp_mod_bupd P: + (|==> |=i=> P)%I ⊢ |=i=> P. + Proof. + iIntros "H". + rewrite interp_mod_eq /interp_mod_def. + iIntros (?) "Hannot". iMod "H". + iMod ("H" with "Hannot") as "[P $]". + done. + Qed. + + Lemma interp_mod_bupd' P: + (|==> P)%I ⊢ |=i=> P. + Proof. + iIntros "H". + rewrite interp_mod_eq /interp_mod_def. + iIntros (?) "Hannot". iMod "H". + by iFrame. + Qed. + + Lemma interp_mod_frame_l P Q: + P ∗ |=i=> Q ⊢ |=i=> (P ∗ Q). + Proof. + iIntros "[P Q]". + iApply (interp_mod_mono with "[P]"). + 2:{ iFrame. } + iIntros "?". iFrame. + Qed. + + Lemma interp_mod_frame_r P Q: + (|=i=> P) ∗ Q ⊢ |=i=> (P ∗ Q). + Proof. + iIntros "[P Q]". + iApply (interp_mod_mono with "[Q]"). + 2:{ iFrame. } + iIntros "?". iFrame. + Qed. + + Lemma interp_mod_sep P Q: + |=i=> P ∗ |=i=> Q ⊢ |=i=> (P ∗ Q). + Proof. + iIntros "[P Q]". + rewrite interp_mod_eq /interp_mod_def. + iIntros (?) "Hannot". + iMod ("P" with "Hannot") as "[$ Hannot]". + by iMod ("Q" with "Hannot") as "[$ $]". + Qed. + + Lemma interp_mod_intro P: + P ⊢ |=i=> P. + Proof. + iIntros "P". + rewrite interp_mod_eq /interp_mod_def. + iIntros (?) "Hannot". + by iFrame. + Qed. + + Lemma interp_mod_wand_r P Q: + (|=i=> P) ∗ (P -∗ Q) ⊢ |=i=> Q. + Proof. + iIntros "[P H]". + by iApply (interp_mod_mono with "H"). + Qed. + + Lemma interp_mod_trans P: + (|=i=> |=i=> P) ⊢ |=i=> P. + Proof. + iIntros "P". + rewrite interp_mod_eq /interp_mod_def. + iIntros (?) "Hannot". + iMod ("P" with "Hannot") as "[P Hannot]". + iMod ("P" with "Hannot") as "[P Hannot]". + by iFrame. + Qed. + + Lemma interp_mod_or P Q: + (|=i=> P) ∨ (|=i=> Q) ⊢ |=i=> (P ∨ Q). + Proof. + iIntros "H". + iDestruct "H" as "[H|H]"; + (iApply interp_mod_mono;[|iFrame]);[iApply bi.or_intro_l| iApply bi.or_intro_r]. + Qed. + + Lemma interp_mod_and P Q: + |=i=> (P ∧ Q) ⊢ |=i=> P ∧ |=i=> Q. + Proof. + iIntros "H". + iSplit; (iApply interp_mod_mono;[|iFrame]); [iApply bi.and_elim_l| iApply bi.and_elim_r]. + Qed. + + Lemma interp_mod_exists {A} P: + (∃ x : A, |=i=> P x) ⊢ |=i=> (∃ x : A, P x). + Proof. + iIntros "[% H]". + iApply interp_mod_mono;[|iFrame]. + iIntros "?"; iExists _;iFrame. + Qed. + + Lemma interp_mod_forall {A} P: + |=i=> (∀ x : A, P x) ⊢ ∀ x : A, |=i=> (P x). + Proof. + iIntros "H". iIntros (?). + iApply interp_mod_mono;[|iFrame]. + iIntros "H". iApply "H". + Qed. + + (* These don't hold *) + (* Lemma interp_mod_except_0 P: *) + (* ◇ (|=i=> P) ⊢ |=i=> (◇ P). *) + + (* Lemma interp_mod_plain P: *) + (* Plain P → (|=i=> P) ⊢ P. *) + + Global Instance interp_mod_proper : + Proper ( bi_entails --> flip bi_entails ) interp_mod. + Proof. + rewrite /Proper. + intros ? ? Hi. + iIntros "?". + iApply interp_mod_mono. + 2: { iFrame. } + iIntros "?". + by iApply Hi. + Qed. + + Global Instance interp_mod_proper' : + Proper (bi_entails ==> bi_entails ) interp_mod. + Proof. + rewrite /Proper. + intros ? ? Hi. + iIntros "?". + iApply interp_mod_mono. + 2: { iFrame. } + iIntros "?". + by iApply Hi. + Qed. + + + Global Instance interp_mod_ne : + NonExpansive interp_mod. + Proof. + rewrite interp_mod_eq /interp_mod_def. + intros ????. + do 5 f_equiv;done. + Qed. + + Global Instance interp_mod_proper'' : + Proper ((≡) ==> (≡)) interp_mod := ne_proper _. + +End lemma. + +From stdpp Require Import nat_cancel. +From iris.proofmode Require Import modality_instances classes. +From iris.proofmode Require Import ltac_tactics class_instances. +From iris.prelude Require Import options. + +Section class_instances_updates. + Context `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG}. + Implicit Types P Q R : (iProp Σ). + + Global Instance from_assumption_iupd p P Q : + FromAssumption p P Q → KnownRFromAssumption p P (|=i=> Q). + Proof. rewrite /KnownRFromAssumption /FromAssumption=>->. apply interp_mod_intro. Qed. + + Global Instance from_pure_iupd a P φ : + FromPure a P φ → FromPure a (|=i=> P) φ. + Proof. rewrite /FromPure=> HR. setoid_rewrite <- HR. apply interp_mod_intro. Qed. + + Global Instance into_wand_iupd p q R P Q : + IntoWand false false R P Q → IntoWand p q (|=i=> R) (|=i=> P) (|=i=> Q). + Proof. + rewrite /IntoWand /= => HR. rewrite !bi.intuitionistically_if_elim HR. + apply bi.wand_intro_l. by rewrite interp_mod_sep bi.wand_elim_r. + Qed. + + Global Instance into_wand_iupd_persistent p q R P Q : + IntoWand false q R P Q → IntoWand p q (|=i=> R) P (|=i=> Q). + Proof. + rewrite /IntoWand /= => HR. + rewrite bi.intuitionistically_if_elim HR. + apply bi.wand_intro_l. by rewrite interp_mod_frame_l bi.wand_elim_r. + Qed. + + Global Instance into_wand_iupd_args p q R P Q : + IntoWand p false R P Q → IntoWand' p q R (|=i=> P) (|=i=> Q). + Proof. + rewrite /IntoWand' /IntoWand /= => ->. + apply bi.wand_intro_l. by rewrite bi.intuitionistically_if_elim interp_mod_wand_r. + Qed. + + Global Instance from_sep_iupd P Q1 Q2 : + FromSep P Q1 Q2 → FromSep (|=i=> P) (|=i=> Q1) (|=i=> Q2). + Proof. rewrite /FromSep=> HR. rewrite interp_mod_sep. + iApply interp_mod_mono. iIntros "[? ?]". iApply HR. by iFrame. Qed. + + Global Instance from_or_iupd P Q1 Q2 : + FromOr P Q1 Q2 → FromOr (|=i=> P) (|=i=> Q1) (|=i=> Q2). + Proof. rewrite /FromOr=><-. apply interp_mod_or. Qed. + + Global Instance into_and_iupd P Q1 Q2 : + IntoAnd false P Q1 Q2 → IntoAnd false (|=i=> P) (|=i=> Q1) (|=i=> Q2). + Proof. rewrite /IntoAnd/==>->. apply interp_mod_and. Qed. + + Global Instance from_exist_iupd {A} P (Φ : A → iProp Σ) : + FromExist P Φ → FromExist (|=i=> P) (λ a, |=i=> Φ a)%I. + Proof. rewrite /FromExist=><-. apply interp_mod_exists. Qed. + + Global Instance into_forall_bupd {A} P (Φ : A → iProp Σ) : + IntoForall P Φ → IntoForall (|=i=> P) (λ a, |=i=> Φ a)%I. + Proof. rewrite /IntoForall=>->. apply interp_mod_forall. Qed. + + (* Global Instance is_except_0_bupd P : IsExcept0 P → IsExcept0 (|=i=> P). *) + (* Proof. *) + (* rewrite /IsExcept0=> HP. *) + (* by rewrite -{2}HP -(except_0_idemp P) -except_0_bupd -(except_0_intro P). *) + (* Qed. *) + + Global Instance from_modal_iupd P : + FromModal True modality_id (|=i=> P) (|=i=> P) P. + Proof. by rewrite /FromModal /= -interp_mod_intro. Qed. + + Global Instance elim_modal_iupd p P Q : + ElimModal True p false (|=i=> P) P (|=i=> Q) (|=i=> Q). + Proof. + rewrite /ElimModal + bi.intuitionistically_if_elim interp_mod_frame_r. iIntros (_). + setoid_rewrite bi.wand_elim_r. by rewrite interp_mod_trans. + Qed. + + (* Global Instance elim_modal_bupd_plain_goal p P Q : *) + (* Plain Q → ElimModal True p false (|=i=> P) P Q Q. *) + (* Proof. *) + (* intros. rewrite /ElimModal bi.intuitionistically_if_elim *) + (* interp_mod_frame_r bi.wand_elim_r. bupd_plain. *) + (* Qed. *) + + (* Global Instance elim_modal_bupd_plain *) + (* `{!BiBUpd PROP, !BiPlainly PROP, !BiBUpdPlainly PROP} p P Q : *) + (* Plain P → ElimModal True p p (|==> P) P Q Q. *) + (* Proof. intros. by rewrite /ElimModal bupd_plain wand_elim_r. Qed. *) + + Global Instance elim_modal_bupd_iupd p P Q : + ElimModal True p false (|==> P) P (|=i=> Q) (|=i=> Q) | 10. + Proof. + by rewrite /ElimModal bi.intuitionistically_if_elim + interp_mod_bupd' interp_mod_frame_r bi.wand_elim_r interp_mod_trans. + Qed. + Global Instance elim_modal_iupd_iupd p P Q : + ElimModal True p false (|=i=> P) P (|=i=> Q) (|=i=> Q). + Proof. + by rewrite /ElimModal bi.intuitionistically_if_elim + interp_mod_frame_r bi.wand_elim_r interp_mod_trans. + Qed. + + Global Instance add_modal_iupd P Q : AddModal (|=i=> P) P (|=i=> Q). + Proof. by rewrite /AddModal interp_mod_frame_r bi.wand_elim_r interp_mod_trans. Qed. + + Global Instance elim_acc_iupd {X} α β mγ Q : + ElimAcc (X:=X) True interp_mod interp_mod α β mγ + (|=i=> Q) + (λ x, |=i=> β x ∗ (mγ x -∗? |=i=> Q))%I. + Proof. + iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". + iDestruct ("Hinner" with "Hα") as "[Hβ Hfin]". + iMod ("Hclose" with "Hβ") as ">Hγ". by iApply "Hfin". + Qed. +End class_instances_updates. diff --git a/theories/low/iris.v b/theories/low/iris.v new file mode 100644 index 0000000..7ef37ff --- /dev/null +++ b/theories/low/iris.v @@ -0,0 +1,23 @@ +(* This file contains the typeclass which is the parameter of the low-level logic, + the weakest precondition and adequacy can be instantiated by any instance of the typeclass*) +From iris.base_logic.lib Require Export fancy_updates. + +From self Require Export cmra. +From self.lang Require Export opsem. +From self.low.lib Require Export annotations. +Import uPred. + +Class irisG `{CMRA Σ} `{!invGS_gen HasNoLc Σ} := IrisG { + (* Interpretation of tied assertions *) + annot_interp : mea Σ -> iProp Σ; + (* Interpretation of global instruction memory and graph *) + gconst_interp : GlobalState.t -> iProp Σ; +}. + + +Class irisGL `{CMRA Σ} := IrisGL { + (* logical thread state *) + log_ts_t : Type; + (* local interpretation (for both 'physical' and logical ts), parametrised by tid *) + local_interp : GlobalState.t -> Tid -> ThreadState.progress -> log_ts_t ->iProp Σ; +}. diff --git a/theories/low/lib/annotations.v b/theories/low/lib/annotations.v new file mode 100644 index 0000000..336904d --- /dev/null +++ b/theories/low/lib/annotations.v @@ -0,0 +1,494 @@ +(* This file contains the definition of edge annotation and node annotation, which are used by weakestpres *) +From iris.algebra Require Import gmap gset. +From iris.base_logic.lib Require Import fancy_updates. +From iris.bi Require Import big_op. +From iris.proofmode Require Import tactics. + +From iris_named_props Require Import named_props. + +From self Require Import stdpp_extra iris_extra. +From self.algebra Require Import base. +From self.lang Require Import mm opsem. + +Notation mea Σ := (gmap Eid (iProp Σ)). +Notation sra Σ := (gmap Eid (mea Σ)). + +Section definition. +Import Graph. + +(** Node Annotation *) +(* resources that avaliable on each node *) +Class NodeAnnot `{CMRA Σ} := + { + na_local_wf tid (na : mea Σ) := set_Forall (fun e => is_local_node_of tid e) (dom na); + (* for all local nodes in [dom(na)], their progresses < current progress [ρ] *) + na_at_progress (gr : Graph.t) (tid : Tid) (pg : ThreadState.progress) (na : mea Σ) : iProp Σ := + (* all local nodes in the domain of na are po pred of current node *) + "%Hna_dom_eq" ∷ ⌜filter (λ e : Eid, Graph.is_local_node_of tid e) (dom na) = LThreadStep.eids_from_init gr tid pg⌝; + na_splitting_wf (s_lob : gset Eid) (na na_used na_unused : mea Σ) : iProp Σ := + "%Hnau_dom_sub" ∷ ⌜dom na_used ⊆ s_lob⌝ ∗ + "#Hnau_wf" ∷ [∗ map] e ↦ Pu;Puu ∈ na_used;na_unused, + (* it is a almost pure equiv (by the plain modality), + so that nothing in the spatial ctxt (nor non-plain persistent ctxt) can be used *) + ▷ ■ (Pu ∗ Puu ∗-∗ from_option (λ P, P) emp (na !! e)); + na_full (gr : Graph.t) (na : mea Σ) : iProp Σ := + "%Hna_dom_full" ∷ ⌜dom na = Candidate.non_initial_eids gr⌝; + }. + +#[global] Instance na_instance `{CMRA Σ}: NodeAnnot := {}. + +(** Protocols *) +Definition prot_t Σ := Addr -> Val -> (Eid -> iProp Σ). + +Class Protocol `{CMRA Σ} := { + prot_node : (Eid -> iProp Σ); + }. + +(** Flow Equations *) + +Class FlowEq `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!Protocol} := { + flow_eq (s_lob s_obs : gset Eid) (e : Eid) (na: mea Σ) (R: iProp Σ) : iProp Σ := + "R_lob_in" ∷ ([∗ set] e_in ∈ s_lob, from_option id True%I (na !! e_in)) ∗ + "#R_obs_in" ∷ □([∗ set] e_in ∈ s_obs, prot_node e_in) + ={⊤,∅}=∗ ▷ |={∅,⊤}=> + "R_obs_out" ∷ □(prot_node e) ∗ + "R_na" ∷ R; + flow_eq_ea (s_lob s_obs : gset Eid) (e : Eid) (gm: mea Σ) (ea: sra Σ) (R: iProp Σ) : iProp Σ := + "R_lob_in" ∷ ([∗ map] _ ↦ R_in ∈ gm, R_in) ∗ + "#R_obs_in" ∷ □([∗ set] e_in ∈ s_obs, prot_node e_in) + ={⊤,∅}=∗ ▷ |={∅,⊤}=> + "#R_obs_out" ∷ □(prot_node e) ∗ + "R_na" ∷ R ∗ + "R_lob_out" ∷ ([∗ set] e_out ∈ s_lob, + from_option (λ gm, from_option id emp (gm !! e)) emp (ea !! e_out)); + }. + +#[global] Instance flow_eq_instance `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!Protocol} : FlowEq := {}. + +Class FlowEqWOProt `{CMRA Σ} `{!invGS_gen HasNoLc Σ} := { + (* the version without mentioning protocols *) + flow_eq_ea_wo_prot (s_ob : gset Eid) + (e : Eid) (gm : mea Σ) (ea: sra Σ) (R: iProp Σ) : iProp Σ := + "R_in" ∷ ([∗ map] _ ↦ R_in ∈ gm, R_in) + ={⊤,∅}=∗ ▷ |={∅,⊤}=> + "R" ∷ R ∗ + "R_out" ∷ ([∗ set] e_out ∈ s_ob, + from_option (λ gm, from_option id emp (gm !! e)) emp (ea !! e_out)) + }. + +#[global] Instance flow_eq_final_instance `{CMRA Σ} `{!invGS_gen HasNoLc Σ} : FlowEqWOProt := {}. + +(** Ob-edge Annotation *) + +Class EdgeAnnot `{FlowEq} := + { + ea_lob_wf (gr : Graph.t) (ea : sra Σ) (na : mea Σ) : iProp Σ:= + (* the map for each node is complete *) + "%Hea_dom_eq" ∷ ⌜dom ea = dom na⌝ ∗ + "%Hea_lob_wf" ∷ ([∗ map] e ↦ gm ∈ ea, ⌜dom gm ⊆ (Graph.lob_pred_of gr e)⌝) ∗ + "Hea_fe" ∷ ([∗ map] e ↦ R ∈ na, + from_option + (λ gm, + let s_obs := (Graph.obs_pred_of gr e) in + let s_lob := (Graph.lob_succ_of gr e) in + flow_eq_ea s_lob s_obs e gm ea R) emp (ea !! e) ); + (* This version is used for ob induction *) + ea_lob_wf_ind (gr : Graph.t) (ea : sra Σ) (na : mea Σ) : iProp Σ:= + (* the map for each node is complete *) + "%Hea_lob_wf" ∷ ([∗ map] e ↦ gm ∈ ea, ⌜dom gm ⊆ (Graph.lob_pred_of gr e)⌝) ∗ + "Hea_fe" ∷ ([∗ map] e ↦ gm ∈ ea, + from_option + (λ R, let s_obs := (Graph.obs_pred_of gr e) in + let s_lob := (Graph.lob_succ_of gr e) in + flow_eq_ea s_lob s_obs e gm ea R) emp (na !! e)); + }. + +#[global] Instance ea_instance `{FlowEq}: EdgeAnnot := {}. + +Class EdgeAnnotWOProt `{FlowEqWOProt}:= + { + ea_ob_wf (gr : Graph.t) (ea : sra Σ) (na : mea Σ) : iProp Σ := + "%Hea_dom_eq" ∷ ⌜dom ea = dom na⌝ ∗ + "%Hea_ob_wf" ∷ ([∗ map] e ↦ gm ∈ ea, ⌜dom gm ⊆ (Graph.ob_pred_of gr e)⌝) ∗ + "Hea_fe" ∷ ([∗ map] e ↦ R;gm ∈ na;ea, + let s_ob := (Graph.ob_succ_of gr e) in + flow_eq_ea_wo_prot s_ob e gm ea R); + ea_ob_wf_ind (gr : Graph.t) (ea : sra Σ) (na : mea Σ) : iProp Σ := + "%Hea_ob_wf" ∷ ([∗ map] e ↦ gm ∈ ea, ⌜dom gm ⊆ (Graph.ob_pred_of gr e)⌝) ∗ + "Hea_fe" ∷ ([∗ map] e ↦ gm ∈ ea, + from_option + (λ R, let s_ob := (Graph.ob_succ_of gr e) in + flow_eq_ea_wo_prot s_ob e gm ea R) emp (na !! e)); + }. + +#[global] Instance eawo_instance `{FlowEqWOProt}: EdgeAnnotWOProt := {}. + +End definition. + +Section lemma. + + (** about [na_at_progress] *) + Lemma na_at_progress_not_elem_of `{CMRA Σ} gr tid pg na: + na_at_progress gr tid pg na ⊢ + ⌜ThreadState.progress_to_node pg tid ∉ dom na⌝. + Proof. + iIntros "Hpg". rewrite /na_at_progress. iNamed "Hpg". + iPureIntro. + assert(G : ThreadState.progress_to_node pg tid ∉ LThreadStep.eids_from_init gr tid pg). + { unfold LThreadStep.eids_from_init. + rewrite elem_of_filter. + rewrite /ThreadState.progress_to_node /ThreadState.progress_of_node /=. + intros [Hpg _]. + by apply (ThreadState.progress_lt_refl_False pg). + } + rewrite -Hna_dom_eq in G. + rewrite elem_of_filter in G. + by contradict G. + Qed. + + Import Graph. + + Context `{Σ: !gFunctors}. + Context `{CMRA Σ}. + Context `{!invGS_gen HasNoLc Σ}. + + (* the version used in the induction proof is equivalent with the one used in the conclusion *) + Lemma ea_ob_wf_ind_equiv gr node_annot edge_annot: + ⌜dom edge_annot = dom node_annot ⌝ ∗ ea_ob_wf_ind gr edge_annot node_annot ⊣⊢ + ea_ob_wf gr edge_annot node_annot. + Proof. + iSplit. iIntros "[% H]". iNamed "H". iSplit. iPureIntro;done. + iSplit. iPureIntro;done. + rewrite big_sepM_sepM2_zip // big_sepM2_flip //. + iNamed 1. iSplit. iPureIntro;done. + iSplit. iPureIntro;done. + rewrite big_sepM_sepM2_zip // big_sepM2_flip //. + Qed. + + Context `{!Protocol}. + + (* the induction proof of FSL style phase two *) + Lemma ea_obs_saturation_aux gr node_annot edge_annot: + NMSWF.wf gr -> + AAConsistent.t gr -> + dom edge_annot = Candidate.valid_eid gr -> + dom edge_annot = dom node_annot -> + forall edge_annot_last, + ob_semi_last_set gr (dom edge_annot_last) (dom edge_annot) -> + edge_annot_last ⊆ edge_annot -> + ea_lob_wf_ind gr edge_annot_last node_annot -∗ + (ea_ob_wf_ind gr + (map_imap (λ e gm, Some ((set_fold (λ e' acc, <[e' := (□(prot_node e'))%I]>acc) ∅ + (obs_pred_of gr e)) ∪ gm)) edge_annot_last) node_annot). + Proof. + intros Hwf Hcs Hea_full Hea_dom_eq. + match goal with + | [ |- forall x, ?G ] => + set (P := (λ (X : gset Eid), forall (x: sra Σ), dom x = X -> G)) + end. + intros eal Heal_last Heal_sub. + eapply (ob_set_ind_L gr (dom edge_annot) P Hcs). + { + rewrite Hea_full //. + } + { + clear eal Heal_last Heal_sub. + rewrite /P. intros eal Heal_dom Heal_last Heal_sub. + iIntros "Hea". iNamed "Hea". + iSplit; apply dom_empty_inv_L in Heal_dom; subst eal; rewrite map_imap_empty; + rewrite big_sepM_empty //. rewrite big_sepM_empty //. + } + { + clear eal Heal_last Heal_sub. + intros ef sl Hef_nv Hef_elem Hsl_last Hef_first IHsl. rewrite /P in IHsl. + rewrite /P /=. + intros eal Heal_dom Heal_last Heal_sub. iIntros "Hea". iNamed "Hea". + + (* split FEs into current FE and the rest *) + assert (is_Some (eal !! ef)) as [gmf Heal_lk]. + { apply elem_of_dom. rewrite Heal_dom. set_solver +. } + assert (<[ef := gmf]> eal = eal) as Heal_ins by rewrite insert_id //. + rewrite -{2}Heal_ins. clear Heal_ins. + rewrite big_sepM_insert_delete. iDestruct "Hea_fe" as "[FE Hea_fe]". + assert (is_Some (node_annot !! ef)) as [R Hna_lk]. + { apply elem_of_dom. rewrite -Hea_dom_eq. set_solver + Hef_elem. } + rewrite Hna_lk /=. + + (* apply IH *) + assert (dom (delete ef eal) = sl) as Hsl_dom. + { rewrite dom_delete_L Heal_dom. set_solver + Hef_nv. } + + specialize (IHsl (delete ef eal)). feed specialize IHsl. + exact Hsl_dom. + rewrite Hsl_dom. destruct Hsl_last;done. + etransitivity;last exact Heal_sub. apply delete_subseteq. + iDestruct (IHsl with "[Hea_fe]") as "IH". + { + iSplit. { iPureIntro. by apply map_Forall_delete. } + iApply (big_sepM_impl with "Hea_fe"). + iModIntro. iIntros (e gm Hea_lk_e). + iIntros "FE". destruct (decide (is_Some (node_annot !! e))) as [[R_e ->]|Hn];simpl. + 2:{ + assert (node_annot !! e = None) as ->;auto. + apply not_elem_of_dom. intro. apply Hn. by apply elem_of_dom. + } + iIntros "R_in". iDestruct ("FE" with "[R_in]") as ">R_e". done. + iModIntro. iNext. iMod "R_e". + iNamed "R_e". iModIntro. iFrame "R_na R_obs_out". + iApply (big_sepS_impl with "R_lob_out"). + iModIntro. iIntros (? Hx_lob). + { + (* x ≠ ef *) + rewrite lookup_delete_ne;auto. + destruct (decide (x ∈ sl)) as [Hx_in | Hx_nin]. set_solver + Hx_in Hsl_dom. + assert (x ∈ dom edge_annot) as Hx_in_all. + { rewrite Hea_full. pose proof (elem_of_lob_succ_of_valid _ _ _ Hwf Hx_lob) as Hsub. set_solver + Hsub. } + destruct Hsl_last as [_ Hsl_last]. + specialize (Hsl_last e). feed specialize Hsl_last. + apply elem_of_dom_2 in Hea_lk_e. rewrite Hsl_dom // in Hea_lk_e. + simpl in Hsl_last. exfalso. eapply (Hsl_last x). set_solver + Hx_nin Hx_in_all. + apply elem_of_ob_pred_of. + rewrite elem_of_ob_pred_of_succ. eapply lob_succ_of_subseteq_ob;eauto. + } + } + iSplit. + { + iPureIntro. intros x gm Hlk. specialize (Hea_lob_wf x). + rewrite map_lookup_imap in Hlk. destruct (eal !! x);inversion Hlk. + specialize (Hea_lob_wf g). feed specialize Hea_lob_wf. done. + rewrite dom_union_L. rewrite (set_fold_to_gmap_dom (obs_pred_of gr x) (λ e, (□ prot_node e)%I)). + pose proof (ob_pred_of_disj_union gr x Hwf Hcs) as [Hsub _]. + etrans. 2:exact Hsub. + apply union_subseteq. + split. apply union_subseteq_r'. set_solver +. apply union_subseteq_l'. set_solver + Hea_lob_wf. + } + (* split FE of ef from the goal *) + rewrite -{4}(insert_delete eal ef gmf);auto. + rewrite map_imap_insert. rewrite map_imap_delete. + rewrite big_sepM_insert_delete. rewrite delete_idemp. + (* show FE of ef and the rest separately *) + iSplitL "FE". + { (* FE *) + rewrite Hna_lk /=. iIntros "R_in". + iDestruct ("FE" with "[R_in]") as ">R_out". + { (* show we have all R_in (sth. about set_fold)*) + rewrite big_sepM_union. iDestruct "R_in" as "[R_obs_in $]". + 2:{ + apply map_disjoint_dom. rewrite set_fold_to_gmap_dom. + specialize (Hea_lob_wf ef gmf Heal_lk). + pose proof (ob_pred_of_disj_union gr ef Hwf Hcs) as [_ Hdisj_lob_obs]. + set_solver + Hdisj_lob_obs Hea_lob_wf. + } + rewrite big_sepS_fold_to_gmap. + iDestruct "R_obs_in" as "#R_obs_in". + iModIntro. + iApply (big_sepS_impl with "R_obs_in"). + iModIntro. iIntros (??) "#R". iFrame "R". + } + iModIntro. iNext. iMod "R_out". iModIntro. + iNamed "R_out". iFrame. + + (* split the goal into lob and obs preds *) + + pose proof (ob_succ_of_disj_union gr ef Hwf Hcs) as [Hob_succ_sub Hdisj_lob_obs]. + pose proof (union_split_difference_intersection_subseteq_L (ob_succ_of gr ef) (lob_succ_of gr ef ∪ obs_succ_of gr ef)) as [-> Hdisj_lob_obs']. + set_solver + Hob_succ_sub. + (* pose proof (ob_succ_of_disj_union gr ef Hwf) as [-> Hdisj_lob_obs]. *) + rewrite big_sepS_union;auto. + iSplitR. + { + iApply big_sepS_impl. + iApply big_sepS_emp. auto. + iModIntro. iIntros (x Hlk) "_". + rewrite map_lookup_imap. + destruct (eal !! x) eqn:Hlk_eal. simpl. + 2:{ simpl. auto. } + rewrite lookup_union_r;auto. + apply Hea_lob_wf in Hlk_eal. + destruct (g !! ef) eqn:Hg. + apply elem_of_dom_2 in Hg. + assert (x ∉ lob_succ_of gr ef). apply elem_of_difference in Hlk. destruct Hlk as [_ Hnotin]. + apply not_elem_of_union in Hnotin. destruct Hnotin;assumption. + assert (ef ∈ lob_pred_of gr x). set_solver + Hg Hlk_eal. + apply elem_of_lob_pred_of_succ in H2. contradiction. + rewrite Hg. auto. + apply not_elem_of_dom. + rewrite (set_fold_to_gmap_dom (obs_pred_of gr x) (λ e, (□ prot_node e)%I)). + intro Hlk'. apply elem_of_obs_pred_of_succ in Hlk'. + apply elem_of_difference in Hlk. + destruct Hlk as [_ Hnotin]. + apply not_elem_of_union in Hnotin. destruct Hnotin;contradiction. + } + rewrite big_sepS_union;auto. + iSplitL. + { (* lob *) + iApply (big_sepS_impl with "R_lob_out"). + iModIntro. iIntros (x Hlk) "R". + rewrite map_lookup_imap. + destruct (eal !! x);last done. + simpl. rewrite lookup_union_r;auto. + apply not_elem_of_dom. + rewrite (set_fold_to_gmap_dom (obs_pred_of gr x) (λ e, (□ prot_node e)%I)). + intro Hlk'. apply elem_of_obs_pred_of_succ in Hlk'. + apply (Hdisj_lob_obs x Hlk Hlk'). + } + { (* obs: use prot_node ef *) + iApply (big_sepS_impl). iApply big_sepS_emp. done. + iModIntro. iIntros (x Hlk) "_". + rewrite map_lookup_imap. + destruct (eal !! x) eqn:Hlk';simpl;last done. + rewrite lookup_union_l;auto. + rewrite set_fold_to_gmap_lookup. done. + by apply elem_of_obs_pred_of_succ. + apply not_elem_of_dom. + specialize (Hea_lob_wf x g Hlk'). intro Hin. simpl in Hea_lob_wf. specialize (Hea_lob_wf ef Hin). + rewrite elem_of_lob_pred_of_succ in Hea_lob_wf. + apply (Hdisj_lob_obs x Hea_lob_wf Hlk). + } + symmetry. apply disjoint_difference_r1. reflexivity. + } + { (* rest *) + iNamed "IH". + iApply (big_sepM_impl with "Hea_fe"). + iModIntro. iIntros (e gm Hlk) "FE". + + destruct (decide (is_Some (node_annot !! e))) as [[R_e ->]|Hn];simpl. + 2:{ + assert (node_annot !! e = None) as ->;auto. + apply not_elem_of_dom. intro. apply Hn. by apply elem_of_dom. + } + + iIntros "R_in_e". iMod ("FE" with "R_in_e") as "R_out_e". + iModIntro. iNext. iMod "R_out_e". iModIntro. + iNamed "R_out_e". iFrame. + iApply (big_sepS_impl with "R_out"). + iModIntro. iIntros (x Hx_ob) "R_out". + rewrite lookup_delete_ne. done. + { + (* x ≠ ef *) + destruct (decide (x ∈ sl)) as [Hx_in | Hx_nin]. set_solver + Hx_in Hsl_dom. + assert (x ∈ dom edge_annot) as Hx_in_all. + { rewrite Hea_full. pose proof (elem_of_ob_succ_of_valid _ _ _ Hwf Hx_ob) as Hsub. set_solver + Hsub. } + destruct Hsl_last as [_ Hsl_last]. + specialize (Hsl_last e). feed specialize Hsl_last. + rewrite lookup_delete_Some in Hlk. destruct Hlk as [Hneq Hlk]. + rewrite map_lookup_imap in Hlk. + destruct (eal !! e) eqn:Heal_lk_e;inversion Hlk. + apply elem_of_dom_2 in Heal_lk_e. + set_solver + Heal_lk_e Hneq Hsl_dom. + simpl in Hsl_last. exfalso. eapply (Hsl_last x). set_solver + Hx_nin Hx_in_all. + apply elem_of_ob_pred_of. + rewrite elem_of_ob_pred_of_succ //. + } + } + } + 2:{ exact Heal_last. } + { by apply subseteq_dom. } + { reflexivity. } + { done. } + { done. } + Qed. + + (* instantiate the induction proof above with [edge_annot] *) + Lemma ea_obs_saturation_aux2 gr node_annot edge_annot: + NMSWF.wf gr -> + AAConsistent.t gr -> + dom edge_annot = Candidate.valid_eid gr -> + dom edge_annot = dom node_annot -> + ea_lob_wf_ind gr edge_annot node_annot -∗ + (ea_ob_wf_ind gr + (map_imap (λ e gm, Some ((set_fold (λ e' acc, <[e' := (□(prot_node e'))%I]>acc) ∅ + (obs_pred_of gr e)) ∪ gm)) edge_annot) node_annot). + Proof. + intros. eapply ea_obs_saturation_aux;eauto. + intros ? ?. rewrite difference_diag_L //. + Qed. + + (* convert to the induction version *) + Lemma ea_lob_wf_impl_ind gr node_annot edge_annot: + ea_lob_wf gr edge_annot node_annot -∗ + ea_lob_wf_ind gr edge_annot node_annot ∗ ⌜dom edge_annot = dom node_annot ⌝. + Proof. + iNamed 1. iSplit;[|done]. iSplit. iPureIntro;done. + rewrite big_sepM_sepM2_zip // big_sepM_sepM2_zip //. + rewrite big_sepM2_flip //. + Qed. + + (* extend [node_annot] and [edge_annot] with initial nodes, first thing to do in phase-2 *) + Lemma ea_init_extend gr node_annot edge_annot: + NMSWF.wf gr -> + AAConsistent.t gr -> + "%Hna_full" ∷ na_full gr node_annot -∗ + "Hea" ∷ ea_lob_wf gr edge_annot node_annot -∗ + "#R_init" ∷ ([∗ set] e ∈ Candidate.initials gr, □ prot_node e) -∗ + let node_annot' := (gset_to_gmap True%I (Candidate.initials gr) ∪ node_annot) in + "%Hna_full" ∷ ⌜dom node_annot' = Candidate.valid_eid gr ⌝ ∗ + "Hea" ∷ ea_lob_wf gr (gset_to_gmap ∅ (Candidate.initials gr) ∪ edge_annot) node_annot'. + Proof. + iIntros (Hwf Hcs). repeat iNamed 1. + iSplit. + { + rewrite dom_union_L Hna_full. rewrite dom_gset_to_gmap. + iPureIntro. pose proof (Candidate.valid_eid_disjoint_union gr) as [? _];done. + } + { + iNamed "Hea". iSplit. + { iPureIntro. rewrite 2!dom_union_L. rewrite 2!dom_gset_to_gmap. rewrite Hea_dom_eq //. } + iSplit. + { + iPureIntro. intros e gm Hlk. + rewrite lookup_union_Some in Hlk. destruct Hlk as [Hlk|Hlk]. + rewrite lookup_gset_to_gmap_Some in Hlk. destruct Hlk as [_ <-]. set_solver +. + specialize (Hea_lob_wf e gm Hlk). set_solver + Hea_lob_wf. + apply map_disjoint_dom. rewrite dom_gset_to_gmap. rewrite Hea_dom_eq Hna_full. + pose proof (Candidate.valid_eid_disjoint_union gr) as [_ ?];done. + } + rewrite big_sepM_union. + 2: { + apply map_disjoint_dom. rewrite dom_gset_to_gmap. rewrite Hna_full. + pose proof (Candidate.valid_eid_disjoint_union gr) as [_ ?];done. + } + iSplitR. + { + rewrite big_sepM_gset_to_gmap. + iApply (big_sepS_impl with "R_init"). + iModIntro. iIntros (??) "R". + rewrite lookup_union_l. rewrite lookup_gset_to_gmap. case_option_guard;last done;simpl. + iIntros "[_ _]". + iApply step_fupd_intro;auto. iFrame "R". + iSplitL;first done. + rewrite no_lob_succ_initial //. by rewrite big_sepS_empty. + apply not_elem_of_dom. rewrite Hea_dom_eq Hna_full. + pose proof (Candidate.valid_eid_disjoint_union gr) as [_ Hdisj]. set_solver. + } + { + iApply (big_sepM_impl with "Hea_fe"). + iModIntro. iIntros (x R Hna_lk_x) "R". + rewrite lookup_union_r. + 2:{ + apply not_elem_of_dom. rewrite dom_gset_to_gmap. + apply elem_of_dom_2 in Hna_lk_x. rewrite Hna_full in Hna_lk_x. + pose proof (Candidate.valid_eid_disjoint_union gr) as [_ Hdisj]. set_solver + Hdisj Hna_lk_x. + } + destruct (decide (is_Some (edge_annot !! x))) as [[gm ->]|Hn];simpl. + 2:{ + assert (edge_annot !! x = None) as ->;auto. + apply not_elem_of_dom. intro. apply Hn. by apply elem_of_dom. + } + + iNamed 1. iDestruct ("R" with "[$R_lob_in $R_obs_in]") as ">R_out". + iModIntro. iNext. iMod "R_out". iModIntro. iNamed "R_out". + iFrame "R_na R_obs_out". + iApply (big_sepS_impl with "R_lob_out"). + iModIntro. iIntros (? Hin_x'). + rewrite lookup_union_r. iIntros "$". + apply not_elem_of_dom. rewrite dom_gset_to_gmap. + apply elem_of_dom_2 in Hna_lk_x. rewrite Hna_full in Hna_lk_x. + pose proof (Candidate.valid_eid_disjoint_union gr) as [_ Hdisj]. + apply (lob_same_thd) in Hin_x';auto. + set_solver + Hin_x' Hdisj. + } + } + Qed. + +End lemma. diff --git a/theories/low/lib/edge.v b/theories/low/lib/edge.v new file mode 100644 index 0000000..827b363 --- /dev/null +++ b/theories/low/lib/edge.v @@ -0,0 +1,337 @@ +(* This file contains the resource construction for edges *) +From SSCCommon Require Import Common. +From iris.base_logic Require Import iprop. + +From self Require Import stdpp_extra. + +From self.algebra Require Import base. + +Module Edge. + (* Edge *) + + Inductive bn := W (ks : AccessStrength) (kv : AccessVariety) | R (ks : AccessStrength) (kv : AccessVariety) | B ( bκ : BarrierKind). + Inductive t := Po | Addr | Data | Ctrl |Rf | Co | Rmw | Fr | Node (bn : bn) | + Obs | Lob | Ob. + + Import AACandExec. + + Definition ef_node_interp (gr : Graph.t) (bn : bn) (e : Eid) : Prop := + ∃ E, gr !! e = Some E + ∧ match bn with + | W ks kv => AAConsistent.event_is_write_with_kind E ks kv + | R ks kv => AAConsistent.event_is_read_with_kind E ks kv + | B (AAArch.DMB κ) => AAConsistent.event_is_dmb κ E + | B AAArch.ISB => AAConsistent.event_is_isb E + end. + + #[global] Hint Unfold ef_node_interp : core. + + Definition ef_edge_interp (gr : Graph.t) (be : t) (e e' : Eid) : Prop := + match be with + | Po => (e,e') ∈ (Candidate.po gr) + | Addr => (e,e') ∈ (Candidate.addr gr) + | Data => (e,e') ∈ (Candidate.data gr) + | Ctrl => (e,e') ∈ (Candidate.ctrl gr) + | Rf => (e,e') ∈ (Candidate.rf gr) + | Co => (e,e') ∈ (Candidate.co gr) + | Rmw => (e,e') ∈ (Candidate.rmw gr) + | Fr => (e, e') ∈ (Candidate.fr gr) + | Node bn => e = e' ∧ ef_node_interp gr bn e + | Lob => (e,e') ∈ (AAConsistent.lob gr) + | Obs => (e,e') ∈ (AAConsistent.obs gr) + | Ob => (e,e') ∈ (AAConsistent.ob gr) + end. + + #[global] Hint Unfold ef_node_interp : core. + #[global] Hint Unfold ef_edge_interp : core. + + (** Some pure lemmas about [ef_edge_interp]*) + Lemma subseteq_lob {gr s e} : + set_Forall (λ x : Eid, ef_edge_interp gr Edge.Lob x e) s -> + s ⊆ Graph.lob_pred_of gr e. + Proof. + intro Hlob. + rewrite /Graph.lob_pred_of. + assert (Hsub : GRel.grel_dom (CSets.gset_product s {[e]}) + ⊆ GRel.grel_dom (filter (λ '(_, et), et = e) (AAConsistent.lob gr))). + { + assert (Hsub : (CSets.gset_product s {[e]}) + ⊆ (filter (λ '(_, et), et = e) (AAConsistent.lob gr))). + { + transitivity (filter (λ '(_, et), et = e) (CSets.gset_product s {[e]})). + intros ? Hin. rewrite elem_of_filter. split. + apply CSets.gset_product_spec in Hin. + destruct Hin as [Hin1 Hin2]. destruct x. set_solver + Hin2. done. + apply stdpp_extra.set_filter_subseteq. + intros ? Hin. apply CSets.gset_product_spec in Hin. destruct Hin as [Hin1 Hin2]. + specialize (Hlob x.1 Hin1). simpl in Hlob. + apply elem_of_singleton in Hin2. destruct x. subst. simpl in Hlob. done. + } + rewrite /GRel.grel_dom. apply set_map_mono. done. set_solver + Hsub. + } + etransitivity;last exact Hsub. set_solver +. + Qed. + +End Edge. + +Section def. + Context `{AABaseG Σ}. + + Import AACandExec. + + Definition edge_def (ef : Edge.t) (e e' : Eid) : iProp Σ := + ∃ gr, "Hgr_interp_e" ∷ graph_agree gr ∗ + "%Hgr_wf_e" ∷ ⌜ AAConsistent.t gr ⌝ ∗ + "%Hgr_cs_e" ∷ ⌜ AACandExec.NMSWF.wf gr ⌝ ∗ + "%Hedge_interp" ∷ ⌜Edge.ef_edge_interp gr ef e e'⌝. + + Definition edge_def_aux : seal (@edge_def). Proof. by eexists. Qed. + Definition edge := edge_def_aux.(unseal). + Definition edge_eq : @edge = @edge_def := edge_def_aux.(seal_eq). + + Definition node_def e (n : Edge.bn): iProp Σ := edge ((Edge.Node n)) e e. + Definition node_def_aux : seal (@node_def). Proof. by eexists. Qed. + Definition node := node_def_aux.(unseal). + Definition node_eq : @node = @node_def := node_def_aux.(seal_eq). +End def. + +Notation "n1 -{ r }> n2" := + (edge r n1 n2) (at level 21, r at level 50, format "n1 -{ r }> n2") : bi_scope. + +Notation "n '-{N}>' e " := + (node n e) (at level 21, e at level 50, format "n '-{N}>' e") : bi_scope. + +Section lemmas. + Context `{CMRA Σ} `{!AABaseG}. + + #[global] Instance edge_def_persist r n1 n2 : Persistent(edge r n1 n2). + Proof. rewrite edge_eq. rewrite /edge_def. apply _. Qed. + + #[global] Instance node_def_persist e n : Persistent(node e n). + Proof. rewrite node_eq. rewrite /node_def. apply _. Qed. + + (* edge prompte/demote lemmas *) + Lemma acq_po_is_lob a b : + a -{N}> Edge.R AS_rel_or_acq AV_plain -∗ + a -{Edge.Po}> b -∗ + a -{Edge.Lob}> b. + Proof. + rewrite node_eq /node_def edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iIntros "[% (Hg2&%&%&%)]". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. + apply Graph.acq_po_subseteq_lob. + 2:{ assumption. } + rewrite /AAConsistent.acq_reads. + destruct H3 as [_ [? [Hlk He]]]. + set_unfold. eexists;eauto. split;first eassumption. + eapply AAConsistent.event_is_read_with_P_impl;last eassumption. + intros. naive_solver. + Qed. + + Lemma po_rel_is_lob a b kind_s: + a -{Edge.Po}> b -∗ + b -{N}> Edge.W AS_rel_or_acq kind_s -∗ + a -{Edge.Lob}> b. + Proof. + rewrite node_eq /node_def edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iIntros "[% (Hg2&%&%&%)]". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. + apply Graph.po_rel_subseteq_lob. done. + rewrite /AAConsistent.acq_reads. + destruct H6 as [_ [? [Hlk He]]]. + set_unfold. eexists. + split;first eassumption. + rewrite /AAConsistent.event_is_rel. + rewrite /AAConsistent.event_is_write_with_kind in He. + eapply AAConsistent.event_is_write_with_P_impl;[|eassumption]. + simpl. intros. + rewrite /AACandExec.Candidate.kind_of_wreq_P. + rewrite /AACandExec.Candidate.kind_of_wreq_P in H6. + destruct (AAInter.WriteReq.access_kind wreq );try contradiction. + case_bool_decide. + rewrite H7. simpl. done. + contradiction. + Qed. + + Lemma addr_is_lob a b : + a -{Edge.Addr}> b -∗ + a -{Edge.Lob}> b. + Proof. + rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. + simpl in H3. apply Graph.addr_subseteq_lob;done. + Qed. + + Lemma data_is_lob a b : + a -{Edge.Data}> b -∗ + a -{Edge.Lob}> b. + Proof. + rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. + simpl in H3. apply Graph.data_subseteq_lob;done. + Qed. + + Lemma lob_is_ob a b: + a -{Edge.Lob}> b -∗ + a -{Edge.Ob}> b. + Proof. + rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. + simpl in H3. apply Graph.lob_subseteq_ob;done. + Qed. + + Lemma rf_co_to_fr a b c : + a -{Edge.Rf}> b -∗ + a -{Edge.Co}> c -∗ + b -{Edge.Fr}> c. + Proof. + rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iIntros "[% (Hg2&%&%&%)]". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. set_solver + H3 H6. + Qed. + + Lemma fre_is_ob a b: + EID.tid a ≠ EID.tid b -> + a -{Edge.Fr}> b -∗ + a -{Edge.Ob}> b. + Proof. + rewrite edge_eq /edge_def. + iIntros (?) "[% (Hg1&%&%&%)]". + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. apply Graph.fre_subseteq_ob;done. + Qed. + + Lemma rfe_is_ob a b: + EID.tid a ≠ EID.tid b -> + a -{Edge.Rf}> b -∗ + a -{Edge.Ob}> b. + Proof. + rewrite edge_eq /edge_def. + iIntros (?) "[% (Hg1&%&%&%)]". + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. apply Graph.rfe_subseteq_ob;done. + Qed. + + Lemma po_dmbsy_po_is_lob a b c: + a -{Edge.Po}> b -∗ + b -{N}> (Edge.B (AAArch.DMB AAArch.Sy)) -∗ + b -{Edge.Po}> c -∗ + a -{Edge.Lob}> c. + Proof. + rewrite node_eq /node_def. rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)] [% (Hg2&%&%&_&%)] [% (Hg3&%&%&%)]". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iDestruct (graph_agree_agree with "Hg1 Hg3") as %->. + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl in *. apply (Graph.po_dmbsy_po_subseteq_lob _ a b c). + done. + rewrite /Edge.ef_node_interp in H6. + rewrite /AAConsistent.dmbs. destruct H6 as [? [Hlk He]]. + set_unfold. eexists;eauto. + done. + Qed. + + Lemma ctrl_w_is_lob a b ak av: + b -{N}> Edge.W ak av -∗ + a -{Edge.Ctrl}> b -∗ + a -{Edge.Lob}> b. + Proof. + rewrite node_eq /node_def edge_eq /edge_def. + iIntros "[% (Hg1&%&%&_&%)] [% (Hg2&%&%&%)]". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iExists _. iFrame. iSplit; first (iPureIntro;assumption). iSplit; first (iPureIntro;assumption). + iPureIntro. simpl in H3,H6. simpl. apply (Graph.ctrl_w_subseteq_lob _ a b). + + done. + + destruct H3 as [? [Hlk He]]. + unfold AAConsistent.event_is_write_with_kind, AAConsistent.event_is_write_with_P in He. + destruct x. destruct o; try (exfalso; assumption). + clear -Hlk. set_unfold. repeat eexists. rewrite Hlk. reflexivity. + Qed. + + Lemma ctrl_isb_po_is_lob a b c ak1 av1 ak2 av2: + a -{N}> Edge.R ak1 av1 -∗ + b -{N}> Edge.B AAArch.ISB -∗ + c -{N}> Edge.R ak2 av2 -∗ + a -{Edge.Ctrl}> b -∗ + b -{Edge.Po}> c -∗ + a -{Edge.Lob}> c. + Proof. + rewrite node_eq /node_def edge_eq /edge_def. + iIntros "[% (Hg1&%&%&_&%)] [% (Hg2&%&%&_&%)] [% (Hg3&%&%&%)] [% (Hg4&%&%&%)] [% (Hg5&%&%&%)]". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iDestruct (graph_agree_agree with "Hg1 Hg3") as %->. + iDestruct (graph_agree_agree with "Hg1 Hg4") as %->. + iDestruct (graph_agree_agree with "Hg1 Hg5") as %->. + iExists _. iFrame. iSplit; first done. iSplit; first done. + iPureIntro. simpl in *. apply (Graph.ctrl_isb_po_subseteq_lob _ a b c). + + done. + + unfold AAConsistent.isbs. destruct H6 as [? [Hlk He]]. + set_unfold. hauto lq: on rew: off. + + done. + + destruct H9 as [_ [? [Hlk He]]]. + unfold AAConsistent.event_is_read_with_kind, AAConsistent.event_is_read_with_P in He. + destruct x. + destruct o; try (exfalso; assumption). + set_unfold. repeat eexists. rewrite Hlk. reflexivity. + Qed. + + Lemma ob_trans a b c: + a -{Edge.Ob}> b -∗ + b -{Edge.Ob}> c -∗ + a -{Edge.Ob}> c. + Proof. + rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iIntros "[% (Hg2&%&%&%)]". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. + rewrite /AAConsistent.ob. + eapply GRel.grel_plus_trans;done. + Qed. + + Lemma ob_acyclic a: + a -{Edge.Ob}> a -∗ False. + Proof. + rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iPureIntro. eapply Graph.ob_acyclic;done. + Qed. + + Lemma po_trans a b c: + a -{Edge.Po}> b -∗ + b -{Edge.Po}> c -∗ + a -{Edge.Po}> c. + Proof. + rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iIntros "[% (Hg2&%&%&%)]". + iDestruct (graph_agree_agree with "Hg1 Hg2") as %->. + iExists _. iFrame. iSplit;first done. iSplit;first done. + iPureIntro. simpl. eapply Graph.po_transitive;done. + Qed. + + Lemma po_irrefl a: + a -{Edge.Po}> a -∗ False. + Proof. + rewrite edge_eq /edge_def. + iIntros "[% (Hg1&%&%&%)]". + iPureIntro. eapply Graph.po_irreflexive;done. + Qed. + +End lemmas. diff --git a/theories/low/lib/event.v b/theories/low/lib/event.v new file mode 100644 index 0000000..6e64be5 --- /dev/null +++ b/theories/low/lib/event.v @@ -0,0 +1,179 @@ +Require Import stdpp.unstable.bitvector. + +From SSCCommon Require Import Common. +From iris.base_logic Require Import iprop. + +From self Require Import stdpp_extra. + +From self.algebra Require Import base. +From self.low.lib Require Import edge. + +Module Event. + (* Event *) + + Inductive t := W (ks : AccessStrength) (ks : AccessVariety) (a : Addr) (v : Val) | R (ks : AccessStrength) (ks : AccessVariety) (a : Addr) (v : Val) | + B (bκ : BarrierKind). + + Import AACandExec. + + Definition event_interp (gr : Graph.t) (ev : t) (e : Eid) : Prop := + ∃ E, gr !! e = Some E + ∧ match ev with + | W ks kv a v => AAConsistent.event_is_write_with E ks kv a v + | R ks kv a v => AAConsistent.event_is_read_with E ks kv a v + | B (AAArch.DMB κ) => AAConsistent.event_is_dmb κ E + | B AAArch.ISB => AAConsistent.event_is_isb E + end. + +End Event. + +Section def. + Context `{AABaseG Σ}. + + Import AACandExec. + + Definition event_def (e : Eid) (ev : Event.t): iProp Σ := + ∃ gr, "Hgr_interp_e" ∷ graph_agree gr ∗ + "%Hgr_wf_e" ∷ ⌜ AAConsistent.t gr ⌝ ∗ + "%Hgr_cs_e" ∷ ⌜ AACandExec.NMSWF.wf gr ⌝ ∗ + "%Hedge_interp" ∷ ⌜Event.event_interp gr ev e⌝. + + Definition event_def_aux : seal (@event_def). Proof. by eexists. Qed. + Definition event := event_def_aux.(unseal). + Definition event_eq : @event = @event_def := event_def_aux.(seal_eq). + +End def. + +Notation "e '-{E}>' E" := + (event e E) (at level 21, E at level 50, format "e '-{E}>' E") : bi_scope. + +Section lemmas. + Context `{CMRA Σ} `{!AABaseG}. + + #[global] Instance event_def_persist e E : Persistent(event e E). + Proof. rewrite event_eq. rewrite /event_def. apply _. Qed. + + Lemma initial_write_zero a addr v k x: + EID.tid a = 0%nat -> + a -{E}> Event.W k x addr v -∗ + (⌜(BV 64 0) = v⌝). + Proof. + rewrite event_eq /event_def. + iIntros (?) "[% (_&%Hcons&%Hwf&%He)] !%". + symmetry. + unfold Event.event_interp in He. + destruct He as [e [G1 G2]]. + apply (Graph.init_zero gr a) => //. + exists e, addr, k, x => //. + Qed. + + Lemma initial_write_co a b addr v v' k k' x x': + EID.tid a = 0%nat -> + EID.tid b ≠ 0%nat -> + a -{E}> Event.W k x addr v -∗ + b -{E}> Event.W k' x' addr v' -∗ + a -{Edge.Co}> b. + Proof. + rewrite event_eq /event_def. + rewrite edge_eq /edge_def. + iIntros (??) "[% (Hag1&%Hcons&%Hwf&%He)] [% (Hag2&_&_&%He')]". + iDestruct (graph_agree_agree with "Hag1 Hag2") as %<-. + iExists gr. iFrame "∗%". + iPureIntro. + simpl. + apply (Graph.init_co _ _ _ addr) => //. + { + unfold Event.event_interp in *. unfold AAConsistent.event_is_write_with_addr. destruct He as [e [G1 G2]]. exists e. split; [assumption|]. + apply AAConsistent.event_is_write_with_impl_addr in G2. exact G2. + } + unfold Event.event_interp in *. unfold AAConsistent.event_is_write_with_addr. destruct He' as [e [G1 G2]]. exists e. split; [assumption|]. + apply AAConsistent.event_is_write_with_impl_addr in G2. exact G2. + Qed. + + Lemma write_of_read a b addr v k x: + a -{E}> Event.R k x addr v -∗ + b -{Edge.Rf}> a -∗ + ∃ k' x', b -{E}> Event.W k' x' addr v. + Proof. + rewrite event_eq /event_def. + rewrite edge_eq /edge_def. + iIntros "[% (Hag1&%Hcons&%Hwf&%Hread)] [% (Hag2&_&_&%Hrf)]". + iDestruct (graph_agree_agree with "Hag1 Hag2") as %<-. + iAssert(∃k' x', ⌜Event.event_interp gr (Event.W k' x' addr v) b⌝)%I as "[%k' [%x' %Hwrite]]". + { iPureIntro. simpl. + unfold Event.event_interp. + destruct Hread as [e [G1 G2]]. + destruct (Graph.wf_read_inv gr a e addr k x v) as [e' [k' [x' [Ew [Hew [His_write Hrf']]]]]] => //. + assert(e'=b) as ->. + { + apply (Graph.wf_read_single gr _ _ a). + - assumption. + - assumption. + - unfold Edge.ef_edge_interp in Hrf. simpl. assumption. + } + exists k', x', Ew. + done. + } + iExists k', x', gr. + iFrame "∗%". + Qed. + + Lemma event_node eid E : + eid -{E}> E -∗ eid -{N}> (match E with + | Event.W ks kv _ _ => Edge.W ks kv + | Event.R ks kv _ _ => Edge.R ks kv + | Event.B bκ => Edge.B bκ + end). + Proof. + rewrite event_eq. rewrite /event_def. + rewrite node_eq. rewrite /node_def. + rewrite edge_eq. rewrite /edge_def. + iIntros "[% [Hag [% [% %HE]]]]". + iExists _. iFrame. iSplit; first done. iSplit; first done. + iPureIntro. simpl. split;first done. rewrite /Edge.ef_node_interp. + rewrite /Event.event_interp in HE. + destruct HE as [? [? ?]]. + eexists. split;first eauto. destruct E. + eapply AAConsistent.event_is_write_with_impl_kind;eauto. + eapply AAConsistent.event_is_read_with_impl_kind;eauto. + done. + Qed. + + Import AAConsistent. + + Lemma event_agree eid E E' : + eid -{E}> E -∗ eid -{E}> E' -∗ ⌜E = E'⌝. + Proof. + rewrite event_eq. rewrite /event_def. + iIntros "[% H1] [% [Hag [_ [_ %HE']]]]". iNamed "H1". + iDestruct (graph_agree_agree with "Hgr_interp_e Hag") as %->. iPureIntro. + + destruct HE' as [? [Hlk' HE']]. destruct Hedge_interp as [? [Hlk HE]]. rewrite Hlk in Hlk'. inversion Hlk'. subst x0. + clear Hgr_wf_e Hgr_cs_e. + destruct E, E'; + + repeat (match goal with + | [ HE: Is_true _ |- _ ] => rewrite -> bool_unfold in HE;destruct_and ? HE + | [HE : context [match ?x with _ => _ end] |- _ ] => destruct x eqn:?;try (by inversion HE) + | [ |- _ ] => unfold event_is_write_with in *; + unfold event_is_read_with in *; + unfold event_is_write_with_P in *; + unfold event_is_read_with_P in *; + unfold event_is_dmb in *; + unfold event_is_isb in *;simpl in * + end);unfold AACandExec.Candidate.kind_of_wreq_P in *; unfold AACandExec.Candidate.kind_of_rreq_P in *. + + all: repeat (match goal with + | [ HE: Is_true _ |- _ ] => rewrite -> bool_unfold in HE;destruct_and ? HE + | [HE : context [match ?x with _ => _ end] |- _ ] => destruct x eqn:?;try (by inversion HE) + | [HE : match ?x with _ => _ end = _|- _ ] => destruct x;try (by inversion HE) + | [HE : match (decide ?x) with _ => _ end = _ |- _ ] => destruct (decide ?x) + | [HE : context[let _ := ?X in _] |- _ ] => destruct X + | [H1 : (@eq _ (?f ?x) _), H2 : (@eq _ (?f ?x) _) |- _ ] => rewrite H1 in H2;inversion H2 + end); subst;try done. + + inversion H1;done. + inversion H2;done. + Qed. + +End lemmas. diff --git a/theories/low/lifting.v b/theories/low/lifting.v new file mode 100644 index 0000000..da5c70e --- /dev/null +++ b/theories/low/lifting.v @@ -0,0 +1,457 @@ +From iris.proofmode Require Import tactics. + +From self.low Require Export weakestpre. +From self Require Export iris_extra stdpp_extra. +Import uPred. + +Section lifting. + Context `{CMRA Σ}. + Context `{!invGS_gen HasNoLc Σ}. + Context `{!irisG}. + Context `{!irisGL}. + Context `{!Protocol}. + Implicit Types s : LThreadState.t. + Implicit Types P Q : iProp Σ. + Implicit Types Φ : LThreadState.t → iProp Σ. + Implicit Types Φs : list (LThreadState.t → iProp Σ). + + Lemma step_fupd_mono P Q E1 E2: + (P -∗ Q) ⊢ (|={E1}[E2]▷=> P) -∗ |={E1}[E2]▷=> Q. + Proof. iIntros "Himp >P". iModIntro. iNext. by iApply "Himp". Qed. + + Lemma sswp_step gs tid s s' pg ls Φ : + let gr := gs.(GlobalState.gs_graph) in + AAConsistent.t gr -> + AACandExec.NMSWF.wf gr -> + LThreadStep.t gs tid s s' → + LThreadState.at_progress s pg -> + local_interp gs tid pg ls -∗ + (□ gconst_interp gs) -∗ + SSWP s @ tid {{ Φ }} -∗ + (if (bool_decide (ThreadState.progress_is_valid gr tid pg)) then + ∀ (na : mea Σ) (ea : sra Σ), + "#Hannot_at_prog" ∷ na_at_progress gr tid pg na ∗ + "Hea_wf" ∷ ea_lob_wf gr ea na ∗ + ("Hinterp_annot" ∷ annot_interp na) ==∗ + let e := (ThreadState.progress_to_node pg tid) in + let s_lob := (Graph.lob_pred_of gr e) in + let s_obs := (Graph.obs_pred_of gr e) in + ∃ (R: iProp Σ) (na_used na_unused : mea Σ) (ls' : log_ts_t), + "#Hna_split" ∷ na_splitting_wf s_lob na na_used na_unused ∗ + "Hinterp_annot" ∷ annot_interp ({[e := R]} ∪ na_unused ∪ na) ∗ + "Hea_wf" ∷ ea_lob_wf gr ({[e := na_used]} ∪ ea) ({[e := R]} ∪ na_unused ∪ na) ∗ + "Hinterp_local" ∷ local_interp gs tid (LThreadState.get_progress s') ls' ∗ + "Hwp" ∷ Φ s' + else |=i=> + ("Hinterp_local" ∷ local_interp gs tid (LThreadState.get_progress s') ls ∗ + "Hwp" ∷ Φ s')). + Proof. + iIntros (? Hgr_consist Hgr_wf Hstep Hpg) "Hls Hgs H". rewrite sswp_eq /sswp_def. + rewrite (LThreadStep.step_not_terminated gs tid s s') //. + iDestruct ("H" $! gs pg s' with "[$Hgs $Hls //]") as "H". + rewrite /gr. case_bool_decide;last done. + iIntros (??) "H'". iNamed "H'". + iMod ("H" $! na with "[$Hinterp_annot $Hannot_at_prog]") as "(%&%&%&%&(#Hna_split&FE)&?&?&?)". + iModIntro. iExists R, na_used, na_unused, ls'. iFrame "Hna_split". iFrame. + iNamed "Hna_split". iNamed "Hea_wf". iDestruct "Hannot_at_prog" as %Hna_dom_eq. + rewrite /ea_lob_wf. + iDestruct (big_sepM2_alt with "Hnau_wf") as "[%Hnau_dom_eq _]". + assert (dom na_used ⊆ dom na) as Hna_dom_sub. + { + assert (dom na_used ⊆ Graph.po_pred_of (GlobalState.gs_graph gs) (ThreadState.progress_to_node pg tid)) as Hsub. + { etransitivity;eauto. apply Graph.lob_pred_of_subseteq_po; done. } + rewrite LThreadStep.eids_from_init_po_pred_of in Hsub;auto. + rewrite -Hna_dom_eq in Hsub. etransitivity;eauto. set_solver +. + } + iSplit;[|iSplit]. + - iPureIntro. rewrite !dom_union_L. rewrite Hea_dom_eq -Hnau_dom_eq. set_solver + Hna_dom_sub. + - iPureIntro. apply map_Forall_union_2;auto. + apply map_Forall_singleton;auto. + - feed pose proof (map_difference_union_exists na_unused na) as Hna_split. + rewrite -Hnau_dom_eq. etransitivity;eauto. + destruct Hna_split as [na_lob (Hnal_sub & Hnal_dom_eq & Hna_split)]. + rewrite -{2}Hna_split. + rewrite big_sepM_union. + 2: { apply map_disjoint_dom. rewrite Hnal_dom_eq. set_solver +. } + iDestruct "Hea_fe" as "[Hea_fe_upd Hea_fe_same]". + rewrite -assoc. assert (na_unused ∪ na = na_unused ∪ (na ∖ na_unused)) as ->. + { + rewrite -{1}Hna_split. rewrite assoc. + assert (na_unused ∪ na_lob = na_unused) as ->. + { + apply map_eq. intros. destruct (na_unused !! i) eqn:Hlk. + rewrite lookup_union_l' //. + apply lookup_union_None. split;auto. apply not_elem_of_dom. rewrite Hnal_dom_eq. + apply not_elem_of_dom;auto. + } + done. + } + assert (ThreadState.progress_to_node pg tid ∉ dom na) as Hcurr_nin. + { + intro Hin. + assert (ThreadState.progress_to_node pg tid ∈ filter (Graph.is_local_node_of tid) (dom na)) as Hin'. + rewrite elem_of_filter. split;done. + rewrite Hna_dom_eq in Hin'. + rewrite elem_of_filter in Hin'. destruct Hin' as [Hin' _]. + rewrite /= ThreadState.progress_of_node_to_node in Hin'. + eapply ThreadState.progress_lt_refl_False;eauto. + } + rewrite assoc. rewrite (big_sepM_union _ _ (na ∖ na_unused)). + 2: { apply map_disjoint_dom. set_solver + Hcurr_nin. } + iSplitR "Hea_fe_same". + + (* the interesting case *) + rewrite big_sepM_union. rewrite big_sepM_singleton. + 2: { apply map_disjoint_dom. + epose proof (Graph.not_elem_of_lob_pred_of _ + (ThreadState.progress_to_node pg tid) Hgr_consist) as Hnin_lob. + set_solver + Hnin_lob Hnau_dom_sub Hnau_dom_eq. + } + iSplitL "FE". + * rewrite lookup_union_l';[|rewrite lookup_singleton //]. + rewrite lookup_singleton /=. + iIntros "R_in". iDestruct ("FE" with "[R_in]") as ">FE". + { + iNamed "R_in". iFrame "R_obs_in". iClear "R_obs_in Hnau_wf". clear Hnau_dom_eq. + iInduction (Graph.lob_pred_of (GlobalState.gs_graph gs) (ThreadState.progress_to_node pg tid)) + as [|e s_lob Hnin] "IH" using set_ind_L forall (na_used Hnau_dom_sub Hna_dom_sub) "R_lob_in". + - rewrite big_sepS_empty //. + - rewrite big_sepS_union;last set_solver + Hnin. + rewrite big_sepS_singleton. + destruct (na_used !! e) eqn:Hlk. + + rewrite -(insert_delete na_used e _ Hlk). + rewrite big_sepM_insert. 2:{ apply lookup_delete_None. left;done. } + iDestruct "R_lob_in" as "[$ R_lob_in]". + iSpecialize ("IH" $! (delete e na_used) with "[]"). + { iPureIntro. setoid_rewrite dom_delete. set_solver + Hlk Hnau_dom_sub. } + iSpecialize ("IH" with "[] R_lob_in"). + { iPureIntro. rewrite dom_delete. set_solver + Hna_dom_sub. } + iApply (big_sepS_impl with "IH"). + iModIntro. iIntros (e' Hin_e) "H". + rewrite lookup_delete_ne;[|set_solver + Hin_e Hnin]. + rewrite insert_delete //. + + iSpecialize ("IH" $! na_used with "[]"). + { iPureIntro. rewrite -not_elem_of_dom in Hlk. set_solver + Hlk Hnau_dom_sub. } + iSpecialize ("IH" with "[//] R_lob_in"). + by iFrame. + } + iModIntro. + { iNext. iMod "FE". iModIntro. + epose proof (Graph.not_elem_of_lob_succ_of _ + (ThreadState.progress_to_node pg tid) Hgr_consist) as Hnin_lob. rewrite /gr in Hnin_lob. + iInduction (Graph.lob_succ_of (GlobalState.gs_graph gs) (ThreadState.progress_to_node pg tid)) + as [|e s_lob Hnin] "IH" using set_ind_L. + - rewrite big_sepS_empty //. iDestruct "FE" as "[$ $]". + - rewrite big_sepS_union;last set_solver + Hnin. + rewrite big_sepS_singleton. + rewrite lookup_union_r. + 2: { apply lookup_singleton_None. set_solver + Hnin_lob. } + destruct (ea !! e) eqn:Hlk. + + (* We show contradiction by showing e1 -[po]> e2 and e2 -[po]> e1 *) + pose proof Hlk as Hea_lk. apply Hea_lob_wf in Hlk. + destruct (g !! (ThreadState.progress_to_node pg tid)) eqn:Hlk'. + exfalso. + assert ((ThreadState.progress_to_node pg tid) ∈ Graph.lob_pred_of (GlobalState.gs_graph gs) e) as Helem. + { apply mk_is_Some in Hlk'. apply elem_of_dom in Hlk'. set_solver + Hlk' Hlk. } + apply Graph.elem_of_lob_pred_of_po in Helem;auto. pose proof Helem as Hpo1. apply Graph.po_valid_eids in Helem. 2: assumption. + destruct Helem as [Hvalid' Htid]. + assert (ThreadState.progress_to_node pg tid ∈ Graph.local_eids (GlobalState.gs_graph gs) tid) as Hvalid + by set_solver + Hvalid'. + assert (e ∈ filter (Graph.is_local_node_of tid) (dom na)) as Hin. + { + apply elem_of_filter. split. simpl in Htid. done. rewrite -Hea_dom_eq. + apply mk_is_Some in Hea_lk. apply elem_of_dom in Hea_lk. + set_solver + Hvalid' Hea_lk. + } + pose proof (ThreadState.progress_lt_po gr tid (ThreadState.progress_of_node e) pg) as Hpo2. + feed specialize Hpo2;auto. destruct Hpo2 as [Hpo2 _]. + rewrite Hna_dom_eq in Hin. apply elem_of_filter in Hin. destruct Hin. + feed specialize Hpo2. split;auto. split. + rewrite /ThreadState.progress_is_valid ThreadState.progress_to_node_of_node;auto. set_solver + Hvalid'. + rewrite ThreadState.progress_to_node_of_node in Hpo2;auto. + eapply Graph.po_irreflexive;eauto. + rewrite /ThreadState.progress_is_valid ThreadState.progress_to_node_of_node;auto. + rewrite /= Hlk' //. + iDestruct ("IH" with "[] FE") as "[$ [$ $]]". iPureIntro. set_solver + Hnin_lob. done. + + iDestruct ("IH" with "[] FE") as "[$ [$ $]]". iPureIntro. set_solver + Hnin_lob. done. + } + * iInduction na_unused as [|e R_e_uu na_unused Hnin] "IH" using map_ind + forall (na_lob Hnal_sub Hnal_dom_eq Hna_split na_used Hnau_dom_sub Hnau_dom_eq Hna_dom_sub). + rewrite big_sepM_empty //. + assert (is_Some (na_lob !! e)) as [R_e Hna_lob_lk]. + { apply elem_of_dom. rewrite Hnal_dom_eq. set_solver + Hnal_dom_eq. } + assert (<[e := R_e]> (delete e na_lob) = na_lob) as <-. by apply insert_delete. + rewrite big_sepM_insert. 2:{ apply lookup_delete_None. left;done. } + rewrite big_sepM_insert //. + iDestruct ("Hea_fe_upd") as "[Hfe_e Hea_fe]". + iSplitL "Hfe_e". + { + rewrite lookup_union_r. + 2: { + rewrite lookup_singleton_None. intros <-. + eapply (Graph.not_elem_of_lob_pred_of _ (ThreadState.progress_to_node pg tid));eauto. + rewrite Hnau_dom_eq in Hnau_dom_sub. set_solver + Hnau_dom_sub. + } + destruct (decide (is_Some (ea !! e))) as [[gm ->]|Hn];simpl. + 2: { + assert (ea !! e = None) as ->;auto. + apply not_elem_of_dom. intro. apply Hn. by apply elem_of_dom. + } + iClear "IH". iIntros "Rin". + iDestruct ("Hfe_e" with "Rin") as ">Hfe_e". + iModIntro. iNext. iMod "Hfe_e". + iNamed "Hfe_e". iFrame. + assert (is_Some (na_used !! e)) as [R_e_u Hnau_lob_lk]. + { apply elem_of_dom. set_solver + Hnau_dom_eq. } + iDestruct (big_sepM2_lookup _ _ _ e R_e_u R_e_uu with "Hnau_wf") as "#Hnau_wf_k". + done. apply lookup_insert_Some;left;done. + assert (na !! e = Some R_e) as Hna_lk. + { rewrite map_subseteq_spec in Hnal_sub. apply Hnal_sub;auto. } + rewrite Hna_lk /=. + iDestruct "Hnau_wf_k" as "[_ Hnau_wf_k]". iDestruct ("Hnau_wf_k" with "R_na") as "[R_na $]". + iInduction (Graph.lob_succ_of (GlobalState.gs_graph gs) e) + as [|e_succ s_lob_succ H_e_succ_nin] "IH" using set_ind_L. + iModIntro. rewrite 2!big_sepS_empty //. iFrame "R_obs_out". + rewrite big_sepS_union;last set_solver + H_e_succ_nin. rewrite big_sepS_singleton. + rewrite big_sepS_union;last set_solver + H_e_succ_nin. rewrite big_sepS_singleton. + iDestruct "R_lob_out" as "[R_e_succ R_lob_out]". + destruct (decide (ThreadState.progress_to_node pg tid = e_succ )) as [-> |Hneq]. + - rewrite lookup_union_l'. rewrite lookup_singleton /=. rewrite Hnau_lob_lk /=. iFrame "R_na R_obs_out". + iModIntro. iApply (big_sepS_impl with "R_lob_out"). + iModIntro. iIntros (? Hin) "?". + rewrite lookup_union_r //. rewrite lookup_singleton_None. set_solver + Hin H_e_succ_nin. + eexists; apply lookup_singleton_Some;split;eauto. + - rewrite lookup_union_r. 2:{ apply lookup_singleton_None;auto. } + iFrame "R_e_succ". by iApply ("IH" with "R_lob_out R_na"). + } + iSpecialize ("IH" $! (delete e na_lob) with "[] [] []"). + { iPureIntro. etransitivity;[|eauto]. apply delete_subseteq. } + { iPureIntro. rewrite dom_delete. rewrite Hnal_dom_eq. rewrite -not_elem_of_dom in Hnin. set_solver + Hnin. } + { iPureIntro. rewrite -{2}Hna_split. + apply map_eq. intros. + destruct (decide (i=e)) as [->|Hneq]. + rewrite lookup_union_r. rewrite lookup_union_l. rewrite Hna_lob_lk. rewrite lookup_difference_Some. + split;auto. rewrite map_subseteq_spec in Hnal_sub. by apply Hnal_sub. + apply lookup_difference_None. right;apply lookup_insert_is_Some. left;done. + apply lookup_delete_None. left;done. + destruct (decide(i ∈ dom na_lob)). + - rewrite lookup_union_l'. rewrite lookup_delete_ne;auto. + rewrite lookup_union_l';auto. by apply elem_of_dom. + rewrite lookup_delete_ne;auto. by apply elem_of_dom. + - rewrite lookup_union_r. rewrite lookup_union_r. + destruct ((na ∖ na_unused) !! i) eqn:Hlk; symmetry. + apply lookup_difference_Some. apply lookup_difference_Some in Hlk. + rewrite lookup_insert_ne;auto. + apply lookup_difference_None. apply lookup_difference_None in Hlk. + rewrite lookup_insert_ne;auto. by apply not_elem_of_dom. + rewrite lookup_delete_ne;auto. by apply not_elem_of_dom. + } + iSpecialize ("IH" $! (delete e na_used) with "[] [] [] []"). + { iPureIntro. etransitivity;[|eauto]. apply subseteq_dom. apply delete_subseteq. } + { + iPureIntro. rewrite dom_delete_L. rewrite Hnau_dom_eq. + apply not_elem_of_dom in Hnin. set_solver + Hnin. + } + { + iPureIntro. rewrite dom_delete. set_solver + Hna_dom_sub. + } + { + iModIntro. + iDestruct (big_sepM2_alt with "Hnau_wf") as "[%Hna_u_dom _]". + rewrite set_eq in Hna_u_dom. pose proof (Hna_u_dom e) as [_ Hna_u_dom']. + feed specialize Hna_u_dom'. rewrite dom_insert_L. set_solver +. + rewrite elem_of_dom in Hna_u_dom'. destruct Hna_u_dom' as [? Hnau_lk]. + iDestruct (big_sepM2_delete _ _ _ e with "Hnau_wf") as "[_ Hnau_wf']";eauto. + rewrite lookup_insert. reflexivity. + rewrite delete_insert_delete. + iClear "Hnau_wf". + assert (delete e na_unused = na_unused) as <-. rewrite delete_notin //. + rewrite delete_idemp. + iApply (big_sepM2_proper with "Hnau_wf'"). + intros k?? Hlk1 Hlk2. + assert (k ≠ e) as Hneq. { intros ->. rewrite lookup_delete_Some in Hlk1. destruct Hlk1;auto. } + specialize (Hna_u_dom k). efeed specialize Hna_u_dom. + rewrite lookup_delete_ne in Hlk1;eauto. + } + iSpecialize ("IH" with "Hea_fe"). iApply (big_sepM_impl with "IH"). + { + iModIntro. iIntros (?? Hlk) "H". + assert (ThreadState.progress_to_node pg tid ≠ k) as Hneq. + { + intros <-. + assert (ThreadState.progress_to_node pg tid ∈ dom na_unused) as Hin. apply elem_of_dom. done. + rewrite dom_insert_L in Hnau_dom_eq. rewrite dom_insert in Hnal_dom_eq. + apply Hcurr_nin. apply subseteq_dom in Hnal_sub. + rewrite Hnal_dom_eq in Hnal_sub. set_solver + Hin Hnal_sub. + } + rewrite lookup_union_r. 2:{ apply lookup_singleton_None. auto. } + rewrite lookup_union_r. 2:{ apply lookup_singleton_None. auto. } + + destruct (decide (is_Some (ea !! k))) as [[gm Hlk_gm]|Hn]. + 2: { + assert (ea !! k = None) as ->;auto. + apply not_elem_of_dom. intro. apply Hn. by apply elem_of_dom. + } + rewrite Hlk_gm /=. iIntros "R_in". iDestruct ("H" with "R_in") as "H". + iApply (step_fupd_mono with "[] H"). iIntros "($&$&H)". + iApply (big_sepS_impl with "H"). iModIntro. iIntros (e_succ Hin). + destruct (decide (ThreadState.progress_to_node pg tid = e_succ )) as [-> |Hneq']. + - rewrite lookup_union_l'. rewrite lookup_singleton /=. + rewrite lookup_union_l'. rewrite lookup_singleton /=. + rewrite lookup_delete_ne. iIntros "$". + intros ->. rewrite Hlk //in Hnin. rewrite lookup_singleton //. rewrite lookup_singleton //. + - rewrite lookup_union_r. rewrite lookup_union_r. + iIntros "$". apply lookup_singleton_None;auto. apply lookup_singleton_None;auto. + } + + (* the boring case *) + iApply (big_sepM_impl with "Hea_fe_same"). + iModIntro. iIntros (?? Hlk) "H". + rewrite lookup_union_r. + 2:{ + apply lookup_singleton_None. + rewrite lookup_difference_Some in Hlk. + destruct Hlk as [Hlk _]. + intros <-. apply Hcurr_nin. apply elem_of_dom. done. + } + destruct (decide (is_Some (ea !! k))) as [[gm Hlk_gm]|Hn]. + 2: { + assert (ea !! k = None) as ->;auto. + apply not_elem_of_dom. intro. apply Hn. by apply elem_of_dom. + } + rewrite Hlk_gm /=. iIntros "R_in". iDestruct ("H" with "R_in") as "H". + iApply (step_fupd_mono with "[] H"). iIntros "($&$&H)". + iApply (big_sepS_impl with "H"). iModIntro. iIntros (e_succ Hin). + destruct (decide (ThreadState.progress_to_node pg tid = e_succ )) as [-> |Hneq']. + * rewrite lookup_union_l'. rewrite lookup_singleton /=. + rewrite lookup_difference_Some in Hlk. destruct Hlk as [_ Hlk]. + apply not_elem_of_dom in Hlk. rewrite -Hnau_dom_eq in Hlk. apply not_elem_of_dom in Hlk. rewrite Hlk. + iIntros "_". done. + rewrite lookup_singleton //. + * rewrite lookup_union_r. + iIntros "$". apply lookup_singleton_None;auto. + Qed. + + Lemma wp_step gs tid s s' pg ls Φ : + let gr := gs.(GlobalState.gs_graph) in + AAConsistent.t gr -> + AACandExec.NMSWF.wf gr -> + LThreadStep.t gs tid s s' → + LThreadState.at_progress s pg -> + local_interp gs tid pg ls -∗ + (□ gconst_interp gs) -∗ + WP s @ tid {{ Φ }} -∗ + (if (bool_decide (ThreadState.progress_is_valid gr tid pg)) then + ∀ (na : mea Σ) (ea : sra Σ), + "#Hannot_at_prog" ∷ na_at_progress gr tid pg na ∗ + "Hea_wf" ∷ ea_lob_wf gr ea na ∗ + ("Hinterp_annot" ∷ annot_interp na) ==∗ + let e := (ThreadState.progress_to_node pg tid) in + let s_lob := (Graph.lob_pred_of gr e) in + let s_obs := (Graph.obs_pred_of gr e) in + ∃ (R: iProp Σ) (na_used na_unused : mea Σ) (ls' : log_ts_t), + "#Hna_split" ∷ na_splitting_wf s_lob na na_used na_unused ∗ + "Hinterp_annot" ∷ annot_interp ({[e := R]} ∪ na_unused ∪ na) ∗ + "Hea_wf" ∷ ea_lob_wf gr ({[e := na_used]} ∪ ea) ({[e := R]} ∪ na_unused ∪ na) ∗ + "Hinterp_local" ∷ local_interp gs tid (LThreadState.get_progress s') ls' ∗ + "Hwp" ∷ WP s' @ tid {{ Φ }} + else + |=i=> ("Hinterp_local" ∷ local_interp gs tid (LThreadState.get_progress s') ls ∗ + "Hwp" ∷ WP s' @ tid {{ Φ }})). + Proof. + iIntros (? Hgr_consist Hgr_wf Hstep Hpg) "Hls Hgs H". + rewrite wp_sswp. iApply (sswp_step with "Hls Hgs H");auto. + Qed. + + Lemma wp_steps (n : nat) gs (tid : Tid) s pg s' ls Φ : + let gr := gs.(GlobalState.gs_graph) in + AAConsistent.t gr -> + AACandExec.NMSWF.wf gr -> + nsteps (LThreadStep.t gs tid) n s s' → + Terminated s' → + LThreadState.at_progress s pg -> + local_interp gs tid pg ls -∗ + (□ gconst_interp gs) -∗ + WP s @ tid {{ Φ }} -∗ + ∀ (na : mea Σ) (ea : sra Σ), + "#Hannot_at_prog" ∷ na_at_progress gr tid pg na ∗ + "Hea_wf" ∷ ea_lob_wf gr ea na ∗ + ("Hinterp_annot" ∷ annot_interp na) ==∗ + ∃ na' ea' ls', + annot_interp na' ∗ + ea_lob_wf gr ea' na' ∗ + "Hinterp_local" ∷ local_interp gs tid (LThreadState.get_progress s') ls' ∗ + (* FEs hold for nodes in the middle, [s,s') *) + ⌜LThreadStep.eids_between gr tid s s' ∪ dom na = dom na'⌝ ∗ + post_lifting Φ tid s'. + Proof. + revert s s' pg ls Φ. + induction n as [|n IH]=> s s' pg ls Φ /=. + { + inversion_clear 3. intros Hterm Hpg. + iIntros "? ? WP". iIntros (??) "H". iModIntro. + iExists na,ea,ls. rewrite Hpg /=. iNamed "H". iFrame. + rewrite LThreadStep.traversed_eids_empty. + iSplit;first (iPureIntro;set_solver+). + iDestruct (wp_terminated_inv' with "WP") as "$"; done. + } + (* Induction case *) + (* preparation *) + iIntros (Hgr_cs Hgr_wf Hsteps Hterm Hpg) "Hls #Hgs Hwp". + inversion_clear Hsteps as [|? ? ?s'' ? Hstep Hsteps']. + iIntros (??) "H". iNamed "H". + iDestruct (wp_step with "Hls Hgs Hwp") as "Step";eauto. + erewrite LThreadStep.steps_traversed_eids_union;eauto. + (* Case on the validity of [pg] *) + case_bool_decide as Hpg_valid. + { (* Case valid: update [na] *) + iMod ("Step" $! na ea with "[$Hannot_at_prog $Hea_wf $Hinterp_annot]") as "(%&%&%&%&H)". + iNamed "H". iNamed "Hna_split". + iDestruct "Hannot_at_prog" as %Hannot_at_prog. + iDestruct (big_sepM2_alt with "Hnau_wf") as "[%Hnauu_dom _]". + assert (dom (na_unused ∪ na) = dom na) as Hnau_dom_eq. + { + erewrite <-(LThreadStep.eids_from_init_po_pred_of _ tid pg) in Hannot_at_prog;eauto. + rewrite dom_union_L. + assert (dom na_used ⊆ dom na) as Hsub. + { + etransitivity. exact Hnau_dom_sub. etransitivity. apply Graph.lob_pred_of_subseteq_po;first assumption. assumption. + rewrite -Hannot_at_prog. + intros ? Hin. rewrite elem_of_filter in Hin. destruct Hin;assumption. + } + set_solver + Hsub Hnauu_dom. + } + specialize (IH s'' s' (LThreadState.get_progress s'') ls' Φ Hgr_cs Hgr_wf Hsteps' Hterm). + iDestruct (IH with "Hinterp_local Hgs Hwp") as "IH";first done. + iSpecialize ("IH" $! ({[ThreadState.progress_to_node pg tid := R]} ∪ na_unused ∪ na) ({[ThreadState.progress_to_node pg tid := na_used]} ∪ ea)). + iMod ("IH" with "[$Hea_wf $Hinterp_annot]") as "(%&%&%ls''&Hinterp_annot&Hea_wf&Hls&Hdom&Hpost)". + { + iPureIntro. + rewrite -assoc. rewrite dom_union_L dom_singleton_L. rewrite filter_union_L filter_singleton_L //. + rewrite Hnau_dom_eq Hannot_at_prog. + rewrite (LThreadStep.step_traversed_eids_from_init_union s s'' Hstep);eauto. + case_bool_decide;subst pg; done. + } + iModIntro. iExists na',ea', ls''. iFrame. + rewrite -assoc. rewrite dom_union_L. rewrite dom_singleton_L. + rewrite Hnau_dom_eq. iDestruct "Hdom" as %Hdom. + iPureIntro. subst pg. case_bool_decide;last contradiction. set_solver + Hdom. + } + { (* Case invalid: keep [na] unchanged *) + specialize (IH s'' s' (LThreadState.get_progress s'') ls Φ Hgr_cs Hgr_wf Hsteps' Hterm). + rewrite {1}interp_mod_eq /interp_mod_def. + iMod ("Step" with "Hinterp_annot") as "[Hwp Hinterp_annot]". + iNamed "Hwp". rewrite /=. + iDestruct (IH with "Hinterp_local Hgs Hwp") as "IH";first done. + iMod ("IH" with "[$Hea_wf $Hinterp_annot]"). + { + iDestruct "Hannot_at_prog" as %Hannot_at_prog. iPureIntro. + rewrite Hannot_at_prog. + rewrite (LThreadStep.step_traversed_eids_from_init_union s s'' Hstep);eauto. + subst pg. case_bool_decide;first done. + rewrite union_empty_l_L //. + } + subst pg;case_bool_decide;auto. contradiction. + rewrite union_empty_l_L //. + } + Qed. + +End lifting. diff --git a/theories/low/rules/announce.v b/theories/low/rules/announce.v new file mode 100644 index 0000000..348cd69 --- /dev/null +++ b/theories/low/rules/announce.v @@ -0,0 +1,63 @@ +From self.low.rules Require Import prelude. + +Import uPred. + +Section rules. + Context `{AAIrisG} `{Htg: !ThreadGNL}. + Import ThreadState. + Lemma branch_announce `{!UserProt} {tid : Tid} {ts ctxt addr dep}: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.BranchAnnounce addr dep) ctxt -> + ⊢ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + ⌜lts' = LThreadState.LTSNormal ((incr_cntr ts) + <| ts_ctrl_srcs := LThreadStep.deps_of_depon tid ts dep ∪ (ThreadState.ts_ctrl_srcs ts) |> + <| ts_reqs := ctxt tt |> ) ⌝ + }}. + Proof. + iIntros (Hreqs). + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2: { + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv; [|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + + inversion_step Hstep. + + iNamed "Hinterp_annot". iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc na (get_progress ts) tid gs emp%I with "[$Hinterp_annot $Hannot_at_prog //]") as "(Hinterp_annot & _)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog //]") as "(Hinterp_token & _)". + + iExists emp%I, ∅, ∅, ls. + iModIntro. + iSplitR; [iSplitR |]. + { by iApply empty_na_splitting_wf. } + { iNamed 1. iApply step_fupd_intro; first auto. + rewrite /prot_node /=. + erewrite progress_to_node_mk_eid_ii; last reflexivity. iNext. + iSplitL. 2: { done. } + iModIntro. + iIntros (????) "E_W". + iDestruct (graph_event_agree with "Hinterp_global E_W") as %Heq. + destruct Heq as [? [Hlk ?]]. + rewrite Hlk in Hgr_lk. inversion Hgr_lk. subst x. contradiction. + } + + iSplitL "Hinterp_annot Hinterp_token". + { rewrite -map_union_assoc map_empty_union insert_union_singleton_l. + iFrame. rewrite dom_union_L dom_singleton_L. by iFrame. } + + iSplitL; last done. + iNamed "Hinterp_local". iSplitL "Hinterp_local_lws". + { + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws"); auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin; eauto. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + } + iApply (po_pred_interp_skip with "Hinterp_po_src");auto. + Qed. +End rules. diff --git a/theories/low/rules/barrier.v b/theories/low/rules/barrier.v new file mode 100644 index 0000000..25177b0 --- /dev/null +++ b/theories/low/rules/barrier.v @@ -0,0 +1,188 @@ +(* This file contains the low-level proof rules for memory barriers *) +From self.low.rules Require Import prelude. + +Import uPred. + +Section rules. + Context `{AAIrisG} `{Htg: !ThreadGNL}. + Import ThreadState. + + Lemma dmb `{!UserProt} {tid : Tid} {o_po_src ts ctxt kind}: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.Barrier (AAArch.DMB kind)) ctxt -> + let eid := progress_to_node (get_progress ts) tid in + o_po_src -{LPo}> -∗ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* update lts' accordingly *) + ⌜lts' =(LThreadState.LTSNormal ((incr_cntr ts) <| ts_reqs := (ctxt tt) |>)) ⌝ ∗ + (* Current event is a read *) + eid -{E}> (Event.B (AAArch.DMB kind)) ∗ + from_option (λ eid_po_src, eid_po_src -{(Edge.Po)}> eid) emp o_po_src ∗ + Some eid -{LPo}> + }}. + Proof. + iIntros (Hreqs ?) "Hpo_src". + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + + (* Hstep gives that a dmb event is happening *) + inversion_step Hstep. + + subst eid. set (eid := (mk_eid_ii ts tid)). + iNamed "Hinterp_local". iDestruct (po_pred_interp_agree with "Hinterp_po_src Hpo_src") as %Hpo. + + (** allocate resources *) + iAssert ( + eid -{E}> (Event.B (AAArch.DMB dκ)) ∗ + (* Po *) + from_option (λ eid_po_src, eid_po_src -{(Edge.Po)}> eid) emp o_po_src)%I + as "(E_B & Ed_po)". + { + rewrite edge_eq /edge_def. rewrite event_eq /event_def. iNamed "Hinterp_global". + + iSplitL;first alloc_graph_res. { repeat case_bool_decide;try contradiction;auto. } + + destruct o_po_src as [po_src|];last done. alloc_graph_res. + destruct Hpo as [? [? ?]]. rewrite -(progress_to_node_of_node tid po_src);auto. + rewrite /eid. erewrite <-progress_to_node_mk_eid_ii;last done. + apply progress_lt_po;[done|repeat (split;[done|]);done]. + } + + (* update na *) + iNamed "Hinterp_annot". iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc na (get_progress ts) tid gs emp%I with "[$Hinterp_annot $Hannot_at_prog //]") as "(Hinterp_annot & _)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog //]") as "(Hinterp_token & _)". + + (* update ls *) + iMod (po_pred_interp_update _ ts (ts <| ts_reqs := ctxt tt |>) with "Hinterp_po_src Hpo_src") as "(Hinterp_po_src & Hpo_src)";auto. + + iExists emp%I, ∅, ∅, (ls <|lls_pop := Some eid|>). + iModIntro. iSplitR; [iSplitR |]. { by iApply empty_na_splitting_wf. } + + (** getting out resources from FE *) + { + repeat iNamed 1. iApply step_fupd_intro;auto. + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. iNext. + + iSplitL. iModIntro. iIntros (????) "E_W'". + iDestruct (graph_event_agree with "Hinterp_global E_W'") as %Heq. + destruct Heq as [? [Hlk ?]]. + rewrite Hlk in Hgr_lk. inversion Hgr_lk. subst x. contradiction. done. + } + + iSplitL "Hinterp_annot Hinterp_token". + { rewrite -map_union_assoc. rewrite map_empty_union. rewrite insert_union_singleton_l. + iFrame. rewrite dom_union_L dom_singleton_L. by iFrame. } + + iSplitL "Hinterp_local_lws Hinterp_po_src". + { + iSplitL "Hinterp_local_lws". + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;last done. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + erewrite progress_to_node_mk_eid_ii;last reflexivity. done. + } + + iFrame "E_B Ed_po Hpo_src". done. + Qed. + + Lemma isb `{!UserProt} {tid : Tid} {o_po_src ts ctxt}: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.Barrier AAArch.ISB) ctxt -> + let eid := progress_to_node (get_progress ts) tid in + o_po_src -{LPo}> -∗ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* update lts' accordingly *) + ⌜lts' =(LThreadState.LTSNormal ((incr_cntr ts) <| ts_reqs := (ctxt tt) |>)) ⌝ ∗ + (* Current event is a read *) + eid -{E}> (Event.B AAArch.ISB) ∗ + (* Po *) + from_option (λ eid_po_src, eid_po_src -{(Edge.Po)}> eid) emp o_po_src ∗ + (Some eid) -{LPo}> ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) + }}. + Proof. + iIntros (Hreqs ?) "Hpo_src". + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + + (* Hstep gives that an isb event is happening *) + inversion_step Hstep. + + subst eid. set (eid := (mk_eid_ii ts tid)). + iNamed "Hinterp_local". iDestruct (po_pred_interp_agree with "Hinterp_po_src Hpo_src") as %Hpo. + + (** allocate resources *) + iAssert ( + eid -{E}> (Event.B AAArch.ISB) ∗ + (* Po *) + from_option (λ eid_po_src, eid_po_src -{(Edge.Po)}> eid) emp o_po_src ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) + )%I as "(E_B & Ed_po & Ed_ctrl)". + { + rewrite edge_eq /edge_def. rewrite event_eq /event_def. iNamed "Hinterp_global". + + iSplitL;first alloc_graph_res. done. + + iSplitL. destruct o_po_src as [po_src|];last done. alloc_graph_res. + destruct Hpo as [? [? ?]]. rewrite -(progress_to_node_of_node tid po_src);last done. + rewrite /eid. erewrite <-progress_to_node_mk_eid_ii;last done. + apply progress_lt_po;first done. repeat(split;[done|]);done. + + rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + } + + (* update na *) + iNamed "Hinterp_annot". + iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc na (get_progress ts) tid gs emp%I with "[$Hinterp_annot $Hannot_at_prog //]") as "(Hinterp_annot & _)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog //]") as "(Hinterp_token & _)". + + (* update ls *) + iMod (po_pred_interp_update _ ts (ts <| ts_reqs := ctxt tt |>) with "Hinterp_po_src Hpo_src") as "(Hinterp_po_src & Hpo_src)";auto. + + iExists emp%I, ∅, ∅, (ls <|lls_pop := Some eid|>). + iModIntro. iSplitR; [iSplitR |]. { by iApply empty_na_splitting_wf. } + + (** getting out resources from FE *) + { + repeat iNamed 1. iApply step_fupd_intro;first auto. + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. iNext. + + iSplitL. iModIntro. iIntros (????) "E_W'". + iDestruct (graph_event_agree with "Hinterp_global E_W'") as %Heq. + destruct Heq as [? [Hlk ?]]. + rewrite Hlk in Hgr_lk. inversion Hgr_lk. subst x. contradiction. done. + } + + iSplitL "Hinterp_annot Hinterp_token". + { rewrite -map_union_assoc. rewrite map_empty_union. rewrite insert_union_singleton_l. + iFrame. rewrite dom_union_L dom_singleton_L. by iFrame. } + iSplitL "Hinterp_local_lws Hinterp_po_src". + { + iSplitL "Hinterp_local_lws". iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;last done. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. contradiction. + erewrite progress_to_node_mk_eid_ii;last reflexivity. done. + } + iFrame "E_B Ed_po Ed_ctrl". by iFrame. + Qed. +End rules. + + diff --git a/theories/low/rules/prelude.v b/theories/low/rules/prelude.v new file mode 100644 index 0000000..fb95948 --- /dev/null +++ b/theories/low/rules/prelude.v @@ -0,0 +1,134 @@ +(* This file contains the helper tactics and lemmas that are useful for showing proof rules *) +From stdpp Require Export unstable.bitvector. + +From iris.proofmode Require Export tactics. + +Require Export ISASem.SailArmInstTypes. + +From self.lang Require Export opsem. +From self.algebra Require Export base. +From self.low Require Export weakestpre instantiation. +From self.low.lib Require Export edge event. + +(* NOTE: all modules are exported, so that other rule files only need to import this prelude module *) + +Import uPred. + +Section helpers. + Context `{AAIrisG} `{Htg: !ThreadGNL}. + + (* spliting and merging node_annots *) + Lemma annot_split_iupd n P Q: + n ↦ₐ (P ∗ Q) -∗ |=i=> (n ↦ₐ P ∗ n ↦ₐ Q). + Proof. + rewrite interp_mod_eq /interp_mod_def. + rewrite /iris.annot_interp /=. iIntros "H %". iNamed 1. + iFrame "Hinterp_token". by iApply (annot_split with "H"). + Qed. + + Lemma annot_merge_iupd n P Q: + n ↦ₐ P -∗ n ↦ₐ Q -∗ |=i=> (n ↦ₐ (P ∗ Q)). + Proof. + rewrite interp_mod_eq /interp_mod_def. + rewrite /iris.annot_interp /=. iIntros "H1 H2 %". iNamed 1. + iFrame "Hinterp_token". by iApply (annot_merge with "H1 H2"). + Qed. + + Import ThreadState. + + (** Helpers *) + + Lemma empty_na_splitting_wf lob_pred na : + ⊢ (na_splitting_wf lob_pred na ∅ ∅ : iProp Σ). + Proof. + iStartProof. iSplit. rewrite dom_empty //. rewrite big_sepM2_empty //. + Qed. + + + Ltac alloc_graph_res := + iExists _;iFrame "Hgr_ag";iPureIntro; repeat (split;[done|]); try (eexists;split;[done|]);simpl; + try (match goal with + | [ HH : _ ⊆ (?f (GlobalState.gs_graph _)) |- _ ∈ (?f (GlobalState.gs_graph _))] => + apply HH; rewrite CSets.gset_product_spec; split; [done| set_solver +] + end). + + Lemma last_local_write_co {gs} {tid : Tid} {pg ls addr ot_coi_pred} W: + AACandExec.NMSWF.wf (GlobalState.gs_graph gs) -> + AAConsistent.t (GlobalState.gs_graph gs) -> + GlobalState.gs_graph gs !! (progress_to_node pg tid) = Some W -> + AAConsistent.event_is_write_with_addr W addr -> + "Hinterp_global" ∷ global_interp gs -∗ + "Hinterp_local_lws" ∷ last_write_interp gs tid pg ls -∗ + "Hlocal" ∷ last_local_write tid addr ot_coi_pred -∗ + from_option (λ eid_coi_pred : Eid, ⌜EID.tid eid_coi_pred = tid⌝ ∗ eid_coi_pred -{Edge.Co}> progress_to_node pg tid) + emp ot_coi_pred. + Proof. + iIntros (?? Hgr_lk Hw). repeat iNamed 1. + destruct ot_coi_pred;last done. + iDestruct(last_write_interp_agree_Some with "Hinterp_local_lws Hlocal") as %(W' & Hlk_w'&?&?&Hco&_). + simpl. iSplitR;first done. rewrite edge_eq /edge_def. + iNamed "Hinterp_global". alloc_graph_res. + apply Graph.wf_coi_inv;auto. + eapply Graph.wf_loc_inv_writes2. repeat eexists;eauto. + eapply AAConsistent.event_is_write_with_addr_elem_of_mem_writes in Hlk_w';eauto. + eapply (AAConsistent.event_is_write_with_addr_elem_of_mem_writes _ _ addr) in Hgr_lk;eauto. + set_solver + Hgr_lk Hlk_w'. + rewrite -(progress_to_node_of_node tid t0);last done. + rewrite -progress_lt_po; last done. split;auto;split;auto. + rewrite /progress_is_valid. rewrite progress_to_node_of_node;last done. + set_solver + Hlk_w'. + set_solver + Hgr_lk. + Qed. + +End helpers. + +(** tactics *) +Ltac alloc_graph_res := + iExists _;iFrame "Hgr_ag";iPureIntro; repeat (split;[done|]); try (eexists;split;[done|]);simpl; + try (match goal with + | [ HH : _ ⊆ (?f (GlobalState.gs_graph _)) |- _ ∈ (?f (GlobalState.gs_graph _))] => + apply HH; rewrite CSets.gset_product_spec; split; [done| set_solver +] + end). + +Ltac existT_inversion := + repeat match goal with + | [HexistT : existT ?x ?f = existT ?y ?g, Heq : ?x = ?y|- _] => + try subst x; clear Heq + | [HexistT : existT ?x ?f = existT _ ?g |- _] => + eapply (DepEq.eq_rect_existT_eq _ _ _ _ _ _ (eq_refl _)) in HexistT; + rewrite -Classical_Prop.Eq_rect_eq.eq_rect_eq in HexistT;subst g + end. + +Ltac inversion_step Hstep := + inversion Hstep; + match goal with + | [ Hreq_eq : ThreadState.reqs_done ?ts , Hreqs : ThreadState.ts_reqs ?ts = AAInter.Next _ _ |- _ ] => + rewrite /ThreadState.reqs_done in Hreq_eq; rewrite Hreqs in Hreq_eq; inversion Hreq_eq + | [ Hreq_eq : ThreadState.next_req_is ?ts ?req ?ctxt, Hreqs : ThreadState.ts_reqs ?ts = EmptyInterp |- _ ] => + rewrite /ThreadState.next_req_is in Hreq_eq; rewrite Hreqs in Hreq_eq; inversion Hreq_eq + | [ Hreq_eq : ThreadState.reqs_done ?ts , Hreqs : ThreadState.ts_reqs ?ts = EmptyInterp |- _ ] => + repeat match goal with + | [ Hts : ?ts' = ts |- _ ] => subst ts' + | [ Heq : ?x = ?x |- _] => clear Heq + | [ Hlk : GlobalState.gs_graph ?gs !! ?e = Some ?E |- _] => rename Hlk into Hgr_lk + end + | [ Hreq_eq : ThreadState.next_req_is ?ts ?req ?ctxt, Hreqs : ThreadState.ts_reqs ?ts = AAInter.Next _ _ |- _ ] => + rewrite /ThreadState.next_req_is in Hreq_eq; rewrite Hreqs in Hreq_eq; inversion Hreq_eq; subst; existT_inversion; + (* clean up *) + repeat match goal with + | [ Hts : ?ts' = ts |- _ ] => subst ts' + | [ Heq : ?x = ?x |- _] => clear Heq + | [ Hlk : GlobalState.gs_graph ?gs !! ?e = Some ?E |- _] => rename Hlk into Hgr_lk + end + end. + +Ltac resolve_atomic := + repeat (match goal with + | [ HH : AACandExec.Candidate.kind_of_wreq_is_atomic (?f _ ?v _ _ _) = ?b |- _] => + rewrite /f /AACandExec.Candidate.kind_of_wreq_is_atomic /AACandExec.Candidate.kind_of_wreq_P /= in HH + | [ HH : bool_decide (?f _ = _) || bool_decide (?g _ = _) = _ |- _ ] => try (rewrite /f /g orb_false_iff /= in HH; destruct HH as [? ?]); + try (rewrite /f /g orb_true_iff /= in HH; destruct HH as [? | ?]) + | [ HH : bool_decide (_ = _) = _ |- _ ] => case_bool_decide; try inversion HH; clear HH + | [ HH : false = true |- _ ] => inversion HH + | [ HH : true = false |- _ ] => inversion HH + end). diff --git a/theories/low/rules/read.v b/theories/low/rules/read.v new file mode 100644 index 0000000..36efc2a --- /dev/null +++ b/theories/low/rules/read.v @@ -0,0 +1,631 @@ +(* This file contains the low-level proof rules for memory reads *) +From self.low.rules Require Import prelude. + +Import uPred. + +Section rules. + Context `{AAIrisG} `{Htg: !ThreadGNL}. + Import ThreadState. + + Lemma mem_read_external `{!UserProt} {tid : Tid} {o_po_src ts ctxt dep addr kind_s kind_v} R po_srcs lob_annot: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemRead 8 (readreq_of_store kind_s kind_v addr dep)) ctxt -> + let eid := progress_to_node (get_progress ts) tid in + let R_graph_facts := (λ val eid_w, + eid -{E}> (Event.R kind_s kind_v addr val) ∗ + (* Po *) + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + (* Addr *) + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep), eid_addr_src -{(Edge.Addr)}> eid) ∗ + (* There must be a write with same addr and val *) + (∃ kind_s_w kind_v_w, eid_w -{E}> (Event.W kind_s_w kind_v_w addr val)) ∗ + (* [optional] rf from write to read *) + eid_w -{(Edge.Rf)}> eid ∗ + (* eid_w is an external write *) + ⌜EID.tid eid_w ≠ tid⌝)%I in + o_po_src -{LPo}> -∗ + ([∗ set] e_po_src ∈ po_srcs, e_po_src -{Po}>) -∗ + last_local_write tid addr None -∗ + (* node annotations *) + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) -∗ + (* Lob edge formers *) + (eid -{N}> (Edge.R kind_s kind_v) -∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{Edge.Po}> eid) -∗ + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) -∗ + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep), eid_addr_src -{(Edge.Addr)}> eid) -∗ + [∗ set] eid_pre ∈ dom lob_annot, eid_pre -{Edge.Lob}> eid) -∗ + (* FE *) + (∀ val eid_w, + R_graph_facts val eid_w ∗ + ([∗ map] _ ↦ annot ∈ lob_annot, annot) ∗ + □(prot addr val eid_w) + ={⊤}[∅]▷=∗ + R addr val eid_w) -∗ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* exists a val, a write kind, and a write eid_w *) + ∃ val eid_w, + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSNormal ((ThreadState.incr_cntr (ts <| ts_iis := (ts.(ts_iis) + <| iis_mem_reads := ((ts.(ts_iis).(iis_mem_reads)) ++ [ts.(ts_iis).(iis_cntr)])%list|>)|>)) + <| ts_reqs := ctxt (inl(val, None)) |> + <| ts_rmw_pred := if bool_decide (kind_v = AV_exclusive) || + bool_decide (kind_v = AV_atomic_rmw) + then Some eid else ts.(ts_rmw_pred) |>)⌝ ∗ + R_graph_facts val eid_w ∗ + (Some eid) -{LPo}> ∗ + (* node annotation *) + (eid ↦ₐ R addr val eid_w) ∗ + (* ([∗ map] node ↦ annot ∈ lob_annot_uu, node ↦ₐ annot) ∗ *) + (* local writes at addr is unchanged *) + last_local_write tid addr None + }}. + Proof. + iIntros (Hreqs ??) "Hpo_src Hpo_srcs Hlocal Hannot Hef Hfe". + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + (* Hstep gives that a read event is happening *) + inversion_step Hstep. + + (* get the write *) + feed pose proof (Graph.wf_read_inv _ _ _ addr kind_s kind_v mv Hgraph_wf Hgr_lk) as Hrf;simpl; + [rewrite /AACandExec.Candidate.kind_of_rreq_P /=; repeat (case_bool_decide;[|contradiction]);done| destruct Hrf as (eid_w & kind_s_w & kind_v_w & E_w &Hgr_lk_w&HE_w&?)]. + + iNamed "Hinterp_local". + iDestruct (last_write_interp_agree_None with "Hinterp_local_lws Hlocal") as %Hlw. + efeed specialize Hlw; [done|eauto|]. eapply AAConsistent.event_is_write_with_impl_addr;done. + + iDestruct (po_pred_interp_agree_big' with "Hinterp_po_src Hpo_srcs") as %Hpo_srcs. + iDestruct (po_pred_interp_agree with "Hinterp_po_src Hpo_src") as %Hpo. + + epose proof (AAConsistent.event_is_write_with_elem_of_mem_writes eid_w _ _ _ _ _ Hgr_lk_w HE_w) as Heid_w. + + subst eid. set (eid := (mk_eid_ii ts tid)). + destruct Hlw as [Hne_tid | [Htid Hlw]]. + 2:{(* reading from later writes *) + exfalso. + pose proof (Graph.wf_rfi_inv eid_w eid Hgraph_wf Hgraph_co H2 Htid) as Hpo'. + erewrite <-(progress_to_node_of_node tid eid_w Htid) in Hpo'. + erewrite <-(progress_to_node_of_node tid eid) in Hpo';[|done]. + rewrite -progress_lt_po in Hpo';[|done]. destruct Hpo'. + rewrite /eid. by apply progress_le_gt_False in Hlw. + } + + assert (Hobs : (eid_w, eid) ∈ AAConsistent.obs (gs.(GlobalState.gs_graph))). + { apply elem_of_union_l. apply elem_of_union_l. apply elem_of_filter. split. rewrite /= //. done. } + + (** allocate resources *) + iAssert (eid -{E}> Event.R kind_s kind_v addr mv ∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{Edge.Po}> progress_to_node (get_progress ts) tid) ∗ + ([∗ set] eid_ctrl_src ∈ ts_ctrl_srcs ts, eid_ctrl_src -{Edge.Ctrl}> eid) ∗ + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep), eid_addr_src -{(Edge.Addr)}> eid) ∗ + eid_w -{E}> Event.W kind_s_w kind_v_w addr mv ∗ + eid_w -{Edge.Rf}> eid)%I as "(E_R & Ed_po & Ed_ctrl & Ed_addr & E_W & Ed_rf)". + { + rewrite edge_eq /edge_def. rewrite event_eq /event_def. iNamed "Hinterp_global". + + iSplitL. alloc_graph_res. + { rewrite /AACandExec.Candidate.kind_of_rreq_P /=; repeat case_bool_decide;try contradiction;auto. } + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + destruct (Hpo_srcs x) as [? [? ?]];auto. rewrite -(progress_to_node_of_node tid x);auto. + rewrite /eid. apply progress_lt_po;auto. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitL;alloc_graph_res;done. + } + + (** get lob *) + iDestruct ("Hef" with "[E_R] Ed_po Ed_ctrl Ed_addr") as "#E_lob". + { iApply (event_node with "E_R"). } + + (** agree on lob *) + iDestruct (graph_edge_agree_big_pred with "Hinterp_global E_lob") as %Hlob. + + (** agree on lob_annot *) + iNamed "Hinterp_annot". + iDestruct (annot_agree_big with "Hinterp_annot Hannot") as "[%Hlob_annot_dom_sub #_]". + + (** update na *) + iDestruct (na_at_progress_not_elem_of with "Hannot_at_prog") as %Hpg_not_in. + iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc _ (get_progress ts) tid gs (R addr mv eid_w) + with "[$Hinterp_annot //]") as "(Hinterp_annot & Hannot_curr)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog]") as "(Hinterp_token & Htok)". + iDestruct "Hannot_at_prog" as %Hannot_at_prog. + + iDestruct (annot_update_big with "Hinterp_annot Hannot") as ">(%lob_annot_uu&%Hannot_dom & Hinterp_annot & #Hannot_split)". + + iMod (po_pred_interp_update _ ts ((ts <| ts_iis := ts_iis ts <| iis_mem_reads := (iis_mem_reads (ts_iis ts) ++ [iis_cntr (ts_iis ts)])%list |> |>) + <| ts_reqs := ctxt (inl (mv, None)) |> + <| ts_rmw_pred := if bool_decide (kind_v = AV_exclusive) || + bool_decide (kind_v = AV_atomic_rmw) then Some eid else ts.(ts_rmw_pred) |> + ) with "Hinterp_po_src Hpo_src") as "(Hinterp_po_src & Hpo_src)";auto. + + iExists (R addr mv eid_w), lob_annot, lob_annot_uu, (ls <|lls_pop := Some eid|>). + + iSplitL "Hfe". iSplitR. + (* show well-splittedness *) + iModIntro. iSplitR. + { iPureIntro. by apply Edge.subseteq_lob. } + { + iApply (big_sepM2_impl with "Hannot_split"). iModIntro. iIntros (k P1 P2 Hlk1 Hlk2) "Heqv". + assert (is_Some (lob_annot !! k)) as [P Hlob_annot_lk]. + { + apply elem_of_dom. apply elem_of_dom_2 in Hlk1. done. + } + (* iDestruct (big_sepM_lookup _ _ k P with "Hannot_ag") as "Heqv'". done. *) + assert (is_Some (na !! k)) as [P' Hna_lk]. + { + apply elem_of_dom. apply elem_of_dom_2 in Hlk1. + set_solver+ Hlk1 Hlob_annot_dom_sub. + } + rewrite lookup_insert_ne. 2:{ apply elem_of_dom_2 in Hna_lk. set_solver+ Hna_lk Hpg_not_in. } + rewrite Hna_lk /=. iNext. rewrite wand_iff_sym //. + } + + (** getting out resources from FE *) + { + iModIntro. repeat iNamed 1. iSpecialize ("Hfe" $! mv eid_w). + + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. + iDestruct (big_sepS_elem_of _ _ eid_w with "R_obs_in") as "R_in". + rewrite /Graph.obs_pred_of. set_solver+ Hobs. + iSpecialize ("R_in" with "E_W"). + rewrite iris_extra.big_sepS_to_map. + iDestruct ("Hfe" with "[R_lob_in $R_in]") as "Hfe". + { + iFrame "#". iSplitR. iSplit;[|done]. iExists _, _. iFrame "E_W". + iApply (big_sepM_proper with "R_lob_in");auto. } + iApply step_fupd_frame_l. + iSplitR "Hfe";last done. + { iModIntro. iIntros (????) "E_W'". iDestruct (event_agree with "E_R E_W'") as %Heq. exfalso. done. } + { set_solver+ Hlob. } + } + + iDestruct (na_at_progress_not_elem_of with "[]") as %Hna_not_in. + iPureIntro. exact Hannot_at_prog. + iSplitL "Hinterp_annot Hinterp_token". + { + rewrite -insert_union_r. rewrite -assoc_L. rewrite insert_union_singleton_l. + rewrite insert_union_singleton_l. iFrame "Hinterp_annot". + rewrite !dom_union_L dom_singleton_L. + assert ((dom lob_annot_uu ∪ dom na) = dom na) as ->. + { rewrite Hannot_dom. set_solver+ Hlob_annot_dom_sub. } + by iFrame. + apply not_elem_of_dom. rewrite Hannot_dom. set_solver+ Hna_not_in Hlob_annot_dom_sub. + } + + iSplitL "Hinterp_local_lws Hinterp_po_src". + { + iSplitL "Hinterp_local_lws". + + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;last done. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + erewrite progress_to_node_mk_eid_ii;done. + } + + iExists mv, eid_w. iModIntro. iSplit. + + erewrite progress_to_node_mk_eid_ii;last reflexivity. + rewrite /readreq_of_store /AACandExec.Candidate.kind_of_rreq_is_atomic /AACandExec.Candidate.kind_of_rreq_P //. + iFrame "E_R Ed_po Ed_ctrl Ed_rf Ed_addr Hpo_src". iSplitR. iSplit;[|done]. iExists _, _. iFrame "E_W". + iFrame. + Qed. + + Lemma mem_read_external_with_local `{!UserProt} {tid : Tid} {o_po_src ts ctxt dep addr kind_s kind_v kind_s' kind_v' leid lval} + R po_srcs lob_annot + : + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemRead 8 (readreq_of_store kind_s kind_v addr dep)) ctxt -> + let eid := progress_to_node (get_progress ts) tid in + let R_graph_facts := (λ val eid_w, + eid -{E}> (Event.R kind_s kind_v addr val) ∗ + (* Po *) + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + (* Addr *) + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep), eid_addr_src -{(Edge.Addr)}> eid) ∗ + (* There must be a write with same addr and val *) + (∃ kind_s_w kind_v_w, eid_w -{E}> (Event.W kind_s_w kind_v_w addr val)) ∗ + (* [optional] rf from write to read *) + eid_w -{(Edge.Rf)}> eid)%I in + o_po_src -{LPo}> -∗ + ([∗ set] e_po_src ∈ po_srcs, e_po_src -{Po}>) -∗ + last_local_write tid addr (Some leid) -∗ + leid -{E}> (Event.W kind_s' kind_v' addr lval) -∗ + (* node annotations *) + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) -∗ + (* Lob edge formers *) + (eid -{N}> (Edge.R kind_s kind_v) -∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{Edge.Po}> eid) -∗ + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) -∗ + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep), eid_addr_src -{(Edge.Addr)}> eid) -∗ + [∗ set] eid_pre ∈ dom lob_annot, eid_pre -{Edge.Lob}> eid) -∗ + (* FE *) + (∀ val eid_w, + R_graph_facts val eid_w ∗ + ⌜EID.tid eid_w ≠ tid⌝ ∗ + ([∗ map] _ ↦ annot ∈ lob_annot, annot) ∗ + □(prot addr val eid_w) + ={⊤}[∅]▷=∗ + R addr val eid_w) -∗ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* exists a val, a write kind, and a write eid_w *) + ∃ val eid_w, + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSNormal ((ThreadState.incr_cntr (ts <| ts_iis := (ts.(ts_iis) + <| iis_mem_reads := ((ts.(ts_iis).(iis_mem_reads)) ++ [ts.(ts_iis).(iis_cntr)])%list|>)|>)) + <| ts_reqs := ctxt (inl(val, None)) |> + <| ts_rmw_pred := if bool_decide (kind_v = AV_exclusive) || + bool_decide (kind_v = AV_atomic_rmw) + then Some eid else ts.(ts_rmw_pred) |>)⌝ ∗ + R_graph_facts val eid_w ∗ + (Some eid) -{LPo}> ∗ + (* node annotation *) + (((eid ↦ₐ R addr val eid_w) ∗ ⌜EID.tid eid_w ≠ tid⌝) ∨ ⌜val = lval⌝) ∗ + (* ([∗ map] node ↦ annot ∈ lob_annot_uu, node ↦ₐ annot) ∗ *) + (* local writes at addr is unchanged *) + last_local_write tid addr (Some leid) + }}. + Proof. + iIntros (Hreqs ??) "Hpo_src Hpo_srcs Hlocal Hlnode Hannot Hef Hfe". + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + (* Hstep gives that a read event is happening *) + inversion_step Hstep. + + (* get the write *) + feed pose proof (Graph.wf_read_inv _ _ _ addr kind_s kind_v mv Hgraph_wf Hgr_lk) as Hrf;simpl; + [rewrite /AACandExec.Candidate.kind_of_rreq_P /=; repeat (case_bool_decide;[|contradiction]);done| destruct Hrf as (eid_w & kind_s_w & kind_v_w & E_w &Hgr_lk_w&HE_w&?)]. + + iNamed "Hinterp_local". + iDestruct (last_write_interp_agree_Some with "Hinterp_local_lws Hlocal") as "(%Elw & %Hleid & %Hw & %Hltid & %Hlpg & %Hlw)". + efeed specialize Hlw; [exact Hgr_lk_w|eauto|]. eapply AAConsistent.event_is_write_with_impl_addr;done. + + iDestruct (po_pred_interp_agree_big' with "Hinterp_po_src Hpo_srcs") as %Hpo_srcs. + iDestruct (po_pred_interp_agree with "Hinterp_po_src Hpo_src") as %Hpo. + + epose proof (AAConsistent.event_is_write_with_elem_of_mem_writes eid_w _ _ _ _ _ Hgr_lk_w HE_w) as Heid_w. + + subst eid. set (eid := (mk_eid_ii ts tid)). + + destruct Hlw as [Hne_tid | [[Hlw Htid] | [Hlw Htid]]]. + 2:{(* reading from later writes *) + exfalso. + pose proof (Graph.wf_rfi_inv eid_w eid Hgraph_wf Hgraph_co H2 Htid) as Hpo'. + erewrite <-(progress_to_node_of_node tid eid_w Htid) in Hpo'. + erewrite <-(progress_to_node_of_node tid eid) in Hpo';[|done]. + rewrite -progress_lt_po in Hpo';[|done]. destruct Hpo'. + rewrite /eid. by apply progress_le_gt_False in Hlw. + } + { + + assert (Hobs : (eid_w, eid) ∈ AAConsistent.obs (gs.(GlobalState.gs_graph))). + { apply elem_of_union_l. apply elem_of_union_l. apply elem_of_filter. split. rewrite /= //. done. } + + (** allocate resources *) + iAssert (eid -{E}> Event.R kind_s kind_v addr mv ∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{Edge.Po}> progress_to_node (get_progress ts) tid) ∗ + ([∗ set] eid_ctrl_src ∈ ts_ctrl_srcs ts, eid_ctrl_src -{Edge.Ctrl}> eid) ∗ + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep), eid_addr_src -{(Edge.Addr)}> eid) ∗ + eid_w -{E}> Event.W kind_s_w kind_v_w addr mv ∗ + eid_w -{Edge.Rf}> eid)%I as "(E_R & Ed_po & Ed_ctrl & Ed_addr & E_W & Ed_rf)". + { + rewrite edge_eq /edge_def. rewrite event_eq /event_def. iNamed "Hinterp_global". + + iSplitL. alloc_graph_res. + { rewrite /AACandExec.Candidate.kind_of_rreq_P /=; repeat case_bool_decide;try contradiction;auto. } + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + destruct (Hpo_srcs x) as [? [? ?]];auto. rewrite -(progress_to_node_of_node tid x);auto. + rewrite /eid. apply progress_lt_po;auto. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitL;alloc_graph_res;done. + } + + (** get lob *) + iDestruct ("Hef" with "[E_R] Ed_po Ed_ctrl Ed_addr") as "#E_lob". + { iApply (event_node with "E_R"). } + + (** agree on lob *) + iDestruct (graph_edge_agree_big_pred with "Hinterp_global E_lob") as %Hlob. + + (** agree on lob_annot *) + iNamed "Hinterp_annot". + iDestruct (annot_agree_big with "Hinterp_annot Hannot") as "[%Hlob_annot_dom_sub #_]". + + (** update na *) + iDestruct (na_at_progress_not_elem_of with "Hannot_at_prog") as %Hpg_not_in. + iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc _ (get_progress ts) tid gs (R addr mv eid_w) + with "[$Hinterp_annot //]") as "(Hinterp_annot & Hannot_curr)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog]") as "(Hinterp_token & Htok)". + iDestruct "Hannot_at_prog" as %Hannot_at_prog. + + iDestruct (annot_update_big with "Hinterp_annot Hannot") as ">(%lob_annot_uu&%Hannot_dom & Hinterp_annot & #Hannot_split)". + + iMod (po_pred_interp_update _ ts ((ts <| ts_iis := ts_iis ts <| iis_mem_reads := (iis_mem_reads (ts_iis ts) ++ [iis_cntr (ts_iis ts)])%list |> |>) + <| ts_reqs := ctxt (inl (mv, None)) |> + <| ts_rmw_pred := if bool_decide (kind_v = AV_exclusive) || + bool_decide (kind_v = AV_atomic_rmw) then Some eid else ts.(ts_rmw_pred) |> + ) with "Hinterp_po_src Hpo_src") as "(Hinterp_po_src & Hpo_src)";auto. + + iExists (R addr mv eid_w), lob_annot, lob_annot_uu, (ls <|lls_pop := Some eid|>). + + iSplitL "Hfe". iSplitR. + (* show well-splittedness *) + iModIntro. iSplitR. + { iPureIntro. by apply Edge.subseteq_lob. } + { + iApply (big_sepM2_impl with "Hannot_split"). iModIntro. iIntros (k P1 P2 Hlk1 Hlk2) "Heqv". + assert (is_Some (lob_annot !! k)) as [P Hlob_annot_lk]. + { + apply elem_of_dom. apply elem_of_dom_2 in Hlk1. done. + } + (* iDestruct (big_sepM_lookup _ _ k P with "Hannot_ag") as "Heqv'". done. *) + assert (is_Some (na !! k)) as [P' Hna_lk]. + { + apply elem_of_dom. apply elem_of_dom_2 in Hlk1. + set_solver+ Hlk1 Hlob_annot_dom_sub. + } + rewrite lookup_insert_ne. 2:{ apply elem_of_dom_2 in Hna_lk. set_solver+ Hna_lk Hpg_not_in. } + rewrite Hna_lk /=. iNext. rewrite wand_iff_sym //. + } + + (** getting out resources from FE *) + { + iModIntro. repeat iNamed 1. iSpecialize ("Hfe" $! mv eid_w). + + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. + iDestruct (big_sepS_elem_of _ _ eid_w with "R_obs_in") as "R_in". + rewrite /Graph.obs_pred_of. set_solver + Hobs. + iSpecialize ("R_in" with "E_W"). + rewrite iris_extra.big_sepS_to_map. + iDestruct ("Hfe" with "[R_lob_in $R_in]") as "Hfe". + { + iFrame "#". iSplitR. iExists _, _. iFrame "E_W". iSplit; [done|]. + iApply (big_sepM_proper with "R_lob_in");auto. } + iApply step_fupd_frame_l. + iSplitR "Hfe";last done. + { iModIntro. iIntros (????) "E_W'". iDestruct (event_agree with "E_R E_W'") as %Heq. exfalso. done. } + { set_solver + Hlob. } + } + + iDestruct (na_at_progress_not_elem_of with "[]") as %Hna_not_in. + iPureIntro. exact Hannot_at_prog. + iSplitL "Hinterp_annot Hinterp_token". + { + rewrite -insert_union_r. rewrite -assoc_L. rewrite insert_union_singleton_l. + rewrite insert_union_singleton_l. iFrame "Hinterp_annot". + rewrite !dom_union_L dom_singleton_L. + assert ((dom lob_annot_uu ∪ dom na) = dom na) as ->. + { rewrite Hannot_dom. set_solver + Hlob_annot_dom_sub. } + by iFrame. + apply not_elem_of_dom. rewrite Hannot_dom. set_solver + Hna_not_in Hlob_annot_dom_sub. + } + + iSplitL "Hinterp_local_lws Hinterp_po_src". + { + iSplitL "Hinterp_local_lws". + + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;last done. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + erewrite progress_to_node_mk_eid_ii;done. + } + + iExists mv, eid_w. iModIntro. iSplit. + + erewrite progress_to_node_mk_eid_ii;last reflexivity. + rewrite /readreq_of_store /AACandExec.Candidate.kind_of_rreq_is_atomic /AACandExec.Candidate.kind_of_rreq_P //. + iFrame "E_R Ed_po Ed_ctrl Ed_rf Ed_addr Hpo_src". iSplitR. iExists _, _. iFrame "E_W". + iFrame. + iLeft. + iFrame. + done. + } + + (** allocate resources *) + iAssert (eid -{E}> Event.R kind_s kind_v addr mv ∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{Edge.Po}> progress_to_node (get_progress ts) tid) ∗ + ([∗ set] eid_ctrl_src ∈ ts_ctrl_srcs ts, eid_ctrl_src -{Edge.Ctrl}> eid) ∗ + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep), eid_addr_src -{(Edge.Addr)}> eid) ∗ + eid_w -{E}> Event.W kind_s_w kind_v_w addr mv ∗ + eid_w -{Edge.Rf}> eid)%I as "(E_R & Ed_po & Ed_ctrl & Ed_addr & E_W & Ed_rf)". + { + rewrite edge_eq /edge_def. rewrite event_eq /event_def. iNamed "Hinterp_global". + + iSplitL. alloc_graph_res. + { rewrite /AACandExec.Candidate.kind_of_rreq_P /=; repeat case_bool_decide;try contradiction;auto. } + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + destruct (Hpo_srcs x) as [? [? ?]];auto. rewrite -(progress_to_node_of_node tid x);auto. + rewrite /eid. apply progress_lt_po;auto. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitL;alloc_graph_res;done. + } + + iNamed "Hinterp_annot". + (** update na *) + iDestruct (na_at_progress_not_elem_of with "Hannot_at_prog") as %Hpg_not_in. + iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc _ (get_progress ts) tid gs True + with "[$Hinterp_annot //]") as "(Hinterp_annot & Hannot_curr)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog]") as "(Hinterp_token & Htok)". + iDestruct "Hannot_at_prog" as %Hannot_at_prog. + (* iDestruct (annot_update_big with "Hinterp_annot Hannot") as ">(%lob_annot_uu&%Hannot_dom & Hinterp_annot & #Hannot_split)". *) + iMod (po_pred_interp_update _ ts ((ts <| ts_iis := ts_iis ts <| iis_mem_reads := (iis_mem_reads (ts_iis ts) ++ [iis_cntr (ts_iis ts)])%list |> |>) + <| ts_reqs := ctxt (inl (mv, None)) |> + <| ts_rmw_pred := if bool_decide (kind_v = AV_exclusive) || + bool_decide (kind_v = AV_atomic_rmw) then Some eid else ts.(ts_rmw_pred) |> + ) with "Hinterp_po_src Hpo_src") as "(Hinterp_po_src & Hpo_src)";auto. + + iExists (True)%I, ∅, ∅, (ls <|lls_pop := Some eid|>). + iSplitL "". iSplitR. + iModIntro. iSplitR. + { iPureIntro. set_solver +. } + { by iApply big_sepM2_empty. } + { iModIntro. iNamed 1. + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. + iApply step_fupd_frame_l. + iSplitR "". + { iModIntro. iIntros (????) "E_W'". iDestruct (event_agree with "E_R E_W'") as %Heq. exfalso. done. } + iApply fupd_mask_intro; set_solver+. + } + iDestruct (na_at_progress_not_elem_of with "[]") as %Hna_not_in. + iPureIntro. exact Hannot_at_prog. + iSplitL "Hinterp_annot Hinterp_token". + { + unfold my_annot_interp. + rewrite insert_union_singleton_l. + rewrite map_union_empty. iFrame. + rewrite dom_union_L. + rewrite dom_singleton_L. + by iFrame. + } + + iSplitL "Hinterp_local_lws Hinterp_po_src". + { + iSplitL "Hinterp_local_lws". + + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;last done. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + erewrite progress_to_node_mk_eid_ii; done. + } + + iExists mv, eid_w. iModIntro. iSplit. + + erewrite progress_to_node_mk_eid_ii;last reflexivity. + rewrite /readreq_of_store /AACandExec.Candidate.kind_of_rreq_is_atomic /AACandExec.Candidate.kind_of_rreq_P //. + iFrame "E_R Ed_po Ed_ctrl Ed_rf Ed_addr Hpo_src". iSplitR. iExists _, _. iFrame "E_W". + iFrame. + iRight. + destruct (decide (leid = eid_w)). + { + rewrite e. + iDestruct(event_agree with "Hlnode E_W") as "%Heq". + iPureIntro. + congruence. + } + assert(Hlw' : progress_of_node eid_w

. + simpl in Hedge. + iPureIntro. + set_solver+ Hedge. + } + assert(Hfr : (eid, leid) ∈ AACandExec.Candidate.fr (GlobalState.gs_graph gs)). + { + set_solver+ Hco Hrf. + } + unfold eid0 in Hgr_lk. + fold eid in Hgr_lk. + assert(Hpo'' : (leid, eid) ∈ AACandExec.Candidate.po (GlobalState.gs_graph gs)). + { + rewrite -(progress_to_node_of_node tid leid). + rewrite -(progress_to_node_of_node tid eid). + apply progress_lt_po. + + assumption. + + split. { assumption. } + rewrite /progress_is_valid. rewrite !progress_to_node_of_node; [|by unfold eid|assumption]. + set_solver+ Hleid Hgr_lk. + + by unfold eid. + + assumption. + } + assert(Hloc : (leid, eid) ∈ AACandExec.Candidate.loc (GlobalState.gs_graph gs)). + { + unfold AAConsistent.event_is_write_with_addr in Hw. + unfold AAConsistent.event_is_write_with_P in Hw. + set_unfold. + exists Elw, (AAInter.IEvent req resp), addr. + split; [assumption|]. + split. { destruct Elw. destruct o; try contradiction. rewrite CBool.bool_unfold in Hw. subst. simpl. + unfold AAConsistent.addr_of_wreq in Hw. by destruct Hw as [_ ->]. } + split; [assumption|]. + reflexivity. + } + destruct Hgraph_co as [Hinternal _ _]. + set(internal := (AACandExec.Candidate.po (GlobalState.gs_graph gs) ∩ AACandExec.Candidate.loc (GlobalState.gs_graph gs) + ∪ AAConsistent.ca (GlobalState.gs_graph gs) ∪ AACandExec.Candidate.rf (GlobalState.gs_graph gs))). + assert(Hpo_int : (leid, eid) ∈ internal). { set_solver+ internal Hpo'' Hloc. } + assert(Hfr_int : (eid, leid) ∈ internal). { set_solver+ internal Hfr. } + assert(Hcyc : (leid, leid) ∈ GRel.grel_plus internal). + { apply (GRel.grel_plus_trans _ leid eid leid); apply GRel.grel_plus_once; assumption. } + rewrite GRel.grel_irreflexive_spec in Hinternal. + exfalso. + specialize (Hinternal (leid, leid)). simpl in Hinternal. + by apply Hinternal. + Qed. +End rules. diff --git a/theories/low/rules/reg.v b/theories/low/rules/reg.v new file mode 100644 index 0000000..fe22ba8 --- /dev/null +++ b/theories/low/rules/reg.v @@ -0,0 +1,129 @@ +(* This file contains the low-level proof rules for register operations *) +From self.low.rules Require Import prelude. + +Import uPred. + +Section rules. + Context `{AAIrisG} `{Htg: !ThreadGNL}. + Import ThreadState. + + Lemma reg_write `{!UserProt} {tid : Tid} {ts ctxt b reg o_dep val}: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.RegWrite reg b o_dep val) ctxt -> + ⊢ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSNormal ((incr_cntr ts) <| ts_regs := <[reg := mk_regval val (LThreadStep.deps_of_depon tid ts o_dep)]>(ts.(ts_regs)) |> + <| ts_reqs := (ctxt tt) |>) ⌝ + }}. + Proof. + iIntros (Hreqs). + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + + (* Hstep gives that a reg-write event is happening *) + inversion_step Hstep. + + set (eid := (mk_eid_ii ts tid)). + + (* update na *) + iNamed "Hinterp_annot". iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc na (get_progress ts) tid gs emp%I with "[$Hinterp_annot $Hannot_at_prog //]") as "(Hinterp_annot & _)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog //]") as "(Hinterp_token & _)". + + iExists emp%I, ∅, ∅, ls. + iModIntro. iSplitR; [iSplitR |]. { by iApply empty_na_splitting_wf. } + + (** getting out resources from FE *) + { + repeat iNamed 1. iApply step_fupd_intro;first auto. + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. iNext. + + iSplitL. iModIntro. iIntros (????) "E_W'". + iDestruct (graph_event_agree with "Hinterp_global E_W'") as %Heq. + destruct Heq as [? [Hlk ?]]. + rewrite Hlk in Hgr_lk. inversion Hgr_lk. subst x. contradiction. done. + } + + iSplitL "Hinterp_annot Hinterp_token". + { rewrite -map_union_assoc. rewrite map_empty_union. rewrite insert_union_singleton_l. + iFrame. rewrite dom_union_L dom_singleton_L. by iFrame. } + iSplitL "Hinterp_local";last done. + { + iNamed "Hinterp_local". iSplitL "Hinterp_local_lws". + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;eauto. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + iApply (po_pred_interp_skip with "Hinterp_po_src");auto. + } + Qed. + + Lemma reg_read `{!UserProt} {tid : Tid} {ts ctxt b reg val}: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.RegRead reg b) ctxt -> + ts.(ts_regs) !! reg = Some (val : RegVal) -> + ⊢ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSNormal ((incr_cntr ts) <| ts_reqs := (ctxt (val.(reg_val))) |>) ⌝ + }}. + Proof. + iIntros (Hreqs Hreg). + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + + (* Hstep gives that a reg-write event is happening *) + inversion_step Hstep. + + set (eid := (mk_eid_ii ts tid)). + + (* update na *) + iNamed "Hinterp_annot". iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc na (get_progress ts) tid gs emp%I with "[$Hinterp_annot $Hannot_at_prog //]") as "(Hinterp_annot & _)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog //]") as "(Hinterp_token & _)". + + iExists emp%I, ∅, ∅, ls. + iModIntro. iSplitR; [iSplitR |]. { by iApply empty_na_splitting_wf. } + + (** getting out resources from FE *) + { + repeat iNamed 1. iApply step_fupd_intro;first auto. + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. iNext. + + iSplitL. iModIntro. iIntros (????) "E_W'". + iDestruct (graph_event_agree with "Hinterp_global E_W'") as %Heq. + destruct Heq as [? [Hlk ?]]. + rewrite Hlk in Hgr_lk. inversion Hgr_lk. subst x. contradiction. + done. + } + + iSplitL "Hinterp_annot Hinterp_token". + { rewrite -map_union_assoc. rewrite map_empty_union. rewrite insert_union_singleton_l. + iFrame. rewrite dom_union_L dom_singleton_L. by iFrame. } + iSplitL "Hinterp_local". + { + iNamed "Hinterp_local". iSplitL "Hinterp_local_lws". + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;eauto. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + iApply (po_pred_interp_skip with "Hinterp_po_src");auto. + } + + destruct H5 as [? [Hlk <-]]. rewrite Hreg in Hlk. inversion Hlk. done. + Qed. + +End rules. diff --git a/theories/low/rules/util.v b/theories/low/rules/util.v new file mode 100644 index 0000000..5126af8 --- /dev/null +++ b/theories/low/rules/util.v @@ -0,0 +1,71 @@ +(* This file contains the low-level proof rules for auxiliary operations *) +From self.low.rules Require Import prelude. + +Import uPred. + +Section rules. + Context `{AAIrisG} `{Htg: !ThreadGNL}. + + Import ThreadState. + + Lemma reload `{!UserProt} {tid : Tid} {ts instr val}: + ThreadState.ts_reqs ts = EmptyInterp -> + ts.(ts_regs) !! RNPC = Some (val : RegVal) -> + (val.(reg_val)) ↦ᵢ instr -∗ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSNormal ((reset_cntr ts) <| ts_reqs := (InstrInterp instr) |>) ⌝ + }}. + Proof. + iIntros (Hreqs Hreg) "Hinstr". + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + { + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + done. + } + + iDestruct (instr_agree_Some with "Hinterp_global Hinstr") as %Hinstr_lk. + (* Hstep gives that a reload/terminating event is happening *) + inversion_step Hstep. + 2:{ (* not terminating *) rewrite Hreg in H4. inversion H4. subst val. rewrite Hinstr_lk // in H5. } + rewrite Hreg in H5. inversion H5. subst val. rewrite Hinstr_lk in H6. inversion H6. + + iModIntro. iSplitL "Hinterp_local";last done. + { iNamed "Hinterp_local". iSplitL "Hinterp_local_lws". + iApply (last_write_interp_progress_non_write' with "Hinterp_local_lws");auto. + iApply (po_pred_interp_skip' with "Hinterp_po_src");auto. + } + Qed. + + Lemma terminate `{!UserProt} {tid : Tid} {ts val}: + ThreadState.ts_reqs ts = EmptyInterp -> + ts.(ts_regs) !! RNPC = Some (val : RegVal) -> + (val.(reg_val)) ↦ᵢ - -∗ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSDone ts ⌝ + }}. + Proof. + iIntros (Hreqs Hreg) "Hinstr". + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + { + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + done. + } + + iDestruct (instr_agree_None with "Hinterp_global Hinstr") as %Hinstr_lk. + + (* Hstep gives that a reload/terminating event is happening *) + inversion_step Hstep. + { (* not reload *) rewrite Hreg in H5. inversion H5. subst val. rewrite Hinstr_lk // in H6. } + + iModIntro. iSplitL "Hinterp_local";last done. iFrame. + Qed. + +End rules. diff --git a/theories/low/rules/write.v b/theories/low/rules/write.v new file mode 100644 index 0000000..d6fc6b9 --- /dev/null +++ b/theories/low/rules/write.v @@ -0,0 +1,181 @@ +(* This file contains the low-level proof rules for (non-exclusive) memory writes *) +From self.low.rules Require Import prelude. + +Import uPred. + +Section rules. + Context `{AAIrisG} `{Htg: !ThreadGNL}. + Import ThreadState. + + Lemma mem_write_non_xcl `{!UserProt} {tid : Tid} {o_po_src ts ctxt addr kind_s kind_v val ot_coi_pred dep_addr dep_data} R po_srcs lob_annot: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemWrite 8 (writereq_of_store kind_s kind_v val addr dep_addr dep_data)) ctxt -> + kind_v = AV_plain -> + let eid := progress_to_node (get_progress ts) tid in + let R_graph_facts := (eid -{E}> (Event.W kind_s kind_v addr val) ∗ + (* Po *) + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + (* Data *) + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep_addr), eid_addr_src -{(Edge.Addr)}> eid) ∗ + (* Addr *) + ([∗ set] eid_data_src ∈ LThreadStep.deps_of_depon tid ts (Some dep_data), eid_data_src -{(Edge.Data)}> eid) ∗ + (* There must be a write with same addr and val *) + from_option (λ eid_coi_pred, ⌜EID.tid eid_coi_pred = tid⌝ ∗ eid_coi_pred -{(Edge.Co)}> eid) emp ot_coi_pred)%I in + o_po_src -{LPo}> -∗ + ([∗ set] e_po_src ∈ po_srcs, e_po_src -{Po}>) -∗ + last_local_write tid addr ot_coi_pred -∗ + (* node annotations *) + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) -∗ + (* Lob edge formers *) + (eid -{N}> (Edge.W kind_s kind_v) -∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) -∗ + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) -∗ + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep_addr), eid_addr_src -{(Edge.Addr)}> eid) -∗ + ([∗ set] eid_data_src ∈ LThreadStep.deps_of_depon tid ts (Some dep_data), eid_data_src -{(Edge.Data)}> eid) -∗ + [∗ set] eid_pre ∈ dom lob_annot, eid_pre -{Edge.Lob}> eid) -∗ + (* FE *) + (R_graph_facts ∗ ([∗ map] _ ↦ annot ∈ lob_annot, annot) + ={⊤}[∅]▷=∗ + R eid ∗ □(prot addr val eid)) -∗ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* exists a bool (indicating if the (atomic) write succeeded) *) + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSNormal ((ThreadState.incr_cntr ts) + <| ts_reqs := ctxt (inl None) |>)⌝ ∗ + R_graph_facts ∗ + (* R flowing in via lob *) + (eid ↦ₐ R eid) ∗ + (* eid is the latest po pred *) + (Some eid) -{LPo}> ∗ + (* local writes at addr is updated *) + last_local_write tid addr (Some eid) + }}. + Proof. + iIntros (Hreqs -> ? ?) "Hpo_src Hpo_srcs Hlocal Hannot Hef Hfe". + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + (* Hstep gives that a read event is happening *) + inversion_step Hstep; resolve_atomic. + + subst eid. set (eid := (mk_eid_ii ts tid)). + iNamed "Hinterp_local". + iDestruct (po_pred_interp_agree with "Hinterp_po_src Hpo_src") as %Hpo. + iDestruct (po_pred_interp_agree_big' with "Hinterp_po_src Hpo_srcs") as %Hpo_src. + + (** allocate resources *) + iDestruct (last_local_write_co with "Hinterp_global Hinterp_local_lws Hlocal") as "#Ed_co";[done|done|done| |]. + simpl;case_bool_decide;done. + + iAssert R_graph_facts as "#(E_W & Ed_po & Ed_ctrl & Ed_addr & Ed_data & _)". + { + rewrite /R_graph_facts edge_eq /edge_def. rewrite event_eq /event_def. iNamed "Hinterp_global". + + iSplitR;first alloc_graph_res. + { rewrite /AACandExec.Candidate.kind_of_wreq_P /=. repeat case_bool_decide;try contradiction;auto. } + + iSplitL. iApply big_sepS_forall. iIntros (??). alloc_graph_res. + destruct (Hpo_src x) as [? [? ?]];auto. rewrite -(progress_to_node_of_node tid x);auto. + rewrite /eid. apply progress_lt_po;auto. + + iSplitR. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitR. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitR. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iFrame "Ed_co". + } + + (** get lob *) + iDestruct ("Hef" with "[E_W] Ed_po Ed_ctrl Ed_addr Ed_data") as "#E_lob". + { iApply (event_node with "E_W"). } + + (** agree on lob *) + iDestruct (graph_edge_agree_big_pred with "Hinterp_global E_lob") as %Hlob. + + (** agree on lob_annot *) + iNamed "Hinterp_annot". + iDestruct (annot_agree_big with "Hinterp_annot Hannot") as "[%Hlob_annot_dom_sub #_]". + + (** update na *) + iDestruct (na_at_progress_not_elem_of with "Hannot_at_prog") as %Hpg_not_in. + iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc _ (get_progress ts) tid gs (R eid) with "[$Hinterp_annot //]") as "(Hinterp_annot & Hannot_curr)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog]") as "(Hinterp_token & Htok)". + iDestruct "Hannot_at_prog" as %Hannot_at_prog. + + iDestruct (annot_update_big with "Hinterp_annot Hannot") as ">(%lob_annot_uu&%Hannot_dom & Hinterp_annot & #Hannot_split)". + + (** update ls*) + iMod (po_pred_interp_update _ ts (ts <| ts_reqs := ctxt (inl None) |>) with "Hinterp_po_src Hpo_src") as "(Hinterp_po_src & Hpo_src)";auto. + + iExists (R eid), lob_annot, lob_annot_uu, (ls <|lls_lws := <[addr := (Some (progress_to_node (get_progress ts) tid))]>ls.(lls_lws)|> + <| lls_pop := Some eid|>). + iSplitL "Hfe". iSplitR. + (* show well-splittedness *) + iModIntro. iSplit. + { iPureIntro. by apply Edge.subseteq_lob. } + { + iApply (big_sepM2_impl with "Hannot_split"). iModIntro. iIntros (k P1 P2 Hlk1 Hlk2) "Heqv". + assert (is_Some (lob_annot !! k)) as [P Hlob_annot_lk]. + { + apply elem_of_dom. apply elem_of_dom_2 in Hlk1. done. + } + assert (is_Some (na !! k)) as [P' Hna_lk]. + { + apply elem_of_dom. apply elem_of_dom_2 in Hlk1. + set_solver + Hlk1 Hlob_annot_dom_sub. + } + rewrite lookup_insert_ne. 2:{ apply elem_of_dom_2 in Hna_lk. set_solver + Hna_lk Hpg_not_in. } + rewrite Hna_lk /=. iNext. rewrite wand_iff_sym //. + } + + (** pushing resources into FE *) + { + iModIntro. repeat iNamed 1. + + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. + rewrite iris_extra.big_sepS_to_map. + 2:{ set_solver + Hlob. } + iDestruct ("Hfe" with "[R_lob_in]") as ">Hfe". + { iFrame "E_W Ed_po Ed_ctrl Ed_addr Ed_data Ed_co". iApply (big_sepM_proper with "R_lob_in");auto. } + + iModIntro. iNext. + iDestruct (fupd_frame_l with "[E_W Hfe]") as "Hfe". iSplitR. iExact "E_W". iExact "Hfe". + iApply (fupd_mono with "Hfe"). iIntros "[#E_W [$ #R_prot]]". + iModIntro. iIntros (????) "E_W'". iDestruct (event_agree with "E_W E_W'") as %Heq. + inversion Heq;subst. iFrame "R_prot". + } + + iDestruct (na_at_progress_not_elem_of with "[]") as %Hna_not_in. + iPureIntro. exact Hannot_at_prog. + iSplitL "Hinterp_annot Hinterp_token". + { + rewrite -insert_union_r. rewrite -assoc_L. rewrite insert_union_singleton_l. + rewrite insert_union_singleton_l. iFrame "Hinterp_annot". + rewrite !dom_union_L dom_singleton_L. + assert ((dom lob_annot_uu ∪ dom na) = dom na) as ->. + { rewrite Hannot_dom. set_solver + Hlob_annot_dom_sub. } + by iFrame. + apply not_elem_of_dom. rewrite Hannot_dom. set_solver + Hna_not_in Hlob_annot_dom_sub. + } + + (* update and frame [my_local_interp] *) + iDestruct (last_write_interp_progress_write _ (ts <| ts_reqs := ctxt (inl None) |>) with "Hinterp_local_lws Hlocal") as ">[$ $]". + done. done. eexists. erewrite progress_to_node_mk_eid_ii;last reflexivity. split. exact Hgr_lk. + simpl. case_bool_decide;done. + iFrame "Hinterp_po_src". + + iModIntro. iSplit. iPureIntro. done. + iFrame "E_W Ed_po Ed_ctrl Ed_addr Ed_data Ed_co". by iFrame "Hannot_curr Hpo_src". + Qed. + +End rules. diff --git a/theories/low/rules/write_xcl.v b/theories/low/rules/write_xcl.v new file mode 100644 index 0000000..76c50af --- /dev/null +++ b/theories/low/rules/write_xcl.v @@ -0,0 +1,308 @@ +(* This file contains the low-level proof rules for exclusive memory writes *) +From self.low.rules Require Import prelude. + +Import uPred. + +Section rules. + Context `{AAIrisG} `{Htg: !ThreadGNL}. + Import ThreadState. + (** rules *) + Lemma mem_write_xcl_None `{!UserProt} {tid : Tid} {ts ctxt addr kind_s kind_v val dep_addr dep_data}: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemWrite 8 (writereq_of_store kind_s kind_v val addr dep_addr dep_data)) ctxt -> + ThreadState.ts_rmw_pred ts = None -> + kind_v = AV_atomic_rmw ∨ kind_v = AV_exclusive -> + let eid := progress_to_node (get_progress ts) tid in + ⊢ SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSNormal ((ThreadState.incr_cntr ts) + <| ts_reqs := ctxt (inl (Some false)) |>)⌝ + }}. + Proof. + iIntros (Hreqs Hrmw_src Hatomic ?). + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + + inversion_step Hstep. + destruct Hatomic;subst kind_v;resolve_atomic. inversion H3. inversion H3. + rewrite Hrmw_src in H4. inversion H4. + + subst eid. set (eid := (mk_eid_ii ts tid)). + + (* update na *) + iNamed "Hinterp_annot". + iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc na (get_progress ts) tid gs emp%I with "[$Hinterp_annot $Hannot_at_prog //]") as "(Hinterp_annot & _)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog //]") as "(Hinterp_token & _)". + + iExists emp%I, ∅, ∅, ls. + iModIntro. iSplitR; [iSplitR |]. { by iApply empty_na_splitting_wf. } + + (** getting out resources from FE *) + { + repeat iNamed 1. iApply step_fupd_intro;first auto. + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. iNext. + + iSplitL. iModIntro. iIntros (????) "E_W'". + iDestruct (graph_event_agree with "Hinterp_global E_W'") as %Heq. + destruct Heq as [? [Hlk ?]]. + rewrite Hlk in Hgr_lk. inversion Hgr_lk. subst x. + rewrite /AAConsistent.event_is_write_with //= in H2. + + done. + } + + iSplitL "Hinterp_annot Hinterp_token". + { rewrite -map_union_assoc. rewrite map_empty_union. rewrite insert_union_singleton_l. + iFrame. rewrite dom_union_L dom_singleton_L //. } + iSplitL "Hinterp_local";last done. + { + iNamed "Hinterp_local". iSplitL "Hinterp_local_lws". + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;eauto. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + iApply (po_pred_interp_skip with "Hinterp_po_src");auto. + } + Qed. + + Lemma mem_write_xcl_Some `{!UserProt} {tid : Tid} {o_po_src ts ctxt addr kind_s kind_v val ot_coi_pred dep_addr dep_data R_loc_in rmw_src} R po_srcs lob_annot: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemWrite 8 (writereq_of_store kind_s kind_v val addr dep_addr dep_data)) ctxt -> + ThreadState.ts_rmw_pred ts = Some rmw_src -> + kind_v = AV_atomic_rmw ∨ kind_v = AV_exclusive -> + let eid := progress_to_node (get_progress ts) tid in + let R_graph_facts := + (eid -{E}> (Event.W kind_s kind_v addr val) ∗ + (* Po *) + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + (* Data *) + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep_addr), eid_addr_src -{(Edge.Addr)}> eid) ∗ + (* Addr *) + ([∗ set] eid_data_src ∈ LThreadStep.deps_of_depon tid ts (Some dep_data), eid_data_src -{(Edge.Data)}> eid) ∗ + (* There must be a write with same addr and val *) + from_option (λ eid_coi_pred, ⌜EID.tid eid_coi_pred = tid⌝ ∗ eid_coi_pred -{(Edge.Co)}> eid) emp ot_coi_pred ∗ + (* Rmw *) + rmw_src -{(Edge.Rmw)}> eid)%I in + o_po_src -{LPo}> -∗ + ([∗ set] e_po_src ∈ po_srcs, e_po_src -{Po}>) -∗ + last_local_write tid addr ot_coi_pred -∗ + (* node annotations *) + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) -∗ + (* Lob edge formers *) + (eid -{N}> (Edge.W kind_s kind_v) -∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) -∗ + ([∗ set] eid_ctrl_src ∈ ts.(ts_ctrl_srcs), eid_ctrl_src -{(Edge.Ctrl)}> eid) -∗ + ([∗ set] eid_addr_src ∈ LThreadStep.deps_of_depon tid ts (Some dep_addr), eid_addr_src -{(Edge.Addr)}> eid) -∗ + ([∗ set] eid_data_src ∈ LThreadStep.deps_of_depon tid ts (Some dep_data), eid_data_src -{(Edge.Data)}> eid) -∗ + rmw_src -{(Edge.Rmw)}> eid -∗ + [∗ set] eid_pre ∈ dom lob_annot, eid_pre -{Edge.Lob}> eid) -∗ + (* local resources that might flow into FE *) + R_loc_in -∗ + (* FE *) + (R_loc_in ∗ R_graph_facts ∗ Tok{ eid } ∗ ([∗ map] _ ↦ annot ∈ lob_annot, annot) + ={⊤}[∅]▷=∗ + R ∗ □(prot addr val eid)) -∗ + SSWP (LThreadState.LTSNormal ts) @ tid {{ λ lts', + (* exists a bool (indicating if the (atomic) write succeeded) *) + ∃ b_succ, + (* update lts' accordingly *) + ⌜lts' = LThreadState.LTSNormal ((ThreadState.incr_cntr ts) + <| ts_reqs := ctxt (inl (Some b_succ)) |>)⌝ ∗ + if b_succ then + (* success *) + R_graph_facts ∗ + (* R flowing in via lob *) + (eid ↦ₐ R) ∗ + (Some eid) -{LPo}> ∗ + (* local writes at addr is updated *) + last_local_write tid addr (Some eid) + else + (* failure, things stay unchanged *) + o_po_src -{LPo}> ∗ + last_local_write tid addr ot_coi_pred ∗ + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) ∗ + R_loc_in + }}. + Proof. + iIntros (Hreqs Hrmw_src Hatomic ??) "Hpo_src Hpo_srcs Hlocal Hannot Hef R_loc_in Hfe". + rewrite sswp_eq /sswp_def /=. + iIntros (????) "H". iNamed "H". + inversion Hat_prog as [Hpg]. clear Hat_prog. + case_bool_decide as Hv. + 2:{ + rewrite (LThreadStep.step_progress_valid_is_reqs_nonempty _ _ _ ts) in Hv;[|done|done]. + rewrite Hreqs /EmptyInterp /= in Hv. exfalso. by apply Hv. + } + iIntros (?). iNamed 1. + + (* Hstep gives that a write event is happening *) + inversion_step Hstep. + destruct Hatomic;subst kind_v;resolve_atomic. + { (* successful case *) + iNamed "Hinterp_local". + iDestruct (po_pred_interp_agree with "Hinterp_po_src Hpo_src") as %Hpo. + iDestruct (po_pred_interp_agree_big' with "Hinterp_po_src Hpo_srcs") as %Hpo_src. + + subst eid;set (eid := (mk_eid_ii ts tid)). + + iDestruct (last_local_write_co with "Hinterp_global Hinterp_local_lws Hlocal") as "#Ed_co"; [done|done|done| |]. + simpl;case_bool_decide;done. + + (** allocate resources *) + iAssert R_graph_facts as "#(E_W & Ed_po & Ed_ctrl & Ed_addr & Ed_data & _ & Ed_rmw)". + { + rewrite /R_graph_facts edge_eq /edge_def. rewrite event_eq /event_def. iNamed "Hinterp_global". + + iSplitL;first alloc_graph_res. { + rewrite /AACandExec.Candidate.kind_of_wreq_P /=. + repeat case_bool_decide;try contradiction;auto. } + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + destruct (Hpo_src x) as [? [? ?]];auto. rewrite -(progress_to_node_of_node tid x);auto. + rewrite /eid. apply progress_lt_po;auto. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iSplitL. rewrite big_sepS_forall. iIntros (??). alloc_graph_res. + + iFrame "Ed_co". + + rewrite Hrmw_src in H4;inversion H4;subst. alloc_graph_res. done. + } + + (** get lob *) + iDestruct ("Hef" with "[E_W] Ed_po Ed_ctrl Ed_addr Ed_data Ed_rmw") as "#E_lob". + { iApply (event_node with "E_W"). } + + (** agree on lob *) + iDestruct (graph_edge_agree_big_pred with "Hinterp_global E_lob") as %Hlob. + + iNamed "Hinterp_annot". + (** agree on lob_annot *) + iDestruct (annot_agree_big with "Hinterp_annot Hannot") as "[%Hlob_annot_dom_sub #_]". + + (** update na *) + iDestruct (na_at_progress_not_elem_of with "Hannot_at_prog") as %Hpg_not_in;auto. + iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + iMod (annot_alloc _ (get_progress ts) tid gs R with "[$Hinterp_annot //]") as "(Hinterp_annot & Hannot_curr)". + iMod (token_alloc with "[$Hinterp_token $Hannot_at_prog]") as "(Hinterp_token & Htok)". + iDestruct "Hannot_at_prog" as %Hannot_at_prog. + + iDestruct (annot_update_big with "Hinterp_annot Hannot") as ">(%lob_annot_uu&%Hannot_dom & Hinterp_annot & #Hannot_split)". + + (** update ls*) + iMod (po_pred_interp_update _ ts (ts <| ts_reqs := ctxt (inl (Some true)) |>) with "Hinterp_po_src Hpo_src") as "(Hinterp_po_src & Hpo_src)";auto. + + iExists R, lob_annot, lob_annot_uu, (ls <|lls_lws := <[addr := (Some (progress_to_node (get_progress ts) tid))]>ls.(lls_lws)|> + <| lls_pop := Some eid|>). + iSplitL "Hfe R_loc_in Htok". iSplitR. + (* show well-splittedness *) + iModIntro. iSplit. + { iPureIntro. by apply Edge.subseteq_lob. } + { + iApply (big_sepM2_impl with "Hannot_split"). iModIntro. iIntros (k P1 P2 Hlk1 Hlk2) "Heqv". + assert (is_Some (lob_annot !! k)) as [P Hlob_annot_lk]. + { + apply elem_of_dom. apply elem_of_dom_2 in Hlk1. done. + } + assert (is_Some (na !! k)) as [P' Hna_lk]. + { + apply elem_of_dom. apply elem_of_dom_2 in Hlk1. + set_solver + Hlk1 Hlob_annot_dom_sub. + } + rewrite lookup_insert_ne. 2:{ apply elem_of_dom_2 in Hna_lk. set_solver + Hna_lk Hpg_not_in. } + rewrite Hna_lk /=. iNext. rewrite wand_iff_sym //. + } + + (** pushing resources into FE *) + { + iModIntro. repeat iNamed 1. + + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. + rewrite iris_extra.big_sepS_to_map. + 2:{ set_solver + Hlob. } + iDestruct ("Hfe" with "[$R_loc_in $R_lob_in $Htok]") as ">Hfe". + { iFrame "E_W Ed_po Ed_ctrl Ed_addr Ed_data Ed_co Ed_rmw". } + + iModIntro. iNext. + iDestruct (fupd_frame_l with "[E_W Hfe]") as "Hfe". iSplitR. iExact "E_W". iExact "Hfe". + iApply (fupd_mono with "Hfe"). iIntros "[#E_W [$ #R_prot]]". + iModIntro. iIntros (????) "E_W'". iDestruct (event_agree with "E_W E_W'") as %Heq. + inversion Heq;subst. iFrame "R_prot". + } + + iDestruct (na_at_progress_not_elem_of with "[]") as %Hna_not_in. + iPureIntro. exact Hannot_at_prog. + iSplitL "Hinterp_annot Hinterp_token". + { + rewrite -insert_union_r. rewrite -assoc_L. rewrite insert_union_singleton_l. + rewrite insert_union_singleton_l. iFrame "Hinterp_annot". + rewrite !dom_union_L dom_singleton_L. + assert ((dom lob_annot_uu ∪ dom na) = dom na) as ->. + { rewrite Hannot_dom. set_solver + Hlob_annot_dom_sub. } + by iFrame. + apply not_elem_of_dom. rewrite Hannot_dom. set_solver + Hna_not_in Hlob_annot_dom_sub. + } + + (* update and frame [my_local_interp] *) + rewrite /resp /=. + iDestruct (last_write_interp_progress_write _ + (ts <| ts_reqs := ctxt (inl (Some true)) |>) with "Hinterp_local_lws Hlocal") as ">[$ ?]". + done. eexists. erewrite progress_to_node_mk_eid_ii;last reflexivity. eexists. split. exact Hgr_lk. + simpl. case_bool_decide;done. + iFrame "Hinterp_po_src". + + iModIntro. iExists true. iSplit. iPureIntro; done. + iFrame "E_W Ed_po Ed_ctrl Ed_addr Ed_data Ed_co Ed_rmw". by iFrame "Hannot_curr Hpo_src". + } + { (* failing case *) + iNamed "Hinterp_annot". iDestruct "Hannot_at_prog" as "#Hannot_at_prog". + (* update na *) + iMod (annot_alloc na (get_progress ts) tid gs emp%I with "[$Hinterp_annot $Hannot_at_prog //]") as "(Hinterp_annot & _)". + iMod (token_alloc with "[$Hinterp_token //]") as "(Hinterp_token & Htok)". + + iExists emp%I, ∅, ∅, ls. + iModIntro. iSplitR; [iSplitR |]. { by iApply empty_na_splitting_wf. } + + (** getting out resources from FE *) + { + repeat iNamed 1. iApply step_fupd_intro;first auto. + rewrite /prot_node /=. erewrite progress_to_node_mk_eid_ii;last reflexivity. iNext. + + iSplitL. iModIntro. iIntros (????) "E_W'". + iDestruct (graph_event_agree with "Hinterp_global E_W'") as %Heq. + destruct Heq as [? [Hlk ?]]. + rewrite Hlk in Hgr_lk. inversion Hgr_lk. subst x. + rewrite /AAConsistent.event_is_write_with //= in H2. + + done. + } + + iSplitL "Hinterp_annot Hinterp_token". + { rewrite -map_union_assoc. rewrite map_empty_union. rewrite insert_union_singleton_l. iFrame. + rewrite dom_union_L dom_singleton_L. iFrame. } + iSplitL "Hinterp_local". + { + iNamed "Hinterp_local". iSplitL "Hinterp_local_lws". + iApply (last_write_interp_progress_non_write with "Hinterp_local_lws");auto. + intro Hin. erewrite progress_to_node_mk_eid_ii in Hin;eauto. + pose proof (AAConsistent.event_is_write_elem_of_mem_writes2 _ Hgraph_wf Hin) as [? [Hlk' HW]]. + rewrite Hgr_lk in Hlk'. inversion Hlk'. subst x. done. + iApply (po_pred_interp_skip with "Hinterp_po_src");auto. + } + iExists false. iSplit;first done. + iFrame. + } + Qed. + +End rules. diff --git a/theories/low/weakestpre.v b/theories/low/weakestpre.v new file mode 100644 index 0000000..ff6d30b --- /dev/null +++ b/theories/low/weakestpre.v @@ -0,0 +1,835 @@ +(* This file contains the definition of weakest preconditions of the low-level logic *) +From iris.proofmode Require Import base tactics classes. +From iris.bi.lib Require Import fixpoint. +From iris.prelude Require Import options. + +From iris_named_props Require Export named_props. + +From self.low Require Export iris interp_mod. +Import uPred. + +(* to facilitate TC search *) +Class Terminated (s : LThreadState.t) := + _terminated : LThreadState.is_terminated s = true. + +Import LThreadState. + +Definition post_lifting `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} Φ tid := + (λ (s : LThreadState.t), ∀ (na : mea Σ), + annot_interp na ==∗ + (annot_interp na ∗ + (([∗ map] e ↦ R ∈ na, if bool_decide (Graph.is_local_node_of tid e) then R + else True%I) -∗ ▷ |==> Φ s)))%I. + +Lemma post_lifting_interp_mod `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} Φ tid s : + |=i=> post_lifting Φ tid s -∗ post_lifting Φ tid s. +Proof. + iIntros "H". + rewrite /post_lifting. + iIntros (?) "Hna". + rewrite interp_mod_eq /interp_mod_def. + iMod ("H" with "Hna") as "[H Hna]". + by iMod ("H" with "Hna") as "[$ $]". +Qed. + +Definition sswp_def `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} (tid: Tid) : + LThreadState.t -d> (LThreadState.t -d> iPropO Σ) -d> iPropO Σ := + (λ s Φ, + if LThreadState.is_terminated s then |=i=> Φ s + else + ( + ∀ (gs : GlobalState.t) pg s' ls, + let gr := gs.(GlobalState.gs_graph) in + (* the graph is forall quantified and interpreted, + it combining with resources gives us partial facts about the graph *) + "%Hgraph_co" ∷ ⌜AAConsistent.t gr⌝ ∗ + "%Hgraph_wf" ∷ ⌜AACandExec.NMSWF.wf gr⌝ ∗ + "#Hinterp_global" ∷ (□ gconst_interp gs) ∗ + "%Hstep" ∷ ⌜LThreadStep.t gs tid s s'⌝ ∗ + "%Hat_prog" ∷ ⌜LThreadState.at_progress s pg⌝ ∗ + "Hinterp_local" ∷ local_interp gs tid pg ls -∗ + (if (bool_decide (ThreadState.progress_is_valid gr tid pg)) then + ∀ (na : mea Σ), + "Hannot_at_prog" ∷ na_at_progress gr tid pg na ∗ + "Hinterp_annot" ∷ annot_interp na + ==∗ + let e := (ThreadState.progress_to_node pg tid) in + let s_lob := (Graph.lob_pred_of gr e) in + let s_obs := (Graph.obs_pred_of gr e) in + ∃ (R: iProp Σ) (na_used na_unused : mea Σ) (ls' : log_ts_t), + (na_splitting_wf s_lob na na_used na_unused ∗ + flow_eq s_lob s_obs e na_used R) ∗ + annot_interp ({[e := R]} ∪ na_unused ∪ na) ∗ + (local_interp gs tid (LThreadState.get_progress s') ls') ∗ + Φ s' + else |=i=> + ((local_interp gs tid (LThreadState.get_progress s') ls) ∗ + Φ s'))) + )%I. + +Definition sswp_aux : seal (@sswp_def). Proof. by eexists. Qed. +Definition sswp := sswp_aux.(unseal). +Arguments sswp {Σ _ _ _ _ _}. +Lemma sswp_eq `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} : sswp = @sswp_def Σ _ _ _ _ _. +Proof. rewrite -sswp_aux.(seal_eq) //. Qed. + +Definition wp_pre `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} (tid : Tid) + (wp : LThreadState.t -> (LThreadState.t -> iProp Σ) -> iProp Σ) + : LThreadState.t -> (LThreadState.t -> iProp Σ) -> iProp Σ := + (λ s Φ, + if LThreadState.is_terminated s then (post_lifting Φ tid) s + else + ( + ∀ (gs : GlobalState.t) pg s' ls, + let gr := gs.(GlobalState.gs_graph) in + (* the graph is forall quantified and interpreted, + it combining with resources gives us partial facts about the graph *) + "%Hgraph_co" ∷ ⌜AAConsistent.t gr⌝ ∗ + "%Hgraph_wf" ∷ ⌜AACandExec.NMSWF.wf gr⌝ ∗ + "#Hinterp_global" ∷ (□ gconst_interp gs) ∗ + "%Hstep" ∷ ⌜LThreadStep.t gs tid s s'⌝ ∗ + "%Hat_prog" ∷ ⌜LThreadState.at_progress s pg⌝ ∗ + "Hinterp_local" ∷ local_interp gs tid pg ls -∗ + (if (bool_decide (ThreadState.progress_is_valid gr tid pg)) then + ∀ (na : mea Σ), + "Hannot_at_prog" ∷ na_at_progress gr tid pg na ∗ + "Hinterp_annot" ∷ annot_interp na ==∗ + let e := (ThreadState.progress_to_node pg tid) in + let s_lob := (Graph.lob_pred_of gr e) in + let s_obs := (Graph.obs_pred_of gr e) in + ∃ (R: iProp Σ) (na_used na_unused : mea Σ) (ls' : log_ts_t), + (na_splitting_wf s_lob na na_used na_unused ∗ + flow_eq s_lob s_obs e na_used R) ∗ + annot_interp ({[e := R]} ∪ na_unused ∪ na) ∗ + (local_interp gs tid (LThreadState.get_progress s') ls') ∗ + wp s' Φ + else |=i=> + ((local_interp gs tid (LThreadState.get_progress s') ls) ∗ + wp s' Φ))) + )%I. + +Local Lemma wp_pre_mono `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} tid + (wp1 wp2 : LThreadState.t -> (LThreadState.t -> iProp Σ) -> iProp Σ) : + ⊢ (□ ∀ s Φ, wp1 s Φ -∗ wp2 s Φ) → + ∀ s Φ, wp_pre tid wp1 s Φ -∗ wp_pre tid wp2 s Φ. +Proof. + iIntros "#H"; iIntros (s Φ) "Hwp". rewrite /wp_pre. + destruct (LThreadState.is_terminated s); first done. + iIntros (????) "Hs". iDestruct ("Hwp" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">(%&%&%&%&(?&HFE)&?&?&Hwp)";iModIntro. + iExists _,_,_,_. iFrame "HFE". iFrame. by iApply "H". + - iDestruct "Hwp" as ">[? ?]". + iModIntro. iFrame. by iApply "H". +Qed. + +Local Definition wp_pre' `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} tid : + (prodO (leibnizO LThreadState.t) (LThreadState.t -d> iPropO Σ) → iPropO Σ) -> (prodO (leibnizO LThreadState.t) (LThreadState.t -d> iPropO Σ) → iPropO Σ) := + uncurry ∘ wp_pre tid ∘ curry. + +#[local] Instance wp_pre_mono' `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} tid: BiMonoPred (wp_pre' tid). +Proof. + constructor. + - iIntros (wp1 wp2 ??) "#H". iIntros ([s Φ]); iRevert (s Φ). + iApply wp_pre_mono. iIntros "!>" (??). + iApply ("H" $! (s, Φ)). + - intros wp Hwp n [s1 Φ1] [s2 Φ2] [?%leibniz_equiv ?]. simplify_eq/=. + rewrite /curry /wp_pre /post_lifting. do 14 (f_equiv || done). + 2:{ rewrite /Datatypes.curry. by apply pair_ne. } + do 13 (f_equiv || done). rewrite /Datatypes.curry. by apply pair_ne. +Qed. + +Local Definition wp_def `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} (tid: Tid) : LThreadState.t -> (LThreadState.t -> iProp Σ) -> iProp +Σ:= + λ s Φ, bi_least_fixpoint (wp_pre' tid) (s,Φ). + +Definition wp_aux : seal (@wp_def). Proof. by eexists. Qed. +Definition wp := wp_aux.(unseal). + +Arguments wp {Σ _ _ _ _ _}. +Lemma wp_eq `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} : wp = @wp_def Σ _ _ _ _ _. +Proof. rewrite -wp_aux.(seal_eq) //. Qed. + +(** Notations *) +Notation "'SSWP' m @ id {{ Φ } }" := (sswp id m Φ) + (at level 20, m, Φ at level 200, only parsing) : bi_scope. + +Notation "'WP' m @ id {{ Φ } }" := (wp id m Φ) + (at level 20, m, Φ at level 200, only parsing) : bi_scope. + +Notation "'SSWP' m @ id {{ v , Q } }" := (sswp id m (λ v, Q)) + (at level 20, m, Q at level 200, + format "'[' 'SSWP' m '/' '[ ' @ id {{ v , Q } } ']' ']'") : bi_scope. + +Notation "'WP' m @ id {{ v , Q } }" := (wp id m (λ v, Q)) + (at level 20, m, Q at level 200, + format "'[' 'WP' m '/' '[ ' @ id {{ v , Q } } ']' ']'") : bi_scope. + +Section wp. + Context `{CMRA Σ}. + Context `{!invGS_gen HasNoLc Σ}. + Context `{!irisG}. + Context `{!irisGL}. + Context `{!Protocol}. + Implicit Types Φ : LThreadState.t → iProp Σ. + Implicit Types s : LThreadState.t. + Implicit Types id : Tid. + Import LThreadState. + + Lemma wp_unfold id s Φ : + WP s @ id {{ Φ }} ⊣⊢ wp_pre id (wp id) s Φ. + Proof. rewrite wp_eq /wp_def least_fixpoint_unfold //. Qed. + + Lemma wp_ind tid Ψ : + (∀ n s, Proper (pointwise_relation _ (dist n) ==> dist n) (Ψ s)) → + □ (∀ s Φ, wp_pre tid (λ s Φ, Ψ s Φ ∧ WP s @ tid {{ Φ }}) s Φ -∗ Ψ s Φ) -∗ + ∀ s Φ, WP s @ tid {{ Φ }} -∗ Ψ s Φ. + Proof. + iIntros (HΨ). iIntros "#IH" (s Φ) "H". rewrite wp_eq. + set (Ψ' := uncurry Ψ : + prodO (leibnizO LThreadState.t) (LThreadState.t -d> iPropO Σ) → iPropO Σ). + assert (NonExpansive Ψ'). + { intros n [s1 Φ1] [s2 Φ2] + [?%leibniz_equiv ?]; simplify_eq/=. by apply HΨ. } + iApply (least_fixpoint_ind _ Ψ' with "[] H"). + iIntros "!>" ([? ?]) "H". by iApply "IH". + Qed. + + Lemma wp_sswp id s Φ : + WP s @ id {{ Φ }} ⊣⊢ SSWP s @ id {{s', WP s' @ id {{ Φ }} }}. + Proof. + rewrite wp_unfold sswp_eq /wp_pre /sswp_def. + destruct (is_terminated s) eqn:Hm; + repeat setoid_rewrite (wp_unfold id s);rewrite /wp_pre ?Hm //=. + iSplitL. + - by iIntros "? !>". + - iApply post_lifting_interp_mod. + Qed. + + #[global] Instance sswp_ne id s n : + Proper (pointwise_relation _ (dist n) ==> dist n) (sswp id s). + Proof. rewrite sswp_eq /sswp_def; intros ?? Heq; repeat f_equiv. Qed. + + #[global] Instance wp_ne id s n : + Proper (pointwise_relation _ (dist n) ==> dist n) (wp id s). + Proof. + intros Φ1 Φ2 HΦ. rewrite !wp_eq. + by apply (least_fixpoint_ne _), pair_ne, HΦ. + Qed. + + #[global] Instance sswp_proper id s : + Proper (pointwise_relation _ (≡) ==> (≡)) (sswp id s). + Proof. + by intros Φ Φ' ?; apply equiv_dist=>n; apply sswp_ne=>v; apply equiv_dist. + Qed. + + #[global] Instance wp_proper id s : + Proper (pointwise_relation _ (≡) ==> (≡)) (wp id s). + Proof. + by intros Φ Φ' ?; apply equiv_dist=>n; apply wp_ne=>v; apply equiv_dist. + Qed. + + (* #[global] Instance sswp_contractive id s n : *) + (* TCEq (is_terminated s) false → *) + (* Proper (pointwise_relation _ (dist_later n) ==> dist n) (sswp id s). *) + (* Proof. *) + (* intros He Φ Ψ HΦ. rewrite !sswp_eq /sswp_def He. *) + (* repeat apply bi.forall_ne =>?. *) + (* by repeat (f_contractive || f_equiv). *) + (* Qed. *) + + (* #[global] Instance wp_contractive id s n : *) + (* TCEq (is_terminated s) false → *) + (* Proper (pointwise_relation _ (dist_later n) ==> dist n) (wp id s). *) + (* Proof. *) + (* intros He Φ Ψ HΦ. rewrite !wp_unfold /wp_pre He. *) + (* repeat apply bi.forall_ne =>?. *) + (* by repeat (f_contractive || f_equiv). *) + (* Qed. *) + + Lemma sswp_terminated' id Φ s : + is_terminated s = true → Φ s ⊢ SSWP s @ id {{ Φ }}. + Proof. iIntros (Hs) "HΦ". rewrite sswp_eq /sswp_def Hs. by iFrame. Qed. + Lemma sswp_terminated_inv' id Φ s : + is_terminated s = true → SSWP s @ id {{ Φ }} -∗ |=i=> Φ s. + Proof. intros Hs; rewrite sswp_eq /sswp_def Hs //. by iIntros "$". Qed. + + Lemma wp_terminated' id Φ s : + is_terminated s = true → post_lifting Φ id s ⊢ WP s @ id {{ Φ }}. + Proof. iIntros (Hs) "HΦ". rewrite wp_unfold /wp_pre Hs. auto. Qed. + Lemma wp_terminated_inv' id Φ s : + is_terminated s = true → WP s @ id {{ Φ }} -∗ post_lifting Φ id s. + Proof. intros Hs; rewrite wp_unfold /wp_pre Hs. iIntros "$". Qed. + + Lemma sswp_strong_mono id s Φ Ψ : + SSWP s @ id {{ Φ }} -∗ (∀ k, Φ k -∗ Ψ k) -∗ SSWP s @ id {{ Ψ }}. + Proof. + iIntros "H HΦ". + rewrite sswp_eq /sswp_def. + destruct (is_terminated s) eqn:?. + { iMod "H". iModIntro. by iApply ("HΦ" with "[-]"). } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">(%&%&%&%&(?&FE)&?&?&Hwp)". + iExists _,_,_,_. iFrame "FE". iFrame. by iApply "HΦ". + - iDestruct "Hwp" as ">[? Hwp]". iModIntro. iFrame. by iApply "HΦ". + Qed. + + Lemma sswp_strong_mono' id s Φ Ψ : + SSWP s @ id {{ Φ }} -∗ (∀ k, Φ k -∗ |=i=> Ψ k) -∗ SSWP s @ id {{ Ψ }}. + Proof. + iIntros "H HΦ". + rewrite sswp_eq /sswp_def. + destruct (is_terminated s) eqn:?. + { iMod "H". by iApply ("HΦ" with "[-]"). } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "[Hs' Hannot]". + rewrite interp_mod_eq /interp_mod_def. + iDestruct ("Hwp" with "[$Hs' $Hannot]") as ">(%&%&%&%&(?&FE)&Hannot&Hwp)". + iDestruct "Hwp" as "[Hwp H]". iSpecialize ("HΦ" with "H"). iDestruct ("HΦ" with "Hannot") as ">[? ?]". + iExists _,_,_,_. iFrame "FE". by iFrame. + - iDestruct "Hwp" as ">[? Hwp]". iMod ("HΦ" with "Hwp"). iModIntro. iFrame. + Qed. + + Lemma post_lifting_strong_mono id s Φ Ψ : + post_lifting Φ id s -∗ (∀ k : t, Φ k ==∗ Ψ k) -∗ post_lifting Ψ id s. + Proof. + iIntros "H HΦ". rewrite /post_lifting. iIntros (?) "Hinterp_annot". + iDestruct ("H" with "Hinterp_annot") as ">[$ H]". + iModIntro. iIntros "P". iSpecialize ("H" with "P"). iNext. iMod "H". + by iApply "HΦ". + Qed. + + Lemma wp_strong_mono id s Φ Ψ : + WP s @ id {{ Φ }} -∗ (∀ k, Φ k ==∗ Ψ k) -∗ WP s @ id {{ Ψ }}. + Proof. + iIntros "H HΦ". iRevert (Ψ) "HΦ"; iRevert (s Φ) "H". + iApply wp_ind; first solve_proper. + iIntros "!>" (s Φ) "IH"; iIntros (Ψ) "HΦ". + rewrite !wp_unfold /wp_pre. + destruct (is_terminated s) eqn:?. + { by iApply (post_lifting_strong_mono with "IH HΦ"). } + iIntros (????) "Hs". iDestruct ("IH" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">(%&%&%&%&(?&FE)&?&?&Hwp)". + iExists _,_,_,_. iFrame "FE". iFrame. iApply ("Hwp" with "HΦ"). + - iMod "Hwp" as "[? Hwp]". iModIntro;iFrame. iApply ("Hwp" with "HΦ"). + Qed. + + Lemma bupd_sswp id s Φ : + (|==> SSWP s @ id {{ Φ }}) ⊢ SSWP s @ id {{ Φ }}. + Proof. + rewrite sswp_eq /sswp_def. iIntros "H". + destruct (is_terminated s) eqn:?. + { by iApply interp_mod_bupd. } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">>(%&%&%&%&(?&FE)&?&Hwp)". + iExists _,_,_,_. iFrame "FE". by iFrame. + - iMod "Hwp" as ">[? ?]". iModIntro. iFrame. + Qed. + + Lemma iupd_sswp id s Φ : + (|=i=> SSWP s @ id {{ Φ }}) ⊢ SSWP s @ id {{ Φ }}. + Proof. + rewrite sswp_eq /sswp_def. iIntros "H". + destruct (is_terminated s) eqn:?. + { iMod "H";done. } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "[Hs' Hannot]". + rewrite interp_mod_eq /interp_mod_def. + iDestruct ("Hwp" with "Hannot") as ">[Hwp Hannot]". + iDestruct ("Hwp" with "[$Hs' $Hannot]") as ">(%&%&%&%&(?&FE)&?&Hwp)". + iModIntro. iExists _,_,_,_. iFrame "FE". by iFrame. + - iMod "Hwp" as ">[? ?]". iModIntro. iFrame. + Qed. + + Lemma sswp_bupd id s Φ : + SSWP s @ id {{ k, |==> Φ k }} ⊢ SSWP s @ id {{ Φ }}. + Proof. + rewrite sswp_eq /sswp_def. iIntros "H". + destruct (is_terminated s) eqn:?. + { rewrite interp_mod_eq /interp_mod_def. + iIntros (?) "Hannot". iDestruct ("H" with "Hannot") as ">[>$ $]". done. } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">(%&%&%&%&(?&FE)&?&?&Hwp)". + iExists _,_,_,_. iFrame "FE". by iFrame. + - iMod "Hwp" as "[? Hwp]". iApply interp_mod_bupd. iMod "Hwp". + iModIntro. iModIntro. iFrame. + Qed. + + Lemma sswp_iupd id s Φ : + SSWP s @ id {{ k, |=i=> Φ k }} ⊢ SSWP s @ id {{ Φ }}. + Proof. + rewrite sswp_eq /sswp_def. iIntros "H". + destruct (is_terminated s) eqn:?. + { iMod "H";done. } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "[Hs' Hannot]". + rewrite interp_mod_eq /interp_mod_def. + iDestruct ("Hwp" with "[$Hs' $Hannot]") as ">(%&%&%&%&(?&FE)&Hannot&Hwp)". + iDestruct "Hwp" as "[? Hwp]". + iDestruct ("Hwp" with "Hannot") as ">[Hwp Hannot]". + iExists _,_,_,_. iFrame "FE". by iFrame. + - iMod "Hwp" as "[? Hwp]". iMod "Hwp". iModIntro. iFrame. + Qed. + + Lemma bupd_wp id s Φ : + (|==> WP s @ id {{ Φ }}) ⊢ WP s @ id {{ Φ }}. + Proof. + rewrite wp_unfold /wp_pre. iIntros "H". destruct (is_terminated s) eqn:?. + { iApply post_lifting_interp_mod. iApply interp_mod_bupd. iMod "H". iModIntro. iModIntro. done. } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">>(%&%&%&%&(?&FE)&?&?&Hwp)". + iExists _,_,_,_. iFrame "FE". by iFrame. + - iMod "Hwp" as ">[? Hwp]". iModIntro;iFrame. + Qed. + + Lemma iupd_wp id s Φ : + (|=i=> WP s @ id {{ Φ }}) ⊢ WP s @ id {{ Φ }}. + Proof. + rewrite wp_unfold /wp_pre. iIntros "H". destruct (is_terminated s) eqn:?. + { iApply post_lifting_interp_mod. done. } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "[Hs' Hannot]". + rewrite interp_mod_eq /interp_mod_def. + iDestruct ("Hwp" with "Hannot") as ">[Hwp Hannot]". + iDestruct ("Hwp" with "[$Hs' $Hannot]") as ">(%&%&%&%&(?&FE)&?&Hwp)". + iModIntro. iExists _,_,_,_. iFrame "FE". by iFrame. + - iMod "Hwp" as ">[? Hwp]". iModIntro;iFrame. + Qed. + + Lemma wp_bupd id s Φ : + WP s @ id {{ k, |==> Φ k }} ⊢ WP s @ id {{ Φ }}. + Proof. iIntros "H". iApply (wp_strong_mono id with "H"); auto. Qed. + + (* don't need this lemma since we removed masks for now *) + (* Lemma sswp_fupd_around id E1 E2 s Φ : *) + (* (|={E1,E2}=> SSWP s @ id; E2 {{ k, |={E2,E1}=> Φ k }}) ⊢ SSWP s @ id; E1 {{ Φ }}. *) + (* Proof. *) + (* iIntros "H". *) + (* rewrite sswp_eq /sswp_def. *) + (* destruct (is_terminated s). *) + (* { by iDestruct "H" as ">>> $". } *) + (* iIntros (gs α β) "H'". iMod "H". *) + (* iMod ("H" with "H'") as "H". *) + (* iModIntro. *) + (* iIntros (s' Hstep). *) + (* iMod ("H" with "[//]") as "H". *) + (* iModIntro. iNext. *) + (* iMod "H" as "[$ >$]"; done. *) + (* Qed. *) + + Lemma sswp_step_bupd id s P Φ : + (|==> P) -∗ + SSWP s @ id {{ k, P ==∗ Φ k }} -∗ + SSWP s @ id {{ Φ }}. + Proof. + rewrite sswp_eq /sswp_def. iIntros "HP H". + destruct (is_terminated s). + { iMod "H". iApply interp_mod_bupd'. iMod "HP". by iApply "H". } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">(%&%&%&%&(?&FE)&?&?&Hwp)". + iExists _,_,_,_. iFrame "FE". iFrame. + iMod ("Hwp" with "HP") as "$". + - iMod "Hwp" as "[? Hwp]". iApply interp_mod_bupd'. + iMod "HP". iMod ("Hwp" with "HP") as "$". done. + Qed. + + Lemma sswp_step_iupd id s P Φ : + (|=i=> P) -∗ + SSWP s @ id {{ k, P -∗ |=i=> Φ k }} -∗ + SSWP s @ id {{ Φ }}. + Proof. + rewrite sswp_eq /sswp_def. iIntros "HP H". + destruct (is_terminated s). + { iMod "H". iMod "HP". by iApply "H". } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "[Hs' Hannot]". + rewrite interp_mod_eq /interp_mod_def. + iDestruct ("HP" with "Hannot") as ">[HP Hannot]". + iDestruct ("Hwp" with "[$Hs' $Hannot]") as ">(%&%&%&%&(?&FE)&Hannot&Hwp)". + iDestruct "Hwp" as "[? Hwp]". iDestruct ("Hwp" with "HP") as "Hwp". + iDestruct ("Hwp" with "Hannot") as ">[Hwp ?]". + iExists _,_,_,_. iFrame "FE". by iFrame. + - iMod "Hwp" as "[? Hwp]". + iMod "HP". iMod ("Hwp" with "HP") as "?". + iModIntro;iFrame. + Qed. + + Lemma wp_step_bupd id s P Φ : + (|==> P) -∗ + WP s @ id {{ k, P ==∗ Φ k }} -∗ + WP s @ id {{ Φ }}. + Proof. + rewrite !wp_unfold /wp_pre. iIntros "HP H". + destruct (is_terminated s). + { iApply (post_lifting_strong_mono with "H"). iIntros (?) "H". iMod "HP". by iApply "H". } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">(%&%&%&%&(?&FE)&?&?&Hwp)". + iExists _,_,_,_. iFrame "FE". iFrame. + iMod "HP". iModIntro. iApply (wp_strong_mono with "Hwp"). + iIntros (k) "H"; iApply "H"; done. + - iMod "HP". iMod "Hwp" as "[? Hwp]". + iApply interp_mod_bupd'. iFrame. + iApply (wp_strong_mono with "Hwp"). + iModIntro. iIntros (k) "H"; iApply "H"; done. + Qed. + + Lemma wp_step_iupd id s P Φ : + (|=i=> P) -∗ + WP s @ id {{ k, P -∗ |==> Φ k }} -∗ + WP s @ id {{ Φ }}. + Proof. + rewrite !wp_unfold /wp_pre. iIntros "HP H". + destruct (is_terminated s). + { iApply post_lifting_interp_mod. iMod "HP". iModIntro. iApply (post_lifting_strong_mono with "H"). iIntros (?) "H". by iApply "H". } + iIntros (????) "Hs". iDestruct ("H" with "Hs") as "Hwp". + case_bool_decide. + - iIntros (?) "Hs'". iDestruct ("Hwp" with "Hs'") as ">(%&%&%&%&(?&FE)&Hannot&?&Hwp)". + iExists _,_,_,_. iFrame "FE". + rewrite interp_mod_eq /interp_mod_def. + iDestruct ("HP" with "Hannot") as ">[HP Hannot]". + iFrame. iApply (wp_strong_mono with "Hwp"). + iModIntro. iIntros (k) "H"; iApply "H"; done. + - iMod "HP". iMod "Hwp" as "[? Hwp]". + iApply interp_mod_bupd'. iFrame. + iApply (wp_strong_mono with "Hwp"). + iModIntro. iIntros (k) "H"; iApply "H"; done. + Qed. + + (** * Derived rules *) + Lemma sswp_mono id s Φ Ψ : + (∀ k, Φ k ⊢ Ψ k) → SSWP s @ id {{ Φ }} ⊢ SSWP s @ id {{ Ψ }}. + Proof. + iIntros (HΦ) "H"; iApply (sswp_strong_mono with "H"); auto. + iIntros (v) "?". by iApply HΦ. + Qed. + + Lemma wp_mono id s Φ Ψ : + (∀ k, Φ k ⊢ Ψ k) → WP s @ id {{ Φ }} ⊢ WP s @ id {{ Ψ }}. + Proof. + iIntros (HΦ) "H"; iApply (wp_strong_mono with "H"); auto. + iIntros (v) "?". by iApply HΦ. + Qed. + + (* Lemma sswp_mask_mono id E1 E2 s Φ : *) + (* E1 ⊆ E2 → SSWP s @ id; E1 {{ Φ }} ⊢ SSWP s @ id; E2 {{ Φ }}. *) + (* Proof. iIntros (?) "H"; iApply (sswp_strong_mono with "H"); auto. Qed. *) + + (* Lemma wp_mask_mono id E1 E2 s Φ : *) + (* E1 ⊆ E2 → WP s @ id; E1 {{ Φ }} ⊢ WP s @ id; E2 {{ Φ }}. *) + (* Proof. iIntros (?) "H"; iApply (wp_strong_mono with "H"); auto. Qed. *) + + Global Instance sswp_mono' id s : + Proper (pointwise_relation _ (⊢) ==> (⊢)) (sswp id s). + Proof. by intros Φ Φ' ?; apply sswp_mono. Qed. + + Global Instance wp_mono' id s : + Proper (pointwise_relation _ (⊢) ==> (⊢)) (wp id s). + Proof. by intros Φ Φ' ?; apply wp_mono. Qed. + + Global Instance sswp_flip_mono' id s : + Proper (pointwise_relation _ (flip (⊢)) ==> (flip (⊢))) (sswp id s). + Proof. by intros Φ Φ' ?; apply sswp_mono. Qed. + + Global Instance wp_flip_mono' id s : + Proper (pointwise_relation _ (flip (⊢)) ==> (flip (⊢))) (wp id s). + Proof. by intros Φ Φ' ?; apply wp_mono. Qed. + + Lemma sswp_terminated id Φ s : + Terminated s → Φ s ⊢ SSWP s @ id {{ Φ }}. + Proof. apply sswp_terminated'. Qed. + + Lemma wp_terminated id Φ s : + Terminated s -> (post_lifting Φ id) s ⊢ WP s @ id {{ Φ }}. + Proof. apply wp_terminated'. Qed. + + Lemma wp_terminated_bupd' id Φ s : + Terminated s → (post_lifting Φ id) s ⊢ WP s @ id {{ Φ }}. + Proof. + intros; rewrite -wp_bupd -wp_terminated' //. + iIntros "?". iApply (post_lifting_strong_mono with "[-]");auto. + Qed. + + (* Lemma sswp_terminated'' id Φ s `{!Terminated s} : *) + (* Φ s ⊢ SSWP s @ id {{ Φ }}. *) + (* Proof. intros; rewrite -sswp_bupd -sswp_terminated //. Qed. *) + + (* Lemma wp_terminated'' id Φ s `{!Terminated s} : *) + (* ((post_lifting Φ id) s) ⊢ WP s @ id {{ Φ }}. *) + (* Proof. *) + (* intros; rewrite -wp_bupd -wp_terminated //. *) + (* iIntros "?". iApply (post_lifting_strong_mono with "[-]");auto. *) + (* Qed. *) + + Lemma sswp_terminated_inv id Φ s : + Terminated s → SSWP s @ id {{ Φ }} -∗ |=i=> Φ s. + Proof. by apply sswp_terminated_inv'. Qed. + + Lemma wp_terminated_inv id Φ s : + Terminated s → WP s @ id {{ Φ }} -∗ (post_lifting Φ id) s. + Proof. apply wp_terminated_inv'. Qed. + + Lemma sswp_frame_l id s Φ R : + R ∗ SSWP s @ id {{ Φ }} ⊢ SSWP s @ id {{ k, R ∗ Φ k }}. + Proof. iIntros "[? H]". iApply (sswp_strong_mono with "H"); auto with iFrame. Qed. + + Lemma wp_frame_l id s Φ R : + R ∗ WP s @ id {{ Φ }} ⊢ WP s @ id {{ k, R ∗ Φ k }}. + Proof. iIntros "[? H]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed. + + Lemma sswp_frame_r id s Φ R : + SSWP s @ id {{ Φ }} ∗ R ⊢ SSWP s @ id {{ k, Φ k ∗ R }}. + Proof. iIntros "[H ?]". iApply (sswp_strong_mono with "H"); auto with iFrame. Qed. + + Lemma wp_frame_r id s Φ R : + WP s @ id {{ Φ }} ∗ R ⊢ WP s @ id {{ k, Φ k ∗ R }}. + Proof. iIntros "[H ?]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed. + + Lemma sswp_frame_step_l id s Φ R : + (|==> R) ∗ SSWP s @ id {{ Φ }} ⊢ SSWP s @ id {{ k, R ∗ Φ k }}. + Proof. + iIntros "[Hu Hwp]". iApply (sswp_step_bupd with "Hu"); try done. + iApply (sswp_mono with "Hwp"). by iIntros (?) "$$". + Qed. + + Lemma sswp_frame_step_l'' id s Φ R : + (|=i=> R) ∗ SSWP s @ id {{ Φ }} ⊢ SSWP s @ id {{ k, R ∗ Φ k }}. + Proof. + iIntros "[Hu Hwp]". iApply (sswp_step_iupd with "Hu"); try done. + iApply (sswp_mono with "Hwp"). iIntros (?) "??". iModIntro. iFrame. + Qed. + + Lemma wp_frame_step_l id s Φ R : + (|==> R) ∗ WP s @ id {{ Φ }} ⊢ WP s @ id {{ k, R ∗ Φ k }}. + Proof. + iIntros "[Hu Hwp]". iApply (wp_step_bupd with "Hu"); try done. + iApply (wp_mono with "Hwp"). by iIntros (?) "$$". + Qed. + + Lemma wp_frame_step_l'' id s Φ R : + (|=i=> R) ∗ WP s @ id {{ Φ }} ⊢ WP s @ id {{ k, R ∗ Φ k }}. + Proof. + iIntros "[Hu Hwp]". iApply (wp_step_iupd with "Hu"); try done. + iApply (wp_mono with "Hwp"). by iIntros (?) "$$". + Qed. + + Lemma sswp_frame_step_r id s Φ R : + SSWP s @ id {{ Φ }} ∗ (|==> R) ⊢ SSWP s @ id {{ k, Φ k ∗ R }}. + Proof. + rewrite [(SSWP _ @ _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply sswp_frame_step_l. + Qed. + + Lemma sswp_frame_step_r'' id s Φ R : + SSWP s @ id {{ Φ }} ∗ (|=i=> R) ⊢ SSWP s @ id {{ k, Φ k ∗ R }}. + Proof. + rewrite [(SSWP _ @ _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply sswp_frame_step_l''. + Qed. + + Lemma wp_frame_step_r id s Φ R : + WP s @ id {{ Φ }} ∗ (|==> R) ⊢ WP s @ id {{ k, Φ k ∗ R }}. + Proof. + rewrite [(WP _ @ _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply wp_frame_step_l. + Qed. + + Lemma wp_frame_step_r'' id s Φ R : + WP s @ id {{ Φ }} ∗ (|=i=> R) ⊢ WP s @ id {{ k, Φ k ∗ R }}. + Proof. + rewrite [(WP _ @ _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply wp_frame_step_l''. + Qed. + + Lemma sswp_frame_step_l' id s Φ R : + R ∗ SSWP s @ id {{ Φ }} ⊢ SSWP s @ id {{ k, R ∗ Φ k }}. + Proof. iIntros "[??]". iApply (sswp_frame_step_l id); try iFrame; eauto. Qed. + + Lemma wp_frame_step_l' id s Φ R : + R ∗ WP s @ id {{ Φ }} ⊢ WP s @ id {{ k, R ∗ Φ k }}. + Proof. iIntros "[??]". iApply (wp_frame_step_l id); try iFrame; eauto. Qed. + + Lemma sswp_frame_step_r' id s Φ R : + SSWP s @ id {{ Φ }} ∗ R ⊢ SSWP s @ id {{ k, Φ k ∗ R }}. + Proof. iIntros "[??]". iApply (sswp_frame_step_r id); try iFrame; eauto. Qed. + + Lemma wp_frame_step_r' id s Φ R : + WP s @ id {{ Φ }} ∗ R ⊢ WP s @ id {{ k, Φ k ∗ R }}. + Proof. iIntros "[??]". iApply (wp_frame_step_r id); try iFrame; eauto. Qed. + + Lemma sswp_wand id s Φ Ψ : + SSWP s @ id {{ Φ }} -∗ (∀ k, Φ k -∗ Ψ k) -∗ SSWP s @ id {{ Ψ }}. + Proof. + iIntros "Hwp H". iApply (sswp_strong_mono with "Hwp"); auto. + Qed. + + Lemma wp_wand id s Φ Ψ : + WP s @ id {{ Φ }} -∗ (∀ k, Φ k -∗ Ψ k) -∗ WP s @ id {{ Ψ }}. + Proof. + iIntros "Hwp H". iApply (wp_strong_mono with "Hwp"); auto. + iIntros (?) "?". by iApply "H". + Qed. + + Lemma sswp_wand_l id s Φ Ψ : + (∀ k, Φ k -∗ Ψ k) ∗ SSWP s @ id {{ Φ }} ⊢ SSWP s @ id {{ Ψ }}. + Proof. iIntros "[H Hwp]". iApply (sswp_wand with "Hwp H"). Qed. + + Lemma wp_wand_l id s Φ Ψ : + (∀ v, Φ v -∗ Ψ v) ∗ WP s @ id {{ Φ }} ⊢ WP s @ id {{ Ψ }}. + Proof. iIntros "[H Hwp]". iApply (wp_wand with "Hwp H"). Qed. + + Lemma sswp_wand_r id s Φ Ψ : + SSWP s @ id {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ SSWP s @ id {{ Ψ }}. + Proof. iIntros "[Hwp H]". iApply (sswp_wand with "Hwp H"). Qed. + + Lemma wp_wand_r id s Φ Ψ : + WP s @ id {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP s @ id {{ Ψ }}. + Proof. iIntros "[Hwp H]". iApply (wp_wand with "Hwp H"). Qed. + + Lemma sswp_frame_wand_l id s Q Φ : + Q ∗ SSWP s @ id {{ v, Q -∗ Φ v }} -∗ SSWP s @ id {{ Φ }}. + Proof. + iIntros "[HQ HWP]". iApply (sswp_wand with "HWP"). + iIntros (v) "HΦ". by iApply "HΦ". + Qed. + + Lemma wp_frame_wand_l id s Q Φ : + Q ∗ WP s @ id {{ v, Q -∗ Φ v }} -∗ WP s @ id {{ Φ }}. + Proof. + iIntros "[HQ HWP]". iApply (wp_wand with "HWP"). + iIntros (v) "HΦ". by iApply "HΦ". + Qed. + +End wp. + +Section proofmode_classes. + Context `{CMRA Σ}. + Context `{!invGS_gen HasNoLc Σ}. + Context `{!irisG}. + Context `{!irisGL}. + Context `{!Protocol}. + Implicit Types P Q : iProp Σ. + Implicit Types Φ : LThreadState.t → iProp Σ. + (* Implicit Types E : coPset. *) + Implicit Types id : Tid. + + #[global] Instance frame_sswp p id s R Φ Ψ : + (∀ k, Frame p R (Φ k) (Ψ k)) → + Frame p R (SSWP s @ id {{ Φ }}) (SSWP s @ id {{ Ψ }}). + Proof. rewrite /Frame=> HR. rewrite sswp_frame_l. apply sswp_mono, HR. Qed. + + #[global] Instance frame_wp p id s R Φ Ψ : + (∀ k, Frame p R (Φ k) (Ψ k)) → + Frame p R (WP s @ id {{ Φ }}) (WP s @ id {{ Ψ }}). + Proof. rewrite /Frame=> HR. rewrite wp_frame_l. apply wp_mono, HR. Qed. + + (* omit the following two for now *) + (* #[global] Instance is_except_0_sswp id s Φ : IsExcept0 (SSWP s @ id {{ Φ }}). *) + (* Proof. rewrite /IsExcept0. -bupd_sswp. -bupd_intro. apply _. Qed. *) + + (* #[global] Instance is_except_0_wp id E s Φ : IsExcept0 (WP s @ id; E {{ Φ }}). *) + (* Proof. by rewrite /IsExcept0 -{2}bupd_wp -except_0_fupd -fupd_intro. Qed. *) + + #[global] Instance elim_modal_bupd_sswp p id s P Φ : + ElimModal True p false (|==> P) P (SSWP s @ id {{ Φ }}) (SSWP s @ id {{ Φ }}). + Proof. + intros H'. + rewrite /ElimModal bi.intuitionistically_if_elim + bupd_frame_r bi.wand_elim_r bupd_sswp //. + Qed. + + #[global] Instance elim_modal_iupd_sswp p id s P Φ : + ElimModal True p false (|=i=> P) P (SSWP s @ id {{ Φ }}) (SSWP s @ id {{ Φ }}). + Proof. + intros H'. + rewrite /ElimModal bi.intuitionistically_if_elim + interp_mod_frame_r bi.wand_elim_r iupd_sswp //. + Qed. + + #[global] Instance elim_modal_bupd_wp p id s P Φ : + ElimModal True p false (|==> P) P (WP s @ id {{ Φ }}) (WP s @ id {{ Φ }}). + Proof. + rewrite /ElimModal bi.intuitionistically_if_elim + bupd_frame_r bi.wand_elim_r bupd_wp //. + Qed. + + #[global] Instance elim_modal_iupd_wp p id s P Φ : + ElimModal True p false (|=i=> P) P (WP s @ id {{ Φ }}) (WP s @ id {{ Φ }}). + Proof. + rewrite /ElimModal bi.intuitionistically_if_elim + interp_mod_frame_r bi.wand_elim_r iupd_wp //. + Qed. + + (* #[global] Instance elim_modal_fupd_sswp p id E s P Φ : *) + (* ElimModal True p false (|={E}=> P) P (SSWP s @ id; E {{ Φ }}) (SSWP s @ id; E {{ Φ }}). *) + (* Proof. *) + (* by rewrite /ElimModal bi.intuitionistically_if_elim *) + (* fupd_frame_r bi.wand_elim_r fupd_sswp. *) + (* Qed. *) + + (* #[global] Instance elim_modal_fupd_wp p id E s P Φ : *) + (* ElimModal True p false (|={E}=> P) P (WP s @ id; E {{ Φ }}) (WP s @ id; E {{ Φ }}). *) + (* Proof. *) + (* by rewrite /ElimModal bi.intuitionistically_if_elim *) + (* fupd_frame_r bi.wand_elim_r fupd_wp. *) + (* Qed. *) + + (* #[global] Instance elim_modal_fupd_sswp_around p id E1 E2 s P Φ : *) + (* ElimModal True p false (|={E1,E2}=> P) P *) + (* (SSWP s @ id; E1 {{ Φ }}) (SSWP s @ id; E2 {{ v, |={E2,E1}=> Φ v }})%I. *) + (* Proof. *) + (* intros. by rewrite /ElimModal bi.intuitionistically_if_elim *) + (* fupd_frame_r bi.wand_elim_r sswp_fupd_around. *) + (* Qed. *) + + #[global] Instance add_modal_bupd_sswp id s P Φ : + AddModal (|==> P) P (SSWP s @ id {{ Φ }}). + Proof. rewrite /AddModal bupd_frame_r bi.wand_elim_r bupd_sswp //. Qed. + + #[global] Instance add_modal_iupd_sswp id s P Φ : + AddModal (|=i=> P) P (SSWP s @ id {{ Φ }}). + Proof. rewrite /AddModal interp_mod_frame_r bi.wand_elim_r iupd_sswp //. Qed. + + #[global] Instance add_modal_bupd_wp id s P Φ : + AddModal (|==> P) P (WP s @ id {{ Φ }}). + Proof. rewrite /AddModal bupd_frame_r bi.wand_elim_r bupd_wp //. Qed. + + #[global] Instance add_modal_iupd_wp id s P Φ : + AddModal (|=i=> P) P (WP s @ id {{ Φ }}). + Proof. rewrite /AddModal interp_mod_frame_r bi.wand_elim_r iupd_wp //. Qed. + + (* #[global] Instance elim_acc_sswp {X} id E1 E2 α β γ s Φ : *) + (* ElimAcc (X:=X) True (fupd E1 E2) (fupd E2 E1) *) + (* α β γ (SSWP s @ id E1 {{ Φ }}) *) + (* (λ x, SSWP s @ id; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I. *) + (* Proof. *) + (* intros _. *) + (* iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". *) + (* iApply (sswp_wand with "(Hinner Hα)"). *) + (* iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose". *) + (* Qed. *) + + (* #[global] Instance elim_acc_wp_nonatomic {X} id E α β γ s Φ : *) + (* ElimAcc (X:=X) True (fupd E E) (fupd E E) *) + (* α β γ (WP s @ id; E {{ Φ }}) *) + (* (λ x, WP s @ id; E {{ v, |={E}=> β x ∗ (γ x -∗? Φ v) }})%I. *) + (* Proof. *) + (* rewrite /ElimAcc. *) + (* iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". *) + (* iApply wp_fupd. *) + (* iApply (wp_wand with "(Hinner Hα)"). *) + (* iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose". *) + (* Qed. *) + +End proofmode_classes. diff --git a/theories/middle/excl.v b/theories/middle/excl.v new file mode 100644 index 0000000..20a2c96 --- /dev/null +++ b/theories/middle/excl.v @@ -0,0 +1,96 @@ +(* This file includes the exclusive invariant and specialised rules *) +(* From stdpp Require Import unstable.bitvector. *) + +From iris.proofmode Require Import tactics. + +From iris.base_logic.lib Require Export invariants. + +From self Require Import stdpp_extra. +From self.low Require Import instantiation. +From self.lang Require Export mm. + +Import uPred. + +Section definition. + Context `{AAIrisG}. + + Definition excl_inv_name (eid_w : EID.t) := (nroot .@ (encode eid_w)). + + Definition excl_inv eid_w P : iProp Σ := + inv (excl_inv_name eid_w) (P eid_w ∨ ∃ eid_xr eid_xw, eid_w -{(Edge.Rf)}> eid_xr ∗ eid_xr -{(Edge.Rmw)}> eid_xw ∗ Tok{ eid_xw }). + +End definition. + +Section rules. + Context `{AABaseG Σ}. + + Lemma rmw_is_bij a b c: + b ≠ c -> + a -{Edge.Rmw}> b -∗ + a -{Edge.Rmw}> c -∗ + False. + Proof. + rewrite edge_eq /edge_def. + iIntros (?) "[% (Hgr1&_&%Hwf&%)] [% (Hgr2&_&_&%)]". + iDestruct (graph_agree_agree with "Hgr1 Hgr2") as %<-. + simpl in *. + rewrite /AACandExec.NMSWF.wf in Hwf. + assert (AACandExec.NMSWF.rmw_wf gr) as Hrmw_wf by naive_solver. + clear Hwf. + rewrite CBool.bool_unfold in Hrmw_wf. + destruct_and ? Hrmw_wf. + exfalso. + rewrite GRel.grel_functional_spec in H4. + specialize (H4 _ _ _ H2 H3). done. + Qed. + + Lemma rmw_rmw eid_w eid_xw eid_xw' eid_xr eid_xr' : + eid_xr ≠ eid_xr' -> + eid_w -{Edge.Rf}> eid_xr -∗ + eid_xr -{Edge.Rmw}> eid_xw -∗ + eid_w -{Edge.Rf}> eid_xr' -∗ + eid_xr' -{Edge.Rmw}> eid_xw' -∗ + False. + Proof. + rewrite edge_eq /edge_def. + iIntros (?) "[% (Hgr1&%Hcs&%Hwf&%)] [% (Hgr2&_&_&%)] [% (Hgr3&_&_&%)] [% (Hgr4&_&_&%)]". + iDestruct (graph_agree_agree with "Hgr1 Hgr2") as %<-. + iDestruct (graph_agree_agree with "Hgr1 Hgr3") as %<-. + iDestruct (graph_agree_agree with "Hgr1 Hgr4") as %<-. + simpl in *. + iPureIntro. + apply (Graph.rmw_rmw gr eid_w eid_xr eid_xr' eid_xw eid_xw'); assumption. + Qed. + + Lemma excl_inv_open_succ `{!invGS_gen HasNoLc Σ} eid_w eid_xr eid_xw E P : + ↑(excl_inv_name eid_w) ⊆ E -> + (Tok{ eid_xw } ∗ eid_w -{Edge.Rf}> eid_xr ∧ ⌜EID.tid eid_w ≠ EID.tid eid_xr⌝ ∗ eid_xr -{(Edge.Rmw)}> eid_xw ∗ + excl_inv eid_w P) + ={E, E ∖ ↑(excl_inv_name eid_w)}=∗ ▷ (P eid_w ∗ |={E ∖ ↑(excl_inv_name eid_w),E}=> emp). + Proof. + iIntros (Hsub) "(Htok & Hrf & %Hext & Hrwm & Hinv)". + iInv "Hinv" as "P" "Hclose". + iModIntro. iNext. + iDestruct "P" as "[$ | (%eid_xr'&%eid_xw'&Hrf'&Hrmw&Htok')]". + iApply ("Hclose" with "[-]"). + { iNext. iRight. iExists _,_. iFrame. } + iDestruct (token_excl with "Htok Htok'") as %Hneq. + destruct (decide (eid_xr = eid_xr')) as [<-|]. + { + iExFalso. by iApply (rmw_is_bij with "Hrwm Hrmw"). + } + { + iExFalso. iApply (rmw_rmw with "Hrf Hrwm Hrf' Hrmw");done. + } + Qed. + + Lemma excl_inv_alloc `{!invGS_gen HasNoLc Σ} {E} eid_w P: + P eid_w ={E}=∗ excl_inv eid_w P. + Proof. + iIntros "P". + iDestruct (inv_alloc (nroot .@ (encode eid_w)) with "[P]") as ">Inv". + 2:{ iModIntro. rewrite /excl_inv. iFrame "Inv". } + iNext. iLeft;done. + Qed. + +End rules. diff --git a/theories/middle/instantiation.v b/theories/middle/instantiation.v new file mode 100644 index 0000000..00cdf4f --- /dev/null +++ b/theories/middle/instantiation.v @@ -0,0 +1,260 @@ +(** This file contains the instantiation of the middle-level logic, + this is the file that all helper files import*) +From iris_named_props Require Export named_props. +From iris.proofmode Require Import base tactics classes. +From iris.algebra Require Export agree gset lib.dfrac_agree. +From iris.base_logic.lib Require Export ghost_map. + +From self.lang Require Import opsem. +From self.low Require Export instantiation. +From self.middle Require Export weakestpre. + + +Class AAThreadInG `{CMRA Σ} := { + AAInGRegs :> ghost_mapG Σ RegName RegVal; + AAInGCtrlSrc :> inG Σ (dfrac_agreeR (gsetO Eid)); + AAInGRmwPred :> inG Σ (dfrac_agreeR (optionO (leibnizO Eid))); +}. + +Class ThreadGN `{AALocGNs : !ThreadGNL} := { + AARegN : gname; + AACtrlSrcN : gname; + AARmwPredN : gname; + }. + +#[global] Arguments AARegN {_ _}. +#[global] Arguments AACtrlSrcN {_ _}. +#[global] Arguments AARmwPredN {_ _}. + +Section genAAThreadG. + Class AAThreadG `{CMRA Σ} := + GenAALThreadG{ + AAIn :> AAThreadInG; + }. + + Definition AAThreadΣ : gFunctors := + #[ + ghost_mapΣ RegName RegVal; + GFunctor (dfrac_agreeR (gsetO Eid)); + GFunctor (dfrac_agreeR (optionO (leibnizO Eid))) + ]. + + #[global] Instance subG_AAThreadpreG `{CMRA Σ}: subG AAThreadΣ Σ -> AAThreadInG. + Proof. solve_inG. Qed. + +End genAAThreadG. + +Definition reg_mapsto_def `{CMRA Σ} `{!AAThreadG} `{ThreadGN} (r : RegName) (v: RegVal) : iProp Σ := + r ↪[AARegN] v. +Definition reg_mapsto_aux : seal (@reg_mapsto_def). by eexists. Qed. +Definition reg_mapsto := unseal reg_mapsto_aux. +Arguments reg_mapsto {Σ _ _ _ _}. +Definition reg_mapsto_eq : @reg_mapsto = @reg_mapsto_def := + seal_eq reg_mapsto_aux. +Notation "r ↦ᵣ v" := (reg_mapsto r v) (at level 20) : bi_scope. + +Definition ctrl_src_half_def `{CMRA Σ} `{!AAThreadG} `{ThreadGN} (s: gset Eid) : iProp Σ := + ∃ s', ⌜s ⊆ s'⌝ ∗ own AACtrlSrcN (to_dfrac_agree (DfracOwn (1/2)%Qp) (s' : (gsetO Eid))). +Definition ctrl_src_half_aux : seal (@ctrl_src_half_def). by eexists. Qed. +Definition ctrl_src_half := unseal ctrl_src_half_aux. +Arguments ctrl_src_half {Σ _ _ _ _}. +Definition ctrl_src_half_eq : @ctrl_src_half = @ctrl_src_half_def := + seal_eq ctrl_src_half_aux. +Notation "s -{Ctrl}>" := (ctrl_src_half s) (at level 20) : bi_scope. + +Definition rmw_pred_half_def `{CMRA Σ} `{!AAThreadG} `{ThreadGN} (me : option Eid) : iProp Σ := + own AARmwPredN (to_dfrac_agree (DfracOwn (1/2)%Qp) (me : (optionO (leibnizO Eid)))). + +Definition rmw_pred_half_aux : seal (@rmw_pred_half_def). by eexists. Qed. +Definition rmw_pred_half := unseal rmw_pred_half_aux. +Arguments rmw_pred_half {Σ _ _ _ _}. +Definition rmw_pred_half_eq : @rmw_pred_half = @rmw_pred_half_def := + seal_eq rmw_pred_half_aux. + +Notation "m -{Rmw}>" := (rmw_pred_half m) (at level 20) : bi_scope. + +Section instantiation. + Context `{CMRA Σ} `{!AAThreadG} `{ThreadGN}. + + Definition reg_interp regs := ghost_map_auth AARegN 1%Qp regs. + + Lemma reg_mapsto_ne {r r' v v'} : + r ↦ᵣ v -∗ + r' ↦ᵣ v' -∗ + ⌜r ≠ r'⌝. + Proof. + rewrite reg_mapsto_eq /reg_mapsto_def. + apply ghost_map_elem_ne. + Qed. + + Lemma reg_interp_agree {regs r v} : + reg_interp regs -∗ + r ↦ᵣ v -∗ + ⌜regs !! r = Some v⌝. + Proof. + rewrite reg_mapsto_eq /reg_mapsto_def. + apply ghost_map_lookup. + Qed. + + Lemma reg_interp_agree_big {regs regs'} : + reg_interp regs -∗ + ([∗ map] r ↦ v∈ regs', r ↦ᵣ v) -∗ + ⌜regs' ⊆ regs⌝. + Proof. + rewrite reg_mapsto_eq /reg_mapsto_def. + apply ghost_map_lookup_big. + Qed. + + Lemma reg_interp_update {regs r v} v' : + reg_interp regs -∗ + r ↦ᵣ v ==∗ + reg_interp (<[r := v']> regs) ∗ r ↦ᵣ v'. + Proof. + rewrite reg_mapsto_eq /reg_mapsto_def. + apply ghost_map_update. + Qed. + + Definition ctrl_srcs_interp (s: gsetO Eid) := own AACtrlSrcN (to_dfrac_agree (DfracOwn (1/2)%Qp) s). + + Lemma ctrl_srcs_interp_agree {s s'} : + ctrl_srcs_interp s -∗ + s' -{Ctrl}> -∗ + ⌜s' ⊆ s⌝. + Proof. + rewrite ctrl_src_half_eq /ctrl_src_half_def. + iIntros "H1 [% [%Hsub H2]]". + iDestruct (own_valid_2 with "H1 H2") as %Hvalid. + rewrite dfrac_agree_op_valid_L in Hvalid. + destruct Hvalid as [_ ->]. done. + Qed. + + Lemma ctrl_srcs_interp_union {s s'} s'' : + ctrl_srcs_interp s -∗ + s' -{Ctrl}> ==∗ + ctrl_srcs_interp (s'' ∪ s) ∗ (s'' ∪ s') -{Ctrl}>. + Proof. + iIntros "H1 H2". + iDestruct (ctrl_srcs_interp_agree with "H1 H2") as %Hsub. + rewrite ctrl_src_half_eq /ctrl_src_half_def. + iDestruct "H2" as "[% [%Hsub' H2]]". + iDestruct (own_update with "[H1 H2]") as ">H". + 2:{ iCombine "H1 H2" as "H". iFrame. } + apply (dfrac_agree_update_2 _ _ _ _ (s'' ∪ s)). rewrite dfrac_op_own. + f_equal. apply (bool_decide_unpack _). by compute. + rewrite own_op. iDestruct "H" as "[? ?]". + iModIntro. iFrame. + iExists _. iFrame. iPureIntro. set_solver + Hsub. + Qed. + + Definition rmw_pred_interp (m : optionO (leibnizO Eid)) := own AARmwPredN (to_dfrac_agree (DfracOwn (1/2)%Qp) m). + + Lemma rmw_pred_interp_agree {m m'} : + rmw_pred_interp m -∗ + m' -{Rmw}> -∗ + ⌜m = m'⌝. + Proof. + rewrite rmw_pred_half_eq /rmw_pred_half_def. + iIntros "H1 H2". + iDestruct (own_valid_2 with "H1 H2") as %Hvalid. + rewrite dfrac_agree_op_valid_L in Hvalid. + destruct Hvalid as [_ ->]. done. + Qed. + + Lemma rmw_pred_interp_update {m m'} m'' : + rmw_pred_interp m -∗ + m' -{Rmw}> ==∗ + rmw_pred_interp m'' ∗ m'' -{Rmw}>. + Proof. + iIntros "H1 H2". + iDestruct (rmw_pred_interp_agree with "H1 H2") as %->. + rewrite rmw_pred_half_eq /rmw_pred_half_def. + iDestruct (own_update with "[H1 H2]") as ">H". + 2:{ iCombine "H1 H2" as "H". iFrame. } + apply (dfrac_agree_update_2 _ _ _ _ m''). rewrite dfrac_op_own. + f_equal. apply (bool_decide_unpack _). by compute. + rewrite own_op. iDestruct "H" as "[? ?]". + iModIntro. iFrame. + Qed. + + Definition thread_local_interp (ts : ThreadState.t) : iProp Σ := + "Hinterp_reg" ∷ reg_interp ts.(ThreadState.ts_regs) ∗ + "[% Hinterp_pc]" ∷ (∃ w, RNPC ↦ᵣ (mk_regval w ∅)) ∗ + "Hinterp_ctrl" ∷ ctrl_srcs_interp ts.(ThreadState.ts_ctrl_srcs) ∗ + "Hinterp_rmw" ∷ rmw_pred_interp ts.(ThreadState.ts_rmw_pred). + + Definition ready_for_next_ins_at (w : Addr) (ts : ThreadState.t) : Prop := + ts.(ThreadState.ts_reqs) = EmptyInterp ∧ + ts.(ThreadState.ts_regs) !! RNPC = Some (mk_regval w ∅). + +End instantiation. + + +Lemma thread_local_interp_alloc `{CMRA Σ} `{!AAThreadG} (HGNL: ThreadGNL) (ts : ThreadState.t): + (∃ w, ts.(ThreadState.ts_regs) !! RNPC = Some (mk_regval w ∅)) -> + ⊢ |==> ∃ `{!ThreadGN}, thread_local_interp ts ∗ + ([∗ map] r ↦ rv ∈ (delete (RNPC) ts.(ThreadState.ts_regs)), r ↦ᵣ rv) ∗ + ts.(ThreadState.ts_ctrl_srcs) -{Ctrl}> ∗ + ts.(ThreadState.ts_rmw_pred) -{Rmw}>. +Proof. + iIntros ([? Hpc]). + iMod (ghost_map_alloc ts.(ThreadState.ts_regs)) as "[%RN [Hinterp_reg Hregs]]". + iMod (own_alloc ((to_dfrac_agree ((DfracOwn (1/2)%Qp) ⋅ (DfracOwn (1/2))%Qp) ts.(ThreadState.ts_ctrl_srcs)))) as "[%CN Hinterp_ctrl]". done. + rewrite dfrac_agree_op. rewrite own_op. iDestruct "Hinterp_ctrl" as "[Hinterp_ctrl Hinterp_ctrl']". + iMod (own_alloc ((to_dfrac_agree ((DfracOwn (1/2)%Qp) ⋅ (DfracOwn (1/2))%Qp) (ts.(ThreadState.ts_rmw_pred) : optionO (leibnizO Eid))))) as "[%WN Hinterp_rmw]". done. + rewrite dfrac_agree_op. rewrite own_op. iDestruct "Hinterp_rmw" as "[Hinterp_rmw Hinterp_rmw']". + iModIntro. + iExists (Build_ThreadGN HGNL RN CN WN). + iFrame. rewrite rmw_pred_half_eq ctrl_src_half_eq. iFrame. + rewrite big_sepM_delete;last exact Hpc. iDestruct "Hregs" as "[Hpc Hregs]". + rewrite reg_mapsto_eq. iFrame. iSplitL "Hpc"; iExists _;iFrame. done. +Qed. + +(* Instantiation of mid-level logic *) +#[global] Instance instantiation_irisGInst `{AAThreadG} `{ThreadGN} + : irisGInst := { + inst_thread_interp := thread_local_interp; + inst_addr_is := ready_for_next_ins_at; + }. + +Lemma inst_post_lifting_lifting `{AAIrisG} tid Φ (addr: Addr) annot : + set_Forall (λ e, (EID.tid e) = tid) (dom annot) -> + ([∗ map] e ↦ P ∈ annot, e ↦ₐ P) -∗ + (([∗ map] _ ↦ P ∈ annot, P) ==∗ Φ (LTSI.Done, addr)) -∗ + inst_post_lifting tid addr Φ. +Proof. + iIntros (Hdom) "Hannot Himp". iIntros (?) "[Hinterp ?]". + iDestruct (annot_agree_big with "Hinterp Hannot") as "[%Hsub #[% Hag]]". + iModIntro. iSplitR "Himp Hannot". iFrame. + iIntros "All". + iApply "Himp". iApply big_sepM_later_2. + iClear "Hannot". + iInduction annot as [|i x Hlkm H' ] "IH" using map_ind forall (m'' na Hsub). done. + rewrite big_sepM_insert;last done. + rewrite dom_insert_L in Hdom. assert (is_Some(na !! i)) as [? Hlk]. + apply elem_of_dom. set_solver. + iDestruct (big_sepM2_dom with "Hag") as %Hdom'. + assert (is_Some(m'' !! i) ) as [? Hlk'']. + apply elem_of_dom. set_solver + Hdom'. + rewrite -(insert_delete m'' i x1);last done. + rewrite big_sepM2_insert. 2:done. 2: apply lookup_delete_None;left;done. + rewrite Hlk /=. + rewrite -(insert_delete na i x0);last done. + iDestruct (big_sepM_insert with "All") as "[H All]". + apply lookup_delete_None;left;done. + case_bool_decide. + 2:{ specialize (Hdom i). feed specialize Hdom. set_solver +. done. } + iDestruct "Hag" as "[Hag1 Hag]". + iSplitL "H". + iNext. iDestruct ("Hag1" with "H") as "[$ _]". + iApply ("IH" with "[] [] [Hag] All"). + iPureIntro. apply set_Forall_union_inv_2 in Hdom. done. + iPureIntro. rewrite dom_delete_L. apply elem_of_dom_2 in Hlk. apply not_elem_of_dom_2 in H'. set_solver. + iModIntro. + iApply (big_sepM2_impl with "Hag"). + iModIntro. iIntros (??? Hlkm' Hlkdm). + destruct (decide (i = k)). subst k. + rewrite lookup_delete_Some in Hlkdm. destruct Hlkdm;done. + rewrite lookup_delete_ne //. + rewrite insert_delete //. + iApply bi.wand_refl. +Qed. diff --git a/theories/middle/rules.v b/theories/middle/rules.v new file mode 100644 index 0000000..daa4991 --- /dev/null +++ b/theories/middle/rules.v @@ -0,0 +1,1069 @@ +(* This file lifts rules of the low-level logic to mid-level *) +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +Require Import ISASem.SailArmInstTypes. + +From self Require Import stdpp_extra. +From self.lang Require Export opsem. +From self.low.rules Require Export prelude write_xcl write read barrier util reg announce. +From self.middle Require Export instantiation excl. + +Import uPred. + +Lemma reg_dep_fold_eq (dep : list _) (ts_regs dep_regs : gmap _ _): + dep_regs ⊆ ts_regs -> + dom dep_regs = list_to_set dep -> + (foldr (λ (r : AAInter.reg) (acc : gset Eid), from_option (λ rd : RegVal, reg_dep rd ∪ acc) acc (ts_regs !! r)) ∅ + dep = (map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs)). +Proof. + revert dep_regs ts_regs. + induction dep using list_subset_ind;intros dep_regs ts_regs Hsub Hdom. + { + rewrite list_to_set_nil in Hdom. + apply dom_empty_inv_L in Hdom. + subst. done. + } + { + destruct dep. + rewrite list_to_set_nil in Hdom. + apply dom_empty_inv_L in Hdom. + subst. done. + rewrite list_to_set_cons in Hdom. simpl. + assert (Hin: r ∈ dom dep_regs) by set_solver + Hdom. + rewrite elem_of_dom in Hin. destruct Hin as [b Hlk]. + rewrite -(insert_delete dep_regs r b Hlk). + pose proof Hsub as Hsub'. + rewrite map_subseteq_spec in Hsub. + apply (Hsub r b) in Hlk. rewrite Hlk /=. + rewrite map_fold_insert_L. + pose proof (list_filter_split dep (λ x, x = r)) as Hsplit. + rewrite (foldr_permutation (=) _ _ dep _ _ Hsplit). + 2:{ + intros. destruct (ts_regs !! a1), (ts_regs !! a2);simpl;auto. set_solver +. + } + pose proof (list_foldr_absorb (filter (λ x : AAInter.reg, x = r) dep) (filter (λ x : AAInter.reg, x ≠ r) dep) + (λ (r0 : AAInter.reg) (acc : gset Eid), from_option (λ rd : RegVal, reg_dep rd ∪ acc) acc (ts_regs !! r0)) + ∅ r ) as Heq. + feed specialize Heq. + { + clear Heq Hsplit Hdom H. + induction dep. by apply Forall_nil. + rewrite filter_cons. + case_decide. + rewrite Forall_cons. + split;done. + done. + } + { intros. rewrite Hlk /=. set_solver +. } + rewrite Hlk /=in Heq. rewrite Heq. + specialize (H (filter (λ x : AAInter.reg, x ≠ r) dep)). + feed specialize H. + exists r. exists (filter (λ x : AAInter.reg, x = r) dep). + rewrite -Permutation_cons_app. reflexivity. + rewrite Permutation_app_comm. done. + specialize (H (delete r dep_regs) ts_regs). + feed specialize H. + etransitivity;[|exact Hsub']. apply delete_subseteq. + rewrite dom_delete_L. rewrite Hdom. + rewrite difference_union_distr_l_L. + rewrite difference_diag_L. rewrite union_empty_l_L. + { + clear Heq Hsplit Hdom H. + induction dep. + rewrite filter_nil. set_solver +. + rewrite filter_cons. + case_decide. + rewrite 2!list_to_set_cons. + rewrite -IHdep. set_solver + H. + set_solver + H IHdep. + } + rewrite H //. + intros. set_solver +. + apply lookup_delete_None;left;done. + } +Qed. + + +Require Import ISASem.Interface. +Require Import Coq.Logic.FunctionalExtensionality. + +Lemma iMon_bind_assoc {a b c: Type} + (h : AACandExec.iMon a) + (f : a -> AACandExec.iMon b) + (g : b -> AACandExec.iMon c) : + (h ≫= (λ x, f x ≫= g)) = ((h ≫= f) ≫= g). +Proof. + rewrite /mbind. + rewrite /AAInter.iMon_mbind_inst. + induction h ;simpl. done. + f_equal. + extensionality x. + specialize (H x). done. +Qed. + +Section rules. + Context `{AAIrisG} `{!AAThreadG} `{ThreadGN} `{!UserProt}. + Import ThreadState. + + Lemma idone {addr tid Φ}: + addr ↦ᵢ - -∗ + Φ (LTSI.Done, addr) -∗ + SSWPi (LTSI.Normal, addr) @ tid {{ Φ }}. + Proof. + iIntros "Hinst Hpost". rewrite sswpi_eq /sswpi_def. + iIntros (?). iNamed 1. rewrite wpi_eq /wpi_def. + iIntros (? [? ?]). repeat iNamed 1. + iApply wp_sswp. + iApply (sswp_strong_mono with "[Hinst]"). + { iApply (terminate with "[Hinst]") => //=. } + iIntros (? ->). simpl. + iApply ("Hcont" with "Hpost");done. + Qed. + + Ltac load_ins := + rewrite sswpi_eq /sswpi_def; + iIntros (?); iNamed 1; rewrite wpi_eq /wpi_def; + iIntros (? [? ?]); repeat iNamed 1; + iApply wp_sswp; iApply (sswp_strong_mono with "[Hinst]"); + first (iApply (reload with "[Hinst]");eauto); iIntros (? ->); simpl. + + Lemma ibr {tid : Tid} {ins_addr addr} : + ins_addr ↦ᵢ (IBr addr) + ⊢ + SSWPi (LTSI.Normal, ins_addr) @ tid + {{ λ ltsi, ⌜ltsi = (LTSI.Normal, addr)⌝ }}. + Proof. + iIntros "Hinst". load_ins. + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply (reg_write);eauto. + simpl. iIntros (? ->). rewrite union_empty_l_L. + iNamed "Hinterp". iMod (reg_interp_update with "Hinterp_reg Hinterp_pc") as "[Hinterp_reg Hinterp_pc]". + + iApply ("Hcont" $! (LTSI.Normal, addr) with "[//]"). + iPureIntro. split;auto. apply lookup_insert_Some;naive_solver. + iFrame;simpl. iExists _;iFrame. + Qed. + + Lemma inc_pc {tid : Tid} {ins_addr ts Ψ}: + ts.(ThreadState.ts_reqs) = IncPCInterp -> + ts_regs ts !! RNPC = Some {| reg_val := ins_addr; reg_dep := ∅ |} -> + (∀ ltsi' : LTSI.t, + ⌜ltsi' = (LTSI.Normal, (ins_addr `+Z` 4)%bv)⌝ -∗ + ∀ ts0 : ThreadState.t, + "%PC" ∷ ⌜ready_for_next_ins_at ltsi'.2 ts0⌝ -∗ + "Hinterp" ∷ thread_local_interp ts0 -∗ + WP LTSI.to_lts ltsi'.1 ts0 @ tid {{ lts, to_lts_Phi (λ ltsi0 : LTSI.t, Ψ ltsi0) lts }})-∗ + thread_local_interp ts -∗ + WP LThreadState.LTSNormal ts @ tid {{ lts, to_lts_Phi Ψ lts }}. + Proof. + iIntros (Hreqs PC) "Hcont Hinterp". + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_read;eauto. + simpl. iIntros (? ->). + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_write;eauto. + simpl. iIntros (? ->). + + iNamed "Hinterp". iMod (reg_interp_update with "Hinterp_reg Hinterp_pc") as "[Hinterp_reg Hinterp_pc]". + + iApply ("Hcont" with "[//]"). + iPureIntro. split;auto. apply lookup_insert_Some;naive_solver. + iFrame;simpl. iExists _;iFrame. + Qed. + + Lemma inop {tid : Tid} {ins_addr} : + ins_addr ↦ᵢ (INop) + ⊢ + SSWPi (LTSI.Normal, ins_addr) @ tid + {{ λ ltsi, ⌜ltsi = (LTSI.Normal, (ins_addr `+Z` 4)%bv)⌝}}. + Proof. + iIntros "Hinst". load_ins. + + iApply (inc_pc with "[Hcont]");eauto. + Qed. + + Lemma idmb {tid : Tid} {ins_addr kind o_po_src} : + ins_addr ↦ᵢ (IDmb kind) -∗ + o_po_src -{LPo}> -∗ + SSWPi (LTSI.Normal, ins_addr) @ tid + {{ λ ltsi, ⌜ltsi = (LTSI.Normal,(ins_addr `+Z` 4)%bv)⌝ ∗ + ∃ eid, eid -{E}> (Event.B (AAArch.DMB kind)) ∗ + (* Po *) + from_option (λ eid_po_src, eid_po_src -{(Edge.Po)}> eid) emp o_po_src ∗ + (Some eid) -{LPo}> + }}. + Proof. + iIntros "Hinst Hpo". load_ins. + + iApply wp_sswp. iApply (sswp_strong_mono with "[Hpo]"). + { iApply (dmb with "Hpo"). reflexivity. } + iIntros (k) "[% (?&?&?)]";simpl;subst k. + + iApply (wp_strong_mono with "[-]"). 2: { iIntros (?) "H". iModIntro. iExact "H". } + iApply (inc_pc with "[-Hinterp]");eauto. + iIntros (?) "Hpost". iApply "Hcont". iFrame. iExists _;iFrame. + Qed. + + Lemma iisb {tid : Tid} {ins_addr o_po_src ctrl_srcs} : + ins_addr ↦ᵢ IIsb -∗ + o_po_src -{LPo}> -∗ + ctrl_srcs -{Ctrl}> -∗ + SSWPi (LTSI.Normal, ins_addr) @ tid + {{ λ ltsi, ⌜ltsi = (LTSI.Normal, (ins_addr `+Z` 4)%bv) ⌝ ∗ + ∃ eid, eid -{E}> (Event.B AAArch.ISB) ∗ + (* Po *) + from_option (λ eid_po_src, eid_po_src -{(Edge.Po)}> eid) emp o_po_src ∗ + (Some eid) -{LPo}> ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + ctrl_srcs -{Ctrl}> + }}. + Proof. + iIntros "Hinst Hpo Hctrl". load_ins. + + iApply wp_sswp. iApply (sswp_strong_mono with "[Hpo]"). + iApply (isb with "Hpo"). reflexivity. + iIntros (?) "[-> (?&?&?&?)]";simpl. + rewrite /get_progress /=. + + iAssert (⌜ctrl_srcs ⊆ ts_ctrl_srcs ts⌝)%I with "[Hinterp Hctrl]" as %Hsub. + iNamed "Hinterp". iApply (ctrl_srcs_interp_agree with "Hinterp_ctrl Hctrl"). + + iApply (wp_strong_mono with "[-]"). 2: { iIntros (?) "H". iModIntro. iExact "H". } + iApply (inc_pc with "[-Hinterp]"); eauto. + iIntros (?) "Hpost". iApply "Hcont". iFrame. + + iExists _;iFrame. iApply big_sepS_subseteq;eauto. + Qed. + + + Fixpoint eval_ae_val ae (regs : RegFile) := + match ae with + | AEval w => Some w + | AEreg r => (λ rv, rv.(reg_val)) <$> regs !! r + | AEbinop op ae1 ae2 => + eval_ae_val ae1 regs + ≫= (λ w1 : bv (8 * AAArch.val_size), + eval_ae_val ae2 regs + ≫= (λ w2 : bv (8 * AAArch.val_size), + Some match op with + | AOplus => (w1 + w2)%bv + | AOminus => (w1 - w2)%bv + | AOtimes => (w1 * w2)%bv + end)) + end. + + Lemma eval_ae_val_subseteq ae regs regs' v: + eval_ae_val ae regs = Some v -> + regs ⊆ regs' -> + eval_ae_val ae regs' = Some v. + Proof. + revert regs regs' v. + induction ae. + - simpl. done. + - simpl. intros. + rewrite fmap_Some. + rewrite fmap_Some in H4. + destruct H4 as (?&?&?). + eexists. split;eauto. + specialize (H5 r). rewrite H4 /= in H5. + destruct (regs' !! r) eqn:Heqn. subst x;done. done. + - simpl. intros ??? Hae_val ?. + destruct (eval_ae_val ae1 regs) eqn:Hae_val1. 2:{ inversion Hae_val. } + destruct (eval_ae_val ae2 regs) eqn:Hae_val2. 2:{ inversion Hae_val. } + simpl in Hae_val. + erewrite IHae1;eauto. + erewrite IHae2;eauto. + Qed. + + Lemma eval_ae_val_Some_unique ae regs v: + eval_ae_val ae regs = Some v -> + eval_ae_val ae (filter (λ '(r,_) , r ∈@{gset _} list_to_set (dep_of_AE_aux ae)) regs) = Some v. + Proof. + revert v. induction ae;simpl;first done. + - intros. rewrite map_filter_lookup. + rewrite fmap_Some. + rewrite fmap_Some in H4. + destruct H4 as (?&?&?). + eexists. rewrite H4 /=. rewrite option_guard_True. + split;eauto. + set_solver +. + - intros ? Hae_val. + destruct (eval_ae_val ae1 regs) eqn:Hae_val1. 2:{ inversion Hae_val. } + destruct (eval_ae_val ae2 regs) eqn:Hae_val2. 2:{ inversion Hae_val. } + simpl in Hae_val. + rewrite list_to_set_app_L. + specialize (IHae1 v0). feed specialize IHae1;auto. rewrite (eval_ae_val_subseteq _ _ _ _ IHae1). + 2: { apply map_filter_strong_subseteq_ext. intros ? ? []. split;[set_solver|done]. } + specialize (IHae2 v1). feed specialize IHae2;auto. rewrite (eval_ae_val_subseteq _ _ _ _ IHae2). + 2: { apply map_filter_strong_subseteq_ext. intros ? ? []. split;[set_solver|done]. } + done. + Qed. + + Fixpoint count_ae_reg ae : nat := + match ae with + | AEval w => 0 + | AEreg r => 1 + | AEbinop op ae1 ae2 => + count_ae_reg ae1 + count_ae_reg ae2 + end. + + Lemma ts_iis_incr_cntr_inversion ts ts' n: + ts_iis ts' = ts_iis ts -> + ts_iis (Nat.iter n incr_cntr ts') = ts_iis (PeanoNat.Nat.iter n incr_cntr ts). + Proof. + revert ts ts'. induction n;first done. + intros. rewrite /= (IHn ts ts') //. + Qed. + + Lemma ae_eval {tid : Tid} {ins_addr ts ae ctxt val Ψ} dep_regs: + ts.(ThreadState.ts_reqs) = AEInterp ae ≫= ctxt -> + ts_regs ts !! RNPC = Some {| reg_val := ins_addr; reg_dep := ∅ |} -> + dom dep_regs = list_to_set (dep_of_AE_aux ae) -> + eval_ae_val ae dep_regs = Some val -> + ( ∀ ts' : ThreadState.t, + ⌜ts_regs ts' !! RNPC = Some {| reg_val := ins_addr; reg_dep := ∅ |} ⌝ -∗ + ⌜ts'.(ThreadState.ts_reqs) = ctxt val ∧ + ts'.(ThreadState.ts_iis) = (Nat.iter (count_ae_reg ae) incr_cntr ts).(ThreadState.ts_iis)⌝ -∗ + ([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv) -∗ + thread_local_interp ts' -∗ + WP LThreadState.LTSNormal ts' @ tid {{ ltsi, to_lts_Phi Ψ ltsi }}) -∗ + ([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv) -∗ + thread_local_interp ts -∗ + WP LThreadState.LTSNormal ts @ tid {{ ltsi, to_lts_Phi Ψ ltsi }}. + Proof. + intros Hreqs Hpc Hreg_dom Hae_val. revert ctxt dep_regs val ts Hreqs Hpc Hreg_dom Hae_val. + induction ae; iIntros (????????) "Hcont HDR Hinterp";simpl in *. + { + inversion Hae_val;subst w. + iApply ("Hcont" with "[//] [//] HDR Hinterp"). + } + { + rewrite union_empty_r_L in Hreg_dom. apply dom_singleton_inv_L in Hreg_dom. + destruct Hreg_dom as [? ->]. simplify_map_eq /=. rewrite {2}big_sepM_singleton. + + iAssert (⌜ ts_regs ts !! r = Some x⌝)%I with "[Hinterp HDR]" as %Hreg_val. + iNamed "Hinterp". iDestruct (reg_interp_agree with "Hinterp_reg HDR") as %Hlk;done. + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_read;eauto. + iIntros (? ->); simpl. + + iApply ("Hcont" with "[] [] [HDR]");auto. + rewrite big_sepM_singleton //. + } + assert (filter (λ '(k, _), k ∈@{gset _} list_to_set (dep_of_AE_aux ae1)) dep_regs ##ₘ filter (λ '(k, _), k ∉@{gset _} list_to_set (dep_of_AE_aux ae1)) dep_regs) as Hdomdisj. + { + pose proof (filter_dom_L (λ k: RegName, k ∈@{gset _} (list_to_set (dep_of_AE_aux ae1))) dep_regs) as Hdomeq2; simpl in Hdomeq2. + pose proof (filter_dom_L (λ k: RegName, k ∉@{gset _} (list_to_set (dep_of_AE_aux ae1))) dep_regs) as Hdomeq2'; simpl in Hdomeq2'. + apply map_disjoint_dom. rewrite -Hdomeq2 -Hdomeq2'. + pose proof (set_filter_split (dom dep_regs) (λ (k : RegName), k ∈@{gset _} list_to_set (dep_of_AE_aux ae1))) as [_ ?]. done. + } + { + pose proof (map_filter_split dep_regs (λ (k : RegName), k ∈@{gset _} list_to_set (dep_of_AE_aux ae1))) as <-. + iDestruct (big_sepM_union with "HDR") as "[HDR1 HDR2]";auto. + + destruct (eval_ae_val ae1 dep_regs) eqn:Hae_val1. 2:{ inversion Hae_val. } + destruct (eval_ae_val ae2 dep_regs) eqn:Hae_val2. 2:{ inversion Hae_val. } + simpl in Hae_val. + + iApply (IHae1 with "[Hcont HDR2] HDR1"). + { rewrite Hreqs. rewrite -iMon_bind_assoc. reflexivity. } + done. + rewrite (dom_filter_L _ dep_regs (filter (λ k, k ∈@{gset _} list_to_set (dep_of_AE_aux ae1)) ((dom dep_regs): gset RegName) )). + 2:{ intros. rewrite elem_of_filter. rewrite elem_of_dom. split;[intros [? []];eexists;done|intros [? []];split;eauto]. } + assert (list_to_set (dep_of_AE_aux ae1) ⊆ dom dep_regs). + { rewrite Hreg_dom. rewrite list_to_set_app_L. set_solver +. } + apply set_eq. intros. rewrite elem_of_filter. set_solver + H4. + + eapply eval_ae_val_Some_unique;eauto. + assert (filter (λ '(k, _), k ∈@{gset _} list_to_set (dep_of_AE_aux ae2)) dep_regs ##ₘ filter (λ '(k, _), k ∉@{gset _} list_to_set (dep_of_AE_aux ae2)) dep_regs) as Hdomdisj2. + { + pose proof (filter_dom_L (λ k: RegName, k ∈@{gset _} (list_to_set (dep_of_AE_aux ae2))) dep_regs) as Hdomeq2; simpl in Hdomeq2. + pose proof (filter_dom_L (λ k: RegName, k ∉@{gset _} (list_to_set (dep_of_AE_aux ae2))) dep_regs) as Hdomeq2'; simpl in Hdomeq2'. + apply map_disjoint_dom. rewrite -Hdomeq2 -Hdomeq2'. + pose proof (set_filter_split (dom dep_regs) (λ (k : RegName), k ∈@{gset _} list_to_set (dep_of_AE_aux ae2))) as [_ ?]. done. + } + { + iIntros (?) "%Hpc' %Hreqs'". iIntros "HDR". + iDestruct (big_sepM_union with "[$HDR $HDR2]") as "HDR";auto. + pose proof (map_filter_split dep_regs (λ (k : RegName), k ∈@{gset _} list_to_set (dep_of_AE_aux ae1))) as ->. + pose proof (map_filter_split dep_regs (λ (k : RegName), k ∈@{gset _} list_to_set (dep_of_AE_aux ae2))) as <-. + + iDestruct (big_sepM_union with "HDR") as "[HDR1 HDR2]";auto. + destruct Hreqs' as [Hreqs' Hpg']. + + iApply (IHae2 with "[Hcont HDR2] HDR1"). + rewrite Hreqs'. rewrite -iMon_bind_assoc. reflexivity. + done. + + rewrite (dom_filter_L _ dep_regs (filter (λ k, k ∈@{gset _} list_to_set (dep_of_AE_aux ae2)) ((dom dep_regs): gset RegName) )). + 2:{ intros. rewrite elem_of_filter. rewrite elem_of_dom. split;[intros [? []];eexists;done|intros [? []];split;eauto]. } + assert (list_to_set (dep_of_AE_aux ae2) ⊆ dom dep_regs). + { rewrite Hreg_dom. rewrite list_to_set_app_L. set_solver +. } + apply set_eq. intros. rewrite elem_of_filter. set_solver + H4. + + eapply eval_ae_val_Some_unique;eauto. + + iIntros (?) "%Hpc'' %Hreqs''". iIntros "HDR". + iDestruct (big_sepM_union with "[$HDR $HDR2]") as "HDR";auto. + pose proof (map_filter_split dep_regs (λ (k : RegName), k ∈@{gset _} list_to_set (dep_of_AE_aux ae2))) as ->. + + iApply ("Hcont" with "[//] [] [HDR]"). + { iPureIntro. + destruct Hreqs'' as [? ?]. + split;auto. simpl in H4. inversion Hae_val;subst val. done. + rewrite H5. rewrite (comm Nat.add) Nat.iter_add. by apply ts_iis_incr_cntr_inversion. + } + done. + } + done. + } + Qed. + + Lemma ibne {tid : Tid} {ins_addr addr ae val ctrl_srcs} dep_regs: + dom dep_regs = list_to_set (dep_of_AE_aux ae) -> + eval_ae_val ae dep_regs = Some val -> + ins_addr ↦ᵢ (IBne ae addr) -∗ + ctrl_srcs -{Ctrl}> -∗ + ([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv) -∗ + SSWPi (LTSI.Normal, ins_addr) @ tid + {{ λ ltsi, + ([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv) ∗ + ((map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs) ∪ ctrl_srcs) -{Ctrl}> ∗ + ((⌜ltsi = (LTSI.Normal, (ins_addr `+Z` 4)%bv)⌝ ∗ ⌜val = (BV 64 0)⌝) + ∨ + (⌜ltsi = (LTSI.Normal, addr)⌝ ∗ ⌜val ≠ (BV 64 0)⌝)) + }}. + Proof. + iIntros (Hdom Heval) "Hinst Hctrl Hrs". load_ins. + iApply (wp_strong_mono with "[-]"). 2: { iIntros (?) "H". iModIntro. iExact "H". } + iApply (ae_eval with "[- Hinterp Hrs] Hrs"); eauto. + iIntros (?) "%PC [% %] Hrs Hinterp". + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + { + iApply branch_announce; eauto. + } + iIntros (? ->) "/=". + iNamed "Hinterp". + iDestruct (ctrl_srcs_interp_union (map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs) with "Hinterp_ctrl Hctrl") as ">(Hinterp_ctrl & Hctrl)". + + iDestruct (reg_interp_agree_big with "Hinterp_reg Hrs") as "%Hrs_sub". + case_bool_decide as Hpred. + + iApply (wp_strong_mono with "[-]"). 2: { iIntros (?) "H". iModIntro. iExact "H". } + iApply (inc_pc with "[-Hinterp_reg Hinterp_ctrl Hinterp_rmw Hinterp_pc]"); eauto. + { iIntros (?) "Hpost". iApply "Hcont". iFrame. + iLeft. + iFrame. + rewrite Hpred. iPureIntro. bv_unfold. bv_simplify. cbv. bv_solve. + } + + iFrame. + iSplitL "Hinterp_pc". { iExists w. iFrame. } + simpl. + rewrite (reg_dep_fold_eq _ _ dep_regs). + { rewrite union_empty_r_L. iFrame. } + { exact Hrs_sub. } + { exact Hdom. } + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply (reg_write); eauto. + simpl. iIntros (? ->). rewrite union_empty_l_L. + iMod (reg_interp_update with "Hinterp_reg Hinterp_pc") as "[Hinterp_reg Hinterp_pc]". + simpl. + + iApply ("Hcont" $! (LTSI.Normal, addr) with "[Hctrl Hrs]"). + { + iFrame. iRight. iSplit; [done|]. + iPureIntro. intro Heq. rewrite Heq in Hpred. contradict Hpred. cbv. bv_solve. + } + { + unfold ready_for_next_ins_at. + iPureIntro; split; [done | by rewrite lookup_insert]. + } + iFrame. + iSplitL "Hinterp_pc". { iExists addr. iFrame. } + simpl. + rewrite (reg_dep_fold_eq _ _ dep_regs). + { rewrite union_empty_r_L. iFrame. } + { exact Hrs_sub. } + { exact Hdom. } + Qed. + + Lemma iassign {tid : Tid} {ins_addr r rv ae val} dep_regs: + dom dep_regs = list_to_set (dep_of_AE_aux ae) -> + eval_ae_val ae dep_regs = Some val -> + ins_addr ↦ᵢ (IAssign r ae) -∗ + r ↦ᵣ rv -∗ + ([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv) -∗ + SSWPi (LTSI.Normal, ins_addr) @ tid + {{ λ ltsi, ⌜ltsi = (LTSI.Normal, (ins_addr `+Z` 4)%bv)⌝ ∗ + r ↦ᵣ (mk_regval val (map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs)) ∗ + ([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv) + }}. + Proof. + iIntros (Hdom Heval) "Hinst HR HDR". load_ins. + + iApply (wp_strong_mono with "[-]"). 2: { iIntros (?) "H". iModIntro. iExact "H". } + iApply (ae_eval with "[- Hinterp HDR] HDR");eauto. + iIntros (?) "%PC [% %] HDR Hinterp". + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_write;eauto. + iIntros (? ->); simpl. + + iNamed "Hinterp". + iDestruct (reg_interp_agree_big with "Hinterp_reg HDR") as %Hsub. + iDestruct (reg_interp_update with "Hinterp_reg HR") as ">[Hinterp_reg HR]". + iDestruct (reg_mapsto_ne with "HR Hinterp_pc") as %Hneq. + + iApply (wp_strong_mono with "[-]"). 2: { iIntros (?) "H". iModIntro. iExact "H". } + iApply (inc_pc with "[-Hinterp_reg Hinterp_ctrl Hinterp_rmw Hinterp_pc]");auto. + { simpl. rewrite lookup_insert_ne //. } + + iIntros (?) "Hpost". iApply "Hcont". iFrame. iFrame. + + rewrite union_empty_r_L. rewrite /incr_cntr /=. rewrite (reg_dep_fold_eq _ _ dep_regs) //. + iFrame. iExists _;iFrame. + Qed. + + (** helper lemmas *) + Lemma mem_read_external `{!UserProt} {tid : Tid} {o_po_src ctrl_srcs ts ctxt dep addr kind_s kind_v mrmw Ψ} + R po_srcs lob_annot dep_regs: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemRead 8 (readreq_of_store kind_s kind_v addr dep)) ctxt -> + dom dep_regs = list_to_set (AAInter.DepOn.regs dep) -> + let reg_deps := map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs in + let mem_deps := + foldr (λ (idx : N) (acc : gset Eid), + from_option (λ md : nat, {[{| EID.tid := tid; EID.iid := ts.(ts_iis).(iis_iid); EID.num := md |}]} ∪ acc) acc + (ts.(ts_iis).(iis_mem_reads) !! idx)) ∅ (AAInter.DepOn.mem_reads dep) in + let R_graph_facts := (λ eid val eid_w, + eid -{E}> (Event.R kind_s kind_v addr val) ∗ + ⌜(EID.tid eid) = tid ∧ (EID.iid eid) = ts.(ts_iis).(iis_iid)⌝ ∗ + (* Po *) + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + (* Addr *) + ([∗ set] eid_addr_src ∈ reg_deps ∪ mem_deps, eid_addr_src -{(Edge.Addr)}> eid) ∗ + (* There must be a write with same addr and val *) + (∃ kind_s_w kind_v_w, eid_w -{E}> (Event.W kind_s_w kind_v_w addr val)) ∗ + (* [optional] rf from write to read *) + eid_w -{(Edge.Rf)}> eid ∗ + (* eid_w is an external write *) + ⌜EID.tid eid_w ≠ tid⌝)%I in + o_po_src -{LPo}> -∗ + ctrl_srcs -{Ctrl}> -∗ + last_local_write tid addr None -∗ + mrmw -{Rmw}> -∗ + ([∗ set] e_po_src ∈ po_srcs, e_po_src -{Po}>) -∗ + ([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv) -∗ + (* node annotations *) + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) -∗ + (∀ eid, + (* Lob edge formers *) + (eid -{N}> (Edge.R kind_s kind_v) -∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) -∗ + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) -∗ + ([∗ set] eid_addr_src ∈ reg_deps ∪ mem_deps, eid_addr_src -{(Edge.Addr)}> eid) -∗ + [∗ set] eid_pre ∈ dom lob_annot, eid_pre -{Edge.Lob}> eid) ∗ + (* FE *) + (∀ val eid_w, + R_graph_facts eid val eid_w ∗ + ([∗ map] _ ↦ annot ∈ lob_annot, annot) ∗ + □(prot addr val eid_w) + ={⊤}[∅]▷=∗ + R addr val eid_w)) -∗ + (* continuation *) + ( + ∀ ts' : ThreadState.t, + "Hinterp" ∷ thread_local_interp ts' -∗ + ⌜ts'.(ts_regs) !! RNPC = ts.(ts_regs) !! RNPC⌝ -∗ + ( + (* exists a val, and a write eid_w *) + ∃ val eid_w, + (* update lts' accordingly *) + ∃ eid, + ⌜ts'.(ts_iis)= (incr_cntr ts).(ts_iis)<|iis_mem_reads := ((ts.(ts_iis).(iis_mem_reads)) ++ [eid.(EID.num)])%list|> + ∧ ts'.(ts_reqs) = ctxt (inl(val, None)) ⌝ ∗ + R_graph_facts eid val eid_w ∗ + (* node annotation *) + (eid ↦ₐ R addr val eid_w) ∗ + (Some eid) -{LPo}> ∗ + ctrl_srcs -{Ctrl}> ∗ + (* local writes at addr is unchanged *) + last_local_write tid addr None ∗ + (* Update this read as the rmw pred if atomic *) + (if bool_decide (kind_v = AV_exclusive) || bool_decide (kind_v = AV_atomic_rmw) + then Some eid else mrmw) -{Rmw}> ∗ + ([∗ map] dr ↦ dv ∈ dep_regs, dr ↦ᵣ dv) + ) -∗ + WP LThreadState.LTSNormal ts' @ tid {{ lts, to_lts_Phi Ψ lts }} + )-∗ + thread_local_interp ts -∗ + WP LThreadState.LTSNormal ts @ tid {{ λ lts', to_lts_Phi Ψ lts' }}. + Proof. + iIntros (? Hdom ???) "Hpo_src Hctrl Hlw Hrmw Hpo_srcs HDRs Hna Hef_fe Hcont Hinterp". + iNamed "Hinterp". + iDestruct (reg_interp_agree_big with "Hinterp_reg HDRs") as %Hdr_sub. + iDestruct (ctrl_srcs_interp_agree with "Hinterp_ctrl Hctrl") as %Hctrl_sub. + iDestruct (rmw_pred_interp_agree with "Hinterp_rmw Hrmw") as %Hrmw_ag. + iApply wp_sswp. + iApply (sswp_strong_mono' with "[-Hinterp_reg Hinterp_ctrl Hinterp_rmw Hinterp_pc HDRs Hctrl Hrmw Hcont]"). + iDestruct ("Hef_fe" $! (progress_to_node (get_progress ts) tid)) as "[Hef Hfe]". + + iApply (mem_read_external with "Hpo_src Hpo_srcs Hlw Hna [Hef] [Hfe]"). eauto. + { + iIntros "E_R Hpo Hctrl Haddr". + iApply ("Hef" with "E_R Hpo [Hctrl] [Haddr]"). + iApply big_sepS_subseteq;eauto. + simpl. erewrite reg_dep_fold_eq;eauto. + } + { + rewrite /R_graph_facts /=. iIntros (??) "H". + set (pg := (get_progress ts)). + erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs);eauto. rewrite /reg_deps. + iSpecialize ("Hfe" with "[-]"). + iDestruct "H" as "[(?&?&?&?&?&?) H]". + iSplitR "H". 2:{ iExact "H". } iFrame. + iSplit;first done. + iApply big_sepS_subseteq;eauto. + iExact "Hfe". + } + iIntros (k) "(%&%&%&(?&?&Hctrl'&?&?&?&?)&Hlpo&Hna&Hlw)". subst k. + iApply interp_mod_bupd'. + iMod (rmw_pred_interp_update (if bool_decide (kind_v = AV_exclusive) || bool_decide (kind_v = AV_atomic_rmw) + then Some _ else mrmw) with "Hinterp_rmw Hrmw") as "[Hinterp_rmw Hrmw]". + simpl. + iFrame. simpl. iModIntro. + + iApply ("Hcont" with "[Hinterp_reg Hinterp_ctrl Hinterp_pc Hinterp_rmw] [] [-]"). + iFrame. rewrite Hrmw_ag. iFrame. iExists _;done. + done. + iExists val,eid_w,_. iSplit. + 2:{ + iFrame. simpl. erewrite reg_dep_fold_eq;eauto. + iSplit;first done. + iSplitL "Hctrl'";last done. iApply big_sepS_subseteq;eauto. + } + done. + Qed. + + Lemma mem_write_non_xcl `{!UserProt} {tid : Tid} {o_po_src ctrl_srcs ts ctxt addr kind_s kind_v val + ot_coi_pred dep_addr dep_data Ψ} R po_srcs lob_annot dep_regs_data dep_regs_addr: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemWrite 8 (writereq_of_store kind_s kind_v val addr dep_addr dep_data)) ctxt -> + kind_v = AV_plain -> + dep_regs_addr ∩ dep_regs_data ⊆ dep_regs_data -> + dom dep_regs_addr = list_to_set (AAInter.DepOn.regs dep_addr) -> + let reg_deps_addr := map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs_addr in + let mem_deps_addr := + foldr (λ (idx : N) (acc : gset Eid), + from_option (λ md : nat, {[{| EID.tid := tid; EID.iid := ts.(ts_iis).(iis_iid); EID.num := md |}]} ∪ acc) acc + (ts.(ts_iis).(iis_mem_reads) !! idx)) ∅ (AAInter.DepOn.mem_reads dep_addr) in + dom dep_regs_data = list_to_set (AAInter.DepOn.regs dep_data) -> + let reg_deps_data := map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs_data in + let mem_deps_data := + foldr (λ (idx : N) (acc : gset Eid), + from_option (λ md : nat, {[{| EID.tid := tid; EID.iid := ts.(ts_iis).(iis_iid); EID.num := md |}]} ∪ acc) acc + (ts.(ts_iis).(iis_mem_reads) !! idx)) ∅ (AAInter.DepOn.mem_reads dep_data) in + let R_graph_facts := (λ eid, + eid -{E}> (Event.W kind_s kind_v addr val) ∗ + ⌜(EID.tid eid) = tid ∧ (EID.iid eid) = ts.(ts_iis).(iis_iid) ⌝ ∗ + (* Po *) + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + (* Data *) + ([∗ set] eid_data_src ∈ reg_deps_data ∪ mem_deps_data, eid_data_src -{(Edge.Data)}> eid) ∗ + (* Addr *) + ([∗ set] eid_addr_src ∈ reg_deps_addr ∪ mem_deps_addr, eid_addr_src -{(Edge.Addr)}> eid) ∗ + (* There must be a write with same addr and val *) + from_option (λ eid_coi_pred, ⌜EID.tid eid_coi_pred = tid⌝ ∗ eid_coi_pred -{(Edge.Co)}> eid) emp ot_coi_pred )%I in + o_po_src -{LPo}> -∗ + ctrl_srcs -{Ctrl}> -∗ + last_local_write tid addr ot_coi_pred -∗ + ([∗ set] e_po_src ∈ po_srcs, e_po_src -{Po}>) -∗ + ([∗ map] dr ↦ dv ∈ dep_regs_addr ∪ dep_regs_data, dr ↦ᵣ dv) -∗ + (* node annotations *) + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) -∗ + (* Lob edge formers *) + (∀ eid, (eid -{N}> (Edge.W kind_s kind_v) -∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) -∗ + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) -∗ + ([∗ set] eid_addr_src ∈ reg_deps_addr ∪ mem_deps_addr, eid_addr_src -{(Edge.Addr)}> eid) -∗ + ([∗ set] eid_data_src ∈ reg_deps_data ∪ mem_deps_data, eid_data_src -{(Edge.Data)}> eid) -∗ + [∗ set] eid_pre ∈ dom lob_annot, eid_pre -{Edge.Lob}> eid) ∗ + (* FE *) + ((R_graph_facts eid) ∗ ([∗ map] _ ↦ annot ∈ lob_annot, annot) + ={⊤}[∅]▷=∗ + R eid ∗ □(prot addr val eid)) + ) -∗ + (* continuation *) + ( + ∀ ts' : ThreadState.t, + "Hinterp" ∷ thread_local_interp ts' -∗ + ⌜ts'.(ts_regs) !! RNPC = ts.(ts_regs) !! RNPC + ∧ ts'.(ts_reqs) = ctxt (inl None)⌝ -∗ + ((* exists a bool (indicating if the (atomic) write succeeded) *) + (* update lts' accordingly *) + (* Current event is a write *) + ∃ eid, (R_graph_facts eid) ∗ + (* R flowing in via lob *) + (eid ↦ₐ R eid) ∗ + ⌜EID.tid eid = tid⌝ ∗ + (Some eid) -{LPo}> ∗ + (* local writes at addr is updated *) + last_local_write tid addr (Some eid) ∗ + ctrl_srcs -{Ctrl}> ∗ + ([∗ map] dr ↦ dv ∈ dep_regs_addr ∪ dep_regs_data, dr ↦ᵣ dv)) -∗ + WP LThreadState.LTSNormal ts' @ tid {{ lts, to_lts_Phi Ψ lts }} + )-∗ + thread_local_interp ts -∗ + WP LThreadState.LTSNormal ts @ tid {{ λ lts', to_lts_Phi Ψ lts' }}. + Proof. + iIntros (?? Hintersec ???????) "Hpo_src Hctrl Hlw Hpo_srcs HDRs Hna Hef_fe Hcont Hinterp". + + iNamed "Hinterp". + iDestruct (reg_interp_agree_big with "Hinterp_reg HDRs") as %Hdr_sub. + iDestruct (ctrl_srcs_interp_agree with "Hinterp_ctrl Hctrl") as %Hctrl_sub. + assert (dep_regs_data ⊆ ts_regs ts) as Hsub'. + { + etrans. 2:exact Hdr_sub. + rewrite map_intersection_filter in Hintersec. + apply map_subseteq_spec. intros ?? Hlk. + destruct (decide (is_Some (dep_regs_addr !! i))). + destruct i0 as [x' Hlk']. + rewrite map_subseteq_spec in Hintersec. + specialize (Hintersec i x'). + feed specialize Hintersec. + apply map_filter_lookup_Some. + split. apply lookup_union_Some_l. done. + split; eexists;done. + apply lookup_union_Some_l. + rewrite Hlk in Hintersec. inversion Hintersec. subst x';done. + rewrite lookup_union_r //. rewrite -elem_of_dom in n. apply not_elem_of_dom. done. + } + + iApply wp_sswp. iApply (sswp_strong_mono with "[-Hinterp_reg Hinterp_ctrl Hinterp_rmw Hinterp_pc HDRs Hctrl Hcont]"). + + iDestruct ("Hef_fe" $! (progress_to_node (get_progress ts) tid)) as "[Hef Hfe]". + iApply (mem_write_non_xcl with "Hpo_src Hpo_srcs Hlw Hna [Hef] [Hfe]");eauto. + { + iIntros "E_R Hpo Hctrl Haddr Hdata". + iApply ("Hef" with "E_R Hpo [Hctrl] [Haddr] [Hdata]"). + iApply big_sepS_subseteq;eauto. + simpl. erewrite reg_dep_fold_eq;eauto. + { etrans. 2:exact Hdr_sub. apply map_union_subseteq_l. } + simpl. erewrite reg_dep_fold_eq;eauto. + } + { + rewrite /R_graph_facts /=. iIntros "H". + set (pg := (get_progress ts)). + erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs_addr);eauto. erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs_data);eauto. + rewrite /reg_deps_addr. + iSpecialize ("Hfe" with "[-]"). + iDestruct "H" as "[(?&?&?&?&?&?) H]". + iSplitR "H";last done. iFrame. + iSplit;first done. + iApply big_sepS_subseteq;eauto. + iExact "Hfe". + { etrans. 2:exact Hdr_sub. apply map_union_subseteq_l. } + } + iIntros (k) "(%&(?&?&?&?&?&?)&?&Hctrl'&?)"; subst k. simpl. + iApply ("Hcont" with "[Hinterp_reg Hinterp_ctrl Hinterp_pc Hinterp_rmw] [] [-]"). + iFrame. iExists _;done. + done. + + iFrame. iExists (progress_to_node (get_progress ts) tid). iFrame. + iSplit; last done. iSplit; first done. + simpl. erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs_addr);eauto. erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs_data);eauto. + iFrame. iApply big_sepS_subseteq;eauto. + { etrans. 2:exact Hdr_sub. apply map_union_subseteq_l. } + Qed. + + + Lemma mem_write_xcl_None `{!UserProt} {tid : Tid} {ts ctxt addr kind_s kind_v val dep_addr dep_data Ψ}: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemWrite 8 (writereq_of_store kind_s kind_v val addr dep_addr dep_data)) ctxt -> + kind_v = AV_atomic_rmw ∨ kind_v = AV_exclusive -> + None -{Rmw}> -∗ + (* continuation *) + ( + ∀ ts' : ThreadState.t, + "Hinterp" ∷ thread_local_interp ts' -∗ + ⌜ts'.(ts_regs) !! RNPC = ts.(ts_regs) !! RNPC + ∧ ts'.(ts_reqs) = ctxt (inl (Some false))⌝ -∗ + None -{Rmw}> -∗ + WP LThreadState.LTSNormal ts' @ tid {{ lts, to_lts_Phi Ψ lts }} + ) -∗ + thread_local_interp ts -∗ + WP LThreadState.LTSNormal ts @ tid {{ λ lts', to_lts_Phi Ψ lts' }}. + Proof. + iIntros (??) "Hrmw_src Hcont Hinterp". + iNamed "Hinterp". + + iDestruct (rmw_pred_interp_agree with "Hinterp_rmw Hrmw_src") as %?. + iApply wp_sswp. iApply (sswp_strong_mono with "[-Hinterp_rmw Hinterp_reg Hinterp_ctrl Hinterp_pc Hrmw_src Hcont]"). + iApply mem_write_xcl_None;eauto. + iIntros (k) "%";subst k. + iApply ("Hcont" with "[Hinterp_reg Hinterp_ctrl Hinterp_pc Hinterp_rmw] [] [-]"). + iFrame. iExists _;done. auto. done. + Qed. + + Lemma mem_write_xcl_Some `{!UserProt} {tid : Tid} {o_po_src ts ctxt addr kind_s kind_v val ot_coi_pred dep_addr dep_data rmw_src Ψ} R R_loc_in po_srcs ctrl_srcs lob_annot (dep_regs_addr: gmap _ _) dep_regs_data: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemWrite 8 (writereq_of_store kind_s kind_v val addr dep_addr dep_data)) ctxt -> + kind_v = AV_atomic_rmw ∨ kind_v = AV_exclusive -> + dep_regs_addr ∩ dep_regs_data ⊆ dep_regs_data -> + dom dep_regs_addr = list_to_set (AAInter.DepOn.regs dep_addr) -> + let reg_deps_addr := map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs_addr in + let mem_deps_addr := + foldr (λ (idx : N) (acc : gset Eid), + from_option (λ md : nat, {[{| EID.tid := tid; EID.iid := ts.(ts_iis).(iis_iid); EID.num := md |}]} ∪ acc) acc + (ts.(ts_iis).(iis_mem_reads) !! idx)) ∅ (AAInter.DepOn.mem_reads dep_addr) in + dom dep_regs_data = list_to_set (AAInter.DepOn.regs dep_data) -> + let reg_deps_data := map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs_data in + let mem_deps_data := + foldr (λ (idx : N) (acc : gset Eid), + from_option (λ md : nat, {[{| EID.tid := tid; EID.iid := ts.(ts_iis).(iis_iid); EID.num := md |}]} ∪ acc) acc + (ts.(ts_iis).(iis_mem_reads) !! idx)) ∅ (AAInter.DepOn.mem_reads dep_data) in + let R_graph_facts := (λ eid, + eid -{E}> (Event.W kind_s kind_v addr val) ∗ + ⌜(EID.tid eid) = tid ∧ (EID.iid eid) = ts.(ts_iis).(iis_iid)⌝ ∗ + (* Po *) + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + (* Data *) + ([∗ set] eid_addr_src ∈ reg_deps_addr ∪ mem_deps_addr, eid_addr_src -{(Edge.Addr)}> eid) ∗ + (* Addr *) + ([∗ set] eid_data_src ∈ reg_deps_data ∪ mem_deps_data, eid_data_src -{(Edge.Data)}> eid) ∗ + (* There must be a write with same addr and val *) + (from_option (λ eid_coi_pred, ⌜EID.tid eid_coi_pred = tid⌝ ∗ eid_coi_pred -{(Edge.Co)}> eid) emp ot_coi_pred) ∗ + (* Rmw *) + rmw_src -{(Edge.Rmw)}> eid)%I in + o_po_src -{LPo}> -∗ + ([∗ set] e_po_src ∈ po_srcs, e_po_src -{Po}>) -∗ + ctrl_srcs -{Ctrl}> -∗ + last_local_write tid addr ot_coi_pred -∗ + Some rmw_src -{Rmw}> -∗ + ([∗ map] dr ↦ dv ∈ dep_regs_addr ∪ dep_regs_data, dr ↦ᵣ dv) -∗ + (* node annotations *) + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) -∗ + (* Lob edge formers *) + (∀ eid, + (eid -{N}> (Edge.W kind_s kind_v) -∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) -∗ + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) -∗ + ([∗ set] eid_addr_src ∈ reg_deps_addr ∪ mem_deps_addr, eid_addr_src -{(Edge.Addr)}> eid) -∗ + ([∗ set] eid_data_src ∈ reg_deps_data ∪ mem_deps_data, eid_data_src -{(Edge.Data)}> eid) -∗ + rmw_src -{(Edge.Rmw)}> eid -∗ + ([∗ set] eid_pre ∈ dom lob_annot, eid_pre -{Edge.Lob}> eid)) ∗ + (* local resources that might flow into FE *) + R_loc_in ∗ + (* FE *) + (R_loc_in ∗ R_graph_facts eid ∗ Tok{ eid } ∗ ([∗ map] _ ↦ annot ∈ lob_annot, annot) + ={⊤}[∅]▷=∗ + R ∗ □(prot addr val eid))) -∗ + (* continuationh *) + ( + ∀ ts' : ThreadState.t, + "Hinterp" ∷ thread_local_interp ts' -∗ + ⌜ts'.(ts_regs) !! RNPC = ts.(ts_regs) !! RNPC⌝ -∗ + (* exists a bool (indicating if the (atomic) write succeeded) *) + (∃ b_succ, + ⌜ts'.(ts_reqs) = ctxt (inl (Some b_succ))⌝ ∗ + ctrl_srcs -{Ctrl}> ∗ + Some rmw_src -{Rmw}> ∗ + (* update lts' accordingly *) + if b_succ then + (* success *) + ∃ eid, + R_graph_facts eid ∗ + (* R flowing in via lob *) + (eid ↦ₐ R) ∗ + (Some eid) -{LPo}> ∗ + (* local writes at addr is updated *) + last_local_write tid addr (Some eid) + else + (* failure, things stay unchanged *) + o_po_src -{LPo}> ∗ + last_local_write tid addr ot_coi_pred ∗ + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) ∗ + R_loc_in) -∗ + WP LThreadState.LTSNormal ts' @ tid {{ lts, to_lts_Phi Ψ lts }} + ) -∗ + thread_local_interp ts -∗ + WP LThreadState.LTSNormal ts @ tid {{ λ lts', to_lts_Phi Ψ lts' }}. + Proof. + iIntros (?? Hintersec ???????) "Hpo_src Hpo_srcs Hctrl Hlw Hrmw_src HDRs Hna Hef_fe Hcont Hinterp". + iNamed "Hinterp". + iDestruct (reg_interp_agree_big with "Hinterp_reg HDRs") as %Hdr_sub. + iDestruct (ctrl_srcs_interp_agree with "Hinterp_ctrl Hctrl") as %Hctrl_sub. + iDestruct (rmw_pred_interp_agree with "Hinterp_rmw Hrmw_src") as %Hrmw. + + assert (dep_regs_data ⊆ ts_regs ts) as Hsub'. + { + etrans. 2:exact Hdr_sub. + rewrite map_intersection_filter in Hintersec. + apply map_subseteq_spec. intros ?? Hlk. + destruct (decide (is_Some (dep_regs_addr !! i))). + destruct i0 as [x' Hlk']. + rewrite map_subseteq_spec in Hintersec. + specialize (Hintersec i x'). + feed specialize Hintersec. + apply map_filter_lookup_Some. + split. apply lookup_union_Some_l. done. + split; eexists;done. + apply lookup_union_Some_l. + rewrite Hlk in Hintersec. inversion Hintersec. subst x';done. + rewrite lookup_union_r //. rewrite -elem_of_dom in n. apply not_elem_of_dom. done. + } + + iApply wp_sswp. iApply (sswp_strong_mono with "[-Hinterp_reg Hinterp_ctrl Hinterp_rmw Hinterp_pc HDRs Hctrl Hrmw_src Hcont]"). + + iDestruct ("Hef_fe" $! (progress_to_node (get_progress ts) tid)) as "[Hef [R_in Hfe]]". + + iApply (mem_write_xcl_Some with "Hpo_src Hpo_srcs Hlw Hna [Hef] R_in [Hfe]"). eauto. eauto. auto. + { + iIntros "E_R Hpo Hctrl Haddr Hdata Hrmw". + iApply ("Hef" with "E_R Hpo [Hctrl] [Haddr] [Hdata] Hrmw"). + iApply big_sepS_subseteq;eauto. + simpl. erewrite reg_dep_fold_eq;eauto. + { etrans. 2:exact Hdr_sub. apply map_union_subseteq_l. } + simpl. erewrite reg_dep_fold_eq;eauto. + } + { + rewrite /R_graph_facts /=. iIntros "[R_in H]". + set (pg := (get_progress ts)). + erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs_addr);eauto. erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs_data);eauto. + rewrite /reg_deps_addr. + iSpecialize ("Hfe" with "[-]"). + iDestruct "H" as "[(?&?&?&?&?&?) H]". iFrame "R_in". + iSplitR "H";last done. iFrame. + iSplit;first done. + iApply big_sepS_subseteq;eauto. + iExact "Hfe". + { etrans. 2:exact Hdr_sub. apply map_union_subseteq_l. } + } + iIntros (k) "[% [% H]]";subst k. + simpl. iApply ("Hcont" with "[Hinterp_reg Hinterp_ctrl Hinterp_pc Hinterp_rmw] [] [-]"). + iFrame. iExists _;done. auto. + + iExists b_succ. iSplitR;first done. iFrame. + simpl. erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs_addr);eauto. erewrite (reg_dep_fold_eq _ (ts_regs ts) dep_regs_data);eauto. + destruct b_succ. + { + iExists (progress_to_node (get_progress ts) tid). iDestruct "H" as "((?&?&?&?&?&?&?)&(?&?&?))". + iFrame. + iSplit;first done. + iApply big_sepS_subseteq;eauto. + } + { iFrame. } + { etrans. 2:exact Hdr_sub. apply map_union_subseteq_l. } + Qed. + + Lemma mem_write_xcl_Some_inv `{!UserProt} {tid : Tid} {o_po_src ts ctxt addr kind_s kind_v val ot_coi_pred dep_addr dep_data rmw_src Ψ} R_loc_in R po_srcs ctrl_srcs lob_annot (dep_regs_addr: gmap _ _) dep_regs_data: + ThreadState.ts_reqs ts = AAInter.Next (AAInter.MemWrite 8 (writereq_of_store kind_s kind_v val addr dep_addr dep_data)) ctxt -> + kind_v = AV_atomic_rmw ∨ kind_v = AV_exclusive -> + dep_regs_addr ∩ dep_regs_data ⊆ dep_regs_data -> + dom dep_regs_addr = list_to_set (AAInter.DepOn.regs dep_addr) -> + let reg_deps_addr := map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs_addr in + let mem_deps_addr := + foldr (λ (idx : N) (acc : gset Eid), + from_option (λ md : nat, {[{| EID.tid := tid; EID.iid := ts.(ts_iis).(iis_iid); EID.num := md |}]} ∪ acc) acc + (ts.(ts_iis).(iis_mem_reads) !! idx)) ∅ (AAInter.DepOn.mem_reads dep_addr) in + dom dep_regs_data = list_to_set (AAInter.DepOn.regs dep_data) -> + let reg_deps_data := map_fold (λ _ dv acc, reg_dep dv ∪ acc) ∅ dep_regs_data in + let mem_deps_data := + foldr (λ (idx : N) (acc : gset Eid), + from_option (λ md : nat, {[{| EID.tid := tid; EID.iid := ts.(ts_iis).(iis_iid); EID.num := md |}]} ∪ acc) acc + (ts.(ts_iis).(iis_mem_reads) !! idx)) ∅ (AAInter.DepOn.mem_reads dep_data) in + let R_graph_facts := (λ eid, + eid -{E}> (Event.W kind_s kind_v addr val) ∗ + ⌜(EID.tid eid) = tid ∧ (EID.iid eid) = ts.(ts_iis).(iis_iid)⌝ ∗ + (* Po *) + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) ∗ + (* Ctrl *) + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) ∗ + (* Data *) + ([∗ set] eid_addr_src ∈ reg_deps_addr ∪ mem_deps_addr, eid_addr_src -{(Edge.Addr)}> eid) ∗ + (* Addr *) + ([∗ set] eid_data_src ∈ reg_deps_data ∪ mem_deps_data, eid_data_src -{(Edge.Data)}> eid) ∗ + (* There must be a write with same addr and val *) + (from_option (λ eid_coi_pred, ⌜EID.tid eid_coi_pred = tid⌝ ∗ eid_coi_pred -{(Edge.Co)}> eid) emp ot_coi_pred) ∗ + (* Rmw *) + rmw_src -{(Edge.Rmw)}> eid)%I in + o_po_src -{LPo}> -∗ + ([∗ set] e_po_src ∈ po_srcs, e_po_src -{Po}>) -∗ + ctrl_srcs -{Ctrl}> -∗ + last_local_write tid addr ot_coi_pred -∗ + Some rmw_src -{Rmw}> -∗ + ([∗ map] dr ↦ dv ∈ dep_regs_addr ∪ dep_regs_data, dr ↦ᵣ dv) -∗ + (* node annotations *) + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) -∗ + (* Lob edge formers *) + (∀ eid, + (eid -{N}> (Edge.W kind_s kind_v) -∗ + ([∗ set] eid_po_src ∈ po_srcs, eid_po_src -{(Edge.Po)}> eid) -∗ + ([∗ set] eid_ctrl_src ∈ ctrl_srcs, eid_ctrl_src -{(Edge.Ctrl)}> eid) -∗ + ([∗ set] eid_addr_src ∈ reg_deps_addr ∪ mem_deps_addr, eid_addr_src -{(Edge.Addr)}> eid) -∗ + ([∗ set] eid_data_src ∈ reg_deps_data ∪ mem_deps_data, eid_data_src -{(Edge.Data)}> eid) -∗ + rmw_src -{(Edge.Rmw)}> eid -∗ + ([∗ set] eid_pre ∈ dom lob_annot, eid_pre -{Edge.Lob}> eid)) ∗ + (* local resources that might flow into FE *) + R_loc_in ∗ + (* FE, with excl invariant *) + (∃ eid_w R_in P, + (* excl invariant flows in *) + (R_loc_in ∗ R_graph_facts eid ∗ ([∗ map] _ ↦ annot ∈ lob_annot, annot) -∗ + R_in ∗ eid_w -{Edge.Rf}> rmw_src ∗ ⌜EID.tid eid_w ≠ EID.tid rmw_src⌝ ∗ excl_inv eid_w P) ∗ + (* FE *) + (R_in ∗ ▷ P eid_w ={⊤∖ ↑(excl_inv_name eid_w)}[∅]▷=∗ R ∗ □(prot addr val eid)))) -∗ + (* continuation *) + ( + ∀ ts' : ThreadState.t, + "Hinterp" ∷ thread_local_interp ts' -∗ + ⌜ts'.(ts_regs) !! RNPC = ts.(ts_regs) !! RNPC⌝ -∗ + (* exists a bool (indicating if the (atomic) write succeeded) *) + (∃ b_succ, + ⌜ts'.(ts_reqs) = ctxt (inl (Some b_succ))⌝ ∗ + ctrl_srcs -{Ctrl}> ∗ + Some rmw_src -{Rmw}> ∗ + if b_succ then + (* success *) + ∃ eid, + R_graph_facts eid ∗ + (* R flowing in via lob *) + (eid ↦ₐ R) ∗ + (Some eid) -{LPo}> ∗ + (* local writes at addr is updated *) + last_local_write tid addr (Some eid) + else + (* failure, things stay unchanged *) + o_po_src -{LPo}> ∗ + last_local_write tid addr ot_coi_pred ∗ + ([∗ map] node ↦ annot ∈ lob_annot, node ↦ₐ annot) ∗ + R_loc_in + ) -∗ + WP LThreadState.LTSNormal ts' @ tid {{ lts, to_lts_Phi Ψ lts }} + ) -∗ + thread_local_interp ts -∗ + WP LThreadState.LTSNormal ts @ tid {{ λ lts', to_lts_Phi Ψ lts' }}. + Proof. + iIntros (?? Hintersec ???????) "Hpo_src Hpo_srcs Hctrl Hlw Hrmw_src HDRs Hna Hef_fe". + iApply (mem_write_xcl_Some with "Hpo_src Hpo_srcs Hctrl Hlw Hrmw_src HDRs Hna [Hef_fe]");auto. + iIntros (?). iDestruct ("Hef_fe" $! eid) as "[$ [$ (%&%&%&Himpl&Hfe)]]". + iIntros "(R_loc_in & #R_gr &Htok&Hna)". + iDestruct ("Himpl" with "[$R_loc_in $R_gr $Hna]") as "(R_in & Ed_rf & Hext & Hinv)". + iDestruct (excl_inv_open_succ with "[$Htok $Ed_rf $Hinv $Hext]") as ">P". done. + { iDestruct "R_gr" as "(_&_&_&_&_&_&_&$)". } + rewrite later_sep. iDestruct "P" as "[P Hclo]". + iDestruct ("Hfe" with "[$R_in $P]") as ">R". + iModIntro. iNext. iMod "R". iMod "Hclo". by iFrame. + Qed. + +End rules. diff --git a/theories/middle/specialised_rules.v b/theories/middle/specialised_rules.v new file mode 100644 index 0000000..7386144 --- /dev/null +++ b/theories/middle/specialised_rules.v @@ -0,0 +1,634 @@ +(* This file contains some highly specialised mid-level proof rules (mostly for loads and stores) *) +From stdpp.unstable Require Import bitvector bitvector_tactics. + +From iris.proofmode Require Import tactics. + +Require Import ISASem.SailArmInstTypes. + +From self Require Import stdpp_extra. +From self.middle Require Export rules. + +Import uPred. + +Section rules. + Context `{AAIrisG} `{!AAThreadG} `{ThreadGN} `{!UserProt}. + Import ThreadState. + + Ltac load_ins := + rewrite sswpi_eq /sswpi_def; + iIntros (?); iNamed 1; rewrite wpi_eq /wpi_def; + iIntros (? [? ?]); repeat iNamed 1; + iApply wp_sswp; iApply (sswp_strong_mono with "[Hinst]"); + first (iApply (reload with "[Hinst]");eauto); iIntros (? ->); simpl. + + (** specialised rules *) + Lemma iload_excl `{!UserProt} {tid inst_addr kind_s ctrl rmw rv ot} R po_priors lob_priors addr reg: + inst_addr ↦ᵢ (ILoad kind_s AV_exclusive reg (AEval addr)) ∗ + reg ↦ᵣ rv ∗ + ot -{LPo}> ∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Po}>) ∗ + ctrl -{Ctrl}> ∗ + rmw -{Rmw}> ∗ + last_local_write tid addr None ∗ + ([∗ map] lob_pred ↦ P ∈ lob_priors, lob_pred ↦ₐ P) -∗ + (∀ eid, + (eid -{N}> (Edge.R kind_s AV_exclusive) -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{(Edge.Po)}> eid) -∗ + [∗ map] lob_prior ↦ _ ∈ lob_priors, lob_prior -{Edge.Lob}> eid) ∗ + ∀ eid' v, eid -{E}> (Event.R kind_s AV_exclusive addr v) -∗ + ⌜(EID.tid eid) = tid⌝ -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Edge.Po}> eid) -∗ + (∃ kind_s_w kind_v_w, eid' -{E}> (Event.W kind_s_w kind_v_w addr v)) -∗ + eid' -{Edge.Rf}> eid -∗ + ([∗ map] _ ↦ P ∈ lob_priors, P) -∗ + □prot addr v eid' ==∗ + R eid' v + ) -∗ + SSWPi (LTSI.Normal,inst_addr) @ tid + {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv)⌝ ∗ + ∃ eid eid' v, eid -{E}> (Event.R kind_s AV_exclusive addr v) ∗ + ⌜(EID.tid eid) = tid⌝ ∗ + reg ↦ᵣ mk_regval v {[eid]} ∗ + eid ↦ₐ (R eid' v) ∗ + (∃ kind_s_w kind_v_w, eid' -{E}> (Event.W kind_s_w kind_v_w addr v)) ∗ + eid' -{Edge.Rf}> eid ∗ ⌜EID.tid eid' ≠ EID.tid eid⌝ ∗ + Some eid -{LPo}> ∗ + ctrl -{Ctrl}> ∗ + Some eid -{Rmw}> ∗ + last_local_write tid addr None + }}. + Proof. + iIntros "(Hinst & Hr & Hlpo & Hpo & Hctrl & Hrmw & Hlast_write &HP) Hfe". load_ins. + iApply (mem_read_external _ (dom po_priors) lob_priors with "Hlpo Hctrl Hlast_write Hrmw [Hpo] [] HP [Hfe] [-Hinterp]") => //=. + + set_solver. + + iIntros (?). iDestruct ("Hfe" $! eid) as "[Hf He]". iSplitL "Hf". + - iIntros "HN Hpo _ _". rewrite big_sepM_dom. iApply ("Hf" with "HN Hpo"). + - iIntros (? eid_w) "((HE & [%Htid _] & Hpo & _ & _ & Hwrite & Hrf & _) & HP & #Hprot)". + iApply (fupd_mask_intro _ ∅). { set_solver. } + iIntros "M !>". + iMod ("He" $! eid_w val with "HE [//] Hpo Hwrite Hrf HP Hprot") as "R". + iMod "M" as "_". iModIntro. iExact "R". + + simpl. + iIntros (?) "Hinterp %Hpc_eq (% & % & % & [% %] & (Hread & [% %] & _ & _ & _ & Hwrite & Hrf & %Hext) & Hannot & Hpo & Hctrl & Hlast_local_write & Hrmw & ?)". + + iNamed "Hinterp". + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_write;eauto. + iIntros (? ->);simpl. + iNamed "Hinterp". iDestruct (reg_interp_update with "Hinterp_reg Hr") as ">[Hinterp_reg Hr]". + iDestruct (reg_mapsto_ne with "Hr Hinterp_pc") as %Hneq. + + iApply (inc_pc with "[-Hinterp_reg Hinterp_pc Hinterp_ctrl Hinterp_rmw]");auto. + simpl. rewrite lookup_insert_ne //. rewrite Hpc_eq //. + iIntros (? -> ? ?) "Hinterp". iApply ("Hcont" with "[-Hinterp]");auto. + iSplit;first done. + iExists eid, eid_w, val. + iFrame. iPureIntro. split;lia. iFrame. simpl. rewrite union_empty_l_L. rewrite H7 /=. + rewrite union_empty_r_L. destruct eid;simpl in *;subst. iFrame. + iExists _;done. + Qed. + + Lemma istore_rel_excl `{!UserProt} {tid inst_addr ctrl ot eid_w eid_xr res_ov} R R' Q po_priors + addr data reg_res: + inst_addr ↦ᵢ (IStore AS_rel_or_acq AV_exclusive reg_res (AEval data) (AEval addr)) ∗ + reg_res ↦ᵣ res_ov ∗ + ot -{LPo}> ∗ + ([∗ map] po_prior ↦ _ ∈ po_priors, po_prior -{Po}>) ∗ + ctrl -{Ctrl}> ∗ + last_local_write tid addr None ∗ + Some eid_xr -{Rmw}> ∗ + ((([∗ map] _ ↦ P ∈ po_priors, P) -∗ excl_inv eid_w R) ∗ + eid_w -{Edge.Rf}> eid_xr ∗ ⌜EID.tid eid_w ≠ EID.tid eid_xr⌝) ∗ + (∀ eid, R eid ==∗ R' eid) ∗ + ([∗ map] po_pred ↦ P ∈ po_priors, po_pred ↦ₐ P) -∗ + ( + ∀ eid, + (eid -{E}> (Event.W AS_rel_or_acq AV_exclusive addr data) -∗ + ⌜(EID.tid eid) = tid⌝ -∗ + (* ([∗ map] po_prior ↦ _ ∈ po_priors, po_prior -{Edge.Po}> eid) -∗ *) + ([∗ map] _ ↦ P ∈ po_priors, P) ={⊤∖ ↑(excl_inv_name eid_w)}[∅]▷=∗ + Q ∗ □ (prot addr data eid)) + ) -∗ + SSWPi (LTSI.Normal,inst_addr) @ tid + {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv) ⌝ ∗ + ∃ b_succ, + reg_res ↦ᵣ mk_regval (bool_to_bv 64 b_succ) ∅ ∗ + ctrl -{Ctrl}> ∗ + (Some eid_xr) -{Rmw}> ∗ + (* update lts' accordingly *) + if b_succ then + (* success *) + ∃ eid, eid -{E}> (Event.W AS_rel_or_acq AV_exclusive addr data) ∗ + ⌜(EID.tid eid) = tid⌝ ∗ + ([∗ set] po_prior ∈ dom po_priors, po_prior -{Edge.Po}> eid) ∗ + Some eid -{LPo}> ∗ + last_local_write tid addr (Some eid) ∗ + eid ↦ₐ (R' eid_w ∗ Q) + else + (* failure, things stay unchanged *) + ot -{LPo}> ∗ + last_local_write tid addr None ∗ + ([∗ map] node ↦ annot ∈ po_priors, node ↦ₐ annot) + }}. + Proof. + iIntros "(Hinst & Hreg_res & Hlpo & Hpos & Hctrl & Hlast_write & Hrmw & (HPexcl & #Hw_rfe_xr) + & Himpl & Hannot) Hfe". load_ins. + + iApply (mem_write_xcl_Some_inv emp _ (dom po_priors) _ (po_priors) ∅ ∅ with + "Hlpo [Hpos] Hctrl Hlast_write Hrmw [] Hannot [Hfe HPexcl Himpl] [-Hinterp]");auto. + + rewrite big_sepM_dom //. + + rewrite map_union_empty. rewrite big_sepM_empty //. + + simpl. iIntros (?). iSplitR. + - iIntros "#HE Hpo _ _ _ Hrmw". + iApply (big_sepS_impl with "Hpo"). + iModIntro. iIntros (? Hin) "Hpo". + iApply (po_rel_is_lob with "Hpo");auto. + - iSplitR; first done. + iExists eid_w, + ((eid -{E}> Event.W AS_rel_or_acq AV_exclusive addr data ∗ + ⌜EID.tid eid = tid ∧ EID.iid eid = (iis_iid (ts_iis ts) + 1)%nat⌝ ∗ + ([∗ set] eid_po_src ∈ dom po_priors, eid_po_src -{Edge.Po}> eid) ∗ + ([∗ set] eid_ctrl_src ∈ ctrl, eid_ctrl_src -{Edge.Ctrl}> eid) ∗ + ([∗ set] eid_addr_src ∈ (map_fold (λ (_ : RegName) (dv : RegVal) (acc : gset Eid), reg_dep dv ∪ acc) ∅ ∅ ∪ ∅), eid_addr_src -{Edge.Addr}> eid) ∗ + ([∗ set] eid_data_src ∈ (map_fold (λ (_ : RegName) (dv : RegVal) (acc : gset Eid), reg_dep dv ∪ acc) ∅ ∅ ∪ ∅), eid_data_src -{Edge.Data}> eid) ∗ + emp ∗ eid_xr -{Edge.Rmw}> eid) ∗ [∗ map] annot ∈ po_priors, annot)%I, R. + iSplitL "HPexcl". + iIntros "[_ (#HG & Hannot)]". + iDestruct ("HPexcl" with "Hannot") as "#Hexcl_inv". + iFrame. iFrame "#". + iIntros "([(#HE & [%Htid _] & (#Hpos & _)) Hannot] & R)". + iDestruct ("Hfe" with "HE [//] Hannot") as ">M". + iModIntro. iNext. iMod "M" as "[Q $]". + iDestruct ("Himpl" with "R") as ">R". iModIntro. + iCombine "R Q" as "R". iExact "R". + + iIntros (?) "Hinterp %Hpc_eq (% & %Heq & HPost)";simpl. simpl in Hpc_eq. + iNamed "Hinterp". + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_write;eauto. + iIntros (? ->);simpl. + iNamed "Hinterp". iDestruct (reg_interp_update with "Hinterp_reg Hreg_res") as ">[Hinterp_reg Hreg_res]". + iDestruct (reg_mapsto_ne with "Hreg_res Hinterp_pc") as %Hneq. + simpl in Heq. + + iApply (inc_pc with "[-Hinterp_reg Hinterp_pc Hinterp_ctrl Hinterp_rmw]");auto. + simpl. rewrite lookup_insert_ne //. rewrite Hpc_eq //. + iIntros (? -> ? ?) "Hinterp". iApply ("Hcont" with "[-Hinterp]");auto. + iSplit;first done. + iDestruct "HPost" as "($&$&HPost)". + iExists b_succ. + iSplitL "Hreg_res". iExact "Hreg_res". + destruct b_succ. + - iDestruct "HPost" as "[% ((?&[[? ?] [? ?]])&HP&?&?)]". + iExists eid. iFrame. + - iDestruct "HPost" as "($&$&$&_)". + - simpl. rewrite union_empty_l_L. iFrame. iExists _;done. + Qed. + + Lemma istore_pln_single_data `{!UserProt} {tid inst_addr ctrl po_prior} reg_data reg_res addr val addr_pred P: + inst_addr ↦ᵢ (IStore AS_normal AV_plain reg_res (AEreg reg_data) (AEval addr)) ∗ + Some po_prior -{LPo}> ∗ + ctrl -{Ctrl}> ∗ + last_local_write tid addr None ∗ + reg_data ↦ᵣ (mk_regval val {[addr_pred]}) ∗ + addr_pred ↦ₐ P ∗ + ( + ∀ eid, eid -{E}> (Event.W AS_normal AV_plain addr val) -∗ + ⌜EID.tid eid = tid⌝ -∗ + po_prior -{Edge.Po}> eid -∗ + addr_pred -{Edge.Data}> eid -∗ + P -∗ + □ (prot addr val eid) + ) -∗ + (* Need to know about the data write here, or write the implication *) + SSWPi (LTSI.Normal,inst_addr) @ tid + {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv) ⌝ ∗ + reg_data ↦ᵣ (mk_regval val {[addr_pred]}) ∗ + ∃ eid, eid -{E}> (Event.W AS_normal AV_plain addr val) ∗ + ⌜EID.tid eid = tid ⌝ ∗ + Some eid -{LPo}> ∗ + last_local_write tid addr (Some eid) ∗ + ctrl -{Ctrl}> + }}. + Proof. + iIntros "(Hinst & Hpo & Hctrl & Hlast_write & Hreg & Hna & Hprot)". load_ins. + + iDestruct (lpo_to_po with "Hpo") as "[Hlpo #Hpo]". + + iApply wp_sswp. + iNamed "Hinterp". iDestruct (reg_interp_agree with "Hinterp_reg Hreg") as %Hreg. + iApply (sswp_strong_mono with "[]"). + iApply (reg_read);eauto. simpl. + iIntros (? ->);simpl. + + iApply (mem_write_non_xcl _ {[po_prior]} {[addr_pred := P]} {[reg_data := _]} ∅ + with "Hlpo Hctrl Hlast_write [] [Hreg] [Hna] [Hprot] [-Hinterp_reg Hinterp_ctrl Hinterp_rmw Hinterp_pc]"). + + simpl. reflexivity. + + done. + + rewrite map_subseteq_spec. + intros ?? Hlk. rewrite lookup_intersection in Hlk. + rewrite lookup_empty in Hlk. inversion Hlk. + + simpl. set_solver +. + + rewrite dom_singleton_L. simpl. set_solver +. + + by iApply big_sepS_singleton. + + rewrite map_empty_union. + by iApply big_sepM_singleton. + + by iApply big_sepM_singleton. + + iIntros (?). + iSplitR. + - iIntros "_ _ _ _ ?". + simpl. rewrite map_fold_singleton /=. rewrite 2!union_empty_r_L. + rewrite dom_singleton_L. rewrite 2!big_sepS_singleton. + by iApply data_is_lob. + - iIntros "((Hev&[Htid _]&Hpos&_&Hdata&_&_)&Hna)". simpl. + rewrite map_fold_singleton /=. rewrite 2!union_empty_r_L. + rewrite 2!big_sepS_singleton. rewrite big_sepM_singleton. + iDestruct ("Hprot" $! eid with "Hev Htid Hpos Hdata Hna") as "Hprot". + iApply (fupd_mask_intro _ ∅). {set_solver. } + iIntros "M !>". iMod "M". iModIntro. iSplit. { iExact "M". } + iFrame. + + iIntros (?) "Hinterp [%Hpc_eq %] [% ((?&[Htid _]&?)&_&_&?&?&?&?)]";simpl. + iApply (inc_pc with "[-Hinterp]");eauto. rewrite Hpc_eq //. + iIntros (? -> ? ?) "Hinterp". iApply ("Hcont" with "[-Hinterp]");auto. + rewrite map_empty_union. rewrite big_sepM_singleton. iFrame. + iSplit;first done. + iExists _;iFrame. + + iFrame. iExists _;iFrame. + Qed. + + Definition iload_pln `{!UserProt} {tid inst_addr kind_s ctrl rmw rv ot} R po_priors lob_priors addr reg: + inst_addr ↦ᵢ (ILoad kind_s AV_plain reg (AEval addr)) ∗ + reg ↦ᵣ rv ∗ + ot -{LPo}> ∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Po}>) ∗ + ctrl -{Ctrl}> ∗ + rmw -{Rmw}> ∗ + last_local_write tid addr None ∗ + ([∗ map] lob_pred ↦ P ∈ lob_priors, lob_pred ↦ₐ P) -∗ + (∀ eid, + (eid -{N}> (Edge.R kind_s AV_plain) -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{(Edge.Po)}> eid) -∗ + [∗ map] lob_prior ↦ _ ∈ lob_priors, lob_prior -{Edge.Lob}> eid) ∗ + ∀ eid' v, eid -{E}> (Event.R kind_s AV_plain addr v) -∗ + ⌜(EID.tid eid) = tid⌝ -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Edge.Po}> eid) -∗ + (∃ kind_s_w kind_v_w, eid' -{E}> (Event.W kind_s_w kind_v_w addr v)) -∗ + eid' -{Edge.Rf}> eid -∗ + ([∗ map] _ ↦ P ∈ lob_priors, P) -∗ + □prot addr v eid' ==∗ + R eid' v + ) -∗ + SSWPi (LTSI.Normal,inst_addr) @ tid + {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv)⌝ ∗ + ∃ eid eid' v, eid -{E}> (Event.R kind_s AV_plain addr v) ∗ + ⌜(EID.tid eid) = tid⌝ ∗ + reg ↦ᵣ mk_regval v {[eid]} ∗ + eid ↦ₐ (R eid' v) ∗ + (∃ kind_s_w kind_v_w, eid' -{E}> (Event.W kind_s_w kind_v_w addr v)) ∗ + eid' -{Edge.Rf}> eid ∗ + Some eid -{LPo}> ∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Edge.Po}> eid) ∗ + ctrl -{Ctrl}> ∗ + rmw -{Rmw}> ∗ + last_local_write tid addr None + }}. + Proof. + iIntros "(Hinst & Hr & Hlpo & Hpo & Hctrl & Hrmw & Hlast_write &HP) Hfe". load_ins. + iApply (mem_read_external _ (dom po_priors) lob_priors with "Hlpo Hctrl Hlast_write Hrmw [Hpo] [] HP [Hfe] [-Hinterp]") => //=. + + set_solver. + + iIntros (?). iDestruct ("Hfe" $! eid) as "[Hf He]". iSplitL "Hf". + - iIntros "HN Hpo _ _". rewrite big_sepM_dom. iApply ("Hf" with "HN Hpo"). + - iIntros (? eid_w) "((HE & [%Htid _] & Hpo & _ & _ & Hwrite & Hrf & _) & HP & #Hprot)". + iApply (fupd_mask_intro _ ∅). { set_solver. } + iIntros "M !>". + iMod ("He" $! eid_w val with "HE [//] Hpo Hwrite Hrf HP Hprot") as "R". + iMod "M" as "_". iModIntro. iExact "R". + + simpl. + iIntros (?) "Hinterp %Hpc_eq (% & % & % & [% %] & (Hread & [% %] & Hpos & _ & _ & Hwrite & Hrf & Hext) & Hannot & Hpo & Hctrl & Hlast_local_write & Hrmw & _)". + + iNamed "Hinterp". + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_write;eauto. + iIntros (? ->);simpl. + iNamed "Hinterp". iDestruct (reg_interp_update with "Hinterp_reg Hr") as ">[Hinterp_reg Hr]". + iDestruct (reg_mapsto_ne with "Hr Hinterp_pc") as %Hneq. + + iApply (inc_pc with "[-Hinterp_reg Hinterp_pc Hinterp_ctrl Hinterp_rmw]");auto. + simpl. rewrite lookup_insert_ne //. rewrite Hpc_eq //. + iIntros (? -> ? ?) "Hinterp". iApply ("Hcont" with "[-Hinterp]");auto. + iSplit;first done. + iExists eid, eid_w, val. + iFrame. done. iFrame. simpl. rewrite union_empty_l_L. rewrite H7 /=. + rewrite union_empty_r_L. destruct eid;simpl in *;subst. iFrame. + iExists _;done. + Qed. + + Lemma iload_pln_fake_addr`{!UserProt} {tid inst_addr kind_s ctrl rmw val addr_pred ot} R addr reg rv reg_dep P: + inst_addr ↦ᵢ ILoad kind_s AV_plain reg (AEbinop AOplus (AEval addr) (AEbinop AOminus (AEreg reg_dep) (AEreg reg_dep)))∗ + reg_dep ↦ᵣ mk_regval val {[addr_pred]} ∗ + addr_pred ↦ₐ P ∗ + reg ↦ᵣ rv ∗ + ot -{LPo}> ∗ + ctrl -{Ctrl}> ∗ + rmw -{Rmw}> ∗ + last_local_write tid addr None -∗ + (∀ eid eid' v, eid -{E}> (Event.R kind_s AV_plain addr v) -∗ + ⌜(EID.tid eid) = tid⌝ -∗ + (∃ kind_s_w kind_v_w, eid' -{E}> (Event.W kind_s_w kind_v_w addr v)) -∗ + eid' -{Edge.Rf}> eid -∗ + addr_pred -{Edge.Addr}> eid -∗ + P -∗ + □prot addr v eid' ==∗ + R eid' v + ) -∗ + + SSWPi (LTSI.Normal, inst_addr) @ tid {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv) ⌝ ∗ + reg_dep ↦ᵣ mk_regval val {[addr_pred]} ∗ + ∃ eid eid' v, eid -{E}> (Event.R kind_s AV_plain addr v) ∗ + ⌜(EID.tid eid) = tid⌝ ∗ + reg ↦ᵣ mk_regval v {[eid]} ∗ + eid ↦ₐ (R eid' v) ∗ + (∃ kind_s_w kind_v_w, eid' -{E}> (Event.W kind_s_w kind_v_w addr v)) ∗ + eid' -{Edge.Rf}> eid ∗ + Some eid -{LPo}> ∗ + ctrl -{Ctrl}> ∗ + rmw -{Rmw}> + }}. + Proof. + iIntros "(Hinst & Hreg & HP & Hr & Hlpo & Hctrl & Hrmw & Hlast_write) Hfe". load_ins. + + iApply wp_sswp. iNamed "Hinterp". iDestruct (reg_interp_agree with "Hinterp_reg Hreg") as %Hreg. + iApply (sswp_strong_mono with "[]"). + iApply reg_read;eauto. + iIntros (? ->);simpl. + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_read;eauto. + iIntros (? ->);simpl. + + + iApply (mem_read_external _ ∅ {[addr_pred := P]} {[reg_dep := _]} with "Hlpo Hctrl Hlast_write Hrmw [] [Hreg] [HP] [Hfe] [-Hinterp_reg Hinterp_pc Hinterp_ctrl Hinterp_rmw]");auto. + + simpl. assert (addr + (val - val) = addr)%bv as -> by bv_solve. reflexivity. + + rewrite dom_singleton_L /=. set_solver +. + + rewrite big_sepM_singleton /=. iFrame. + + rewrite big_sepM_singleton /=. iFrame. + + iIntros (?). iSplitR "Hfe". + - iIntros "HN _ _ Haddr". simpl. + rewrite map_fold_singleton /=. rewrite 2!union_empty_r_L. + rewrite dom_singleton_L. rewrite 2!big_sepS_singleton. + by iApply addr_is_lob. + - iIntros (? eid_w) "((HE & [%Htid _] & Hpo & _ & Haddr & Hwrite & Hrf & _) & HP & #Hprot)". + iApply (fupd_mask_intro _ ∅). { set_solver. } + iIntros "M !>". + iMod ("Hfe" $! eid eid_w val0 with "HE [//] Hwrite Hrf [Haddr] [HP] [$Hprot]") as "R". + { simpl. rewrite map_fold_singleton /=. rewrite 2!union_empty_r_L. rewrite big_sepS_singleton //. } + { rewrite big_sepM_singleton //. } + iMod "M" as "_". iModIntro. iExact "R". + + simpl. iIntros (?) "Hinterp %Hpc_eq (% & % & % & [% %] & (Hread & [% %] & _ & _ & _ & Hwrite & Hrf & Hext) & Hannot & Hpo & Hctrl & Hlast_local_write & Hrmw & Hreg_dep)". + subst. + + iNamed "Hinterp". + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_write;eauto. + iIntros (? ->);simpl. + iNamed "Hinterp". iDestruct (reg_interp_update with "Hinterp_reg Hr") as ">[Hinterp_reg Hr]". + iDestruct (reg_mapsto_ne with "Hr Hinterp_pc") as %Hneq. + + iApply (inc_pc with "[-Hinterp_reg Hinterp_pc Hinterp_ctrl Hinterp_rmw]");auto. + simpl. rewrite lookup_insert_ne //. rewrite Hpc_eq //. + iIntros (? -> ? ?) "Hinterp". iApply ("Hcont" with "[-Hinterp]");auto. + iSplit;first done. rewrite big_sepM_singleton. iFrame. + iExists eid, eid_w, val0. + iFrame. done. iSplitL "Hinterp_reg". simpl. rewrite union_empty_l_L. rewrite H7 /=. + rewrite union_empty_r_L. destruct eid;simpl in *;subst. iFrame. + iFrame. iExists _;done. + + iFrame. iExists _;done. + Qed. + + Lemma istore_pln `{!UserProt} {tid inst_addr ctrl ot lastw} Q po_priors lob_priors addr data reg_res: + inst_addr ↦ᵢ (IStore AS_normal AV_plain reg_res (AEval data) (AEval addr)) ∗ + ot -{LPo}> ∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Po}>) ∗ + ctrl -{Ctrl}> ∗ + last_local_write tid addr lastw ∗ + ([∗ map] lob_pred ↦ P ∈ lob_priors, lob_pred ↦ₐ P) -∗ + ( + ∀ eid, + (eid -{N}> (Edge.W AS_normal AV_plain) -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{(Edge.Po)}> eid) -∗ + ([∗ set] ctrl_prior ∈ ctrl, ctrl_prior -{(Edge.Ctrl)}> eid) -∗ + [∗ map] lob_prior ↦ _ ∈ lob_priors, lob_prior -{Edge.Lob}> eid) ∗ + (eid -{E}> (Event.W AS_normal AV_plain addr data) -∗ + ⌜(EID.tid eid) = tid⌝ -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Edge.Po}> eid) -∗ + ([∗ map] _ ↦ P ∈ lob_priors, P) ==∗ + Q eid ∗ □ (prot addr data eid)) + ) -∗ + SSWPi (LTSI.Normal,inst_addr) @ tid + {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv) ⌝ ∗ + ∃ eid, eid -{E}> (Event.W AS_normal AV_plain addr data) ∗ + ⌜(EID.tid eid) = tid⌝ ∗ + Some eid -{LPo}> ∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Edge.Po}> eid) ∗ + last_local_write tid addr (Some eid) ∗ + ctrl -{Ctrl}> ∗ + eid ↦ₐ Q eid + }}. + Proof. + iIntros "(Hinst & Hlpo & Hpos & Hctrl & Hlast_write & Hannot) Hfe". load_ins. + + iApply (mem_write_non_xcl _ po_priors lob_priors with "Hlpo Hctrl Hlast_write [Hpos] [] [Hannot] [Hfe] [-Hinterp]");auto. + + assert (G: (∅ : gmap RegName RegVal) ∩ ∅ ⊆ ∅) => //. + + set_solver. + + set_solver. + + rewrite map_union_empty. rewrite big_sepM_empty //. + + simpl. iIntros (?). iDestruct ("Hfe" $! eid) as "[Hf He]". iSplitL "Hf". + - iIntros "HE Hpos Hctrl _ _". rewrite big_sepM_dom. iApply ("Hf" with "HE Hpos Hctrl"). + - iIntros "((HE & [%Htid _] & (Hpos & _)) & Hannot)". + iApply (fupd_mask_intro _ ∅). { set_solver. } + iIntros "M !>". iMod "M". + iDestruct ("He" with "HE [//] Hpos Hannot") as ">[HQ Hprot]". + iModIntro. iSplit. { iExact "HQ". } done. + + iIntros (?) "Hinterp [%Hpc_eq %] [% ((?&[? ?]&?&?&?)&HP&_&?&?&?&?)]";simpl. + iApply (inc_pc with "[-Hinterp]");eauto. rewrite Hpc_eq //. + iIntros (? -> ? ?) "Hinterp". iApply ("Hcont" with "[-Hinterp]");auto. + iFrame. iSplit;first done. + iExists _;iFrame "#∗". + Qed. + + Lemma istore_rel_raw `{!UserProt} {tid inst_addr reg_res ctrl ot o_lw} Q po_priors lob_priors addr data: + po_priors ⊆ dom lob_priors -> + inst_addr ↦ᵢ (IStore AS_rel_or_acq AV_plain reg_res (AEval data) (AEval addr)) ∗ + ot -{LPo}> ∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Po}>) ∗ + ctrl -{Ctrl}> ∗ + last_local_write tid addr o_lw ∗ + ([∗ map] lob_pred ↦ P ∈ lob_priors, lob_pred ↦ₐ P) ∗ + ( + ∀ eid, + (eid -{N}> Edge.W AS_rel_or_acq AV_plain -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Edge.Po}> eid) -∗ + ([∗ set] lob_pred ∈ dom lob_priors ∖ po_priors, lob_pred -{Edge.Lob}> eid)) ∗ + (eid -{E}> (Event.W AS_rel_or_acq AV_plain addr data) -∗ + ⌜(EID.tid eid) = tid⌝ -∗ + ([∗ set] po_prior ∈ po_priors, po_prior -{Edge.Po}> eid) -∗ + (* ([∗ set] lob_pred ∈ dom lob_priors, lob_pred -{Edge.Lob}> eid) -∗ *) + ([∗ map] _ ↦ P ∈ lob_priors, P) ={⊤}=∗ + Q ∗ □ (prot addr data eid)) + ) -∗ + SSWPi (LTSI.Normal, inst_addr) @ tid {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv) ⌝ ∗ + ∃ eid, eid -{E}> (Event.W AS_rel_or_acq AV_plain addr data) ∗ + ⌜(EID.tid eid) = tid⌝ ∗ + Some eid -{LPo}> ∗ + ctrl -{Ctrl}> ∗ + last_local_write tid addr (Some eid) ∗ + eid ↦ₐ Q + }}. + Proof. + iIntros (Hsub) "(Hinst & Hlpo & Hpo & Hctrl & Hlast_write & HP & Hprot)". load_ins. + + iApply (mem_write_non_xcl _ po_priors lob_priors with "Hlpo Hctrl Hlast_write [Hpo] [] HP [Hprot] [-Hinterp]") => //=. + + assert (G: (∅ : gmap RegName RegVal) ∩ ∅ ⊆ ∅) => //. + + set_solver. + + set_solver. + + rewrite map_union_empty. rewrite big_sepM_empty //. + + simpl. iIntros (?). iDestruct ("Hprot" $! eid) as "[Hef Hprot]". + iSplitL "Hef". + - iIntros "#HE #Hpo _ _ _". + iSpecialize ("Hef" with "HE Hpo"). + iDestruct (big_sepS_impl with "Hpo") as "#Hlob". + iSpecialize ("Hlob" with "[]"). + iModIntro. iIntros (? Hin) "Hpo'". + iApply (po_rel_is_lob with "Hpo' HE");auto. + iDestruct (big_sepS_union_2 with "Hef Hlob") as "Hlob'". + assert ((dom lob_priors ∖ po_priors ∪ po_priors) = dom lob_priors) as ->. + rewrite union_comm_L. rewrite -union_difference_L //. + done. + - iIntros "((Hev&[%Htid _]&Hpos&?&?&?&_)&HP)". + iDestruct ("Hprot" with "Hev [//] Hpos HP") as ">[HQ Hprot]". + iApply (fupd_mask_intro _ ∅). {set_solver. } + iIntros "M !>". iMod "M". + iModIntro. iSplit. { iExact "HQ". } + iFrame. + + iIntros (?) "Hinterp [%Hpc_eq %] [% ((?&[[? ?] ?])&HP&_&?&?&?&?)]";simpl. + iApply (inc_pc with "[-Hinterp]");eauto. rewrite Hpc_eq //. + iIntros (? -> ? ?) "Hinterp". iApply ("Hcont" with "[-Hinterp]");auto. + iFrame. iSplit;first done. iExists _;iFrame. + Qed. + + Lemma istore_rel `{!UserProt} {tid inst_addr reg_res ctrl ot o_lw} Q po_priors addr data: + inst_addr ↦ᵢ (IStore AS_rel_or_acq AV_plain reg_res (AEval data) (AEval addr)) ∗ + ot -{LPo}> ∗ + ([∗ map] po_prior ↦ _ ∈ po_priors, po_prior -{Po}>) ∗ + ctrl -{Ctrl}> ∗ + last_local_write tid addr o_lw ∗ + ([∗ map] po_pred ↦ P ∈ po_priors, po_pred ↦ₐ P) ∗ + ( + ∀ eid, eid -{E}> (Event.W AS_rel_or_acq AV_plain addr data) -∗ + ⌜(EID.tid eid) = tid⌝ -∗ + ([∗ map] po_prior ↦ _ ∈ po_priors, po_prior -{Edge.Po}> eid) -∗ + ([∗ map] _ ↦ P ∈ po_priors, P) ={⊤}=∗ + Q ∗ □ (prot addr data eid) + ) -∗ + SSWPi (LTSI.Normal, inst_addr) @ tid {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv) ⌝ ∗ + ∃ eid, eid -{E}> (Event.W AS_rel_or_acq AV_plain addr data) ∗ + ⌜(EID.tid eid) = tid⌝ ∗ + Some eid -{LPo}> ∗ + ctrl -{Ctrl}> ∗ + last_local_write tid addr (Some eid) ∗ + eid ↦ₐ Q + }}. + Proof. + iIntros "(Hinst & Hlpo & Hpo & Hctrl & Hlast_write & HP & Hprot)". + + iApply (istore_rel_raw Q (dom po_priors) po_priors with "[$Hinst $Hlpo Hpo $Hctrl $Hlast_write $HP Hprot]");auto. + rewrite big_sepM_dom. iFrame "Hpo". + iIntros (?). + iSplitR. { rewrite difference_diag_L. iIntros "? ?". done. } + iIntros "HE Htid Hpo HP". + iApply ("Hprot" with "HE Htid [Hpo] HP"). + rewrite big_sepM_dom. iFrame "Hpo". + Qed. + + Lemma istore_pln_fake_data `{!UserProt} {tid inst_addr ctrl po_prior} reg_dep val reg_res addr data addr_pred P: + inst_addr ↦ᵢ (IStore AS_normal AV_plain + reg_res (AEbinop AOplus (AEval data) (AEbinop AOminus (AEreg reg_dep) (AEreg reg_dep))) (AEval addr)) ∗ + Some po_prior -{LPo}> ∗ + ctrl -{Ctrl}> ∗ + last_local_write tid addr None ∗ + reg_dep ↦ᵣ (mk_regval val {[addr_pred]}) ∗ + addr_pred ↦ₐ P ∗ + ( + ∀ eid, eid -{E}> (Event.W AS_normal AV_plain addr data) -∗ + po_prior -{Edge.Po}> eid -∗ + addr_pred -{Edge.Data}> eid -∗ + P ==∗ + □ (prot addr data eid) + ) -∗ + (* Need to know about the data write here, or write the implication *) + SSWPi (LTSI.Normal, inst_addr) @ tid + {{ λ ltsi, + ⌜ltsi = (LTSI.Normal, (inst_addr `+Z` 4)%bv) ⌝ ∗ + reg_dep ↦ᵣ (mk_regval val {[addr_pred]}) ∗ + ∃ eid, eid -{E}> (Event.W AS_normal AV_plain addr data) ∗ + Some eid -{LPo}> ∗ + last_local_write tid addr (Some eid) ∗ + ctrl -{Ctrl}> + }}. + Proof. + iIntros "(Hinst & Hpo & Hctrl & Hlast_write & Hreg & Hna & Hprot)". load_ins. + + iDestruct (lpo_to_po with "Hpo") as "[Hlpo #Hpo]". + + iApply wp_sswp. iNamed "Hinterp". iDestruct (reg_interp_agree with "Hinterp_reg Hreg") as %Hreg. + iApply (sswp_strong_mono with "[]"). + iApply reg_read;eauto. + iIntros (? ->);simpl. + + iApply wp_sswp. iApply (sswp_strong_mono with "[]"). + iApply reg_read;eauto. + iIntros (? ->);simpl. + + iApply (mem_write_non_xcl _ {[po_prior]} {[addr_pred := P]} {[reg_dep := _]} ∅ with "Hlpo Hctrl Hlast_write [] [Hreg] [Hna] [Hprot] [-Hinterp_reg Hinterp_ctrl Hinterp_rmw Hinterp_pc]"). + + simpl. reflexivity. + + done. + + rewrite map_subseteq_spec. + intros ?? Hlk. rewrite lookup_intersection in Hlk. + rewrite lookup_empty in Hlk. inversion Hlk. + + simpl. set_solver +. + + rewrite dom_singleton_L. simpl. set_solver +. + + by iApply big_sepS_singleton. + + rewrite map_empty_union. + by iApply big_sepM_singleton. + + by iApply big_sepM_singleton. + + iIntros (?). iSplitR. + - iIntros "_ _ _ _ ?". + simpl. rewrite map_fold_singleton /=. rewrite 2!union_empty_r_L. + rewrite dom_singleton_L. rewrite 2!big_sepS_singleton. + by iApply data_is_lob. + - iIntros "((Hev&_&Hpos&_&Hdata&_&_)&Hna)". simpl. + rewrite map_fold_singleton /=. rewrite 2!union_empty_r_L. + rewrite 2!big_sepS_singleton. rewrite big_sepM_singleton. + assert ((data + (val - val)) = data)%bv as ->. bv_solve. + iDestruct ("Hprot" $! eid with "Hev Hpos Hdata Hna") as "Hprot". + iApply (fupd_mask_intro _ ∅). {set_solver. } + iIntros "M !>". iMod "M". iMod "Hprot". iModIntro. iSplit. { iExact "M". } + iFrame. + + iIntros (?) "Hinterp [%Hpc_eq %] [% ((?&?)&_&_&?&?&?&?)]";simpl. + iApply (inc_pc with "[-Hinterp]");eauto. rewrite Hpc_eq //. + iIntros (? -> ? ?) "Hinterp". iApply ("Hcont" with "[-Hinterp]");auto. + rewrite map_empty_union. rewrite big_sepM_singleton. iFrame. + iSplit;first done. + iExists _;iFrame. + assert ((data + (val - val)) = data)%bv as ->. bv_solve. done. + + iFrame. iExists _;iFrame. + Qed. + +End rules. diff --git a/theories/middle/weakestpre.v b/theories/middle/weakestpre.v new file mode 100644 index 0000000..c95972f --- /dev/null +++ b/theories/middle/weakestpre.v @@ -0,0 +1,539 @@ +(** This file contains the instantiation of the middle-level logic, + this is the file that all helper files import*) +From iris_named_props Require Export named_props. +From iris.proofmode Require Import base tactics classes. +From iris.algebra Require Export agree gset lib.dfrac_agree. +From iris.base_logic.lib Require Export ghost_map. + +From self.lang Require Import opsem. +From self.low Require Export weakestpre. + +Import uPred. + +Module LTSI. + Import ThreadState. + + Inductive mode : Type := + Normal | Done. + + Definition to_lts (mode : mode) (ts : ThreadState.t) := + match mode with + | Normal => LThreadState.LTSNormal ts + | Done => LThreadState.LTSDone ts + end. + + Definition t : Type := (mode * Addr). + +End LTSI. + +Class irisGInst `{CMRA Σ} := + { + inst_thread_interp : ThreadState.t -> iProp Σ; + inst_addr_is : Addr -> ThreadState.t -> Prop; + }. + +Definition to_lts_Phi `{CMRA Σ} `{!irisGInst} (Φ : LTSI.t -> iProp Σ) + (lts : LThreadState.t) : iProp Σ := + match lts with + | LThreadState.LTSNormal ts => inst_thread_interp ts ∗ + ∃ ins_addr', ⌜inst_addr_is ins_addr' ts⌝ ∗ + Φ (LTSI.Normal, ins_addr') + | LThreadState.LTSDone ts => inst_thread_interp ts ∗ + ∃ ins_addr', ⌜inst_addr_is ins_addr' ts⌝ ∗ + Φ (LTSI.Done, ins_addr') + end. + + +Definition wpi_def `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} `{!irisGInst} + (tid: Tid) (ltsi : LTSI.t) (Φ : LTSI.t -> iProp Σ) : iProp Σ := + (∀ (ts : ThreadState.t), + "%PC" ∷ ⌜inst_addr_is ltsi.2 ts⌝ -∗ + "Hinterp" ∷ inst_thread_interp ts -∗ + WP (LTSI.to_lts ltsi.1 ts) @ tid {{ ltsi, (to_lts_Phi Φ) ltsi}})%I. + +Definition wpi_aux : seal (@wpi_def). Proof. by eexists. Qed. +Definition wpi := wpi_aux.(unseal). + +Arguments wpi {Σ _ _ _ _ _ _}. +Lemma wpi_eq `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} `{!irisGInst} : wpi = @wpi_def Σ _ _ _ _ _ _. +Proof. rewrite -wpi_aux.(seal_eq) //. Qed. + +Notation "'WPi' m @ id {{ Φ } }" := (wpi id m Φ) + (at level 20, m, Φ at level 200, only parsing) : bi_scope. + +Notation "'WPi' m @ id {{ v , Q } }" := (wpi id m (λ v, Q)) + (at level 20, m, Q at level 200, + format "'[' 'WPi' m '/' '[ ' @ id {{ v , Q } } ']' ']'") : bi_scope. + +Definition sswpi_def `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} `{!irisGInst} + (tid: Tid) (ltsi : LTSI.t) (Φ : LTSI.t -> iProp Σ) : iProp Σ := + (∀ Ψ, + "Hcont" ∷ (∀ ltsi', Φ ltsi' -∗ (WPi ltsi' @ tid {{ ltsi, Ψ ltsi}})) -∗ + WPi ltsi @ tid {{ ltsi', Ψ ltsi'}})%I. + +Definition sswpi_aux : seal (@sswpi_def). Proof. by eexists. Qed. +Definition sswpi := sswpi_aux.(unseal). + +Arguments sswpi {Σ _ _ _ _ _ _}. +Lemma sswpi_eq `{CMRA Σ} `{!invGS_gen HasNoLc Σ} `{!irisG} `{!irisGL} `{!Protocol} `{!irisGInst}: sswpi = @sswpi_def Σ _ _ _ _ _ _. +Proof. rewrite -sswpi_aux.(seal_eq) //. Qed. + +Notation "'SSWPi' i @ id {{ Φ } }" := (sswpi id i Φ) + (at level 20, i, Φ at level 200, only parsing) : bi_scope. + +Notation "'SSWPi' i @ id {{ v , Q } }" := (sswpi id i (λ v, Q)) + (at level 20, i, Q at level 200, + format "'[' 'SSWPi' i '/' '[ ' @ id {{ v , Q } } ']' ']'") : bi_scope. + +Section wpi. + Context `{CMRA Σ}. + Context `{!invGS_gen HasNoLc Σ}. + Context `{!irisG}. + Context `{!irisGL}. + Context `{!Protocol}. + Context `{!irisGInst}. + Implicit Types Φ : LTSI.t → iProp Σ. + Implicit Types s : LTSI.t. + Implicit Types id : Tid. + + Lemma sswpi_wpi id s Φ : + SSWPi s @ id {{s', WPi s' @ id {{ Φ }} }} ⊢ WPi s @ id {{ Φ }}. + Proof. + rewrite sswpi_eq /sswpi_def. + iIntros "SSWP". iDestruct ("SSWP" $! Φ ) as "SSWP". + iApply "SSWP". iIntros (?) "$". + Qed. + + #[global] Instance sswpi_ne id s n : + Proper (pointwise_relation _ (dist n) ==> dist n) (sswpi id s). + Proof. + rewrite sswpi_eq /sswpi_def; intros ?? Heq. + do 6 f_equiv. rewrite /to_lts_Phi /=. repeat f_equiv. + Qed. + + #[global] Instance wpi_ne id s n : + Proper (pointwise_relation _ (dist n) ==> dist n) (wpi id s). + Proof. + rewrite wpi_eq /wpi_def; intros ?? Heq. + do 6 f_equiv. rewrite /to_lts_Phi /=. repeat f_equiv. + Qed. + + #[global] Instance sswpi_proper id s : + Proper (pointwise_relation _ (≡) ==> (≡)) (sswpi id s). + Proof. + by intros Φ Φ' ?; apply equiv_dist=>n; apply sswpi_ne=>v; apply equiv_dist. + Qed. + + #[global] Instance wpi_proper id s : + Proper (pointwise_relation _ (≡) ==> (≡)) (wpi id s). + Proof. + by intros Φ Φ' ?; apply equiv_dist=>n; apply wpi_ne=>v; apply equiv_dist. + Qed. + + Lemma to_lts_mono lts Φ Ψ : + to_lts_Phi Φ lts -∗ + (∀ s', Φ s' -∗ Ψ s') -∗ + to_lts_Phi Ψ lts. + Proof. + iIntros "H Himp". rewrite /to_lts_Phi. + destruct lts;auto;iDestruct "H" as "($ & %&?&H)";iExists _; iFrame; + iApply ("Himp" with "H"). + Qed. + + Lemma to_lts_strong_mono lts Φ Ψ : + to_lts_Phi Φ lts -∗ + (∀ s', Φ s' ==∗ Ψ s') ==∗ + to_lts_Phi Ψ lts. + Proof. + iIntros "H Himp". + rewrite /to_lts_Phi. + destruct lts;auto;iDestruct "H" as "($ & %&?&H)";iExists _; iFrame; + iApply ("Himp" with "H"). + Qed. + + Lemma wpi_strong_mono id s Φ Ψ : + WPi s @ id {{ Ψ }} -∗ + (∀ s', Ψ s' ==∗ Φ s') -∗ + WPi s @ id {{ Φ }}. + Proof. + rewrite wpi_eq /wpi_def. + iIntros "WP Himp". iIntros (?). repeat iNamed 1. + iSpecialize ("WP" with "[//] Hinterp"). + iApply (wp_strong_mono with "WP"). + iIntros (?) "H". by iApply (to_lts_strong_mono with "H"). + Qed. + + Lemma wpi_mono id s Φ Ψ : + (∀ s', Ψ s' ⊢ Φ s') -> + WPi s @ id {{ Ψ }} -∗ + WPi s @ id {{ Φ }}. + Proof. + rewrite wpi_eq /wpi_def. + iIntros (Himp) "WP %". repeat iNamed 1. + iSpecialize ("WP" with "[//] Hinterp"). + iApply (wp_mono with "WP"). + iIntros (?) "H". iApply (to_lts_mono with "H"). + iIntros (?) "?". iApply Himp;done. + Qed. + + Lemma bupd_wpi id s Φ : + (|==> WPi s @ id {{ Φ }}) ⊢ WPi s @ id {{ Φ }}. + Proof. + rewrite wpi_eq /wpi_def. + iIntros "WP %". repeat iNamed 1. + iMod "WP". iApply ("WP" with "[//] Hinterp"). + Qed. + + Lemma iupd_wpi id s Φ : + (|=i=> WPi s @ id {{ Φ }}) ⊢ WPi s @ id {{ Φ }}. + Proof. + rewrite wpi_eq /wpi_def. iIntros "WP %". repeat iNamed 1. + iMod "WP". iApply ("WP" with "[//] Hinterp"). + Qed. + + Lemma wpi_bupd id s Φ : + WPi s @ id {{ k, |==> Φ k }} ⊢ WPi s @ id {{ Φ }}. + Proof. iIntros "H". iApply (wpi_strong_mono id with "H"); auto. Qed. + + + Lemma sswpi_strong_mono id s Φ Ψ : + SSWPi s @ id {{ Ψ }} -∗ + (∀ s', Ψ s' ==∗ Φ s') -∗ + SSWPi s @ id {{ Φ }}. + Proof. + rewrite sswpi_eq /sswpi_def. + iIntros "WP Himp". iIntros (?). repeat iNamed 1. + iApply ("WP" with "[Himp Hcont]" ). + iIntros (?) "HΨ". + iApply bupd_wpi. iApply "Hcont". + by iApply "Himp". + Qed. + + Lemma sswpi_mono id s Φ Ψ : + SSWPi s @ id {{ Ψ }} -∗ + (∀ s', Ψ s' -∗ Φ s') -∗ + SSWPi s @ id {{ Φ }}. + Proof. + rewrite sswpi_eq /sswpi_def. + iIntros "WP Himp". iIntros (?). repeat iNamed 1. + iApply ("WP" with "[Himp Hcont]" ). + iIntros (?) "HΨ". + iApply "Hcont". + by iApply "Himp". + Qed. + + Lemma bupd_sswpi id s Φ : + (|==> SSWPi s @ id {{ Φ }}) ⊢ SSWPi s @ id {{ Φ }}. + Proof. + rewrite sswpi_eq /sswpi_def. + iIntros "WP %". repeat iNamed 1. + iApply bupd_wpi. iMod "WP". by iApply "WP". + Qed. + + Lemma iupd_sswpi id s Φ : + (|=i=> SSWPi s @ id {{ Φ }}) ⊢ SSWPi s @ id {{ Φ }}. + Proof. + rewrite sswpi_eq /sswpi_def. iIntros "WP %". repeat iNamed 1. + iApply iupd_wpi. iMod "WP". by iApply "WP". + Qed. + + Lemma sswpi_bupd id s Φ : + WPi s @ id {{ k, |==> Φ k }} ⊢ WPi s @ id {{ Φ }}. + Proof. iIntros "H". iApply (wpi_strong_mono id with "H"); auto. Qed. + + Lemma sswpi_step_bupd id s P Φ : + (|==> P) -∗ + SSWPi s @ id {{ k, P ==∗ Φ k }} -∗ + SSWPi s @ id {{ Φ }}. + Proof. + rewrite sswpi_eq /sswpi_def. iIntros "P". iIntros "WP %". repeat iNamed 1. + iApply "WP". + iIntros (?) "HP". iApply bupd_wpi. + iMod "P". iApply "Hcont". by iApply "HP". + Qed. + + Lemma sswpi_step_iupd id s P Φ : + (|=i=> P) -∗ + SSWPi s @ id {{ k, P -∗ |=i=> Φ k }} -∗ + SSWPi s @ id {{ Φ }}. + Proof. + rewrite sswpi_eq /sswpi_def. iIntros "P". iIntros "WP %". repeat iNamed 1. + iApply "WP". + iIntros (?) "HP". iApply iupd_wpi. + iMod "P". iApply "Hcont". by iApply "HP". + Qed. + + Lemma wpi_step_bupd id s P Φ : + (|==> P) -∗ + WPi s @ id {{ k, P ==∗ Φ k }} -∗ + WPi s @ id {{ Φ }}. + Proof. + rewrite wpi_eq /wpi_def. iIntros "P". iIntros "WP %". repeat iNamed 1. + iSpecialize ("WP" with "[//] Hinterp"). + iApply (wp_strong_mono with "WP"). + iIntros (?) "HP". iApply (to_lts_strong_mono with "HP"). + iIntros (?) "HP". iMod "P". by iApply "HP". + Qed. + + Lemma wpi_step_iupd id s P Φ : + (|=i=> P) -∗ + WPi s @ id {{ k, P ==∗ Φ k }} -∗ + WPi s @ id {{ Φ }}. + Proof. + rewrite wpi_eq /wpi_def. iIntros "P". iIntros "WP %". repeat iNamed 1. + iSpecialize ("WP" with "[//] Hinterp"). iMod "P". + iApply (wp_strong_mono with "WP"). + iIntros (?) "HP". iApply (to_lts_strong_mono with "HP"). + iIntros (?) "HP". by iApply "HP". + Qed. + + Definition inst_post_lifting tid (addr: Addr) Φ := + (∀ na : mea Σ, annot_interp na ==∗ + annot_interp na ∗ + (([∗ map] e↦R ∈ na, if bool_decide (Graph.is_local_node_of tid e) then R else True) -∗ ▷ |==> Φ (LTSI.Done, addr)))%I. + + Lemma wpi_terminated {tid :Tid} {addr Φ}: + inst_post_lifting tid addr Φ -∗ + WPi (LTSI.Done, addr) @ tid {{ Φ }}. + Proof. + iIntros "Hpost". + rewrite wpi_eq /wpi_def. iIntros (?). repeat iNamed 1. + iApply wp_terminated'; [done|]. + unfold post_lifting. simpl. + iIntros (?) "L". iDestruct ("Hpost" with "L") as ">[$ Hpost]". + iModIntro. simpl. + iIntros "H". iSpecialize ("Hpost" with "H"). iNext. iMod "Hpost". iModIntro. + iSplitL "Hinterp"; [iFrame|]. + iExists _; by iFrame. + Qed. + + (** * Derived rules *) + Lemma sswpi_mono' id s Φ Ψ : + (∀ k, Φ k ⊢ Ψ k) → SSWPi s @ id {{ Φ }} ⊢ SSWPi s @ id {{ Ψ }}. + Proof. + iIntros (HΦ) "H"; iApply (sswpi_strong_mono with "H"); auto. + iIntros (v) "?". by iApply HΦ. + Qed. + + Lemma wpi_mono' id s Φ Ψ : + (∀ k, Φ k ⊢ Ψ k) → WPi s @ id {{ Φ }} ⊢ WPi s @ id {{ Ψ }}. + Proof. + iIntros (HΦ) "H"; iApply (wpi_mono with "H"); auto. + Qed. + + Global Instance sswpi_mono'' id s : + Proper (pointwise_relation _ (⊢) ==> (⊢)) (sswpi id s). + Proof. by intros Φ Φ' ?; apply sswpi_mono'. Qed. + + Global Instance wpi_mono'' id s : + Proper (pointwise_relation _ (⊢) ==> (⊢)) (wpi id s). + Proof. by intros Φ Φ' ?; apply wpi_mono'. Qed. + + Global Instance sswpi_flip_mono' id s : + Proper (pointwise_relation _ (flip (⊢)) ==> (flip (⊢))) (sswpi id s). + Proof. by intros Φ Φ' ?; apply sswpi_mono''. Qed. + + Global Instance wpi_flip_mono' id s : + Proper (pointwise_relation _ (flip (⊢)) ==> (flip (⊢))) (wpi id s). + Proof. by intros Φ Φ' ?; apply wpi_mono''. Qed. + + Lemma sswpi_frame_l id s Φ R : + R ∗ SSWPi s @ id {{ Φ }} ⊢ SSWPi s @ id {{ k, R ∗ Φ k }}. + Proof. iIntros "[? H]". iApply (sswpi_strong_mono with "H"); auto with iFrame. Qed. + + Lemma wpi_frame_l id s Φ R : + R ∗ WPi s @ id {{ Φ }} ⊢ WPi s @ id {{ k, R ∗ Φ k }}. + Proof. iIntros "[? H]". iApply (wpi_strong_mono with "H"); auto with iFrame. Qed. + + Lemma sswpi_frame_r id s Φ R : + SSWPi s @ id {{ Φ }} ∗ R ⊢ SSWPi s @ id {{ k, Φ k ∗ R }}. + Proof. iIntros "[H ?]". iApply (sswpi_strong_mono with "H"); auto with iFrame. Qed. + + Lemma wpi_frame_r id s Φ R : + WPi s @ id {{ Φ }} ∗ R ⊢ WPi s @ id {{ k, Φ k ∗ R }}. + Proof. iIntros "[H ?]". iApply (wpi_strong_mono with "H"); auto with iFrame. Qed. + + Lemma sswpi_frame_step_l id s Φ R : + (|==> R) ∗ SSWPi s @ id {{ Φ }} ⊢ SSWPi s @ id {{ k, R ∗ Φ k }}. + Proof. + iIntros "[Hu Hwp]". iApply (sswpi_step_bupd with "Hu"); try done. + iApply (sswpi_mono with "Hwp"). by iIntros (?) "$$". + Qed. + + Lemma sswpi_frame_step_l'' id s Φ R : + (|=i=> R) ∗ SSWPi s @ id {{ Φ }} ⊢ SSWPi s @ id {{ k, R ∗ Φ k }}. + Proof. + iIntros "[Hu Hwp]". iApply (sswpi_step_iupd with "Hu"); try done. + iApply (sswpi_mono with "Hwp"). iIntros (?) "??". iModIntro. iFrame. + Qed. + + Lemma wpi_frame_step_l id s Φ R : + (|==> R) ∗ WPi s @ id {{ Φ }} ⊢ WPi s @ id {{ k, R ∗ Φ k }}. + Proof. + iIntros "[Hu Hwp]". iApply (wpi_step_bupd with "Hu"); try done. + iApply (wpi_mono with "Hwp"). by iIntros (?) "$$". + Qed. + + Lemma wpi_frame_step_l'' id s Φ R : + (|=i=> R) ∗ WPi s @ id {{ Φ }} ⊢ WPi s @ id {{ k, R ∗ Φ k }}. + Proof. + iIntros "[Hu Hwp]". iApply (wpi_step_iupd with "Hu"); try done. + iApply (wpi_mono with "Hwp"). by iIntros (?) "$$". + Qed. + + Lemma sswpi_frame_step_r id s Φ R : + SSWPi s @ id {{ Φ }} ∗ (|==> R) ⊢ SSWPi s @ id {{ k, Φ k ∗ R }}. + Proof. + rewrite [(SSWPi _ @ _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply sswpi_frame_step_l. + Qed. + + Lemma sswpi_frame_step_r'' id s Φ R : + SSWPi s @ id {{ Φ }} ∗ (|=i=> R) ⊢ SSWPi s @ id {{ k, Φ k ∗ R }}. + Proof. + rewrite [(SSWPi _ @ _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply sswpi_frame_step_l''. + Qed. + + Lemma wpi_frame_step_r id s Φ R : + WPi s @ id {{ Φ }} ∗ (|==> R) ⊢ WPi s @ id {{ k, Φ k ∗ R }}. + Proof. + rewrite [(WPi _ @ _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply wpi_frame_step_l. + Qed. + + Lemma wpi_frame_step_r'' id s Φ R : + WPi s @ id {{ Φ }} ∗ (|=i=> R) ⊢ WPi s @ id {{ k, Φ k ∗ R }}. + Proof. + rewrite [(WPi _ @ _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply wpi_frame_step_l''. + Qed. + + Lemma sswpi_frame_step_l' id s Φ R : + R ∗ SSWPi s @ id {{ Φ }} ⊢ SSWPi s @ id {{ k, R ∗ Φ k }}. + Proof. iIntros "[??]". iApply (sswpi_frame_step_l id); try iFrame; eauto. Qed. + + Lemma sswpi_frame_step_r' id s Φ R : + SSWPi s @ id {{ Φ }} ∗ R ⊢ SSWPi s @ id {{ k, Φ k ∗ R }}. + Proof. iIntros "[??]". iApply (sswpi_frame_step_r id); try iFrame; eauto. Qed. + + Lemma wpi_frame_step_l' id s Φ R : + R ∗ WPi s @ id {{ Φ }} ⊢ WPi s @ id {{ k, R ∗ Φ k }}. + Proof. iIntros "[??]". iApply (wpi_frame_step_l id); try iFrame; eauto. Qed. + + Lemma wpi_frame_step_r' id s Φ R : + WPi s @ id {{ Φ }} ∗ R ⊢ WPi s @ id {{ k, Φ k ∗ R }}. + Proof. iIntros "[??]". iApply (wpi_frame_step_r id); try iFrame; eauto. Qed. + + Lemma sswpi_wand id s Φ Ψ : + SSWPi s @ id {{ Φ }} -∗ (∀ k, Φ k -∗ Ψ k) -∗ SSWPi s @ id {{ Ψ }}. + Proof. + iIntros "Hwp H". iApply (sswpi_mono with "Hwp"); auto. + Qed. + + Lemma wpi_wand id s Φ Ψ : + WPi s @ id {{ Φ }} -∗ (∀ k, Φ k -∗ Ψ k) -∗ WPi s @ id {{ Ψ }}. + Proof. + iIntros "Hwp H". iApply (wpi_strong_mono with "Hwp"); auto. + iIntros (?) "?". by iApply "H". + Qed. + + Lemma sswpi_wand_l id s Φ Ψ : + (∀ k, Φ k -∗ Ψ k) ∗ SSWPi s @ id {{ Φ }} ⊢ SSWPi s @ id {{ Ψ }}. + Proof. iIntros "[H Hwp]". iApply (sswpi_wand with "Hwp H"). Qed. + + Lemma wpi_wand_l id s Φ Ψ : + (∀ v, Φ v -∗ Ψ v) ∗ WPi s @ id {{ Φ }} ⊢ WPi s @ id {{ Ψ }}. + Proof. iIntros "[H Hwp]". iApply (wpi_wand with "Hwp H"). Qed. + + Lemma sswpi_wand_r id s Φ Ψ : + SSWPi s @ id {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ SSWPi s @ id {{ Ψ }}. + Proof. iIntros "[Hwp H]". iApply (sswpi_wand with "Hwp H"). Qed. + + Lemma wpi_wand_r id s Φ Ψ : + WPi s @ id {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WPi s @ id {{ Ψ }}. + Proof. iIntros "[Hwp H]". iApply (wpi_wand with "Hwp H"). Qed. + + Lemma sswpi_frame_wand_l id s Q Φ : + Q ∗ SSWPi s @ id {{ v, Q -∗ Φ v }} -∗ SSWPi s @ id {{ Φ }}. + Proof. + iIntros "[HQ HWPi]". iApply (sswpi_wand with "HWPi"). + iIntros (v) "HΦ". by iApply "HΦ". + Qed. + + Lemma wpi_frame_wand_l id s Q Φ : + Q ∗ WPi s @ id {{ v, Q -∗ Φ v }} -∗ WPi s @ id {{ Φ }}. + Proof. + iIntros "[HQ HWPi]". iApply (wpi_wand with "HWPi"). + iIntros (v) "HΦ". by iApply "HΦ". + Qed. + +End wpi. + +Section proofmode_classes. + Context `{CMRA Σ}. + Context `{!invGS_gen HasNoLc Σ}. + Context `{!irisG}. + Context `{!irisGL}. + Context `{!irisGInst}. + Context `{!Protocol}. + Implicit Types P Q : iProp Σ. + Implicit Types Φ : LTSI.t → iProp Σ. + (* Implicit Types E : coPset. *) + Implicit Types id : Tid. + + #[global] Instance frame_sswpi p id s R Φ Ψ : + (∀ k, Frame p R (Φ k) (Ψ k)) → + Frame p R (SSWPi s @ id {{ Φ }}) (SSWPi s @ id {{ Ψ }}). + Proof. rewrite /Frame=> HR. rewrite sswpi_frame_l. apply sswpi_mono', HR. Qed. + + #[global] Instance frame_wpi p id s R Φ Ψ : + (∀ k, Frame p R (Φ k) (Ψ k)) → + Frame p R (WPi s @ id {{ Φ }}) (WPi s @ id {{ Ψ }}). + Proof. rewrite /Frame=> HR. rewrite wpi_frame_l. apply wpi_mono', HR. Qed. + + #[global] Instance elim_modal_bupd_sswpi p id s P Φ : + ElimModal True p false (|==> P) P (SSWPi s @ id {{ Φ }}) (SSWPi s @ id {{ Φ }}). + Proof. + rewrite /ElimModal bi.intuitionistically_if_elim + bupd_frame_r bi.wand_elim_r bupd_sswpi //. + Qed. + + #[global] Instance elim_modal_iupd_sswpi p id s P Φ : + ElimModal True p false (|=i=> P) P (SSWPi s @ id {{ Φ }}) (SSWPi s @ id {{ Φ }}). + Proof. + rewrite /ElimModal bi.intuitionistically_if_elim + interp_mod_frame_r bi.wand_elim_r iupd_sswpi //. + Qed. + + #[global] Instance elim_modal_bupd_wpi p id s P Φ : + ElimModal True p false (|==> P) P (WPi s @ id {{ Φ }}) (WPi s @ id {{ Φ }}). + Proof. + rewrite /ElimModal bi.intuitionistically_if_elim + bupd_frame_r bi.wand_elim_r bupd_wpi //. + Qed. + + #[global] Instance elim_modal_iupd_wpi p id s P Φ : + ElimModal True p false (|=i=> P) P (WPi s @ id {{ Φ }}) (WPi s @ id {{ Φ }}). + Proof. + rewrite /ElimModal bi.intuitionistically_if_elim + interp_mod_frame_r bi.wand_elim_r iupd_wpi //. + Qed. + + #[global] Instance add_modal_bupd_sswpi id s P Φ : + AddModal (|==> P) P (SSWPi s @ id {{ Φ }}). + Proof. rewrite /AddModal bupd_frame_r bi.wand_elim_r bupd_sswpi //. Qed. + + #[global] Instance add_modal_iupd_sswp id s P Φ : + AddModal (|=i=> P) P (SSWPi s @ id {{ Φ }}). + Proof. rewrite /AddModal interp_mod_frame_r bi.wand_elim_r iupd_sswpi //. Qed. + + #[global] Instance add_modal_bupd_wpi id s P Φ : + AddModal (|==> P) P (WPi s @ id {{ Φ }}). + Proof. rewrite /AddModal bupd_frame_r bi.wand_elim_r bupd_wpi //. Qed. + + #[global] Instance add_modal_iupd_wp id s P Φ : + AddModal (|=i=> P) P (WPi s @ id {{ Φ }}). + Proof. rewrite /AddModal interp_mod_frame_r bi.wand_elim_r iupd_wpi //. Qed. + +End proofmode_classes. diff --git a/theories/stdpp_extra.v b/theories/stdpp_extra.v new file mode 100644 index 0000000..ab77e8d --- /dev/null +++ b/theories/stdpp_extra.v @@ -0,0 +1,375 @@ +From stdpp Require Import ssreflect list sets fin_maps fin_map_dom gmap. + +Lemma head_app{A} (l1 l2 :list A): head (l1 ++ l2) = match head l1 with + | Some x => Some x + | None => head l2 + end. +Proof. destruct l1; done. Qed. + +Lemma list_sum_zero l : list_sum l = 0 -> Forall (fun e => e = 0) l. +Proof. + intros Hsum. + induction l;first done. + rewrite /= in Hsum. + assert (a = 0) as -> by lia. + rewrite Nat.add_0_l in Hsum. + apply Forall_cons_2;auto. +Qed. + +Lemma list_filter_split {A} (l : list A) (P: A -> Prop) `{forall x : A, Decision (P x)}: + l ≡ₚ filter (λ x, P x) l ++ filter (λ x, ¬ P x) l. + Proof. + induction l. + rewrite !filter_nil. done. + destruct (decide (P a)). + { + rewrite filter_cons_True //. + rewrite filter_cons_False //. + rewrite {1}IHl. + rewrite app_comm_cons //. + intro. done. + } + { + rewrite filter_cons_False //. + rewrite filter_cons_True //. + rewrite {1}IHl. + rewrite -Permutation_cons_app. + reflexivity. done. + } + Qed. + + Lemma list_foldr_absorb {A B} (l1 l2 : list A) (f : A -> B -> B) (b : B) (x : A): + Forall (λ x', x' = x) l1 -> + (forall b', f x b' = f x (f x b')) -> + f x (foldr f b (l1 ++ l2)) = f x (foldr f b l2). + Proof. + intros. + induction l1. done. + rewrite -app_comm_cons. + rewrite foldr_cons. + apply Forall_cons_1 in H. destruct H as [-> Hforall]. + rewrite IHl1 //. + Qed. + + +Section list_subset_ind. + (* An induction principle that works well with [big_sepL/big_sepL2] *) + Definition list_subset {A} (l l' : list A) := ∃ x l'', l' ≡ₚ l ++ (x :: l'') . + + Lemma list_subset_wf {A} : wf ((@list_subset A))%stdpp. + Proof. + intros l. + apply (Acc_impl (fun l1 l2 => length l1 < length l2)). + apply (wf_projected (lt) length). + done. apply lt_wf. + intros ? ? [? [? Hp]]. + rewrite Hp. + rewrite app_length. rewrite cons_length. + lia. + Qed. + + Lemma list_subset_ind {A} (P : list A → Prop) : + P [] → (∀ l'', (∀l', list_subset l' l'' -> P l') → P l'') → forall l', P l'. + Proof. + intros. + apply well_founded_induction with (list_subset). + apply list_subset_wf. + intros. destruct x eqn:Heqn. done. + apply H0. + intros. apply H1. done. + Qed. + +End list_subset_ind. + +Section prefix_ind. + (* An induction principle that works well with [big_sepL/big_sepL2] *) + Definition prefix_strict {A} (l l' : list A) := ∃ x, l' = l ++ [x]. + + Lemma prefix_strict_wf {A} : wf ((@prefix_strict A))%stdpp. + Proof. + intros l. + apply (Acc_impl (fun l1 l2 => length l1 < length l2)). + apply (wf_projected (lt) length). + done. + apply lt_wf. + intros ? ? []. + rewrite H. + rewrite app_length. + simpl. lia. + Qed. + + Lemma prefix_strict_cons {A} (l l' : list A) x : l = x :: l' -> ∃ l'', prefix_strict l'' l. + Proof. + intros. + revert x l H. + induction l'. + exists []. exists x. done. + { + intros. + specialize (IHl' a (a::l')). + feed specialize IHl'. + done. + destruct IHl' as [l'' []]. + exists (x::l''). + exists x0. + rewrite H. + rewrite H0. + done. + } + Qed. + + Lemma prefix_strict_ind {A} (P : list A → Prop) : + P [] → (∀ l' l'', prefix_strict l' l'' -> P l' → P l'') → forall l', P l'. + Proof. + intros. + apply well_founded_induction with (prefix_strict). + apply prefix_strict_wf. + intros. + destruct x eqn:Heqn. + done. + pose proof (prefix_strict_cons x l a). + feed specialize H2;first done. + destruct H2. + rewrite -Heqn. + apply (H0 x0);first done. + apply H1. + rewrite -Heqn //. + Qed. +End prefix_ind. + +Section sets. + Context `{Countable T}. + Implicit Type A B C : gset T. + + Lemma union_split_difference_intersection_L A B: + A = (A ∖ B) ∪ (A ∩ B) ∧ (A ∖ B) ## (A ∩ B). + Proof. + split. + rewrite union_intersection_l_L difference_union_L. set_solver. + set_solver. + Qed. + + Lemma union_split_difference_intersection_subseteq_L A B: + B ⊆ A -> + A = (A ∖ B) ∪ B ∧ (A ∖ B) ## B. + Proof. + intro H0. + pose proof (union_split_difference_intersection_L A B) as H1. + assert (A ∩ B = B) by set_solver + H0. + set_solver + H1 H2. + Qed. + + Lemma difference_split_subseteq_L A B C : + A ⊆ B -> B ⊆ C -> + C ∖ A = (C ∖ B) ∪ (B ∖ A). + Proof. + intros H1 H2. + pose proof (union_split_difference_intersection_subseteq_L B A H1) as [Heq Hdisj]. + rewrite {1}Heq. + rewrite difference_union_distr_r_L. + rewrite union_intersection_r_L. + rewrite difference_union_L. + set_solver. + Qed. + +End sets. + +Section set_filter. + Context `{FinSet A C}. + + Lemma set_filter_subseteq (s1 s2 : C) `{∀ x : A, Decision (P x)}: + s1 ⊆ s2 -> + filter P s1 ⊆ filter P s2. + Proof. + intros ?? Hin. apply elem_of_filter in Hin. destruct Hin as [Heq Hin]. + apply elem_of_filter. split;auto. + Qed. + + Lemma set_filter_split (s : C) P `{∀ x : A, Decision (P x)}: + filter P s ∪ filter (λ x, ¬P x) s ≡ s ∧ filter P s ## filter (λ x, ¬P x) s. + Proof. + split. + { + apply set_equiv. + intros. + rewrite elem_of_union. + split. + intros [|]. + apply elem_of_filter in H8. naive_solver. + apply elem_of_filter in H8. naive_solver. + intro. + destruct (decide (P x)). + left;apply elem_of_filter;done. + right;apply elem_of_filter;done. + } + intros ???. apply elem_of_filter in H8. apply elem_of_filter in H9. naive_solver. + Qed. +End set_filter. + +Section theorems. + + Lemma map_filter_split {A} `{FinMap K M} (m : M A) P `{∀ x : K, Decision (P x)}: + filter (λ '(k,v), P k) m ∪ filter (λ '(k,v), ¬P k) m = m. + Proof. + apply map_eq_iff. + intros. + rewrite lookup_union. + rewrite 2!map_filter_lookup. + destruct (m !! i) eqn:Hlk;simpl. + { + rewrite option_guard_bool_decide. + case_bool_decide. + rewrite option_guard_False;auto. + rewrite option_guard_True //. + } + done. + Qed. + + Lemma map_difference_union_exists {A} `{!Equiv A} `{FinMapDom K M D} + `{!RelDecision (≡@{D})} + `{!RelDecision (∈@{D})} (m1 m2 : M A) : + dom m1 ⊆ dom m2 -> + exists m3, m3 ⊆ m2 ∧ + dom m3 ≡@{D} dom m1 ∧ + m3 ∪ (m2 ∖ m1) =@{M A} m2. + Proof. + intros Hsub. revert m1 Hsub. + induction m2 using map_ind. + - intros. exists ∅. split;auto. rewrite dom_empty in Hsub. + apply set_subseteq_antisymm in Hsub. + feed specialize Hsub. + apply empty_subseteq. + rewrite !Hsub. + split. rewrite dom_empty //. + apply dom_empty_iff in Hsub. + subst m1. + rewrite map_difference_empty. rewrite map_union_empty //. + - intros. rewrite dom_insert in Hsub. + destruct (decide (i ∈ dom m1)). + assert (dom (delete i m1) ⊆ dom m) as Hdom. + assert (delete i ({[i := x]} ∪ m) = m) as <-. + rewrite -insert_union_singleton_l. + by apply delete_insert. + rewrite 2!dom_delete. + apply difference_mono_r. + rewrite dom_union dom_singleton //. + specialize (IHm2 _ Hdom). + destruct IHm2 as [m3 (Hsubm3 & Hdomm3 & Heqm3)]. + exists (<[i := x]> m3). + split. apply insert_subseteq_l. apply lookup_insert_Some. left;done. + transitivity m. done. by apply insert_subseteq_r. + split. + rewrite elem_of_dom in e. destruct e. + assert (m1 = <[i:= x0]> (delete i m1)) as ->. + rewrite insert_delete //. + rewrite !dom_insert. + f_equiv. done. + rewrite -insert_union_l. rewrite -{2}Heqm3. + f_equal. f_equal. + apply elem_of_dom in e. destruct e as [x1 Hlk1]. + rewrite -{1}(insert_delete m1 i x1) //. + erewrite difference_insert. rewrite insert_delete. + apply map_eq. intros. rewrite !lookup_difference_with. + destruct (m !! i0) eqn:Heqn;simpl. + apply elem_of_dom_2 in Heqn. + apply not_elem_of_dom in H14. + rewrite lookup_delete_ne //. + set_solver + Heqn H14. + done. exact Hlk1. + assert (dom m1 ⊆ dom m) as Hdom. + { + apply not_elem_of_dom in H14. + set_solver. + } + specialize (IHm2 _ Hdom). + destruct IHm2 as [m3 (Hsubm3 & Hdomm3 & Heqm3)]. + exists m3. split. apply insert_subseteq_r. rewrite -not_elem_of_dom. rewrite Hdomm3 //. done. + split. done. + rewrite -{2} Heqm3. + assert (<[i:=x]> m ∖ m1 = <[i:=x]> (m ∖ m1)) as ->. + rewrite insert_difference. + rewrite delete_notin //. apply not_elem_of_dom. auto. + rewrite insert_union_r //. + apply not_elem_of_dom. + set_solver. + Qed. + +End theorems. + +Section set_fold_to_gmap. + Context `{Countable A}. + + Lemma set_fold_to_gmap_insert {B} (X : gset A) (f : A -> B) (m1 m2 : gmap A B) (x : A): + x ∉ dom m1 -> + {[x]} ∪ dom m1 ## dom m2 -> + {[x]} ∪ dom m1 ## X -> + set_fold (λ e acc, <[e:= f e]> acc) m2 X ∪ <[x:= f x]> m1 + = set_fold (λ e acc, <[e:= f e]> acc) (<[x:= f x]> m2) X ∪ m1. + revert m1 m2. + induction X using set_ind_L. + { + intros ?? Hnin Hdisj1 Hdisj2. rewrite 2!set_fold_empty //. + rewrite -insert_union_r //. + rewrite insert_union_l //. + apply not_elem_of_dom. set_solver + Hdisj1. + } + { + intros ?? Hnin Hdisj1 Hdisj2. + setoid_rewrite (set_fold_disj_union_strong _ (λ e acc, <[e:= f e]> acc)). + rewrite 2!set_fold_singleton. + erewrite IHX;eauto. rewrite insert_commute //. + set_solver + Hdisj2. + rewrite dom_insert_L. set_solver + Hnin Hdisj1 Hdisj2. + set_solver + Hdisj2. + intros. apply _. + intros. by apply insert_commute. + set_solver. + intros. apply _. + intros. by apply insert_commute. + set_solver. + } + Qed. + + Lemma map_imap_dom_Some {B C} (m : gmap A B) (f : A -> B -> C) : + dom (map_imap (λ k v, Some (f k v)) m) = dom m. + Proof. + induction m using map_ind. + rewrite map_imap_empty //. + rewrite map_imap_insert. rewrite 2!dom_insert_L. rewrite IHm //. + Qed. + + Lemma set_fold_to_gmap_imap {B} (X : gset A) (Y : gmap A B) (f : A -> B): + X ## dom Y -> + (set_fold (λ e (acc : gmap A B), <[e:=f e]> acc) Y X) = map_imap (λ k _, Some (f k)) (gset_to_gmap tt X) ∪ Y. + Proof. + revert Y. induction X as [|x X Hin] using set_ind_L;intros Y. + - rewrite set_fold_empty //. rewrite map_imap_empty. rewrite map_empty_union //. + - intros Hdisj. rewrite set_fold_disj_union_strong. + rewrite set_fold_singleton. + rewrite IHX //. + rewrite gset_to_gmap_union_singleton. rewrite map_imap_insert. + rewrite -(union_insert_delete _ (<[x:=f x]> Y) x (f x)). + rewrite delete_insert //. apply not_elem_of_dom. set_solver + Hdisj. + apply not_elem_of_dom. rewrite map_imap_dom_Some. rewrite dom_gset_to_gmap. set_solver + Hin. + apply lookup_insert. + set_solver. + intros. rewrite insert_commute //. + set_solver. + Qed. + + Lemma set_fold_to_gmap_dom {B} (X : gset A) (f : A -> B): + dom (set_fold (λ e (acc : gmap A B), <[e:=f e]> acc) ∅ X) = X. + Proof. + rewrite set_fold_to_gmap_imap //. rewrite dom_union_L. + rewrite map_imap_dom_Some. rewrite dom_gset_to_gmap //. set_solver. + Qed. + + Lemma set_fold_to_gmap_lookup {B} (X : gset A) (f : A -> B) k: + k ∈ X -> + (set_fold (λ e (acc : gmap A B), <[e:=f e]> acc) ∅ X) !! k = Some (f k). + Proof. + intros. rewrite set_fold_to_gmap_imap //. rewrite lookup_union_l //. + rewrite map_lookup_imap. rewrite lookup_gset_to_gmap. case_option_guard; done. + Qed. + +End set_fold_to_gmap.