diff --git a/.gitignore b/.gitignore
index d485fb3c1f995858588fded73a4f71cc2e3bf8a7..a89171ef758256c991313dcb8547a961dac42bbd 100644
--- a/.gitignore
+++ b/.gitignore
@@ -13,6 +13,9 @@
.coq-native/
Makefile.coq
Makefile.coq.conf
+_CoqProject.*
+Makefile.package.*
+.Makefile.package.*
builddep
*.crashcoqide
.coqdeps.d
diff --git a/README.md b/README.md
index 0dcb68469a81c09af54adacd979d024d7b73fc0f..490eb4597e80052d208d94f59117507d15668f4c 100644
--- a/README.md
+++ b/README.md
@@ -1,14 +1,13 @@
# GPFSL (iRC11) COQ DEVELOPMENT
-This is a separation logic for [ORC11] based on [iGPS] and [FSL]. It has been recently renamed as **iRC11**.
+This is a separation logic for ORC11 based on [iGPS] and [FSL]. It has been recently renamed as **iRC11**.
## Prerequisites
This version is known to compile with:
- Coq 8.15.1
- - A development version of [ORC11] and [Iris]. See the [opam](opam) file for the exact
- version.
+ - A development version of [Iris].
The easiest way to install the correct versions of the dependencies is through
opam (2.0.0 or newer). You will need the Coq and Iris opam repositories:
@@ -30,37 +29,63 @@ dependencies. To fix that, please run `opam update` followed by
Run `make -jN` to build the full development, where `N` is the number of your
CPU cores.
-## STRUCTURE
+## ORC11
+
+ORC11 provides an operational version of [RC11] without SC accesses and SC fences,
+and with a race detector for non-atomics.
+
+In [thread.v](orc11/thread.v), the definition of the semantics
+is decomposed into 3 relations `lbl_machine_step`, `drf_pre`, and `drf_post`.
+`lbl_machine_step` concerns the main semantics of views, while `drf_pre` and
+`drf_post` implement the race detector (Section 5.1 of the RBrlx paper).
+
+### Race detector simplified
+
+The race detector is summarized as follows (NA: non-atomic / AT : atomic):
+* An NA write must have seen all other operations
+* An NA read must have seen all writes (NA & AT)
+* An AT write must have seen all NA operations (read & writes)
+* An AT read must have seen all NA writes
+
+| Must have seen | NA write | NA read | AT write | AT read |
+| -----------------| --------:| --------:| --------:| -------:|
+| NA write | + | + | + | + |
+| NA read | + | | + | |
+| AT write | + | + | | |
+| AT read | + | | | |
+
+
+## iRC11
iRC11 formalizes the actual language of RBrlx, as well as the logic for general
verification of programs written that language.
-* [lang/lang.v](theories/lang/lang.v) defines the language as a
+* [lang/lang.v](gpfsl/lang/lang.v) defines the language as a
combination of ORC11 and a *CPS-style expression* language following that of
lambda-Rust.
* The expression language is defined with `base.head_step`.
* The complete language combines `base.head_step`, `lbl_machine_step`,
`drf_pre`, and `drf_post` into `head_step`.
-* [base_logic](theories/base_logic) is the instantiation of the
+* [base_logic](gpfsl/base_logic) is the instantiation of the
language in Iris. The view-predicate assertion type `vProp` (Section 3.1, 4.2
- of the RBrlx paper) is defined in [vprop.v](theories/base_logic/vprop.v).
+ of the RBrlx paper) is defined in [vprop.v](gpfsl/base_logic/vprop.v).
The points-to assertions `l ↦ v` (Section 3.1) are defined in
- [na.v](theories/base_logic/na.v).
- * [adequacy.v](theories/base_logic/adequacy.v) proves that
+ [na.v](gpfsl/base_logic/na.v).
+ * [adequacy.v](gpfsl/base_logic/adequacy.v) proves that
expressions verified in the base logic are actually safe and functionally
correct. Since iRC11 is built on the base logic, this in turn implies that
expressions verified in iRC11 are also safe and functionally correct.
-* [gps](theories/gps) provides the model of iRC11 single-location
+* [gps](gpfsl/gps) provides the model of iRC11 single-location
cancellable invariants (Section 3.2, 4.4). Note that iRC11 single-location
invariants presented in the paper are only a very simplified version of what
we actually need in Coq.
* The ATOM definition (iRC11-CInv-Model, Section 4.4) is called `GPS_INV` in
Coq, see `GPS_INV_def` in
- [middleware.v](theories/gps/middleware.v).
+ [middleware.v](gpfsl/gps/middleware.v).
The actual instantiation with raw cancellable invariants can be found in
- [surface.v](theories/gps/surface.v), for example
+ [surface.v](gpfsl/gps/surface.v), for example
`GPS_vSP_Reader`.
- * [surface.v](theories/gps/surface.v) contains a *single-writer*
+ * [surface.v](gpfsl/gps/surface.v) contains a *single-writer*
instance of iRC11 single-location cancellable invariants. The following
table lists the rules that are ***similar*** but not exactly the same as the
rules presented in Section 3 of the RBrlx paper, because in Coq they are
@@ -80,9 +105,9 @@ verification of programs written that language.
More details on the single-writer invariants can be found in Section 5 of
the technical appendix of the RBrlx paper.
-* [logic](theories/logic) provides the models of various other
+* [logic](gpfsl/logic) provides the models of various other
features of the logic.
- * [view_invariants.v](theories/logic/view_invariants.v) provides
+ * [view_invariants.v](gpfsl/logic/view_invariants.v) provides
the model of raw cancellable invariants (Section 4.2, 4.3). So in Coq, raw
cancellable invariants are call *view invariants*.
@@ -105,7 +130,7 @@ verification of programs written that language.
Note that the access rule Raw-CInv-Acc is given Coq with Iris style, where
viewshifts are used instead of Hoare triples.
- * [relacq.v](theories/logic/relacq.v) provides the model of
+ * [relacq.v](gpfsl/logic/relacq.v) provides the model of
fence modalities (Section 5.2).
| Definition (Sect. 5.2)| File | Definition |
@@ -114,16 +139,16 @@ verification of programs written that language.
| AcqMod-Model | relacq.v | acq_mod_def |
* The Ghost-Mod rule is realized by `rel_embed_elim` and `acq_embed_elim`
- (in [relacq.v](theories/logic/relacq.v)),
+ (in [relacq.v](gpfsl/logic/relacq.v)),
because ghost elements are embedded in iRC11 directly from Iris.
If `ownGhost(γ,a)` is the ghost ownership assertion in Iris (dashed box in
Fig. 3 of the paper), then `⎡ownGhost(γ,a)⎤` is the ghost ownership
assertion in iRC11.
The *embedding* modality `⎡·⎤` is defined with `monPred_embed_def` in Iris's
- [monPred.v](https://gitlab.mpi-sws.org/iris/iris/blob/master/theories/bi/monpred.v).
+ [monPred.v](https://gitlab.mpi-sws.org/iris/iris/blob/master/gpfsl/bi/monpred.v).
- * [lifting.v](theories/logic/lifting.v) provides the rules of
+ * [lifting.v](gpfsl/logic/lifting.v) provides the rules of
various features around Hoare triples.
In Iris's Coq, we use weakest preconditions `wp` instead of Hoare triples.
Again, not all rules are exact matches with what were presented in the
@@ -140,9 +165,8 @@ verification of programs written that language.
* An example verification of the Message-Passing example, which has stronger
resource reclamation than both examples given in Figure 4 of the RBrlx paper,
- is given in [examples/mp_reclaim.v](theories/examples/mp_reclaim.v)
+ is given in [examples/mp_reclaim.v](gpfsl/examples/mp_reclaim.v)
-[ORC11]: https://gitlab.mpi-sws.org/iris/orc11
[Iris]: https://gitlab.mpi-sws.org/iris/iris
[iGPS]: http://plv.mpi-sws.org/igps/
[FSL]: http://plv.mpi-sws.org/fsl/
diff --git a/_CoqProject b/_CoqProject
index 0be5a53c1b853d15f100336c8cc50f6c1b0c529b..81a08e00f5e2a9426e0d53353eb458c62875999e 100644
--- a/_CoqProject
+++ b/_CoqProject
@@ -1,120 +1,138 @@
--Q theories gpfsl
+# Search paths for all packages. They must all match the regex
+# `-Q $PACKAGE[/ ]` so that we can filter out the right ones for each package.
+-Q gpfsl gpfsl
+-Q orc11 orc11
+# silence coq_makefile warning
+-docroot gpfsl
# We sometimes want to locally override notation, and there is no good way to do that with scopes.
-arg -w -arg -notation-overridden
# Cannot use non-canonical projections as it causes massive unification failures
# (https://github.com/coq/coq/issues/6294).
-arg -w -arg -redundant-canonical-projection
+# ORC11
+orc11/base.v
+orc11/value.v
+orc11/mem_order.v
+orc11/event.v
+orc11/location.v
+orc11/view.v
+orc11/memory.v
+orc11/tview.v
+orc11/thread.v
+orc11/progress.v
+
+
# Language Definitions
-theories/lang/lang.v
-theories/lang/notation.v
-theories/lang/tactics.v
+gpfsl/lang/lang.v
+gpfsl/lang/notation.v
+gpfsl/lang/tactics.v
# CMRAs
-theories/algebra/lat_auth.v
-theories/algebra/to_agree.v
-theories/algebra/lattice_cmra.v
+gpfsl/algebra/lat_auth.v
+gpfsl/algebra/to_agree.v
+gpfsl/algebra/lattice_cmra.v
# Based Logic with Views
## Ghost Constructions
-theories/base_logic/history_cmra.v
+gpfsl/base_logic/history_cmra.v
## Extra Semantics Properties
-theories/base_logic/memory.v
+gpfsl/base_logic/memory.v
## View-predicates
-theories/base_logic/bi.v
-theories/base_logic/vprop.v
-theories/base_logic/frame_instances.v
+gpfsl/base_logic/bi.v
+gpfsl/base_logic/vprop.v
+gpfsl/base_logic/frame_instances.v
## Instantiation
-theories/base_logic/history.v
-theories/base_logic/weakestpre.v
-theories/base_logic/adequacy.v
-theories/base_logic/local_preds.v
-theories/base_logic/na.v
-theories/base_logic/meta_data.v
-theories/base_logic/base_lifting.v
-theories/base_logic/iwp.v
+gpfsl/base_logic/history.v
+gpfsl/base_logic/weakestpre.v
+gpfsl/base_logic/adequacy.v
+gpfsl/base_logic/local_preds.v
+gpfsl/base_logic/na.v
+gpfsl/base_logic/meta_data.v
+gpfsl/base_logic/base_lifting.v
+gpfsl/base_logic/iwp.v
# Surface-level Logic
-theories/logic/relacq.v
-theories/logic/lifting.v
-theories/logic/proofmode.v
+gpfsl/logic/relacq.v
+gpfsl/logic/lifting.v
+gpfsl/logic/proofmode.v
## Invariants
-theories/logic/na_invariants.v
-theories/logic/invariants.v
-theories/logic/view_invariants.v
-theories/logic/subj_invariants.v
-theories/logic/sc_invariants.v
+gpfsl/logic/na_invariants.v
+gpfsl/logic/invariants.v
+gpfsl/logic/view_invariants.v
+gpfsl/logic/subj_invariants.v
+gpfsl/logic/sc_invariants.v
## Logical Atomic Triples
-theories/logic/atomic_update.v
-theories/logic/logatom.v
+gpfsl/logic/atomic_update.v
+gpfsl/logic/logatom.v
## Atomic Points-to
-theories/logic/atomic_cmra.v
-theories/logic/atomic_ghost.v
-theories/logic/atomic_preds.v
-theories/logic/atomic_ops.v
-theories/logic/atomic_ops_vj.v
-theories/logic/atomics.v
+gpfsl/logic/atomic_cmra.v
+gpfsl/logic/atomic_ghost.v
+gpfsl/logic/atomic_preds.v
+gpfsl/logic/atomic_ops.v
+gpfsl/logic/atomic_ops_vj.v
+gpfsl/logic/atomics.v
## Derived Constructs
-theories/logic/repeat_loop.v
-theories/logic/for_loop.v
-theories/logic/new_delete.v
-theories/logic/atomic_exchange.v
-theories/logic/diverge.v
-theories/logic/arith.v
+gpfsl/logic/repeat_loop.v
+gpfsl/logic/for_loop.v
+gpfsl/logic/new_delete.v
+gpfsl/logic/atomic_exchange.v
+gpfsl/logic/diverge.v
+gpfsl/logic/arith.v
# GPS protocols
## Model
-theories/gps/block_ends.v
-theories/gps/cbends.v
-theories/gps/cmras.v
-theories/gps/model_defs.v
-theories/gps/model_rules_init.v
-theories/gps/model_rules_dealloc.v
-theories/gps/model_rules_read.v
-theories/gps/model_rules_write.v
-theories/gps/model_rules_cas.v
-theories/gps/model.v
+gpfsl/gps/block_ends.v
+gpfsl/gps/cbends.v
+gpfsl/gps/cmras.v
+gpfsl/gps/model_defs.v
+gpfsl/gps/model_rules_init.v
+gpfsl/gps/model_rules_dealloc.v
+gpfsl/gps/model_rules_read.v
+gpfsl/gps/model_rules_write.v
+gpfsl/gps/model_rules_cas.v
+gpfsl/gps/model.v
## Middleware Rules
-theories/gps/middleware_SW.v
-theories/gps/middleware_PP.v
-theories/gps/middleware.v
-theories/gps/protocols.v
+gpfsl/gps/middleware_SW.v
+gpfsl/gps/middleware_PP.v
+gpfsl/gps/middleware.v
+gpfsl/gps/protocols.v
## Surface Rules
-theories/gps/escrows.v
-theories/gps/surface_iSP.v
-theories/gps/surface_vSP.v
-theories/gps/surface_iPP.v
-theories/gps/surface.v
+gpfsl/gps/escrows.v
+gpfsl/gps/surface_iSP.v
+gpfsl/gps/surface_vSP.v
+gpfsl/gps/surface_iPP.v
+gpfsl/gps/surface.v
# Examples
-theories/examples/uniq_token.v
-theories/examples/nat_tokens.v
-theories/examples/map_seq.v
+gpfsl/examples/uniq_token.v
+gpfsl/examples/nat_tokens.v
+gpfsl/examples/map_seq.v
## Message-Passing
-theories/examples/mp/code.v
-theories/examples/mp/spec.v
-theories/examples/mp/proof_gps.v
-theories/examples/mp/proof_reclaim_gps.v
-theories/examples/mp/proof_gen_inv.v
+gpfsl/examples/mp/code.v
+gpfsl/examples/mp/spec.v
+gpfsl/examples/mp/proof_gps.v
+gpfsl/examples/mp/proof_reclaim_gps.v
+gpfsl/examples/mp/proof_gen_inv.v
## Locks
-theories/examples/lock/code_ticket_lock.v
-theories/examples/lock/proof_ticket_lock_gps.v
+gpfsl/examples/lock/code_ticket_lock.v
+gpfsl/examples/lock/proof_ticket_lock_gps.v
## Circular Buffer
-theories/examples/circ_buff/code.v
-theories/examples/circ_buff/code_na.v
-theories/examples/circ_buff/proof_gps.v
+gpfsl/examples/circ_buff/code.v
+gpfsl/examples/circ_buff/code_na.v
+gpfsl/examples/circ_buff/proof_gps.v
## Stack
-theories/examples/stack/spec_na.v
-theories/examples/stack/spec_per_elem.v
-theories/examples/stack/code_na.v
-theories/examples/stack/proof_na.v
-theories/examples/stack/code_treiber.v
-theories/examples/stack/proof_treiber_gps.v
+gpfsl/examples/stack/spec_na.v
+gpfsl/examples/stack/spec_per_elem.v
+gpfsl/examples/stack/code_na.v
+gpfsl/examples/stack/proof_na.v
+gpfsl/examples/stack/code_treiber.v
+gpfsl/examples/stack/proof_treiber_gps.v
## Queue
-theories/examples/queue/spec_per_elem.v
-theories/examples/queue/code_ms.v
-theories/examples/queue/proof_ms_gps.v
+gpfsl/examples/queue/spec_per_elem.v
+gpfsl/examples/queue/code_ms.v
+gpfsl/examples/queue/proof_ms_gps.v
## Chase-Lev Double-ended Queue
-theories/examples/chase_lev/code.v
+gpfsl/examples/chase_lev/code.v
diff --git a/coq-gpfsl.opam b/coq-gpfsl.opam
index f6862143fd02831ecfaf565b7a0162615926e824..4056a457a33a02bae10d475700bebfc263331b29 100644
--- a/coq-gpfsl.opam
+++ b/coq-gpfsl.opam
@@ -10,9 +10,9 @@ version: "dev"
synopsis: "A combination of GPS and FSL in the promising semantics WITHOUT promises"
depends: [
- "coq-iris" { (= "dev.2022-08-10.1.b06a6961") | (= "dev") }
- "coq-orc11" { (= "dev.2022-08-05.0.c8ba00f9") | (= "dev") }
+ "coq-iris" { (= "dev.2022-08-11.5.b6b4b694") | (= "dev") }
+ "coq-orc11" {= version}
]
-build: [make "-j%{jobs}%"]
-install: [make "install"]
+build: ["./make-package" "gpfsl" "-j%{jobs}%"]
+install: ["./make-package" "gpfsl" "install"]
diff --git a/coq-orc11.opam b/coq-orc11.opam
new file mode 100644
index 0000000000000000000000000000000000000000..6d1846d9c41554b37b83d86b322cd274d1f660e1
--- /dev/null
+++ b/coq-orc11.opam
@@ -0,0 +1,18 @@
+opam-version: "2.0"
+maintainer: "Hoang-Hai Dang <haidang@mpi-sws.org>"
+authors: "The ORC11 semantics team"
+license: "BSD-3-Clause"
+homepage: "https://gitlab.mpi-sws.org/iris/orc11"
+bug-reports: "https://gitlab.mpi-sws.org/iris/orc11/issues"
+dev-repo: "git+https://gitlab.mpi-sws.org/iris/orc11.git"
+version: "dev"
+
+synopsis: "A Coq formalization of the ORC11 semantics for weak memory"
+
+depends: [
+ "coq" { (>= "8.13.0" & < "8.16~") | (= "dev") }
+ "coq-stdpp" { (= "dev.2022-08-11.4.409da1f6") | (= "dev") }
+]
+
+build: ["./make-package" "orc11" "-j%{jobs}%"]
+install: ["./make-package" "orc11" "install"]
diff --git a/theories/algebra/lat_auth.v b/gpfsl/algebra/lat_auth.v
similarity index 100%
rename from theories/algebra/lat_auth.v
rename to gpfsl/algebra/lat_auth.v
diff --git a/theories/algebra/lattice_cmra.v b/gpfsl/algebra/lattice_cmra.v
similarity index 100%
rename from theories/algebra/lattice_cmra.v
rename to gpfsl/algebra/lattice_cmra.v
diff --git a/theories/algebra/to_agree.v b/gpfsl/algebra/to_agree.v
similarity index 100%
rename from theories/algebra/to_agree.v
rename to gpfsl/algebra/to_agree.v
diff --git a/theories/base_logic/adequacy.v b/gpfsl/base_logic/adequacy.v
similarity index 100%
rename from theories/base_logic/adequacy.v
rename to gpfsl/base_logic/adequacy.v
diff --git a/theories/base_logic/base_lifting.v b/gpfsl/base_logic/base_lifting.v
similarity index 100%
rename from theories/base_logic/base_lifting.v
rename to gpfsl/base_logic/base_lifting.v
diff --git a/theories/base_logic/bi.v b/gpfsl/base_logic/bi.v
similarity index 100%
rename from theories/base_logic/bi.v
rename to gpfsl/base_logic/bi.v
diff --git a/theories/base_logic/frame_instances.v b/gpfsl/base_logic/frame_instances.v
similarity index 100%
rename from theories/base_logic/frame_instances.v
rename to gpfsl/base_logic/frame_instances.v
diff --git a/theories/base_logic/history.v b/gpfsl/base_logic/history.v
similarity index 100%
rename from theories/base_logic/history.v
rename to gpfsl/base_logic/history.v
diff --git a/theories/base_logic/history_cmra.v b/gpfsl/base_logic/history_cmra.v
similarity index 100%
rename from theories/base_logic/history_cmra.v
rename to gpfsl/base_logic/history_cmra.v
diff --git a/theories/base_logic/iwp.v b/gpfsl/base_logic/iwp.v
similarity index 100%
rename from theories/base_logic/iwp.v
rename to gpfsl/base_logic/iwp.v
diff --git a/theories/base_logic/local_preds.v b/gpfsl/base_logic/local_preds.v
similarity index 100%
rename from theories/base_logic/local_preds.v
rename to gpfsl/base_logic/local_preds.v
diff --git a/theories/base_logic/memory.v b/gpfsl/base_logic/memory.v
similarity index 100%
rename from theories/base_logic/memory.v
rename to gpfsl/base_logic/memory.v
diff --git a/theories/base_logic/meta_data.v b/gpfsl/base_logic/meta_data.v
similarity index 100%
rename from theories/base_logic/meta_data.v
rename to gpfsl/base_logic/meta_data.v
diff --git a/theories/base_logic/na.v b/gpfsl/base_logic/na.v
similarity index 100%
rename from theories/base_logic/na.v
rename to gpfsl/base_logic/na.v
diff --git a/theories/base_logic/vprop.v b/gpfsl/base_logic/vprop.v
similarity index 100%
rename from theories/base_logic/vprop.v
rename to gpfsl/base_logic/vprop.v
diff --git a/theories/base_logic/weakestpre.v b/gpfsl/base_logic/weakestpre.v
similarity index 100%
rename from theories/base_logic/weakestpre.v
rename to gpfsl/base_logic/weakestpre.v
diff --git a/theories/examples/chase_lev/code.v b/gpfsl/examples/chase_lev/code.v
similarity index 100%
rename from theories/examples/chase_lev/code.v
rename to gpfsl/examples/chase_lev/code.v
diff --git a/theories/examples/circ_buff/code.v b/gpfsl/examples/circ_buff/code.v
similarity index 100%
rename from theories/examples/circ_buff/code.v
rename to gpfsl/examples/circ_buff/code.v
diff --git a/theories/examples/circ_buff/code_na.v b/gpfsl/examples/circ_buff/code_na.v
similarity index 100%
rename from theories/examples/circ_buff/code_na.v
rename to gpfsl/examples/circ_buff/code_na.v
diff --git a/theories/examples/circ_buff/proof_gps.v b/gpfsl/examples/circ_buff/proof_gps.v
similarity index 100%
rename from theories/examples/circ_buff/proof_gps.v
rename to gpfsl/examples/circ_buff/proof_gps.v
diff --git a/theories/examples/lock/code_ticket_lock.v b/gpfsl/examples/lock/code_ticket_lock.v
similarity index 100%
rename from theories/examples/lock/code_ticket_lock.v
rename to gpfsl/examples/lock/code_ticket_lock.v
diff --git a/theories/examples/lock/proof_ticket_lock_gps.v b/gpfsl/examples/lock/proof_ticket_lock_gps.v
similarity index 100%
rename from theories/examples/lock/proof_ticket_lock_gps.v
rename to gpfsl/examples/lock/proof_ticket_lock_gps.v
diff --git a/theories/examples/map_seq.v b/gpfsl/examples/map_seq.v
similarity index 100%
rename from theories/examples/map_seq.v
rename to gpfsl/examples/map_seq.v
diff --git a/theories/examples/mp/code.v b/gpfsl/examples/mp/code.v
similarity index 100%
rename from theories/examples/mp/code.v
rename to gpfsl/examples/mp/code.v
diff --git a/theories/examples/mp/proof_gen_inv.v b/gpfsl/examples/mp/proof_gen_inv.v
similarity index 100%
rename from theories/examples/mp/proof_gen_inv.v
rename to gpfsl/examples/mp/proof_gen_inv.v
diff --git a/theories/examples/mp/proof_gps.v b/gpfsl/examples/mp/proof_gps.v
similarity index 100%
rename from theories/examples/mp/proof_gps.v
rename to gpfsl/examples/mp/proof_gps.v
diff --git a/theories/examples/mp/proof_reclaim_gps.v b/gpfsl/examples/mp/proof_reclaim_gps.v
similarity index 100%
rename from theories/examples/mp/proof_reclaim_gps.v
rename to gpfsl/examples/mp/proof_reclaim_gps.v
diff --git a/theories/examples/mp/spec.v b/gpfsl/examples/mp/spec.v
similarity index 100%
rename from theories/examples/mp/spec.v
rename to gpfsl/examples/mp/spec.v
diff --git a/theories/examples/nat_tokens.v b/gpfsl/examples/nat_tokens.v
similarity index 100%
rename from theories/examples/nat_tokens.v
rename to gpfsl/examples/nat_tokens.v
diff --git a/theories/examples/queue/code_ms.v b/gpfsl/examples/queue/code_ms.v
similarity index 100%
rename from theories/examples/queue/code_ms.v
rename to gpfsl/examples/queue/code_ms.v
diff --git a/theories/examples/queue/proof_ms_gps.v b/gpfsl/examples/queue/proof_ms_gps.v
similarity index 100%
rename from theories/examples/queue/proof_ms_gps.v
rename to gpfsl/examples/queue/proof_ms_gps.v
diff --git a/theories/examples/queue/spec_per_elem.v b/gpfsl/examples/queue/spec_per_elem.v
similarity index 100%
rename from theories/examples/queue/spec_per_elem.v
rename to gpfsl/examples/queue/spec_per_elem.v
diff --git a/theories/examples/stack/code_na.v b/gpfsl/examples/stack/code_na.v
similarity index 100%
rename from theories/examples/stack/code_na.v
rename to gpfsl/examples/stack/code_na.v
diff --git a/theories/examples/stack/code_treiber.v b/gpfsl/examples/stack/code_treiber.v
similarity index 100%
rename from theories/examples/stack/code_treiber.v
rename to gpfsl/examples/stack/code_treiber.v
diff --git a/theories/examples/stack/proof_na.v b/gpfsl/examples/stack/proof_na.v
similarity index 100%
rename from theories/examples/stack/proof_na.v
rename to gpfsl/examples/stack/proof_na.v
diff --git a/theories/examples/stack/proof_treiber_gps.v b/gpfsl/examples/stack/proof_treiber_gps.v
similarity index 100%
rename from theories/examples/stack/proof_treiber_gps.v
rename to gpfsl/examples/stack/proof_treiber_gps.v
diff --git a/theories/examples/stack/spec_na.v b/gpfsl/examples/stack/spec_na.v
similarity index 100%
rename from theories/examples/stack/spec_na.v
rename to gpfsl/examples/stack/spec_na.v
diff --git a/theories/examples/stack/spec_per_elem.v b/gpfsl/examples/stack/spec_per_elem.v
similarity index 100%
rename from theories/examples/stack/spec_per_elem.v
rename to gpfsl/examples/stack/spec_per_elem.v
diff --git a/theories/examples/uniq_token.v b/gpfsl/examples/uniq_token.v
similarity index 100%
rename from theories/examples/uniq_token.v
rename to gpfsl/examples/uniq_token.v
diff --git a/theories/gps/block_ends.v b/gpfsl/gps/block_ends.v
similarity index 100%
rename from theories/gps/block_ends.v
rename to gpfsl/gps/block_ends.v
diff --git a/theories/gps/cbends.v b/gpfsl/gps/cbends.v
similarity index 100%
rename from theories/gps/cbends.v
rename to gpfsl/gps/cbends.v
diff --git a/theories/gps/cmras.v b/gpfsl/gps/cmras.v
similarity index 100%
rename from theories/gps/cmras.v
rename to gpfsl/gps/cmras.v
diff --git a/theories/gps/escrows.v b/gpfsl/gps/escrows.v
similarity index 100%
rename from theories/gps/escrows.v
rename to gpfsl/gps/escrows.v
diff --git a/theories/gps/middleware.v b/gpfsl/gps/middleware.v
similarity index 100%
rename from theories/gps/middleware.v
rename to gpfsl/gps/middleware.v
diff --git a/theories/gps/middleware_PP.v b/gpfsl/gps/middleware_PP.v
similarity index 100%
rename from theories/gps/middleware_PP.v
rename to gpfsl/gps/middleware_PP.v
diff --git a/theories/gps/middleware_SW.v b/gpfsl/gps/middleware_SW.v
similarity index 100%
rename from theories/gps/middleware_SW.v
rename to gpfsl/gps/middleware_SW.v
diff --git a/theories/gps/model.v b/gpfsl/gps/model.v
similarity index 100%
rename from theories/gps/model.v
rename to gpfsl/gps/model.v
diff --git a/theories/gps/model_defs.v b/gpfsl/gps/model_defs.v
similarity index 100%
rename from theories/gps/model_defs.v
rename to gpfsl/gps/model_defs.v
diff --git a/theories/gps/model_rules_cas.v b/gpfsl/gps/model_rules_cas.v
similarity index 100%
rename from theories/gps/model_rules_cas.v
rename to gpfsl/gps/model_rules_cas.v
diff --git a/theories/gps/model_rules_dealloc.v b/gpfsl/gps/model_rules_dealloc.v
similarity index 100%
rename from theories/gps/model_rules_dealloc.v
rename to gpfsl/gps/model_rules_dealloc.v
diff --git a/theories/gps/model_rules_init.v b/gpfsl/gps/model_rules_init.v
similarity index 100%
rename from theories/gps/model_rules_init.v
rename to gpfsl/gps/model_rules_init.v
diff --git a/theories/gps/model_rules_read.v b/gpfsl/gps/model_rules_read.v
similarity index 100%
rename from theories/gps/model_rules_read.v
rename to gpfsl/gps/model_rules_read.v
diff --git a/theories/gps/model_rules_write.v b/gpfsl/gps/model_rules_write.v
similarity index 100%
rename from theories/gps/model_rules_write.v
rename to gpfsl/gps/model_rules_write.v
diff --git a/theories/gps/protocols.v b/gpfsl/gps/protocols.v
similarity index 100%
rename from theories/gps/protocols.v
rename to gpfsl/gps/protocols.v
diff --git a/theories/gps/surface.v b/gpfsl/gps/surface.v
similarity index 100%
rename from theories/gps/surface.v
rename to gpfsl/gps/surface.v
diff --git a/theories/gps/surface_iPP.v b/gpfsl/gps/surface_iPP.v
similarity index 100%
rename from theories/gps/surface_iPP.v
rename to gpfsl/gps/surface_iPP.v
diff --git a/theories/gps/surface_iSP.v b/gpfsl/gps/surface_iSP.v
similarity index 100%
rename from theories/gps/surface_iSP.v
rename to gpfsl/gps/surface_iSP.v
diff --git a/theories/gps/surface_vSP.v b/gpfsl/gps/surface_vSP.v
similarity index 100%
rename from theories/gps/surface_vSP.v
rename to gpfsl/gps/surface_vSP.v
diff --git a/theories/lang/lang.v b/gpfsl/lang/lang.v
similarity index 100%
rename from theories/lang/lang.v
rename to gpfsl/lang/lang.v
diff --git a/theories/lang/notation.v b/gpfsl/lang/notation.v
similarity index 100%
rename from theories/lang/notation.v
rename to gpfsl/lang/notation.v
diff --git a/theories/lang/tactics.v b/gpfsl/lang/tactics.v
similarity index 100%
rename from theories/lang/tactics.v
rename to gpfsl/lang/tactics.v
diff --git a/theories/logic/arith.v b/gpfsl/logic/arith.v
similarity index 100%
rename from theories/logic/arith.v
rename to gpfsl/logic/arith.v
diff --git a/theories/logic/atomic_cmra.v b/gpfsl/logic/atomic_cmra.v
similarity index 100%
rename from theories/logic/atomic_cmra.v
rename to gpfsl/logic/atomic_cmra.v
diff --git a/theories/logic/atomic_exchange.v b/gpfsl/logic/atomic_exchange.v
similarity index 100%
rename from theories/logic/atomic_exchange.v
rename to gpfsl/logic/atomic_exchange.v
diff --git a/theories/logic/atomic_ghost.v b/gpfsl/logic/atomic_ghost.v
similarity index 100%
rename from theories/logic/atomic_ghost.v
rename to gpfsl/logic/atomic_ghost.v
diff --git a/theories/logic/atomic_ops.v b/gpfsl/logic/atomic_ops.v
similarity index 100%
rename from theories/logic/atomic_ops.v
rename to gpfsl/logic/atomic_ops.v
diff --git a/theories/logic/atomic_ops_vj.v b/gpfsl/logic/atomic_ops_vj.v
similarity index 100%
rename from theories/logic/atomic_ops_vj.v
rename to gpfsl/logic/atomic_ops_vj.v
diff --git a/theories/logic/atomic_preds.v b/gpfsl/logic/atomic_preds.v
similarity index 100%
rename from theories/logic/atomic_preds.v
rename to gpfsl/logic/atomic_preds.v
diff --git a/theories/logic/atomic_update.v b/gpfsl/logic/atomic_update.v
similarity index 100%
rename from theories/logic/atomic_update.v
rename to gpfsl/logic/atomic_update.v
diff --git a/theories/logic/atomics.v b/gpfsl/logic/atomics.v
similarity index 100%
rename from theories/logic/atomics.v
rename to gpfsl/logic/atomics.v
diff --git a/theories/logic/diverge.v b/gpfsl/logic/diverge.v
similarity index 100%
rename from theories/logic/diverge.v
rename to gpfsl/logic/diverge.v
diff --git a/theories/logic/for_loop.v b/gpfsl/logic/for_loop.v
similarity index 100%
rename from theories/logic/for_loop.v
rename to gpfsl/logic/for_loop.v
diff --git a/theories/logic/invariants.v b/gpfsl/logic/invariants.v
similarity index 100%
rename from theories/logic/invariants.v
rename to gpfsl/logic/invariants.v
diff --git a/theories/logic/lifting.v b/gpfsl/logic/lifting.v
similarity index 100%
rename from theories/logic/lifting.v
rename to gpfsl/logic/lifting.v
diff --git a/theories/logic/logatom.v b/gpfsl/logic/logatom.v
similarity index 100%
rename from theories/logic/logatom.v
rename to gpfsl/logic/logatom.v
diff --git a/theories/logic/na_invariants.v b/gpfsl/logic/na_invariants.v
similarity index 100%
rename from theories/logic/na_invariants.v
rename to gpfsl/logic/na_invariants.v
diff --git a/theories/logic/new_delete.v b/gpfsl/logic/new_delete.v
similarity index 100%
rename from theories/logic/new_delete.v
rename to gpfsl/logic/new_delete.v
diff --git a/theories/logic/proofmode.v b/gpfsl/logic/proofmode.v
similarity index 100%
rename from theories/logic/proofmode.v
rename to gpfsl/logic/proofmode.v
diff --git a/theories/logic/relacq.v b/gpfsl/logic/relacq.v
similarity index 100%
rename from theories/logic/relacq.v
rename to gpfsl/logic/relacq.v
diff --git a/theories/logic/repeat_loop.v b/gpfsl/logic/repeat_loop.v
similarity index 100%
rename from theories/logic/repeat_loop.v
rename to gpfsl/logic/repeat_loop.v
diff --git a/theories/logic/sc_invariants.v b/gpfsl/logic/sc_invariants.v
similarity index 100%
rename from theories/logic/sc_invariants.v
rename to gpfsl/logic/sc_invariants.v
diff --git a/theories/logic/subj_invariants.v b/gpfsl/logic/subj_invariants.v
similarity index 100%
rename from theories/logic/subj_invariants.v
rename to gpfsl/logic/subj_invariants.v
diff --git a/theories/logic/view_invariants.v b/gpfsl/logic/view_invariants.v
similarity index 100%
rename from theories/logic/view_invariants.v
rename to gpfsl/logic/view_invariants.v
diff --git a/make-package b/make-package
new file mode 100755
index 0000000000000000000000000000000000000000..55c051a9f6b9b3d25936782b46e6b55dc35fa4ab
--- /dev/null
+++ b/make-package
@@ -0,0 +1,32 @@
+#!/bin/bash
+set -e
+# Helper script to build and/or install just one package out of this repository.
+# Assumes that all the other packages it depends on have been installed already!
+
+PROJECT="$1"
+shift
+
+COQFILE="_CoqProject.$PROJECT"
+MAKEFILE="Makefile.package.$PROJECT"
+
+if ! egrep -q "^$PROJECT/" _CoqProject; then
+ echo "No files in $PROJECT/ found in _CoqProject; this does not seem to be a valid project name."
+ exit 1
+fi
+
+# Generate _CoqProject file and Makefile
+rm -f "$COQFILE"
+# Get the right "-Q" line.
+egrep "^-Q $PROJECT[ /]" _CoqProject >> "$COQFILE"
+# Get everything until the first empty line except for the "-Q" lines.
+sed -n '/./!q;p' _CoqProject | egrep -v "^-Q " >> "$COQFILE"
+# Get the files.
+egrep "^$PROJECT/" _CoqProject >> "$COQFILE"
+# Now we can run coq_makefile.
+"${COQBIN}coq_makefile" -f "$COQFILE" -o "$MAKEFILE"
+
+# Run build
+make -f "$MAKEFILE" "$@"
+
+# Cleanup
+rm -f ".$MAKEFILE.d" "$MAKEFILE"*
diff --git a/orc11/base.v b/orc11/base.v
new file mode 100644
index 0000000000000000000000000000000000000000..d8160061b196e7b646d9b40820f8f1cce90fa8e3
--- /dev/null
+++ b/orc11/base.v
@@ -0,0 +1,874 @@
+From Coq Require Export Utf8 ssreflect.
+From stdpp Require Export prelude finite gmap.
+From stdpp Require Import sorting.
+
+Global Open Scope general_if_scope.
+Global Set SsrOldRewriteGoalsOrder. (* See https://github.com/coq/coq/issues/5706 *)
+Ltac done := stdpp.tactics.done.
+
+Require Import stdpp.options.
+
+Section gmap_top.
+
+Context `{Countable K} {A : Type}
+ (R: relation K)
+ `{∀ x y, Decision (R x y)} `{!PartialOrder R} `{!Total R}.
+
+Implicit Type (m: gmap K A).
+
+Definition gmap_top m : option (K * A) :=
+ let tlst := merge_sort R (elements (dom m)) in
+ match tlst with
+ | nil => None
+ | head :: _ =>
+ match m !! head with
+ | None => None
+ | Some a => Some (head, a)
+ end
+ end.
+
+Lemma gmap_top_lookup k a m:
+ gmap_top m = Some (k,a) → m !! k = Some a.
+Proof.
+ rewrite /gmap_top. case_match; first done. case_match; last done.
+ inversion 1. by subst.
+Qed.
+
+Lemma gmap_top_top k a m:
+ gmap_top m = Some (k,a)
+ → ∀ k', k' ∈ (dom m) → R k k'.
+Proof using All.
+ rewrite /gmap_top. destruct (merge_sort R (elements (dom m))) eqn: Heql; first done.
+ case_match; last done.
+ inversion 1. subst. move => k' In.
+ assert (Hk': k' ∈ k :: l).
+ { by rewrite -Heql merge_sort_Permutation elem_of_elements. }
+ move : Hk' => /elem_of_cons [-> //|Hk'].
+ assert (HS:= StronglySorted_merge_sort R (elements (dom m))).
+ rewrite Heql in HS. inversion HS as [|a' l' HA FA].
+ subst. rewrite -> Forall_forall in FA. by apply FA.
+Qed.
+
+Lemma gmap_top_inv k a m:
+ m !! k = Some a
+ → (∀ k', k' ∈ (dom m) → R k k')
+ → gmap_top m = Some (k,a).
+Proof using All.
+ rewrite /gmap_top => In TOP.
+ assert (IS: is_Some (m !! k)) by (eexists; eauto).
+ destruct merge_sort as [|head ?] eqn: EQ.
+ - exfalso. apply (elem_of_dom (D:=gset K)) in IS. move:IS.
+ rewrite -elem_of_elements. rewrite <-(merge_sort_Permutation R).
+ by rewrite EQ elem_of_nil.
+ - assert (head ∈ dom m) as InD.
+ { rewrite -elem_of_elements. rewrite <-(merge_sort_Permutation R).
+ rewrite EQ elem_of_cons. by left. }
+ destruct (m !! head) eqn:Heqo.
+ + have Eqt: head = k.
+ { apply (anti_symm R); last by apply TOP.
+ assert (HS:= StronglySorted_merge_sort R (elements (dom m))).
+ inversion HS as [Eq|a' l' HA FA Eq]; rewrite -Eq in EQ;
+ [done|inversion EQ; subst].
+ rewrite -> Forall_forall in FA.
+ have Hk': k ∈ head :: l.
+ { rewrite Eq merge_sort_Permutation elem_of_elements.
+ by apply elem_of_dom. }
+ move : Hk' => /elem_of_cons [-> //|Hk']. by apply FA. }
+ rewrite Eqt In in Heqo. inversion Heqo. by subst.
+ + move : InD => /elem_of_dom [?]. by rewrite Heqo.
+Qed.
+
+Lemma gmap_top_equiv k a m:
+ gmap_top m = Some (k,a) ↔ (m !! k = Some a ∧ (∀ k', k' ∈ (dom m) → R k k')).
+Proof using All.
+ split.
+ - move => ?. split; [by apply gmap_top_lookup|by eapply gmap_top_top].
+ - move => [? ?]. by apply gmap_top_inv.
+Qed.
+
+Lemma gmap_top_nonempty m (NEMP: m ≠∅) :
+ ∃ k a, gmap_top m = Some (k, a).
+Proof.
+ rewrite /gmap_top.
+ destruct merge_sort as [|head ?] eqn: EQ.
+ - exfalso. apply NEMP, (dom_empty_iff (D:=gset K)) => k.
+ rewrite -elem_of_elements. rewrite <-(merge_sort_Permutation R).
+ by rewrite EQ elem_of_nil.
+ - assert (is_Some (m !! head)) as [a Eqa].
+ { apply (elem_of_dom (D:=gset K)). rewrite -elem_of_elements.
+ rewrite <-(merge_sort_Permutation R). rewrite EQ. by left. }
+ exists head, a. by rewrite Eqa.
+Qed.
+
+Lemma gmap_top_nonempty_2 k a m (Eq: m !! k = Some a) :
+ ∃ k' a', gmap_top m = Some (k', a').
+Proof. apply gmap_top_nonempty => EqE. by rewrite EqE lookup_empty in Eq. Qed.
+
+Lemma gmap_top_nonempty_inv k a m :
+ gmap_top m = Some (k, a) → m ≠∅.
+Proof. move => /gmap_top_lookup Eq ?. subst. by rewrite lookup_empty in Eq. Qed.
+
+Lemma gmap_top_empty : gmap_top ∅ = None.
+Proof. by rewrite /gmap_top dom_empty_L elements_empty /=. Qed.
+
+Lemma gmap_top_singleton k a : gmap_top {[k := a]} = Some (k,a).
+Proof.
+ rewrite /gmap_top.
+ rewrite (_: elements (dom {[k := a]}) = [k]);
+ last by rewrite dom_singleton_L elements_singleton.
+ by rewrite /= lookup_insert.
+Qed.
+
+Lemma gmap_top_insert_eq m k a a' (CH: gmap_top m = Some (k, a)):
+ gmap_top (<[k := a']> m) = Some (k, a').
+Proof using All.
+ apply gmap_top_inv; eauto; first by rewrite lookup_insert.
+ move => k'. rewrite dom_insert subseteq_union_1.
+ - by eapply gmap_top_top.
+ - rewrite -elem_of_subseteq_singleton elem_of_dom.
+ apply gmap_top_lookup in CH. by eexists.
+Qed.
+
+Lemma gmap_top_insert_ne_old m k a k' a'
+ (CH: gmap_top m = Some (k,a))
+ (NEQ: k' ≠k)
+ (LE: R k k'):
+ gmap_top (<[k' := a']> m) = Some (k, a).
+Proof using All.
+ apply gmap_top_inv; eauto.
+ - rewrite lookup_insert_ne; last done. by eapply gmap_top_lookup.
+ - move => k0. rewrite dom_insert elem_of_union elem_of_singleton => [[-> //|]].
+ by eapply gmap_top_top.
+Qed.
+
+Lemma gmap_top_insert_new m k a k' a'
+ (CH: gmap_top m = Some (k,a))
+ (LE: R k' k):
+ gmap_top (<[k' := a']> m) = Some (k', a').
+Proof using All.
+ apply gmap_top_inv; eauto; first by rewrite lookup_insert.
+ move => k0. rewrite dom_insert elem_of_union elem_of_singleton => [[-> //|]].
+ move => InD. etrans; [exact LE| by eapply gmap_top_top].
+Qed.
+
+Lemma gmap_top_insert_new_2 m k a
+ (TOP: ∀ k', k' ∈ (dom m) → R k k'):
+ gmap_top (<[k := a]> m) = Some (k, a).
+Proof using All.
+ apply gmap_top_inv; eauto; first by rewrite lookup_insert.
+ move => k'. rewrite dom_insert elem_of_union elem_of_singleton => [[-> //|]].
+ by apply TOP.
+Qed.
+End gmap_top.
+
+(** Wellformedness *)
+
+Class Wellformed A := Wf : A → Prop.
+Existing Class Wf.
+Global Hint Mode Wellformed ! : typeclass_instances.
+
+Class WellformedPreserving `{Wellformed A} `{Wellformed B} (R : A → B → Prop) := {
+ wf_pre_proper a b : R a b → Wf a → Wf b;
+}.
+
+Global Hint Extern 100 (Wf ?b) =>
+ match goal with
+ | H : _ ?a b |- _ => apply (wf_pre_proper a b H)
+ end : typeclass_instances.
+
+Global Instance option_wf `{Wellformed A} : Wellformed (option A) :=
+ from_option Wf True.
+
+(** SqSubsetEq, Join and Meet notations **)
+
+Infix "⊑*" := (Forall2 (⊑)) (at level 70) : stdpp_scope.
+Notation "(⊑*)" := (Forall2 (⊑)) (only parsing) : stdpp_scope.
+Infix "⊑**" := (Forall2 (⊑*)) (at level 70) : stdpp_scope.
+Infix "⊑1*" := (Forall2 (λ p q, p.1 ⊑ q.1)) (at level 70) : stdpp_scope.
+Infix "⊑2*" := (Forall2 (λ p q, p.2 ⊑ q.2)) (at level 70) : stdpp_scope.
+Infix "⊑1**" := (Forall2 (λ p q, p.1 ⊑* q.1)) (at level 70) : stdpp_scope.
+Infix "⊑2**" := (Forall2 (λ p q, p.2 ⊑* q.2)) (at level 70) : stdpp_scope.
+
+Infix "âŠ" := (strict sqsubseteq) (at level 70) : stdpp_scope.
+Notation "(âŠ)" := (strict sqsubseteq) (only parsing) : stdpp_scope.
+Notation "( X âŠ)" := (sqsubseteq X) (only parsing) : stdpp_scope.
+Notation "(⊠X )" := (λ Y, Y ⊠X) (only parsing) : stdpp_scope.
+Infix "âŠ*" := (Forall2 (âŠ)) (at level 70) : stdpp_scope.
+Notation "(âŠ*)" := (Forall2 (âŠ)) (only parsing) : stdpp_scope.
+Infix "âŠ**" := (Forall2 (âŠ*)) (at level 70) : stdpp_scope.
+Infix "âŠ1*" := (Forall2 (λ p q, p.1 ⊠q.1)) (at level 70) : stdpp_scope.
+Infix "âŠ2*" := (Forall2 (λ p q, p.2 ⊠q.2)) (at level 70) : stdpp_scope.
+Infix "âŠ1**" := (Forall2 (λ p q, p.1 âŠ* q.1)) (at level 70) : stdpp_scope.
+Infix "âŠ2**" := (Forall2 (λ p q, p.2 âŠ* q.2)) (at level 70) : stdpp_scope.
+Global Instance Strict_sqsubseteq_Rewrite `{SqSubsetEq T} : @RewriteRelation T (âŠ) := {}.
+
+Infix "⊔*" := (zip_with (⊔)) (at level 50, left associativity) : stdpp_scope.
+Notation "(⊔*)" := (zip_with (⊔)) (only parsing) : stdpp_scope.
+Infix "⊔**" := (zip_with (zip_with (⊔)))
+ (at level 50, left associativity) : stdpp_scope.
+Infix "⊔*⊔**" := (zip_with (prod_zip (⊔) (⊔*)))
+ (at level 50, left associativity) : stdpp_scope.
+
+Infix "⊓*" := (zip_with (⊓)) (at level 40, left associativity) : stdpp_scope.
+Notation "(⊓*)" := (zip_with (⊓)) (only parsing) : stdpp_scope.
+Infix "⊓**" := (zip_with (zip_with (⊓)))
+ (at level 40, left associativity) : stdpp_scope.
+Infix "⊓*⊓**" := (zip_with (prod_zip (⊓) (⊓*)))
+ (at level 40, left associativity) : stdpp_scope.
+
+(* Lattice canonical structure *)
+Structure latticeT : Type := Make_Lat {
+ lat_ty :> Type;
+ lat_equiv : Equiv lat_ty;
+ lat_sqsubseteq : SqSubsetEq lat_ty;
+ #[canonical=no]
+ lat_join : Join lat_ty;
+ #[canonical=no]
+ lat_meet : Meet lat_ty;
+
+ #[canonical=no]
+ lat_inhabited : Inhabited lat_ty;
+ #[canonical=no]
+ lat_sqsubseteq_proper : Proper ((≡) ==> (≡) ==> iff) (⊑);
+ #[canonical=no]
+ lat_join_proper : Proper ((≡) ==> (≡) ==> (≡)) (⊔);
+ #[canonical=no]
+ lat_meet_proper : Proper ((≡) ==> (≡) ==> (≡)) (⊓);
+ #[canonical=no]
+ lat_equiv_equivalence : Equivalence (≡);
+ #[canonical=no]
+ lat_pre_order : PreOrder (⊑@{lat_ty});
+ #[canonical=no]
+ lat_sqsubseteq_antisym : AntiSymm (≡) (⊑);
+ #[canonical=no]
+ lat_join_sqsubseteq_l (X Y : lat_ty) : X ⊑ X ⊔ Y;
+ #[canonical=no]
+ lat_join_sqsubseteq_r (X Y : lat_ty) : Y ⊑ X ⊔ Y;
+ #[canonical=no]
+ lat_join_lub (X Y Z : lat_ty) : X ⊑ Z → Y ⊑ Z → X ⊔ Y ⊑ Z;
+ #[canonical=no]
+ lat_meet_sqsubseteq_l (X Y : lat_ty) : X ⊓ Y ⊑ X;
+ #[canonical=no]
+ lat_meet_sqsubseteq_r (X Y : lat_ty) : X ⊓ Y ⊑ Y;
+ #[canonical=no]
+ lat_meet_glb (X Y Z : lat_ty) : X ⊑ Y → X ⊑ Z → X ⊑ Y ⊓ Z
+}.
+Arguments lat_equiv : simpl never.
+Arguments lat_sqsubseteq : simpl never.
+Arguments lat_join : simpl never.
+Arguments lat_join_sqsubseteq_l {_} _ _.
+Arguments lat_join_sqsubseteq_r {_} _ _.
+Arguments lat_join_lub {_} _ _ _.
+Arguments lat_meet : simpl never.
+Arguments lat_meet_sqsubseteq_l {_} _ _.
+Arguments lat_meet_sqsubseteq_r {_} _ _.
+Arguments lat_meet_glb {_} _ _ _.
+Global Existing Instances lat_equiv lat_sqsubseteq lat_join lat_meet
+ lat_inhabited lat_sqsubseteq_proper lat_sqsubseteq_antisym
+ lat_join_proper lat_meet_proper lat_equiv_equivalence lat_pre_order.
+
+Lemma lat_join_sqsubseteq_or (Lat : latticeT) (X Y Z : Lat) :
+ Z ⊑ X ∨ Z ⊑ Y → Z ⊑ X ⊔ Y.
+Proof.
+ intros [H|H]; (etrans; [apply H|]);
+ [apply lat_join_sqsubseteq_l|apply lat_join_sqsubseteq_r].
+Qed.
+
+Lemma lat_meet_sqsubseteq_or (Lat : latticeT) (X Y Z : Lat) :
+ X ⊑ Z ∨ Y ⊑ Z → X ⊓ Y ⊑ Z.
+Proof.
+ intros [H|H]; (etrans; [|apply H]);
+ [apply lat_meet_sqsubseteq_l|apply lat_meet_sqsubseteq_r].
+Qed.
+
+Create HintDb lat.
+Ltac solve_lat := by typeclasses eauto with lat core.
+Global Hint Resolve lat_join_lub lat_meet_glb : lat.
+Global Hint Extern 0 (?a ⊑ ?b) =>
+ (* We first check whether a and b are unifiable, in order not to
+ trigger typeclass search for Reflexivity when this is not needed. *)
+ unify a b with lat; reflexivity : lat.
+Global Hint Extern 0 (_ = _) => apply (anti_symm (⊑)) : lat.
+Global Hint Extern 0 (_ ≡ _) => apply (anti_symm (⊑)) : lat.
+Global Hint Resolve lat_join_sqsubseteq_or | 10 : lat.
+Global Hint Resolve lat_meet_sqsubseteq_or | 10 : lat.
+Global Hint Extern 100 (?a ⊑ ?c) =>
+ match goal with H : a ⊑ ?b |- _ => transitivity b; [exact H|] end
+ : lat.
+Global Hint Extern 200 (?a ⊑ ?c) =>
+ match goal with H : ?b ⊑ c |- _ => transitivity b; [|exact H] end
+ : lat.
+
+Section Lat.
+
+Context {Lat : latticeT}.
+
+Global Instance lat_sqsubseteq_order_L `{!LeibnizEquiv Lat} :
+ PartialOrder (A:=Lat) (⊑).
+Proof.
+ split; [apply lat_pre_order|] => x y ??.
+ by apply leibniz_equiv, (anti_symm (⊑)).
+Qed.
+
+Global Instance lat_join_assoc : @Assoc Lat (≡) (⊔).
+Proof. intros ???; solve_lat. Qed.
+Global Instance lat_join_assoc_L `{!LeibnizEquiv Lat} : @Assoc Lat (=) (⊔).
+Proof. intros ???. solve_lat. Qed.
+
+Global Instance lat_join_comm : @Comm Lat Lat (≡) (⊔).
+Proof. intros ??; solve_lat. Qed.
+Global Instance lat_join_comm_L `{!LeibnizEquiv Lat} : @Comm Lat Lat (=) (⊔).
+Proof. intros ??; solve_lat. Qed.
+
+Global Instance lat_join_mono : Proper ((⊑) ==> (⊑) ==> (⊑)) (@join Lat _).
+Proof. intros ?????. solve_lat. Qed.
+Global Instance lat_join_mono_flip :
+ Proper (flip (⊑) ==> flip (⊑) ==> flip (⊑)) (@join Lat _).
+Proof. solve_proper. Qed.
+
+Lemma lat_le_join_l (x y : Lat) : y ⊑ x → x ⊔ y ≡ x.
+Proof. solve_lat. Qed.
+Lemma lat_le_join_l_L `{!LeibnizEquiv Lat} (x y : Lat) : y ⊑ x → x ⊔ y = x.
+Proof. solve_lat. Qed.
+
+Lemma lat_le_join_r (x y : Lat) : x ⊑ y → x ⊔ y ≡ y.
+Proof. solve_lat. Qed.
+Lemma lat_le_join_r_L `{!LeibnizEquiv Lat} (x y : Lat) : x ⊑ y → x ⊔ y = y.
+Proof. solve_lat. Qed.
+
+Lemma lat_join_idem (x : Lat) : x ⊔ x ≡ x.
+Proof. solve_lat. Qed.
+Lemma lat_join_idem_L `{!LeibnizEquiv Lat} (x : Lat) : x ⊔ x = x.
+Proof. solve_lat. Qed.
+
+Global Instance lat_meet_assoc : @Assoc Lat (≡) (⊓).
+Proof. intros ???; solve_lat. Qed.
+Global Instance lat_meet_assoc_L `{!LeibnizEquiv Lat} : @Assoc Lat (=) (⊓).
+Proof. intros ???. solve_lat. Qed.
+
+Global Instance lat_meet_comm : @Comm Lat Lat (≡) (⊓).
+Proof. intros ??; solve_lat. Qed.
+Global Instance lat_meet_comm_L `{!LeibnizEquiv Lat} : @Comm Lat Lat (=) (⊓).
+Proof. intros ??; solve_lat. Qed.
+
+Global Instance lat_meet_mono : Proper ((⊑) ==> (⊑) ==> (⊑)) (@meet Lat _).
+Proof. intros ?????. solve_lat. Qed.
+Global Instance lat_meet_mono_flip :
+ Proper (flip (⊑) ==> flip (⊑) ==> flip (⊑)) (@meet Lat _).
+Proof. solve_proper. Qed.
+
+Lemma lat_le_meet_l (x y : Lat) : x ⊑ y → x ⊓ y ≡ x.
+Proof. solve_lat. Qed.
+Lemma lat_le_meet_l_L `{!LeibnizEquiv Lat} (x y : Lat) : x ⊑ y → x ⊓ y = x.
+Proof. solve_lat. Qed.
+
+Lemma lat_le_meet_r (x y : Lat) : y ⊑ x → x ⊓ y ≡ y.
+Proof. solve_lat. Qed.
+Lemma lat_le_meet_r_L `{!LeibnizEquiv Lat} (x y : Lat) : y ⊑ x → x ⊓ y = y.
+Proof. solve_lat. Qed.
+
+Lemma lat_meet_idem (x : Lat) : x ⊓ x ≡ x.
+Proof. solve_lat. Qed.
+Lemma lat_meet_idem_L `{!LeibnizEquiv Lat} (x : Lat) : x ⊓ x = x.
+Proof. solve_lat. Qed.
+
+(* Lattices with a bottom element. *)
+Class LatBottom (bot : Lat) :=
+ lat_bottom_sqsubseteq X : bot ⊑ X.
+Hint Resolve lat_bottom_sqsubseteq : lat.
+
+Global Instance lat_join_bottom_rightid `{!LatBottom bot} : RightId (≡) bot (⊔).
+Proof. intros ?; solve_lat. Qed.
+Global Instance lat_join_bottom_rightid_L `{!LeibnizEquiv Lat} `{!LatBottom bot} :
+ RightId (=) bot (⊔).
+Proof. intros ?; solve_lat. Qed.
+
+Global Instance lat_join_bottom_leftid `{!LatBottom bot} : LeftId (≡) bot (⊔).
+Proof. intros ?; solve_lat. Qed.
+Global Instance lat_join_bottom_leftid_L `{!LeibnizEquiv Lat} `{!LatBottom bot} :
+ LeftId (=) bot (⊔).
+Proof. intros ?; solve_lat. Qed.
+
+Global Instance lat_meet_bottom_leftabsorb `{!LatBottom bot} (x : Lat) :
+ LeftAbsorb (≡) bot (⊓).
+Proof. intros ?; solve_lat. Qed.
+Global Instance lat_meet_bottom_leftabsorb_L `{!LeibnizEquiv Lat} `{!LatBottom bot} :
+ LeftAbsorb (=) bot (⊓).
+Proof. intros ?. solve_lat. Qed.
+
+Global Instance lat_meet_bottom_rightabsorb `{!LatBottom bot} (x : Lat) :
+ RightAbsorb (≡) bot (⊓).
+Proof. intros ?; solve_lat. Qed.
+Global Instance lat_meet_bottom_rightabsorb_L `{!LeibnizEquiv Lat} `{!LatBottom bot} :
+ RightAbsorb (=) bot (⊓).
+Proof. intros ?. solve_lat. Qed.
+
+End Lat.
+
+Global Hint Resolve lat_bottom_sqsubseteq : lat.
+
+(** Lattice for product **)
+
+Section Prod.
+
+Context (A B : latticeT).
+
+Program Canonical Structure prod_Lat :=
+ Make_Lat (A * B) prod_equiv (prod_relation (⊑) (⊑))
+ (λ p1 p2, (p1.1 ⊔ p2.1, p1.2 ⊔ p2.2))
+ (λ p1 p2, (p1.1 ⊓ p2.1, p1.2 ⊓ p2.2))
+ _ _ _ _ _ _ _ _ _ _ _ _ _.
+Next Obligation.
+ intros ??[a b]??[c d]. split=>-[??]; split;
+ rewrite -?a -?b // -?c -?d // ?a ?c // ?b ?d //.
+Qed.
+Next Obligation.
+ intros ??[a b]??[c d]. split; rewrite /= ?a ?c // ?b ?d //.
+Qed.
+Next Obligation.
+ intros ??[a b]??[c d]. split; rewrite /= ?a ?c // ?b ?d //.
+Qed.
+Next Obligation.
+ split; [apply: prod_relation_refl | apply: prod_relation_trans].
+Qed.
+Next Obligation. intros ??[??][??]; split; by apply (anti_symm (⊑)). Qed.
+Next Obligation. intros ??. split; solve_lat. Qed.
+Next Obligation. intros ??. split; solve_lat. Qed.
+Next Obligation. intros ??? [??] [??]. by split; solve_lat. Qed.
+Next Obligation. intros ??. split; solve_lat. Qed.
+Next Obligation. intros ??. split; solve_lat. Qed.
+Next Obligation. intros ??? [??] [??]. by split; solve_lat. Qed.
+
+Global Instance prod_sqsubseteq_dec :
+ RelDecision (A:=A) (⊑) → RelDecision (A:=B) (⊑) → RelDecision (A:=A * B) (⊑).
+Proof.
+ move => ?? ab ab'.
+ case: (decide (fst ab ⊑ fst ab'));
+ case: (decide (snd ab ⊑ snd ab'));
+ [left => //|right|right|right]; move => []; abstract naive_solver.
+Qed.
+
+Global Instance prod_latbottom `{!@LatBottom A botA, !@LatBottom B botB} :
+ LatBottom (botA, botB).
+Proof. split; solve_lat. Qed.
+
+Global Instance fst_lat_mono : Proper ((⊑) ==> (⊑)) (@fst A B).
+Proof. move => [??][??][-> _]//. Qed.
+
+Global Instance snd_lat_mono : Proper ((⊑) ==> (⊑)) (@snd A B).
+Proof. move => [??][??][_ ->]//. Qed.
+
+Lemma lat_join_fst x y :
+ fst (x ⊔ y) = fst x ⊔ fst y.
+Proof. done. Qed.
+
+Lemma lat_join_snd x y :
+ snd (x ⊔ y) = snd x ⊔ snd y.
+Proof. done. Qed.
+
+End Prod.
+
+(** Lattice for option. None is the bottom element. **)
+
+Global Instance option_sqsubseteq `{SqSubsetEq A} : SqSubsetEq (option A) :=
+ λ o1 o2, if o1 is Some x1 return _ then
+ if o2 is Some x2 return _ then x1 ⊑ x2 else False
+ else True.
+
+Global Instance option_sqsubseteq_preorder `{SqSubsetEq A} `{!@PreOrder A (⊑)} :
+ @PreOrder (option A) (⊑).
+Proof.
+ split.
+ - move=>[x|] //. apply (@reflexivity A (⊑) _).
+ - move=>[x|] [y|] [z|] //. apply (@transitivity A (⊑) _).
+Qed.
+
+
+Global Instance option_sqsubseteq_po `{SqSubsetEq A} `{!@PartialOrder A (⊑)} :
+ @PartialOrder (option A) (⊑).
+Proof.
+ split; [apply _|].
+ move => [?|] [?|] ??; [|done|done|done]. f_equal. by apply : (anti_symm (⊑)).
+Qed.
+
+Section option.
+
+Context (Lat : latticeT).
+
+Program Canonical Structure option_Lat :=
+ Make_Lat (option Lat) option_equiv option_sqsubseteq
+ (λ o1 o2, if o1 is Some x1 return _ then
+ if o2 is Some x2 return _ then Some (x1 ⊔ x2) else o1
+ else o2)
+ (λ o1 o2, if o1 is Some x1 return _ then
+ if o2 is Some x2 return _ then Some (x1 ⊓ x2) else None
+ else None) _ _ _ _ _ _ _ _ _ _ _ _ _.
+Next Obligation.
+ intros ??[???|]??[???|]; try by split. by apply lat_sqsubseteq_proper.
+Qed.
+Next Obligation.
+ intros ??[?? EQ1|]??[?? EQ2|]=>//; constructor; by setoid_subst.
+Qed.
+Next Obligation.
+ intros ??[?? EQ1|]??[?? EQ2|]=>//; constructor; by setoid_subst.
+Qed.
+Next Obligation. move=>[x|] [y|] //. constructor. solve_lat. Qed.
+Next Obligation. move=>[x|] [y|] //. solve_lat. Qed.
+Next Obligation. move=>[x|] [y|] //. solve_lat. Qed.
+Next Obligation. move=>[x|] [y|] [z|] //. solve_lat. Qed.
+Next Obligation. move=>[x|] [y|] //. solve_lat. Qed.
+Next Obligation. move=>[x|] [y|] //. solve_lat. Qed.
+Next Obligation. move=>[x|] [y|] [z|] //. solve_lat. Qed.
+
+Global Instance option_sqsubseteq_dec :
+ RelDecision (A:=Lat) (⊑) → RelDecision (A:=option Lat) (⊑).
+Proof.
+ move=>DEC [a|][a'|]; unfold Decision; [edestruct (DEC a a')|..]; auto with lat.
+Qed.
+
+Global Instance option_latbottom : LatBottom (@None Lat).
+Proof. done. Qed.
+
+Global Instance option_Total `{!@Total Lat (⊑)}:
+ @Total (option Lat) (⊑).
+Proof.
+ move => [x|] [y|]; (try by right); (try by left). destruct (total (⊑) x y); auto.
+Qed.
+
+Global Instance Some_mono : Proper ((⊑) ==> (⊑)) (@Some Lat).
+Proof. solve_proper. Qed.
+Global Instance Some_mono_flip : Proper (flip (⊑) ==> flip (⊑)) (@Some Lat).
+Proof. solve_proper. Qed.
+
+(* Global Instance fmap_sqsubseteq_mono f : *)
+(* Proper ((⊑) ==> (⊑)) f -> *)
+(* Proper ((⊑) ==> (⊑)) (@fmap option option_fmap Lat (option Lat) f). *)
+(* Proof. *)
+(* move => H. *)
+(* repeat move => ? ? S. rewrite /fmap /option_fmap /option_map. *)
+(* repeat case_match; simplify_option_eq; cbn; [by apply H|destruct S|done|done]. *)
+(* Qed. *)
+
+Lemma fmap_sqsubseteq `{Lat2 : latticeT} (f : Lat -> Lat2) (x y : option Lat) {H : Proper ((⊑) ==> (⊑)) f} :
+ x ⊑ y -> fmap f x ⊑ fmap f y.
+Proof.
+ rewrite /fmap/option_fmap/option_map.
+ repeat case_match; simplify_option_eq; cbn; [by apply H|inversion 1|done|done].
+Qed.
+
+End option.
+
+Global Instance from_option_bot_proper {A: latticeT} `{@LatBottom B bot}
+ (f: A → B) `{!Proper ((⊑) ==> (⊑)) f} :
+ Proper ((⊑) ==> (⊑)) (from_option f bot).
+Proof. move => [?|] [?|] ?; [solve_proper|done..]. Qed.
+
+
+Section Forall2.
+ Context {A} (R : relation A).
+
+ Global Instance option_Forall2_refl : Reflexive R → Reflexive (option_Forall2 R).
+ Proof. intros ? [?|]; by constructor. Qed.
+ Global Instance option_Forall2_sym : Symmetric R → Symmetric (option_Forall2 R).
+ Proof. destruct 2; by constructor. Qed.
+ Global Instance option_Forall2_trans : Transitive R → Transitive (option_Forall2 R).
+ Proof. destruct 2; inversion_clear 1; constructor; etrans; eauto. Qed.
+ Global Instance option_Forall2_equiv : Equivalence R → Equivalence (option_Forall2 R).
+ Proof. destruct 1; split; apply _. Qed.
+End Forall2.
+
+(** Lattice for gmap **)
+
+Section gmap.
+Context K `{Countable K}.
+
+Global Instance gmap_sqsubseteq `{SqSubsetEq A} : SqSubsetEq (gmap K A) :=
+ λ m1 m2, ∀ i, m1 !! i ⊑@{option A} m2 !! i.
+
+Global Instance gmap_sqsubseteq_preorder `{SqSubsetEq A} `{!@PreOrder A (⊑)} :
+ @PreOrder (gmap K A) (⊑).
+Proof. split=>??//? LE1 LE2 ?; etrans; [apply LE1|apply LE2]. Qed.
+
+Global Instance gmap_sqsubseteq_po `{SqSubsetEq A} `{!@PartialOrder A (⊑)} :
+ @PartialOrder (gmap K A) (⊑).
+Proof.
+ constructor; [apply _|].
+ move => ????. apply map_eq => ?. by apply : (anti_symm (⊑)).
+Qed.
+
+Global Instance gmap_key_filter {A} : Filter K (gmap K A) :=
+ λ P _, filter (λ kv, P (kv.1)).
+
+
+Context (A : latticeT).
+
+Program Canonical Structure gmap_Lat :=
+ Make_Lat (gmap K A) map_equiv gmap_sqsubseteq
+ (union_with (λ x1 x2, Some (x1 ⊔ x2)))
+ (intersection_with (λ x1 x2, Some (x1 ⊓ x2)))
+ _ _ _ _ _ _ _ _ _ _ _ _ _.
+Next Obligation. move=> ??? ???; split=>??; setoid_subst=>//. Qed.
+Next Obligation.
+ move=> X1 Y1 EQ1 X2 Y2 EQ2 i. rewrite !lookup_union_with.
+ by destruct (EQ1 i), (EQ2 i); setoid_subst.
+Qed.
+Next Obligation.
+ move=> X1 Y1 EQ1 X2 Y2 EQ2 i. rewrite !lookup_intersection_with.
+ by destruct (EQ1 i), (EQ2 i); setoid_subst.
+Qed.
+Next Obligation.
+ move=>?? LE1 LE2 ?. apply (anti_symm (⊑)); [apply LE1|apply LE2].
+Qed.
+Next Obligation.
+ move=>???. rewrite lookup_union_with.
+ repeat destruct lookup=>//. solve_lat.
+Qed.
+Next Obligation.
+ move=>???. rewrite lookup_union_with.
+ repeat destruct lookup=>//. solve_lat.
+Qed.
+Next Obligation.
+ move=>??? LE1 LE2 i. rewrite lookup_union_with.
+ specialize (LE1 i). specialize (LE2 i).
+ repeat destruct lookup=>//. solve_lat.
+Qed.
+Next Obligation.
+ move=>???. rewrite lookup_intersection_with.
+ repeat destruct lookup=>//. solve_lat.
+Qed.
+Next Obligation.
+ move=>???. rewrite lookup_intersection_with.
+ repeat destruct lookup=>//. solve_lat.
+Qed.
+Next Obligation.
+ move=>??? LE1 LE2 i. rewrite lookup_intersection_with.
+ specialize (LE1 i). specialize (LE2 i).
+ repeat destruct lookup=>//. solve_lat.
+Qed.
+
+Global Instance gmap_bottom : LatBottom (@empty (gmap K A) _).
+Proof. done. Qed.
+
+Global Instance gmap_sqsubseteq_dec :
+ RelDecision (A:=A) (⊑) → RelDecision (A:=gmap K A) (⊑).
+Proof.
+ move => ? m m'.
+ destruct (decide (set_Forall (λ k, m !! k ⊑ m' !! k) (dom m))) as [Y|N].
+ - left => k.
+ case: (decide (k ∈ dom m)).
+ + by move/Y.
+ + move/not_elem_of_dom => -> //.
+ - right.
+ apply not_set_Forall_Exists in N; last apply _.
+ case : N => x [/elem_of_dom [a ?]] NSqsubseteq ?. by apply NSqsubseteq.
+Qed.
+
+Global Instance lookup_mono l :
+ Proper ((⊑) ==> (⊑)) (@lookup K A (gmap K A) _ l).
+Proof. intros ?? Le. apply Le. Qed.
+Global Instance lookup_mono_flip l :
+ Proper (flip (⊑) ==> flip (⊑)) (@lookup K A (gmap K A) _ l).
+Proof. solve_proper. Qed.
+
+Global Instance gmap_sqsubseteq_dom_proper :
+ Proper ((@sqsubseteq (gmap K A) _) ==> (⊆)) (dom).
+Proof.
+ move => m1 m2 Sqsubseteq k /elem_of_dom [a Eqa].
+ specialize (Sqsubseteq k). rewrite Eqa in Sqsubseteq.
+ destruct (m2 !! k) as [|] eqn:Eq2; last done.
+ apply elem_of_dom. by eexists.
+Qed.
+
+Lemma gmap_join_dom_union (m1 m2 : gmap K A):
+ dom (m1 ⊔ m2) ≡@{gset K} dom m1 ∪ dom m2.
+Proof.
+ move => k. rewrite elem_of_union 3!elem_of_dom lookup_union_with /=.
+ case (m1 !! k) => [v1|]; case (m2 !! k) => [v2|] /=; naive_solver.
+Qed.
+
+Lemma gmap_meet_dom_intersection (m1 m2 : gmap K A):
+ dom (m1 ⊓ m2) ≡@{gset K} dom m1 ∩ dom m2.
+Proof.
+ move => k. rewrite elem_of_intersection 3!elem_of_dom lookup_intersection_with /=.
+ case (m1 !! k) => [v1|]; case (m2 !! k) => [v2|] /=; naive_solver.
+Qed.
+
+Lemma lookup_join (m1 m2 : gmap K A) k:
+ (m1 ⊔ m2) !! k = m1 !! k ⊔ m2 !! k.
+Proof. rewrite lookup_union_with. by do 2!case: (_ !! k). Qed.
+
+Lemma lookup_meet (m1 m2 : gmap K A) k:
+ (m1 ⊓ m2) !! k = m1 !! k ⊓ m2 !! k.
+Proof. rewrite lookup_intersection_with. by do 2!case: (_ !! k). Qed.
+
+Global Instance gmap_leibniz_eq :
+ LeibnizEquiv A → LeibnizEquiv (gmap K A).
+Proof. intros. apply map_leibniz. Qed.
+
+End gmap.
+
+Lemma gmap_subseteq_empty `{Countable K} {A} (m : gmap K A) : ∅ ⊆ m.
+Proof. intros ?. rewrite lookup_empty. by case lookup. Qed.
+
+Lemma gset_to_gmap_sqsubseteq `{Countable K} `{SqSubsetEq A}
+ (m1 m2: gset K) (a b: A) (Sub: m1 ⊆ m2) (Ext: a ⊑ b) :
+ gset_to_gmap a m1 ⊑ gset_to_gmap b m2.
+Proof.
+ intros i.
+ destruct (gset_to_gmap a m1 !! i) as [a'|] eqn:Eq; last done.
+ apply lookup_gset_to_gmap_Some in Eq as [In ?]. subst a'.
+ rewrite (_: gset_to_gmap b m2 !! i = Some b).
+ - by apply Ext.
+ - apply lookup_gset_to_gmap_Some. split; last done. by apply Sub.
+Qed.
+
+(** Lattice for positive *)
+Program Canonical Structure pos_Lat :=
+ Make_Lat (positive) (=) (≤)%positive
+ (λ (p q : positive), if (decide (p ≤ q)%positive) then q else p)
+ (λ (p q : positive), if (decide (p ≤ q)%positive) then p else q)
+ _ _ _ _ _ _ _ _ _ _ _ _ _.
+Next Obligation. move=>x y ??. erewrite Pos.le_antisym; eauto. Qed.
+Next Obligation. move=>x y. unfold join. destruct decide=>//. Qed.
+Next Obligation.
+ move=> x y. unfold join. destruct decide => //. apply Pos.le_nlt. lia.
+Qed.
+Next Obligation. move=>x y z. unfold join; destruct decide=>?? //. Qed.
+Next Obligation.
+ move=>x y. unfold meet. destruct decide => //. apply Pos.le_nlt. lia.
+Qed.
+Next Obligation. move=>x y. unfold meet. destruct decide=>//. Qed.
+Next Obligation. move=>x y z. unfold meet; destruct decide=>?? //. Qed.
+
+Global Instance pos_leibnizequiv : LeibnizEquiv positive := λ _ _ H, H.
+
+Global Instance pos_Total : Total (@sqsubseteq positive _).
+Proof.
+ move => x y. case: (decide (x ≤ y)%positive); first tauto.
+ move => /Pos.lt_nle /Pos.lt_le_incl. tauto.
+Qed.
+
+Global Instance pos_sqsubseteq_decision : RelDecision (@sqsubseteq positive _).
+Proof. intros ??. apply _. Qed.
+
+(** Lattice for nat *)
+Program Canonical Structure nat_Lat :=
+ Make_Lat (nat) (=) (≤)%nat max min
+ _ _ _ _ _ _ _
+ Max.le_max_l Max.le_max_r Max.max_lub Min.le_min_l Min.le_min_r _.
+Next Obligation. intros. by apply Min.min_glb. Qed.
+Global Instance nat_leibnizequiv : LeibnizEquiv nat := λ _ _ H, H.
+
+Global Instance nat_Total : Total (@sqsubseteq nat _).
+Proof. intros ??. by apply Nat.le_ge_cases. Qed.
+Global Instance nat_sqsubseteq_decision : RelDecision (@sqsubseteq nat _).
+Proof. intros ??. apply _. Qed.
+
+(** Lattice for Z *)
+Program Canonical Structure Z_Lat :=
+ Make_Lat (Z) (=) (≤)%Z Z.max Z.min
+ _ _ _ _ _ _ _
+ Z.le_max_l Z.le_max_r Z.max_lub Z.le_min_l Z.le_min_r _.
+Next Obligation. intros. by apply Z.min_glb. Qed.
+Global Instance Z_leibnizequiv : LeibnizEquiv Z := λ _ _ H, H.
+
+Global Instance Z_Total : Total (@sqsubseteq Z _).
+Proof. intros ??. by apply Z.le_ge_cases. Qed.
+Global Instance Z_sqsubseteq_decision : RelDecision (@sqsubseteq Z _).
+Proof. intros ??. apply _. Qed.
+
+(** Lattice for gset *)
+Section gset.
+Context (A: Type) `{Countable A}.
+(* Lattice of sets with subseteq *)
+Program Canonical Structure gset_Lat :=
+ Make_Lat (gset A) (≡) subseteq union intersection
+ _ _ _ _ _ _ _ _ _ _ _ _ _.
+Next Obligation. move => ???. by apply union_subseteq_l. Qed.
+Next Obligation. move => ???. by apply union_subseteq_r. Qed.
+Next Obligation. move => ???. by apply union_least. Qed.
+Next Obligation. move => ???. by apply intersection_subseteq_l. Qed.
+Next Obligation. move => ???. by apply intersection_subseteq_r. Qed.
+Next Obligation. move => ??????. by apply intersection_greatest. Qed.
+
+Global Instance gset_Lat_bot : LatBottom (∅ : gset_Lat).
+Proof. done. Qed.
+
+Global Instance gset_sqsubseteq_dec : RelDecision (A:=gset A) (⊑) := _.
+End gset.
+
+(* We restrict these to semilattices to avoid divergence. *)
+Global Instance flip_total {A : latticeT} :
+ @Total A (⊑) → @Total A (flip (⊑)).
+Proof. move=>Ht x y. destruct (Ht y x); auto. Qed.
+Global Instance flip_sqsubseteq_antisymm {A : latticeT} :
+ @AntiSymm A (≡) (⊑) → @AntiSymm A (≡) (flip (⊑)).
+Proof. move=>?????. by apply (anti_symm (⊑)). Qed.
+Global Instance flip_sqsubseteq_antisymm_L {A : latticeT} :
+ @AntiSymm A (=) (⊑) → @AntiSymm A (=) (flip (⊑)).
+Proof. move=>?????. by apply (anti_symm (⊑)). Qed.
+Global Instance flip_partialorder {A : latticeT} :
+ @PartialOrder A (⊑) → @PartialOrder A (flip (⊑)).
+Proof. move=>?. constructor; apply _. Qed.
+
+Infix "∋" := (flip elem_of) (at level 70) : stdpp_scope.
+Notation "(∋)" := (flip elem_of) (only parsing) : stdpp_scope.
+Notation "( X ∋)" := ((flip elem_of) X) (only parsing) : stdpp_scope.
+Notation "(∋ x )" := (λ X, X ∋ x) (only parsing) : stdpp_scope.
+Notation "X ∌ x" := (¬X ∋ x) (at level 80) : stdpp_scope.
+Notation "(∌)" := (λ X x, X ∌ x) (only parsing) : stdpp_scope.
+Notation "( X ∌)" := (λ x, X ∌ x) (only parsing) : stdpp_scope.
+Notation "(∌ x )" := (λ X, X ∌ x) (only parsing) : stdpp_scope.
+
+(*
+Section IsoLat.
+Context (A : latticeT) (B: Type)
+ (fA: lat_ty A → B) (gB: B → lat_ty A) (ISO: ∀ x, gB (fA x) ≡ x).
+
+Program Canonical Structure iso_Lat :=
+ Make_Lat B
+ (λ b1 b2, gB b1 ≡ gB b2)
+ (λ b1 b2, gB b1 ⊑ gB b2)
+ (λ b1 b2, fA (gB b1 ⊔ gB b2))
+ (λ b1 b2, fA (gB b1 ⊓ gB b2))
+ (populate (fA inhabitant)) _ _ _ _ _ _ _ _ _ _ _ _.
+Next Obligation. solve_proper. Qed.
+Next Obligation. move => ??????. rewrite {1}/join {2}/join {1}/equiv 2!ISO. solve_proper. Qed.
+Next Obligation. move => ??????. rewrite {1}/meet {2}/meet {1}/equiv 2!ISO. solve_proper. Qed.
+Next Obligation. constructor.
+ - move => ?. by rewrite {1}/equiv.
+ - move => ??. by rewrite {1}/equiv {2}/equiv.
+ - move => ???. rewrite {1}/equiv {2}/equiv {3}/equiv => -> //.
+Qed.
+Next Obligation. constructor.
+ - move => ?. by rewrite {1}/sqsubseteq.
+ - move => ???. rewrite {1}/sqsubseteq {2}/sqsubseteq {3}/sqsubseteq => -> //.
+Qed.
+Next Obligation. move => ????. rewrite {1}/equiv. by apply : anti_symm. Qed.
+Next Obligation. move => ??. rewrite {1}/join {1}/sqsubseteq ISO. solve_lat. Qed.
+Next Obligation. move => ??. rewrite {1}/join {1}/sqsubseteq ISO. solve_lat. Qed.
+Next Obligation.
+ move => ???. rewrite {1}/join {1}/sqsubseteq {2}/sqsubseteq {3}/sqsubseteq ISO.
+ solve_lat.
+Qed.
+Next Obligation. move => ??. rewrite {1}/meet {1}/sqsubseteq ISO. solve_lat. Qed.
+Next Obligation. move => ??. rewrite {1}/meet {1}/sqsubseteq ISO. solve_lat. Qed.
+Next Obligation.
+ move => ???. rewrite {1}/meet {1}/sqsubseteq {2}/sqsubseteq {3}/sqsubseteq ISO.
+ solve_lat.
+Qed.
+
+Global Instance iso_Lat_sqsubseteq_dec :
+ RelDecision (A:=A) (⊑) → RelDecision (A:=iso_Lat) (⊑).
+Proof.
+ move => ? m m'. rewrite {1}/sqsubseteq /lat_sqsubseteq /=. apply _.
+Qed.
+
+Global Instance iso_Lat_leibniz_eq `{INJ: Inj _ _ (=) (=) gB} :
+ LeibnizEquiv A → LeibnizEquiv iso_Lat.
+Proof.
+ move => ???. rewrite {1}/equiv /lat_equiv /=.
+ move => /leibniz_equiv_iff /INJ //.
+Qed.
+
+End IsoLat. *)
diff --git a/orc11/event.v b/orc11/event.v
new file mode 100644
index 0000000000000000000000000000000000000000..16b546e4241510ea00bcfc0eb84ab38517d408a4
--- /dev/null
+++ b/orc11/event.v
@@ -0,0 +1,26 @@
+From orc11 Require Export value mem_order.
+
+Require Import stdpp.options.
+
+Record sysEvent := mkSysEvent {
+ output: Z;
+ inputs: list Z;
+ }.
+
+Section Event.
+ Context {loc: Type} `{Countable VAL}.
+
+ Inductive event :=
+ | Silent
+ | Alloc (l : loc) (n: positive)
+ | Dealloc (l : loc) (n : positive)
+ | Read (l: loc) (v: val (VAL:=VAL)) (o: memOrder)
+ | Write (l: loc) (v: VAL) (o: memOrder)
+ | Update (l: loc) (vr vw: VAL) (or ow: memOrder)
+ | Fence (or ow: memOrder)
+ | SysCall (sevt: sysEvent)
+ .
+
+End Event.
+
+Arguments event loc VAL : clear implicits.
diff --git a/orc11/location.v b/orc11/location.v
new file mode 100644
index 0000000000000000000000000000000000000000..db96584957eb129600080421fef625c0ba945e47
--- /dev/null
+++ b/orc11/location.v
@@ -0,0 +1,222 @@
+From stdpp Require Import sorting.
+From orc11 Require Export base.
+
+Require Import stdpp.options.
+
+(** Classes for locations *)
+
+Class LocFacts (loc: Type) := {
+ loc_inhab :> Inhabited loc;
+ loc_eqdec :> EqDecision loc;
+ loc_count :> Countable loc;
+}.
+(* The next line is commented out to avoid TC divergence in lambda-rust-weak. *)
+(* Hint Mode LocFacts ! : typeclass_instances. *)
+
+Class Shift (loc: Type) := {
+ shift : loc → nat → loc;
+ shift_nat_inj l (n1 n2: nat) : shift l n1 = shift l n2 → n1 = n2;
+ shift_nat_assoc l (n1 n2: nat) : shift (shift l n1) n2 = shift l (n1 + n2);
+ shift_0 l : shift l 0 = l;
+}.
+Global Hint Mode Shift ! : typeclass_instances.
+
+Infix ">>" := shift (at level 50, left associativity) : stdpp_scope.
+Notation "(>>)" := shift (only parsing) : stdpp_scope.
+Notation "( l >>)" := (shift l) (only parsing) : stdpp_scope.
+Arguments shift : simpl never.
+
+Class StateFacts (loc state: Type) `{!LocFacts loc} := {
+ state_dom :> Dom state (gset loc);
+ state_wf :> Wellformed state;
+ state_dealloc : state → gset loc;
+ state_dealloc_sub σ : state_dealloc σ ⊆ dom σ;
+}.
+Arguments StateFacts _ _ {_}.
+(* Hint Mode StateFacts ! ! : typeclass_instances. *)
+
+Class Allocator (loc state: Type)
+ `{!LocFacts loc} `{!StateFacts loc state} `{!Shift loc} := {
+ alloc : state → nat → loc → Prop;
+ dealloc : state → nat → loc → Prop;
+ alloc_add_fresh σ l n:
+ alloc σ n l
+ → ∀ (n' : nat), n' < n → l >> n' ∉ dom σ;
+ dealloc_remove σ l n :
+ dealloc σ n l
+ → ∀ (n' : nat), n' < n →
+ l >> n' ∈ (dom σ ∖ state_dealloc σ);
+}.
+Arguments Allocator _ _ {_ _ _}.
+
+Arguments alloc {_ _ _ _ _ _}.
+Arguments dealloc {_ _ _ _ _ _}.
+Arguments alloc_add_fresh {_ _ _ _ _ _}.
+Arguments dealloc_remove {_ _ _ _ _ _}.
+
+
+(** Locations as positives *)
+
+Global Instance pos_loc : LocFacts positive.
+Proof. esplit; apply _. Qed.
+
+Global Program Instance pos_loc_shift : Shift positive
+ := {| shift := λ p z, Z.to_pos (Zpos p + Z.of_nat z) |}.
+Next Obligation. move => l n1 n2 H. apply Z2Pos.inj in H; lia. Defined.
+Next Obligation. intros. simpl. f_equal. rewrite Z2Pos.id; lia. Defined.
+Next Obligation. done. Defined.
+
+Global Instance pos_ge_transitive : Transitive Pos.ge.
+Proof.
+ move => ???/Pos.ge_le? /Pos.ge_le?. apply Pos.le_ge. by etrans.
+Qed.
+
+Global Instance pos_ge_total : Total Pos.ge.
+Proof.
+ move => x y.
+ case (decide (x ≤ y)%positive) => [?|].
+ - right. by apply Pos.le_ge.
+ - rewrite <- Pos.lt_nle. left. by apply Pos.le_ge, Pos.lt_le_incl.
+Qed.
+
+Section LocPos.
+ Context `{!StateFacts positive state}.
+
+ Implicit Types (σ : state) (l : positive).
+
+ Inductive pos_alloc (σ : state) n l : Prop :=
+ | PosAlloc
+ (NONEMPTY: 0 < n)
+ (NEW: ∀ n', n' < n → l >> n' ∉ dom σ)
+ : pos_alloc σ n l.
+
+ Inductive pos_dealloc (σ: state)
+ : nat → positive → Prop :=
+ | PosDealloc l (ALLOC: l ∈ (dom σ ∖ state_dealloc σ))
+ : pos_dealloc σ 1%nat l.
+
+ Definition fresh_pos σ :=
+ let loclst := merge_sort (Pos.ge) (elements (dom σ)) in
+ match loclst with
+ | nil => 1%positive
+ | max :: _ => Pos.succ max
+ end.
+
+ Lemma fresh_pos_max σ l (In : l ∈ dom σ) :
+ (l < fresh_pos σ)%positive.
+ Proof.
+ rewrite /fresh_pos.
+ assert (InL: l ∈ merge_sort Pos.ge (elements (dom σ))).
+ { by rewrite (merge_sort_Permutation Pos.ge (elements _)) elem_of_elements. }
+ destruct (merge_sort (Pos.ge) (elements (dom σ))) as [|max L] eqn:HEq.
+ - by apply elem_of_nil in InL.
+ - apply elem_of_cons in InL as [?|InL]; first by (subst max; lia).
+ assert (HS := StronglySorted_merge_sort Pos.ge (elements (dom σ))).
+ rewrite HEq in HS.
+ inversion HS as [|?? SS FA]. subst.
+ rewrite -> Forall_forall in FA. apply FA in InL.
+ apply Pos.ge_le in InL. by apply Pos.lt_succ_r.
+ Qed.
+
+ Lemma is_fresh_pos_block σ (n : nat) :
+ fresh_pos σ >> n ∉ dom σ.
+ Proof.
+ assert (LE: (fresh_pos σ ≤ fresh_pos σ >> n)%positive).
+ { rewrite /shift /pos_loc_shift /=. destruct n; simpl; [done|lia]. }
+ move => /fresh_pos_max. lia.
+ Qed.
+
+ Lemma pos_alloc_fresh n σ:
+ let l := fresh_pos σ in
+ 0 < n → pos_alloc σ n l.
+ Proof.
+ intros l Hn. constructor; first by assumption. intros.
+ by apply is_fresh_pos_block.
+ Qed.
+
+ Global Program Instance pos_allocator : Allocator positive state :=
+ {| alloc := pos_alloc;
+ dealloc := pos_dealloc; |}.
+ Next Obligation. intros ??? ALL. inversion ALL. by apply NEW. Qed.
+ Next Obligation.
+ intros ??? DEL ? Lt. inversion DEL. subst. apply Nat.lt_1_r in Lt. subst.
+ by apply ALLOC.
+ Qed.
+End LocPos.
+
+(** Locations as blocks *)
+
+Definition block := positive.
+Definition lblock : Type := block * Z.
+
+Global Instance lblock_loc : LocFacts lblock.
+Proof. esplit; apply _. Qed.
+
+Global Program Instance lblock_shift : Shift lblock :=
+ {| shift := λ b z, (b.1, (b.2 + Z.of_nat z)%Z) |}.
+Next Obligation. move => ???. inversion 1. lia. Defined.
+Next Obligation. intros. simpl. f_equal. lia. Defined.
+Next Obligation. intros []. f_equal. simpl. lia. Defined.
+
+Implicit Type (l : lblock).
+Lemma shift_lblock_assoc l n n':
+ (l >> n) >> n' = l >> (n+n').
+Proof. rewrite /shift /lblock_shift /=. f_equal. lia. Qed.
+
+Lemma shift_lblock_0 l : l >> 0 = l.
+Proof. apply shift_0. Qed.
+
+Global Instance shift_lblock_inj l : Inj (=) (=) (l >>).
+Proof. destruct l as [b o]; intros n n' [=?]; lia. Qed.
+
+Lemma shift_lblock l n : (l >> n).1 = l.1.
+Proof. done. Qed.
+
+Section LocBlock.
+ Context `{!StateFacts lblock state}.
+
+ Implicit Types (σ : state).
+
+ Inductive lblock_alloc σ n l : Prop :=
+ | LBlockAlloc
+ (NONEMPTY: 0 < n)
+ (MAX: ∀ n', (l.1, n') ∉ dom σ)
+ : lblock_alloc σ n l.
+
+ Inductive lblock_dealloc σ n l : Prop :=
+ | LBlockDealloc
+ (NONEMPTY: 0 < n)
+ (ALLOC: ∀ n': nat, (n' < n)%nat → l >> n' ∈ (dom σ ∖ state_dealloc σ))
+ (SIZE: ∀ n': nat, l >> n' ∈ dom σ ↔ (n' < n)%nat)
+ : lblock_dealloc σ n l.
+
+ Definition fresh_block (σ : state) : block :=
+ let loclst : list lblock := elements (dom σ) in
+ let blockset : gset block := foldr (λ l, ({[l.1]} ∪.)) ∅ loclst in
+ fresh blockset.
+
+ Lemma is_fresh_block σ i : (fresh_block σ,i) ∉ dom σ.
+ Proof.
+ assert (∀ l ls (X : gset block),
+ l ∈ ls → l.1 ∈ foldr (λ l, ({[l.1]} ∪.)) X ls) as help.
+ { induction 1; set_solver. }
+ rewrite /fresh_block /shift /= -elem_of_elements.
+ move=> /(help _ _ ∅) /=. apply is_fresh.
+ Qed.
+
+ Lemma lblock_alloc_fresh n σ:
+ let l := (fresh_block σ, 0%Z) in
+ 0 < n →
+ lblock_alloc σ n l.
+ Proof.
+ intros l Hn. constructor; [by assumption|].
+ intros i. apply (is_fresh_block _ i).
+ Qed.
+
+
+ Global Program Instance lblock_allocator : Allocator lblock state :=
+ {| alloc := lblock_alloc;
+ dealloc := lblock_dealloc; |}.
+ Next Obligation. intros ??? Hl ??. inversion Hl. by apply MAX. Qed.
+ Next Obligation. intros ??? Hl ??. inversion Hl. by apply ALLOC. Qed.
+End LocBlock.
diff --git a/orc11/mem_order.v b/orc11/mem_order.v
new file mode 100644
index 0000000000000000000000000000000000000000..9cf20a5613db33ddaf65c9ce6d3ba79546c97e03
--- /dev/null
+++ b/orc11/mem_order.v
@@ -0,0 +1,52 @@
+From orc11 Require Export base.
+
+Require Import stdpp.options.
+
+Inductive memOrder := | NonAtomic | Relaxed | AcqRel | SeqCst .
+
+Definition memOrder_le : relation memOrder :=
+ λ o1 o2,
+ match o1, o2 with
+ | NonAtomic, _ => True
+ | _, NonAtomic => False
+
+ | Relaxed, _ => True
+ | _, Relaxed => False
+
+ | AcqRel, _ => True
+ | _, AcqRel => False
+
+ | SeqCst, SeqCst => True
+ end.
+
+Global Instance memOrder_dec : EqDecision memOrder.
+Proof. solve_decision. Defined.
+
+Global Instance memOrder_countable : Countable memOrder.
+Proof.
+ refine(inj_countable'
+ (λ v, match v with
+ | NonAtomic => 0 | Relaxed => 1 | AcqRel => 2 | SeqCst => 3
+ end)
+ (λ x, match x with
+ | 0 => NonAtomic | 1 => Relaxed | 2 => AcqRel | _ => SeqCst
+ end) _); by intros [].
+Qed.
+
+Global Instance memOrder_le_dec : RelDecision memOrder_le.
+Proof. move => [] []; firstorder. Defined.
+
+Program Canonical Structure memOrder_Lat :=
+ Make_Lat memOrder (=) memOrder_le
+ (λ o1 o2, if (decide (memOrder_le o1 o2)) then o2 else o1)
+ (λ o1 o2, if (decide (memOrder_le o1 o2)) then o1 else o2)
+ _ _ _ _ _ _ _ _ _ _ _ _ _.
+Next Obligation. repeat constructor. Qed.
+Next Obligation. split; [move=>[]//|move=>[][]//[]//]. Qed.
+Next Obligation. move=>[][]//. Qed.
+Next Obligation. move=>[][]//. Qed.
+Next Obligation. move=>[][]//. Qed.
+Next Obligation. move=>[][][]//. Qed.
+Next Obligation. move=>[][]//. Qed.
+Next Obligation. move=>[][]//. Qed.
+Next Obligation. move=>[][][]//. Qed.
diff --git a/orc11/memory.v b/orc11/memory.v
new file mode 100644
index 0000000000000000000000000000000000000000..e5e825353234a6c3918622e2d180480500383f45
--- /dev/null
+++ b/orc11/memory.v
@@ -0,0 +1,1873 @@
+From stdpp Require Export gmap finite tactics sorting.
+From orc11 Require Export view value.
+
+Require Import stdpp.options.
+
+Section Memory.
+
+ Context `{!LocFacts loc} `{CVAL: Countable VAL}.
+
+ Notation val := (@val VAL).
+ Notation view := (@view loc _).
+ Implicit Types (V: view).
+
+ (** Base messages do not have loc and to fields *)
+ Record baseMessage :=
+ mkBMes { mval : val;
+ mrel : option view; }.
+
+ Global Instance baseMessage_inhabited: Inhabited baseMessage
+ := populate (mkBMes AVal None).
+ Definition _bMsg_to_tuple (m : baseMessage) : _
+ := (mval m, mrel m).
+ Definition _tuple_to_bMsg (m : _) : baseMessage :=
+ match m with
+ | (v, R) => mkBMes v R
+ end.
+
+ Global Instance baseMsg_dec_eq : EqDecision baseMessage.
+ Proof using All. solve_decision. Qed.
+
+ Global Instance baseMsg_countable : Countable baseMessage.
+ Proof. refine (inj_countable _bMsg_to_tuple (Some ∘ _tuple_to_bMsg) _); by intros []. Qed.
+
+ Record baseMessage_le m1 m2 :=
+ mkbMsgSqSubsetEq {
+ bMsg_sqsubseteq_mval : m1.(mval) = m2.(mval) ;
+ bMsg_sqsubseteq_mrel : m1.(mrel) ⊑ m2.(mrel);
+ }.
+
+ Global Instance baseMessage_sqsubseteq : SqSubsetEq baseMessage := baseMessage_le.
+
+ Global Instance baseMessage_sqsubseteq_po :
+ PartialOrder ((⊑) : SqSubsetEq baseMessage).
+ Proof.
+ constructor; [constructor|]; [done|..].
+ - intros [][][] [][]. simpl in *.
+ constructor; [by subst|by etrans].
+ - intros [][] [][]. simpl in *. subst.
+ f_equal. by apply : (anti_symm (⊑)).
+ Qed.
+
+
+ (* ======================================================================== *)
+ (** Cells are containers of messages per location,
+ defined as maps from time to base messages *)
+ Notation cell := (gmap time baseMessage) (only parsing).
+
+ Implicit Types (t: time) (l: loc) (m: baseMessage) (C: cell).
+
+ (* Extension on Cell that ONLY extends views *)
+ (* This is different from the cell extension that adds new messages *)
+ (* Cell le is use to prove that the machine behavior is monotone w.r.t. views *)
+ Definition cell_le C1 C2 :=
+ ∀ (t : time),
+ option_Forall2 (A:=baseMessage) (⊑) (C1 !! t) (C2 !! t).
+ (* We do not declare an SqSubsetEq instance for cells, because it
+ would conflict with the default one from gmap. *)
+
+ Global Instance cell_le_partial_order : PartialOrder cell_le.
+ Proof.
+ constructor; [constructor|].
+ - intros ??. by destruct lookup; constructor.
+ - intros ??? H1 H2 t. specialize (H1 t).
+ destruct (H2 t); inversion_clear H1; constructor. by etrans.
+ - intros ?? H1 H2. apply map_eq=>t.
+ eapply (anti_symm (⊑)); [generalize (H1 t)|generalize (H2 t)];
+ by do 2 case: (_!!t)=>[?|]; inversion 1.
+ Qed.
+
+ Lemma cell_le_non_empty (C1 C2: cell) (LE: cell_le C1 C2): C1 ≠∅ ↔ C2 ≠∅.
+ Proof.
+ split => NE;
+ destruct (map_choose _ NE) as [te [me Eqe]];
+ move : (LE te); rewrite Eqe; inversion 1 as [?? Eq1 Eq2 Eq3|] => EQ; by subst.
+ Qed.
+
+ Lemma cell_le_singleton (C: cell) t m (LE: cell_le {[t := m]} C):
+ ∃ m', C = {[t := m']}.
+ Proof.
+ move : (LE t). rewrite lookup_singleton. inversion 1 as [? m'|]; subst.
+ exists m'. apply map_eq => t'.
+ case (decide (t' = t)) => [->|?].
+ - by rewrite lookup_insert.
+ - move : (LE t'). do 2 (rewrite lookup_insert_ne ; last done).
+ rewrite lookup_empty. by inversion 1.
+ Qed.
+
+ Lemma cell_le_dom (C1 C2: cell) (LE: cell_le C1 C2):
+ dom C1 ≡ dom C2.
+ Proof.
+ move => t. rewrite 2!elem_of_dom. specialize (LE t).
+ split; move => [? Eq]; rewrite Eq in LE; inversion LE; by eexists.
+ Qed.
+
+ (** Cell operations *)
+ (* CELL ADDINS ------------------------------------------------------------ *)
+ Inductive cell_addins to m C: cell → Prop :=
+ CellAddIns (DISJ: C !! to = None) : cell_addins to m C (<[to := m]> C).
+ Lemma lookup_cell_addins_fresh to m C C'
+ (ADD: cell_addins to m C C') :
+ C !! to = None.
+ Proof. by inversion ADD. Qed.
+
+ Lemma lookup_cell_addins_new to m C C' (ADD: cell_addins to m C C') :
+ C' !! to = Some m.
+ Proof. inversion ADD. by rewrite lookup_insert. Qed.
+
+ Lemma lookup_cell_addins_old_eq t t' m C C'
+ (ADD: cell_addins t m C C') (NEq: t ≠t'):
+ C !! t' = C' !! t'.
+ Proof. inversion ADD. by rewrite lookup_insert_ne. Qed.
+
+ Lemma cell_addins_subset t m C C' (ADD: cell_addins t m C C'):
+ C ⊆ C'.
+ Proof.
+ inversion ADD. move => t'.
+ case (decide (t' = t)) => [->|?];
+ [rewrite lookup_insert DISJ //|rewrite lookup_insert_ne //; by case lookup].
+ Qed.
+
+
+ (** Cell deallocation ----------------------------------------------------- *)
+
+ Definition cell_max (C: cell) := gmap_top (flip (⊑)) C.
+
+ Definition cell_min (C: cell) := gmap_top (⊑) C.
+
+ Definition cell_deallocated (C: cell) : Prop :=
+ match cell_max C with
+ | None => False
+ | Some (_,m) => m.(mval) = DVal
+ end.
+
+ Global Instance cell_deallocated_dec: ∀ C, Decision (cell_deallocated C).
+ Proof using All.
+ move => C. rewrite /cell_deallocated. destruct (cell_max C); solve_decision.
+ Qed.
+
+ Lemma cell_deallocated_correct1 C:
+ cell_deallocated C →
+ ∃ (t: time) m,
+ C !! t = Some m
+ ∧ m.(mval) = DVal
+ ∧ ∀ (t': time), t' ∈ (dom C) → (t' ≤ t)%positive.
+ Proof.
+ rewrite /cell_deallocated.
+ destruct (cell_max C) eqn:Heqo; last done.
+ case_match => Eqv.
+ eexists. eexists. repeat split; eauto.
+ - apply (gmap_top_lookup (flip (⊑))). by eauto.
+ - apply (gmap_top_top _ _ _ _ Heqo).
+ Qed.
+
+ Lemma cell_deallocated_correct2 C:
+ (∃ (t: time) m,
+ C !! t = Some m
+ ∧ m.(mval) = DVal
+ ∧ ∀ (t': time), t' ∈ (dom C) → (t' ≤ t)%positive)
+ → cell_deallocated C.
+ Proof.
+ rewrite /cell_deallocated /cell_max.
+ move => [t [m [In [Eq1 Max]]]].
+ by rewrite (gmap_top_inv (flip (⊑)) t m).
+ Qed.
+
+ Lemma cell_deallocated_neg_insert t m C
+ (ALLOC: ¬ cell_deallocated C)
+ (ND: m.(mval) ≠DVal) :
+ ¬ cell_deallocated (<[t := m]> C).
+ Proof.
+ move => /cell_deallocated_correct1 [t' [m' [Eqm' [EqD MAX]]]].
+ move : Eqm'.
+ case (decide (t' = t)) => [Eq|NEq];
+ [subst t'; rewrite lookup_insert|rewrite lookup_insert_ne; last done].
+ - inversion 1. by subst.
+ - move => In. apply ALLOC.
+ apply cell_deallocated_correct2.
+ exists t', m'. repeat split; auto.
+ move => ??. apply MAX. rewrite dom_insert elem_of_union. by right.
+ Qed.
+
+ Lemma cell_deallocated_neg_singleton t m
+ (ND: m.(mval) ≠DVal):
+ ¬ cell_deallocated {[t := m]}.
+ Proof.
+ move => /cell_deallocated_correct1
+ [? [? [/lookup_singleton_Some [_ ?] [? _]]]].
+ by subst.
+ Qed.
+
+ Lemma cell_deallocated_singleton t m
+ (ND: m.(mval) = DVal):
+ cell_deallocated {[t := m]}.
+ Proof.
+ apply cell_deallocated_correct2. exists t, m.
+ rewrite lookup_insert. repeat split; first done.
+ move => t'. by rewrite dom_singleton elem_of_singleton => ->.
+ Qed.
+
+ (** Allocation invariant for cells ---------------------------------------- *)
+ Definition cell_alloc_inv C :=
+ ∀ t m, (C !! t = Some m ∧ m.(mval) = AVal) ↔ cell_min C = Some (t, m).
+
+ Lemma cell_addins_alloc_min t m C C' tm mm
+ (ADD: cell_addins t m C C')
+ (EQ: cell_min C = Some (tm,mm))
+ (Le: (tm ≤ t)%positive):
+ cell_min C' = Some (tm,mm).
+ Proof.
+ inversion_clear ADD.
+ apply (gmap_top_insert_ne_old _ _ _ _ _ _ EQ); last done.
+ move => ?. subst tm.
+ apply gmap_top_lookup in EQ; eauto with typeclass_instances.
+ by rewrite EQ in DISJ.
+ Qed.
+
+ Lemma cell_addins_alloc_min_2 t m C C' tm mm
+ (ADD: cell_addins t m C C')
+ (EQ: cell_min C = Some (tm,mm))
+ (Le: (tm ≤ t)%positive):
+ cell_min C' = cell_min C.
+ Proof.
+ rewrite EQ. apply (cell_addins_alloc_min _ _ _ _ _ _ ADD EQ Le).
+ Qed.
+
+ Lemma cell_addins_alloc_empty t m C'
+ (ADD: cell_addins t m ∅ C') (ISA: m.(mval) = AVal) :
+ cell_alloc_inv C'.
+ Proof.
+ inversion ADD. rewrite insert_empty.
+ move => t' m'. rewrite /cell_min gmap_top_singleton lookup_singleton_Some.
+ naive_solver.
+ Qed.
+
+ Lemma cell_addins_alloc_inv t m C C'
+ (ADD: cell_addins t m C C')
+ (AINV: cell_alloc_inv C)
+ (EQ: ∃ t', is_Some (C !! t') ∧ (t' ≤ t)%positive)
+ (NAV: m.(mval) ≠AVal) :
+ cell_alloc_inv C'.
+ Proof.
+ destruct EQ as [t' [[m' Eqt'] Le']].
+ destruct (gmap_top_nonempty_2 Pos.le _ _ C Eqt') as [tm [mm Eqmm]].
+ have Le: (tm ≤ t)%positive.
+ { etrans; last apply Le'.
+ apply (gmap_top_top _ _ _ _ Eqmm), elem_of_dom. by eexists. }
+ have Eqmm2: cell_min C' = cell_min C
+ by apply (cell_addins_alloc_min_2 _ _ _ _ _ _ ADD Eqmm).
+ move => t0 m0.
+ rewrite Eqmm2 -AINV. inversion ADD. subst.
+ case (decide (t0 = t)) => [Eq|NEq];
+ [rewrite Eq lookup_insert|by rewrite lookup_insert_ne].
+ split; first by move => [[<-] ?]. rewrite DISJ => [[//]].
+ Qed.
+
+
+ Lemma cell_le_alloc_inv_min (C1 C2: cell) (LE: cell_le C1 C2):
+ (∀ t m, C1 !! t = Some m ∧ mval m = AVal → cell_min C1 = Some (t, m)) ↔
+ (∀ t m, C2 !! t = Some m ∧ mval m = AVal → cell_min C2 = Some (t, m)).
+ Proof.
+ have DOM := cell_le_dom _ _ LE.
+ split => AINV t m; specialize (LE t);
+ move => [Eqt Eqv];
+ rewrite /cell_le Eqt in LE; inversion LE as [m1 m2 Le Eq1 Eq2|]; subst;
+ inversion Le as [Eqv2 _]; rewrite Eqv in Eqv2;
+ apply gmap_top_inv; eauto with typeclass_instances.
+ - have MIN : cell_min C1 = Some (t, m1) by apply AINV.
+ move => ?. rewrite -DOM.
+ by apply (gmap_top_top _ _ _ _ MIN).
+ - have MIN : cell_min C2 = Some (t, m2) by apply AINV.
+ move => ?. rewrite DOM.
+ by apply (gmap_top_top _ _ _ _ MIN).
+ Qed.
+
+ Lemma cell_le_alloc_inv (C1 C2: cell) (LE: cell_le C1 C2):
+ cell_alloc_inv C1 ↔ cell_alloc_inv C2.
+ Proof.
+ have DOM := cell_le_dom _ _ LE.
+ split => AINV t m; specialize (LE t);
+ rewrite gmap_top_equiv; split; move => [Eqt Hv]; (split; [done|]);
+ rewrite /cell_le Eqt in LE; inversion LE as [m1 m2 Le Eq1 Eq2|]; subst;
+ inversion Le as [Eqv _].
+ - rewrite Hv in Eqv. move => ?. rewrite -DOM.
+ have MIN : cell_min C1 = Some (t, m1) by apply AINV.
+ by apply (gmap_top_top _ _ _ _ MIN).
+ - rewrite -Eqv.
+ have MIN : cell_min C1 = Some (t, m1).
+ { apply gmap_top_inv; eauto with typeclass_instances.
+ move => ?. rewrite DOM. by apply Hv. }
+ by apply AINV in MIN as [??].
+ - rewrite Hv in Eqv. move => ?. rewrite DOM.
+ have MIN : cell_min C2 = Some (t, m2) by apply AINV.
+ by apply (gmap_top_top _ _ _ _ MIN).
+ - rewrite Eqv.
+ have MIN : cell_min C2 = Some (t, m2).
+ { apply gmap_top_inv; eauto with typeclass_instances.
+ move => ?. rewrite -DOM. by apply Hv. }
+ by apply AINV in MIN as [??].
+ Qed.
+
+
+ (** Deallocation invariant for cells -------------------------------------- *)
+ Definition cell_dealloc_inv C :=
+ ∀ t m, C !! t = Some m → m.(mval) = DVal → cell_max C = Some (t,m).
+
+ Lemma cell_addins_nDVal_dealloc_inv t m C C'
+ (ADD: cell_addins t m C C')
+ (EQ: ∀ t m, C !! t = Some m → m.(mval) ≠DVal)
+ (NDV: m.(mval) ≠DVal) :
+ cell_dealloc_inv C'.
+ Proof.
+ inversion_clear ADD.
+ move => t' m'.
+ case (decide (t' = t)) => [->|NEq];
+ [rewrite lookup_insert|rewrite lookup_insert_ne; last done];
+ [by move => [<-]|by move => /EQ].
+ Qed.
+
+ Lemma cell_addins_dealloc_inv t m C C'
+ (ADD: cell_addins t m C C')
+ (EQ: ∀ t' m', C !! t' = Some m' → m'.(mval) ≠DVal ∧ (t' < t)%positive) :
+ cell_dealloc_inv C'.
+ Proof using All.
+ inversion_clear ADD.
+ move => t0 m0.
+ case (decide (t0 = t)) => [->|NEq];
+ [rewrite lookup_insert|rewrite lookup_insert_ne; last done];
+ [move => [<-] EqD|by move => /EQ []].
+ case (decide (C = ∅)) => [->|NEMP];
+ first by (apply gmap_top_singleton; eauto with typeclass_instances).
+ apply (gmap_top_nonempty (flip (⊑))) in NEMP as [tm [mm Eqmm]].
+ apply (gmap_top_insert_new _ _ _ _ _ _ Eqmm).
+ apply gmap_top_lookup, EQ in Eqmm as [_ Lt]; eauto with typeclass_instances.
+ by apply Pos.lt_le_incl.
+ Qed.
+
+ Lemma cell_le_alloc_inv_max (C1 C2: cell) (LE: cell_le C1 C2):
+ (∀ t m, C1 !! t = Some m ∧ mval m = DVal → cell_max C1 = Some (t, m)) ↔
+ (∀ t m, C2 !! t = Some m ∧ mval m = DVal → cell_max C2 = Some (t, m)).
+ Proof.
+ have DOM := cell_le_dom _ _ LE.
+ split => AINV t m; specialize (LE t);
+ move => [Eqt Eqv];
+ rewrite /cell_le Eqt in LE; inversion LE as [m1 m2 Le Eq1 Eq2|]; subst;
+ inversion Le as [Eqv2 _]; rewrite Eqv in Eqv2;
+ apply gmap_top_inv; eauto with typeclass_instances.
+ - have MIN : cell_max C1 = Some (t, m1) by apply AINV.
+ move => ?. rewrite -DOM.
+ by apply (gmap_top_top _ _ _ _ MIN).
+ - have MIN : cell_max C2 = Some (t, m2) by apply AINV.
+ move => ?. rewrite DOM.
+ by apply (gmap_top_top _ _ _ _ MIN).
+ Qed.
+
+ (* ======================================================================== *)
+ (** Memory are maps from locations to cells.
+ To preserve leibniz equality, however, we represent them as maps from
+ (loc * time) to baseMessage. *)
+ Definition memory := gmap (loc * time) baseMessage.
+
+ Implicit Types (M: memory).
+
+ (** Lookup cells from memory *)
+ Definition memory_cell_lookup (l : loc) (M : memory) : cell :=
+ default ∅ (gmap_curry M !! l).
+ Notation "M !!c l" := (memory_cell_lookup l M) (at level 20) : stdpp_scope.
+
+ Global Instance memory_loc_dom : Dom memory (gset loc) :=
+ λ M, dom (gmap_curry M).
+
+ Lemma memory_lookup_cell M l t :
+ M !! (l,t) = (M !!c l) !! t.
+ Proof.
+ rewrite /memory_cell_lookup -lookup_gmap_curry.
+ case: (gmap_curry M !! l)=>//.
+ Qed.
+
+ Lemma memory_loc_not_elem_of_dom l M :
+ l ∉ dom M ↔ M !!c l = ∅.
+ Proof.
+ rewrite /dom /memory_loc_dom elem_of_dom -eq_None_not_Some map_eq_iff
+ lookup_gmap_curry_None. apply forall_proper=>t.
+ by rewrite memory_lookup_cell lookup_empty.
+ Qed.
+
+ Lemma memory_loc_elem_of_dom l M :
+ l ∈ dom M ↔ M !!c l ≠∅.
+ Proof.
+ rewrite -memory_loc_not_elem_of_dom. split; [by auto|]. by apply dec_stable.
+ Qed.
+
+ (** Insert cells to memory *)
+ Global Instance memory_cell_insert : Insert loc cell memory :=
+ λ l C M, gmap_uncurry (<[l:=C]>(gmap_curry M)).
+
+ Lemma memory_uncurry_lookup_insert l C M (NE: C ≠∅) :
+ gmap_curry (<[l:=C]>M) !! l = Some C.
+ Proof.
+ rewrite /insert /memory_cell_insert /=.
+ rewrite gmap_curry_uncurry_non_empty.
+ - by rewrite lookup_insert.
+ - move => i x.
+ case (decide (i = l)) => [->|?].
+ + by rewrite lookup_insert => [[<-]].
+ + rewrite lookup_insert_ne; last done. by apply gmap_curry_non_empty.
+ Qed.
+
+ Lemma memory_uncurry_lookup_insert_ne l l' C M (NE: l ≠l') (NE2: C ≠∅):
+ gmap_curry (<[l:=C]>M) !! l' = gmap_curry M !! l'.
+ Proof.
+ rewrite /insert /memory_cell_insert /=.
+ rewrite gmap_curry_uncurry_non_empty.
+ - by rewrite lookup_insert_ne.
+ - move => i x.
+ case (decide (i = l)) => [->|?].
+ + by rewrite lookup_insert => [[<-]].
+ + rewrite lookup_insert_ne; last done. by apply gmap_curry_non_empty.
+ Qed.
+
+ Lemma memory_cell_lookup_insert l C M :
+ <[l:=C]>M !!c l = C.
+ Proof.
+ apply map_eq=>t. rewrite -memory_lookup_cell lookup_gmap_uncurry lookup_insert //.
+ Qed.
+
+ Lemma memory_cell_lookup_insert_ne l l' C M :
+ l ≠l' → <[l:=C]>M !!c l' = M !!c l'.
+ Proof.
+ intros Hll'. apply map_eq=>t.
+ rewrite -!memory_lookup_cell lookup_gmap_uncurry lookup_insert_ne //
+ lookup_gmap_curry //.
+ Qed.
+
+ Lemma memory_cell_insert_insert l C C' M:
+ <[l:=C]>(<[l:=C']>M) = <[l:=C]>M.
+ Proof.
+ apply map_eq=> [[l' t]].
+ rewrite !memory_lookup_cell.
+ case (decide (l' = l)) => [->|?];
+ [by rewrite 2!memory_cell_lookup_insert|
+ by do 3 (rewrite memory_cell_lookup_insert_ne; last done)].
+ Qed.
+
+ (** Memory closedness *)
+ Global Instance closed_view : ElemOf view memory := λ V M,
+ ∀ l (t: time), V !!w l = Some t
+ → ∃ m (t' : time), (t ≤ t')%positive ∧ M !! (l,t') = Some m.
+
+ Lemma closed_view_memory_fresh_insert_mono l t m (V: view) M
+ (In: V ∈ M) (FRESH: M !! (l,t) = None) :
+ V ∈ <[l:= <[t:= m]>(M !!c l)]> M.
+ Proof.
+ move => l' t'; setoid_rewrite memory_lookup_cell;
+ (case (decide (l'=l)) => [->|?]); move => Eqt'.
+ - rewrite memory_cell_lookup_insert.
+ apply In in Eqt'.
+ destruct Eqt' as [m' [to' [Eqt' Eql']]].
+ exists m', to'. split; first done.
+ rewrite lookup_insert_ne; first by rewrite -memory_lookup_cell.
+ move => ?. subst to'. by rewrite FRESH in Eql'.
+ - rewrite memory_cell_lookup_insert_ne; last done.
+ setoid_rewrite <- memory_lookup_cell. by apply In.
+ Qed.
+
+ Definition closed_view_opt' (oV: option view) M : Prop :=
+ from_option (.∈ M) True oV.
+
+ Global Instance closed_view_opt : ElemOf (option view) memory := closed_view_opt'.
+
+ Lemma closed_view_memory_None V (M: memory) l
+ (EMPTY: M !!c l = ∅) (CLOSED: V ∈ M) :
+ V !! l = None.
+ Proof.
+ destruct (V !! l) as [t|] eqn:EqV; last done.
+ move/(view_lookup_wp _ _): EqV => EqV.
+ apply CLOSED in EqV as (? & ? & _ & Eq).
+ by rewrite memory_lookup_cell EMPTY in Eq.
+ Qed.
+
+ Definition closed_mem M : Prop :=
+ ∀ l to m, M !! (l,to) = Some m → m.(mrel) ∈ M.
+
+ Lemma join_closed_view V1 V2 M (C1: V1 ∈ M) (C2: V2 ∈ M) :
+ V1 ⊔ V2 ∈ M.
+ Proof.
+ move => l to /(view_lookup_of_wp _ _) [[????] [<-]].
+ rewrite lookup_union_with.
+ move Eq1: (V1 !! l) => [t1|]; move Eq2: (V2 !! l) => [t2|];
+ [move => []; cbn..|done].
+ - rewrite /join /lat_join /=. case_decide; intros; simplify_eq.
+ + by apply C2; simplify_view.
+ + by apply C1; simplify_view.
+ - intros; simplify_eq. by eapply C1; simplify_view.
+ - intros; simplify_eq. by eapply C2; simplify_view.
+ Qed.
+
+ Lemma join_opt_closed_view
+ (V1 V2: option view) M (C1: V1 ∈ M) (C2: V2 ∈ M) :
+ (V1 : option_Lat _) ⊔ V2 ∈ M.
+ Proof. destruct V1, V2; auto. by apply join_closed_view. Qed.
+
+ (** Proper instances *)
+ Global Instance closed_view_downclosed:
+ Proper ((@sqsubseteq view _) ==> (@eq memory) ==> flip impl) (∈).
+ Proof.
+ move => V1 V2 Sqsubseteq M1 M2 -> In l t Eq2.
+ move : Sqsubseteq => /(_ l). move/(view_sqsubseteq _ _ _) => [].
+ rewrite Eq2.
+ move HT2: (V2 !!w l) => [to|]; cbn; last done.
+ cbn => Le.
+ destruct (In _ _ HT2) as [m [to' [Le' Eq]]].
+ exists m, to'. split=>//. etrans; [apply Le|done].
+ Qed.
+
+ Global Instance opt_closed_view_downclosed:
+ Proper ((@sqsubseteq (option view) _) ==> (@eq memory) ==> flip impl) (∈).
+ Proof.
+ move => [?|] [?|] Sqsubseteq ??-> // In.
+ eapply (closed_view_downclosed _ _ Sqsubseteq _ _ eq_refl In).
+ Qed.
+
+ (* Extension on memory that ONLY extends views *)
+ Definition memory_le M1 M2 :=
+ ∀ (l : loc),
+ option_Forall2 (A:=cell) (cell_le) (gmap_curry M1 !! l) (gmap_curry M2 !! l).
+ (* We do not declare an SqSubsetEq instance for memory, because it
+ would conflict with the default one from gmap. *)
+
+ Global Instance memory_le_partial_order : PartialOrder memory_le.
+ Proof.
+ constructor; [constructor|].
+ - intros ??. by destruct lookup; constructor.
+ - intros ??? H1 H2 l. specialize (H1 l).
+ destruct (H2 l); inversion_clear H1; constructor. by etrans.
+ - intros ?? H1 H2. apply map_eq=>-[l t].
+ rewrite -2!lookup_gmap_curry. f_equal.
+ specialize (H1 l). destruct (H2 l); inversion_clear H1; [|done].
+ f_equal. by eapply (anti_symm (cell_le)).
+ Qed.
+
+ Lemma memory_le_insert_mono M1 M2 l C (LE: memory_le M1 M2) (NE: C ≠∅) :
+ memory_le (<[l := C]> M1) (<[l := C]> M2).
+ Proof.
+ move => l'.
+ case (decide (l' = l)) => [->|?].
+ - by do 2 (rewrite memory_uncurry_lookup_insert; last done).
+ - do 2 (rewrite memory_uncurry_lookup_insert_ne; [|done..]). by apply LE.
+ Qed.
+
+ Lemma memory_le_lookup_empty M1 M2 l (LE: memory_le M1 M2):
+ M1 !!c l = ∅ ↔ M2 !!c l = ∅.
+ Proof.
+ rewrite /memory_cell_lookup. specialize (LE l).
+ destruct (gmap_curry M1 !! l) as [C|] eqn:Eq => /=;
+ inversion LE as [? ? NE'|]; last done.
+ apply gmap_curry_non_empty in Eq. split; first done.
+ by apply (cell_le_non_empty _ _ NE') in Eq.
+ Qed.
+
+ Lemma memory_le_lookup_pair M1 M2 l t
+ (LE: memory_le M1 M2) :
+ (M1 !! (l, t) : option baseMessage) ⊑ M2 !! (l, t).
+ Proof.
+ specialize (LE l).
+ rewrite 2!memory_lookup_cell /memory_cell_lookup.
+ destruct (gmap_curry M1 !! l) as [C1|] eqn:Eq1; simpl; last done.
+ inversion LE as [? C2 LE'|]. simpl.
+ specialize (LE' t). by inversion LE'.
+ Qed.
+
+ Lemma memory_le_lookup_pair_2 M1 M2 l t
+ (LE: memory_le M1 M2) :
+ option_Forall2 (⊑) (M1 !! (l, t) : option baseMessage) (M2 !! (l, t)).
+ Proof.
+ specialize (LE l).
+ rewrite 2!memory_lookup_cell /memory_cell_lookup.
+ destruct (gmap_curry M1 !! l) as [C1|] eqn:Eq1;
+ destruct (gmap_curry M2 !! l) as [C2|] eqn:Eq2; simpl;
+ by inversion LE.
+ Qed.
+
+ Lemma memory_le_closed_timenap M1 M2 V
+ (LE: memory_le M1 M2):
+ V ∈ M1 ↔ V ∈ M2.
+ Proof.
+ split; move => IN l t /IN [m [t' [Le Eq]]];
+ have Le2 := memory_le_lookup_pair_2 _ _ l t' LE;
+ rewrite Eq in Le2; inversion Le2; subst;
+ by do 2 eexists.
+ Qed.
+
+ Lemma memory_le_cell_lookup M1 M2 :
+ memory_le M1 M2 ↔
+ ∀ l, cell_le (default ∅ (gmap_curry M1 !! l))
+ (default ∅ (gmap_curry M2 !! l)).
+ Proof.
+ split => LE; move => l; specialize (LE l).
+ - destruct (gmap_curry M1 !! l) as [C1|]; by inversion LE.
+ - destruct (gmap_curry M1 !! l) as [C1|] eqn:EqC1.
+ + apply gmap_curry_non_empty in EqC1. simpl in LE.
+ destruct (gmap_curry M2 !! l) as [C2|] eqn:EqC2; first by constructor.
+ exfalso. by apply (cell_le_non_empty _ _ LE) in EqC1.
+ + destruct (gmap_curry M2 !! l) as [C2|] eqn:EqC2; last by constructor.
+ apply gmap_curry_non_empty in EqC2.
+ exfalso. by apply (cell_le_non_empty _ _ LE) in EqC2.
+ Qed.
+
+
+ Lemma memory_cell_lookup_non_empty M l:
+ M !!c l ≠∅ ↔ is_Some (gmap_curry M !! l).
+ Proof.
+ rewrite /memory_cell_lookup.
+ destruct (gmap_curry M !! l) as [?|] eqn:Eq; rewrite /= is_Some_alt; [|done].
+ by apply gmap_curry_non_empty in Eq.
+ Qed.
+
+ Lemma memory_cell_lookup_empty M l:
+ M !!c l = ∅ ↔ l ∉ dom M.
+ Proof.
+ rewrite /memory_cell_lookup (not_elem_of_dom (D:=gset _) (M:=gmap loc)).
+ destruct (gmap_curry M !! l) as [?|] eqn:Eq;
+ [by apply gmap_curry_non_empty in Eq|done].
+ Qed.
+
+
+ (** Actual message *)
+ Record message :=
+ mkMsg {
+ mloc : loc;
+ mto: time;
+ mbase : baseMessage;
+ }.
+
+ Notation "'<' x → v @ t , R >" :=
+ (mkMsg x t (mkBMes v R))
+ (at level 20, format "< x → v @ t , R >",
+ x at level 21, v at level 21, t at level 21, R at level 21).
+
+ Implicit Type (ð‘š: message). (* U1D45A *)
+
+ Record message_le ð‘š1 ð‘š2 := {
+ message_sqsubseteq_loc : ð‘š1.(mloc) = ð‘š2.(mloc);
+ message_sqsubseteq_to : ð‘š1.(mto) = ð‘š2.(mto);
+ message_sqsubseteq_base: ð‘š1.(mbase) ⊑ ð‘š2.(mbase);
+ }.
+
+ Global Instance message_sqsubseteq : SqSubsetEq message := message_le.
+
+ Global Instance message_sqsubseteq_po :
+ PartialOrder ((⊑) : SqSubsetEq message).
+ Proof.
+ constructor; [constructor|]; [done|..].
+ - intros [][][] [???] [???]. simpl in *.
+ constructor; [by subst|by subst|by etrans].
+ - intros [][] [??Le1][??Le2]. simpl in *. subst.
+ f_equal. by apply : (anti_symm (⊑)).
+ Qed.
+
+ (** Memory wellformedness *)
+ Global Instance message_wf : Wellformed message :=
+ λ ð‘š, ∀ V, ð‘š.(mbase).(mrel) = Some V → Some ð‘š.(mto) = V !!w ð‘š.(mloc).
+
+ Definition loc_cell_wf l C := ∀ to m, C !! to = Some m → Wf (mkMsg l to m).
+
+ Record mem_wf' M := {
+ mem_wf_closed : closed_mem M;
+ mem_wf_loc_cell : ∀ l, loc_cell_wf l (M !!c l);
+ }.
+
+ Global Instance mem_wf : Wellformed memory := mem_wf'.
+
+ Lemma mem_insert_max_singleton_wf M l t m
+ (WF: Wf M) (WFm: Wf (mkMsg l t m))
+ (CLOSED: m.(mrel) ∈ <[l := {[t:=m]}]> M)
+ (MAX: ∀ t', is_Some (M !! (l,t')) → (t' < t)%positive) :
+ Wf (<[l := {[t:=m]}]> M).
+ Proof.
+ constructor; move => l1; [move => t1 m1; rewrite memory_lookup_cell|..];
+ (case (decide (l1 = l)) => [->|?];
+ [rewrite memory_cell_lookup_insert
+ |rewrite memory_cell_lookup_insert_ne; last done]);
+ [..|by apply WF].
+ - by move => /lookup_singleton_Some [? <-].
+ - rewrite -memory_lookup_cell => Eq.
+ destruct (m1.(mrel)) as [V|] eqn:EQV; last done.
+ have INM: V ∈ M.
+ { change (Some V ∈ M). rewrite -EQV. by eapply WF. }
+ move => l2 t2 Eq2. setoid_rewrite memory_lookup_cell.
+ have EE := INM _ _ Eq2.
+ case (decide (l2 = l)) => ?;
+ [subst l2; rewrite memory_cell_lookup_insert|
+ rewrite memory_cell_lookup_insert_ne; last done].
+ + exists m,t. split; last by rewrite lookup_insert.
+ destruct EE as (?&?&Le&Eq'). etrans; first apply Le.
+ apply Pos.lt_le_incl. apply MAX. by eexists.
+ + by setoid_rewrite <- memory_lookup_cell.
+ - move => ?? /lookup_singleton_Some [<- <-] //.
+ Qed.
+
+ Global Instance message_ElemOf : ElemOf message memory :=
+ λ ð‘š M, M !! (mloc ð‘š, mto ð‘š) = Some (mbase ð‘š).
+
+ Global Instance msg_elem_wf_pre : @WellformedPreserving memory _ message _ (∋).
+ Proof.
+ constructor. move => ?? In WF.
+ apply WF. rewrite -memory_lookup_cell. apply In.
+ Qed.
+
+
+ (** Memory alloc/dealloc -------------------------------------------------- *)
+ Definition mem_deallocated M : gset loc :=
+ filter (λ l, cell_deallocated (M !!c l)) (dom M).
+
+ Lemma mem_deallocated_sub M :
+ mem_deallocated M ⊆ dom M.
+ Proof. set_solver. Qed.
+
+ Lemma mem_deallocated_correct1 M l:
+ l ∈ mem_deallocated M → cell_deallocated (M !!c l).
+ Proof. set_solver. Qed.
+
+ Lemma mem_deallocated_correct2 M l:
+ cell_deallocated (M !!c l) → l ∈ mem_deallocated M.
+ Proof.
+ move=>HM. move : (HM). intros (t & ? & EQ & _)%cell_deallocated_correct1.
+ rewrite -memory_lookup_cell -lookup_gmap_curry in EQ.
+ rewrite elem_of_filter /dom /memory_loc_dom elem_of_dom.
+ destruct lookup; by eauto.
+ Qed.
+
+ Record alloc_inv M := {
+ alloc_inv_min_alloc : ∀ l, cell_alloc_inv (M !!c l);
+ alloc_inv_max_dealloc : ∀ l, cell_dealloc_inv (M !!c l);
+ }.
+
+ Global Program Instance memory_state : StateFacts loc memory :=
+ {| state_dealloc := mem_deallocated; |}.
+ Next Obligation. intros. by apply mem_deallocated_sub. Defined.
+
+ (* M ↩{A} 𑚠*)
+ Inductive memory_addins 𑚠: memory → memory → Prop :=
+ MemAddIns M C'
+ (ADD: cell_addins (mto ð‘š) (mbase ð‘š) (M !!c (mloc ð‘š)) C')
+ : memory_addins ð‘š M (<[(mloc ð‘š) := C']> M).
+
+ Lemma lookup_mem_first_eq l t C M:
+ (<[l:= C]> M) !! (l,t) = C !! t.
+ Proof. by rewrite lookup_gmap_uncurry lookup_insert. Qed.
+
+ Lemma lookup_mem_first_ne l l' t C M (NEq: l ≠l'):
+ (<[l:= C]> M) !! (l',t) = M !! (l',t).
+ Proof. by rewrite lookup_gmap_uncurry lookup_insert_ne ?lookup_gmap_curry. Qed.
+
+ (* MEM ADDINS ------------------------------------------------------------- *)
+ Lemma memory_addins_eq (M1 M2: memory) ð‘š
+ (ADD: memory_addins ð‘š M1 M2) :
+ M2 = <[(mloc ð‘š) := (<[(mto ð‘š) := (mbase ð‘š) ]> (M1 !!c ð‘š.(mloc)))]> M1.
+ Proof. inversion ADD. subst. by inversion ADD0. Qed.
+
+ Lemma memory_addins_update ð‘š M1 M2
+ (ADD: memory_addins ð‘š M1 M2) :
+ M2 !!c mloc ð‘š = <[mto ð‘š:=mbase ð‘š]> (M1 !!c ð‘š.(mloc)).
+ Proof. rewrite (memory_addins_eq _ _ _ ADD) memory_cell_lookup_insert //. Qed.
+
+ Lemma lookup_mem_addins_old_first_eq M1 M2 ð‘š l
+ (ADD: memory_addins ð‘š M1 M2) (NEq: l ≠mloc ð‘š)
+ : M1 !!c l = M2 !!c l.
+ Proof. inversion ADD. by rewrite memory_cell_lookup_insert_ne. Qed.
+
+ Lemma lookup_mem_addins_old_eq M1 M2 ð‘š l t
+ (ADD: memory_addins ð‘š M1 M2) (NEq: (l,t) ≠(mloc ð‘š, mto ð‘š))
+ : M1 !! (l,t) = M2 !! (l,t).
+ Proof.
+ inversion ADD. subst.
+ case (decide (l = mloc ð‘š)) => [?|?]; last by rewrite lookup_mem_first_ne.
+ subst l. rewrite lookup_mem_first_eq.
+ inversion ADD0. rewrite lookup_insert_ne -?memory_lookup_cell //.
+ congruence.
+ Qed.
+
+ Lemma lookup_mem_addins_fresh M1 M2 ð‘š
+ (ADD: memory_addins ð‘š M1 M2)
+ : M1 !! (mloc ð‘š, mto ð‘š) = None.
+ Proof.
+ rewrite memory_lookup_cell. inversion ADD. subst.
+ eapply lookup_cell_addins_fresh; eauto; apply _.
+ Qed.
+
+ Lemma lookup_mem_addins_new M1 M2 ð‘š
+ (ADD: memory_addins ð‘š M1 M2)
+ : M2 !! (mloc ð‘š, mto ð‘š) = Some (mbase ð‘š).
+ Proof.
+ inversion ADD. rewrite lookup_mem_first_eq. by eapply lookup_cell_addins_new.
+ Qed.
+
+ Lemma lookup_mem_addins_old l t m M1 M2 ð‘š
+ (HL: M1 !! (l,t) = Some m)
+ (ADD: memory_addins ð‘š M1 M2):
+ M2 !! (l,t) = Some m.
+ Proof.
+ case (decide ((l,t) = (mloc ð‘š,mto ð‘š))) => [Eq1|?].
+ - inversion Eq1. subst l t.
+ by rewrite (lookup_mem_addins_fresh _ _ _ ADD) in HL.
+ - rewrite -HL. symmetry. by eapply lookup_mem_addins_old_eq.
+ Qed.
+
+ Lemma closed_view_addins_mono V M1 M2 ð‘š
+ (C1: V ∈ M1) (ADD: memory_addins 𑚠M1 M2) :
+ V ∈ M2.
+ Proof.
+ move => ?? /C1 [m [to [? Eq]]]. exists m, to. split; first by auto.
+ eapply lookup_mem_addins_old in Eq; eauto.
+ Qed.
+
+ Lemma opt_closed_view_addins_mono (V : option view) M1 M2 ð‘š
+ (C1: V ∈ M1) (ADD: memory_addins 𑚠M1 M2) :
+ V ∈ M2.
+ Proof. destruct V; [by eapply closed_view_addins_mono|done]. Qed.
+
+ Lemma closed_mem_addins M1 M2 ð‘š
+ (WF: closed_mem M1) (ADD: memory_addins ð‘š M1 M2) (CLOSED: ð‘š.(mbase).(mrel) ∈ M2) :
+ closed_mem M2.
+ Proof.
+ move => l t m Eq.
+ case (decide ((l, t) = (mloc ð‘š, mto ð‘š))) => [Eq1|NEq].
+ - rewrite Eq1 (lookup_mem_addins_new _ _ _ ADD) in Eq.
+ inversion Eq. by subst m.
+ - rewrite -(lookup_mem_addins_old_eq _ _ _ _ _ ADD NEq) in Eq.
+ eapply opt_closed_view_addins_mono; eauto.
+ Qed.
+
+ Lemma wf_mem_addins M1 M2 ð‘š
+ (mWF: Wf ð‘š) (CLOSED: ð‘š.(mbase).(mrel) ∈ M2)
+ (ADD: memory_addins ð‘š M1 M2) (WF: Wf M1):
+ Wf M2.
+ Proof.
+ constructor.
+ - eapply closed_mem_addins; eauto. apply WF.
+ - move => l t m.
+ case (decide (l = mloc ð‘š)) => [->|NEq].
+ + case (decide (t = mto ð‘š)) => [->|NEq].
+ * rewrite -memory_lookup_cell (lookup_mem_addins_new _ _ _ ADD)=>[[<-]].
+ by destruct ð‘š.
+ * move => Eq.
+ assert (H2: M1 !! (mloc ð‘š, t) = Some m).
+ { rewrite (lookup_mem_addins_old_eq _ _ _ _ _ ADD); last congruence.
+ by rewrite memory_lookup_cell. }
+ rewrite memory_lookup_cell in H2. by eapply WF.
+ + rewrite -(lookup_mem_addins_old_first_eq _ _ _ _ ADD NEq). by apply WF.
+ Qed.
+
+ Lemma memory_addins_subset (P M1 M2 : memory) ð‘š
+ (ADD: memory_addins ð‘š M1 M2)
+ (SUB: P ⊆ M1) :
+ P ⊆ M2.
+ Proof.
+ etrans; first by apply SUB.
+ move => [l t]. case Eq : (M1 !! (l,t))=> [m|].
+ + by rewrite (lookup_mem_addins_old _ _ _ _ _ _ Eq ADD).
+ + by case (M2 !! (l, t)).
+ Qed.
+
+
+ (** Allocation and Deallocation invariants for memory --------------------- *)
+
+ Definition allocated l M := ∀ t m, M !! (l, t) = Some m → mval m ≠DVal.
+
+ Lemma allocated_cell_deallocated l M
+ (ALLOC: ¬ cell_deallocated (M !!c l))
+ (AINV: alloc_inv M):
+ allocated l M.
+ Proof.
+ move => t m Eqm EqD. apply ALLOC. rewrite memory_lookup_cell in Eqm.
+ have EqM: cell_max (M !!c l) = Some (t, m) by eapply alloc_inv_max_dealloc.
+ by rewrite /cell_deallocated EqM.
+ Qed.
+
+ Lemma allocated_cell_deallocated_inv l M
+ (ALLOC: allocated l M)
+ (AINV: alloc_inv M):
+ ¬ cell_deallocated (M !!c l).
+ Proof.
+ move => /cell_deallocated_correct1 [t [m [Eqm [Eqv _]]]].
+ apply (ALLOC t m); last done. by rewrite memory_lookup_cell.
+ Qed.
+
+ Lemma memory_addins_AVal_alloc_inv ð‘š M1 M2
+ (ADD: memory_addins ð‘š M1 M2)
+ (NOTAD: ð‘š.(mbase).(mval) = AVal)
+ (FRESH: M1 !!c ð‘š.(mloc) = ∅)
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof.
+ inversion_clear ADD. subst. rewrite FRESH /= in ADD0.
+ assert (C' ≠∅). { inversion ADD0. apply insert_non_empty. }
+ constructor => l0 C0;
+ (case (decide (l0 = ð‘š.(mloc))) => [->|NEq];
+ [rewrite memory_cell_lookup_insert // |
+ rewrite memory_cell_lookup_insert_ne //; by apply AINV]).
+ - eapply cell_addins_alloc_empty; eauto.
+ - eapply cell_addins_nDVal_dealloc_inv; eauto. by rewrite NOTAD.
+ Qed.
+
+ Lemma memory_addins_VVal_alloc ð‘š M1 M2
+ (ADD: memory_addins ð‘š M1 M2)
+ (ISVAL: isval ð‘š.(mbase).(mval))
+ (ALLOC: allocated ð‘š.(mloc) M1)
+ (LALL: ∃ t', is_Some ( M1 !! (ð‘š.(mloc), t')) ∧ (t' <= ð‘š.(mto))%positive)
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof.
+ inversion_clear ADD. subst. destruct LALL as [t' [[m' Eqm'] Le']].
+ constructor; intros l;
+ (case (decide (l = ð‘š.(mloc))) => [->|NEq];
+ [rewrite memory_cell_lookup_insert // |
+ rewrite memory_cell_lookup_insert_ne //; by apply AINV]).
+ - apply (cell_addins_alloc_inv _ _ _ _ ADD0);
+ [by eapply AINV|..|by inversion ISVAL].
+ eexists. split; last exact Le'. rewrite -memory_lookup_cell. by eexists.
+ - apply (cell_addins_nDVal_dealloc_inv _ _ _ _ ADD0); last by inversion ISVAL.
+ move => t m Eqt. apply (ALLOC t). by rewrite memory_lookup_cell.
+ Qed.
+
+ Lemma memory_addins_nAVal_alloc ð‘š M1 M2
+ (ADD: memory_addins ð‘š M1 M2)
+ (NOTAD: ð‘š.(mbase).(mval) ≠AVal)
+ (ALLOC: ∀ t' m', M1 !! (ð‘š.(mloc), t') = Some m' →
+ mval m' ≠DVal ∧ (t' < ð‘š.(mto))%positive)
+ (LALL: ∃ t', is_Some (M1 !! (ð‘š.(mloc), t')))
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof using All.
+ inversion_clear ADD. destruct LALL as [t' [m' Eqm']].
+ constructor; intros l;
+ (case (decide (l = ð‘š.(mloc))) => [->|NEq];
+ [rewrite memory_cell_lookup_insert // |
+ rewrite memory_cell_lookup_insert_ne //; by apply AINV]).
+ - apply (cell_addins_alloc_inv _ _ _ _ ADD0);
+ [by eapply AINV|..|done].
+ eexists. rewrite -memory_lookup_cell. split; first by eexists.
+ apply Pos.lt_le_incl. by apply (ALLOC _ m').
+ - apply (cell_addins_dealloc_inv _ _ _ _ ADD0).
+ move => t0 m0 ?. apply (ALLOC t0). by rewrite memory_lookup_cell.
+ Qed.
+
+ (** Memory writes --------------------------------------------------------- *)
+ (* M -{ð‘š}-> M' *)
+ Inductive memory_write M1 ð‘š M2: Prop :=
+ | MemWrite
+ (MEM: memory_addins ð‘š M1 M2)
+ (mWF: Wf ð‘š) (CLOSED: ð‘š.(mbase).(mrel) ∈ M2)
+ (ISVAL: isval (ð‘š.(mbase).(mval)))
+ (ALLOC: allocated ð‘š.(mloc) M1)
+ (LALL: ∃ t', is_Some (M1 !! (ð‘š.(mloc), t')) ∧ (t' ≤ ð‘š.(mto))%positive)
+ .
+
+ Lemma memory_write_wf M1 ð‘š M2
+ (WRITE: memory_write M1 ð‘š M2) (WF: Wf M1):
+ Wf M2.
+ Proof. inversion WRITE. by eapply wf_mem_addins. Qed.
+
+ Lemma memory_write_alloc_inv M1 ð‘š M2
+ (WRITE: memory_write M1 ð‘š M2)
+ (AINV: alloc_inv M1):
+ alloc_inv M2.
+ Proof. inversion WRITE. by apply (memory_addins_VVal_alloc _ _ _ MEM). Qed.
+
+ Lemma memory_write_addins_fresh M1 ð‘š M2
+ (WRITE: memory_write M1 ð‘š M2) :
+ M1 !! (ð‘š.(mloc), ð‘š.(mto)) = None.
+ Proof. inversion WRITE. by eapply lookup_mem_addins_fresh. Qed.
+
+ Lemma memory_write_addins_eq M1 ð‘š M2
+ (WRITE: memory_write M1 ð‘š M2) :
+ M2 = <[mloc ð‘š:=<[mto ð‘š:=mbase ð‘š]> (M1 !!c mloc ð‘š)]> M1.
+ Proof. inversion WRITE. by eapply memory_addins_eq. Qed.
+
+ Lemma memory_write_new M1 ð‘š M2
+ (WRITE: memory_write M1 ð‘š M2) :
+ M2 !! (mloc ð‘š, mto ð‘š) = Some (mbase ð‘š).
+ Proof. inversion WRITE. by eapply lookup_mem_addins_new. Qed.
+
+ Lemma memory_write_msg_wf M1 ð‘š M2
+ (WRITE: memory_write M1 ð‘š M2):
+ Wf ð‘š.
+ Proof. by inversion WRITE. Qed.
+
+ Lemma memory_write_closed_view M1 ð‘š M2 V
+ (WRITE: memory_write M1 ð‘š M2)
+ (CLOSED: V ∈ M1):
+ V ∈ M2.
+ Proof.
+ inversion WRITE. eapply closed_view_addins_mono; by eauto.
+ Qed.
+
+ Lemma memory_write_opt_closed_view M1 ð‘š M2 (oV: option view)
+ (WRITE: memory_write M1 ð‘š M2)
+ (CLOSED: oV ∈ M1):
+ oV ∈ M2.
+ Proof. destruct oV; [by eapply memory_write_closed_view|done]. Qed.
+
+
+ (** Memory list addins ---------------------------------------------------- *)
+ Inductive mem_list_addins : list message → relation memory :=
+ | MemListAddNone M : mem_list_addins nil M M
+ | MemListAddSome ð‘š ð‘šs M1 M2 M3
+ (NEXT: mem_list_addins ð‘šs M1 M2)
+ (ADD: memory_addins ð‘š M2 M3)
+ (WF: Wf ð‘š)
+ (CLOSED: ð‘š.(mbase).(mrel) ∈ M3)
+ : mem_list_addins (ð‘š :: ð‘šs) M1 M3.
+
+ Lemma wf_mem_list_addins M1 M2 ð‘šs (WF: Wf M1):
+ mem_list_addins ð‘šs M1 M2 → Wf M2.
+ Proof.
+ induction 1; first exact WF.
+ eapply wf_mem_addins; eauto.
+ Qed.
+
+ Lemma closed_view_list_addins_mono V M1 M2 ð‘šs
+ (C1: V ∈ M1) (ADD: mem_list_addins ð‘šs M1 M2):
+ V ∈ M2.
+ Proof.
+ induction ADD; first by auto.
+ apply (closed_view_addins_mono _ _ _ _ (IHADD C1) ADD0).
+ Qed.
+
+ Lemma opt_closed_view_list_addins_mono (V : option view) M1 M2 ð‘šs
+ (C1: V ∈ M1) (ADD: mem_list_addins ð‘šs M1 M2) (WF: Wf M1):
+ V ∈ M2.
+ Proof. destruct V; [by eapply closed_view_list_addins_mono|done]. Qed.
+
+ Lemma mem_list_addins_dom_mono M1 ð‘šs M2
+ (IN: mem_list_addins ð‘šs M1 M2):
+ dom M1 ⊆ dom M2.
+ Proof.
+ induction IN; first done.
+ etrans; first apply IHIN. inversion_clear ADD.
+ intros l. rewrite !memory_loc_elem_of_dom=>?.
+ destruct (decide (l = mloc ð‘š)) as [->|].
+ { rewrite memory_cell_lookup_insert. inversion ADD0. apply insert_non_empty. }
+ rewrite memory_cell_lookup_insert_ne //.
+ Qed.
+
+ Lemma mem_list_addins_dom M1 ð‘šs M2
+ (IN: mem_list_addins ð‘šs M1 M2) :
+ ∀ ð‘š, 𑚠∈ ð‘šs → ð‘š.(mloc) ∈ dom M2.
+ Proof.
+ setoid_rewrite memory_loc_elem_of_dom. revert M2 IN.
+ induction ð‘šs as [|ð‘š0 ð‘šs IHð‘šs]=> M2 IN ð‘š ; first by rewrite elem_of_nil.
+ inversion IN. subst. move => /elem_of_cons [->|].
+ - inversion ADD. rewrite memory_cell_lookup_insert.
+ inversion ADD0. apply insert_non_empty.
+ - move => In. inversion ADD. destruct (decide (mloc ð‘š0 = mloc ð‘š)) as [->|].
+ + rewrite memory_cell_lookup_insert. inversion ADD0; apply insert_non_empty.
+ + rewrite memory_cell_lookup_insert_ne //. by apply IHð‘šs.
+ Qed.
+
+ Lemma mem_list_addins_sub M1 ð‘šs M2
+ (IN: mem_list_addins ð‘šs M1 M2) (WF: Wf M1) :
+ M1 ⊑ M2.
+ Proof.
+ revert M2 IN.
+ induction ð‘šs => M2 IN; inversion IN; subst; first done.
+ etrans; first apply (IHð‘šs _ NEXT).
+ move => [l t]. case Eq: (M3 !! (l,t)) => [m|]; last done.
+ erewrite (lookup_mem_addins_old _ _ _ M3); eauto.
+ Qed.
+
+ Definition mem_list_disj (ð‘šs : list message) :=
+ ∀ n1 n2 ð‘š1 ð‘š2,
+ ð‘šs !! n1 = Some ð‘š1 → ð‘šs !! n2 = Some ð‘š2 → ð‘š1.(mloc) = ð‘š2.(mloc)
+ → n1 = n2.
+
+ Lemma mem_list_disj_cons ð‘š ð‘šs :
+ mem_list_disj (ð‘š :: ð‘šs) → mem_list_disj ð‘šs.
+ Proof.
+ move => DISJ n1 n2 ð‘š1 ð‘š2 HL1 HL2 Eq.
+ have Eqm : ∀ n, (n + 1 - length [ð‘š])%nat = n by intros; simpl; lia.
+ have HL1': (ð‘š :: ð‘šs) !! (n1 + 1)%nat = Some ð‘š1.
+ { rewrite -HL1 -{2}(Eqm n1)-lookup_app_r; [auto|simpl; lia]. }
+ have HL2': (ð‘š :: ð‘šs) !! (n2 + 1)%nat = Some ð‘š2.
+ { rewrite -HL2 -{2}(Eqm n2)-lookup_app_r; [auto|simpl; lia]. }
+ assert (EQ := DISJ _ _ _ _ HL1' HL2' Eq). by lia.
+ Qed.
+
+ Lemma mem_list_disj_cons_rest ð‘š ð‘šs :
+ mem_list_disj (ð‘š :: ð‘šs) → ∀ ð‘š', ð‘š' ∈ ð‘šs → ð‘š.(mloc) ≠ð‘š'.(mloc).
+ Proof.
+ move => DISJ ð‘š' /elem_of_list_lookup [i HL2] Eq.
+ have HL1: (ð‘š :: ð‘šs) !! 0%nat = Some ð‘š by auto.
+ have HL2': (ð‘š :: ð‘šs) !! (i + 1)%nat = Some ð‘š'.
+ { rewrite (lookup_app_r [ð‘š]); simpl; last by lia.
+ rewrite (_: (i + 1 - 1)%nat = i); by [auto|lia]. }
+ have Eq' :=DISJ _ _ _ _ HL1 HL2' Eq. clear -Eq'. by lia.
+ Qed.
+
+ Lemma mem_list_addins_old ð‘šs M1 M2 l
+ (ADD: mem_list_addins ð‘šs M1 M2) (NONE: ∀ ð‘š, 𑚠∈ ð‘šs → l ≠ð‘š.(mloc)):
+ M1 !!c l = M2 !!c l.
+ Proof.
+ induction ADD; first done.
+ rewrite IHADD.
+ - eapply lookup_mem_addins_old_first_eq; eauto. apply NONE. by left.
+ - move => ð‘š' ?. apply NONE. by right.
+ Qed.
+
+ Lemma mem_list_addins_old_2 ð‘šs M1 M2 l t
+ (ADD: mem_list_addins ð‘šs M1 M2) (NONE: ∀ ð‘š, 𑚠∈ ð‘šs → l ≠ð‘š.(mloc)):
+ M1 !! (l, t) = M2 !! (l, t).
+ Proof. rewrite !memory_lookup_cell. f_equal. by eapply mem_list_addins_old. Qed.
+
+ Lemma mem_list_addins_disjoint ð‘šs M1 M2
+ (ADD: mem_list_addins ð‘šs M1 M2)
+ (DISJ: mem_list_disj ð‘šs) :
+ ∀ ð‘š, 𑚠∈ ð‘šs →
+ M2 !!c ð‘š.(mloc) = <[ð‘š.(mto) := ð‘š.(mbase)]> (M1 !!c ð‘š.(mloc)).
+ Proof.
+ revert M2 ADD.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => M2 ADD ð‘š' Inð‘š';
+ first by apply elem_of_nil in Inð‘š'.
+ inversion_clear ADD.
+ have DISJ' := mem_list_disj_cons _ _ DISJ.
+ move : Inð‘š'=> /elem_of_cons [?|In].
+ - subst ð‘š'.
+ rewrite (mem_list_addins_old _ _ _ _ NEXT);
+ last by apply mem_list_disj_cons_rest.
+ eapply memory_addins_update; eauto.
+ - have NEq := mem_list_disj_cons_rest _ _ DISJ _ In.
+ specialize (IH DISJ' _ NEXT).
+ rewrite -(lookup_mem_addins_old_first_eq _ _ _ _ ADD0);
+ [by apply IH|done].
+ Qed.
+
+ Lemma mem_list_addins_fresh_alloc M1 ð‘šs M2
+ (IN: mem_list_addins ð‘šs M1 M2)
+ (DISJ : mem_list_disj ð‘šs)
+ (FRESH: ∀ ð‘š, 𑚠∈ ð‘šs → ð‘š.(mloc) ∉ dom M1 ∧ ð‘š.(mbase).(mval) = AVal)
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof.
+ revert M2 IN.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => M2 IN ; inversion IN; subst; first done.
+ destruct (FRESH ð‘š) as [NIn EqV]; first by left.
+ apply (memory_addins_AVal_alloc_inv _ _ _ ADD EqV).
+ { rewrite -(mem_list_addins_old _ _ _ _ NEXT);
+ [by eapply memory_loc_not_elem_of_dom |by apply mem_list_disj_cons_rest]. }
+ apply IH; [by eapply mem_list_disj_cons| |done].
+ move => ??. apply FRESH. by right.
+ Qed.
+
+ Lemma mem_list_addins_dealloc_alloc M1 ð‘šs M2
+ (IN: mem_list_addins ð‘šs M1 M2)
+ (DISJ : mem_list_disj ð‘šs)
+ (DEALLOC: ∀ ð‘š, 𑚠∈ ð‘šs
+ → ð‘š.(mbase).(mval) = DVal
+ ∧ (∀ (t': time) m', M1 !! (ð‘š.(mloc), t') = Some m'
+ → mval m' ≠DVal ∧ (t' < ð‘š.(mto))%positive)
+ ∧ ∃ t', is_Some (M1 !! (ð‘š.(mloc),t')))
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof using All.
+ revert M2 IN.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => M2 IN ; inversion IN; subst; first done.
+ destruct (DEALLOC ð‘š) as [EqV [MAX SOME]]; first by left.
+ apply (memory_addins_nAVal_alloc _ _ _ ADD);
+ [by rewrite EqV|..].
+ - move => t' m' Eq'. apply MAX.
+ rewrite (mem_list_addins_old_2 _ _ _ _ _ NEXT); first done.
+ by apply mem_list_disj_cons_rest.
+ - destruct SOME as [t' [m' Eq']].
+ eexists t', m'.
+ rewrite -(mem_list_addins_old_2 _ _ _ _ _ NEXT); first done.
+ by apply mem_list_disj_cons_rest.
+ - apply IH; [by eapply mem_list_disj_cons| |done].
+ move => ??. apply DEALLOC. by right.
+ Qed.
+
+ Definition alloc_new_mem M ð‘šs : memory :=
+ foldr (λ ð‘š M, <[ð‘š.(mloc) := {[ð‘š.(mto) := ð‘š.(mbase)]}]> M) M ð‘šs.
+
+ Definition dealloc_new_mem (M: memory) (ð‘šs: list message) : memory :=
+ foldr (λ 𑚠M,
+ <[ð‘š.(mloc) := <[ð‘š.(mto) := ð‘š.(mbase)]> (M !!c ð‘š.(mloc))]> M) M ð‘šs.
+
+ Definition alloc_new_na (ð“: view) (ð‘šs: list message) : view :=
+ foldr (λ ð‘š ð“, <[ð‘š.(mloc) := [{ ð‘š.(mto), ∅, ∅, ∅ }] ]> ð“) ð“ ð‘šs.
+
+ Lemma alloc_new_mem_lookup_old M (ð‘šs: list message) l
+ (NONE: ∀ ð‘š, 𑚠∈ ð‘šs → l ≠ð‘š.(mloc)):
+ (alloc_new_mem M ð‘šs) !!c l = M !!c l.
+ Proof.
+ induction ð‘šs as [|ð‘š ð‘šs IH] ; first done.
+ rewrite /= memory_cell_lookup_insert_ne.
+ - apply IH => ??. apply NONE. by right.
+ - move => ?. apply (NONE ð‘š); [by left|done].
+ Qed.
+
+ Lemma alloc_new_mem_lookup_new M (ð‘šs: list message) ð‘š
+ (DISJ: mem_list_disj ð‘šs)
+ (IN: 𑚠∈ ð‘šs):
+ (alloc_new_mem M ð‘šs) !!c ð‘š.(mloc) = {[mto ð‘š := mbase ð‘š]}.
+ Proof.
+ induction ð‘šs as [|ð‘š' ð‘šs' IH];
+ first by apply not_elem_of_nil in IN.
+ apply elem_of_cons in IN as [?|IN].
+ - subst. rewrite memory_cell_lookup_insert //.
+ - rewrite /= memory_cell_lookup_insert_ne;
+ last by apply (mem_list_disj_cons_rest _ _ DISJ).
+ apply IH; last done. by eapply mem_list_disj_cons.
+ Qed.
+
+ Lemma alloc_new_na_lookup_old (ð‘šs: list message) ð“ l
+ (NONE: ∀ ð‘š, 𑚠∈ ð‘šs → l ≠ð‘š.(mloc)):
+ alloc_new_na ð“ ð‘šs !! l = ð“ !! l.
+ Proof.
+ induction ð‘šs as [|ð‘š ð‘šs IH]; first done.
+ simpl. rewrite lookup_insert_ne.
+ - apply IH. move => ??. apply NONE. by right.
+ - move => ?. apply (NONE ð‘š); [by left|done].
+ Qed.
+
+ Lemma closed_na_view_list_addins (ð“: view) M1 M2 ð‘šs
+ (C1: ð“ ∈ M1) (ADD: mem_list_addins ð‘šs M1 M2):
+ alloc_new_na ð“ ð‘šs ∈ M2.
+ Proof.
+ revert M2 ADD.
+ induction ð‘šs as [|ð‘š ð‘šs]
+ => M2 ADD /=; inversion ADD; subst; first done.
+ move => l t.
+ case (decide (l = ð‘š.(mloc))) => [->|NEq].
+ - move/(view_lookup_of_wp _ _) => [[t' ws rsa rsn] /= [-> {t'} ]].
+ rewrite lookup_insert => [[<-] ? ?].
+ do 2 eexists. split; last by eapply lookup_mem_addins_new. done.
+ - move/(view_lookup_of_wp _ _) => [[t' ? ? ?] /= [-> {t'} ]].
+ rewrite lookup_insert_ne; last by auto.
+ move/(view_lookup_w _ _).
+ move => /(IHð‘šs _ NEXT) [m [to' H']].
+ exists m, to'.
+ rewrite -(lookup_mem_addins_old_eq _ _ _ _ _ ADD0); first done.
+ by move => [? ?].
+ Qed.
+
+ Section Allocation.
+ Context `{!Shift loc} `{!Allocator loc memory}.
+ (** Allocation *)
+ Inductive memory_alloc
+ (n : nat) l ð‘šs M1 M2 : Prop :=
+ | MemAlloc
+ (LEN: length ð‘šs = n)
+ (AMES: ∀ (n' : nat) ð‘š, ð‘šs !! n' = Some ð‘š
+ → ð‘š.(mloc) = l >> n'
+ ∧ ð‘š.(mbase).(mval) = AVal
+ ∧ ð‘š.(mbase).(mrel) = None)
+ (ADD: mem_list_addins ð‘šs M1 M2)
+ (ALLOC: alloc M1 n l).
+
+ Lemma memory_alloc_disjoint n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2) :
+ mem_list_disj ð‘šs.
+ Proof.
+ inversion ALLOC.
+ move => n1 n2 ð‘š1 ð‘š2 /AMES [Hn1 _] /AMES [Hn2 _] Eql.
+ rewrite Eql Hn2 in Hn1. by eapply shift_nat_inj.
+ Qed.
+
+ Lemma memory_alloc_loc_eq n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mloc) = l >> n'.
+ Proof. apply ALLOC. Qed.
+
+ Lemma memory_alloc_AVal n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mbase).(mval) = AVal.
+ Proof. apply ALLOC. Qed.
+
+ Lemma memory_alloc_view_None n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mbase).(mrel) = None.
+ Proof. apply ALLOC. Qed.
+
+ Lemma memory_alloc_length n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ length ð‘šs = n.
+ Proof. apply ALLOC. Qed.
+
+ Lemma memory_alloc_fresh n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ (n' : nat), (n' < n)%nat → l >> n' ∈ dom M2 ∖ dom M1.
+ Proof.
+ inversion ALLOC.
+ move => n' Lt. rewrite elem_of_difference. split.
+ - assert (is_Some (ð‘šs !! n')) as [ð‘š HL].
+ { apply lookup_lt_is_Some_2. by rewrite LEN. }
+ destruct (AMES _ _ HL) as [Eq _].
+ rewrite -Eq. eapply mem_list_addins_dom; eauto.
+ by eapply elem_of_list_lookup_2.
+ - by apply (alloc_add_fresh _ _ _ ALLOC0).
+ Qed.
+
+ Lemma memory_alloc_fresh_2 n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ ð‘š, 𑚠∈ ð‘šs → ð‘š.(mloc) ∉ dom M1.
+ Proof.
+ move => ð‘š /elem_of_list_lookup [n' Eqn'].
+ rewrite (memory_alloc_loc_eq _ _ _ _ _ ALLOC _ _ Eqn').
+ apply lookup_lt_Some in Eqn'.
+ rewrite (memory_alloc_length _ _ _ _ _ ALLOC) in Eqn'.
+ move : (memory_alloc_fresh _ _ _ _ _ ALLOC _ Eqn')
+ => /elem_of_difference [//].
+ Qed.
+
+ Lemma memory_alloc_fresh_3 n l ð‘šs (M1 M2 : memory)
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ ð‘š, 𑚠∈ ð‘šs → M1 !!c ð‘š.(mloc) = ∅.
+ Proof.
+ move => ð‘š In. apply memory_loc_not_elem_of_dom. by eapply memory_alloc_fresh_2.
+ Qed.
+
+ Lemma memory_alloc_alloc_inv n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2)
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof.
+ eapply mem_list_addins_fresh_alloc;
+ [apply ALLOC|by eapply memory_alloc_disjoint| |done].
+ move => ð‘š In. split.
+ - apply (memory_alloc_fresh_2 _ _ _ _ _ ALLOC _ In).
+ - apply elem_of_list_lookup in In as [n' Eqn'].
+ apply (memory_alloc_AVal _ _ _ _ _ ALLOC _ _ Eqn').
+ Qed.
+
+ Lemma memory_alloc_lookup n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ ð‘š, 𑚠∈ ð‘šs
+ → M2 !!c ð‘š.(mloc) = {[ð‘š.(mto) := ð‘š.(mbase)]}.
+ Proof.
+ move => ? In. inversion ALLOC.
+ by rewrite (mem_list_addins_disjoint _ _ _
+ ADD (memory_alloc_disjoint _ _ _ _ _ ALLOC) _ In)
+ (memory_alloc_fresh_3 _ _ _ _ _ ALLOC _ In).
+ Qed.
+
+ Lemma memory_alloc_insert n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ M2 = alloc_new_mem M1 ð‘šs.
+ Proof.
+ have FRESH := memory_alloc_fresh_3 _ _ _ _ _ ALLOC.
+ have DISJ := memory_alloc_disjoint _ _ _ _ _ ALLOC.
+ inversion_clear ALLOC. clear LEN AMES ALLOC0 n l.
+ revert M2 ADD FRESH.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => M2 ADD FRESH;
+ inversion_clear ADD; first done.
+ simpl. subst.
+ rewrite -(IH (mem_list_disj_cons _ _ DISJ) _ NEXT).
+ - rewrite (memory_addins_eq _ _ _ ADD0). f_equal.
+ rewrite -(mem_list_addins_old _ _ _ _ NEXT);
+ last by apply mem_list_disj_cons_rest.
+ rewrite FRESH; [done|by left].
+ - move => ??. apply FRESH. by right.
+ Qed.
+
+ (** DeAllocation *)
+ Inductive memory_dealloc
+ (n : nat) l ð‘šs M1 M2 :Prop :=
+ | MemDealloc
+ (LEN: length ð‘šs = n)
+ (DMES: ∀ (n' : nat) ð‘š, ð‘šs !! n' = Some ð‘š
+ → ð‘š.(mloc) = l >> n'
+ ∧ ð‘š.(mbase).(mval) = DVal
+ ∧ ð‘š.(mbase).(mrel) = None
+ ∧ (∀ (t': time) m', M1 !! (ð‘š.(mloc), t') = Some m'
+ → mval m' ≠DVal ∧ (t' < ð‘š.(mto))%positive)
+ ∧ ∃ t', is_Some (M1 !! (ð‘š.(mloc), t')))
+ (ADD: mem_list_addins ð‘šs M1 M2)
+ (DEALLOC: dealloc M1 n l).
+
+ Lemma memory_dealloc_disjoint n l ð‘šs M1 M2
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2) :
+ mem_list_disj ð‘šs.
+ Proof.
+ inversion DEALLOC.
+ move => n1 n2 ð‘š1 ð‘š2 /DMES [Hn1 _] /DMES [Hn2 _] Eql.
+ rewrite Eql Hn2 in Hn1. by eapply shift_nat_inj.
+ Qed.
+
+ Lemma memory_dealloc_loc_eq n l ð‘šs M1 M2
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mloc) = l >> n'.
+ Proof. apply DEALLOC. Qed.
+
+ Lemma memory_dealloc_DVal n l ð‘šs M1 M2
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mbase).(mval) = DVal.
+ Proof. apply DEALLOC. Qed.
+
+ Lemma memory_dealloc_length n l ð‘šs M1 M2
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2):
+ length ð‘šs = n.
+ Proof. apply DEALLOC. Qed.
+
+ Lemma memory_dealloc_max n l ð‘šs M1 M2
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2) :
+ ∀ ð‘š, 𑚠∈ ð‘šs
+ → ∀ ð‘š', ð‘š' ∈ M1 → ð‘š'.(mloc) = ð‘š.(mloc) → (ð‘š'.(mto) < ð‘š.(mto))%positive.
+ Proof.
+ inversion DEALLOC.
+ move => ? /elem_of_list_lookup [n' /DMES [_[_[_ [MAX _]]]]] ð‘š' IN EQL.
+ rewrite -EQL in MAX. by apply (MAX _ _ IN).
+ Qed.
+
+ Lemma memory_dealloc_remove n l ð‘šs M1 M2
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2) :
+ ∀ (n' : nat), (n' < n)%nat
+ → l >> n' ∈ (dom M1 ∖ mem_deallocated M1) ∩ mem_deallocated M2.
+ Proof.
+ inversion DEALLOC.
+ move => n' Lt. rewrite elem_of_intersection. split.
+ - by apply (dealloc_remove _ _ _ DEALLOC0).
+ - apply mem_deallocated_correct2.
+ assert (is_Some (ð‘šs !! n')) as [ð‘š Eqð‘š].
+ { apply lookup_lt_is_Some_2. by rewrite LEN. }
+ destruct (DMES _ _ Eqð‘š) as [Eq1 [Eq2 [Eq3 [MAX _]]]].
+ have DISJ:= memory_dealloc_disjoint _ _ _ _ _ DEALLOC.
+ move : (dealloc_remove _ _ _ DEALLOC0 _ Lt)
+ => /elem_of_difference [/memory_loc_elem_of_dom FRESH NIn].
+ have INð‘š: 𑚠∈ ð‘šs by apply elem_of_list_lookup; eexists.
+ have EqM2: M2 !!c mloc ð‘š = <[mto ð‘š:=mbase ð‘š]> (M1 !!c (l >> n'))
+ by rewrite (mem_list_addins_disjoint _ _ _ ADD) // Eq1.
+ rewrite -Eq1 EqM2. apply cell_deallocated_correct2.
+ exists ð‘š.(mto), ð‘š.(mbase).
+ repeat split; [by rewrite lookup_insert|by auto|].
+ move => t' /elem_of_dom Eq.
+ case (decide (t' = mto ð‘š)) => [->|NEQ]; first done.
+ move : Eq. rewrite lookup_insert_ne; last by auto.
+ move => [m' Eqm'].
+ apply Pos.lt_le_incl, (MAX _ m'). rewrite Eq1.
+ by rewrite memory_lookup_cell.
+ Qed.
+
+ Lemma memory_dealloc_dom_old n l ð‘šs M1 M2
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2) :
+ ∀ (n' : nat), (n' < n)%nat → l >> n' ∈ dom M1.
+ Proof.
+ inversion DEALLOC.
+ by move => ? /(dealloc_remove _ _ _ DEALLOC0) /elem_of_difference [? _].
+ Qed.
+
+ Lemma memory_dealloc_alloc_inv n l ð‘šs M1 M2
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2)
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof.
+ inversion DEALLOC.
+ apply (mem_list_addins_dealloc_alloc _ _ _ ADD);
+ [by eapply memory_dealloc_disjoint| |done].
+ move => ð‘š /elem_of_list_lookup [n' Eqn'].
+ by destruct (DMES _ _ Eqn') as (? & ? & _ & ? & ?).
+ Qed.
+
+ End Allocation.
+
+ (** Cell lists ------------------------------------------------------------ *)
+ Section cell_lists.
+ Context `{!Shift loc}.
+ Definition cell_cons l (n: nat) (M : memory) (Cl : list cell) : list cell :=
+ M !!c (l >> n) :: Cl.
+
+ Fixpoint cell_list' l (n : nat) (M : memory) (Cl: list cell): list cell :=
+ match n with
+ | O => Cl
+ | S n' => cell_list' l n' M (cell_cons l n' M Cl)
+ end.
+
+ Definition cell_list l n M := cell_list' l n M [].
+
+ Lemma cell_list'_length l n M Cl:
+ (length (cell_list' l n M Cl) ≤ (n + length Cl)%nat)%nat.
+ Proof.
+ move : Cl. induction n as [|n Hn] => Cl /=; first done.
+ rewrite /cell_cons. etrans; first apply Hn. simpl. lia.
+ Qed.
+
+ Lemma cell_list'_tail l n M Cl :
+ ∃ Cl', cell_list' l n M Cl = Cl' ++ Cl.
+ Proof.
+ move : Cl. induction n as [|n IH] => Cl; first by exists [].
+ simpl. rewrite /cell_cons.
+ destruct (IH ((M !!c (l >> n)) :: Cl)) as [Cl' Eq'].
+ exists (Cl'++[M !!c (l >> n)]). by rewrite Eq' -app_assoc.
+ Qed.
+
+ Lemma cell_list'_length_exact l n M Cl:
+ (length (cell_list' l n M Cl) = (n + length Cl)%nat)%nat.
+ Proof.
+ move : Cl. induction n as [|n Hn] => Cl /=; first done.
+ rewrite /cell_cons (_: S (n + length Cl) = (n + length (M !!c (l >> n) :: Cl))%nat);
+ last by (simpl;lia).
+ apply Hn.
+ Qed.
+
+ Lemma cell_list'_app l (n: nat) M Cl:
+ cell_list' l n M Cl = cell_list' l n M [] ++ Cl.
+ Proof.
+ revert Cl. induction n as [|n Hn] => Cl /=; first done.
+ rewrite /cell_cons Hn (Hn [_]) app_assoc_reverse //.
+ Qed.
+
+ Lemma cell_list'_cons l (n: nat) M Cl C:
+ cell_list' l (S n) M Cl = cell_list' l n M (M !!c (l >> n)::Cl).
+ Proof. done. Qed.
+
+ Lemma cell_list_app l (n: nat) M C:
+ cell_list l (S n) M = cell_list l n M ++ [M !!c (l >> n)].
+ Proof.
+ rewrite /cell_list (cell_list'_cons _ _ _ []); last done.
+ apply cell_list'_app.
+ Qed.
+
+ Lemma cell_list'_lookup l n n' M Cl
+ (Le: (n ≤ n')%nat) :
+ (cell_list' l n M Cl) !! n' = Cl !! (n' - n)%nat.
+ Proof.
+ destruct (cell_list'_tail l n M Cl) as [Cl' Eq'].
+ rewrite Eq'.
+ assert (HL:= cell_list'_length_exact l n M Cl).
+ rewrite Eq' app_length in HL.
+ assert (HL': length Cl' = n) by lia.
+ rewrite -HL'. apply lookup_app_r. by rewrite HL'.
+ Qed.
+
+ Lemma cell_list'_Some l n M :
+ ∀ (n': nat) C Cl,
+ (∀ (n0: nat) C0, Cl !! n0 = Some C0 → M !!c (l >> (n + n0)%nat) = C0)
+ → (n' < n)%nat
+ → (cell_list' l n M Cl) !! n' = Some C ↔ M !!c (l >> n') = C.
+ Proof.
+ induction n as [|n IH] => n' C Cl HCl Lt; first by lia.
+ simpl. apply lt_n_Sm_le, le_lt_or_eq in Lt as [Lt|Eq].
+ - apply IH; [|done] => n0 C0.
+ rewrite /cell_cons. destruct n0 as [|n0].
+ + move => /= [<-]. by rewrite -plus_n_O.
+ + rewrite (lookup_app_r [_] Cl); last by (simpl; lia).
+ move => /= /HCl. rewrite -minus_n_O.
+ rewrite (_: (S n + n0)%nat = (n + S n0)%nat); [done|lia].
+ - rewrite Eq cell_list'_lookup; last done.
+ rewrite Nat.sub_diag /cell_cons /=. split; congruence.
+ Qed.
+
+ Lemma cell_list_Some l n M :
+ ∀ (n': nat) C,
+ (n' < n)%nat
+ → (cell_list l n M) !! n' = Some C ↔ M !!c (l >> n') = C.
+ Proof.
+ move => n' C Lt. apply cell_list'_Some; auto. by move => ?? /=.
+ Qed.
+
+ Lemma cell_list_Some_2 l n M :
+ ∀ (n': nat) C,
+ (cell_list l n M) !! n' = Some C → M !!c (l >> n') = C.
+ Proof.
+ move => n' C In. apply (cell_list_Some _ n); last done.
+ apply lookup_lt_Some in In.
+ rewrite cell_list'_length_exact /= in In. by lia.
+ Qed.
+
+ Lemma cell_list_fmap (l : loc) (n: nat) (M: memory) :
+ (cell_list l n M) = fmap (λ i : nat, M !!c (l >> i)) (seq 0%nat n).
+ Proof.
+ apply list_eq=> n'.
+ have LEN: length (cell_list l n M) = n.
+ { by rewrite cell_list'_length_exact /= -plus_n_O. }
+ rewrite list_lookup_fmap.
+ case (decide (n' < n)%nat) => [Lt|Ge].
+ - assert (is_Some(cell_list l n M !! n')) as [C EqC].
+ { apply lookup_lt_is_Some. by rewrite LEN. }
+ rewrite EqC. apply cell_list_Some_2 in EqC.
+ by rewrite (lookup_seq_lt _ _ _ Lt) /= EqC.
+ - apply Nat.nlt_ge in Ge.
+ rewrite lookup_ge_None_2; last by rewrite LEN.
+ by rewrite (lookup_seq_ge _ _ _ Ge) /=.
+ Qed.
+
+ Lemma memory_alloc_cell_list `{!Allocator loc memory} n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ (n': nat) C,
+ (cell_list l n M2) !! n' = Some C
+ ↔ ∃ ð‘š, ð‘šs !! n' = Some 𑚠∧ C = {[ð‘š.(mto) := ð‘š.(mbase)]}.
+ Proof.
+ move => n' C.
+ split.
+ - move => In.
+ assert (Lt: (n' < n)%nat).
+ { have HL := cell_list'_length_exact l n M2 [].
+ rewrite /= -(plus_n_O n) in HL. rewrite -HL. by eapply lookup_lt_Some. }
+ assert (is_Some (ð‘šs !! n')) as [ð‘š Eqð‘š].
+ { by rewrite lookup_lt_is_Some (memory_alloc_length _ _ _ _ _ ALLOC). }
+ exists ð‘š. split; first done.
+ move : (cell_list_Some_2 _ _ _ _ _ In).
+ rewrite -(memory_alloc_loc_eq _ _ _ _ _ ALLOC _ _ Eqð‘š)
+ (memory_alloc_lookup _ _ _ _ _ ALLOC); [done|].
+ apply elem_of_list_lookup. by eexists.
+ - move => [ð‘š [Eqð‘š ->]]. apply cell_list_Some; auto.
+ + rewrite -(memory_alloc_length _ _ _ _ _ ALLOC).
+ apply lookup_lt_is_Some. by eexists.
+ + rewrite -(memory_alloc_loc_eq _ _ _ _ _ ALLOC _ _ Eqð‘š).
+ apply (memory_alloc_lookup _ _ _ _ _ ALLOC), elem_of_list_lookup.
+ by eexists.
+ Qed.
+
+ Lemma memory_alloc_cell_list_map `{!Allocator loc memory} n l ð‘šs M1 M2
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ (cell_list l n M2) = fmap (λ ð‘š, {[ð‘š.(mto) := ð‘š.(mbase)]}) ð‘šs.
+ Proof.
+ apply list_eq => n'. rewrite list_lookup_fmap.
+ destruct (cell_list l n M2 !! n') as [C|] eqn:HC.
+ - apply (memory_alloc_cell_list _ _ _ _ _ ALLOC) in HC as [ð‘š [HC1 HC2]].
+ by rewrite HC1 HC2.
+ - apply lookup_ge_None in HC. move : HC.
+ rewrite cell_list'_length_exact /=.
+ by rewrite -(plus_n_O n) -(memory_alloc_length _ _ _ _ _ ALLOC)
+ -lookup_ge_None => [->].
+ Qed.
+
+ End cell_lists.
+
+ (** Cell cut -------------------------------------------------------------- *)
+ Definition cell_cut t: cell → cell := filter (λ t', (t ≤ t')%positive).
+
+ Lemma cell_cut_insert C t t' m :
+ (t ≤ t')%positive →
+ cell_cut t (<[t' := m]> C) = <[t' := m]> (cell_cut t C).
+ Proof. move=>?. by rewrite /cell_cut -map_filter_insert_True. Qed.
+
+ Lemma cell_cut_empty C t
+ (MAX: ∀ t', is_Some (C !! t') → (t' < t)%positive) :
+ cell_cut t C = ∅.
+ Proof.
+ apply map_eq => to. rewrite lookup_empty map_filter_lookup_None.
+ right => ? Eq. apply Pos.lt_nle, MAX. by eexists.
+ Qed.
+
+ Lemma cell_cut_empty_2 t :
+ cell_cut t ∅ = ∅.
+ Proof. apply map_filter_empty. Qed.
+
+ Lemma cell_cut_addins_atomic (to t: time) m C1 C2
+ (Le: (to ≤ t)%positive) (ADD: cell_addins t m C1 C2) :
+ cell_cut to C2 = <[t := m]> (cell_cut to C1).
+ Proof. inversion ADD. by apply cell_cut_insert. Qed.
+
+ Lemma cell_cut_addins_na (t : time) m C1 C2
+ (ADD: cell_addins t m C1 C2) (MAX: ∀ t', is_Some (C1 !! t') → (t' < t)%positive) :
+ cell_cut t C2 = {[t := m]}.
+ Proof.
+ inversion ADD. rewrite cell_cut_insert; last done.
+ by rewrite (cell_cut_empty _ _ MAX).
+ Qed.
+
+ Lemma cell_cut_lookup_Some C t t' m :
+ cell_cut t C !! t' = Some m ↔ C !! t' = Some m ∧ (t ≤ t')%positive.
+ Proof. apply map_filter_lookup_Some. Qed.
+
+ Lemma cell_cut_lookup_None C t t':
+ cell_cut t C !! t' = None ↔ C !! t' = None ∨ ¬ (t ≤ t')%positive.
+ Proof.
+ rewrite map_filter_lookup_None.
+ split; move => [|]; [naive_solver| |naive_solver|naive_solver].
+ destruct (C !! t'); naive_solver.
+ Qed.
+
+ Lemma cell_cut_singleton C t t' m':
+ cell_cut t C = {[t' := m']} → ∀ t0, is_Some (C !! t0) → (t0 ≤ t')%positive.
+ Proof.
+ move => HC t0 [m0 Eq0].
+ destruct (cell_cut t C !! t0) as [m1|] eqn:Eq1.
+ - move : Eq1. by rewrite HC lookup_singleton_Some => [[-> _]].
+ - apply cell_cut_lookup_None in Eq1 as [Eq1|Eq1];
+ first by rewrite Eq1 in Eq0.
+ apply Pos.lt_nle in Eq1.
+ have Eq2: cell_cut t C !! t' = Some m' by rewrite HC lookup_insert.
+ apply cell_cut_lookup_Some in Eq2 as [_ Le2].
+ etrans; last exact Le2. by apply Pos.lt_le_incl.
+ Qed.
+
+ Lemma cell_cut_dom t (C: cell) :
+ dom (cell_cut t C) ⊆ dom C.
+ Proof.
+ move => t'. rewrite 2!elem_of_dom.
+ move => [m' /cell_cut_lookup_Some [Eq' ?]]. by eexists.
+ Qed.
+
+ Lemma cell_cut_cell_alloc_inv t0 C (AINV: cell_alloc_inv C) :
+ ∀ t m, cell_cut t0 C !! t = Some m ∧ mval m = AVal
+ → cell_min (cell_cut t0 C) = Some (t, m).
+ Proof.
+ move => t m [Eqt Eqv].
+ apply gmap_top_inv; eauto with typeclass_instances.
+ apply cell_cut_lookup_Some in Eqt as [Eqt Le].
+ have MIN : cell_min C = Some (t, m) by apply AINV.
+ move => k' IN. apply (gmap_top_top _ _ _ _ MIN).
+ move : IN. apply dom_filter_subseteq.
+ Qed.
+
+ Lemma cell_cut_cell_dealloc_inv t0 C (DINV: cell_dealloc_inv C) :
+ ∀ t m, cell_cut t0 C !! t = Some m ∧ mval m = DVal
+ → cell_max (cell_cut t0 C) = Some (t, m).
+ Proof.
+ move => t m [Eqt Eqv].
+ apply gmap_top_inv; eauto with typeclass_instances.
+ apply cell_cut_lookup_Some in Eqt as [Eqt Le].
+ have MIN : cell_max C = Some (t, m) by apply DINV.
+ move => k' IN. apply (gmap_top_top _ _ _ _ MIN).
+ move : IN. apply dom_filter_subseteq.
+ Qed.
+
+ (* Cell le *)
+ Lemma cell_cut_cell_le (C1 C2: cell) t (LE: cell_le C1 C2) :
+ cell_le (cell_cut t C1) (cell_cut t C2).
+ Proof.
+ move => t'. specialize (LE t').
+ destruct (cell_cut t C1 !! t') as [m1|] eqn:Eq1.
+ - apply cell_cut_lookup_Some in Eq1 as [Eq1 Let].
+ rewrite Eq1 in LE. inversion LE as [? m2 LE' Eq Eq2|].
+ rewrite (_ : cell_cut t C2 !! t' = Some m2); first by constructor.
+ by apply cell_cut_lookup_Some.
+ - rewrite (_ : cell_cut t C2 !! t' = None); first by constructor.
+ apply cell_cut_lookup_None in Eq1 as [Eq1|NLe];
+ [rewrite Eq1 in LE; inversion LE|];
+ apply cell_cut_lookup_None; [by left|by right].
+ Qed.
+
+ Lemma cell_addins_cell_cut_le t m t0
+ (Ce C: cell) (LE: cell_le Ce (cell_cut t0 C))
+ (ADD: cell_addins t m C (<[t:= m]> C)) :
+ cell_addins t m Ce (<[t:= m]> Ce).
+ Proof.
+ constructor.
+ inversion ADD; subst; simpl in *.
+ specialize (LE t).
+ inversion LE as [? m1 LE1 Eq1 Eq2|]; last done. subst.
+ symmetry in Eq2. apply cell_cut_lookup_Some in Eq2 as [Eq2 Le'].
+ by rewrite Eq2 in DISJ.
+ Qed.
+
+ Lemma cell_addins_cell_cut t m t0 C
+ (ADD: cell_addins t m C (<[t:= m]> C)) :
+ cell_addins t m (cell_cut t0 C) (<[t:= m]> (cell_cut t0 C)).
+ Proof.
+ constructor. inversion ADD; subst; simpl in *.
+ apply cell_cut_lookup_None. by left.
+ Qed.
+
+ (** Mem cut -------------------------------------------------------------- *)
+ Definition mem_cut_filter V (lt : loc * time) : Prop :=
+ from_option (λ t', (t' ≤ lt.2)%positive) False (V !!w lt.1).
+ Instance mem_cut_filter_dec V lt : Decision (mem_cut_filter V lt).
+ Proof. unfold mem_cut_filter. destruct view_lookup_write; simpl; apply _. Qed.
+ Definition mem_cut (M : memory) (V : view) :=
+ filter (mem_cut_filter V) M.
+
+ Lemma mem_cut_lookup M V l :
+ mem_cut M V !!c l = from_option (λ t, cell_cut t (M !!c l)) ∅ (V !!w l).
+ Proof.
+ apply map_eq=>t. rewrite -memory_lookup_cell /mem_cut /mem_cut_filter.
+ symmetry. case EQ : (filter _ _ !! _).
+ - move:EQ=>/map_filter_lookup_Some /=. destruct (V!!wl)=>[/=|[_ []]].
+ by rewrite cell_cut_lookup_Some -memory_lookup_cell.
+ - move:EQ=>/map_filter_lookup_None /=. destruct (V!!wl)=>//=.
+ rewrite cell_cut_lookup_None -memory_lookup_cell=>-[|]; [auto|].
+ case: (M !! (l, t)); eauto.
+ Qed.
+
+ (* Lemma mem_cut_insert M V l C t: *)
+ (* <[l:=cell_cut t C]> (mem_cut M V) *)
+ (* = mem_cut (<[l:=C]> M) (partial_alter (λ o, Some (t, default ∅ (snd <$> o))) l V). *)
+ (* Proof. *)
+ (* apply map_eq=>-[l' t']. rewrite !memory_lookup_cell mem_cut_lookup. *)
+ (* destruct (decide (l = l')) as [->|?]. *)
+ (* - rewrite !memory_cell_lookup_insert /timeNap_lookup_write lookup_partial_alter //. *)
+ (* - rewrite !memory_cell_lookup_insert_ne // /timeNap_lookup_write /= lookup_partial_alter_ne // mem_cut_lookup //. *)
+ (* Qed. *)
+
+ Lemma mem_cut_insert M V l C t ws rsa rsn:
+ <[l:=cell_cut t C]> (mem_cut M V) =
+ mem_cut (<[l:=C]> M) (<[l:= [{ t, ws, rsa, rsn }] ]> V).
+ Proof.
+ apply map_eq=>-[l' t']. rewrite !memory_lookup_cell mem_cut_lookup.
+ destruct (decide (l = l')) as [->|?].
+ - rewrite !memory_cell_lookup_insert /view_lookup_write lookup_insert //.
+ - rewrite !memory_cell_lookup_insert_ne //
+ /view_lookup_write lookup_insert_ne // mem_cut_lookup //.
+ Qed.
+
+ Lemma mem_cut_addins_na ð‘š M1 M2 ws rsa rsn ð“
+ (ADD: memory_addins ð‘š M1 M2) :
+ mem_cut M2 (<[ð‘š.(mloc) := [{ ð‘š.(mto), ws, rsa, rsn }] ]> ð“) =
+ <[ð‘š.(mloc) := (<[ð‘š.(mto) := ð‘š.(mbase)]> (cell_cut ð‘š.(mto) (M1 !!c ð‘š.(mloc))))]>
+ (mem_cut M1 ð“).
+ Proof.
+ apply map_eq => l. inversion ADD. rewrite -mem_cut_insert.
+ inversion_clear ADD0. subst. by rewrite cell_cut_insert.
+ Qed.
+
+ Lemma mem_cut_list_addins_na M1 M2 ð‘šs ð“
+ (IN: mem_list_addins ð‘šs M1 M2)
+ (DISJ : mem_list_disj ð‘šs)
+ (MAX: ∀ ð‘š, 𑚠∈ ð‘šs
+ → ∀ ð‘š', ð‘š' ∈ M1 → ð‘š'.(mloc) = ð‘š.(mloc) → (ð‘š'.(mto) < ð‘š.(mto))%positive) :
+ mem_cut M2 (alloc_new_na ð“ ð‘šs) = alloc_new_mem (mem_cut M1 ð“) ð‘šs.
+ Proof.
+ revert M2 IN.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => M2; inversion 1; subst; first done. simpl.
+ rewrite (mem_cut_addins_na _ _ _ _ _ _ _ ADD)
+ -(mem_list_addins_old _ _ _ _ NEXT);
+ last by apply mem_list_disj_cons_rest.
+ rewrite IH;
+ [|by eapply mem_list_disj_cons|by move => ??; apply MAX; right| done].
+ f_equal.
+ rewrite /= cell_cut_empty; first done.
+ move => t' [m' Eqm'].
+ have IN2: 𑚠∈ ð‘š :: ð‘šs by left.
+ apply (MAX _ IN2 (mkMsg ð‘š.(mloc) t' m')); last done.
+ rewrite /elem_of /message_ElemOf memory_lookup_cell //.
+ Qed.
+
+ Lemma mem_cut_list_addins_fresh_na M1 M2 ð‘šs ð“
+ (ADD: mem_list_addins ð‘šs M1 M2)
+ (DISJ : mem_list_disj ð‘šs)
+ (FRESH: ∀ ð‘š, 𑚠∈ ð‘šs → ð‘š.(mloc) ∉ dom M1) :
+ mem_cut M2 (alloc_new_na ð“ ð‘šs) = alloc_new_mem (mem_cut M1 ð“) ð‘šs.
+ Proof.
+ apply mem_cut_list_addins_na; [assumption|assumption|].
+ move => ð‘š /FRESH /memory_loc_not_elem_of_dom EMP ð‘š' IN EQL.
+ rewrite /elem_of /message_ElemOf memory_lookup_cell EQL EMP
+ lookup_empty // in IN.
+ Qed.
+
+ Lemma mem_cut_memory_alloc `{!Shift loc} `{!Allocator loc memory} l n M1 M2 ð‘šs ð“
+ (ALLOC: memory_alloc n l ð‘šs M1 M2) :
+ mem_cut M2 (alloc_new_na ð“ ð‘šs) = alloc_new_mem (mem_cut M1 ð“) ð‘šs.
+ Proof.
+ apply mem_cut_list_addins_fresh_na; [apply ALLOC|..].
+ - by eapply memory_alloc_disjoint.
+ - by eapply memory_alloc_fresh_2.
+ Qed.
+
+ Lemma mem_cut_memory_dealloc `{!Shift loc} `{!Allocator loc memory} l n M1 M2 ð‘šs ð“
+ (DEALLOC: memory_dealloc n l ð‘šs M1 M2) :
+ mem_cut M2 (alloc_new_na ð“ ð‘šs) = alloc_new_mem (mem_cut M1 ð“) ð‘šs.
+ Proof.
+ apply mem_cut_list_addins_na; [apply DEALLOC|..].
+ - by eapply memory_dealloc_disjoint.
+ - by eapply memory_dealloc_max.
+ Qed.
+
+End Memory.
+
+Arguments memory loc {_} VAL.
+Arguments message loc {_} VAL.
+
+Notation cell := (gmap time baseMessage) (only parsing).
+Notation "M !!c l" := (memory_cell_lookup l M) (at level 20) : stdpp_scope.
diff --git a/orc11/progress.v b/orc11/progress.v
new file mode 100644
index 0000000000000000000000000000000000000000..7a18a03f48f6b085965c895c1e64fe5bb947bcb7
--- /dev/null
+++ b/orc11/progress.v
@@ -0,0 +1,1327 @@
+From stdpp Require Import gmap.
+From orc11 Require Export thread.
+
+Require Import stdpp.options.
+
+Section Wellformedness.
+ Context `{!LocFacts loc} `{CVAL: Countable VAL} `{!Shift loc} `{!Allocator loc (memory loc VAL)}.
+
+ Notation memory := (memory loc VAL).
+ Notation message := (message loc VAL).
+ Notation event := (event loc VAL).
+ Notation global := (@global loc _ VAL).
+ Notation config := (@config loc _ VAL).
+ Notation val := (@val VAL).
+ Notation view := (@view loc _).
+ Notation threadView := (@threadView loc _).
+
+ Implicit Type (ð‘š: message) (M: memory) (ð“: view) (ð“¥: threadView)
+ (l: loc) (G: global) (c: config).
+
+ (** Wellformedness of program local step *)
+ (* memory wf *)
+ Lemma alloc_step_mem_wf ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) (WF: Wf M1) :
+ Wf M2.
+ Proof. inversion ALLOC. inversion MEMALL. by eapply wf_mem_list_addins. Qed.
+
+ Lemma dealloc_step_mem_wf ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) (WF: Wf M1) :
+ Wf M2.
+ Proof. inversion DEALLOC. inversion MEMALL. by eapply wf_mem_list_addins. Qed.
+
+ Lemma write_step_mem_wf ð“¥1 M1 ð‘š o V ð“¥2 M2
+ (WRITE: write_step ð“¥1 M1 ð‘š o V ð“¥2 M2) (WF: Wf M1):
+ Wf M2.
+ Proof. inversion WRITE. by eapply memory_write_wf. Qed.
+
+ Lemma machine_step_mem_wf ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2
+ (STEP: machine_step ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2) (WF: Wf M1) :
+ Wf M2.
+ Proof.
+ inversion STEP; simpl; subst; auto;
+ [by eapply alloc_step_mem_wf|by eapply dealloc_step_mem_wf
+ |by eapply write_step_mem_wf|by eapply write_step_mem_wf].
+ Qed.
+
+ (* threadView closed *)
+ Lemma read_step_closed_tview ð“¥1 M tr ð‘š o ð“¥2
+ (READ: read_step ð“¥1 M tr ð‘š o ð“¥2)
+ (CLOSED: ð“¥1 ∈ M) (WF: Wf M) : ð“¥2 ∈ M.
+ Proof.
+ inversion READ. eapply read_helper_closed_tview; eauto.
+ destruct (mrel (mbase ð‘š)) as [V|] eqn:HR; last done.
+ have ?: Some V ∈ M by rewrite -HR; eapply WF. done.
+ Qed.
+
+ Lemma write_step_closed_tview ð“¥1 M1 ð‘š o V ð“¥2 M2
+ (WRITE: write_step ð“¥1 M1 ð‘š o V ð“¥2 M2)
+ (CLOSED: ð“¥1 ∈ M1) : ð“¥2 ∈ M2.
+ Proof. inversion WRITE. eapply write_helper_closed_tview; eauto. Qed.
+
+ Lemma alloc_step_closed_tview ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2)
+ (CLOSED: ð“¥1 ∈ M1) : ð“¥2 ∈ M2.
+ Proof.
+ inversion ALLOC. inversion MEMALL.
+ eapply alloc_helper_mem_closed_tview; eauto. by apply AMES.
+ Qed.
+
+ Lemma dealloc_step_closed_tview ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2)
+ (CLOSED: ð“¥1 ∈ M1) : ð“¥2 ∈ M2.
+ Proof.
+ inversion DEALLOC. inversion MEMALL.
+ eapply alloc_helper_mem_closed_tview; eauto. by apply DMES.
+ Qed.
+
+ Lemma acq_fence_step_closed_tview ð“¥ ð“¥' M
+ (ACQ: acq_fence_step ð“¥ ð“¥') (CLOSED: 𓥠∈ M) : ð“¥' ∈ M.
+ Proof. inversion ACQ. constructor; apply CLOSED. Qed.
+
+ Lemma rel_fence_step_closed_tview ð“¥1 ð“¥2 M
+ (REL: rel_fence_step ð“¥1 ð“¥2) (CLOSED: ð“¥1 ∈ M) : ð“¥2 ∈ M.
+ Proof. inversion REL. constructor=>/=; apply CLOSED. Qed.
+
+ Lemma sc_fence_step_closed_tview ð“¥1 ð“¥2 M ð“¢ ð“¢'
+ (SC: sc_fence_step ð“¥1 ð“¢ ð“¢' ð“¥2) (CLOSED: ð“¥1 ∈ M) (CLOSED2: 𓢠∈ M): ð“¥2 ∈ M.
+ Proof. inversion SC. eapply sc_fence_helper_closed_tview; eauto. Qed.
+
+ Lemma machine_step_closed_tview ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2
+ (STEP: machine_step ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2)
+ (WF: Wf M1) (CLOSED: ð“¥1 ∈ M1) (CLOSEDð“¢: ð“¢1 ∈ M1) :
+ ð“¥2 ∈ M2.
+ Proof.
+ inversion STEP; simpl; subst.
+ - eapply alloc_step_closed_tview; eauto.
+ - eapply dealloc_step_closed_tview; eauto.
+ - eapply read_step_closed_tview; eauto; apply WF.
+ - eapply write_step_closed_tview; eauto.
+ - eapply write_step_closed_tview; eauto.
+ eapply read_step_closed_tview; eauto; apply WF.
+ - eapply acq_fence_step_closed_tview; eauto.
+ - eapply rel_fence_step_closed_tview; eauto.
+ - eapply sc_fence_step_closed_tview; eauto.
+ Qed.
+
+ (* sc closed *)
+ Lemma alloc_step_closed_view ð“¥1 M1 l n ð‘šs ð“¥2 M2 (V: view)
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2)
+ (CLOSED: V ∈ M1) : V ∈ M2.
+ Proof.
+ inversion ALLOC. inversion MEMALL.
+ eapply closed_view_list_addins_mono; eauto.
+ Qed.
+
+ Lemma dealloc_step_closed_view ð“¥1 M1 l n ð‘šs ð“¥2 M2 (V: view)
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2)
+ (CLOSED: V ∈ M1) : V ∈ M2.
+ Proof.
+ inversion DEALLOC. inversion MEMALL.
+ eapply closed_view_list_addins_mono; eauto.
+ Qed.
+
+ Lemma write_step_closed_view ð“¥1 M1 ð‘š o R ð“¥2 M2 (V: view)
+ (WRITE: write_step ð“¥1 M1 ð‘š o R ð“¥2 M2)
+ (CLOSED: V ∈ M1) : V ∈ M2.
+ Proof.
+ inversion WRITE. eapply memory_write_closed_view; eauto; apply WF.
+ Qed.
+
+ Lemma machine_step_closed_view ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2 (V: view)
+ (STEP: machine_step ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2)
+ (CLOSED: V ∈ M1) (WF: Wf M1) :
+ V ∈ M2.
+ Proof.
+ inversion STEP; simpl; subst; [| |done|..|done|done|done].
+ - eapply alloc_step_closed_view; eauto.
+ - eapply dealloc_step_closed_view; eauto.
+ - eapply write_step_closed_view; eauto.
+ - eapply write_step_closed_view; eauto.
+ Qed.
+
+ Lemma machine_step_view_join_update
+ (ð“¥ ð“¥': threadView) (σ σ': global) ev (V: view) ot ð‘šs
+ (STEP: machine_step 𓥠σ.(mem) σ.(sc) ev ot ð‘šs ð“¥' σ'.(mem) σ'.(sc))
+ (WF: Wf σ) (CLOSED: V ∈ σ.(mem)) (CLOSED2: 𓥠∈ σ.(mem)):
+ V ⊔ ð“¥'.(acq) ∈ σ'.(mem).
+ Proof.
+ apply join_closed_view.
+ - eapply machine_step_closed_view; eauto; apply WF.
+ - eapply machine_step_closed_tview; eauto; apply WF.
+ Qed.
+
+ Lemma sc_fence_step_closed_sc ð“¥1 ð“¥2 M ð“¢ ð“¢'
+ (SC: sc_fence_step ð“¥1 ð“¢ ð“¢' ð“¥2) (CLOSED: ð“¥1 ∈ M) (CLOSED2: 𓢠∈ M): ð“¢' ∈ M.
+ Proof. inversion SC. eapply sc_fence_helper_closed_sc; eauto. Qed.
+
+ Lemma machine_step_closed_sc ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2
+ (STEP: machine_step ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2)
+ (CLOSED: ð“¥1 ∈ M1) (CLOSEDð“¢: ð“¢1 ∈ M1) : ð“¢2 ∈ M2.
+ Proof.
+ inversion STEP; subst; simpl; auto.
+ - eapply alloc_step_closed_view; eauto.
+ - eapply dealloc_step_closed_view; eauto.
+ - eapply write_step_closed_view; eauto.
+ - eapply write_step_closed_view; eauto.
+ - eapply sc_fence_step_closed_sc; eauto.
+ Qed.
+
+ (* threadView sqsubseteq *)
+ Lemma acq_fence_step_tview_sqsubseteq ð“¥ ð“¥'
+ (ACQ: acq_fence_step ð“¥ ð“¥') : 𓥠⊑ ð“¥'.
+ Proof. inversion ACQ. constructor; [done|done|by apply cur_acq|done]. Qed.
+
+ Lemma rel_fence_step_tview_sqsubseteq ð“¥1 ð“¥2
+ (REL: rel_fence_step ð“¥1 ð“¥2) : ð“¥1 ⊑ ð“¥2.
+ Proof. inversion REL. constructor=>//=. apply frel_cur. Qed.
+
+ Lemma sc_fence_helper_tview_sqsubseteq ð“¥ ð“¥' ð“¢ ð“¢'
+ (SC: sc_fence_helper ð“¥ ð“¢ ð“¥' ð“¢') : 𓥠⊑ ð“¥'.
+ Proof.
+ inversion SC. have ?: ð“¥.(acq) ⊑ ð“¥.(acq) ⊔ ð“¢ by solve_lat.
+ subst ð“¢'. constructor; by [|rewrite frel_cur cur_acq|rewrite cur_acq|].
+ Qed.
+
+ Lemma sc_fence_step_tview_sqsubseteq ð“¥1 ð“¢1 ð“¥2 ð“¢2
+ (SC: sc_fence_step ð“¥1 ð“¢1 ð“¢2 ð“¥2) : ð“¥1 ⊑ ð“¥2.
+ Proof. inversion SC. by eapply sc_fence_helper_tview_sqsubseteq. Qed.
+
+ Lemma alloc_step_tview_sqsubseteq ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) : ð“¥1 ⊑ ð“¥2.
+ Proof. inversion ALLOC. by eapply alloc_helper_tview_sqsubseteq. Qed.
+
+ Lemma dealloc_step_tview_sqsubseteq ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2): ð“¥1 ⊑ ð“¥2.
+ Proof. inversion DEALLOC. by eapply alloc_helper_tview_sqsubseteq. Qed.
+
+ Lemma read_step_tview_sqsubseteq ð“¥1 M1 tr ð‘š o ð“¥2
+ (READ: read_step ð“¥1 M1 tr ð‘š o ð“¥2) : ð“¥1 ⊑ ð“¥2.
+ Proof. inversion READ. by eapply read_helper_tview_sqsubseteq. Qed.
+
+ Lemma write_step_tview_sqsubseteq ð“¥1 M1 ð‘š o V ð“¥2 M2
+ (WRITE: write_step ð“¥1 M1 ð‘š o V ð“¥2 M2): ð“¥1 ⊑ ð“¥2.
+ Proof. inversion WRITE. by eapply write_helper_tview_sqsubseteq. Qed.
+
+ Lemma machine_step_tview_sqsubseteq ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2
+ (STEP: machine_step ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2): ð“¥1 ⊑ ð“¥2.
+ Proof.
+ inversion STEP; subst.
+ - by eapply alloc_step_tview_sqsubseteq.
+ - by eapply dealloc_step_tview_sqsubseteq.
+ - by eapply read_step_tview_sqsubseteq.
+ - by eapply write_step_tview_sqsubseteq.
+ - etrans; [by eapply read_step_tview_sqsubseteq|by eapply write_step_tview_sqsubseteq].
+ - by apply acq_fence_step_tview_sqsubseteq.
+ - by apply rel_fence_step_tview_sqsubseteq.
+ - by eapply sc_fence_step_tview_sqsubseteq.
+ Qed.
+
+ (* na closed *)
+ Lemma memory_write_closed_na_view
+ (M1: memory) ð‘š M2 o ð“ ð“'
+ (WRITE: memory_write M1 ð‘š M2)
+ (DRF: drf_post_write ð‘š.(mloc) ð‘š.(mto) o ð“ ð“')
+ (CLOSED: ð“ ∈ M1) : ð“' ∈ M2.
+ Proof.
+ inversion DRF. case_decide; subst.
+ - apply add_awrite_id_memory. by eapply memory_write_closed_view.
+ - move => l t.
+ case (decide (l = ð‘š.(mloc))) => [->|NEq].
+ + rewrite /set_write_time /view_lookup_write lookup_partial_alter.
+ move/fmap_Some => [[t'???]/= [/fmap_Some [? [? ?]] ->]]. simplify_eq.
+ do 2 eexists. split; last by eapply memory_write_new. done.
+ + rewrite /set_write_time /view_lookup_write lookup_partial_alter_ne //.
+ move/fmap_Some => [[????]/= [? ->]].
+ by eapply memory_write_closed_view, view_lookup_w.
+ Qed.
+
+ Lemma alloc_step_closed_na ð“¥1 M1 l n ð‘šs ð“¥2 M2 ð“
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) (CLOSED: ð“ ∈ M1):
+ alloc_new_na ð“ ð‘šs ∈ M2.
+ Proof.
+ inversion ALLOC. inversion MEMALL.
+ eapply closed_na_view_list_addins; eauto.
+ Qed.
+
+ Lemma dealloc_step_closed_na ð“¥1 M1 l n ð‘šs ð“¥2 M2 ð“1
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) (CLOSED: ð“1 ∈ M1) :
+ alloc_new_na ð“1 ð‘šs ∈ M2.
+ Proof.
+ inversion DEALLOC. inversion MEMALL.
+ eapply closed_na_view_list_addins; eauto.
+ Qed.
+
+ Lemma read_step_closed_na M1 tr l o ð“1 ð“2
+ (DRF: drf_post_read l o tr ð“1 ð“2) (CLOSED: ð“1 ∈ M1): ð“2 ∈ M1.
+ Proof.
+ inversion DRF. case_decide; destruct POST; subst.
+ - by apply add_aread_id_memory. - by apply add_nread_id_memory.
+ Qed.
+
+ Lemma write_step_closed_na ð“¥1 M1 ð‘š o V ð“¥2 M2 ð“1 ð“2
+ (WRITE: write_step ð“¥1 M1 ð‘š o V ð“¥2 M2)
+ (DRF: drf_post_write ð‘š.(mloc) ð‘š.(mto) o ð“1 ð“2)
+ (CLOSED: ð“1 ∈ M1) : ð“2 ∈ M2.
+ Proof. inversion WRITE. eapply memory_write_closed_na_view; eauto. Qed.
+
+ Lemma machine_step_closed_na ð“¥1 (σ1: global) ev ot ð‘šs ð“¥2 σ2
+ (STEP: machine_step ð“¥1 σ1.(mem) σ1.(sc) ev ot ð‘šs ð“¥2 σ2.(mem) σ2.(sc))
+ (DRF: drf_post σ1.(na) ev ot ð‘šs σ2.(na))
+ (CLOSED: σ1.(na) ∈ σ1.(mem)) (WF: Wf σ1.(mem)):
+ σ2.(na) ∈ σ2.(mem).
+ Proof.
+ inversion DRF; subst; inversion STEP; subst; [..|done|done|done]; clear DRF STEP.
+ - by eapply write_step_closed_na.
+ - by eapply read_step_closed_na.
+ - inversion DRF0. destruct POST as [POST1 POST2].
+ rewrite POST1. apply add_awrite_id_memory, add_aread_id_memory.
+ eapply write_step_closed_view; eauto.
+ - by eapply dealloc_step_closed_na.
+ - by eapply alloc_step_closed_na.
+ Qed.
+
+ (* alloc_inv *)
+ Lemma alloc_step_alloc_inv ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2)
+ (AINV: alloc_inv M1):
+ alloc_inv M2.
+ Proof. inversion ALLOC. by eapply memory_alloc_alloc_inv. Qed.
+
+ Lemma dealloc_step_alloc_inv ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2)
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof. inversion DEALLOC. by eapply memory_dealloc_alloc_inv. Qed.
+
+ Lemma write_step_alloc_inv ð“¥1 M1 ð‘š o V ð“¥2 M2
+ (WRITE: write_step ð“¥1 M1 ð‘š o V ð“¥2 M2)
+ (AINV: alloc_inv M1) :
+ alloc_inv M2.
+ Proof. inversion WRITE. by eapply memory_write_alloc_inv. Qed.
+
+ Lemma machine_step_alloc_inv ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2
+ (STEP: machine_step ð“¥1 M1 ð“¢1 ev ot ð‘šs ð“¥2 M2 ð“¢2)
+ (AINV: alloc_inv M1):
+ alloc_inv M2.
+ Proof.
+ inversion STEP; auto; subst; auto;
+ [by eapply alloc_step_alloc_inv|by eapply dealloc_step_alloc_inv
+ |by eapply write_step_alloc_inv|by eapply write_step_alloc_inv].
+ Qed.
+
+ (* dealloc_na_agree *)
+ Lemma memory_write_dealloc_na_mono M1 ð‘š M2 ð“
+ (WRITE: memory_write M1 ð‘š M2)
+ (AGREE: dealloc_na_agree M1 ð“) :
+ dealloc_na_agree M2 ð“.
+ Proof.
+ inversion_clear WRITE.
+ move => l t m; case (decide ((l, t) = (mloc ð‘š, mto ð‘š))) => [Eq|NEq].
+ - rewrite Eq (lookup_mem_addins_new _ _ _ MEM) => [[<-]]. by inversion ISVAL.
+ - rewrite -(lookup_mem_addins_old_eq _ _ _ _ _ MEM NEq). by apply AGREE.
+ Qed.
+
+ Lemma mem_list_addins_dealloc_na ð‘šs M1 M2 ð“
+ (ADDINS: mem_list_addins ð‘šs M1 M2)
+ (ND: ∀ ð‘š, 𑚠∈ ð‘šs → ð“ !!w ð‘š.(mloc) ⊑ Some ð‘š.(mto))
+ (DISJ: mem_list_disj ð‘šs)
+ (AGREE: dealloc_na_agree M1 ð“) :
+ dealloc_na_agree M2 (alloc_new_na ð“ ð‘šs).
+ Proof.
+ revert M2 ADDINS.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => M2 ADDINS; inversion ADDINS; subst; [done|].
+ move => l t m /=.
+ case (decide ((l, t) = (mloc ð‘š, mto ð‘š))) => [Eq|NEq].
+ - rewrite Eq (lookup_mem_addins_new _ _ _ ADD) => [[<-]].
+ inversion Eq. by rewrite /view_lookup_write lookup_insert.
+ - rewrite -(lookup_mem_addins_old_eq _ _ _ _ _ ADD NEq).
+ have IH2: dealloc_na_agree M3 (alloc_new_na ð“ ð‘šs).
+ { apply IH; [|by eapply mem_list_disj_cons|done].
+ move => ??. apply ND. by right. }
+ etrans; first by eapply IH2.
+ rewrite /view_lookup_write.
+ case (decide (l = ð‘š.(mloc))) => [Eql|NEql];
+ [rewrite Eql lookup_insert| by rewrite lookup_insert_ne].
+ rewrite alloc_new_na_lookup_old.
+ + apply ND. by left.
+ + by apply mem_list_disj_cons_rest.
+ Qed.
+
+ Lemma alloc_dealloc_na ð“¥1 M1 l n ð‘šs ð“¥2 M2 ð“
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2)
+ (AGREE: dealloc_na_agree M1 ð“) (CLOSED: ð“ ∈ M1):
+ dealloc_na_agree M2 (alloc_new_na ð“ ð‘šs).
+ Proof.
+ inversion_clear ALLOC.
+ have DISJ := memory_alloc_disjoint _ _ _ _ _ MEMALL.
+ inversion_clear MEMALL.
+ eapply (mem_list_addins_dealloc_na _ _ _ _ ADD); [|done|done].
+ move => ð‘š /elem_of_list_lookup [n' Inð‘š].
+ destruct (ð“ !!w ð‘š.(mloc)) as [t|] eqn:Hð“; last done.
+ apply CLOSED in Hð“ as [? [? [_ Eqt]]].
+ have Lt: (n' < n)%nat by rewrite -LEN; eapply lookup_lt_Some. exfalso.
+ apply (alloc_add_fresh _ _ _ ALLOC _ Lt), memory_loc_elem_of_dom.
+ destruct (AMES _ _ Inð‘š) as [Eql _]. rewrite -Eql.
+ intros EQ. by rewrite memory_lookup_cell EQ in Eqt.
+ Qed.
+
+ Lemma dealloc_dealloc_na ð“¥1 M1 l n ð‘šs ð“¥2 M2 ð“
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2)
+ (AGREE: dealloc_na_agree M1 ð“) (CLOSED: ð“ ∈ M1):
+ dealloc_na_agree M2 (alloc_new_na ð“ ð‘šs).
+ Proof.
+ inversion_clear DEALLOC.
+ have DISJ := memory_dealloc_disjoint _ _ _ _ _ MEMALL.
+ inversion MEMALL.
+ eapply (mem_list_addins_dealloc_na _ _ _ _ ADD); [|done|done].
+ move => ð‘š Inð‘š.
+ destruct (ð“ !!w ð‘š.(mloc)) as [t|] eqn:Hð“; last done.
+ apply CLOSED in Hð“ as [? [t' [Le Eqt]]].
+ transitivity (Some t')=>//. apply Pos.lt_le_incl.
+ by apply (memory_dealloc_max _ _ _ _ _ MEMALL _ Inð‘š (mkMsg ð‘š.(mloc) t' _) Eqt).
+ Qed.
+
+ Lemma read_step_dealloc_na ð“¥1 M1 tr ð‘š o ð“¥2 ð“1 ð“2
+ (READ: read_step ð“¥1 M1 tr ð‘š o ð“¥2)
+ (DRF: drf_post_read ð‘š.(mloc) o tr ð“1 ð“2)
+ (AGREE: dealloc_na_agree M1 ð“1) (CLOSED: ð“1 ∈ M1) :
+ dealloc_na_agree M1 ð“2.
+ Proof.
+ inversion READ. inversion DRF.
+ case_decide; destruct POST; subst;
+ move => ???; [rewrite add_aread_id_eqw|rewrite add_nread_id_eqw]; by apply AGREE.
+ Qed.
+
+ Lemma write_step_dealloc_na ð“¥1 M1 ð‘š o R M2 ð“¥2 ð“1 ð“2
+ (WRITE: write_step ð“¥1 M1 ð‘š o R ð“¥2 M2)
+ (DRFPRE: drf_pre_write ð‘š.(mloc) ð“1 ð“¥1 M1 o)
+ (DRFP: drf_post_write ð‘š.(mloc) ð‘š.(mto) o ð“1 ð“2)
+ (CLOSED: ð“1 ∈ M1)
+ (AGREE: dealloc_na_agree M1 ð“1):
+ dealloc_na_agree M2 ð“2.
+ Proof.
+ inversion_clear WRITE. inversion_clear DRFPRE. inversion_clear DRFP.
+ case_decide; simplify_eq.
+ - subst. by eapply add_awrite_id_dealloc_agree, memory_write_dealloc_na_mono.
+ - move => l t m Eqm EqV.
+ etrans; first by eapply memory_write_dealloc_na_mono.
+ rewrite /view_lookup_write /set_write_time.
+ case (decide (l = ð‘š.(mloc))) => [->|NEq];
+ [rewrite lookup_partial_alter|by rewrite lookup_partial_alter_ne].
+ case Hð“: (ð“1 !! mloc ð‘š) => [[????]/=|]; last done.
+ apply view_lookup_w in Hð“.
+ destruct (CLOSED _ _ Hð“) as [mn [tn' [Le Eqmm]]].
+ transitivity (Some tn')=>//. change (Some tn' ⊑ Some ð‘š.(mto)).
+ destruct WriteNA as [LAST ?].
+ etrans; first apply (LAST (mkMsg ð‘š.(mloc) tn' mn)); auto.
+ apply strict_include. by inversion WVIEW.
+ Qed.
+
+ Lemma update_step_dealloc_na ð“¥1 M1 ð“¢1 ð‘š tr vr vw or ow ð“¥2 M2 ð“¢2 ð“1 ð“2
+ (STEP: machine_step ð“¥1 M1 ð“¢1 (Update ð‘š.(mloc) vr vw or ow) (Some tr) [ð‘š] ð“¥2 M2 ð“¢2)
+ (DRFP: drf_post_update ð‘š.(mloc) tr ð‘š.(mto) ð“1 ð“2)
+ (AGREE: dealloc_na_agree M1 ð“1)
+ (CLOSED: ð“1 ∈ M1):
+ dealloc_na_agree M2 ð“2.
+ Proof.
+ inversion STEP; subst. inversion DRFP; subst.
+ clear STEP DRFP.
+ have Eq1 := (read_step_tview_sqsubseteq _ _ _ _ _ _ READ).
+ destruct POST as [POST1 POST2]. subst ð“2.
+ apply add_awrite_id_dealloc_agree, (memory_write_dealloc_na_mono M1 ð‘š).
+ { by inversion WRITE. }
+ by apply add_aread_id_dealloc_agree.
+ Qed.
+
+ Lemma machine_step_dealloc_na (g1: global) ð“¥1 ev ot ð‘šs ð“¥2 g2
+ (STEP: machine_step ð“¥1 g1.(mem) g1.(sc) ev ot ð‘šs ð“¥2 g2.(mem) g2.(sc))
+ (DRF': drf_pre g1.(na) ð“¥1 g1.(mem) ev)
+ (DRF: drf_post g1.(na) ev ot ð‘šs g2.(na))
+ (AGREE: dealloc_na_agree g1.(mem) g1.(na))
+ (CLOSED: g1.(na) ∈ g1.(mem)):
+ dealloc_na_agree g2.(mem) g2.(na).
+ Proof.
+ inversion DRF; auto; subst; inversion DRF'; subst.
+ - inversion STEP; subst. by eapply write_step_dealloc_na.
+ - inversion STEP; subst. by eapply read_step_dealloc_na.
+ - eapply update_step_dealloc_na; eauto.
+ - inversion STEP; subst. by eapply dealloc_dealloc_na.
+ - inversion STEP; subst. by eapply alloc_dealloc_na.
+ - inversion STEP; by subst.
+ Qed.
+
+ Lemma write_step_global_wf ð‘š o σ σ' (Vr: view) ð“¥ ð“¥'
+ (WRITE: write_step 𓥠σ.(mem) ð‘š o Vr ð“¥' σ'.(mem))
+ (DRFPRE: drf_pre_write ð‘š.(mloc) σ.(na) 𓥠σ.(mem) o)
+ (DRFP: drf_post_write ð‘š.(mloc) ð‘š.(mto) o σ.(na) σ'.(na))
+ (CLOSED: 𓥠∈ σ.(mem)) (WF: Wf σ) (EQSC: σ.(sc) = σ'.(sc)):
+ Wf σ'.
+ Proof.
+ constructor.
+ - eapply write_step_mem_wf; [by eauto|by apply WF].
+ - eapply write_step_alloc_inv; [by eauto|by apply WF..].
+ - eapply write_step_dealloc_na; eauto; [by apply WF..].
+ - rewrite -EQSC. eapply write_step_closed_view; [eauto|by apply WF].
+ - eapply write_step_closed_na; [by eauto|by eauto|by apply WF..].
+ Qed.
+
+ Lemma machine_step_global_wf ð“¥ (σ: global) ev ot ð‘šs ð“¥' σ'
+ (STEP: machine_step 𓥠σ.(mem) σ.(sc) ev ot ð‘šs ð“¥' σ'.(mem) σ'.(sc))
+ (DRF': drf_pre σ.(na) 𓥠σ.(mem) ev)
+ (DRF: drf_post σ.(na) ev ot ð‘šs σ'.(na))
+ (WF: Wf σ) (CLOSED: 𓥠∈ σ.(mem)) :
+ Wf σ'.
+ Proof.
+ constructor.
+ - eapply machine_step_mem_wf; eauto; apply WF.
+ - eapply machine_step_alloc_inv; eauto; apply WF.
+ - eapply machine_step_dealloc_na; eauto; apply WF.
+ - eapply machine_step_closed_sc; eauto; apply WF.
+ - eapply machine_step_closed_na; eauto; apply WF.
+ Qed.
+
+ Lemma machine_step_config_wf c1 ev ot ð‘šs c2
+ (STEP: machine_step c1.(lc) c1.(gb).(mem) c1.(gb).(sc) ev ot ð‘šs
+ c2.(lc) c2.(gb).(mem) c2.(gb).(sc))
+ (DRF': drf_pre c1.(gb).(na) c1.(lc) c1.(gb).(mem) ev)
+ (DRF: drf_post c1.(gb).(na) ev ot ð‘šs c2.(gb).(na))
+ (WF: Wf c1) :
+ Wf c2.
+ Proof.
+ constructor.
+ - eapply machine_step_global_wf; eauto; apply WF.
+ - by eapply machine_step_closed_tview; eauto; apply WF.
+ Qed.
+
+End Wellformedness.
+
+
+Section AllocSteps.
+ Context `{!LocFacts loc} `{CVAL: Countable VAL} `{!Shift loc} `{!Allocator loc (memory loc VAL)}.
+
+ Notation memory := (memory loc VAL).
+ Notation message := (message loc VAL).
+ Notation event := (event loc VAL).
+ Notation machine_step := (@machine_step _ _ VAL _ _).
+ Notation view := (@view loc _).
+
+ Implicit Type (ð‘š: message) (M: memory) (ð“: view).
+
+ (* Lifting lemmas to alloc step level *)
+ Lemma alloc_step_mem_fresh ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ (n' : nat), (n' < n)%nat → l >> n' ∈ dom M2 ∖ dom M1.
+ Proof. inversion ALLOC. by eapply memory_alloc_fresh. Qed.
+
+ Lemma alloc_step_mem_fresh_2 ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ ð‘š, 𑚠∈ ð‘šs → ð‘š.(mloc) ∉ dom M1.
+ Proof. inversion ALLOC. by eapply memory_alloc_fresh_2. Qed.
+
+ Lemma alloc_step_cell_list_lookup ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ (n': nat) C,
+ (cell_list l n M2) !! n' = Some C
+ ↔ ∃ ð‘š, ð‘šs !! n' = Some 𑚠∧ C = {[ð‘š.(mto) := ð‘š.(mbase)]}.
+ Proof. inversion ALLOC. by eapply memory_alloc_cell_list. Qed.
+
+ Lemma alloc_step_cell_list_map ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ (cell_list l n M2) = fmap (λ ð‘š, {[ð‘š.(mto) := ð‘š.(mbase)]}) ð‘šs.
+ Proof. inversion ALLOC. by eapply memory_alloc_cell_list_map. Qed.
+
+ Lemma alloc_step_mem_lookup ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ ð‘š, 𑚠∈ ð‘šs
+ → M2 !!c ð‘š.(mloc) = {[ð‘š.(mto) := ð‘š.(mbase)]}.
+ Proof. inversion ALLOC. by eapply memory_alloc_lookup. Qed.
+
+ Lemma alloc_step_mem_insert ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ M2 = alloc_new_mem M1 ð‘šs.
+ Proof. inversion ALLOC. by eapply memory_alloc_insert. Qed.
+
+ Lemma alloc_step_disjoint ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ mem_list_disj ð‘šs.
+ Proof. inversion ALLOC. by eapply memory_alloc_disjoint. Qed.
+
+ Lemma alloc_step_loc_eq ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mloc) = l >> n'.
+ Proof. inversion ALLOC. by eapply memory_alloc_loc_eq. Qed.
+
+ Lemma alloc_step_AVal ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mbase).(mval) = AVal.
+ Proof. inversion ALLOC. by eapply memory_alloc_AVal. Qed.
+
+ Lemma alloc_step_view_None ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mbase).(mrel) = None.
+ Proof. inversion ALLOC. by eapply memory_alloc_view_None. Qed.
+
+ Lemma alloc_step_length ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ length ð‘šs = n.
+ Proof. inversion ALLOC. by eapply memory_alloc_length. Qed.
+
+ Lemma alloc_step_mem_cut ð“¥1 M1 l n ð‘šs ð“¥2 M2 ð“
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ mem_cut M2 (alloc_new_na ð“ ð‘šs) = alloc_new_mem (mem_cut M1 ð“) ð‘šs.
+ Proof. inversion ALLOC. by eapply mem_cut_memory_alloc. Qed.
+
+ Lemma dealloc_step_disjoint ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) :
+ mem_list_disj ð‘šs.
+ Proof. inversion DEALLOC. by eapply memory_dealloc_disjoint. Qed.
+
+ Lemma dealloc_step_remove ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) :
+ ∀ (n' : nat), (n' < n)%nat
+ → l >> n' ∈ (dom M1 ∖ mem_deallocated M1) ∩ mem_deallocated M2.
+ Proof. inversion DEALLOC. by eapply memory_dealloc_remove. Qed.
+
+ Lemma dealloc_step_loc_eq ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mloc) = l >> n'.
+ Proof. inversion DEALLOC. by eapply memory_dealloc_loc_eq. Qed.
+
+ Lemma dealloc_step_AVal ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ ∀ (n': nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mbase).(mval) = DVal.
+ Proof. inversion DEALLOC. by eapply memory_dealloc_DVal. Qed.
+
+ Lemma dealloc_step_length ð“¥1 M1 l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ length ð‘šs = n.
+ Proof. inversion DEALLOC. by eapply memory_dealloc_length. Qed.
+
+ Lemma dealloc_step_mem_cut ð“¥1 M1 l n ð‘šs ð“¥2 M2 ð“
+ (DEALLOC: dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2):
+ mem_cut M2 (alloc_new_na ð“ ð‘šs) = alloc_new_mem (mem_cut M1 ð“) ð‘šs.
+ Proof. inversion DEALLOC. by eapply mem_cut_memory_dealloc. Qed.
+
+ (** Progress for alloc *)
+ Definition alloc_messages (n: nat) (l : loc) : list message :=
+ fmap (λ (i: nat), mkMsg (l >> i) 1%positive (mkBMes AVal None)) (seq 0%nat n).
+
+ Definition alloc_new_tview (ð‘šs: list message) ð“¥1:=
+ foldr (λ ð‘š ð“¥, write_tview ð“¥ NonAtomic ð‘š.(mloc) ð‘š.(mto)) ð“¥1 ð‘šs.
+
+ Lemma alloc_messages_cons n l :
+ alloc_messages (S n) l =
+ mkMsg (l >> 0) 1%positive (mkBMes AVal None) :: alloc_messages n (l >> 1).
+ Proof.
+ rewrite /alloc_messages /=. f_equal. simpl. apply list_eq => i.
+ rewrite 2!list_lookup_fmap /=. case (decide (i < n)) => [Lt| Ge].
+ - do 2 (rewrite lookup_seq_lt; last done). simpl.
+ rewrite shift_nat_assoc. by f_equal.
+ - apply Nat.nlt_ge in Ge.
+ do 2 (rewrite lookup_seq_ge; last done). done.
+ Qed.
+
+ Lemma alloc_messages_shift_1 n l :
+ ∀ ð‘š , 𑚠∈ alloc_messages n (l >> 1) → l >> 0 ≠mloc ð‘š.
+ Proof.
+ move => ð‘š /elem_of_list_fmap [i [-> In]] /=.
+ rewrite (shift_nat_assoc _ 1) => /(shift_nat_inj _ 0). lia.
+ Qed.
+
+ Lemma alloc_memory_progress n l M1
+ (FRESH: alloc M1 n l):
+ let ð‘šs := alloc_messages n l in
+ memory_alloc n l ð‘šs M1 (alloc_new_mem M1 ð‘šs).
+ Proof.
+ move => ð‘šs.
+ constructor; last done.
+ - by rewrite map_length seq_length.
+ - move => n' ð‘š Eq.
+ rewrite /ð‘šs /alloc_messages in Eq.
+ apply list_lookup_fmap_inv in Eq as [i [Eq1 [Eq2 Lt]%lookup_seq]].
+ simpl in Eq2. subst i.
+ by rewrite Eq1 /=.
+ - have FRESH' := alloc_add_fresh _ _ _ FRESH.
+ rewrite /ð‘šs. clear FRESH ð‘šs.
+ revert l FRESH'.
+ induction n as [|n IH] => l FRESH.
+ + rewrite /alloc_messages /=. constructor.
+ + rewrite alloc_messages_cons /=.
+ have MA : mem_list_addins (alloc_messages n (l >> 1)) M1
+ (alloc_new_mem M1 (alloc_messages n (l >> 1))).
+ { apply (IH (l >> 1)).
+ move => n' Lt. rewrite (shift_nat_assoc _ 1). apply FRESH. by lia. }
+ econstructor; [exact MA| |done..].
+ econstructor. simpl.
+ rewrite -(mem_list_addins_old _ _ _ _ MA).
+ * rewrite (_ : _ !!c _ = ∅); first done.
+ apply memory_loc_not_elem_of_dom, (FRESH 0). by lia.
+ * apply alloc_messages_shift_1.
+ Qed.
+
+ Lemma alloc_tview_progress n l M1 ð“¥1
+ (HC: ð“¥1 ∈ M1)
+ (FRESH: alloc M1 n l):
+ let ð‘šs := alloc_messages n l in
+ alloc_helper ð‘šs ð“¥1 (alloc_new_tview ð‘šs ð“¥1).
+ Proof.
+ move => ð‘šs. rewrite /ð‘šs.
+ have FRESH' := alloc_add_fresh _ _ _ FRESH.
+ clear FRESH ð‘šs. revert l FRESH'.
+ induction n as [|n IH] => l FRESH.
+ - rewrite /alloc_messages /=. constructor.
+ - rewrite alloc_messages_cons /=.
+ set ð“¥' := alloc_new_tview (alloc_messages n (l >> 1)) ð“¥1.
+ have MA : alloc_helper (alloc_messages n (l >> 1)) ð“¥1 ð“¥'.
+ { apply (IH (l >> 1)).
+ move => n' Lt. rewrite (shift_nat_assoc _ 1). apply FRESH. by lia. }
+ clear IH.
+ have HRlx : ð“¥'.(cur) !! (l >> 0) = None. {
+ rewrite -(alloc_helper_cur_old _ _ _ _ MA);
+ last by apply alloc_messages_shift_1.
+ apply (closed_view_memory_None _ M1); last apply HC.
+ apply memory_loc_not_elem_of_dom, (FRESH 0). by lia. }
+ have HRel : ð“¥'.(rel) !! (l >> 0) = None.
+ { rewrite -(alloc_helper_rel_old _ _ _ _ MA);
+ last by apply alloc_messages_shift_1.
+ apply (not_elem_of_dom (D:=gset loc))=>/(rel_dom _ _) /elem_of_dom [[????] Eq].
+ destruct (closed_tview_cur _ _ HC _ _ (view_lookup_w _ _ _ _ _ _ Eq))
+ as [m [t' [_ Eqm]]].
+ apply (FRESH 0); first by lia. rewrite memory_lookup_cell in Eqm.
+ apply memory_loc_elem_of_dom=>EQ. by rewrite EQ in Eqm. }
+ econstructor; [exact MA|]. simpl.
+ erewrite ->threadView_eq; [econstructor|..]=>//=.
+ by rewrite (view_lookup_w' _ _ _ HRlx); compute.
+ Qed.
+
+ Lemma alloc_progress ð“¥1 M1 ð“¢1 l n
+ (CLOSED: ð“¥1 ∈ M1)
+ (ALLOC: alloc M1 (Pos.to_nat n) l):
+ let ð‘šs := alloc_messages (Pos.to_nat n) l in
+ let ð“¥2 := (alloc_new_tview ð‘šs ð“¥1) in
+ let M2 := (alloc_new_mem M1 ð‘šs) in
+ machine_step ð“¥1 M1 ð“¢1 (Alloc l n) None ð‘šs ð“¥2 M2 ð“¢1.
+ Proof.
+ move => ð‘šs. eapply PStepA. constructor.
+ - by apply alloc_memory_progress.
+ - eapply alloc_tview_progress; eauto.
+ Qed.
+
+ (** Progress for dealloc *)
+ Definition dealloc_messages (M: memory) (n: nat) (l : loc) : list message :=
+ fmap (λ (i: nat),
+ match cell_max (M !!c (l >> i)) with
+ | Some (t,_) =>
+ mkMsg (l >> i) (t+1)%positive (mkBMes DVal None)
+ | _ =>
+ mkMsg (l >> i) 1%positive (mkBMes DVal None)
+ end)
+ (seq 0%nat n).
+
+ Definition dealloc_new_mem (M: memory) (ð‘šs: list message) : memory :=
+ foldr (λ 𑚠M,
+ <[ð‘š.(mloc) := <[ð‘š.(mto) := ð‘š.(mbase)]> (M !!c ð‘š.(mloc))]> M) M ð‘šs.
+
+ Definition dealloc_new_tview (ð‘šs: list message) ð“¥1:=
+ foldr (λ ð‘š ð“¥, write_tview ð“¥ NonAtomic ð‘š.(mloc) ð‘š.(mto)) ð“¥1 ð‘šs.
+
+ Lemma dealloc_messages_cons M n l :
+ dealloc_messages M (S n) l =
+ (match (cell_max (M !!c (l >> 0))) with
+ | Some (t,_) =>
+ mkMsg (l >> 0) (t+1)%positive (mkBMes DVal None)
+ | _ =>
+ mkMsg (l >> 0) 1%positive (mkBMes DVal None)
+ end) :: dealloc_messages M n (l >> 1).
+ Proof.
+ rewrite /dealloc_messages /=. f_equal. apply list_eq => i.
+ rewrite 2!list_lookup_fmap /=. case (decide (i < n)) => [Lt| Ge].
+ - do 2 (rewrite lookup_seq_lt; last done). simpl.
+ rewrite shift_nat_assoc. by f_equal.
+ - apply Nat.nlt_ge in Ge.
+ do 2 (rewrite lookup_seq_ge; last done). done.
+ Qed.
+
+ Lemma dealloc_messages_shift_1 M n l :
+ ∀ ð‘š , 𑚠∈ dealloc_messages M n (l >> 1) → l >> 0 ≠mloc ð‘š.
+ Proof.
+ move => ð‘š /elem_of_list_fmap [i [-> In]] /=.
+ case_match; first case_match; simpl;
+ rewrite (shift_nat_assoc _ 1) => /(shift_nat_inj _ 0); lia.
+ Qed.
+
+ Lemma dealloc_messages_length M n l:
+ length (dealloc_messages M n l) = n.
+ Proof. by rewrite fmap_length seq_length. Qed.
+
+ Lemma dealloc_messages_eq_loc M n l :
+ ∀ (n': nat) ð‘š, (dealloc_messages M n l) !! n' = Some 𑚠→ ð‘š.(mloc) = l >> n'.
+ Proof.
+ move => n' ð‘š Eq.
+ have Lt: (n' < n)%nat.
+ { apply lookup_lt_Some in Eq. move : Eq. by rewrite dealloc_messages_length. }
+ move : Eq.
+ rewrite list_lookup_fmap (lookup_seq_lt _ _ _ Lt) /= => [[<-]].
+ by case_match; [case_match|].
+ Qed.
+
+ Lemma dealloc_messages_eq_loc_2 M n l :
+ ∀ ð‘š, 𑚠∈ (dealloc_messages M n l) →
+ ∃ n':nat, (dealloc_messages M n l) !! n' = Some 𑚠∧ (n' < n)%nat ∧ ð‘š.(mloc) = l >> n'.
+ Proof.
+ move => ð‘š /elem_of_list_lookup [n' Eqn'].
+ exists n'. split; [done|split]; last by eapply dealloc_messages_eq_loc.
+ apply lookup_lt_Some in Eqn'. by rewrite dealloc_messages_length in Eqn'.
+ Qed.
+
+ Lemma dealloc_messages_max M n l :
+ ∀ ð‘š, 𑚠∈ (dealloc_messages M n l) →
+ ∀ ð‘š', ð‘š' ∈ M → mloc ð‘š' = mloc 𑚠→ (mto ð‘š' < mto ð‘š)%positive.
+ Proof.
+ move => ð‘š /elem_of_list_fmap [i [-> In]] /= ð‘š' In' EQL.
+ have EQLOC: ð‘š'.(mloc) = l >> i by case_match; [case_match|]. clear EQL.
+ rewrite /elem_of /message_ElemOf memory_lookup_cell in In'.
+ assert (∃ t0 m0, cell_max (M !!c mloc ð‘š') = Some (t0, m0)) as [t0 [m0 Eqm0]]
+ by (eapply gmap_top_nonempty_2; eauto with typeclass_instances).
+ rewrite -EQLOC. rewrite Eqm0.
+ eapply Pos.le_lt_trans.
+ - eapply (gmap_top_top _ _ _ _ Eqm0), elem_of_dom_2, In'.
+ - simpl. lia.
+ Qed.
+
+ Lemma dealloc_memory_progress n l (M: memory)
+ (NEMP: ∀ (n':nat), (n' < n)%nat → M !!c (l >> n') ≠∅)
+ (DEALLOC: dealloc M n l) (AINV: alloc_inv M):
+ let ð‘šs := dealloc_messages M n l in
+ memory_dealloc n l ð‘šs M (dealloc_new_mem M ð‘šs).
+ Proof.
+ move => ð‘šs.
+ have REMOVE:= dealloc_remove _ _ _ DEALLOC.
+ constructor; last done.
+ - by rewrite map_length seq_length.
+ - move => n' ð‘š Eq. rewrite /ð‘šs /dealloc_messages in Eq.
+ apply list_lookup_fmap_inv in Eq as [i [Eq1 [Eq2 Lt]%lookup_seq]].
+ simpl in Eq2. subst i.
+ move : (REMOVE _ Lt)
+ => /elem_of_difference [/memory_loc_elem_of_dom Eqm NIN].
+ assert (∃ t m, cell_max (M !!c (l >> n')) = Some (t, m)) as [t [m Eqmx]].
+ { by apply gmap_top_nonempty; eauto. }
+ rewrite Eqmx in Eq1. rewrite Eq1 /=.
+ split; [done|split; [done|split; [done|split]]]; last first.
+ { apply gmap_top_lookup in Eqmx; eauto with typeclass_instances.
+ do 2 eexists. by rewrite memory_lookup_cell. }
+ move => t' m' Eqm'. rewrite memory_lookup_cell in Eqm'.
+ split.
+ + move => EqD. apply NIN, mem_deallocated_correct2.
+ apply cell_deallocated_correct2.
+ exists t', m'. split; [done|split;[done|]].
+ have MAX: cell_max (M !!c (l >> n')) = Some (t',m')
+ by apply (alloc_inv_max_dealloc _ AINV).
+ by apply (gmap_top_top _ _ _ _ MAX).
+ + eapply Pos.le_lt_trans.
+ * by apply (gmap_top_top _ _ _ _ Eqmx), (elem_of_dom_2 _ _ _ Eqm').
+ * lia.
+ - clear DEALLOC. revert l ð‘šs NEMP REMOVE.
+ induction n as [|n IH] => l ð‘šs NEMP REMOVE; first by constructor.
+ have MA : mem_list_addins (dealloc_messages M n (l >> 1)) M
+ (dealloc_new_mem M (dealloc_messages M n (l >> 1))).
+ { apply (IH (l >> 1));
+ [move => ??|move => ??]; rewrite (shift_nat_assoc _ 1);
+ [apply NEMP|apply REMOVE]; by lia. } clear IH.
+ rewrite /ð‘šs dealloc_messages_cons.
+ econstructor; [exact MA|..].
+ + assert (∃ t0 m0, cell_max (M !!c (l >> 0)) = Some (t0, m0)) as [t0 [m0 Eqm0]].
+ { apply gmap_top_nonempty; eauto with typeclass_instances.
+ by apply (NEMP 0); lia. }
+ have HL: M !!c (l >> 0)
+ = dealloc_new_mem M (dealloc_messages M n (l >> 1)) !!c (l >> 0).
+ { rewrite (mem_list_addins_old _ _ _ _ MA); first done.
+ apply dealloc_messages_shift_1. }
+ rewrite Eqm0. econstructor. rewrite -HL /=. constructor.
+ destruct ((M !!c (l >> 0)) !! (t0 + 1)%positive) eqn: Eqt0; last done.
+ have ? : ((t0 + 1)%positive ≤ t0)%positive.
+ { by apply (gmap_top_top _ _ _ _ Eqm0), (elem_of_dom_2 _ _ _ Eqt0). }
+ by lia.
+ + by case_match; [case_match|].
+ + by case_match; [case_match|].
+ Qed.
+
+ Lemma dealloc_tview_progress n l M1 ð“¥1
+ (HC: ð“¥1 ∈ M1)
+ (DEALLOC: dealloc M1 n l):
+ let ð‘šs := dealloc_messages M1 n l in
+ alloc_helper ð‘šs ð“¥1 (dealloc_new_tview ð‘šs ð“¥1).
+ Proof.
+ move => ð‘šs. rewrite /ð‘šs.
+ have REMOVE := dealloc_remove _ _ _ DEALLOC.
+ clear DEALLOC ð‘šs. revert l REMOVE.
+ induction n as [|n IH] => l REMOVE; first by constructor.
+ rewrite dealloc_messages_cons.
+ set ð“¥' := dealloc_new_tview (dealloc_messages M1 n (l >> 1)) ð“¥1.
+ have MA : alloc_helper (dealloc_messages M1 n (l >> 1)) ð“¥1 ð“¥'.
+ { apply (IH (l >> 1)) => n' Lt. rewrite (shift_nat_assoc _ 1).
+ apply REMOVE. by lia. } clear IH.
+ econstructor; [exact MA|].
+ econstructor=>//. remember (mloc _) as l'.
+ rewrite -(_: ð“¥1.(cur) !!w l' = ð“¥'.(cur) !!w l'); last first.
+ { rewrite (view_lookup_w' _ _ _ (alloc_helper_cur_old _ _ _ l' MA _)); [done|].
+ subst l'. by case_match; [case_match|]; apply dealloc_messages_shift_1. }
+ subst l'.
+ destruct (ð“¥1.(cur) !! (l >> 0)) as [t0|] eqn:Ht0;
+ last by (case_match; [case_match|]; rewrite /= (view_lookup_w' _ _ _ Ht0); compute).
+ apply view_lookup_w' in Ht0.
+ destruct (closed_tview_cur _ _ HC _ _ Ht0) as [mo [to [Leo Eqmo]]].
+ rewrite memory_lookup_cell in Eqmo.
+ assert (∃ tm mm, cell_max (M1 !!c (l >> 0)) = Some (tm, mm)) as [tm [mm Eqmm]].
+ { by eapply gmap_top_nonempty_2; eauto with typeclass_instances. }
+ rewrite Eqmm /= Ht0.
+ eapply (strict_transitive_r _ (Some to)); first apply Leo.
+ eapply (strict_transitive_r _ (Some tm)), total_not_strict, Pos.lt_nle; last lia.
+ apply (gmap_top_top _ _ _ _ Eqmm), (elem_of_dom_2 _ _ _ Eqmo).
+ Qed.
+
+ Lemma dealloc_progress ð“¥1 M1 ð“¢1 ð“1 l n
+ (DEALLOC: dealloc M1 (Pos.to_nat n) l)
+ (NEMP: ∀ n', (n' < Pos.to_nat n)%nat → M1 !!c (l >> n') ≠∅)
+ (DRFB: ∀ n', (n' < Pos.to_nat n)%nat → ð“1 !! (l >> n') ⊑ ð“¥1.(cur) !! (l >> n'))
+ (DRFW: ∀ n', (n' < Pos.to_nat n)%nat →
+ ∀ ð‘š', ð‘š' ∈ M1 → mloc ð‘š' = l >> n' →
+ Some (mto ð‘š') ⊑ ð“¥1.(cur) !!w (l >> n'))
+ (AINV: alloc_inv M1)
+ (CLOSED: ð“¥1 ∈ M1) :
+ drf_pre_dealloc l n ð“¥1 M1 ð“1 ∧
+ let ð‘šs := dealloc_messages M1 (Pos.to_nat n) l in
+ let ð“¥2 := (dealloc_new_tview ð‘šs ð“¥1) in
+ let M2 := (dealloc_new_mem M1 ð‘šs) in
+ machine_step ð“¥1 M1 ð“¢1 (Dealloc l n) None ð‘šs ð“¥2 M2 ð“¢1.
+ Proof.
+ split; first by constructor.
+ move => ð‘šs ð“¥2 M2. apply PStepD. constructor.
+ - by apply dealloc_memory_progress.
+ - by apply dealloc_tview_progress.
+ (* - constructor.
+ + move => ð‘š Inð‘š. econstructor; eauto. simpl.
+ destruct (dealloc_messages_eq_loc_2 _ _ _ _ Inð‘š) as [n' [Eq' [Lt' EqL]]].
+ move => ? /(DRFW _ Lt') Lt EqL'. rewrite EqL' EqL in Lt. rewrite EqL.
+ by apply Lt.
+ + move => ð‘š /dealloc_messages_eq_loc_2 [n' [Eq' [Lt' EqL]]].
+ rewrite EqL. apply view_sqsubseteq. by apply DRFB.
+ + move => ð‘š /dealloc_messages_eq_loc_2 [n' [Eq' [Lt' EqL]]].
+ rewrite EqL. apply view_sqsubseteq. by apply DRFB.
+ + move => ð‘š /dealloc_messages_eq_loc_2 [n' [Eq' [Lt' EqL]]].
+ rewrite EqL. apply view_sqsubseteq. by apply DRFB. *)
+ Qed.
+End AllocSteps.
+
+Section Steps.
+ Context `{!LocFacts loc} `{CVAL: Countable VAL} `{!Shift loc} `{!Allocator loc (memory loc VAL)}.
+
+ Notation memory := (memory loc VAL).
+ Notation message := (message loc VAL).
+ Notation event := (event loc VAL).
+ Notation machine_step := (@machine_step _ _ VAL _ _).
+ Notation view := (@view loc _).
+ Notation threadView := (@threadView loc _).
+
+ Implicit Types (M: memory) (ð‘š: message).
+
+ (* Lifting lemmas to step level *)
+ Lemma write_step_addins_fresh ð“¥1 M1 ð‘š o V ð“¥2 M2
+ (WRITE: write_step ð“¥1 M1 ð‘š o V ð“¥2 M2) (WF: Wf M1) :
+ M1 !! (ð‘š.(mloc), ð‘š.(mto)) = None.
+ Proof.
+ inversion_clear WRITE. by eapply memory_write_addins_fresh.
+ Qed.
+
+ Lemma write_step_addins_eq ð“¥1 M1 ð‘š o V ð“¥2 M2
+ (WRITE: write_step ð“¥1 M1 ð‘š o V ð“¥2 M2) :
+ M2 = <[mloc ð‘š:=<[mto ð‘š:=mbase ð‘š]> (M1 !!c mloc ð‘š)]> M1.
+ Proof.
+ inversion_clear WRITE. by eapply memory_write_addins_eq.
+ Qed.
+
+ (** Progress for read *)
+ Definition read_new_tview (o : memOrder) l t tr (R: view) ð“¥ : threadView :=
+ let V : view :=
+ if decide (Relaxed ⊑ o)
+ then {[l := [{ t, ∅, ∅, {[tr]} }] ]}
+ else {[l := [{ t, ∅, {[tr]}, ∅ }] ]} in
+ read_tview ð“¥ o R V.
+
+ Lemma tview_closed_max (ð“¥: threadView) M l tm mm
+ (CLOSED: 𓥠∈ M) (MAX: cell_max (VAL:=VAL) (M !!c l) = Some (tm, mm)) :
+ ð“¥.(cur) !!w l ⊑ Some tm.
+ Proof.
+ destruct (ð“¥.(cur) !!w l) as [ct|] eqn:Eqct; last done.
+ destruct (closed_tview_cur _ _ CLOSED _ _ Eqct) as [mt [tt [Lett Eqmt]]].
+ cbn. transitivity (Some tt)=>//.
+ apply (gmap_top_top _ _ _ _ MAX), elem_of_dom.
+ eexists. by rewrite -memory_lookup_cell.
+ Qed.
+
+ Lemma read_step_progress l o M1 ð“¥1 ð“1
+ (CLOSED: ð“¥1 ∈ M1) (WFM: Wf M1)
+ (AINV: alloc_inv M1) (ALLOC: allocated l M1)
+ (NE: M1 !!c l ≠∅):
+ (* basic na safe *)
+ let otl := ð“¥1.(cur) !!w l in ð“1 !!w l ⊑ otl →
+ (* read na safe *)
+ (o = NonAtomic →
+ (∀ ð‘š', ð‘š' ∈ M1 → ð‘š'.(mloc) = l → Some ð‘š'.(mto) ⊑ otl)
+ ∧ ð“1 !!aw l ⊑ ð“¥1.(cur) !!aw l) →
+ drf_pre_read l ð“1 ð“¥1 M1 o ∧
+ ∃ ð‘š tr ð“2, ð‘š.(mloc) = l
+ ∧ Wf ð‘š
+ ∧ (∀ t': time, is_Some (M1 !! (l,t')) → t' ⊑ ð‘š.(mto))
+ ∧ read_step ð“¥1 M1 tr ð‘š o
+ (read_new_tview o l ð‘š.(mto) tr (default ∅ ð‘š.(mbase).(mrel)) ð“¥1)
+ ∧ drf_post_read l o tr ð“1 ð“2
+ ∧ (* initialized *)
+ ((∃ t m, M1 !! (l,t) = Some m ∧ (m.(mval) = AVal → Some t ⊠otl)) →
+ isval ð‘š.(mbase).(mval)).
+ Proof.
+ move => otl VLe PLN.
+ split. { constructor; [done|]. case_decide; [done|apply PLN; by destruct o]. }
+ destruct (gmap_top_nonempty (flip (⊑)) _ NE) as [tm [mm Eqmm]].
+ have Lmm: M1 !! (l, tm) = Some mm.
+ { rewrite memory_lookup_cell.
+ eapply gmap_top_lookup, Eqmm; eauto with typeclass_instances. }
+ have Ler: ð“¥1.(cur) !!w l ⊑ Some tm
+ by apply (tview_closed_max _ M1 _ _ mm).
+ have ?: otl ⊑ Some tm. { rewrite -Ler. by apply view_sqsubseteq. }
+ set tr := if decide (Relaxed ⊑ o)
+ then fresh_aread_id ð“1 l else fresh_nread_id ð“1 l.
+ set ð“2 := if decide (Relaxed ⊑ o)
+ then add_aread_id ð“1 l tr else add_nread_id ð“1 l tr.
+ exists (mkMsg l tm mm), tr, ð“2.
+ have MAX: ∀ (t' : time) m', M1 !! (l, t') = Some m' → t' ⊑ tm.
+ { move => ???.
+ apply (gmap_top_top _ _ _ _ Eqmm), elem_of_dom.
+ eexists. by rewrite -memory_lookup_cell. }
+ split; [done|]. split; first by eapply msg_elem_wf_pre.
+ split; last split; last split.
+ - move => ? [? ?]. by eapply MAX.
+ - constructor; [|done..]. simpl. constructor; [done|].
+ destruct mm.(mrel) as [Vmm|] eqn:EqVmm; [|done].
+ rewrite /= (_: Some tm = Vmm !!w l); [done|]. move : EqVmm.
+ have WFm: Wf (mkMsg l tm mm) by eapply msg_elem_wf_pre.
+ apply WFm.
+ - constructor; simpl. by case_decide.
+ - move => [ti [mi [Eqmi Lti]]] /=. rewrite memory_lookup_cell in Eqmi.
+ destruct mm.(mval) eqn:Hmv; [|exfalso; by apply (ALLOC tm mm)|done].
+ have CM: cell_min (M1 !!c l) = Some (tm, mm).
+ { apply (alloc_inv_min_alloc _ AINV). by rewrite -memory_lookup_cell. }
+ have ?: ti ∈ dom (M1 !!c l) by apply elem_of_dom; eexists.
+ have ?: tm = ti.
+ { apply : (anti_symm (⊑)).
+ - by apply (gmap_top_top _ _ _ _ CM).
+ - by eapply (gmap_top_top _ _ _ _ Eqmm). }
+ subst ti. rewrite memory_lookup_cell in Lmm.
+ rewrite Eqmi in Lmm. inversion Lmm. subst. specialize (Lti Hmv).
+ edestruct (irreflexivity (âŠ) otl). by eapply strict_transitive_r.
+ Qed.
+
+ Lemma read_progress ð“¥1 M1 ð“¢1 ð“1 l o
+ (CLOSED: ð“¥1 ∈ M1) (WFM: Wf M1)
+ (AINV: alloc_inv M1) (ALLOC: allocated l M1)
+ (NE: M1 !!c l ≠∅):
+ (* basic na safe *)
+ let otl := ð“¥1.(cur) !!w l in ð“1 !!w l ⊑ otl →
+ (* read na safe *)
+ (o = NonAtomic →
+ (∀ ð‘š', ð‘š' ∈ M1 → mloc ð‘š' = l → Some (mto ð‘š') ⊑ otl)
+ ∧ ð“1 !!aw l ⊑ ð“¥1.(cur) !!aw l) →
+ drf_pre_read l ð“1 ð“¥1 M1 o ∧
+ ∃ ð“¥2 ð“2 tr v, machine_step ð“¥1 M1 ð“¢1 (Read l v o) (Some tr) [] ð“¥2 M1 ð“¢1
+ ∧ drf_post_read l o tr ð“1 ð“2
+ ∧ (* initialized *)
+ ((∃ t m, M1 !! (l,t) = Some m ∧ (m.(mval) = AVal → Some t ⊠otl))
+ → isval v).
+ Proof.
+ move => otl VLe PLN.
+ destruct (read_step_progress _ _ _ _ _ CLOSED WFM AINV ALLOC NE VLe PLN)
+ as [DRFPR [ð‘š [tr [ð“2 [EQL [_ [_ [RS [DRF ISVAL]]]]]]]]].
+ split; [done|].
+ exists (read_new_tview o l ð‘š.(mto) tr (default ∅ ð‘š.(mbase).(mrel)) ð“¥1),
+ ð“2, tr, ð‘š.(mbase).(mval).
+ subst l. split; [by eapply (PStepR _ _ _ ð‘š)|done].
+ Qed.
+
+ (** Progress for writes *)
+ Definition write_new_na (o : memOrder) l t ð“ : view :=
+ if decide (Relaxed ⊑ o) then add_awrite_id ð“ l t else set_write_time ð“ l t.
+
+ Definition write_new_mview o l t Vr ð“¥ : option view :=
+ let V : view :=
+ if decide (Relaxed ⊑ o) then {[l := [{t, {[t]}, ∅,∅ }] ]}
+ else {[l := [{t, ∅, ∅,∅ }] ]} in
+ let Vra := if decide (AcqRel ⊑ o) then ð“¥.(cur) ⊔ V else V in
+ let V' := default ∅ (ð“¥.(rel) !! l) ⊔ Vra in
+ if decide (Relaxed ⊑ o) then Some (V' ⊔ ð“¥.(frel) ⊔ Vr) else None.
+
+ Lemma write_new_mview_na_time o l t Vr ð“¥:
+ 𓥠.(cur) !!w l ⊑ Some t → Vr !!w l ⊑ Some t →
+ (default ∅ (write_new_mview o l t Vr ð“¥)) !!w l ⊑ Some t.
+ Proof.
+ rewrite /write_new_mview => Le1 Le2. case_match; [|done]. simpl.
+ rewrite 3!view_lookup_w_join.
+ apply lat_join_lub; [|done].
+ apply lat_join_lub; [|rewrite -Le1; apply view_sqsubseteq, frel_cur].
+ have ?: ({[l := [{ t, {[t]},∅,∅ }] ]} : view) !!w l ⊑ Some t.
+ { rewrite (view_lookup_w _ l t {[t]} ∅ ∅); [done|].
+ by rewrite /= lookup_insert. }
+ apply lat_join_lub; [|case decide => ? //].
+ - have Lel := rel_cur ð“¥ l. destruct (ð“¥.(rel) !! l); [|done].
+ etrans; [apply view_sqsubseteq,Lel|done].
+ - rewrite view_lookup_w_join. by apply lat_join_lub.
+ Qed.
+
+ Lemma write_new_mview_message_wf o (l : loc) t (v : val) (Vr: view) ð“¥:
+ 𓥠.(cur) !!w l ⊑ Some t → Vr !!w l ⊑ Some t →
+ Wf (mkMsg (VAL:=VAL) l t (mkBMes v (write_new_mview o l t Vr ð“¥))).
+ Proof.
+ move => Le1 Le2 V /= LE. apply : anti_symm.
+ - rewrite (_ : V = default ∅ (Some V)); [|done]. rewrite -LE.
+ by apply write_new_mview_na_time.
+ - move : LE. rewrite /write_new_mview. case_match; last done.
+ have ?: Some t ⊑ ({[l := [{ t, {[t]}, ∅, ∅ }] ]}: view) !!w l
+ by rewrite view_lookup_w_insert.
+ move => [<-].
+ destruct (ð“¥.(rel) !! l); case_match => /=;
+ rewrite ?view_lookup_w_join; solve_lat.
+ Qed.
+
+ Lemma write_new_mview_closed o l (t : time) v (Vr: view) ð“¥ M1 C V'
+ (MAX : ∀ t' : time, is_Some (M1 !! (l, t')) → (t' < t)%positive)
+ (CLOSED: 𓥠∈ M1) (CLOSEDV: Vr ∈ M1):
+ (write_new_mview o l t Vr ð“¥) ∈
+ (<[l := (<[t := mkBMes (VAL:=VAL) v V']>C) ]>M1).
+ Proof.
+ rewrite /write_new_mview.
+ set V : time_ids → view := λ ws, {[l := [{ t,ws,∅,∅ }] ]}.
+ set M2: memory := <[l := (<[t := mkBMes (VAL:=VAL) v V' ]>C) ]>M1.
+ have INV: ∀ ws, V ws ∈ M2.
+ { move => ? l1 t1 Eq1. apply view_lookup_w_singleton_Some in Eq1 as [??].
+ subst l1 t1. eexists. exists t.
+ split; [done|by rewrite lookup_mem_first_eq lookup_insert]. }
+ have ?: ð“¥.(cur) ∈ M2.
+ { move => l1 t1.
+ case (decide (l1 = l)) => [->|?] Eqt1.
+ - rewrite /M2. setoid_rewrite lookup_mem_first_eq.
+ eexists. exists t. rewrite lookup_insert. split; last done.
+ apply CLOSED in Eqt1 as [m2 [t2 [Le2 Eqt2]]].
+ etrans; first exact Le2. apply Pos.lt_le_incl, MAX. by eexists.
+ - apply CLOSED in Eqt1 as [m2 [t2 Eqt2]].
+ exists m2, t2. by rewrite (lookup_mem_first_ne l l1) //. }
+ have ?: ð“¥.(frel) ∈ M2 by rewrite frel_cur.
+ have ?: Vr ∈ M2.
+ { move => l1 t1.
+ case (decide (l1 = l)) => [->|?] Eqt1.
+ - rewrite /M2. setoid_rewrite lookup_mem_first_eq.
+ eexists. exists t. rewrite lookup_insert. split; last done.
+ apply CLOSEDV in Eqt1 as [m2 [t2 [Le2 Eqt2]]].
+ etrans; first exact Le2. apply Pos.lt_le_incl, MAX. by eexists.
+ - apply CLOSEDV in Eqt1 as [m2 [t2 Eqt2]].
+ exists m2, t2. by rewrite (lookup_mem_first_ne l l1) //. }
+ case_match; last done. destruct (ð“¥.(rel) !! l) as [V0|] eqn:EQV.
+ - have CLOSED0: V0 ∈ M1.
+ { change (Some V0 ∈ M1). rewrite -EQV. apply CLOSED. }
+ have ?: V0 ∈ M2.
+ { move => l1 t1.
+ case (decide (l1 = l)) => [->|?] Eqt1.
+ - rewrite /M2. setoid_rewrite lookup_mem_first_eq.
+ eexists. exists t. rewrite lookup_insert. split; last done.
+ apply CLOSED0 in Eqt1 as [m2 [t2 [Le2 Eqt2]]].
+ etrans; first exact Le2. apply Pos.lt_le_incl, MAX. by eexists.
+ - apply CLOSED0 in Eqt1 as [m2 [t2 Eqt2]].
+ exists m2, t2. by rewrite (lookup_mem_first_ne l l1). }
+ case_match; simpl; repeat apply join_closed_view => //; apply INV.
+ - case_match; simpl; repeat apply join_closed_view=>//; apply INV.
+ Qed.
+
+ Lemma memory_write_addins_progress ð“¥ l o t v (Vr: view) M1 m
+ (CLOSED: 𓥠∈ M1) (CLOSEDV: Vr ∈ M1)
+ (ALLOC: allocated l M1) (Eqm: M1 !! (l, t) = Some m)
+ (MAX: ∀ t': time, is_Some (M1 !! (l,t')) → t' ⊑ t):
+ let VR := write_new_mview o l (t+1)%positive Vr ð“¥ in
+ let ð‘š := mkMsg l (t+1)%positive (mkBMes (VVal v) VR) in
+ ∃ M2, memory_write (VAL:=VAL) M1 𑚠M2.
+ Proof.
+ move => VR ð‘š.
+ exists (<[l := (<[(t+1)%positive := ð‘š.(mbase) ]>(M1 !!c l)) ]>M1).
+ constructor; [..|done|done|].
+ - econstructor; first eauto. constructor.
+ destruct ((M1 !!c l) !! (t + 1)%positive) eqn: Eqt0; last done.
+ have ? : ((t + 1)%positive ≤ t)%positive.
+ { apply MAX. eexists. by rewrite memory_lookup_cell. } lia.
+ - have Le: ∀ V, V ∈ M1 → V !!w l ⊑ Some (t + 1)%positive.
+ { move => V CV.
+ destruct (V !!w l) as [tv|] eqn: Eqtv; [|done].
+ apply CV in Eqtv as [m' [to' [Le' Eq']]].
+ change (tv ≤ (t + 1))%positive. etrans; [apply Le'|].
+ etrans; [apply MAX; by eexists|]. lia. }
+ eapply write_new_mview_message_wf; eauto. apply Le, CLOSED.
+ - apply write_new_mview_closed; auto.
+ move => ? /MAX Le. eapply Pos.le_lt_trans; first exact Le. lia.
+ - exists t. split; first by eauto. simpl. lia.
+ Qed.
+
+ Lemma write_step_addins_progress l o v t m (Vr: view) M1 ð“¥1 ð“1
+ (CLOSED: ð“¥1 ∈ M1)
+ (AINV: alloc_inv M1) (ALLOC: allocated l M1)
+ (Eqm: M1 !! (l, t) = Some m)
+ (MAX: ∀ t': time, is_Some (M1 !! (l,t')) → t' ⊑ t)
+ (CLOSEDV: Vr ∈ M1) (NAR: ð“1 !!nr l ⊑ ð“¥1.(cur) !!nr l) :
+ (* na write safe *)
+ let ot := ð“¥1.(cur) in ð“1 !!w l ⊑ ot !!w l →
+ (o = NonAtomic →
+ (∀ ð‘š', ð‘š' ∈ M1 → mloc ð‘š' = l → Some (mto ð‘š') ⊑ ot !!w l) ∧
+ (ð“1 !!aw l ⊑ ð“¥1.(cur) !!aw l) ∧
+ (ð“1 !!ar l ⊑ ð“¥1.(cur) !!ar l)) →
+ drf_pre_write l ð“1 ð“¥1 M1 o ∧
+ let VR := write_new_mview o l (t+1)%positive Vr ð“¥1 in
+ let ð‘š := mkMsg l (t+1)%positive (mkBMes (VVal v) VR) in
+ ∃ ð“¥2 M2,
+ write_step ð“¥1 M1 ð‘š o Vr ð“¥2 M2 ∧ ð‘š.(mloc) = l ∧
+ drf_post_write l (t + 1)%positive o ð“1 (write_new_na o l (t + 1)%positive ð“1).
+ Proof.
+ move => otl Vnaw Vna. split.
+ { econstructor; [done..|]. case_match; [done|]. apply Vna. by destruct o. }
+ move => NAW ð‘š.
+ destruct (memory_write_addins_progress _ _ o t v _ _ _
+ CLOSED CLOSEDV ALLOC Eqm MAX) as [M2 WRITE].
+ have Ler: ð“¥1.(cur) !!w l ⊑ Some t.
+ { apply (tview_closed_max _ M1 _ _ m); [done|].
+ rewrite memory_lookup_cell in Eqm.
+ apply gmap_top_inv; eauto with typeclass_instances.
+ move => ? /elem_of_dom [??].
+ apply MAX. rewrite memory_lookup_cell. by eexists. }
+ eexists. exists M2. split; last split; [|done|].
+ - econstructor; [done|]. econstructor; eauto; simpl.
+ eapply strict_transitive_r; first by eauto.
+ apply total_not_strict, Pos.lt_nle. lia.
+ - econstructor. rewrite /write_new_na. by case_match.
+ Qed.
+
+ Lemma write_addins_progress ð“¥1 M1 ð“¢1 ð“1 l o v
+ (CLOSED: ð“¥1 ∈ M1)
+ (AINV: alloc_inv M1) (ALLOC: allocated l M1)
+ (NEMP: ∃ t, is_Some (M1 !! (l,t)))
+ (* write na safe *) (Vler: ð“1 !!nr l ⊑ ð“¥1.(cur) !!nr l):
+ let ot := ð“¥1.(cur) in ð“1 !!w l ⊑ ot !!w l →
+ (o = NonAtomic →
+ (∀ ð‘š', ð‘š' ∈ M1 → mloc ð‘š' = l → Some (mto ð‘š') ⊑ ot !!w l) ∧
+ (ð“1 !!aw l ⊑ ot !!aw l) ∧ (ð“1 !!ar l ⊑ ot !!ar l)) →
+ drf_pre_write l ð“1 ð“¥1 M1 o ∧
+ ∃ ð‘š ð“¥2 M2, machine_step ð“¥1 M1 ð“¢1 (Write l v o) None [ð‘š] ð“¥2 M2 ð“¢1 ∧ ð‘š.(mloc) = l ∧
+ drf_post_write l ð‘š.(mto) o ð“1 (write_new_na o l ð‘š.(mto) ð“1).
+ Proof.
+ move => otl Vlew Vna.
+ destruct NEMP as [ts [ms Eqms]]. rewrite memory_lookup_cell in Eqms.
+ destruct (gmap_top_nonempty_2 (flip (⊑)) _ _ _ Eqms) as [t [m Eqm]].
+ assert (EqL := gmap_top_lookup _ _ _ _ Eqm). rewrite -memory_lookup_cell in EqL.
+ set MAX:= gmap_top_top _ _ _ _ Eqm.
+ destruct (write_step_addins_progress _ o v t _ ∅ _ _ ð“1
+ CLOSED AINV ALLOC EqL)
+ as [DRFPR [ð“¥2 [M2 [WRITE [EQL DRF]]]]]; [..|done|done|done|done|].
+ { move => t' [m' Eqt'].
+ apply (gmap_top_top _ _ _ _ Eqm), (elem_of_dom (M:=gmap time)).
+ rewrite -memory_lookup_cell. by eexists. }
+ split; [done|].
+ exists (mkMsg l (t + 1) (mkBMes (VVal v) (write_new_mview o l (t + 1) ∅ ð“¥1))).
+ do 2 eexists. split; [|done].
+ eapply (PStepW _ _ _ (mkMsg l _ (mkBMes (VVal v) _))); eauto.
+ Qed.
+
+ Lemma read_step_stronger_read ð“¥ (M: memory) tr ð‘š or1 or2 :
+ let ð“¥': memOrder → threadView :=
+ λ o, read_new_tview o ð‘š.(mloc) ð‘š.(mto) tr (default ∅ ð‘š.(mbase).(mrel)) ð“¥ in
+ Relaxed ⊑ or1 → read_step ð“¥ M tr ð‘š or1 (ð“¥' or1) → read_step ð“¥ M tr ð‘š or2 (ð“¥' or2).
+ Proof.
+ move => ð“¥' oLE. inversion 1; subst; simpl.
+ constructor; [|done..]. inversion READ. simpl in *. by constructor.
+ Qed.
+
+ Lemma read_step_relaxed ð“¥ ð“¥' (M: memory) ð‘š tr or1 or2:
+ Relaxed ⊑ or1 → read_step ð“¥ M tr ð‘š or1 ð“¥' →
+ ∃ ð“¥2, read_step ð“¥ M tr ð‘š or2 ð“¥2.
+ Proof.
+ move => oLE. inversion 1. subst; simpl in *.
+ inversion READ. subst; simpl in *.
+ eexists. constructor; [|done..]. by constructor.
+ Qed.
+
+ (* We match updates with C/Rust CASes, which have success/failure modes,
+ thus effectively correspond to 3 access modes: read failure mode orf,
+ read success mode or, and write success mod ow.
+ C11 requires that orf ⊑ or. This condition is removed in C17.
+ Additionally, progress forbids non-atomic CASes. *)
+ Lemma update_read_write_addins_progress ð“¥1 M1 ð“¢1 ð“1 l vr vw orf or ow
+ (CLOSED: ð“¥1 ∈ M1)
+ (AINV: alloc_inv M1) (WFM: Wf M1)
+ (ALLOC: allocated l M1) (NE: M1 !!c l ≠∅)
+ (RLX: Relaxed ⊑ orf) (RLX1: Relaxed ⊑ or) (RLX2: Relaxed ⊑ ow)
+ (* basic na safe *) (VLer: ð“1 !!nr l ⊑ ð“¥1.(cur) !!nr l) :
+ let ot := ð“¥1.(cur) in ð“1 !!w l ⊑ ot !!w l →
+ (* initialized *)
+ (∃ t m, M1 !! (l,t) = Some m ∧ (m.(mval) = AVal → Some t ⊠ot !!w l) ) →
+ drf_pre ð“1 ð“¥1 M1 (Update l vr vw or ow) ∧
+ ((∃ ð“¥2 M2 ð“2 v tr,
+ v ≠vr ∧
+ machine_step ð“¥1 M1 ð“¢1 (Read l (VVal v) orf) (Some tr) [] ð“¥2 M2 ð“¢1 ∧
+ drf_post_read l orf tr ð“1 ð“2)
+ ∨ (∃ ð“¥2 M2 ð“2 tr ð‘š,
+ machine_step ð“¥1 M1 ð“¢1 (Update l vr vw or ow) (Some tr) [ð‘š] ð“¥2 M2 ð“¢1 ∧ ð‘š.(mloc) = l ∧
+ drf_post_update l tr ð‘š.(mto) ð“1 ð“2)).
+ Proof.
+ move => otl VLe INIT. split.
+ { constructor.
+ - constructor; [done|by rewrite (decide_True _ _ RLX1)].
+ - constructor; [done..|by rewrite (decide_True _ _ RLX2)]. }
+ destruct (read_step_progress _ orf _ _ ð“1 CLOSED WFM AINV ALLOC NE VLe)
+ as [DRFPR [ð‘š [tr [ð“2 [EQL [WFm [MAx [RS [DRFPS ISVAL]]]]]]]]];
+ [move => ?; by subst orf|].
+ specialize (ISVAL INIT). inversion ISVAL as [vm Eqvm].
+ set ð“¥2 : memOrder → threadView :=
+ λ o, read_new_tview o l ð‘š.(mto) tr (default ∅ ð‘š.(mbase).(mrel)) ð“¥1.
+ case (decide (vm = vr)) => ?; last first.
+ { left. exists (ð“¥2 orf), M1, ð“2, vm, tr. split; first done. subst l.
+ rewrite Eqvm. split; [by eapply (PStepR _ _ _ ð‘š)|done]. }
+ subst vm l.
+ have IN: 𑚠∈ M1 by inversion RS; inversion READ.
+ have RS':= read_step_stronger_read _ _ _ _ _ or RLX RS.
+ have LE':= read_step_tview_sqsubseteq _ _ _ _ _ _ RS'.
+ have ?: ð“2 = add_aread_id ð“1 ð‘š.(mloc) tr. {
+ clear - DRFPS RLX. inversion DRFPS. subst.
+ rewrite decide_True in POST; [apply POST|done]. } subst ð“2.
+ destruct (write_step_addins_progress ð‘š.(mloc) ow vw ð‘š.(mto) ð‘š.(mbase)
+ (default ∅ ð‘š.(mbase).(mrel))
+ M1 (ð“¥2 or) (add_aread_id ð“1 ð‘š.(mloc) tr))
+ as [DRFWP [ð“¥3 [M2 [WRITE DRFW]]]]; auto.
+ - by apply (read_step_closed_tview _ _ _ _ _ _ RS').
+ - have ?:= mem_wf_closed _ WFM _ _ _ IN.
+ by destruct ð‘š.(mbase).(mrel).
+ - rewrite add_aread_id_eqnr VLer. by apply view_sqsubseteq, LE'.
+ - rewrite add_aread_id_eqw VLe. by apply view_sqsubseteq, LE'.
+ - move => ?. by subst.
+ - right. exists ð“¥3, M2. eexists. exists tr. eexists. split.
+ + by eapply (PStepU _ _ _ _ (mkMsg _ (ð‘š.(mto) + 1) (mkBMes _ _))); eauto.
+ + constructor; simpl; [done|]. inversion DRFPS. inversion DRFW.
+ subst. constructor. split; [done|].
+ rewrite (decide_True _ _ RLX) in POST. by destruct POST.
+ Qed.
+
+ Lemma acq_fence_progress ð“¥1 M1 ð“¢1:
+ ∃ ð“¥2, machine_step ð“¥1 M1 ð“¢1 (Fence AcqRel Relaxed) None [] ð“¥2 M1 ð“¢1.
+ Proof. eexists. do 2 constructor. Qed.
+
+ Lemma rel_fence_progress ð“¥1 M1 ð“¢1:
+ ∃ ð“¥2, machine_step ð“¥1 M1 ð“¢1 (Fence Relaxed AcqRel) None [] ð“¥2 M1 ð“¢1.
+ Proof. eexists. do 2 constructor. Qed.
+
+ Lemma sc_fence_progress ð“¥1 M1 ð“¢1:
+ ∃ ð“¥2 ð“¢2, machine_step ð“¥1 M1 ð“¢1 (Fence SeqCst SeqCst) None [] ð“¥2 M1 ð“¢2.
+ Proof. do 2 eexists. constructor. constructor=>//=. Qed.
+
+End Steps.
diff --git a/orc11/thread.v b/orc11/thread.v
new file mode 100644
index 0000000000000000000000000000000000000000..8e74b2adc811d2a46520c5adf4678f928709c16f
--- /dev/null
+++ b/orc11/thread.v
@@ -0,0 +1,747 @@
+From stdpp Require Import numbers.
+From orc11 Require Export tview event.
+
+Require Import stdpp.options.
+
+Section Thread.
+
+ Context `{!LocFacts loc} `{CVAL: Countable VAL} `{!Shift loc} `{!Allocator loc (memory loc VAL)}.
+
+ Notation memory := (memory loc VAL).
+ Notation message := (message loc VAL).
+ Notation event := (event loc VAL).
+ Notation view := (@view loc _).
+ Notation threadView := (@threadView loc).
+
+ Record global := mkGB {
+ sc: view;
+ na : view;
+ mem: memory
+ }.
+ Record config := mkCFG { lc: threadView; gb : global; }.
+
+ Implicit Type (ð‘š: message) (M: memory) (ð“: view) (G: global)
+ (c: config) (ð“¥: threadView).
+
+ Definition dealloc_na_agree M ð“ :=
+ ∀ l t m, M !! (l, t) = Some m → m.(mval) = DVal → Some t ⊑ ð“ !!w l.
+
+ Record global_wf' G := {
+ global_wf_mem : Wf G.(mem);
+ global_wf_alloc : alloc_inv G.(mem);
+ global_wf_dealloc_na : dealloc_na_agree G.(mem) G.(na);
+ global_wf_sc : G.(sc) ∈ G.(mem);
+ global_wf_na : G.(na) ∈ G.(mem);
+ }.
+ Global Instance global_wf : Wellformed global := global_wf'.
+
+ Record global_le g1 g2 :=
+ mkGlobalSqSubsetEq {
+ global_sqsubseteq_sc : g1.(sc) ⊑ g2.(sc) ;
+ global_sqsubseteq_na : g1.(na) = g2.(na) ; (* YES WE CAN *)
+ global_sqsubseteq_mem : memory_le g1.(mem) g2.(mem)
+ }.
+ Global Instance global_sqsubseteq : SqSubsetEq global := global_le.
+
+ Global Instance global_sqsubseteq_po :
+ PartialOrder ((⊑) : SqSubsetEq global).
+ Proof.
+ constructor; [constructor|]; [done|..].
+ - intros [][][] [][]. constructor; intros; by etrans.
+ - intros [][] [][]. simpl in *. f_equal; [|done|].
+ + by apply : (anti_symm (⊑)).
+ + by apply : (anti_symm memory_le).
+ Qed.
+
+ Record config_wf' c := {
+ config_wf_global: Wf c.(gb);
+ config_wf_closed_tview : c.(lc) ∈ c.(gb).(mem);
+ }.
+ Global Instance config_wf : Wellformed config := config_wf'.
+
+ Record config_le c1 c2 :=
+ mkCFGSqSubsetEq {
+ config_sqsubseteq_local : c1.(lc) ⊑ c2.(lc) ;
+ config_sqsubseteq_global : c1.(gb) ⊑ c2.(gb) ;
+ }.
+ Global Instance config_sqsubseteq : SqSubsetEq config := config_le.
+
+ Global Instance config_sqsubseteq_po :
+ PartialOrder ((⊑) : SqSubsetEq config).
+ Proof.
+ split; [split|]; [done|..].
+ - intros [][][] [][]. split; by etrans.
+ - intros [][] [][]. simpl in *. f_equal; by apply : (anti_symm (⊑)).
+ Qed.
+
+ (** Thread-local non-promising steps *)
+
+ (* <ð“¥ ,M> -{ R(l,v,o) }-> <ð“¥ ',M> *)
+ Inductive read_step ð“¥1 M1 tr ð‘š o ð“¥2: Prop :=
+ | ReadStep
+ (READ: read_helper ð“¥1 o ð‘š.(mloc) ð‘š.(mto) tr (default ∅ ð‘š.(mbase).(mrel)) ð“¥2)
+ (IN: 𑚠∈ M1)
+ (ALLOC: allocated ð‘š.(mloc) M1).
+
+ (* <ð“¥,M> -{ W(l,v,o) }-> <ð“¥',M'> *)
+ Inductive write_step ð“¥1 M1 ð‘š o V ð“¥2 M2: Prop :=
+ | WriteStep
+ (WRITE: memory_write M1 ð‘š M2)
+ (WVIEW : write_helper ð“¥1 o ð‘š.(mloc) ð‘š.(mto) V ð‘š.(mbase).(mrel) ð“¥2).
+
+ (* <ð“¥,M> -{ U(l,vr,vw,or,ow) }-> <ð“¥',M'> *)
+ (* Inductive update_step L1 M1 ð‘š1 ð‘š2 or ow: bool → local → memory → Prop :=
+ | UpdateStep ð“¥2 ð“¥3 M3 b
+ (READ: read_step L1 M1 ð‘š1 or ð“¥2)
+ (WRITE: write_step ð“¥2 M1 ð‘š2 ow b (default ∅ ð‘š1.(mbase).(mrel)) ð“¥3 M3)
+ (ADJ: ð‘š1.(mto) = ð‘š2.(mbase).(mfrom))
+ (SAME: ð‘š1.(mloc) = ð‘š2.(mloc))
+ : update_step L1 M1 ð‘š1 ð‘š2 or ow b ð“¥3 M3. *)
+
+ (* ð“¥> -{ F_acq }-> ð“¥ ' *)
+ Program Definition acq_fence_tview ð“¥ :=
+ mkTView ð“¥.(rel) ð“¥.(frel) ð“¥.(acq) ð“¥.(acq) _ _ _ _.
+ Next Obligation.
+ intros. apply bool_decide_pack. etrans; [apply rel_dom|]. by rewrite cur_acq.
+ Qed.
+ Next Obligation. intros. apply bool_decide_pack=>l. by rewrite rel_cur cur_acq. Qed.
+ Next Obligation. intros. apply bool_decide_pack. by rewrite frel_cur cur_acq. Qed.
+ Next Obligation. intros. by apply bool_decide_pack. Qed.
+
+ Inductive acq_fence_step 𓥠: threadView → Prop :=
+ | AcqFenceStep : acq_fence_step ð“¥ (acq_fence_tview ð“¥).
+
+ (* ð“¥ -{ F_rel }-> <ð“¥ ',P> *)
+ Program Definition rel_fence_tview ð“¥ :=
+ mkTView ð“¥.(rel) ð“¥.(cur) ð“¥.(cur) ð“¥.(acq) _ _ _ _.
+ Next Obligation. intros. apply bool_decide_pack, rel_dom. Qed.
+ Next Obligation. intros. apply bool_decide_pack, rel_cur. Qed.
+ Next Obligation. intros. by apply bool_decide_pack. Qed.
+ Next Obligation. intros. apply bool_decide_pack, cur_acq. Qed.
+ Inductive rel_fence_step ð“¥: threadView → Prop :=
+ | RelFenceStep
+ : rel_fence_step ð“¥ (rel_fence_tview ð“¥).
+
+ (* <ð“¥,ð“¢> -{ F_sc }-> <<ð“¥ ',P>,ð“¢'> *)
+ Inductive sc_fence_step ð“¥ ð“¢: view → threadView → Prop :=
+ | SCFenceStep ð“¢' ð“¥'
+ (SC: sc_fence_helper ð“¥ ð“¢ ð“¥' ð“¢')
+ : sc_fence_step ð“¥ ð“¢ ð“¢' ð“¥'.
+
+ (* <ð“¥ ,M> -{ Alloc(l,n) }-> <ð“¥ ',M'> *)
+ Inductive alloc_step ð“¥1 M1 l n ð‘šs: threadView → memory → Prop :=
+ | AllocStep M2 ð“¥2
+ (MEMALL: memory_alloc n l ð‘šs M1 M2)
+ (VALL: alloc_helper ð‘šs ð“¥1 ð“¥2)
+ : alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2.
+
+ (* <ð“¥ ,M> -{ Dealloc(l,n) }-> <ð“¥ ',M'> *)
+ Inductive dealloc_step ð“¥1 M1 l n: list message → threadView → memory → Prop :=
+ | DeallocStep ð‘šs M2 ð“¥2
+ (MEMALL: memory_dealloc n l ð‘šs M1 M2)
+ (VALL: alloc_helper ð‘šs ð“¥1 ð“¥2)
+ : dealloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2.
+
+ (* DRF steps *)
+ Definition fresh_aread_id (ð“ : view) l :=
+ fresh (default ∅ (ð“ !!ar l)).
+ Definition fresh_nread_id (ð“ : view) l :=
+ fresh (default ∅ (ð“ !!nr l)).
+
+ Definition add_aread_id (V : view) l r :=
+ partial_alter
+ (λ o, (λ p, [{ p.(twrite), p.(tawrite), p.(tnread), {[r]} ∪ p.(taread) }]) <$> o)
+ l V.
+ Definition add_nread_id (V : view) l r :=
+ partial_alter
+ (λ o, (λ p, [{ p.(twrite), p.(tawrite), {[r]} ∪ p.(tnread), p.(taread) }]) <$> o)
+ l V.
+ Definition add_awrite_id (V : view) l w :=
+ partial_alter
+ (λ o, (λ p, [{ p.(twrite), {[w]} ∪ p.(tawrite), p.(tnread), p.(taread) }]) <$> o)
+ l V.
+ Definition set_write_time (V : view) l t :=
+ partial_alter (λ o, (λ p, [{ t, p.(tawrite), p.(tnread), p.(taread) }]) <$> o) l V.
+
+ Lemma add_aread_id_sqsubseteq V l r :
+ V ⊑ add_aread_id V l r.
+ Proof.
+ intros l'. rewrite /add_aread_id.
+ case: (decide (l' = l)).
+ - move => -> {l'}. rewrite lookup_partial_alter.
+ move: (V !! l) => [/=[????]|//].
+ repeat split; simpl; [done..|]. set_solver.
+ - move => ?. rewrite lookup_partial_alter_ne //.
+ Qed.
+
+ Lemma add_nread_id_sqsubseteq V l r :
+ V ⊑ add_nread_id V l r.
+ Proof.
+ intros l'. rewrite /add_aread_id.
+ case: (decide (l' = l)).
+ - move => -> {l'}. rewrite lookup_partial_alter.
+ move: (V !! l) => [/=[????]|//].
+ repeat split; simpl; [done..|set_solver|done].
+ - move => ?. rewrite lookup_partial_alter_ne //.
+ Qed.
+
+ Section InsertAReadID.
+ Context (ð“¥ : threadView) (l : loc) (r : time_id).
+
+ Program Definition tview_insert_aread_id :=
+ let cur' := add_aread_id ð“¥.(cur) l r in
+ let acq' := ð“¥.(acq) ⊔ cur' in
+ mkTView ð“¥.(rel) ð“¥.(frel) cur' acq' _ _ _ _.
+ Next Obligation.
+ intros. apply bool_decide_pack. pose proof (rel_dom ð“¥).
+ rewrite /cur' /add_aread_id. etrans; [done|].
+ move => l' /elem_of_dom [[????] ?]. apply/elem_of_dom.
+ case: (decide (l' = l)) => ?.
+ - simplify_eq. rewrite lookup_partial_alter.
+ eexists. rewrite fmap_Some. eexists; split; [eassumption|reflexivity].
+ - rewrite lookup_partial_alter_ne //.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack=>l'.
+ transitivity (Some ð“¥.(cur)).
+ { generalize l'. eapply bool_decide_unpack, rel_cur_dec. }
+ apply add_aread_id_sqsubseteq.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack.
+ transitivity (ð“¥.(cur)).
+ { eapply bool_decide_unpack, frel_cur_dec. }
+ apply add_aread_id_sqsubseteq.
+ Qed.
+ Next Obligation. intros. solve_lat. Qed.
+ End InsertAReadID.
+
+ Section InsertNReadID.
+ Context (ð“¥ : threadView) (l : loc) (r: time_id).
+
+ Program Definition tview_insert_nread_id :=
+ let cur' := add_nread_id ð“¥.(cur) l r in
+ let acq' := ð“¥.(acq) ⊔ cur' in
+ mkTView ð“¥.(rel) ð“¥.(frel) cur' acq' _ _ _ _.
+ Next Obligation.
+ intros. apply bool_decide_pack. pose proof (rel_dom ð“¥).
+ rewrite /cur' /add_aread_id. etrans; [done|].
+ move => l' /elem_of_dom [[????] ?]. apply/elem_of_dom.
+ case: (decide (l' = l)) => ?.
+ - simplify_eq. rewrite lookup_partial_alter.
+ eexists. rewrite fmap_Some. eexists; split; [eassumption|reflexivity].
+ - rewrite lookup_partial_alter_ne //.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack=>l'.
+ transitivity (Some ð“¥.(cur)).
+ { generalize l'. eapply bool_decide_unpack, rel_cur_dec. }
+ apply add_nread_id_sqsubseteq.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack.
+ transitivity (ð“¥.(cur)).
+ { eapply bool_decide_unpack, frel_cur_dec. }
+ apply add_nread_id_sqsubseteq.
+ Qed.
+ Next Obligation. intros. solve_lat. Qed.
+ End InsertNReadID.
+
+ Inductive drf_pre_write l (ð“ : view) ð“¥ M o : Prop :=
+ | WriteDRF
+ (* All writes must have seen all NA reads *)
+ (ReadNA : ð“ !!nr l ⊑ ð“¥.(cur) !!nr l)
+ (* All writes must have seen all NA writes *)
+ (AllW : ð“ !!w l ⊑ ð“¥.(cur) !!w l)
+ (* NA writes must have seen the mo-latest write, all atomics reads and writes *)
+ (WriteNA: if decide (Relaxed ⊑ o) then True
+ else (∀ ð‘š', ð‘š' ∈ M → ð‘š'.(mloc) = l → Some (ð‘š'.(mto)) ⊑ ð“¥.(cur) !!w l)
+ ∧ ð“ !!aw l ⊑ ð“¥.(cur) !!aw l ∧ ð“ !!ar l ⊑ ð“¥.(cur) !!ar l).
+
+ Inductive drf_pre_read l (ð“ : view) ð“¥ M o : Prop :=
+ | ReadDRF
+ (* All reads must have seen all NA writes *)
+ (WriteNA: ð“ !!w l ⊑ ð“¥.(cur) !!w l)
+ (* NA reads must have seen the mo-latest write *)
+ (AllW : if decide (Relaxed ⊑ o) then True
+ else (∀ ð‘š', ð‘š' ∈ M → ð‘š'.(mloc) = l → Some (ð‘š'.(mto)) ⊑ ð“¥.(cur) !!w l)
+ ∧ ð“ !!aw l ⊑ ð“¥.(cur) !!aw l).
+
+ Inductive drf_pre_dealloc l (n: positive) ð“¥ M ð“ : Prop :=
+ | DeallocDRF
+ (WNA: ∀ n', (n' < Pos.to_nat n)%nat →
+ (∀ ð‘š', ð‘š' ∈ M → ð‘š'.(mloc) = l >> n' → Some (ð‘š'.(mto)) ⊑ ð“¥.(cur) !!w (l >> n')))
+ (ALL: ∀ n', (n' < Pos.to_nat n)%nat → ð“ !! (l >> n') ⊑ ð“¥.(cur) !! (l >> n'))
+ : drf_pre_dealloc l n ð“¥ M ð“.
+
+ Inductive drf_pre (ð“ : view) ð“¥ M : event → Prop :=
+ (* write *)
+ | DRFPreW l o v (DRF: drf_pre_write l ð“ ð“¥ M o)
+ : drf_pre ð“ ð“¥ M (Write l v o)
+ (* read *)
+ | DRFPreR l o v (DRF: drf_pre_read l ð“ ð“¥ M o)
+ : drf_pre ð“ ð“¥ M (Read l v o)
+ (* update *)
+ | DRFPreU l or ow vr vw
+ (DRFR: drf_pre_read l ð“ ð“¥ M or) (DRFW: drf_pre_write l ð“ ð“¥ M ow)
+ : drf_pre ð“ ð“¥ M (Update l vr vw or ow)
+ (* dealloc *)
+ | DRFPreDA l n (DRF: drf_pre_dealloc l n ð“¥ M ð“)
+ : drf_pre ð“ ð“¥ M (Dealloc l n)
+ (* alloc *)
+ | DRFPreAL l n
+ : drf_pre ð“ ð“¥ M (Alloc l n)
+ (* fences *)
+ | DRFPreF o1 o2
+ : drf_pre ð“ ð“¥ M (Fence o1 o2)
+ .
+
+ Inductive drf_post_read l o tr ð“ : view → Prop :=
+ | DRFPstR ð“'
+ (POST: if decide (Relaxed ⊑ o)
+ then (ð“' = add_aread_id ð“ l tr ∧ tr = fresh_aread_id ð“ l)
+ else (ð“' = add_nread_id ð“ l tr) ∧ tr = fresh_nread_id ð“ l)
+ : drf_post_read l o tr ð“ ð“'.
+
+ Inductive drf_post_write l t o ð“ : view → Prop :=
+ | DRFPstW ð“'
+ (POST: if decide (Relaxed ⊑ o)
+ then ð“' = add_awrite_id ð“ l t
+ else ð“' = set_write_time ð“ l t)
+ : drf_post_write l t o ð“ ð“'.
+
+ Inductive drf_post_update l tr tw ð“ : view → Prop :=
+ | DRFPstU ð“'
+ (POST: ð“' = add_awrite_id (add_aread_id ð“ l tr) l tw ∧ tr = fresh_aread_id ð“ l)
+ : drf_post_update l tr tw ð“ ð“'.
+
+ Inductive drf_post (ð“ : view) : event → option time → list message → view → Prop :=
+ (* write *)
+ | DRFPostW ð‘š v o ð“'
+ (DRF: drf_post_write ð‘š.(mloc) ð‘š.(mto) o ð“ ð“')
+ : drf_post ð“ (Write ð‘š.(mloc) v o) None [ð‘š] ð“'
+ (* read *)
+ | DRFPostR l tr o v ð“' (DRF: drf_post_read l o tr ð“ ð“')
+ : drf_post ð“ (Read l v o) (Some tr) [] ð“'
+ (* update *)
+ | DRFPostU ð‘š or ow tr vr vw ð“'
+ (DRF: drf_post_update ð‘š.(mloc) tr ð‘š.(mto) ð“ ð“')
+ : drf_post ð“ (Update ð‘š.(mloc) vr vw or ow) (Some tr) [ð‘š] ð“'
+ (* dealloc *)
+ | DRFPostDA l n ð‘šs
+ : drf_post ð“ (Dealloc l n) None ð‘šs (alloc_new_na ð“ ð‘šs)
+ (* alloc *)
+ | DRFPostAL l n ð‘šs
+ : drf_post ð“ (Alloc l n) None ð‘šs (alloc_new_na ð“ ð‘šs)
+ (* fences *)
+ | DRFPostF o1 o2
+ : drf_post ð“ (Fence o1 o2) None [] ð“
+ .
+
+
+ Inductive machine_step ð“¥1 M1 ð“¢1 :
+ event → option time → list message → threadView → memory → view → Prop :=
+ (* ALLOC *)
+ (* (alloc_new_na c1.(gb).(na) ð‘šs) *)
+ | PStepA l n ð“¥2 M2 ð‘šs
+ (ALLOC: alloc_step ð“¥1 M1 l (Pos.to_nat n) ð‘šs ð“¥2 M2)
+ : machine_step ð“¥1 M1 ð“¢1 (Alloc l n) None ð‘šs ð“¥2 M2 ð“¢1
+ (* DEALLOC *)
+ (* (alloc_new_na c1.(gb).(na) ð‘šs) *)
+ | PStepD l n ð‘šs ð“¥2 M2
+ (DEALLOC: dealloc_step ð“¥1 M1 l (Pos.to_nat n) ð‘šs ð“¥2 M2)
+ : machine_step ð“¥1 M1 ð“¢1
+ (Dealloc l n) None ð‘šs ð“¥2 M2 ð“¢1
+ (* READ *)
+ | PStepR ð‘š o ð“¥2 ð“2 tr
+ (READ: read_step ð“¥1 M1 tr ð‘š o ð“¥2)
+ : machine_step ð“¥1 M1 ð“¢1
+ (Read ð‘š.(mloc) ð‘š.(mbase).(mval) o) (Some tr) [] ð“¥2 M1 ð“¢1
+ (* WRITE *)
+ | PStepW ð‘š o ð“¥2 M2 v
+ (ISVAL: ð‘š.(mbase).(mval) = VVal v)
+ (WRITE: write_step ð“¥1 M1 ð‘š o ∅ ð“¥2 M2)
+ : machine_step ð“¥1 M1 ð“¢1
+ (Write ð‘š.(mloc) v o) None [ð‘š] ð“¥2 M2 ð“¢1
+ (* UPDATE *)
+ | PStepU ð‘š1 ð‘š2 or ow ð“¥2 ð“¥3 M3 tr v1 v2
+ (ISV1 : ð‘š1.(mbase).(mval) = VVal v1)
+ (ISV2 : ð‘š2.(mbase).(mval) = VVal v2)
+ (ADJ: ð‘š2.(mto) = (ð‘š1.(mto) + 1)%positive)
+ (SAME: ð‘š1.(mloc) = ð‘š2.(mloc))
+ (READ: read_step ð“¥1 M1 tr ð‘š1 or ð“¥2)
+ (WRITE: write_step ð“¥2 M1 ð‘š2 ow (default ∅ ð‘š1.(mbase).(mrel)) ð“¥3 M3)
+ : machine_step ð“¥1 M1 ð“¢1
+ (Update ð‘š1.(mloc) v1 v2 or ow) (Some tr) [ð‘š2] ð“¥3 M3 ð“¢1
+ (* ACQ-FENCE *)
+ | PStepFAcq ð“¥2
+ (FACQ: acq_fence_step ð“¥1 ð“¥2)
+ : machine_step ð“¥1 M1 ð“¢1
+ (Fence AcqRel Relaxed) None [] ð“¥2 M1 ð“¢1
+ (* REL-FENCE *)
+ | PStepFRel ð“¥2
+ (FREL: rel_fence_step ð“¥1 ð“¥2)
+ : machine_step ð“¥1 M1 ð“¢1
+ (Fence Relaxed AcqRel) None [] ð“¥2 M1 ð“¢1
+ (* SC-FENCE *)
+ | PStepFSC ð“¥2 ð“¢2
+ (FSC: sc_fence_step ð“¥1 ð“¢1 ð“¢2 ð“¥2)
+ : machine_step ð“¥1 M1 ð“¢1
+ (Fence SeqCst SeqCst) None [] ð“¥2 M1 ð“¢2.
+
+End Thread.
+
+Section Machine.
+ (** Machine instantiations *)
+ Context `{Countable VAL}.
+
+ (** Thread steps for machine whose locations are positives *)
+ Definition pos_machine_step := machine_step (loc:= positive) (VAL:=VAL).
+
+ (** Thread steps for machine whose locations are block+offset's *)
+ Definition lbl_machine_step := machine_step (loc:= lblock) (VAL:=VAL).
+
+End Machine.
+
+
+Section props.
+
+ Context `{!LocFacts loc} `{CVAL: Countable VAL} `{!Shift loc} `{!Allocator loc (memory loc VAL)}.
+
+ Notation memory := (memory loc VAL).
+ Notation message := (message loc VAL).
+ Notation baseMessage := (@baseMessage loc _ VAL).
+ Notation event := (event loc VAL).
+ Notation view := (@view loc _).
+ Notation threadView := (@threadView loc).
+ Notation global := (@global loc _ VAL).
+ Notation config := (@config loc _ VAL).
+
+ Implicit Type (ð‘š: message) (M: memory) (ð“: view) (G: global)
+ (c: config) (ð“¥: threadView).
+
+ Lemma add_nread_id_eq V l r l' :
+ add_nread_id V l r !!w l' = V !!w l' ∧
+ add_nread_id V l r !!aw l' = V !!aw l' ∧
+ add_nread_id V l r !!ar l' = V !!ar l'.
+ Proof.
+ rewrite /view_lookup_write /view_lookup_awrite /view_lookup_aread /add_nread_id.
+ case: (decide (l' = l)) => [->|?].
+ - rewrite lookup_partial_alter.
+ by case: (_ !! _) => //.
+ - rewrite lookup_partial_alter_ne //.
+ Qed.
+ Lemma add_nread_id_eqw V l r l' :
+ add_nread_id V l r !!w l' = V !!w l'.
+ Proof. by apply add_nread_id_eq. Qed.
+ Lemma add_nread_id_eqaw V l r l' :
+ add_nread_id V l r !!aw l' = V !!aw l'.
+ Proof. by apply add_nread_id_eq. Qed.
+ Lemma add_nread_id_eqar V l r l' :
+ add_nread_id V l r !!ar l' = V !!ar l'.
+ Proof. by apply add_nread_id_eq. Qed.
+
+ Lemma add_aread_id_eq V l r l' :
+ add_aread_id V l r !!w l' = V !!w l' ∧
+ add_aread_id V l r !!aw l' = V !!aw l' ∧
+ add_aread_id V l r !!nr l' = V !!nr l'.
+ Proof.
+ rewrite /view_lookup_write /view_lookup_awrite /view_lookup_nread /add_aread_id.
+ case: (decide (l' = l)) => [->|?].
+ - rewrite lookup_partial_alter.
+ by case: (_ !! _) => //.
+ - rewrite lookup_partial_alter_ne //.
+ Qed.
+ Lemma add_aread_id_eqw V l r l' :
+ add_aread_id V l r !!w l' = V !!w l'.
+ Proof. by apply add_aread_id_eq. Qed.
+ Lemma add_aread_id_eqaw V l r l' :
+ add_aread_id V l r !!aw l' = V !!aw l'.
+ Proof. by apply add_aread_id_eq. Qed.
+ Lemma add_aread_id_eqnr V l r l' :
+ add_aread_id V l r !!nr l' = V !!nr l'.
+ Proof. by apply add_aread_id_eq. Qed.
+
+ Lemma add_awrite_id_eq V l r l' :
+ add_awrite_id V l r !!w l' = V !!w l' ∧
+ add_awrite_id V l r !!nr l' = V !!nr l' ∧
+ add_awrite_id V l r !!ar l' = V !!ar l'.
+ Proof.
+ rewrite /view_lookup_write /view_lookup_nread /view_lookup_aread /add_awrite_id.
+ case: (decide (l' = l)) => [->|?].
+ - rewrite lookup_partial_alter.
+ by case: (_ !! _) => //.
+ - rewrite lookup_partial_alter_ne //.
+ Qed.
+ Lemma add_awrite_id_eqw V l r l' :
+ add_awrite_id V l r !!w l' = V !!w l'.
+ Proof. by apply add_awrite_id_eq. Qed.
+ Lemma add_awrite_id_eqnr V l r l' :
+ add_awrite_id V l r !!nr l' = V !!nr l'.
+ Proof. by apply add_awrite_id_eq. Qed.
+ Lemma add_awrite_id_eqar V l r l' :
+ add_awrite_id V l r !!ar l' = V !!ar l'.
+ Proof. by apply add_awrite_id_eq. Qed.
+
+ Lemma add_aread_id_memory V l r M :
+ V ∈ M → add_aread_id V l r ∈ M.
+ Proof. move => IN ??. rewrite add_aread_id_eqw. by apply IN. Qed.
+
+ Lemma add_nread_id_memory V l r M :
+ V ∈ M → add_nread_id V l r ∈ M.
+ Proof. move => IN ??. rewrite add_nread_id_eqw. by apply IN. Qed.
+
+ Lemma add_awrite_id_memory V l r M :
+ V ∈ M → add_awrite_id V l r ∈ M.
+ Proof. move => IN ??. rewrite add_awrite_id_eqw. by apply IN. Qed.
+
+ Lemma add_awrite_id_sqsubseteq V l r :
+ V ⊑ add_awrite_id V l r.
+ Proof.
+ intros l'. rewrite /add_awrite_id.
+ case: (decide (l' = l)).
+ - move => -> {l'}. rewrite lookup_partial_alter.
+ move: (V !! l) => [/=[????]|//].
+ repeat split; simpl; [done| |done..]. set_solver.
+ - move => ?. rewrite lookup_partial_alter_ne //.
+ Qed.
+
+ Lemma add_awrite_id_mono V1 V2 l r:
+ V1 ⊑ V2 → add_awrite_id V1 l r ⊑ add_awrite_id V2 l r.
+ Proof.
+ move => LE l'. apply view_sqsubseteq. repeat split.
+ - rewrite 2!add_awrite_id_eqw. by apply view_sqsubseteq.
+ - rewrite /add_awrite_id /= /view_lookup_awrite /=.
+ case (decide (l' = l)) => [->|?].
+ + rewrite !lookup_partial_alter. apply fmap_sqsubseteq; [apply _|].
+ apply fmap_sqsubseteq; [|apply LE].
+ intros [][] [?[?[??]]]; simpl. repeat split => //. solve_proper.
+ + do 2 (rewrite lookup_partial_alter_ne; [|done]).
+ apply fmap_sqsubseteq; [apply _|apply LE].
+ - rewrite 2!add_awrite_id_eqnr. by apply view_sqsubseteq.
+ - rewrite 2!add_awrite_id_eqar. by apply view_sqsubseteq.
+ Qed.
+
+ Lemma add_aread_id_mono V1 V2 l r:
+ V1 ⊑ V2 → add_aread_id V1 l r ⊑ add_aread_id V2 l r.
+ Proof.
+ move => LE l'. apply view_sqsubseteq. repeat split.
+ - rewrite 2!add_aread_id_eqw. by apply view_sqsubseteq.
+ - rewrite 2!add_aread_id_eqaw. by apply view_sqsubseteq.
+ - rewrite 2!add_aread_id_eqnr. by apply view_sqsubseteq.
+ - rewrite /add_aread_id /= /view_lookup_aread /=.
+ case (decide (l' = l)) => [->|?].
+ + rewrite !lookup_partial_alter. apply fmap_sqsubseteq; [apply _|].
+ apply fmap_sqsubseteq; [|apply LE].
+ intros [][] [?[?[??]]]; simpl. repeat split => //. solve_proper.
+ + do 2 (rewrite lookup_partial_alter_ne; [|done]).
+ apply fmap_sqsubseteq; [apply _|apply LE].
+ Qed.
+
+ Lemma add_nread_id_mono V1 V2 l r:
+ V1 ⊑ V2 → add_nread_id V1 l r ⊑ add_nread_id V2 l r.
+ Proof.
+ move => LE l'. apply view_sqsubseteq. repeat split.
+ - rewrite 2!add_nread_id_eqw. by apply view_sqsubseteq.
+ - rewrite 2!add_nread_id_eqaw. by apply view_sqsubseteq.
+ - rewrite /add_nread_id /= /view_lookup_nread /=.
+ case (decide (l' = l)) => [->|?].
+ + rewrite !lookup_partial_alter. apply fmap_sqsubseteq; [apply _|].
+ apply fmap_sqsubseteq; [|apply LE].
+ intros [][] [?[?[??]]]; simpl. repeat split => //. solve_proper.
+ + do 2 (rewrite lookup_partial_alter_ne; [|done]).
+ apply fmap_sqsubseteq; [apply _|apply LE].
+ - rewrite 2!add_nread_id_eqar. by apply view_sqsubseteq.
+ Qed.
+
+ Lemma add_nread_id_dealloc_agree M V l t:
+ dealloc_na_agree M V → dealloc_na_agree M (add_nread_id V l t).
+ Proof. move => DA ???. rewrite add_nread_id_eqw. by apply DA. Qed.
+
+ Lemma add_aread_id_dealloc_agree M V l t:
+ dealloc_na_agree M V → dealloc_na_agree M (add_aread_id V l t).
+ Proof. move => DA ???. rewrite add_aread_id_eqw. by apply DA. Qed.
+
+ Lemma add_awrite_id_dealloc_agree M V l t:
+ dealloc_na_agree M V → dealloc_na_agree M (add_awrite_id V l t).
+ Proof. move => DA ???. rewrite add_awrite_id_eqw. by apply DA. Qed.
+
+ Lemma set_write_time_id V l t (HL: V !!w l = Some t):
+ set_write_time V l t = V.
+ Proof.
+ apply (map_eq _ V) => l'. rewrite /set_write_time.
+ case: (decide (l' = l)).
+ - move => -> {l'}. rewrite lookup_partial_alter.
+ destruct (V !! l) as [[]|] eqn:EqV; rewrite EqV; [|done]. simpl.
+ f_equal. f_equal. rewrite (view_lookup_w _ _ _ _ _ _ EqV) in HL.
+ by inversion HL.
+ - move => ?. rewrite lookup_partial_alter_ne //.
+ Qed.
+
+ Lemma set_write_time_mono V1 V2 l t:
+ V1 ⊑ V2 → set_write_time V1 l t ⊑ set_write_time V2 l t.
+ Proof.
+ move => LE l'. rewrite /set_write_time.
+ case (decide (l' = l)) => [->|?].
+ - rewrite 2!lookup_partial_alter /=. apply fmap_sqsubseteq.
+ + by intros [] [] [? [? []]].
+ + by apply LE.
+ - do 2 (rewrite lookup_partial_alter_ne; [|done]). by apply LE.
+ Qed.
+
+ Lemma mem_cut_insert_set_write M V l C t (IS: is_Some (V !! l)):
+ <[l:=cell_cut t C]> (mem_cut M V) = mem_cut (<[l:=C]> M) (set_write_time V l t).
+ Proof.
+ rewrite /set_write_time
+ (mem_cut_insert _ _ _ _ _ (default ∅ (V !!aw l))
+ (default ∅ (V !!nr l)) (default ∅ (V !!ar l))).
+ f_equal. apply (map_eq (<[_ := _]> V)) => l'.
+ case (decide (l' = l)) => ?; [subst l'|].
+ - rewrite lookup_insert lookup_partial_alter /=.
+ destruct (V !! l) as [[]|] eqn:Eql; rewrite Eql; simpl.
+ + by rewrite (view_lookup_aw _ _ _ _ _ _ Eql)
+ (view_lookup_ar _ _ _ _ _ _ Eql) (view_lookup_nr _ _ _ _ _ _ Eql) /=.
+ + by destruct IS.
+ - rewrite lookup_insert_ne; [|done].
+ by rewrite lookup_partial_alter_ne; [|done].
+ Qed.
+
+ Lemma mem_cut_write l ð‘š o M1 M2 ð“1 ð“2 Vc ð“¥ t1 Cf1
+ (WRITE : memory_addins ð‘š M1 M2)
+ (DRFR : drf_pre_write ð‘š.(mloc) ð“1 ð“¥ M1 o)
+ (DRFP : drf_post_write ð‘š.(mloc) ð‘š.(mto) o ð“1 ð“2)
+ (LE: ð“1 ⊑ Vc)
+ (HL: M1 !!c l = Cf1 ∧ Vc !!w l = Some t1)
+ (NEWT: t1 ⊠ð‘š.(mto)) (EQLOC: l = ð‘š.(mloc))
+ (NEW: ð“¥.(cur) !!w l ⊠Some ð‘š.(mto)) :
+ let C2 : cell := <[ð‘š.(mto) := ð‘š.(mbase)]> (if (decide (Relaxed ⊑ o))
+ then (cell_cut t1 Cf1) else ∅) in
+ let Vc' : view := (if decide (Relaxed ⊑ o) then add_awrite_id Vc l ð‘š.(mto)
+ else set_write_time Vc l ð‘š.(mto)) in
+ let t2 : time := (if (decide (Relaxed ⊑ o)) then t1 else ð‘š.(mto)) in
+ ∃ Cf2, M2 = <[l:=Cf2]> M1 ∧ ð“2 ⊑ Vc' ∧ C2 = cell_cut t2 Cf2.
+ Proof.
+ have EqCf2 := memory_addins_eq _ _ _ WRITE.
+ destruct HL as [EqCf1 HL]. rewrite -EQLOC EqCf1 /= in EqCf2.
+ exists (<[mto ð‘š:=mbase ð‘š]> Cf1).
+ split; [done|]. inversion DRFR. inversion DRFP; subst.
+ case_decide; subst; split.
+ - by apply add_awrite_id_mono.
+ - rewrite cell_cut_insert; [done|]. by apply strict_include in NEWT.
+ - by apply set_write_time_mono.
+ - rewrite cell_cut_insert; [|done].
+ f_equal. symmetry. apply cell_cut_empty => t' [m' Eqt'].
+ have LT: t' ⊠ð‘š.(mto).
+ { change (Some t' ⊠Some ð‘š.(mto)). destruct WriteNA as [LAST ?].
+ eapply strict_transitive_r;
+ [apply (LAST (mkMsg ð‘š.(mloc) t' m')); [|done]|done].
+ by rewrite -memory_lookup_cell in Eqt'. }
+ by apply Pos.lt_nle, LT.
+ Qed.
+
+ Lemma mem_cut_add_aread_id M V l t:
+ mem_cut M (add_aread_id V l t) = mem_cut M V.
+ Proof.
+ rewrite /mem_cut /mem_cut_filter.
+ apply (map_filter_ext (M:= gmap (loc * time))).
+ move => [l' t'] m' ? /=. by rewrite add_aread_id_eqw.
+ Qed.
+
+ Lemma mem_cut_add_nread_id M V l t:
+ mem_cut M (add_nread_id V l t) = mem_cut M V.
+ Proof.
+ rewrite /mem_cut /mem_cut_filter.
+ apply (map_filter_ext (M:= gmap (loc * time))).
+ move => [l' t'] m' ? /=. by rewrite add_nread_id_eqw.
+ Qed.
+
+ Lemma mem_cut_add_awrite_id M V l t:
+ mem_cut M (add_awrite_id V l t) = mem_cut M V.
+ Proof.
+ rewrite /mem_cut /mem_cut_filter.
+ apply (map_filter_ext (M:= gmap (loc * time))).
+ move => [l' t'] m' ? /=. by rewrite add_awrite_id_eqw.
+ Qed.
+
+ Lemma memory_cell_insert_id l M:
+ <[l := M !!c l]> M = M.
+ Proof.
+ apply (map_eq (M:= gmap _)) => [[l' t]]. rewrite !memory_lookup_cell.
+ destruct (decide (l = l')) as [->|?].
+ - by rewrite memory_cell_lookup_insert.
+ - by rewrite memory_cell_lookup_insert_ne.
+ Qed.
+
+ Lemma cell_cut_singleton_eq C (t: time) (m: baseMessage)
+ (MAX: ∀ (t0: time), is_Some (C !! t0) → (t0 ≤ t)%positive)
+ (Eqt': C !! t = Some m):
+ cell_cut t C = {[t := m]}.
+ Proof.
+ apply map_eq => t0.
+ case (decide (t0 = t)) => [->|NE];
+ [rewrite lookup_insert|rewrite lookup_insert_ne; last done].
+ - by apply cell_cut_lookup_Some.
+ - apply cell_cut_lookup_None.
+ destruct (C !! t0) as [m0|] eqn:Eqt0; [right|by left].
+ move => Le. apply NE. apply : anti_symm; [apply MAX; by eexists|done].
+ Qed.
+
+ Lemma mem_cut_max_time l (t: time) m M C Vc tc
+ (CUT: C = cell_cut tc (M !!c l))
+ (MAX: ∀ (t0 : time), is_Some (C !! t0) → (t0 ≤ t)%positive)
+ (Eqt: C !! t = Some m)
+ (IS: is_Some (Vc !! l)) :
+ mem_cut M (set_write_time Vc l t) = (<[l:={[t := m]}]> (mem_cut M Vc)).
+ Proof.
+ rewrite -{1}(memory_cell_insert_id l M) -mem_cut_insert_set_write; [|done].
+ f_equal. apply cell_cut_singleton_eq.
+ - move => t0 [m0 Eqt0].
+ case (decide (t0 ≤ tc)%positive) => Le.
+ + etrans; [apply Le|].
+ apply (cell_cut_lookup_Some (M !!c l) _ _ m). by rewrite -CUT.
+ + apply MAX. exists m0. rewrite CUT.
+ apply cell_cut_lookup_Some. split; [done|].
+ apply Pos.lt_le_incl. by apply Pos.lt_nle in Le.
+ - move : Eqt. rewrite CUT. by move => /cell_cut_lookup_Some [?].
+ Qed.
+End props.
+
+Section memory_lblock.
+ Context `{CVAL: Countable VAL}.
+ Notation memory := (@memory _ lblock_loc VAL).
+ (** Some properties of memory specific to lblock *)
+ Lemma memory_alloc_old n l ð‘šs (M1 M2 : memory)
+ (ALLOC: memory_alloc n l ð‘šs M1 M2):
+ ∀ i : Z, (¬ l.2 ≤ i < l.2 + Z.of_nat n)%Z → M2 !!c (l.1, i) = M1 !!c (l.1, i).
+ Proof.
+ move => n' NIn.
+ inversion ALLOC. symmetry.
+ eapply mem_list_addins_old; first exact ADD.
+ move => ð‘š /elem_of_list_lookup [n1 Eq1].
+ have Lt := lookup_lt_Some _ _ _ Eq1. rewrite LEN in Lt.
+ apply AMES in Eq1 as [Eq1 _]. rewrite Eq1.
+ rewrite /location.shift /=. inversion 1; subst n'. lia.
+ Qed.
+
+ Lemma alloc_step_mem_old ð“¥1 (M1: memory) l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) :
+ ∀ i : Z, (¬ l.2 ≤ i < l.2 + Z.of_nat n)%Z → M2 !!c (l.1, i) = M1 !!c (l.1, i).
+ Proof. inversion ALLOC. by eapply memory_alloc_old. Qed.
+
+ Lemma memory_alloc_old_2 n l ð‘šs (M1 M2 : memory)
+ (ALLOC: memory_alloc n l ð‘šs M1 M2) :
+ ∀ l', l'.1 ≠l.1 → M2 !!c l' = M1 !!c l'.
+ Proof.
+ move => l' NEq. inversion ALLOC. symmetry.
+ eapply mem_list_addins_old; first exact ADD.
+ move => ð‘š /elem_of_list_lookup [n1 Eq1].
+ have Lt := lookup_lt_Some _ _ _ Eq1. rewrite LEN in Lt.
+ apply AMES in Eq1 as [Eq1 _]. rewrite Eq1. rewrite /shift /=.
+ destruct l'. by inversion 1.
+ Qed.
+
+ Lemma alloc_step_mem_old_2 ð“¥1 (M1: memory) l n ð‘šs ð“¥2 M2
+ (ALLOC: alloc_step ð“¥1 M1 l n ð‘šs ð“¥2 M2) :
+ ∀ l', l'.1 ≠l.1 → M2 !!c l' = M1 !!c l'.
+ Proof. inversion ALLOC. by eapply memory_alloc_old_2. Qed.
+End memory_lblock.
diff --git a/orc11/tview.v b/orc11/tview.v
new file mode 100644
index 0000000000000000000000000000000000000000..d402aa2109eadfc05e90004ffd0058815c3ca7d0
--- /dev/null
+++ b/orc11/tview.v
@@ -0,0 +1,687 @@
+From stdpp Require Export gmap tactics.
+From orc11 Require Export view memory mem_order.
+
+Require Import stdpp.options.
+
+Section ThreadView.
+ Context `{!LocFacts loc} `{CVAL: Countable VAL}.
+ Notation view := (@view loc _).
+ Implicit Types (V: view).
+
+ (* TODO: clean up these instances *)
+ Global Instance all_gmap_sqsubseteq_decision (M: gmap loc view) (V: option view) :
+ Decision (∀ l, M !! l ⊑ V).
+ Proof.
+ assert (IFF : (∀ l, M !! l ⊑ V) ↔ (Forall (λ lV', Some lV'.2 ⊑ V) (map_to_list M))).
+ { rewrite list.Forall_forall. split.
+ - intros ? [l V'] Eq%elem_of_map_to_list. by rewrite /= -Eq.
+ - intros HM l. destruct (M!!l) eqn:Eq; [|done].
+ apply elem_of_map_to_list in Eq. eapply (HM (_,_)). eauto. }
+ destruct (decide (Forall (λ lV', Some lV'.2 ⊑ V) (map_to_list M)));
+ [left|right]; by rewrite IFF.
+ Qed.
+
+ Global Instance all_gmap_sqsubseteq_decision' (M: gmap loc view) V :
+ Decision (∀ l V', M !! l = Some V' → V ⊑ V').
+ Proof.
+ assert (IFF : (∀ (l : loc) (V' : view), M !! l = Some V' → V ⊑ V') ↔
+ (Forall (λ lV', V ⊑ lV'.2) (map_to_list M))).
+ { rewrite list.Forall_forall. split.
+ - intros ? [l V'] Eq%elem_of_map_to_list. eauto.
+ - intros HM l V' ?. by eapply (HM (_, _)), elem_of_map_to_list. }
+ destruct (decide (Forall (λ lV' : loc * view, V ⊑ lV'.2) (map_to_list M)));
+ [left|right]; by rewrite IFF.
+ Qed.
+
+ Record threadView : Type :=
+ mkTView {
+ rel : gmap loc view; (* The latest release write for each location. *)
+ frel: view; (* The latest SC or REL fence. *)
+ cur : view;
+ acq : view;
+
+ rel_dom_dec :
+ bool_decide (dom rel ⊆ dom cur);
+ rel_cur_dec : bool_decide (∀ l, rel !! l ⊑ Some cur);
+ frel_cur_dec : bool_decide (frel ⊑ cur);
+ cur_acq_dec : bool_decide (cur ⊑ acq);
+ }.
+
+ Lemma rel_dom ð“¥ : dom ð“¥.(rel) ⊆ dom ð“¥.(cur).
+ Proof. eapply bool_decide_unpack, rel_dom_dec. Qed.
+ Lemma rel_cur ð“¥ l : (ð“¥.(rel) !! l) ⊑ Some ð“¥.(cur).
+ Proof. revert l. eapply bool_decide_unpack, rel_cur_dec. Qed.
+ Lemma rel_cur' ð“¥ l : default ∅ (ð“¥.(rel) !! l) ⊑ ð“¥.(cur).
+ Proof. pose proof (rel_cur ð“¥ l). by destruct lookup. Qed.
+ Lemma frel_cur ð“¥ : ð“¥.(frel) ⊑ ð“¥.(cur).
+ Proof. eapply bool_decide_unpack, frel_cur_dec. Qed.
+ Lemma cur_acq ð“¥ : ð“¥.(cur) ⊑ ð“¥.(acq).
+ Proof. eapply bool_decide_unpack, cur_acq_dec. Qed.
+
+ Lemma threadView_eq ð“¥1 ð“¥2 :
+ ð“¥1.(rel) = ð“¥2.(rel) → ð“¥1.(frel) = ð“¥2.(frel) → ð“¥1.(cur) = ð“¥2.(cur) → ð“¥1.(acq) = ð“¥2.(acq) →
+ ð“¥1 = ð“¥2.
+ Proof. destruct ð“¥1, ð“¥2=>/= ????. subst. f_equal; apply proof_irrel. Qed.
+
+ Program Definition init_tview := mkTView ∅ ∅ ∅ ∅ _ _ _ _.
+ Solve Obligations with eapply bool_decide_pack; set_solver.
+
+ Global Instance threadViewInhabited : Inhabited threadView.
+ Proof. constructor. exact init_tview. Qed.
+
+ Implicit Type (ð“¥: threadView (* U+1D4E5 *)).
+
+ Record tview_le ð“¥1 ð“¥2 :=
+ mkTViewSqSubsetEq {
+ tview_sqsubseteq_rel : ð“¥1.(rel) ⊑ ð“¥2.(rel);
+ tview_sqsubseteq_frel : ð“¥1.(frel) ⊑ ð“¥2.(frel);
+ tview_sqsubseteq_cur : ð“¥1.(cur) ⊑ ð“¥2.(cur);
+ tview_sqsubseteq_acq : ð“¥1.(acq) ⊑ ð“¥2.(acq);
+ }.
+
+ Program Definition tview_join :=
+ λ ð“¥1 ð“¥2, mkTView ((ð“¥1.(rel) : gmap_Lat loc view_Lat) ⊔ ð“¥2.(rel))
+ (ð“¥1.(frel) ⊔ ð“¥2.(frel))
+ (ð“¥1.(cur) ⊔ ð“¥2.(cur)) (ð“¥1.(acq) ⊔ ð“¥2.(acq)) _ _ _ _.
+ Next Obligation.
+ intros. apply bool_decide_pack. rewrite !gmap_join_dom_union=>l.
+ rewrite !elem_of_union=>-[?|?]; [left|right]; by apply rel_dom.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack=>l. by rewrite lookup_join !rel_cur.
+ Qed.
+ Next Obligation. intros. apply bool_decide_pack. by rewrite !frel_cur. Qed.
+ Next Obligation. intros. apply bool_decide_pack. by rewrite !cur_acq. Qed.
+
+ Program Definition tview_meet :=
+ λ ð“¥1 ð“¥2, mkTView ((ð“¥1.(rel) : gmap_Lat loc view_Lat) ⊓ ð“¥2.(rel))
+ (ð“¥1.(frel) ⊓ ð“¥2.(frel))
+ (ð“¥1.(cur) ⊓ ð“¥2.(cur)) (ð“¥1.(acq) ⊓ ð“¥2.(acq)) _ _ _ _.
+ Next Obligation.
+ intros. apply bool_decide_pack. rewrite !gmap_meet_dom_intersection=>l.
+ rewrite !elem_of_intersection=>-[? ?]; split; by apply rel_dom.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack=>l. by rewrite lookup_meet !rel_cur.
+ Qed.
+ Next Obligation. intros. apply bool_decide_pack. by rewrite !frel_cur. Qed.
+ Next Obligation. intros. apply bool_decide_pack. by rewrite !cur_acq. Qed.
+
+ Program Canonical Structure tview_Lat :=
+ Make_Lat threadView (=) tview_le tview_join tview_meet
+ _ _ _ _ _ _ _ _ _ _ _ _ _.
+ Next Obligation.
+ split; [by split|] => ??? [????] [????]. constructor; by etrans.
+ Qed.
+ Next Obligation.
+ intros [][][][]. apply threadView_eq; by apply: (anti_symm (⊑)).
+ Qed.
+ Next Obligation.
+ move => ??. split; simpl; try solve_lat.
+ move => ?. rewrite lookup_join. by apply lat_join_sqsubseteq_l.
+ Qed.
+ Next Obligation.
+ move => ??. split; simpl; try solve_lat.
+ move => ?. rewrite lookup_join. by apply lat_join_sqsubseteq_r.
+ Qed.
+ Next Obligation.
+ intros ??? [][]. split; simpl; try solve_lat.
+ move => ?. rewrite lookup_join. apply lat_join_lub; auto.
+ Qed.
+ Next Obligation.
+ move => ??. split; simpl; try solve_lat.
+ move => ?. rewrite lookup_meet. by apply lat_meet_sqsubseteq_l.
+ Qed.
+ Next Obligation.
+ move => ??. split; simpl; try solve_lat.
+ move => ?. rewrite lookup_meet. by apply lat_meet_sqsubseteq_r.
+ Qed.
+ Next Obligation.
+ intros ??? [][]. split; simpl; try solve_lat.
+ move => ?. rewrite lookup_meet. apply lat_meet_glb; auto.
+ Qed.
+
+ Global Instance rel_mono : Proper ((⊑) ==> (⊑)) rel.
+ Proof. solve_proper. Qed.
+ Global Instance acq_mono : Proper ((⊑) ==> (⊑)) acq.
+ Proof. solve_proper. Qed.
+ Global Instance frel_mono : Proper ((⊑) ==> (⊑)) frel.
+ Proof. solve_proper. Qed.
+ Global Instance cur_mono : Proper ((⊑) ==> (⊑)) cur.
+ Proof. solve_proper. Qed.
+
+ Global Instance rel_mono_flip : Proper (flip (⊑) ==> flip (⊑)) rel.
+ Proof. solve_proper. Qed.
+ Global Instance acq_mono_flip : Proper (flip (⊑) ==> flip (⊑)) acq.
+ Proof. solve_proper. Qed.
+ Global Instance frel_mono_flip : Proper (flip (⊑) ==> flip (⊑)) frel.
+ Proof. solve_proper. Qed.
+ Global Instance cur_mono_flip : Proper (flip (⊑) ==> flip (⊑)) cur.
+ Proof. solve_proper. Qed.
+
+ Global Instance tview_Lat_bot : LatBottom init_tview.
+ Proof. done. Qed.
+
+ Notation memory := (memory loc VAL).
+ Notation message := (message loc VAL).
+ Implicit Type (M: memory).
+
+ Record closed_tview' ð“¥ M :=
+ { closed_tview_rel: ∀ l, (ð“¥.(rel) !! l) ∈ M;
+ closed_tview_frel: ð“¥.(frel) ∈ M;
+ closed_tview_cur: ð“¥.(cur) ∈ M;
+ closed_tview_acq: ð“¥.(acq) ∈ M; }.
+
+ Global Instance closed_tview : ElemOf threadView memory := closed_tview'.
+
+ Global Instance closed_tview_downclosed :
+ Proper ((@sqsubseteq threadView _) ==> (@eq memory) ==> flip impl) (∈).
+ Proof.
+ move => [????????] [????????] [/= SE1 SE2 SE3 SE4] ?? -> [/=????].
+ constructor => /=.
+ - move => l. by rewrite (SE1 l).
+ - by rewrite SE2.
+ - by rewrite SE3.
+ - by rewrite SE4.
+ Qed.
+
+ Lemma closed_tview_acq_inv ð“¥ M (HC: ð“¥.(acq) ∈ M):
+ 𓥠∈ M.
+ Proof.
+ have HCur: ð“¥.(cur) ∈ M by rewrite cur_acq.
+ constructor; [|by rewrite frel_cur|done..].
+ by move => l; rewrite rel_cur.
+ Qed.
+
+ (* <rel,cur,acq> -{o,l,t,R}-> <cur',acq',rel> *)
+ Program Definition read_tview ð“¥ o R V
+ (cur' := if decide (AcqRel ⊑ o) then ð“¥.(cur) ⊔ V ⊔ R else ð“¥.(cur) ⊔ V)
+ (acq' := if decide (Relaxed ⊑ o) then ð“¥.(acq) ⊔ V ⊔ R else ð“¥.(acq) ⊔ V)
+ := (mkTView ð“¥.(rel) ð“¥.(frel) cur' acq' _ _ _ _).
+ Next Obligation.
+ intros. apply bool_decide_pack. etrans; [apply rel_dom|f_equiv; subst cur'].
+ case_match; solve_lat.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack=>l. rewrite rel_cur /cur'. case_match; solve_lat.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack. rewrite frel_cur /cur'. case_match; solve_lat.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack. destruct o; rewrite /cur' /acq' /= cur_acq; solve_lat.
+ Qed.
+
+ Inductive read_helper 𓥠(o: memOrder) l t tr (R: view) : threadView → Prop :=
+ | ReadHelper
+ (PLN: ð“¥.(cur) !!w l ⊑ Some t)
+ (PLN2: R !!w l ⊑ Some t)
+ (V : view := if decide (Relaxed ⊑ o)
+ then {[l := [{ t, ∅, ∅, {[tr]} }] ]}
+ else {[l := [{ t, ∅, {[tr]}, ∅ }] ]})
+ (cur' := if decide (AcqRel ⊑ o) then ð“¥.(cur) ⊔ V ⊔ R else ð“¥.(cur) ⊔ V)
+ (acq' := if decide (Relaxed ⊑ o) then ð“¥.(acq) ⊔ V ⊔ R else ð“¥.(acq) ⊔ V)
+ : read_helper ð“¥ o l t tr R (read_tview ð“¥ o R V).
+
+ (* <rel,cur,acq> -{o,l,t,Rr,Rw}-> <cur',acq',rel'> *)
+ Section write.
+ Context ð“¥ o l t
+ (V : view := if decide (Relaxed ⊑ o)
+ then {[l := [{ t, {[t]}, ∅, ∅ }] ]}
+ else {[l := [{ t, ∅, ∅, ∅ }] ]})
+ (Vra := if decide (AcqRel ⊑ o) then ð“¥.(cur) ⊔ V else V)
+ (V' := default ∅ (ð“¥.(rel) !! l) ⊔ Vra)
+ (rel' := <[l := V']> (ð“¥.(rel))).
+
+ Program Definition write_tview :=
+ mkTView rel' ð“¥.(frel) (ð“¥.(cur) ⊔ V) (ð“¥.(acq) ⊔ V) _ _ _ _.
+ Next Obligation.
+ intros. apply bool_decide_pack. pose proof (rel_dom ð“¥).
+ rewrite /rel' dom_insert gmap_join_dom_union /V.
+ case decide => ?; rewrite dom_singleton; set_solver.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack=>l'. destruct (decide (l = l')) as [<-|].
+ - rewrite lookup_insert /V' rel_cur' /Vra. case_match; solve_lat.
+ - rewrite lookup_insert_ne // rel_cur. solve_lat.
+ Qed.
+ Next Obligation. intros. apply bool_decide_pack. rewrite frel_cur. solve_lat. Qed.
+ Next Obligation. intros. apply bool_decide_pack. by rewrite cur_acq. Qed.
+
+ Definition write_Rw Rr :=
+ if decide (Relaxed ⊑ o) then Some (V' ⊔ ð“¥.(frel) ⊔ Rr) else None.
+ End write.
+ Inductive write_helper 𓥠o l t Rr : option view → threadView → Prop :=
+ | WriteHelper
+ (RLX: ð“¥.(cur) !!w l ⊠Some t)
+ : write_helper ð“¥ o l t Rr (write_Rw ð“¥ o l t Rr) (write_tview ð“¥ o l t).
+
+ (* <ð“¥,ð“¢> -{ F_sc }-> <ð“¥',ð“¢'> *)
+ Program Definition sc_fence_tview ð“¥ ð“¢ :=
+ let ð“¢' := ð“¥.(acq) ⊔ ð“¢ in
+ mkTView ð“¥.(rel) ð“¢' ð“¢' ð“¢' _ _ _ _.
+ Next Obligation.
+ intros. apply bool_decide_pack. etrans; [apply rel_dom|]. f_equiv.
+ rewrite cur_acq. solve_lat.
+ Qed.
+ Next Obligation.
+ intros. apply bool_decide_pack=>l. rewrite rel_cur cur_acq. solve_lat.
+ Qed.
+ Next Obligation. intros. apply bool_decide_pack=>//. Qed.
+ Next Obligation. intros. apply bool_decide_pack=>//. Qed.
+
+ Inductive sc_fence_helper 𓥠𓢠: threadView → view → Prop :=
+ | SCFenceHelper (ð“¢' := ð“¥.(acq) ⊔ ð“¢ )
+ : sc_fence_helper ð“¥ ð“¢ (sc_fence_tview ð“¥ ð“¢) ð“¢'.
+
+ Inductive alloc_helper : list message → relation threadView :=
+ | AllocListNone ð“¥: alloc_helper nil ð“¥ ð“¥
+ | AllocListSome ð‘š ð‘šs ð“¥1 ð“¥2 ð“¥3
+ (NEXT: alloc_helper ð‘šs ð“¥1 ð“¥2)
+ (WRITE: write_helper ð“¥2 NonAtomic ð‘š.(mloc) ð‘š.(mto) ∅ None ð“¥3)
+ : alloc_helper (ð‘š :: ð‘šs) ð“¥1 ð“¥3.
+
+ (** Lots of lemmas about thread-views *)
+ Lemma read_helper_tview_sqsubseteq ð“¥ ð“¥' o l t tr R
+ (READ: read_helper ð“¥ o l t tr R ð“¥'):
+ 𓥠⊑ ð“¥'.
+ Proof.
+ inversion READ. subst V cur' acq'. constructor=>//=; clear; case_match; solve_lat.
+ Qed.
+
+ Lemma write_helper_tview_sqsubseteq ð“¥ ð“¥' o l t Rr Rw
+ (WRITE: write_helper ð“¥ o l t Rr Rw ð“¥'):
+ 𓥠⊑ ð“¥'.
+ Proof.
+ inversion_clear WRITE.
+ constructor; (try solve_lat) => l'.
+ case (decide (l' = l)) => [->|?]; [rewrite lookup_insert|by rewrite lookup_insert_ne].
+ case: (rel ð“¥ !! l) => [?|]; solve_lat.
+ Qed.
+
+ Lemma read_helper_closed_tview ð“¥ ð“¥' o l t tr R M
+ (READ: read_helper ð“¥ o l t tr R ð“¥')
+ (CLOSED: 𓥠∈ M) (CR: R ∈ M) (SOME: ∃ m, M !! (l, t) = Some m):
+ ð“¥' ∈ M.
+ Proof.
+ inversion READ. subst.
+ have ?: {[l := [{ t,∅,∅,{[tr]} }] ]} ∈ M.
+ { move => ??.
+ rewrite /view_lookup_write fmap_Some.
+ move => [[? ? ? ?] []] /lookup_singleton_Some [<- <-] /= ->. naive_solver. }
+ have ?: {[l := [{ t,∅,{[tr]},∅ }] ]} ∈ M.
+ { move => ??.
+ rewrite /view_lookup_write fmap_Some.
+ move => [[? ? ? ?] []] /lookup_singleton_Some [<- <-] /= ->. naive_solver. }
+ have ?: V ∈ M by subst V; case_match.
+ have ?: cur 𓥠⊔ V ∈ M by apply join_closed_view; [apply CLOSED|by auto].
+ have ?: acq 𓥠⊔ V ∈ M by apply join_closed_view; [apply CLOSED|by auto].
+ subst cur' acq'. constructor; simpl; [apply CLOSED|apply CLOSED|..].
+ - case (decide (AcqRel ⊑ _)) => _ /=; [by apply join_closed_view|by auto].
+ - subst V. case_match; [by apply join_closed_view|by auto].
+ Qed.
+
+ Lemma read_helper_view_relaxed_1 {l t tr ð“¥ ð“¥' V}
+ (RH : read_helper ð“¥ Relaxed l t tr V ð“¥'):
+ V ⊑ ð“¥'.(acq).
+ Proof. inversion RH; simpl in *. solve_lat. Qed.
+
+ Lemma read_helper_view_relaxed {l t tr ð“¥ ð“¥' oV1 oV2}
+ (RH : read_helper ð“¥ Relaxed l t tr (default ∅ oV2) ð“¥')
+ (LE: oV1 ⊑ oV2):
+ default ∅ oV1 ⊑ ð“¥'.(acq).
+ Proof. etrans; last by eapply read_helper_view_relaxed_1. by rewrite LE. Qed.
+
+ Lemma read_helper_view_acq_1 {l t tr ð“¥ ð“¥' V}
+ (RH : read_helper ð“¥ AcqRel l t tr V ð“¥'):
+ V ⊑ ð“¥'.(cur).
+ Proof. inversion RH; simpl in *. by solve_lat. Qed.
+
+ Lemma read_helper_view_acq {l t tr ð“¥ ð“¥' oV1 oV2}
+ (RH : read_helper ð“¥ AcqRel l t tr (default ∅ oV2) ð“¥')
+ (LE: oV1 ⊑ oV2):
+ default ∅ oV1 ⊑ ð“¥'.(cur).
+ Proof. etrans; last by eapply read_helper_view_acq_1. by rewrite LE. Qed.
+
+ Lemma read_helper_view_sc_1 l t tr ð“¥ ð“¥' V
+ (RH : read_helper ð“¥ SeqCst l t tr V ð“¥'):
+ V ⊑ ð“¥'.(cur).
+ Proof. inversion RH; simpl in *. by solve_lat. Qed.
+
+ Lemma read_helper_view_sc l t tr ð“¥ ð“¥' oV1 oV2
+ (RH : read_helper ð“¥ SeqCst l t tr (default ∅ oV2) ð“¥')
+ (LE: oV1 ⊑ oV2):
+ default ∅ oV1 ⊑ ð“¥'.(cur).
+ Proof. etrans; last by eapply read_helper_view_sc_1. by rewrite LE. Qed.
+
+ Lemma read_helper_view_at l t tr ð“¥ ð“¥' oV1 oV2 o
+ (RH : read_helper ð“¥ o l t tr (default ∅ oV2) ð“¥')
+ (LE: oV1 ⊑ oV2)
+ (RLX: Relaxed ⊑ o):
+ default ∅ oV1 ⊑ if decide (AcqRel ⊑ o) then ð“¥'.(cur) else ð“¥'.(acq).
+ Proof.
+ destruct o; [done|..]; simpl.
+ - by eapply read_helper_view_relaxed.
+ - by eapply read_helper_view_acq.
+ - by eapply read_helper_view_sc.
+ Qed.
+
+ Lemma read_helper_view_at_acq l t tr ð“¥ ð“¥' oV1 oV2 o
+ (RH : read_helper ð“¥ o l t tr (default ∅ oV2) ð“¥')
+ (LE: oV1 ⊑ oV2)
+ (RLX: Relaxed ⊑ o):
+ default ∅ oV1 ⊑ ð“¥'.(acq).
+ Proof.
+ etrans; first by eapply read_helper_view_at.
+ case decide => ?; [by apply cur_acq|done].
+ Qed.
+
+
+ Lemma mem_addins_closed_tview ð“¥ ð“¥' o Rr M1 ð‘š M2
+ (WRITE: write_helper ð“¥ o (mloc ð‘š) (mto ð‘š) Rr ð‘š.(mbase).(mrel) ð“¥')
+ (MADD: memory_addins ð‘š M1 M2)
+ (CLOSED: 𓥠∈ M1) : ð“¥' ∈ M2.
+ Proof.
+ inversion WRITE. clear H0.
+ have INM2: ∀ ws, {[ð‘š.(mloc) := [{ ð‘š.(mto), ws ,∅,∅ }] ]} ∈ M2.
+ { move => ???.
+ rewrite /view_lookup_write fmap_Some.
+ move => [[????] []] /lookup_singleton_Some [<- <-] /= ->. do 2 eexists.
+ split; last by eapply lookup_mem_addins_new. done. }
+ have ?: (if decide (Relaxed ⊑ o)
+ then {[ð‘š.(mloc) := [{ ð‘š.(mto),{[ð‘š.(mto)]},∅,∅ }]]}
+ else {[ð‘š.(mloc) := [{ ð‘š.(mto),∅,∅,∅ }]]}) ∈ M2.
+ { by case decide => ?; apply INM2. }
+ have ?: ð“¥.(frel) ∈ M2.
+ { eapply closed_view_addins_mono; eauto. by apply CLOSED. }
+ constructor; simpl; [|done|..].
+ - move => l. case (decide (l = mloc ð‘š)) => [->|?];
+ [rewrite lookup_insert|rewrite lookup_insert_ne; last done].
+ + repeat apply join_closed_view=>//.
+ * pose proof (closed_tview_rel _ _ CLOSED (mloc ð‘š)).
+ destruct (rel ð“¥ !! mloc ð‘š) eqn:?; [|done].
+ by eapply closed_view_addins_mono.
+ * case (decide (AcqRel ⊑ _)) => _ //.
+ apply join_closed_view => //.
+ eapply closed_view_addins_mono; eauto. apply CLOSED.
+ + eapply opt_closed_view_addins_mono=>//. apply CLOSED.
+ - apply join_closed_view => //.
+ eapply closed_view_addins_mono; eauto. apply CLOSED.
+ - apply join_closed_view; [|by auto].
+ eapply closed_view_addins_mono; eauto. apply CLOSED.
+ Qed.
+
+ Lemma write_helper_closed_tview ð“¥ ð“¥' o Rr M1 ð‘š M2
+ (WRITE: write_helper ð“¥ o (mloc ð‘š) (mto ð‘š) Rr ð‘š.(mbase).(mrel) ð“¥')
+ (MWRITE: memory_write M1 ð‘š M2)
+ (CLOSED: 𓥠∈ M1) : ð“¥' ∈ M2.
+ Proof.
+ inversion WRITE. clear H0.
+ have INM2: ∀ ws, {[ð‘š.(mloc) := [{ ð‘š.(mto), ws ,∅,∅ }] ]} ∈ M2.
+ { move => ???.
+ rewrite /view_lookup_write fmap_Some.
+ move => [[????] []] /lookup_singleton_Some [<- <-] /= ->. do 2 eexists.
+ split; last by eapply memory_write_new. done. }
+ have ?: (if decide (Relaxed ⊑ o)
+ then {[ð‘š.(mloc) := [{ ð‘š.(mto),{[ð‘š.(mto)]},∅,∅ }]]}
+ else {[ð‘š.(mloc) := [{ ð‘š.(mto),∅,∅,∅ }]]}) ∈ M2.
+ { by case decide => ?; apply INM2. }
+ have ?: ð“¥.(frel) ∈ M2.
+ { eapply memory_write_closed_view; eauto. by apply CLOSED. }
+ constructor; simpl; [|done|..].
+ - move => l.
+ case (decide (l = mloc ð‘š)) => [->|?];
+ [rewrite lookup_insert|rewrite lookup_insert_ne; last done].
+ + repeat apply join_closed_view=>//.
+ * pose proof (closed_tview_rel _ _ CLOSED (mloc ð‘š)).
+ destruct (rel ð“¥ !! mloc ð‘š)=>//.
+ eapply memory_write_closed_view=>//.
+ * case (decide (AcqRel ⊑ _)) => _ /=; [|done].
+ apply join_closed_view; [|done].
+ eapply memory_write_closed_view; eauto. apply CLOSED.
+ + eapply memory_write_opt_closed_view; eauto. by apply CLOSED.
+ - apply join_closed_view; [|by auto].
+ eapply memory_write_closed_view; eauto. apply CLOSED.
+ - apply join_closed_view; [|by auto].
+ eapply memory_write_closed_view; eauto. apply CLOSED.
+ Qed.
+
+ Lemma write_helper_fresh {ð“¥ l o t Rr Rw ð“¥'}
+ (WH: write_helper ð“¥ o l t Rr Rw ð“¥') :
+ ð“¥.(cur) !!w l ⊠Some t.
+ Proof. by inversion WH. Qed.
+
+ Lemma write_helper_read_write_relaxed' {ð“¥ l o t Rr Rw ð“¥'}
+ (WH: write_helper ð“¥ o l t Rr Rw ð“¥') (RLX: Relaxed ⊑ o) :
+ Some Rr ⊑ Rw.
+ Proof. inversion_clear WH. rewrite /write_Rw /= decide_True //. solve_lat. Qed.
+ Lemma write_helper_read_write_relaxed {ð“¥ l o t Rr Rw ð“¥'}
+ (WH: write_helper ð“¥ o l t Rr Rw ð“¥') (RLX: Relaxed ⊑ o) :
+ Rr ⊑ default ∅ Rw.
+ Proof. inversion_clear WH. rewrite /write_Rw /= decide_True //. solve_lat. Qed.
+
+ Lemma write_helper_read_write_relaxed_inv ð“¥ l o t Rr Rw ð“¥'
+ (WH: write_helper ð“¥ o l t Rr Rw ð“¥') (RLX: Relaxed ⊑ o) :
+ default ∅ Rw ⊑ Rr ⊔ ð“¥'.(cur).
+ Proof.
+ inversion_clear WH.
+ rewrite /write_Rw /= !(decide_True (P := Relaxed ⊑ o)) //.
+ have LeRel : default ∅ (ð“¥.(rel) !! l) ⊑ ð“¥.(cur) by apply rel_cur'.
+ have LeFrel : ð“¥.(frel) ⊑ ð“¥.(cur) by apply frel_cur.
+ case decide => ? /=; solve_lat.
+ Qed.
+
+ Lemma write_helper_relaxed_mrel ð“¥ l t R oV ð“¥'
+ (WH: write_helper ð“¥ Relaxed l t R oV ð“¥') :
+ Some (ð“¥.(frel) ⊔ {[l := [{ t,{[t]},∅,∅ }] ]}) ⊑ oV.
+ Proof. inversion_clear WH. rewrite /write_Rw /=. solve_lat. Qed.
+
+ Lemma write_helper_relaxed_mrel_frel ð“¥ l t R oV ð“¥'
+ (WH: write_helper ð“¥ Relaxed l t R oV ð“¥') :
+ Some ð“¥'.(frel) ⊑ oV.
+ Proof. inversion WH. rewrite /write_Rw /=. solve_lat. Qed.
+
+ Lemma write_helper_release_seqcst_mrel ð“¥ o l t R oV ð“¥'
+ (REL: AcqRel ⊑ o)
+ (WH: write_helper ð“¥ o l t R oV ð“¥'):
+ Some (ð“¥.(cur) ⊔ {[l := [{ t,{[t]},∅,∅ }] ]}) ⊑ oV.
+ Proof. inversion_clear WH. destruct o; [done|done|simpl..]; solve_lat. Qed.
+
+ Lemma write_helper_release_seqcst_mrel_cur' ð“¥ o l t R oV ð“¥'
+ (REL: AcqRel ⊑ o)
+ (WH: write_helper ð“¥ o l t R oV ð“¥'):
+ ð“¥.(cur) ⊑ default ∅ oV.
+ Proof.
+ eapply write_helper_release_seqcst_mrel in WH; [|done].
+ change (Some ð“¥.(cur) ⊑ Some (default ∅ oV)). destruct oV as [V|]; [|done].
+ simpl; etrans; [|apply WH]. solve_lat.
+ Qed.
+
+ Lemma write_helper_release_seqcst_mrel_cur ð“¥ o l t R oV ð“¥'
+ (REL: AcqRel ⊑ o)
+ (WH: write_helper ð“¥ o l t R oV ð“¥'):
+ Some ð“¥'.(cur) ⊑ oV.
+ Proof.
+ etrans; last by eapply write_helper_release_seqcst_mrel.
+ destruct o; [done|done|..]; by inversion WH.
+ Qed.
+
+ Lemma write_helper_release_mrel ð“¥ l t R oV ð“¥'
+ (WH: write_helper ð“¥ AcqRel l t R oV ð“¥'):
+ Some (ð“¥.(cur) ⊔ {[l := [{ t,{[t]},∅,∅ }] ]}) ⊑ oV.
+ Proof. by eapply write_helper_release_seqcst_mrel. Qed.
+
+ Lemma write_helper_release_mrel_cur ð“¥ l t R oV ð“¥'
+ (WH: write_helper ð“¥ AcqRel l t R oV ð“¥'):
+ Some ð“¥'.(cur) ⊑ oV.
+ Proof. by eapply write_helper_release_seqcst_mrel_cur. Qed.
+
+ Lemma write_helper_acq_tview_include {ð“¥ l t o R oV ð“¥'}
+ (WH: write_helper ð“¥ o l t R oV ð“¥') (HACQ: R ⊑ ð“¥.(acq)) :
+ oV ⊑ Some ð“¥'.(acq).
+ Proof.
+ inversion_clear WH. rewrite /write_tview /write_Rw /=.
+ case_match=>//. case_match; rewrite rel_cur' frel_cur HACQ cur_acq; solve_lat.
+ Qed.
+
+ Lemma write_helper_cur_tview_include {ð“¥ l t o R oV ð“¥'}
+ (WH: write_helper ð“¥ o l t R oV ð“¥') (CUR: R ⊑ ð“¥.(cur)) :
+ oV ⊑ Some ð“¥'.(cur).
+ Proof.
+ inversion_clear WH. rewrite /write_tview /write_Rw /=.
+ case_match=>//. case_match; rewrite rel_cur' frel_cur CUR; solve_lat.
+ Qed.
+
+ Lemma writeRw_included ð“¥ o l t R:
+ write_Rw ð“¥ o l t R ⊑ Some (R ⊔ ð“¥.(cur) ⊔ {[l := [{ t,{[t]},∅,∅ }] ]}).
+ Proof.
+ rewrite /write_Rw. case (decide _) => ?; [|done].
+ destruct (ð“¥.(rel) !! l) as [V|] eqn:EqV; simpl.
+ - have LeV: V ⊑ ð“¥.(cur).
+ { change (Some V ⊑ Some ð“¥.(cur)). rewrite -EqV. apply rel_cur. }
+ rewrite LeV frel_cur. case (decide _) => ?; solve_lat.
+ - rewrite frel_cur left_id_L. case (decide _) => ?; solve_lat.
+ Qed.
+
+
+ Lemma sc_fence_helper_closed_sc ð“¥ ð“¥' ð“¢ ð“¢' M
+ (SC: sc_fence_helper ð“¥ ð“¢ ð“¥' ð“¢')
+ (CLOSED: 𓥠∈ M) (CS: 𓢠∈ M):
+ ð“¢' ∈ M.
+ Proof. inversion SC. apply join_closed_view; [by apply CLOSED|by auto]. Qed.
+
+ Lemma sc_fence_helper_tview_sqsubseteq ð“¥ ð“¥' ð“¢ ð“¢'
+ (SC: sc_fence_helper ð“¥ ð“¢ ð“¥' ð“¢') :
+ 𓥠⊑ ð“¥'.
+ Proof.
+ inversion SC.
+ have ? : ð“¥.(acq) ⊑ (ð“¥.(acq) ⊔ ð“¢) by solve_lat.
+ constructor; rewrite /sc_fence_tview //= ?frel_cur cur_acq //.
+ Qed.
+
+ Lemma sc_fence_helper_sc_sqsubseteq ð“¥ ð“¥' ð“¢ ð“¢'
+ (SC: sc_fence_helper ð“¥ ð“¢ ð“¥' ð“¢') :
+ 𓢠⊑ ð“¢'.
+ Proof. inversion SC. solve_lat. Qed.
+
+ Lemma sc_fence_helper_closed_tview ð“¥ ð“¥' ð“¢ ð“¢' M
+ (SC: sc_fence_helper ð“¥ ð“¢ ð“¥' ð“¢')
+ (CLOSED: 𓥠∈ M) (CS: 𓢠∈ M):
+ ð“¥' ∈ M.
+ Proof.
+ inversion SC.
+ have ?: ð“¢' ∈ M by eapply sc_fence_helper_closed_sc.
+ subst. constructor; simpl; [|done..]. apply CLOSED.
+ Qed.
+
+ Lemma alloc_helper_mem_closed_tview
+ ð“¥1 ð“¥2 (ð‘šs: list message) M1 M2
+ (NONE: ∀ (n' : nat) ð‘š, ð‘šs !! n' = Some 𑚠→ ð‘š.(mbase).(mrel) = None)
+ (MALL: mem_list_addins ð‘šs M1 M2)
+ (VALL: alloc_helper ð‘šs ð“¥1 ð“¥2)
+ (CLOSED: ð“¥1 ∈ M1) : ð“¥2 ∈ M2.
+ Proof.
+ revert ð“¥1 ð“¥2 M1 M2 CLOSED MALL VALL.
+ induction ð‘šs; move => ð“¥1 ð“¥2 M1 M2 CLOSED MALL VALL.
+ - inversion VALL. inversion MALL. by subst.
+ - inversion VALL. inversion MALL. subst.
+ assert (NONE': ∀ (n' : nat) ð‘š, ð‘šs !! n' = Some 𑚠→ mrel (mbase ð‘š) = None).
+ { move => n' ð‘š In. eapply (NONE (n' + 1)).
+ rewrite (lookup_app_r (a :: nil)); simpl; last by lia.
+ rewrite (_: n' + 1 - 1 = n'); [done|by lia]. }
+ eapply mem_addins_closed_tview; eauto.
+ by rewrite (NONE 0 a).
+ Qed.
+
+ Lemma alloc_helper_tview_sqsubseteq ð‘šs ð“¥ ð“¥'
+ (ALLOC: alloc_helper ð‘šs ð“¥ ð“¥') :
+ 𓥠⊑ ð“¥'.
+ Proof.
+ induction ALLOC; first by auto.
+ apply write_helper_tview_sqsubseteq in WRITE. etrans; eauto.
+ Qed.
+
+ Lemma alloc_helper_cur_sqsubseteq ð‘šs ð“¥1 ð“¥2
+ (ALLOC: alloc_helper ð‘šs ð“¥1 ð“¥2) :
+ ∀ ð‘š, 𑚠∈ ð‘šs → Some ð‘š.(mto) ⊑ ð“¥2.(cur) !!w ð‘š.(mloc).
+ Proof.
+ move : ð“¥2 ALLOC.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => ð“¥3 ALLOC ð‘š'; first by inversion 1.
+ inversion_clear ALLOC.
+ move => /elem_of_cons [->|In].
+ - inversion WRITE. rewrite view_lookup_w_join view_lookup_w_insert.
+ solve_lat.
+ - etrans; first apply (IH _ NEXT _ In).
+ rewrite /view_lookup_write. apply fmap_sqsubseteq; [apply _|].
+ eapply write_helper_tview_sqsubseteq, WRITE.
+ Qed.
+
+ Lemma alloc_helper_awrite_ids ð‘šs ð“¥1 ð“¥2
+ (ALLOC: alloc_helper ð‘šs ð“¥1 ð“¥2) :
+ ∀ ð‘š, 𑚠∈ ð‘šs → Some ∅ ⊑ ð“¥2.(cur) !!aw ð‘š.(mloc).
+ Proof.
+ move : ð“¥2 ALLOC.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => ð“¥3 ALLOC ð‘š'; first by inversion 1.
+ inversion_clear ALLOC.
+ move => /elem_of_cons [->|In].
+ - inversion WRITE. rewrite view_lookup_aw_join view_lookup_aw_insert.
+ solve_lat.
+ - etrans; first apply (IH _ NEXT _ In).
+ apply fmap_sqsubseteq; [apply _|].
+ eapply write_helper_tview_sqsubseteq, WRITE.
+ Qed.
+
+ Lemma alloc_helper_nread_ids ð‘šs ð“¥1 ð“¥2
+ (ALLOC: alloc_helper ð‘šs ð“¥1 ð“¥2) :
+ ∀ ð‘š, 𑚠∈ ð‘šs → Some ∅ ⊑ ð“¥2.(cur) !!nr ð‘š.(mloc).
+ Proof.
+ move : ð“¥2 ALLOC.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => ð“¥3 ALLOC ð‘š'; first by inversion 1.
+ inversion_clear ALLOC.
+ move => /elem_of_cons [->|In].
+ - inversion WRITE. rewrite view_lookup_nr_join view_lookup_nr_insert.
+ solve_lat.
+ - etrans; first apply (IH _ NEXT _ In).
+ apply fmap_sqsubseteq; [apply _|].
+ eapply write_helper_tview_sqsubseteq, WRITE.
+ Qed.
+
+ Lemma alloc_helper_aread_ids ð‘šs ð“¥1 ð“¥2
+ (ALLOC: alloc_helper ð‘šs ð“¥1 ð“¥2) :
+ ∀ ð‘š, 𑚠∈ ð‘šs → Some ∅ ⊑ ð“¥2.(cur) !!ar ð‘š.(mloc).
+ Proof.
+ move : ð“¥2 ALLOC.
+ induction ð‘šs as [|ð‘š ð‘šs IH] => ð“¥3 ALLOC ð‘š'; first by inversion 1.
+ inversion_clear ALLOC.
+ move => /elem_of_cons [->|In].
+ - inversion WRITE. rewrite view_lookup_ar_join view_lookup_ar_insert.
+ solve_lat.
+ - etrans; first apply (IH _ NEXT _ In).
+ apply fmap_sqsubseteq; [apply _|].
+ eapply write_helper_tview_sqsubseteq, WRITE.
+ Qed.
+
+ Lemma alloc_helper_cur_old ð‘šs ð“¥1 ð“¥2 l
+ (UPDATE : alloc_helper ð‘šs ð“¥1 ð“¥2) (NONE: ∀ ð‘š, 𑚠∈ ð‘šs → l ≠ð‘š.(mloc)):
+ ð“¥1.(cur) !! l = ð“¥2.(cur) !! l.
+ Proof.
+ induction UPDATE; first done.
+ rewrite IHUPDATE.
+ - inversion WRITE. rewrite lookup_join lookup_insert_ne; last first.
+ { move => ?. eapply NONE; [by left|done]. }
+ by rewrite lookup_empty right_id_L.
+ - move => ð‘š' ?. apply NONE. by right.
+ Qed.
+
+ Lemma alloc_helper_rel_old ð‘šs ð“¥1 ð“¥2 l
+ (UPDATE : alloc_helper ð‘šs ð“¥1 ð“¥2) (NONE: ∀ ð‘š, 𑚠∈ ð‘šs → l ≠ð‘š.(mloc)):
+ ð“¥1.(rel) !! l = ð“¥2.(rel) !! l.
+ Proof.
+ induction UPDATE; first done.
+ rewrite IHUPDATE.
+ - inversion WRITE. rewrite /= lookup_insert_ne //.
+ move => ?. eapply NONE; [by left|done].
+ - move => ð‘š' ?. apply NONE. by right.
+ Qed.
+
+End ThreadView.
diff --git a/orc11/value.v b/orc11/value.v
new file mode 100644
index 0000000000000000000000000000000000000000..0ab6227433e3d0f8ea8bb07a70b2b9951bdaf76d
--- /dev/null
+++ b/orc11/value.v
@@ -0,0 +1,36 @@
+From orc11 Require Export base.
+
+Require Import stdpp.options.
+
+Section Val.
+
+ Context `{Countable VAL}.
+ Inductive val := | AVal | DVal | VVal (v : VAL).
+
+ Inductive isval : ∀ (v : val), Prop := val_is_val v : isval (VVal v).
+
+ Lemma NEqADVal : AVal ≠DVal. Proof. congruence. Qed.
+
+ Global Instance val_dec_eq : EqDecision val.
+ Proof using All. solve_decision. Qed.
+
+ Global Instance val_inhabited : Inhabited val := populate AVal.
+
+ Section ValCount.
+ Definition _val_to_sum (v : val): _ :=
+ match v with
+ | AVal => inl ()
+ | DVal => inr (inl ())
+ | VVal v => inr (inr v)
+ end.
+ Definition _sum_to_val s : val :=
+ match s with
+ | inl () => AVal
+ | inr (inl ()) => DVal
+ | inr (inr v) => VVal v
+ end.
+ End ValCount.
+
+ Global Instance val_countable : Countable val.
+ Proof. refine (inj_countable _val_to_sum (Some ∘ _sum_to_val) _); by intros []. Qed.
+End Val.
diff --git a/orc11/view.v b/orc11/view.v
new file mode 100644
index 0000000000000000000000000000000000000000..215c8b5ad29245c8881b8087f9f1975bfba46b8b
--- /dev/null
+++ b/orc11/view.v
@@ -0,0 +1,360 @@
+From orc11 Require Export location.
+
+Require Import stdpp.options.
+
+Notation time := (positive) (only parsing).
+Notation time_id := (positive) (only parsing).
+Notation time_ids := (gset time_id) (only parsing).
+
+Record timeInfo : Type := mkTimeInfo {
+ twrite : time;
+ tawrite: time_ids;
+ tnread : time_ids;
+ taread : time_ids;
+}.
+
+Notation "[{ t , wa , rn , ra }]" :=
+ (mkTimeInfo t wa rn ra)
+ (at level 20, format "[{ t , wa , rn , ra }]",
+ t at level 21, wa at level 21, rn at level 21, ra at level 21) : stdpp_scope.
+
+Global Instance timeInfo_dec_eq : EqDecision timeInfo.
+Proof. solve_decision. Qed.
+
+Section timeInfoCountable.
+ Definition _ti_tuple : Type := time * time_ids * time_ids * time_ids.
+ Definition _ti_to_tuple (ti: timeInfo) : _ti_tuple :=
+ (twrite ti, tawrite ti, tnread ti, taread ti).
+ Definition _tuple_to_ti (ti: _ti_tuple) : timeInfo :=
+ match ti with
+ | (t, wa, rn, ra) => ([{ t, wa, rn, ra }])
+ end.
+End timeInfoCountable.
+
+Global Instance timeInfo_countable : Countable timeInfo.
+Proof.
+ refine (inj_countable _ti_to_tuple (Some ∘ _tuple_to_ti) _); by intros [].
+Qed.
+
+Global Instance timeInfo_sqsubseteq : SqSubsetEq timeInfo :=
+ λ i1 i2, i1.(twrite) ⊑ i2.(twrite) ∧ i1.(tawrite) ⊑ i2.(tawrite) ∧
+ i1.(tnread) ⊑ i2.(tnread) ∧ i1.(taread) ⊑ i2.(taread).
+
+Global Instance timeInfo_inhabited : Inhabited timeInfo := populate ([{ 1, ∅, ∅, ∅ }]).
+
+Program Canonical Structure timeInfo_Lat : latticeT :=
+ Make_Lat timeInfo eq timeInfo_sqsubseteq
+ (λ i1 i2, [{ i1.(twrite) ⊔ i2.(twrite), i1.(tawrite) ⊔ i2.(tawrite),
+ i1.(tnread) ⊔ i2.(tnread), i1.(taread) ⊔ i2.(taread) }])
+ (λ i1 i2, [{ i1.(twrite) ⊓ i2.(twrite), i1.(tawrite) ⊓ i2.(tawrite),
+ i1.(tnread) ⊓ i2.(tnread), i1.(taread) ⊓ i2.(taread) }])
+ (populate ([{ 1, ∅, ∅, ∅ }])) _ _ _ _ _ _ _ _ _ _ _ _.
+Next Obligation.
+ constructor; first done. move => ??? [?[?[??]]] [?[?[??]]]. repeat split; by etrans.
+Qed.
+Next Obligation.
+ move => [????] [????] [?[?[??]]] [?[?[??]]]. f_equal; by apply : anti_symm.
+Qed.
+Next Obligation. intros [] []. repeat split; simpl; solve_lat. Qed.
+Next Obligation. intros [] []. repeat split; simpl; solve_lat. Qed.
+Next Obligation.
+ move => [????] [????] [????] [?[?[??]]] [?[?[??]]]. repeat split; solve_lat.
+Qed.
+Next Obligation. intros [] []. repeat split; simpl; solve_lat. Qed.
+Next Obligation. intros [] []. repeat split; simpl; solve_lat. Qed.
+Next Obligation.
+ move => [????] [????] [????] [?[?[??]]] [?[?[??]]]. repeat split; solve_lat.
+Qed.
+
+Global Instance timeInfo_sqsubseteq_dec : RelDecision (A:=timeInfo) (⊑).
+Proof. solve_decision. Qed.
+
+Global Instance timeInfo_leibniz_eq : LeibnizEquiv timeInfo.
+Proof. move => ?? //. Qed.
+
+Section View.
+ Context `{!LocFacts loc}.
+
+ Definition view := gmap loc timeInfo.
+ (* this is not canonical, as it overlaps [gmap_Lat].
+ This is to avoid TC divergence in lambda-rust-weak. *)
+ Canonical Structure view_Lat := gmap_Lat loc timeInfo_Lat.
+
+ Implicit Type (V: view).
+
+ Definition view_lookup_write: Lookup loc time view
+ := fun l V => fmap twrite (V !! l).
+ Definition view_lookup_awrite: Lookup loc time_ids view
+ := fun l V => fmap tawrite (V !! l).
+ Definition view_lookup_nread: Lookup loc time_ids view
+ := fun l V => fmap tnread (V !! l).
+ Definition view_lookup_aread: Lookup loc time_ids view
+ := fun l V => fmap taread (V !! l).
+
+ Global Instance default_view_bot : Proper ((⊑) ==> (⊑)) (default (∅: view)).
+ Proof. apply from_option_bot_proper. solve_proper. Qed.
+End View.
+Arguments view {_ _}.
+Arguments view_Lat {_ _}.
+
+
+Notation "V !!w i" := (view_lookup_write i V) (at level 20) : stdpp_scope.
+Notation "V !!aw i" := (view_lookup_awrite i V) (at level 20) : stdpp_scope.
+Notation "V !!ar i" := (view_lookup_aread i V) (at level 20) : stdpp_scope.
+Notation "V !!nr i" := (view_lookup_nread i V) (at level 20) : stdpp_scope.
+
+Section ViewLookup.
+Context `{!LocFacts loc}.
+Implicit Types (l : loc) (t: time).
+
+Lemma view_lookup_w' V l o:
+ V !! l = o → V !!w l = twrite <$> o.
+Proof. destruct o; [rewrite fmap_Some|rewrite fmap_None]; eauto. Qed.
+
+Lemma view_lookup_w V l t wsa rsn rsa :
+ V !! l = Some ([{ t, wsa, rsn , rsa }]) → V !!w l = Some t.
+Proof. rewrite fmap_Some. eauto. Qed.
+
+Lemma view_lookup_aw' V l o:
+ V !! l = o → V !!aw l = tawrite <$> o.
+Proof. destruct o; [rewrite fmap_Some|rewrite fmap_None]; eauto. Qed.
+
+Lemma view_lookup_aw V l t wsa rsn rsa :
+ V !! l = Some ([{ t, wsa, rsn , rsa }]) → V !!aw l = Some wsa.
+Proof. rewrite fmap_Some. eauto. Qed.
+
+Lemma view_lookup_nr' V l o:
+ V !! l = o → V !!nr l = tnread <$> o.
+Proof. destruct o; [rewrite fmap_Some|rewrite fmap_None]; eauto. Qed.
+
+Lemma view_lookup_nr V l t wsa rsn rsa :
+ V !! l = Some ([{ t, wsa, rsn, rsa }]) → V !!nr l = Some rsn.
+Proof. rewrite fmap_Some. eauto. Qed.
+
+Lemma view_lookup_ar' V l o:
+ V !! l = o → V !!ar l = taread <$> o.
+Proof. destruct o; [rewrite fmap_Some|rewrite fmap_None]; eauto. Qed.
+
+Lemma view_lookup_ar V l t wsa rsn rsa :
+ V !! l = Some ([{ t, wsa, rsn, rsa }]) → V !!ar l = Some rsa.
+Proof. rewrite fmap_Some. eauto. Qed.
+
+
+Lemma view_lookup_wp V l p :
+ V !! l = Some p → V !!w l = Some p.(twrite).
+Proof. rewrite fmap_Some. eauto. Qed.
+
+Lemma view_lookup_awp V l p :
+ V !! l = Some p → V !!aw l = Some p.(tawrite).
+Proof. rewrite fmap_Some. eauto. Qed.
+
+Lemma view_lookup_nrp V l p :
+ V !! l = Some p → V !!nr l = Some p.(tnread).
+Proof. rewrite fmap_Some. eauto. Qed.
+
+Lemma view_lookup_arp V l p :
+ V !! l = Some p → V !!ar l = Some p.(taread).
+Proof. rewrite fmap_Some. eauto. Qed.
+
+Lemma view_lookup_of_wp V l t :
+ V !!w l = Some t → ∃ p, p.(twrite) = t ∧ V !! l = Some p.
+Proof. rewrite fmap_Some. move => [? [-> ->]]. eauto. Qed.
+
+Lemma view_lookup_of_awp V l ws :
+ V !!aw l = Some ws → ∃ p, p.(tawrite) = ws ∧ V !! l = Some p.
+Proof. rewrite fmap_Some. move => [? [-> ->]]. eauto. Qed.
+
+Lemma view_lookup_of_nrp V l rs :
+ V !!nr l = Some rs → ∃ p, p.(tnread) = rs ∧ V !! l = Some p.
+Proof. rewrite fmap_Some. move => [? [-> ->]]. eauto. Qed.
+
+Lemma view_lookup_of_arp V l rs :
+ V !!ar l = Some rs → ∃ p, p.(taread) = rs ∧ V !! l = Some p.
+Proof. rewrite fmap_Some. move => [? [-> ->]]. eauto. Qed.
+
+Lemma view_lookup_of V l t wsa rsa rsn:
+ V !!w l = Some t → V !!aw l = Some wsa →
+ V !!nr l = Some rsn → V !!ar l = Some rsa → V !! l = Some ([{ t, wsa, rsn, rsa }]).
+Proof.
+ move/(view_lookup_of_wp _ _ _) => [[????] /= [-> ?]].
+ move/(view_lookup_of_awp _ _ _) => [[????] /= [-> ?]].
+ move/(view_lookup_of_nrp _ _ _) => [[????] /= [-> ?]].
+ move/(view_lookup_of_arp _ _ _) => [[????] /= [-> ?]].
+ by simplify_map_eq.
+Qed.
+
+Lemma view_lookup_w_join V1 V2 l:
+ (V1 ⊔ V2) !!w l = V1 !!w l ⊔ V2 !!w l.
+Proof.
+ rewrite /view_lookup_write /= lookup_join.
+ destruct (V1 !! l) as [[]|] eqn:Eq1; destruct (V2 !! l) as [[]|] eqn:Eq2;
+ rewrite ?Eq1 ?Eq2; done.
+Qed.
+
+Lemma view_lookup_aw_join V1 V2 l:
+ (V1 ⊔ V2) !!aw l = V1 !!aw l ⊔ V2 !!aw l.
+Proof.
+ rewrite /view_lookup_awrite /= lookup_join.
+ destruct (V1 !! l) as [[]|] eqn:Eq1; destruct (V2 !! l) as [[]|] eqn:Eq2;
+ rewrite ?Eq1 ?Eq2; done.
+Qed.
+
+Lemma view_lookup_nr_join V1 V2 l:
+ (V1 ⊔ V2) !!nr l = V1 !!nr l ⊔ V2 !!nr l.
+Proof.
+ rewrite /view_lookup_nread /= lookup_join.
+ destruct (V1 !! l) as [[]|] eqn:Eq1; destruct (V2 !! l) as [[]|] eqn:Eq2;
+ rewrite Eq1 Eq2; simpl; done.
+Qed.
+
+Lemma view_lookup_ar_join V1 V2 l:
+ (V1 ⊔ V2) !!ar l = V1 !!ar l ⊔ V2 !!ar l.
+Proof.
+ rewrite /view_lookup_aread /= lookup_join.
+ destruct (V1 !! l) as [[]|] eqn:Eq1; destruct (V2 !! l) as [[]|] eqn:Eq2;
+ rewrite Eq1 Eq2; simpl; done.
+Qed.
+
+Lemma view_lookup_w_insert V l p :
+ <[l := p]> V !!w l = Some p.(twrite).
+Proof. by rewrite /view_lookup_write lookup_insert. Qed.
+
+Lemma view_lookup_aw_insert V l p :
+ <[l := p]> V !!aw l = Some p.(tawrite).
+Proof. by rewrite /view_lookup_awrite lookup_insert. Qed.
+
+Lemma view_lookup_nr_insert V l p :
+ <[l := p]> V !!nr l = Some p.(tnread).
+Proof. by rewrite /view_lookup_nread lookup_insert. Qed.
+
+Lemma view_lookup_ar_insert V l p :
+ <[l := p]> V !!ar l = Some p.(taread).
+Proof. by rewrite /view_lookup_aread lookup_insert. Qed.
+
+Lemma view_lookup_w_insert_ne V l l' p :
+ l ≠l' → <[l := p]> V !!w l' = V !!w l'.
+Proof. move => ?. by rewrite /view_lookup_write lookup_insert_ne. Qed.
+
+Lemma view_lookup_aw_insert_ne V l l' p :
+ l ≠l' → <[l := p]> V !!aw l' = V !!aw l'.
+Proof. move => ?. by rewrite /view_lookup_awrite lookup_insert_ne. Qed.
+
+Lemma view_lookup_nr_insert_ne V l l' p :
+ l ≠l' → <[l := p]> V !!nr l' = V !!nr l'.
+Proof. move => ?. by rewrite /view_lookup_nread lookup_insert_ne. Qed.
+
+Lemma view_lookup_ar_insert_ne V l l' p :
+ l ≠l' → <[l := p]> V !!ar l' = V !!ar l'.
+Proof. move => ?. by rewrite /view_lookup_aread lookup_insert_ne. Qed.
+
+Lemma view_lookup_w_singleton_Some l p l' t:
+ {[l := p]} !!w l' = Some t → l' = l ∧ t = p.(twrite).
+Proof.
+ rewrite /view_lookup_write. case (decide (l' = l)) => ?; [subst l'|].
+ - by rewrite lookup_insert => [[<-]].
+ - by rewrite lookup_insert_ne.
+Qed.
+
+Lemma view_lookup_aw_singleton_Some l p l' rs:
+ {[l := p]} !!aw l' = Some rs → l' = l ∧ rs = p.(tawrite).
+Proof.
+ rewrite /view_lookup_awrite. case (decide (l' = l)) => ?; [subst l'|].
+ - by rewrite lookup_insert => [[<-]].
+ - by rewrite lookup_insert_ne.
+Qed.
+
+Lemma view_lookup_nr_singleton_Some l p l' rs:
+ {[l := p]} !!nr l' = Some rs → l' = l ∧ rs = p.(tnread).
+Proof.
+ rewrite /view_lookup_nread. case (decide (l' = l)) => ?; [subst l'|].
+ - by rewrite lookup_insert => [[<-]].
+ - by rewrite lookup_insert_ne.
+Qed.
+
+Lemma view_lookup_ar_singleton_Some l p l' rs:
+ {[l := p]} !!ar l' = Some rs → l' = l ∧ rs = p.(taread).
+Proof.
+ rewrite /view_lookup_aread. case (decide (l' = l)) => ?; [subst l'|].
+ - by rewrite lookup_insert => [[<-]].
+ - by rewrite lookup_insert_ne.
+Qed.
+
+
+Lemma view_lookup_w_singleton_None l p l':
+ {[l := p]} !!w l' = None → l' ≠l.
+Proof.
+ rewrite /view_lookup_write. case (decide (l' = l)) => [?|//]. subst l'.
+ by rewrite lookup_insert.
+Qed.
+
+Lemma view_lookup_aw_singleton_None l p l':
+ {[l := p]} !!aw l' = None → l' ≠l.
+Proof.
+ rewrite /view_lookup_awrite. case (decide (l' = l)) => [?|//]. subst l'.
+ by rewrite lookup_insert.
+Qed.
+
+Lemma view_lookup_nr_singleton_None l p l':
+ {[l := p]} !!nr l' = None → l' ≠l.
+Proof.
+ rewrite /view_lookup_nread. case (decide (l' = l)) => [?|//]. subst l'.
+ by rewrite lookup_insert.
+Qed.
+
+Lemma view_lookup_ar_singleton_None l p l':
+ {[l := p]} !!ar l' = None → l' ≠l.
+Proof.
+ rewrite /view_lookup_aread. case (decide (l' = l)) => [?|//]. subst l'.
+ by rewrite lookup_insert.
+Qed.
+
+End ViewLookup.
+
+Tactic Notation "simplify_view":= repeat
+ match goal with
+ | H : ?V !! ?l = ?o |- context P [ ?V !!w ?l ] =>
+ let o' := eval cbn in (twrite <$> o) in
+ let g := (context P [o']) in
+ cut g; first (rewrite (view_lookup_w' V l o H); exact id)
+ | H : ?V !! ?l = ?o |- context P [ ?V !!aw ?l ] =>
+ let o' := eval cbn in (tawrite <$> o) in
+ let g := (context P [o']) in
+ cut g; first (rewrite (view_lookup_aw' V l o H); exact id)
+ | H : ?V !! ?l = ?o |- context P [ ?V !!ar ?l ] =>
+ let o' := eval cbn in (taread <$> o) in
+ let g := (context P [o']) in
+ cut g; first (rewrite (view_lookup_ar' V l o H); exact id)
+ | H : ?V !! ?l = ?o |- context P [ ?V !!nr ?l ] =>
+ let o' := eval cbn in (tnread <$> o) in
+ let g := (context P [o']) in
+ cut g; first (rewrite (view_lookup_nr' V l o H); exact id)
+ end.
+
+
+Lemma view_sqsubseteq `{!LocFacts loc} (V1 V2 : view) (l : loc) :
+ V1 !! l ⊑ V2 !! l ↔
+ V1 !!w l ⊑ V2 !!w l ∧ V1 !!aw l ⊑ V2 !!aw l ∧
+ V1 !!nr l ⊑ V2 !!nr l ∧ V1 !!ar l ⊑ V2 !!ar l.
+Proof.
+ rewrite {1}/sqsubseteq /lat_sqsubseteq /= /option_sqsubseteq.
+ split.
+ - destruct (V1 !! l) as [[]|] eqn:Eq1;
+ destruct (V2 !! l) as [[]|] eqn:Eq2;
+ simplify_view; cbn; try done.
+ - destruct (V1 !! l) as [[]|] eqn:Eq1;
+ destruct (V2 !! l) as [[]|] eqn:Eq2;
+ simplify_view; cbn; try done. intuition.
+Qed.
+
+
+Global Instance twrite_sqsubseteq_proper: Proper (sqsubseteq ==> sqsubseteq) twrite.
+Proof. solve_proper. Qed.
+
+Global Instance tawrite_sqsubseteq_proper: Proper (sqsubseteq ==> sqsubseteq) tawrite.
+Proof. by intros [][] [?[?[]]]. Qed.
+
+Global Instance tnread_sqsubseteq_proper: Proper (sqsubseteq ==> sqsubseteq) tnread.
+Proof. by intros [][] [?[?[]]]. Qed.
+
+Global Instance taread_sqsubseteq_proper: Proper (sqsubseteq ==> sqsubseteq) taread.
+Proof. by intros [][] [?[?[]]]. Qed.