diff --git a/README.md b/README.md
index b66f3c9b9d52bf9a769a894e2ef24ceeb247dc4b..0505dbb605d87d93ee9c0c59f0a30b7e0bd8139c 100644
--- a/README.md
+++ b/README.md
@@ -64,6 +64,8 @@ The project follows the following structure below the `theories` folder:
* `behavior.v` defines the notion of contextual refinement and expression well-formedness.
* `adequacy.v` contains the resulting adequacy proof.
* `examples` contains example optimizations, see below.
+- `tree_borrows` contains the Simuliris development of Tree Borrows.
+ This development has its own README in `tree_borrows/README.md`.
## Theorems, definitions, and examples referenced in the paper
diff --git a/_CoqProject b/_CoqProject
index beae3548e47c677d13b0c28b1ff4e4153a3e3137..a982889c6e1eee3732cab25613e33b5ed5b9571a 100644
--- a/_CoqProject
+++ b/_CoqProject
@@ -124,7 +124,6 @@ theories/stacked_borrows/examples/coinductive.v
## Tree Borrows
-theories/tree_borrows/helpers.v
theories/tree_borrows/locations.v
theories/tree_borrows/lang_base.v
theories/tree_borrows/notation.v
@@ -136,23 +135,16 @@ theories/tree_borrows/bor_semantics.v
theories/tree_borrows/bor_lemmas.v
theories/tree_borrows/lang.v
-# Proofs directly against the operational semantics.
-# Ultimately goes in a different direction but there are useful
-# intermediate lemmas.
-# Both of these files can be removed (after extracting some lemmas)
-# if keeping them building slows down development too much.
-theories/tree_borrows/steps_preserve.v
-theories/tree_borrows/disjoint.v
-
# Actual Simuliris proof content for TB
theories/tree_borrows/defs.v
theories/tree_borrows/steps_foreach.v
-theories/tree_borrows/steps_access.v
+theories/tree_borrows/steps_preserve.v
theories/tree_borrows/steps_wf.v
theories/tree_borrows/steps_progress.v
theories/tree_borrows/steps_inv.v
theories/tree_borrows/tactics.v
+theories/tree_borrows/wishlist.v
theories/tree_borrows/class_instances.v
theories/tree_borrows/tkmap_view.v
theories/tree_borrows/logical_state.v
@@ -171,7 +163,6 @@ theories/tree_borrows/steps_all.v
theories/tree_borrows/primitive_laws.v
theories/tree_borrows/proofmode.v
theories/tree_borrows/early_proofmode.v
-theories/tree_borrows/wishlist.v
theories/tree_borrows/tree_access_laws.v
theories/tree_borrows/tag_protected_laws.v
theories/tree_borrows/loc_controlled_laws.v
@@ -202,10 +193,20 @@ theories/tree_borrows/examples/protected/mutable_reorder_read_down.v
theories/tree_borrows/examples/protected/mutable_reorder_read_up.v
theories/tree_borrows/examples/protected/shared_reorder_read_down_escaped.v
theories/tree_borrows/examples/protected/shared_reorder_read_up_escaped.v
+theories/tree_borrows/examples/protected/shared_insert_read.v
theories/tree_borrows/examples/protected/mutable_reorder_write_down_activated.v
theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated.v
+theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated_paper.v
theories/tree_borrows/examples/unprotected/mutable_delete_read.v
theories/tree_borrows/examples/unprotected/shared_delete_read_escaped.v
theories/tree_borrows/examples/unprotected/shared_delete_read_escaped_coinductive.v
theories/tree_borrows/examples/lib.v
theories/tree_borrows/examples/pure.v
+
+# Proofs directly against the operational semantics.
+# This results in a proof that reads can be reordered.
+theories/tree_borrows/read_read_reorder/low_level.v
+theories/tree_borrows/read_read_reorder/read_reorder.v
+theories/tree_borrows/read_read_reorder/equivalence_def.v
+
+
diff --git a/theories/tree_borrows/README.md b/theories/tree_borrows/README.md
index 83aeafaad388821e3e020d9c702c92afd282621d..83d9d1ddde5bb1a7ec5eeb55bd671f5724e1b862 100644
--- a/theories/tree_borrows/README.md
+++ b/theories/tree_borrows/README.md
@@ -2,14 +2,154 @@
Forked and adapted from the sibling folder `../stacked_borrows` with the same structure.
-* `tree.v`, `locations.v` contain preliminary definitions.
-* `lang_base.v`, `expr_semantics.v`, `bor_semantics.v`, and `lang.v` contain the language definition.
-* `tree_lemmas.v`, `bor_lemmas.v` and `steps_wf.v` contain basic lemmas to help with the manipulation of trees.
-* [WIP] `logical_state.v` defines the invariants and instantiates the simulation relation.
-* [WIP] `steps_refl.v` and `steps_opt.v` prove the main execution lemmas.
-* [WIP] `behavior.v` defines the notion of contextual refinement and expression well-formedness.
-* [WIP] `adequacy.v` contains the resulting adequacy proof.
-* [WIP] `examples` contains example optimizations.
-
-In addition, `disjoint.v` provides proofs of simple reorderings (swapping adjacent operations in
-a sequential setting) directly against the operational semantics.
+## Structure
+
+### TCB
+
+Our trusted computing base is the definition of our borrow calculus language.
+It consists of the following files:
+
+* `tree.v` defines our notion of trees, where nodes are indexed by tags.
+* `locations.v` defines pointers in our block-based (CompCert) memory model.
+* `lang_base.v` defines the syntax of our core calculus, which is mostly unchanged from the one in `../stacked_borrows`
+* `expr_semantics.v` defines the semantics of expressions, ignoring the aliasing model. It is also mostly unchanged from SB.
+* `bor_semantics.v` defines the semantics of retags and the aliasing. It is where most of Tree Borrows' core definitions live.
+* `parallel_subst.v` defines parallel substitution.
+* `lang.v` finally instantiates the language interface of Simuliris.
+
+Most of our example files construct an end-to-end proof against the semantics outlined in here, using the machinery provided by Simuliris.
+Of course, that end-to-end proof uses Simuliris' definition of refinement, but this definition is already in the literature.
+
+
+### Development
+
+* `defs.v` contains some more logical definitions, notably that of well-formed states (`state_wf`).
+* `tactics.v` and `class_instances.v` are some more Simuliris-related infrastructure.
+* `tree_lemmas.v`, `bor_lemmas.v`, `steps_foreach.v`, `steps_inv.v`, and `steps_preserve.v` contain basic lemmas to help with the manipulation of trees.
+* `steps_wf.v` proves that all OpSem steps preserve state well-foundedness.
+* `tree_access_laws.v` contains more complex lemmas about the entire memory (`trees`) rather than single allocations (`tree`).
+* `steps_progress.v` states success conditions for the various borrow steps so that we can prove absence of UB or exploit presence of UB.
+* `tkmap_view.v` defines views (partial ownership) of the global maps we use to remember the kind of each tag.
+* `trees_equal/` contains a number of files related to a `trees_equal` binary relation between trees.
+ In Stacked Borrows the source stack and the target stack are always identical.
+ In Tree Borrows that is no longer the case, and this relation describes the extent to which they are allowed to differ.
+* `logical_state.v` defines the invariants and instantiates the simulation relation,
+ using among others a notion of when trees are similar in `trees_equal/`.
+* `tag_protected_laws.v` contains reasoning principles about protectors.
+* `loc_controlled_laws.v` contains reasoning principles for "heaplets" and tags.
+* `steps_refl.v` and `steps_opt.v` prove the main execution lemmas.
+* `steps_all.v`, `proofmode.v`, and `primitive_laws.v` collect all laws of the program logic.
+* `wf.v` defines well-formedness for expressions, in particular that they contain no raw location literals.
+* `behavior.v` defines the notion of contextual refinement and expression well-formedness.
+* `adequacy.v` contains the resulting adequacy proof.
+* `examples/` contains example optimizations, further subdivided into
+ - `unprotected/` optimizations, which are program transformations that can be applied even in the absence of protectors,
+ - `protected/` optimizations, which require a protector to hold,
+ - `impossible/` optimizations used to hold under Stacked Borrows,
+ but we know of counter-examples under Tree Borrows.
+
+In addition, `read_read_reorder/` provides proofs of simple reorderings
+(swapping adjacent operations in a sequential setting)
+directly against the operational semantics.
+You can find more details in the associated `README.md`.
+
+## Correspondence with Section 5
+
+Section 5 has three examples, one for deleting reads, one for deleting writes, and one for reordering reads.
+
+### Paragraph 1: Deleting Reads (Example 16)
+
+This example corresponds to the one in `examples/unprotected/shared_delete_read_escaped.v`.
+The Coq example is very close to the one in the paper.
+The only difference is that `f` has an extra argument in Coq, which corresponds to the implicit environment that closures have in Rust.
+
+In the justification in the paper (around line 818), we say that a protected Reserved cousing of a tag can be conflicted in one side,
+but not in the other. In Coq, this is achieved using the `pseudo_conflicted` case of `perm_eq_up_to_C` in line 88 of `trees_equal_base.v`.
+
+### Paragraph 2: Deleting Writes (Optimizing with Protectors) (Example 17)
+
+This example corresponds to the one in `examples/protected/mutable_reorder_write_up_activated_paper.v`.
+This Coq example corresponds very closely to the one in the paper.
+The only difference is that `f` and `g` have an extra argument in Coq, which corresponds to the implicit environment that closures have in Rust.
+
+This is also where we need (and the paper finally explains) protector end semantics.
+Protector end semantics ensure that two states remain `trees_equal` even when a protector is removed.
+The main lemma here is `trees_equal_remove_call` in line 1160 of `trees_equal_endcall_law.v`,
+which shows that after the protector end access, `trees_equal` is preserved even without the just ended protector.
+
+### Paragraph 4: Reordering Reads (Example 18)
+
+This is proven in `read_read_reorder`, particularly in `read_reorder.v`.
+These proofs do not use the `simuliris` library, but instead they do a much simpler equivalence proof directly against the operational semantics.
+This is because these proofs only hold for a non-concurrent language.
+We suspect that they also hold in a concurrent setting, but this would require data race reasoning, and thus we have not proven that.
+
+Specifically, the simple notion of "equivalence after a few steps" is in `equivalence_def.v`.
+The proof that the two reads can be reordered is in `read_reorder.v`.
+The file `low_level.v` contains low-level lemmas used in `read_reorder.v`
+
+### Other Examples From The Paper
+
+Example 1 is similar to the one shown in `examples/unprotected/mutable_delete_read.v`.
+The one shown in Coq has two places where arbitrary unknown functions are called, and Example 1 is just a special case of that, if one instantiates these unknown functions correctly.
+
+We have not shown Example 14, but two examples similar to it:
+* `examples/unprotected/shared_delete_read_escaped_coinductive.v` demonstrates reasoning in a while loop.
+ But note that this does not insert a read if there is none. Also, the tag is not protected.
+* `examples/protected/shared_insert_read.v` demonstrates that reads can be inserted on protected tags.
+
+This shows that the program logic has all the reasoning primitives required for verifying Example 14,
+so that its verification would be straightforward, just needing to combine the two reasoning principles.
+
+## Program Logic
+
+As mentioned in the paper, the way we proved these refinements is using a program logic.
+This program logic can prove refinements, and uses several separation logic resources to accomplish this.
+You can see the separation logic in action in the examples shown above.
+Here, we explain the resources that you will encounter when stepping through the proof.
+
+The `$$` resource associates a "tag" with a "tag kind." Remember that each tag corresponds to a specific node in the borrow tree.
+The tag kind is a very coarse over-approximation of the shape of the tree from that specific node.
+
+The simplemost kind is `tk_local`, which says that the tree here is a singleton, and this tag is the only tag in the tree.
+`tk_local` tags are used for new fresh allocations that do not have their address taken, and allows treating them as local variables.
+
+To talk about the value of such a local tag, the "heaplet points-to" `l ↦t∗[tk_local]{t} vs` is used.
+This resource comes in two kinds, with `l ↦t∗[tk_local]{t} vs` for the target side and `l ↦s∗[tk_local]{t} vs` for the source side.
+In it, `vs` is a list of values, and this heaplet expresses knowledge that the values stored at `l` are `vs`. `vs` is a list so that we can talk about arrays; in many examples it is a singleton list.
+
+This "heaplet" resource works like the separation logic points-to. The version with `tk_local` is exclusive, expressing that this location is "local" to the function.
+`tk_local` heaplets are very unrestricted: they can be set to arbitrary values in either source and target, just like local variables.
+The rules for heaplets with a different tag kind are more restricted, as we see now.
+
+The next tag kind is `tk_unq`, which corresponds to a mutable reference. It is created when a reference is mutably retagged.
+It has two kinds: `tk_unq tk_res` and `tk_unq tk_act`, which correspond to the reservation and activation phase of a mutable reference.
+When a `tk_unq tk_res` is written to, it transitions to `tk_unq tk_act` (See rule `sim_write_activate_unprotected` in `step_laws/steps_unique.v`).
+
+The heaplet points-tos for `tk_unq` are still exclusive, since a mutable reference should give us unique access to the memory.
+Unfortunately, this is only true with protectors (see below); without protectors, these tags must be written to in lockstep and already deleting reads is restricted.
+
+Finally, there is `tk_pub`, which is the "default" permission that is also not exclusive, but persistent.
+Once a tag has been made public, the program logic exposes very weak guarantees on it, but it can be passed around freely.
+This corresponds to how it's hard to optimize around unknown pointers.
+
+`tk_pub` tags come in two kinds: Those with, and those without a heaplet.
+Those without a heaplet carry almost no information.
+Those with a heaplet are more interesting: They correspond to "frozen" tags.
+`tk_pub` heaplets are also persistent, so the values stored there can not change their value.
+This allows passing a shared reference to another function and later still knowing that the function could not have changed the value.
+
+At this point, we should mention that all heaplets represent "conditional" knowledge: They basically say that the given value is stored in memory, or that alternatively the corresponding tag has since become `Disabled`.
+This allows proving rules like lockstep reads (`sim_copy` in `step_laws/steps_unique.v`), based on the argument that either the source has UB when the tag is `Disabled`, or we know that the heaplet is still alive and hence the read is possible.
+This means that lockstep rules are typically easy to prove with our setup, but proving anything about single-sided reads is much more difficult, which is why we can only prove read removal optimizations without protectors.
+
+### Protectors
+
+Protectors allow us to prove much more optimizations.
+The reason here is that protectors give us "independent" and exclusive ownership that a certain tag is has not yet become `Disabled`.
+This is expressed using permissions like `c @@ <[t_i:=<[i +ₗ 0%nat:=EnsuringAccess Strongly]> ∅]> ∅`, which say that call `c` protects tag `t_i` at offset `i`.
+Once we have such a protector permission, we are able to treat `tk_unq` tags almost like `tk_local` tags: They can be read from and written to individually, can have unrelated values on each side, etc. (See `step_laws/steps_prot.v`.)
+
+The only restrictions here are that the activating write must still happen in lockstep (`sim_write_activate_protected` in `step_laws/steps_unique.v`), and that the values must be related when the protector ends (line 316, for lemma `sim_protected_unprotect` in `step_laws/steps_opt.v`).
+This corresponds to what we claimed in the paper (860-870).
+
diff --git a/theories/tree_borrows/behavior.v b/theories/tree_borrows/behavior.v
index 9a27df7deeb12cc4ecbcf7925697adedcddc56fb..d22e3758edaf81fe2e1c4028c4c27c1c2b119f21 100755
--- a/theories/tree_borrows/behavior.v
+++ b/theories/tree_borrows/behavior.v
@@ -20,6 +20,7 @@ Definition obs_scalar (sc_t sc_s : scalar) :=
| _, _ => False
end
.
+
Definition obs_value (v_t v_s : value) : Prop := Forall2 obs_scalar v_t v_s.
Definition obs_result (r_t r_s : val bor_lang) : Prop :=
match r_t, r_s with
diff --git a/theories/tree_borrows/bor_lemmas.v b/theories/tree_borrows/bor_lemmas.v
index 259269314005933e20baed9bc6bd5256e0303357..773a1fad384da504054b711ca9bddc9c99cec6f1 100644
--- a/theories/tree_borrows/bor_lemmas.v
+++ b/theories/tree_borrows/bor_lemmas.v
@@ -2,6 +2,13 @@ From iris.prelude Require Import prelude options.
From simuliris.tree_borrows Require Import lang_base notation bor_semantics tree tree_lemmas.
From iris.prelude Require Import options.
+(** A collection of lemmas to reason about the current state of the tree.
+ These are not invariants (you will find those in [steps_wf.v].
+ Rather, consider that this file is to [bor_semantics.v] what
+ [tree_lemmas.v] is to [tree.v]: these are specialized lemmas
+ to reason about the instanciation of trees that is specifically
+ with [item]s containing [tag]s (and some non-tree lemmas also). *)
+
Lemma most_init_comm m1 m2 : most_init m1 m2 = most_init m2 m1.
Proof. by destruct m1, m2. Qed.
@@ -32,6 +39,9 @@ Lemma exists_somewhere
a + b + c ≥ 1 <-> a ≥ 1 \/ b ≥ 1 \/ c ≥ 1.
Proof. lia. Qed.
+(** [tree_unique] is defined by [count_nodes].
+ [tree_contains] is defined by [exists_node].
+ Here are some lemmas that relate the two. *)
Lemma unique_exists {tr tg} :
tree_unique tg tr ->
tree_contains tg tr.
@@ -66,7 +76,6 @@ Proof.
reflexivity.
Qed.
-
Lemma count_0_not_exists tr tg :
tree_count_tg tg tr = 0
<-> ~tree_contains tg tr.
@@ -93,6 +102,8 @@ Proof.
+ apply IHtr2. auto.
Qed.
+(** [tree_item_determined] is defined by a [forall_nodes].
+ We can similarly relate it to predicates derived from [count_nodes]. *)
Lemma absent_determined tr tg :
tree_count_tg tg tr = 0 ->
forall it, tree_item_determined tg it tr.
@@ -148,6 +159,12 @@ Proof.
- right; right; auto.
Qed.
+(** Some of the most important lemmas here.
+ They characterizes insertion of a child node in terms of its relationship
+ with other nodes. If you insert [n'] as a child of [n]...
+ then in the resulting tree [n'] is a child of [n]!
+ Not a groundbreaking statement, but necessary due to our representation
+ of trees. *)
Lemma insert_eqv_strict_rel t t' (ins:item) (tr:tree item) (search:item -> Prop)
{search_dec:forall it, Decision (search it)} :
~IsTag t ins ->
@@ -225,69 +242,6 @@ Proof.
erewrite exists_sibling_insert. eauto.
Qed.
-Lemma join_map_eqv_strict_rel t t' (tr tr':tree item) :
- forall fn,
- (forall it it', fn it = Some it' -> itag it = itag it') ->
- join_nodes (map_nodes fn tr) = Some tr' ->
- StrictParentChildIn t t' tr <-> StrictParentChildIn t t' tr'.
-Proof.
- intros fn FnPreservesTag Success.
- generalize dependent tr'.
- unfold StrictParentChildIn.
- induction tr as [|data ? IHtr1 ? IHtr2]; intros tr' Success; simpl in *.
- - inversion Success; auto.
- - destruct (destruct_joined _ _ _ _ Success) as [data' [tr1' [tr2' [EqTr' [EqData' [EqTr1' EqTr2']]]]]].
- rewrite IHtr1; [|eapply EqTr1'].
- rewrite IHtr2; [|eapply EqTr2'].
- subst; simpl.
- split; intro H; destruct H as [H[??]]; try repeat split; try assumption.
- all: intro Hyp.
- + rewrite <- join_map_preserves_exists.
- * apply H. erewrite FnPreservesTag; eassumption.
- * intros; subst. erewrite FnPreservesTag; eauto.
- * apply EqTr2'.
- + rewrite join_map_preserves_exists.
- * apply H. erewrite <- FnPreservesTag; eassumption.
- * intros; subst. erewrite FnPreservesTag; eauto.
- * apply EqTr2'.
-Qed.
-
-Lemma join_map_eqv_rel
- {t t' tr tr' fn}
- (PreservesTags : forall it it', fn it = Some it' -> itag it = itag it')
- (Success : join_nodes (map_nodes fn tr) = Some tr')
- : ParentChildIn t t' tr <-> ParentChildIn t t' tr'.
-Proof.
- unfold ParentChildIn.
- rewrite join_map_eqv_strict_rel; eauto.
-Qed.
-
-Lemma join_map_eqv_imm_rel
- {t t' tr tr' fn}
- (PreservesTags : forall it it', fn it = Some it' -> itag it = itag it')
- (Success : join_nodes (map_nodes fn tr) = Some tr')
- : ImmediateParentChildIn t t' tr <-> ImmediateParentChildIn t t' tr'.
-Proof.
- generalize dependent tr'.
- unfold ImmediateParentChildIn.
- induction tr as [|data ? IHtr1 ? IHtr2]; intros tr' Success; simpl in *.
- - inversion Success; auto.
- - destruct (destruct_joined _ _ _ _ Success) as [data' [tr1' [tr2' [EqTr' [EqData' [EqTr1' EqTr2']]]]]].
- rewrite IHtr1; [|eapply EqTr1'].
- rewrite IHtr2; [|eapply EqTr2'].
- subst; simpl.
- split; intros (H&?&?); split_and!; try done.
- all: intro Hyp.
- + rewrite <- join_map_preserves_exists_sibling.
- * apply H. erewrite PreservesTags; eassumption.
- * intros; subst. erewrite PreservesTags; eauto.
- * apply EqTr2'.
- + rewrite join_map_preserves_exists_sibling.
- * apply H. erewrite <- PreservesTags; eassumption.
- * intros; subst. erewrite PreservesTags; eauto.
- * apply EqTr2'.
-Qed.
-
Lemma insert_produces_StrictParentChild t (ins:item) (tr:tree item) :
~IsTag t ins ->
StrictParentChildIn t ins.(itag) (insert_child_at tr ins (IsTag t)).
@@ -326,7 +280,6 @@ Proof.
intro H; contradiction.
Qed.
-
Lemma ImmediateParentChild_of_insert_is_parent t t' (ins:item) (tr:tree item) :
¬ exists_node (IsTag (ins.(itag))) tr ->
exists_node (IsTag t') tr ->
@@ -367,7 +320,76 @@ Proof.
eapply IHtr1'; first done. all: simpl in H1tr2,Hnt2; tauto.
Qed.
+(** Recall:
+ [map_nodes : (X -> Y) -> tree X -> tree Y] applies a function to each node.
+ [join_nodes : tree (option X) -> option (tree X)] collects failures.
+
+ Our semantics are mostly expressed as a combination of these two,
+ in the form of [join_nodes (map_nodes faillible_function tree)].
+ Therefore it is not surprising that these characterizations of
+ [join]+[map] are also among the most important lemmas here. *)
+Lemma join_map_eqv_strict_rel t t' (tr tr':tree item) :
+ forall fn,
+ (forall it it', fn it = Some it' -> itag it = itag it') ->
+ join_nodes (map_nodes fn tr) = Some tr' ->
+ StrictParentChildIn t t' tr <-> StrictParentChildIn t t' tr'.
+Proof.
+ intros fn FnPreservesTag Success.
+ generalize dependent tr'.
+ unfold StrictParentChildIn.
+ induction tr as [|data ? IHtr1 ? IHtr2]; intros tr' Success; simpl in *.
+ - inversion Success; auto.
+ - destruct (destruct_joined _ _ _ _ Success) as [data' [tr1' [tr2' [EqTr' [EqData' [EqTr1' EqTr2']]]]]].
+ rewrite IHtr1; [|eapply EqTr1'].
+ rewrite IHtr2; [|eapply EqTr2'].
+ subst; simpl.
+ split; intro H; destruct H as [H[??]]; try repeat split; try assumption.
+ all: intro Hyp.
+ + rewrite <- join_map_preserves_exists.
+ * apply H. erewrite FnPreservesTag; eassumption.
+ * intros; subst. erewrite FnPreservesTag; eauto.
+ * apply EqTr2'.
+ + rewrite join_map_preserves_exists.
+ * apply H. erewrite <- FnPreservesTag; eassumption.
+ * intros; subst. erewrite FnPreservesTag; eauto.
+ * apply EqTr2'.
+Qed.
+
+Lemma join_map_eqv_rel
+ {t t' tr tr' fn}
+ (PreservesTags : forall it it', fn it = Some it' -> itag it = itag it')
+ (Success : join_nodes (map_nodes fn tr) = Some tr')
+ : ParentChildIn t t' tr <-> ParentChildIn t t' tr'.
+Proof.
+ unfold ParentChildIn.
+ rewrite join_map_eqv_strict_rel; eauto.
+Qed.
+Lemma join_map_eqv_imm_rel
+ {t t' tr tr' fn}
+ (PreservesTags : forall it it', fn it = Some it' -> itag it = itag it')
+ (Success : join_nodes (map_nodes fn tr) = Some tr')
+ : ImmediateParentChildIn t t' tr <-> ImmediateParentChildIn t t' tr'.
+Proof.
+ generalize dependent tr'.
+ unfold ImmediateParentChildIn.
+ induction tr as [|data ? IHtr1 ? IHtr2]; intros tr' Success; simpl in *.
+ - inversion Success; auto.
+ - destruct (destruct_joined _ _ _ _ Success) as [data' [tr1' [tr2' [EqTr' [EqData' [EqTr1' EqTr2']]]]]].
+ rewrite IHtr1; [|eapply EqTr1'].
+ rewrite IHtr2; [|eapply EqTr2'].
+ subst; simpl.
+ split; intros (H&?&?); split_and!; try done.
+ all: intro Hyp.
+ + rewrite <- join_map_preserves_exists_sibling.
+ * apply H. erewrite PreservesTags; eassumption.
+ * intros; subst. erewrite PreservesTags; eauto.
+ * apply EqTr2'.
+ + rewrite join_map_preserves_exists_sibling.
+ * apply H. erewrite <- PreservesTags; eassumption.
+ * intros; subst. erewrite PreservesTags; eauto.
+ * apply EqTr2'.
+Qed.
Lemma Immediate_is_StrictChildTag tg tr :
HasImmediateChildTag tg tr →
@@ -868,7 +890,6 @@ Proof.
exists br2. split; [|assumption]. right; right; assumption.
Qed.
-(* FIXME: these proofs ane absolutely horrible, refactor them. *)
Lemma unique_only_one_subtree
{tr tg br1 br2} :
tree_unique tg tr ->
diff --git a/theories/tree_borrows/bor_semantics.v b/theories/tree_borrows/bor_semantics.v
index e73439694e7fc88fd2d8c54c89aec8317ef49e63..79a8ea91f9592cb8cd8589606343056053108be8 100755
--- a/theories/tree_borrows/bor_semantics.v
+++ b/theories/tree_borrows/bor_semantics.v
@@ -17,17 +17,9 @@ From Equations Require Import Equations.
From iris.prelude Require Import prelude options.
From stdpp Require Export gmap.
-From simuliris.tree_borrows Require Export lang_base notation tree tree_lemmas.
+From simuliris.tree_borrows Require Export lang_base notation tree locations.
From iris.prelude Require Import options.
-Lemma decision_equiv (P Q:Prop) :
- (P <-> Q) ->
- Decision P ->
- Decision Q.
-Proof.
- unfold Decision. tauto.
-Defined.
-
(*** TREE BORROWS SEMANTICS ---------------------------------------------***)
Implicit Type (c:call_id) (cids:call_id_set).
@@ -351,7 +343,6 @@ Definition apply_access_perm_inner (kind:access_kind) (rel:rel_pos) (isprot:bool
| AccessRead, Foreign _ =>
(* Foreign read. Makes [Reserved] conflicted, freezes [Active]. *)
match perm with
- (* FIXME: refactor *)
| Reserved ResActivable => Some (Reserved (if isprot then ResConflicted else ResActivable))
| Active => if isprot then
(* So that the function is commutative on all states and not just on reachable states,
@@ -364,7 +355,7 @@ Definition apply_access_perm_inner (kind:access_kind) (rel:rel_pos) (isprot:bool
| AccessWrite, Foreign _ =>
(* Foreign write. Disables everything except interior mutable [Reserved]. *)
match perm with
- (* TODO: remove -- this can never happen, but having it simplifies theorems. *)
+ (* NOTE: this can never happen, but having it simplifies theorems. *)
| ReservedIM => if isprot then Some Disabled else Some $ ReservedIM
| Disabled => Some Disabled
| _ => Some Disabled
@@ -401,11 +392,6 @@ Definition protector_is_for_call c prot := call_of_protector prot = Some c.
Global Instance protector_is_for_call_dec c prot : Decision (protector_is_for_call c prot).
Proof. rewrite /protector_is_for_call /call_of_protector. case_match; [case_match|]; solve_decision. Defined.
-(* FIXME: This definition overlaps with logical_state.v:protected_by
- We should pick one of them. If we pick this one it should be simplified
- to match prot with Some (mkProtector _ c) => c in cids | None => False end.
-
- In practice: delete [protector_is_active]. rename [witness_protector_is_active]. fix proofs. *)
Definition protector_is_active prot cids :=
exists c, protector_is_for_call c prot /\ call_is_active c cids.
@@ -436,6 +422,14 @@ Proof.
* inversion IsProt.
Defined.
+Lemma decision_equiv (P Q:Prop) :
+ (P <-> Q) ->
+ Decision P ->
+ Decision Q.
+Proof.
+ unfold Decision. tauto.
+Defined.
+
Global Instance protector_is_active_dec prot cids :
Decision (protector_is_active prot cids).
Proof.
@@ -507,7 +501,6 @@ Definition tree_apply_access
(* Initial permissions. *)
Definition init_perms perm off sz
- (* FIXME: simplify to just ø directly ? *)
: permissions := mem_apply_range'_defined (fun _ => mkPerm PermInit perm) (off, sz) ∅.
(* Initial tree is a single root whose default permission is [Active]. *)
@@ -568,7 +561,7 @@ Definition memory_deallocate cids t range
let post_write := memory_access AccessWrite cids t range tr in
(* Then strong protector UB. *)
let find_strong_prot : item -> option item := fun it => (
- (* FIXME: switch to plain [decide] ? *)
+ (* FIXME: consider switching to plain [decide] *)
if bool_decide (protector_is_strong it.(iprot)) && bool_decide (protector_is_active it.(iprot) cids)
then None
else Some it
@@ -595,7 +588,7 @@ Definition witness_transition p p' : Prop :=
| _, _ => False
end.
-(* FIXME: use builtin rtc *)
+(* FIXME: using builtin reflexive transitive closure could simplify some proofs. *)
Inductive witness_reach p p' : Prop :=
| witness_reach_refl : p = p' -> witness_reach p p'
| witness_reach_step p'' : witness_transition p p'' -> witness_reach p'' p' -> witness_reach p p'
@@ -613,11 +606,17 @@ Definition reach p p' : Prop :=
| _, _ => False
end.
+(* Denotes a permission that "acts like Frozen" for the purpose
+ of a later invariant. Concretely this contains
+ [Frozen], [Disabled], [Reserved ResConflicted],
+ which are the 3 permissions that are not affected by a foreign read,
+ so "acts like frozen" can mean "is allowed to coexist with shared references". *)
Definition freeze_like p : Prop :=
reach Frozen p \/ p = Reserved ResConflicted.
-(* Now we check that the two definitions are equivalent, so that the clean definition
- acts as a witness for the easy-to-do-case-analysis definition *)
+(* Now we check that the two definitions of reachability are equivalent,
+ so that the clean definition acts as a witness for the easy-to-do-case-analysis
+ definition *)
Ltac destruct_permission :=
match goal with
@@ -723,20 +722,26 @@ Proof.
all: destruct isprot'; simpl; try auto.
Qed.
+(** Some important predicates on trees. *)
+
+(** There is a node with tag [tg]. *)
Definition tree_contains tg tr
: Prop :=
exists_node (IsTag tg) tr.
+(** All nodes with tag [tg] equal [it].
+ This is often useless on its own if you don't also own a [tree_contains tg]. *)
Definition tree_item_determined tg it tr
: Prop :=
every_node (fun it' => IsTag tg it' -> it' = it) tr.
Notation has_tag tg := (fun it => bool_decide (IsTag tg it)) (only parsing).
+(** Counting how many nodes in a tree have a certain tag. *)
Definition tree_count_tg tg tr : nat := count_nodes (has_tag tg) tr.
Definition tree_unique tg tr : Prop := tree_count_tg tg tr = 1.
-(* TODO change to thing below *)
+(** Capable of lifting any of the above predicates to [trees]. *)
Definition trees_at_block prop trs blk
: Prop :=
match trs !! blk with
@@ -767,7 +772,7 @@ Definition trees_unique tg trs blk it :=
Definition ParentChildInBlk tg tg' trs blk :=
trees_at_block (ParentChildIn tg tg') trs blk.
-(* FIXME: order of args *)
+(* FIXME: Future refactoring: improve consistency of argument ordering *)
(** Reborrow *)
@@ -814,7 +819,6 @@ Definition every_tagged t (P:item -> Prop) tr
: Prop :=
every_node (fun it => IsTag t it -> P it) tr.
-(* FIXME: gmap::partial_alter ? *)
Definition apply_within_trees (fn:tree item -> option (tree item)) blk
: trees -> option trees := fun trs =>
oldtr ↠trs !! blk;
@@ -832,61 +836,6 @@ Definition trees_fresh_call cid trs blk :=
trs !! blk = Some tr ->
tree_fresh_call cid tr.
-(* FIXME: this can only do strong accesses *)
-Inductive bor_local_step tr cids
- : bor_local_event -> tree item -> call_id_set -> Prop :=
- | AccessLIS kind tr' range tg
- (EXISTS_TAG: tree_contains tg tr)
- (ACC: memory_access kind cids tg range tr = Some tr') :
- bor_local_step
- tr cids
- (AccessBLEvt kind tg range)
- tr' cids
- | InitCallLIS cid
- (INACTIVE_CID : ~cid ∈ cids)
- (FRESH_CID : tree_fresh_call cid tr) :
- bor_local_step
- tr cids
- (InitCallBLEvt cid)
- tr ({[cid]} ∪ cids)
- | EndCallLIS cid
- (EL: cid ∈ cids) :
- bor_local_step
- tr cids
- (EndCallBLEvt cid)
- tr (cids ∖ {[cid]})
- | RetagLIS tr' tgp tg pk im (cid : call_id) rk
- (EL: cid ∈ cids)
- (EXISTS_PARENT: tree_contains tgp tr)
- (FRESH_CHILD: ~tree_contains tg tr)
- (RETAG_EFFECT: create_child cids tgp tg pk im rk cid tr = Some tr') :
- bor_local_step
- tr cids
- (RetagBLEvt tgp tg pk im cid rk)
- tr' cids
- (* TODO: this is missing the no-op retag for shared interiormut. *)
- .
-
-Record seq_invariant := MkRecord {
- seq_inv : tree item -> call_id_set -> Prop;
-}.
-Inductive bor_local_seq (invariant : seq_invariant) tr cids
- : list bor_local_event -> tree item -> call_id_set -> Prop :=
- | bor_nil
- (INV : invariant.(seq_inv) tr cids) :
- bor_local_seq invariant
- tr cids
- []
- tr cids
- | bor_cons evt tr' cids' evts tr'' cids''
- (INV : invariant.(seq_inv) tr cids)
- (HEAD : bor_local_step tr cids evt tr' cids')
- (REST : bor_local_seq invariant tr' cids' evts tr'' cids'') :
- bor_local_seq invariant
- tr cids
- (evt :: evts)
- tr'' cids''.
-
(* Traverse the entire tree and get for each tag protected by cid its currently initialized locations.
Those are all the locations that we'll do a read access through, or even a write access if it is Active *)
Definition tree_get_all_protected_tags_initialized_locs (cid : nat) (tr : tree item)
@@ -914,7 +863,9 @@ Definition tree_access_all_protected_initialized (cids : call_id_set) (cid : nat
(* finally we can combine this all *)
set_fold (fun '(tg, init_locs) (tr:option (tree item)) => tr ↠tr; reader_locs tg init_locs tr) (Some tr) init_locs.
-(* FIXME: IMPORTANT: don't make the access visible to children ! *)
+(* WARNING: don't make the access visible to children!
+ You can check in `trees_access_all_protected_initialized` that we properly use
+ `memory_access_nonchildren_only`. *)
(* Finally we read all protected initialized locations on the entire trees by folding it
for each tree separately.
NOTE: be careful about how other properties assume the uniqueness of tags intra- and inter- trees,
@@ -929,8 +880,9 @@ Definition trees_access_all_protected_initialized (cids : call_id_set) (cid : na
Inductive bor_step (trs : trees) (cids : call_id_set) (nxtp : nat) (nxtc : call_id)
: event -> trees -> call_id_set -> nat -> call_id -> Prop :=
| AllocIS (blk : block) (off : Z) (sz : nat)
+ (* Memory allocation *)
(FRESH : trs !! blk = None)
- (NONZERO : (sz > 0)%nat) : (* FIXME: should we have an event for zero-size allocations ? *)
+ (NONZERO : (sz > 0)%nat) :
bor_step
trs cids nxtp nxtc
(AllocEvt blk nxtp (off, sz))
@@ -951,14 +903,18 @@ Inductive bor_step (trs : trees) (cids : call_id_set) (nxtp : nat) (nxtc : call_
trs cids nxtp nxtc
(CopyEvt alloc tg range val)
trs cids nxtp nxtc
- | FailedCopyIS (alloc : block) range tg
+(* | FailedCopyIS (alloc : block) range tg
(* Unsuccessful read access just returns poison instead of causing UB *)
+ (* WARNING: SB works like this, having failed reads return poison
+ instead of triggering UB. We can't do this for Tree Borrows.
+ This was a hack for SB anyway, and not having it gives a stronger result.
+ *)
(EXISTS_TAG : trees_contain tg trs alloc)
(ACC : apply_within_trees (memory_access AccessRead cids tg range) alloc trs = None) :
bor_step
trs cids nxtp nxtc
(FailedCopyEvt alloc tg range)
- trs cids nxtp nxtc
+ trs cids nxtp nxtc *)
| WriteIS trs' (alloc : block) range tg val
(* Successful write access *)
(EXISTS_TAG: trees_contain tg trs alloc)
@@ -981,7 +937,6 @@ Inductive bor_step (trs : trees) (cids : call_id_set) (nxtp : nat) (nxtc : call_
We want to do the read *after* the insertion so that it properly initializes the locations of the range. *)
(EL: cid ∈ cids)
(EXISTS_TAG: trees_contain parentt trs alloc)
- (* TODO get rid of fresh_child assumption here *)
(FRESH_CHILD: ~trees_contain nxtp trs alloc)
(RETAG_EFFECT: apply_within_trees (create_child cids parentt nxtp pk im rk cid) alloc trs = Some trs')
(READ_ON_REBOR: apply_within_trees (memory_access AccessRead cids nxtp range) alloc trs' = Some trs'') :
@@ -990,9 +945,8 @@ Inductive bor_step (trs : trees) (cids : call_id_set) (nxtp : nat) (nxtc : call_
(RetagEvt alloc range parentt nxtp pk im cid rk)
trs'' cids (S nxtp) nxtc
| RetagNoopIS parentt (alloc : block) range pk im cid rk
- (* For a retag we require that the parent exists and the introduced tag is fresh, then we do a read access.
- NOTE: create_child does not read, it only inserts, so the read needs to be explicitly added.
- We want to do the read *after* the insertion so that it properly initializes the locations of the range.*)
+ (* This is a noop retag. Some "retagging" operations don't actually do anything,
+ e.g. raw pointer retags. *)
(EL: cid ∈ cids)
(EXISTS_TAG: trees_contain parentt trs alloc)
(IS_NOOP: retag_perm pk im rk = None) :
@@ -1023,11 +977,29 @@ Inductive bor_step (trs : trees) (cids : call_id_set) (nxtp : nat) (nxtc : call_
trs' (cids ∖ {[c]}) nxtp nxtc
.
+Inductive bor_steps trs cids nxtp nxtc
+ : list event -> trees -> call_id_set -> nat -> call_id -> Prop :=
+ | BorStepsDone :
+ bor_steps
+ trs cids nxtp nxtc
+ []
+ trs cids nxtp nxtc
+ | BorStepsMore evt evts
+ trs1 cids1 nxtp1 nxtc1
+ trs2 cids2 nxtp2 nxtc2
+ (HEAD : bor_step trs cids nxtp nxtc evt trs1 cids1 nxtp1 nxtc1)
+ (REST : bor_steps trs1 cids1 nxtp1 nxtc1 evts trs2 cids2 nxtp2 nxtc2) :
+ bor_steps
+ trs cids nxtp nxtc
+ (evt :: evts)
+ trs2 cids2 nxtp2 nxtc2
+ .
+
+(** Unit test for the tree relation definition, showing how it works *)
(* conversion is magic *)
Local Definition unpack_option {A:Type} (o : option A) {oo : A} (Heq : o = Some oo) : A := oo.
Local Notation unwrap K := (unpack_option K eq_refl).
-
Local Definition initial_tree := init_tree 1 0 4.
Local Definition with_one_child :=
unwrap (create_child ∅ 1 2 MutRef TyFrz Default 0 initial_tree).
@@ -1045,6 +1017,8 @@ Local Definition with_three_children :=
In particular, 4 is a non-immediate child of 1, but all other child relations are immediate.
*)
+
+(** Having constructed the above tree, we can now check that all relations are computed correctly *)
(* conversion keeps being magical *)
Succeed Example foo : rel_dec with_three_children 1 1 = Child This := eq_refl.
Succeed Example foo : rel_dec with_three_children 1 2 = Foreign (Parent Immediate) := eq_refl.
@@ -1063,7 +1037,3 @@ Succeed Example foo : rel_dec with_three_children 4 2 = Child (Strict Immediate)
Succeed Example foo : rel_dec with_three_children 4 3 = Foreign Cousin := eq_refl.
Succeed Example foo : rel_dec with_three_children 4 4 = Child This := eq_refl.
-
-
-
-
diff --git a/theories/tree_borrows/class_instances.v b/theories/tree_borrows/class_instances.v
index 70ffe1229267b71d0fad607600075f066fec526e..985b8b09679927f47dc5321c9b6c27d266d64b72 100755
--- a/theories/tree_borrows/class_instances.v
+++ b/theories/tree_borrows/class_instances.v
@@ -13,7 +13,6 @@ Section pure_exec.
subst; intros ?; apply nsteps_once, pure_base_step_pure_step;
constructor; [solve_exec_safe | solve_exec_puredet].
-
(*pure_expr_step*)
Global Instance pure_iota_val x (e2 : expr) (v1 : value) :
PureExec True 1 (Let x (Val v1) e2) (subst' x (Val v1) e2).
@@ -225,7 +224,7 @@ Section safe_reach.
Global Instance safe_implies_copy_place P σ l tg (sz:nat) :
SafeImplies ( (∃ v, read_mem l sz σ.(shp) = Some v ∧ trees_contain tg σ.(strs) l.1 ∧ is_Some (apply_within_trees (memory_access AccessRead σ.(scs) tg (l.2, sz)) l.1 σ.(strs)) ∧ sz ≠0%nat)
∨ (∃ v, read_mem l sz σ.(shp) = Some v ∧ sz = 0%nat)
- ∨ (trees_contain tg σ.(strs) l.1 ∧ apply_within_trees (memory_access AccessRead σ.(scs) tg (l.2, sz)) l.1 σ.(strs) = None ∧ is_Some (read_mem l sz σ.(shp)))) P (Copy (Place l tg sz)) σ.
+ (*∨ (trees_contain tg σ.(strs) l.1 ∧ apply_within_trees (memory_access AccessRead σ.(scs) tg (l.2, sz)) l.1 σ.(strs) = None ∧ is_Some (read_mem l sz σ.(shp)))*)) P (Copy (Place l tg sz)) σ.
Proof. prove_safe_implies. Qed.
Global Instance safe_implies_write_val_left1 P σ v v' :
diff --git a/theories/tree_borrows/defs.v b/theories/tree_borrows/defs.v
index 4cd1a08e23c98fc10ecc2194fce41e9b52823a0a..8f8c276b9c52a5cf1c98627ad50089adc7a69dbc 100755
--- a/theories/tree_borrows/defs.v
+++ b/theories/tree_borrows/defs.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From iris.prelude Require Export prelude.
From simuliris.tree_borrows Require Export tactics notation lang bor_semantics bor_lemmas.
From iris.prelude Require Import options.
@@ -16,15 +12,28 @@ Definition wf_mem_tag (h: mem) (nxtp: tag) :=
Definition lazy_perm_wf (lp : lazy_permission) :=
lp.(perm) = Active → lp.(initialized) = PermInit.
+(** Well-formedness constraints on items *)
Record item_wf (it:item) (nxtp:tag) (nxtc:call_id) := {
+ (** Tag is valid *)
item_tag_valid : forall tg, IsTag tg it -> (tg < nxtp)%nat;
+ (** Callid is valid *)
item_cid_valid : forall cid, protector_is_for_call cid (iprot it) -> (cid < nxtc)%nat;
+ (** Permission registered as "default" can't be Active *)
item_default_perm_valid : it.(initp) ≠Active;
+ (** Only protected items can have ReservedIM somewhere in their permissions *)
item_perms_reserved_im_protected : is_Some (it.(iprot)) → ∀ off, (default (mkPerm PermLazy it.(initp)) (it.(iperm) !! off)).(perm) = ReservedIM → False;
+ (** Active implies initialized *)
item_perms_valid : map_Forall (λ _, lazy_perm_wf) it.(iperm);
+ (** Current permission is reachable from initial permission. (This guarantees no Active on shared references) *)
item_perm_reachable : it.(initp) ≠Disabled → map_Forall (λ k v, reach it.(initp) (perm v)) it.(iperm)
}.
+(** Relating the state of the current item with that of its parents.
+ The important properties are:
+ - an initialized item must have initialized parents,
+ - an Active item must have Active parents,
+ - a protected must not have Disabled parents.
+ *)
Definition item_all_more_init itp itc := ∀ l, initialized (item_lookup itc l) = PermInit → initialized (item_lookup itp l) = PermInit.
Definition parents_more_init (tr : tree item) := ∀ tg, every_child tg item_all_more_init tr.
Definition item_all_more_active itp itc := ∀ l, perm (item_lookup itc l) = Active → perm (item_lookup itp l) = Active.
@@ -45,9 +54,8 @@ Definition tree_items_unique (tr:tree item) :=
Definition tree_items_compat_nexts (tr:tree item) (nxtp:tag) (nxtc: call_id) :=
every_node (λ it, item_wf it nxtp nxtc) tr.
- (* FIXME: rename above to just tree_items_wf *)
+ (* FIXME: Improve consistency of naming conventions *)
-(* FIXME: consistent naming *)
Definition wf_tree (tr:tree item) :=
tree_items_unique tr.
Definition each_tree_wf (trs:trees) :=
@@ -69,23 +77,16 @@ Definition trees_compat_nexts (trs:trees) (nxtp:tag) (nxtc: call_id) :=
∀ blk tr, trs !! blk = Some tr → tree_items_compat_nexts tr nxtp nxtc.
Definition wf_non_empty (trs:trees) :=
∀ blk tr, trs !! blk = Some tr → tr ≠empty.
-(*
-Definition wf_no_dup (α: stacks) :=
- ∀ l stk, α !! l = Some stk → NoDup stk.
-*)
+
Definition wf_cid_incl (cids: call_id_set) (nxtc: call_id) :=
∀ c : call_id, c ∈ cids → (c < nxtc)%nat.
Definition wf_scalar t sc := ∀ t' l, sc = ScPtr l t' → t' < t.
-(* mem ~ gmap loc scalar
-*)
-
Definition same_blocks (hp:mem) (trs:trees) :=
dom trs =@{gset _} set_map fst (dom hp).
Arguments same_blocks / _ _.
-(* OLD: forall blk l, is_Some (hp !! (blk, l)) -> is_Some (trs !! blk). *)
-(* FIXME: map fst (dom hp) === dom trs *)
-(* FIXME: forall blk, (exists l, is_Some (hp !! (blk, l))) <-> is_Some (trs !! blk). *)
+(* Formerly: map fst (dom hp) === dom trs
+ However this is no longer accurate. *)
Definition root_invariant blk it (shp : mem) :=
it.(iprot) = None ∧ it.(initp) = Disabled ∧
@@ -94,7 +95,6 @@ Definition root_invariant blk it (shp : mem) :=
| Some (mkPerm PermLazy Disabled) | None => shp !! (blk, off) = None
| _ => False end.
-
Definition tree_root_compatible (tr : tree item) blk shp :=
match tr with empty => False | branch it sib _ => root_invariant blk it shp ∧ sib = empty end.
@@ -102,22 +102,29 @@ Definition tree_roots_compatible (trs : trees) shp :=
∀ blk tr, trs !! blk = Some tr → tree_root_compatible tr blk shp.
+(* A State is well-formed if... *)
Record state_wf (s: state) := {
- (*state_wf_dom : dom s.(shp) ≡ dom s.(strs); Do we care ? After all TB is very permissive about the range, so out-of-bounds UB is *always* triggered at the level of the heap, not the trees *)
+ (*state_wf_dom : dom s.(shp) ≡ dom s.(strs);
+ This was included in SB but we don't care anymore because TB
+ is very permissive about the range so out-of-bounds UB is *always*
+ triggered by `expr_semantics` not `bor_semantics`. *)
+
+ (* The heap and the trees talk of the same allocations *)
state_wf_dom : same_blocks s.(shp) s.(strs);
- (*state_wf_mem_tag : wf_mem_tag s.(shp) s.(snp);*) (* FIXME: this seems to state that all pointers are wf, it should be included *)
+ (* Every tree is well-formed (includes uniqueness of tags) *)
state_wf_tree_unq : wf_trees s.(strs);
+ (* The child-parent constraints relating to initialization etc. hold *)
state_wf_tree_more_init : each_tree_parents_more_init s.(strs);
state_wf_tree_more_active : each_tree_parents_more_active s.(strs);
state_wf_tree_not_disabled : each_tree_protected_parents_not_disabled s.(scs) s.(strs);
+ (* Some other constraints on relations (cousins can't be simultaneously active) *)
state_wf_tree_no_active_cousins : each_tree_no_active_cousins s.(scs) s.(strs);
+ (* "next fresh tag" is fresh. *)
state_wf_tree_compat : trees_compat_nexts s.(strs) s.(snp) s.(snc);
- (* state_wf_non_empty : wf_non_empty s.(strs); *)
+ (* Every root pointer is active *)
state_wf_roots_active : tree_roots_compatible s.(strs) s.(shp);
- (*state_wf_cid_no_dup : NoDup s.(scs) ;*) (* FIXME: call ids are unique, include this *)
+ (* "next fresh callid" is fresh. *)
state_wf_cid_agree: wf_cid_incl s.(scs) s.(snc);
- (* state_wf_cid_non_empty : s.(scs) ≠[]; *)
- (* state_wf_no_dup : wf_no_dup σ.(cst).(sst); *)
}.
Definition init_state := (mkState ∅ ∅ {[O]} O 1).
diff --git a/theories/tree_borrows/disjoint.v b/theories/tree_borrows/disjoint.v
deleted file mode 100644
index 3931894958715690f2559c5c728a0916f18e2414..0000000000000000000000000000000000000000
--- a/theories/tree_borrows/disjoint.v
+++ /dev/null
@@ -1,1990 +0,0 @@
-(** This file proves some simple reorderings directly against the operational semantics
- in sequential code.
-
- For example we prove here the fact that in any context, two adjacent read
- accesses can be swapped and the resulting state is identical to the initial state.
- Because these proofs use a different definition of bor_step and do not involve
- parallelism, the lemmas established here are *definitely not useful* for the rest
- of the project.
-
- Results proven here:
- (1) any combination of two consecutive accesses of which
- - exactly one is through a foreign pointer,
- - at least one is a write,
- - (sometimes with the extra restriction that one is protected)
- that does not result in UB means that the two accesses must be on disjoint
- ranges of memory.
- (2) any pair of adjacent reads can be swapped to obtain an identical final state.
-
- These two combine into (1) + (2) : any two accesses of which exactly one
- is foreign can be swapped (with the appropriate protector restrictions).
-
- I.e. this file culminates with the theorem `llvm_noalias_reorder`
- that states that if `x` is
- - retagged by the current function, and
- - protected during the entire process, and
- - not an ancestor of `y`
- then for an arbitrary access `Ax` through `x` on range `Rx` and an arbitrary
- access `Ay` through `y` on range `Ry`, for any initial state S,
- S --[Ax(x, Rx)]-> _ --[Ay(y, Ry)]-> S'
- if and only if
- S --[Ay(y, Ry)]-> _ --[Ax(x, Rx)]-> S'
- *)
-From iris.prelude Require Import prelude options.
-From stdpp Require Export gmap.
-From simuliris.tree_borrows Require Import lang_base notation bor_semantics tree tree_lemmas bor_lemmas steps_preserve.
-From iris.prelude Require Import options.
-
-(*
-(* TODO do not forget *)
-Check neven_see_also_the_todo_for_the_local_step_semantics_which_is_missing_a_case.
-
-(* Key lemma: converts the entire traversal to a per-node level.
-This is applicable to every permission in the accessed range, all that's needed
-to complement it should be preservation of permissions outside of said range. *)
-Lemma access_effect_per_loc_within_range
- {tr affected_tag access_tag pre kind cids cids' range tr' z zpre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Step : bor_local_step tr cids (AccessBLEvt kind access_tag range) tr' cids')
- : exists post zpost, (
- let rel := rel_dec tr access_tag affected_tag in
- let isprot := bool_decide (protector_is_active pre.(iprot) cids) in
- apply_access_perm kind rel isprot zpre = Some zpost
- /\ tree_item_determined affected_tag post tr'
- /\ item_lazy_perm_at_loc post z = zpost
- /\ iprot post = iprot pre
- ).
-Proof.
- inversion Step as [???? EXISTS_TAG ACC| | | ]; subst.
- (* use apply_access_spec_per_node to get info on the post permission *)
- destruct (apply_access_spec_per_node Ex Unq ACC) as [post [SpecPost [ContainsPost UniquePost]]].
- (* and then it's per-tag work *)
- rewrite (tree_determined_specifies_tag _ _ _ Ex Unq) in SpecPost.
- option step in SpecPost as ?:tmpSpec.
- injection SpecPost; intro H; subst; clear SpecPost.
- (* now down to per-location *)
- pose proof (mem_apply_range'_spec _ _ z _ _ tmpSpec) as ForeachSpec.
- rewrite (decide_True _ _ Within) in ForeachSpec.
- destruct ForeachSpec as [lazy_perm [PermExists ForeachSpec]].
- assert (default {| initialized := PermLazy; perm := initp pre |} (iperm pre !! z) = item_lazy_perm_at_loc pre z) as InitPerm. {
- unfold item_lazy_perm_at_loc, item_lookup. destruct (iperm pre !! z); simpl; reflexivity.
- } rewrite InitPerm in ForeachSpec.
- eexists. eexists.
- split; [|split; [|split]]; [|exact UniquePost|reflexivity|reflexivity].
- simpl in ForeachSpec.
- rewrite ForeachSpec.
- unfold item_lazy_perm_at_loc, item_lookup.
- rewrite PermExists; simpl; reflexivity.
-Qed.
-
-Lemma access_effect_per_loc_outside_range
- {tr affected_tag access_tag pre kind cids cids' range tr' z zpre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Outside : ~range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Step : bor_local_step tr cids (AccessBLEvt kind access_tag range) tr' cids')
- : exists post, (
- tree_item_determined affected_tag post tr
- /\ item_lazy_perm_at_loc post z = zpre
- /\ iprot post = iprot pre
- ).
-Proof.
- inversion Step as [???? EXISTS_TAG ACC| | | ]; subst.
- destruct (apply_access_spec_per_node Ex Unq ACC) as [post [SpecPost [ContainsPost UniquePost]]].
- (* We now show that
- (1) post has zpre at loc z
- (2) post is equal to whatever item the goal refers to *)
- assert (item_lazy_perm_at_loc post z = item_lazy_perm_at_loc pre z) as SamePerm. {
- option step in SpecPost as ?:SpecPerms.
- injection SpecPost; intros; subst; clear SpecPost.
- pose proof (mem_apply_range'_spec _ _ z _ _ SpecPerms) as RangeForeach.
- rewrite (decide_False _ _ Outside) in RangeForeach.
- unfold item_lazy_perm_at_loc, item_lookup; simpl.
- rewrite RangeForeach; reflexivity.
- }
- eexists.
- split; [|split]; [exact Unq|reflexivity|reflexivity].
-Qed.
-
-(* Strategy for lemmas of the form
-
-Lemma _
- (Ex : tree_contains ?aff ?tr)
- (Unq : tree_item_determined ?aff ?pre ?tr)
- (Within : range_contains ?range ?z)
-
- optional: (Nonchild : ~ParentChildIn ?aff ?acc ?tr)
- optional: (Child : ParentChildIn ?aff ?acc ?tr)
- optional: restrictions on (perm ?pre), e.g. reachability
- optional: protector_is_active (iprot ?pre) ?cids
-
-(Step : bor_local_step ?tr ?cids (AccessBLEvt _ ?acc ?range) ?tr' _)
- : _.
-
-Where the conclusion can be either
-* there is UB:
- : False.
-* there is some item in the new tree that is related to ?pre:
- : exists post zpost, (
- tree_item_determined ?aff post ?tr'
- /\ item_lazy_perm_at_loc post z = zpost
- /\ iprot post = iprot pre
- /\ ...
- optional: restrictions on reachability of (perm zpost),
- e.g. reach (perm ?pre) ?(perm zpost)
- ).
-
-These lemmas can be solved by a case analysis on ?pre, which the following tactic performs *)
-Ltac auto_access_event_within_range :=
- match goal with
- (* First off, if we see an access step, we apply the key per-location lemma *)
- | Ex : tree_contains ?aff ?tr,
- Unq : tree_item_determined ?aff ?pre ?tr,
- Within : range'_contains ?range ?z,
- Step : bor_local_step ?tr _ (AccessBLEvt _ _ ?range) _ _
- |- exists _ _, _ =>
- destruct (access_effect_per_loc_within_range Ex Unq Within eq_refl Step) as [post[zpost[?[?[??]]]]];
- exists post, zpost;
- clear Step Unq Within Ex
- | Ex : tree_contains ?aff ?tr,
- Unq : tree_item_determined ?aff ?pre ?tr,
- Within : range'_contains ?range ?z,
- Step : bor_local_step ?tr _ (AccessBLEvt _ _ ?range) _ _
- |- _ =>
- destruct (access_effect_per_loc_within_range Ex Unq Within eq_refl Step) as [post[zpost[?[?[??]]]]];
- clear Step Unq Within Ex
- (* if we need to solve a naive_rel_dec, we look for a known one *)
- | H : context[rel_dec ?tr ?acc ?aff]
- |- _ => unfold rel_dec in H;
- destruct (decide (ParentChildIn _ _ _)); try contradiction;
- destruct (decide (ParentChildIn _ _ _)); try contradiction
- (* we might need to decide protectors *)
- | H : context[bool_decide (protector_is_active ?p ?cids)],
- P : protector_is_active ?p ?cids
- |- _ => rewrite (bool_decide_eq_true_2 _ P) in H
- | H : context[bool_decide (protector_is_active ?p ?cids)]
- |- _ => destruct (bool_decide (protector_is_active _ _))
- (* we'd always rather work on permissions directly than item_lazy_perm_at_loc *)
- | E : item_lazy_perm_at_loc ?x ?z = _,
- H : context[item_lazy_perm_at_loc ?x ?z]
- |- _ => rewrite E in H
- (* and then big case analysis *)
- | x : lazy_permission |- _ => destruct x; simpl in *
- | p : permission |- _ => destruct p as [[][]| | |]; simpl in *
- | i : perm_init |- _ => destruct i; simpl in *
- | H : apply_access_perm _ _ _ _ = Some _ |- _ => try (inversion H; done); clear H
- (* when all the rest is done, you can split and auto *)
- | |- _ => subst; try repeat split; eauto
- end
- .
-
-Lemma nonchild_write_reserved_to_disabled
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Nonchild : ~ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Reach : reach (Reserved TyFrz ResActivable) (perm zpre))
- (Step : bor_local_step tr cids (AccessBLEvt AccessWrite access_tag range) tr' cids')
- : exists post zpost, (
- tree_item_determined affected_tag post tr'
- /\ item_lazy_perm_at_loc post z = zpost
- /\ reach Disabled (perm zpost)
- /\ iprot post = iprot pre
- ).
-Proof. do 11 auto_access_event_within_range. Qed.
-
-Lemma nonchild_write_any_protected_to_disabled
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Nonchild : ~ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Protected : protector_is_active (iprot pre) cids)
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Step : bor_local_step tr cids (AccessBLEvt AccessWrite access_tag range) tr' cids')
- : exists post zpost, (
- tree_item_determined affected_tag post tr'
- /\ item_lazy_perm_at_loc post z = zpost
- /\ reach Disabled (perm zpost)
- /\ iprot post = iprot pre
- ).
-Proof. do 11 auto_access_event_within_range. Qed.
-
-Check neven_see_also_the_todo_for_the_local_step_semantics_which_is_missing_a_case.
-
-Lemma nonchild_read_active_to_frozen
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Nonchild : ~ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Reach : reach Active (perm zpre))
- (Step : bor_local_step tr cids (AccessBLEvt AccessRead access_tag range) tr' cids')
- : exists post zpost, (
- tree_item_determined affected_tag post tr'
- /\ item_lazy_perm_at_loc post z = zpost
- /\ reach Frozen (perm zpost)
- /\ reach (perm zpre) (perm zpost)
- ).
-Proof. do 11 auto_access_event_within_range. Qed.
-
-Lemma child_write_frozen_to_ub
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Child : ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Reach : reach Frozen (perm zpre))
- (Step : bor_local_step tr cids (AccessBLEvt AccessWrite access_tag range) tr' cids')
- : False.
-Proof. do 11 auto_access_event_within_range. Qed.
-
-Lemma child_write_protected_freeze_like_to_ub
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Child : ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Within : range'_contains range z)
- (Protected : protector_is_active (iprot pre) cids)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (FrzLike : freeze_like (perm zpre))
- (Step : bor_local_step tr cids (AccessBLEvt AccessWrite access_tag range) tr' cids')
- : False.
-Proof.
- unfold freeze_like in FrzLike.
- destruct FrzLike as [?|[?|?]].
- all: do 11 auto_access_event_within_range.
-Qed.
-
-Lemma child_read_disabled_to_ub
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Child : ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Reach : reach Disabled (perm zpre))
- (Step : bor_local_step tr cids (AccessBLEvt AccessRead access_tag range) tr' cids')
- : False.
-Proof. do 11 auto_access_event_within_range. Qed.
-
-Lemma child_write_any_to_init_active
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Child : ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Step : bor_local_step tr cids (AccessBLEvt AccessWrite access_tag range) tr' cids')
- : exists post zpost, (
- tree_item_determined affected_tag post tr'
- /\ item_lazy_perm_at_loc post z = zpost
- /\ perm zpost = Active
- /\ iprot post = iprot pre
- /\ initialized zpost = PermInit
- ).
-Proof. do 11 auto_access_event_within_range. Qed.
-
-Lemma child_read_any_to_init_nondis
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Child : ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Step : bor_local_step tr cids (AccessBLEvt AccessRead access_tag range) tr' cids')
- : exists post zpost, (
- tree_item_determined affected_tag post tr'
- /\ item_lazy_perm_at_loc post z = zpost
- /\ ~reach Disabled (perm zpost)
- /\ iprot post = iprot pre
- /\ initialized zpost = PermInit
- ).
-Proof. do 15 auto_access_event_within_range. Qed.
-
-
-Lemma protected_nonchild_write_initialized_to_ub
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Nonchild : ~ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Protected : protector_is_active (iprot pre) cids)
- (Initialized : initialized (item_lazy_perm_at_loc pre z) = PermInit)
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (NonDis : ~reach Disabled (perm zpre))
- (Step : bor_local_step tr cids (AccessBLEvt AccessWrite access_tag range) tr' cids')
- : False.
-Proof. do 15 auto_access_event_within_range. Qed.
-
-Lemma protected_nonchild_read_initialized_active_to_ub
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Nonchild : ~ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Protected : protector_is_active (iprot pre) cids)
- (Initialized : initialized (item_lazy_perm_at_loc pre z) = PermInit)
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Activated : perm zpre = Active)
- (Step : bor_local_step tr cids (AccessBLEvt AccessRead access_tag range) tr' cids')
- : False.
-Proof. do 15 auto_access_event_within_range. Qed.
-
-(*
-Definition freeze_like p : Prop :=
- reach Frozen p \/ p = ReservedConfl \/ p = ReservedConflMut.
-*)
-
-Lemma protected_nonchild_read_any_to_conflicted
- {tr affected_tag access_tag pre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Nonchild : ~ParentChildIn affected_tag access_tag tr)
- {cids cids' range tr' z zpre}
- (Protected : protector_is_active (iprot pre) cids)
- (Within : range'_contains range z)
- (IsPre : item_lazy_perm_at_loc pre z = zpre)
- (Step : bor_local_step tr cids (AccessBLEvt AccessRead access_tag range) tr' cids')
- : exists post zpost, (
- tree_item_determined affected_tag post tr'
- /\ iprot post = iprot pre
- /\ item_lazy_perm_at_loc post z = zpost
- /\ freeze_like (perm zpost)
- ).
-Proof. unfold freeze_like. do 15 auto_access_event_within_range. Qed.
-
-(* `migrate` facilitates moving hypotheses across borrow steps.
- Usage:
- migrate P.
- migrate P as Q.
- Moves common preserved hypotheses across borrow steps.
- E.g.: tree_contains is a property that is preserved by borrow steps:
- `forall tg, tree_contains tg ?tr -> bor_step ?tr _ _ ?tr' _ -> tree_contains tg ?tr'`.
- If you have a `H : tree_contains tg ?tr`, you can move it across the `bor_step`
- using `migrate H`.
-
- Handles hypotheses :
- - tree_contains
- - ParentChildIn
- - protector_is_for_call
- - tree_determined
-
- through steps:
- - bor_step
- - bor_seq
-*)
-Ltac migrate prop dest :=
- lazymatch type of prop with
- (* Migrate a tree_contains *)
- | tree_contains ?tg ?tr =>
- lazymatch goal with
- | Step: bor_local_step tr _ _ _ _ |- _ =>
- pose proof (bor_local_step_preserves_contains prop Step) as dest
- | Seq : bor_local_seq _ tr _ _ _ _ |- _ =>
- pose proof (bor_local_seq_last_contains prop (bor_local_seq_forget Seq)) as dest
- end
- (* Migrate a parent-child relation *)
- | context [ParentChildIn ?tg ?tg' ?tr] =>
- lazymatch goal with
- | Step : bor_local_step tr _ _ _ _,
- Ex : tree_contains tg tr,
- Ex' : tree_contains tg' tr
- |- _ =>
- pose proof prop as dest;
- rewrite (bor_local_step_eqv_rel Ex Ex' Step) in dest
- | Seq : bor_local_seq _ tr _ _ _ _,
- Ex : tree_contains tg tr,
- Ex' : tree_contains tg' tr
- |- _ =>
- pose proof prop as dest;
- rewrite (bor_local_seq_last_eqv_rel Ex Ex' (bor_local_seq_forget Seq)) in dest
- end
- (* Migrate info on a protector *)
- | context [protector_is_for_call _ ?old] =>
- lazymatch goal with
- | ACC: old = ?new |- _ =>
- pose proof prop as dest;
- rewrite ACC in dest
- | ACC: ?new = old |- _ =>
- pose proof prop as dest;
- rewrite <- ACC in prop
- end
- (* Migrate a tree_item_determined (lossy) *)
- | tree_item_determined ?tg _ ?tr =>
- lazymatch goal with
- | Seq : bor_local_seq _ tr _ _ _ _,
- Ex : tree_contains tg tr
- |- _ =>
- pose proof (bor_local_seq_last_determined Ex prop (bor_local_seq_forget Seq)) as dest
- end
- (* failed *)
- | ?other =>
- idtac prop " of type " other " cannot be migrated"
- end.
-
-Tactic Notation "migrate" constr(prop) "as" ident(dest) :=
- migrate prop dest.
-Tactic Notation "migrate" constr(prop) :=
- let tmp := fresh "tmp" in
- migrate prop as tmp;
- clear prop;
- rename tmp into prop.
-
-(* `forget` makes a name fresh again
- Usage:
- forget x.
-*)
-Ltac forget x :=
- repeat match goal with
- | H: context [x] |- _ => clear H
- end;
- clear x.
-
-(* `created_determined`, `created_protected`, and `created_nonparent` know the properties of items produced by `create_new_item`
- Usage:
- created tg determined as [tgExists tgUnique].
- created tg protected as tgProtected.
- created tg nonparent of tg' as Unrelated.
- If you have sufficient hypotheses, these will produce proofs for
- - tree_contains tg ?tr
- - tree_item_determined tg (create_new_item tg _) ?tr
- - protector_is_for_call (iprot (create_new_item tg _)) _
- - ~ParentChildIn tg tg' ?tr
- respectively.
-*)
-Ltac created_determined tg bindEx bindUnq :=
- match goal with
- | Rebor : bor_local_step ?tr _ (RetagBLEvt _ tg _ _ _) _ _ |- _ =>
- pose proof (bor_local_step_retag_produces_contains_determined Rebor) as [bindEx bindUnq]
- end.
-
-Tactic Notation "created" constr(tg) "determined" "as" "[" ident(ex) ident(uq) "]" :=
- created_determined tg ex uq.
-Tactic Notation "created" constr(tg) "determined" :=
- let ex := fresh "Exists" in
- let uq := fresh "Unique" in
- created_determined tg ex uq.
-
-Ltac created_protected tg dest :=
- let newp := fresh "newp" in
- lazymatch goal with
- | _ : context [create_new_item tg ?pk FnEntry ?cid]
- |- _ =>
- assert (protector_is_for_call cid (iprot (create_new_item tg pk FnEntry cid))) as dest by constructor
- end.
-
-Tactic Notation "created" constr(tg) "protected" "as" ident(prot) :=
- created_protected tg prot.
-Tactic Notation "created" constr(tg) "protected" :=
- let prot := fresh "Protected" in
- created_protected tg prot.
-
-Ltac created_nonparent tg other dest :=
- match goal with
- | Rebor : bor_local_step ?tr _ (RetagBLEvt _ tg _ _ _) _ _,
- Exother : tree_contains other ?tr
- |- _ =>
- pose proof (bor_local_step_retag_order_nonparent Exother Rebor) as dest
- end.
-
-Tactic Notation "created" constr(tg) "nonparent" "of" constr(other) "as" ident(dest) :=
- created_nonparent tg other dest.
-Tactic Notation "created" constr(tg) "nonparent" "of" constr(other) :=
- let unrel := fresh "Unrelated" in
- created_nonparent tg other unrel.
-
-(* Incomplete heuristics to derive `reach _ _` *)
-Ltac solve_reachability :=
- let p := fresh "perm" in
- multimatch goal with
- | |- reach _ _ => assumption
- | |- reach _ _ => eapply reach_reflexive; done
- | |- reach _ (perm (item_lazy_perm_at_loc (create_new_item _ _ _ _) _)) => eapply create_new_item_perm_prop
- (* transitivity hints *)
- | |- reach Frozen ?p => apply (reach_transitive Frozen Disabled p); [done|]
- end.
-
-(* `specialize` on steroids.
- `pose replace` is a generalization of `specialize`:
- `pose replace H with @ x` is mostly equivalent to `specialize H with x`.
-
- What it offers in addition is
- - specialization of Prop arguments
- - arbitrary order of arguments (if the one you need is not there, add it below as a Tactic Notation)
-
- `pose replace H with P Q @ R`
- will replace the hypothesis `H` with `(P Q H R)`
-*)
-Ltac squash new old := try clear old; rename new into old.
-Ltac xspecialize name term :=
- let tmp := fresh "tmp" in
- pose proof term as tmp;
- squash tmp name.
-Tactic Notation "pose" "replace" constr(target) "with" uconstr(a) uconstr(b) := xspecialize target (a b).
-Tactic Notation "pose" "replace" constr(target) "with" "@" uconstr(b) := xspecialize target (target b).
-Tactic Notation "pose" "replace" constr(target) "with" "@" uconstr(b) uconstr(c) := xspecialize target (target b c).
-Tactic Notation "pose" "replace" constr(target) "with" uconstr(a) uconstr(b) uconstr(c) uconstr(d) "@" := xspecialize target (a b c d target).
-Tactic Notation "pose" "replace" constr(target) "with" uconstr(a) uconstr(b) uconstr(c) "@" uconstr(d) := xspecialize target (a b c target d).
-Tactic Notation "pose" "replace" constr(target) "with" uconstr(a) uconstr(b) uconstr(c) uconstr(d) "@" uconstr(f) := xspecialize target (a b c d target f).
-Tactic Notation "pose" "replace" constr(target) "with" uconstr(a) uconstr(b) uconstr(c) uconstr(d) uconstr(e) "@" uconstr(g) := xspecialize target (a b c d e target g).
-
-Lemma fwrite_cwrite_disjoint
- {tg tg' range1 range2 tgp tr0 tr0' tr1 tr1' tr2 tr2' cid cids0 cids0' cids1 cids1' cids2 cids2' pk rk}
- (Ex : tree_contains tg tr0)
- (ResReach : reach (Reserved TyFrz ResActivable) (pointer_kind_to_perm pk))
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid rk) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Write1 : bor_local_step tr1 cids1 (AccessBLEvt AccessWrite tg range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr1' cids1' l tr2 cids2)
- (Write2 : bor_local_step tr2 cids2 (AccessBLEvt AccessWrite tg' range2) tr2' cids2')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-Proof.
- intros [z [RContains1 RContains2]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- assert (reach (Reserved TyFrz ResActivable) (perm (item_lazy_perm_at_loc (create_new_item tg' pk rk cid) z))) as ResReach1 by solve_reachability.
- migrate Unrelated.
- pose replace ResReach1 with bor_local_seq_last_backward_reach Ex' Unq' @ Seq01.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- pose replace ResReach1 with @ post Unq'.
- migrate Ex'.
- forget tr0'.
-
- (* write step 1 *)
- rename post into pre.
- destruct (nonchild_write_reserved_to_disabled Ex' Unq' Unrelated RContains1 eq_refl ltac:(solve_reachability) Write1)
- as [post [zpost [Unq'Post [PermPost [DisPost ProtPost]]]]].
- migrate Ex'.
- forget tr1.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- pose replace DisPost with bor_local_seq_last_backward_reach Ex' Unq' @ Seq12.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- pose replace DisPost with @ post Unq'.
- migrate Ex'.
-
- (* write step 2 *)
- destruct (child_write_frozen_to_ub Ex' Unq' ltac:(left; done) RContains2 eq_refl ltac:(repeat solve_reachability) Write2).
-Qed.
-
-Lemma fwrite_cread_disjoint
- {tg tg' pk rk range1 range2 tgp tr0 tr0' tr1 tr1' tr2 tr2' cid cids0 cids0' cids1 cids1' cids2 cids2'}
- (Ex : tree_contains tg tr0)
- (ResReach : reach (Reserved TyFrz ResActivable) (pointer_kind_to_perm pk))
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid rk) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Write1 : bor_local_step tr1 cids1 (AccessBLEvt AccessWrite tg range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr1' cids1' l tr2 cids2)
- (Read2 : bor_local_step tr2 cids2 (AccessBLEvt AccessRead tg' range2) tr2' cids2')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-Proof.
- move=> [z [RContains1 RContains2]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- assert (reach (Reserved TyFrz ResActivable) (perm (item_lazy_perm_at_loc (create_new_item tg' pk rk cid) z))) as ResReach1 by solve_reachability.
- migrate Unrelated.
- pose replace ResReach1 with bor_local_seq_last_backward_reach Ex' Unq' @ Seq01.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- pose replace ResReach1 with @ post Unq'.
- migrate Ex'.
- forget tr0'.
-
- (* write step 1 *)
- rename post into pre.
- destruct (nonchild_write_reserved_to_disabled
- Ex' Unq'
- Unrelated
- RContains1 eq_refl
- ltac:(solve_reachability)
- Write1
- ) as [post [zpost [Unq'Post [PermPost [DisPost ProtPost]]]]].
- migrate Ex'.
- forget tr1.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- pose replace DisPost with bor_local_seq_last_backward_reach Ex' Unq' @ Seq12.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- pose replace DisPost with @ post Unq'.
- migrate Ex'.
-
- (* read step 2 *)
- destruct (child_read_disabled_to_ub
- Ex' Unq'
- ltac:(left; reflexivity)
- RContains2 eq_refl
- ltac:(solve_reachability)
- Read2).
-Qed.
-
-Lemma protected_fwrite_cwrite_disjoint
- {tg tg' pk range1 range2 tgp tr0 tr0' tr1 tr1' tr2 tr2' cid cids0 cids0' cids1 cids1' cids2 cids2'}
- (Ex : tree_contains tg tr0)
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid FnEntry) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Call : call_is_active cid cids1)
- (Write1 : bor_local_step tr1 cids1 (AccessBLEvt AccessWrite tg range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr1' cids1' l tr2 cids2)
- (Write2 : bor_local_step tr2 cids2 (AccessBLEvt AccessWrite tg' range2) tr2' cids2')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-Proof.
- intros [z [RContains1 RContains2]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- migrate Unrelated.
- migrate Unq'; destruct Unq' as [post [Unq' Prot']].
- migrate Ex'.
- forget tr0'.
-
- (* write step 1 *)
- rename post into pre.
- assert (protector_is_active (iprot pre) cids1) as Protected by (eexists; split; [|eassumption]; rewrite -Prot'; constructor).
- destruct (nonchild_write_any_protected_to_disabled Ex' Unq' Unrelated Protected RContains1 eq_refl Write1)
- as [post [zpost [Unq'Post [PermPost [DisPost ProtPost]]]]].
- migrate Ex'.
- forget tr1.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- pose replace DisPost with bor_local_seq_last_backward_reach Ex' Unq' @ Seq12.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- pose replace DisPost with @ post Unq'.
- migrate Ex'.
-
- (* write step 2 *)
- destruct (child_write_frozen_to_ub Ex' Unq' ltac:(left; done) RContains2 eq_refl ltac:(repeat solve_reachability) Write2).
-Qed.
-
-Lemma protected_fwrite_cread_disjoint
- {tg tg' pk range1 range2 tgp tr0 tr0' tr1 tr1' tr2 tr2' cid cids0 cids0' cids1 cids1' cids2 cids2'}
- (Ex : tree_contains tg tr0)
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid FnEntry) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Call : call_is_active cid cids1)
- (Write1 : bor_local_step tr1 cids1 (AccessBLEvt AccessWrite tg range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr1' cids1' l tr2 cids2)
- (Read2 : bor_local_step tr2 cids2 (AccessBLEvt AccessRead tg' range2) tr2' cids2')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-Proof.
- move=> [z [RContains1 RContains2]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- migrate Unrelated.
- migrate Unq'; destruct Unq' as [post [Unq' Prot']].
- migrate Ex'.
- forget tr0'.
-
- (* write step 1 *)
- rename post into pre.
- assert (protector_is_active (iprot pre) cids1) as Protected by (eexists; split; [|eassumption]; rewrite -Prot'; constructor).
- destruct (nonchild_write_any_protected_to_disabled
- Ex' Unq'
- Unrelated
- Protected RContains1
- eq_refl
- Write1
- ) as [post [zpost [Unq'Post [PermPost [DisPost ProtPost]]]]].
- migrate Ex'.
- forget tr1.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- pose replace DisPost with bor_local_seq_last_backward_reach Ex' Unq' @ Seq12.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- pose replace DisPost with @ post Unq'.
- migrate Ex'.
-
- (* read step 2 *)
- destruct (child_read_disabled_to_ub
- Ex' Unq'
- ltac:(left; reflexivity)
- RContains2 eq_refl
- ltac:(solve_reachability)
- Read2).
-Qed.
-
-
-Lemma activated_fread_cwrite_disjoint
- {tg tg' pk rk range1 range2 range3 tgp tr0 tr0' tr1 tr1' tr2 tr2' tr3 tr3' cid cids0 cids0' cids1 cids1' cids2 cids2' cids3 cids3'}
- (Ex : tree_contains tg tr0)
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid rk) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Write1 : bor_local_step tr1 cids1 (AccessBLEvt AccessWrite tg' range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr1' cids1' l tr2 cids2)
- (Read2 : bor_local_step tr2 cids2 (AccessBLEvt AccessRead tg range2) tr2' cids2')
- (Seq23 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr2' cids2' l tr3 cids3)
- (Write3 : bor_local_step tr3 cids3 (AccessBLEvt AccessWrite tg' range3) tr3' cids3')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z /\ range'_contains range3 z.
-Proof.
- move=> [z [RContains1 [RContains2 RContains3]]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- migrate Unrelated.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- migrate Ex'.
- migrate Ex.
- forget tr0'.
-
- (* write step 1 *)
- rename post into pre.
- destruct (child_write_any_to_init_active
- Ex' Unq'
- ltac:(left; reflexivity)
- RContains1 eq_refl
- Write1
- ) as [post [zpost [Unq'Post [PermPost [ActPost _]]]]].
- migrate Unrelated.
- migrate Ex'.
- migrate Ex.
- forget tr1.
- forget pre.
- assert (reach Active (perm zpost)) as ActReachPost by solve_reachability.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- migrate Unrelated.
- pose replace ActReachPost with bor_local_seq_last_backward_reach Ex' Unq' @ Seq12.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- pose replace ActReachPost with @ post Unq'.
- migrate Ex'.
- forget pre.
-
- (* read step 2 *)
- rename post into pre.
- rename ActReachPost into ActReachPre.
- destruct (nonchild_read_active_to_frozen
- Ex' Unq'
- Unrelated
- RContains2 eq_refl
- ltac:(solve_reachability)
- Read2) as [post [zpost [Unq'Post [PermPost [FrzReachPost PreReachPost]]]]].
- migrate Ex'.
- forget tr2.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq23 as [evts23 Seq23].
- pose replace FrzReachPost with bor_local_seq_last_backward_reach Ex' Unq' @ Seq23.
- migrate Unq'; destruct Unq' as [post [Unq' _]].
- pose replace FrzReachPost with @ post Unq'.
- migrate Ex'.
-
- (* write step 3 *)
- destruct (child_write_frozen_to_ub
- Ex' Unq'
- ltac:(left; reflexivity)
- RContains3 eq_refl
- ltac:(solve_reachability)
- Write3).
-Qed.
-
-Lemma protected_cwrite_fwrite_disjoint
- {tg tg' cid pk range1 range2 tgp tr0 tr0' tr1 tr1' tr2 tr2' cids0 cids0' cids1 cids1' cids2 cids2'}
- (Ex : tree_contains tg tr0)
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid FnEntry) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Write1 : bor_local_step tr1 cids1 (AccessBLEvt AccessWrite tg' range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ cids => call_is_active cid cids|} tr1' cids1' l tr2 cids2)
- (Write2 : bor_local_step tr2 cids2 (AccessBLEvt AccessWrite tg range2) tr2' cids2')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-Proof.
- move=> [z [RContains1 RContains2]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' protected as Protected.
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- migrate Unrelated.
- migrate Unq'; destruct Unq' as [post [Unq' Prot']].
- migrate Ex'.
- migrate Ex.
- forget tr0'.
-
- (* write step 1 *)
- subst.
- rename post into pre.
- destruct (child_write_any_to_init_active
- Ex' Unq' ltac:(left; reflexivity)
- RContains1 eq_refl
- Write1
- ) as [post [zpost [Unq'Post [PermPost [ActPost [ProtPost InitPost]]]]]].
- migrate Unrelated.
- migrate Ex.
- migrate Ex'.
- migrate Protected.
- rewrite <- ProtPost in Protected.
- forget tr1.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- migrate Unrelated.
- assert (bor_local_seq
- {|seq_inv:=fun tr cids =>
- (forall it,
- tree_item_determined tg' it tr ->
- initialized (item_lazy_perm_at_loc it z) = PermInit)
- /\ call_is_active cid cids|}
- tr1' cids1' evts12 tr2 cids2) as GenActPost. {
- pose proof (bor_local_seq_always_perminit Ex' Unq' InitPost (bor_local_seq_forget Seq12)) as Seq12Init.
- eapply seq_always_build_weaken; [|exact (seq_always_merge Seq12Init Seq12)].
- simpl. move=> ?? H; split; edestruct H; eauto.
- }
- pose replace ActPost with protected_during_seq_last_stays_active Ex' Unq' eq_refl Protected @ GenActPost.
- migrate Unq'; destruct Unq' as [post [Unq' ProtPost]].
- pose replace ActPost with @ post Unq'.
- migrate Ex'.
- migrate Protected.
- forget pre.
-
- (* write step 2 *)
- subst.
- pose proof (seq_always_destruct_last GenActPost) as [Init Call].
- destruct (protected_nonchild_write_initialized_to_ub
- Ex' Unq' Unrelated
- ltac:(eexists; split; [exact Protected|exact Call])
- (Init _ Unq')
- RContains2 eq_refl
- ltac:(rewrite ActPost; eauto)
- Write2).
-Qed.
-
-Lemma protected_cread_fwrite_disjoint
- {tg tg' cid pk range1 range2 tgp tr0 tr0' tr1 tr1' tr2 tr2' cids0 cids0' cids1 cids1' cids2 cids2'}
- (Ex : tree_contains tg tr0)
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid FnEntry) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Read1 : bor_local_step tr1 cids1 (AccessBLEvt AccessRead tg' range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ cids => call_is_active cid cids|} tr1' cids1' l tr2 cids2)
- (Write2 : bor_local_step tr2 cids2 (AccessBLEvt AccessWrite tg range2) tr2' cids2')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-Proof.
- move=> [z [RContains1 RContains2]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' protected as Protected.
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- migrate Unrelated.
- migrate Unq'; destruct Unq' as [post [Unq' Prot']].
- migrate Ex'.
- migrate Ex.
- forget tr0'.
-
- (* write step 1 *)
- subst.
- rename post into pre.
- destruct (child_read_any_to_init_nondis
- Ex' Unq' ltac:(left; reflexivity)
- RContains1 eq_refl Read1
- ) as [post [zpost [Unq'Post [PermPost [DisUnreachPost [ProtPost InitPost]]]]]].
- migrate Unrelated.
- migrate Ex.
- migrate Ex'.
- migrate Protected.
- rewrite <- ProtPost in Protected.
- forget tr1.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- migrate Unrelated.
- assert (bor_local_seq
- {|seq_inv:=fun tr cids =>
- (forall it,
- tree_item_determined tg' it tr ->
- initialized (item_lazy_perm_at_loc it z) = PermInit)
- /\ call_is_active cid cids|}
- tr1' cids1' evts12 tr2 cids2) as GenNonDisPost. {
- pose proof (bor_local_seq_always_perminit Ex' Unq' InitPost (bor_local_seq_forget Seq12)) as Seq12Init.
- eapply seq_always_build_weaken; [|exact (seq_always_merge Seq12Init Seq12)].
- simpl. move=> ?? [??]; auto.
- }
- pose replace DisUnreachPost with protected_during_seq_last_stays_nondis Ex' Unq' eq_refl Protected @ GenNonDisPost.
- migrate Unq'; destruct Unq' as [post [Unq' ProtPost]].
- pose replace DisUnreachPost with @ post Unq'.
- migrate Ex'.
- migrate Protected.
- forget pre.
-
- subst.
- pose proof (seq_always_destruct_last GenNonDisPost) as [Init Call].
- destruct (protected_nonchild_write_initialized_to_ub
- Ex' Unq' Unrelated
- ltac:(eexists; split; [exact Protected|exact Call])
- (Init _ Unq') RContains2 eq_refl DisUnreachPost Write2).
-Qed.
-
-Lemma protected_cwrite_fread_disjoint
- {tg tg' cid pk range1 range2 tgp tr0 tr0' tr1 tr1' tr2 tr2' cids0 cids0' cids1 cids1' cids2 cids2'}
- (Ex : tree_contains tg tr0)
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid FnEntry) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Write1 : bor_local_step tr1 cids1 (AccessBLEvt AccessWrite tg' range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ cids => call_is_active cid cids|} tr1' cids1' l tr2 cids2)
- (Read2 : bor_local_step tr2 cids2 (AccessBLEvt AccessRead tg range2) tr2' cids2')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-Proof.
- move=> [z [RContains1 RContains2]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' protected as Protected.
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- migrate Unrelated.
- migrate Unq'; destruct Unq' as [post [Unq' Prot']].
- migrate Ex'.
- migrate Ex.
- forget tr0'.
-
- (* write step 1 *)
- subst.
- rename post into pre.
- destruct (child_write_any_to_init_active
- Ex' Unq' ltac:(left; reflexivity)
- RContains1 eq_refl Write1) as [post [zpost [Unq'Post [PermPost [ActPost [ProtPost InitPost]]]]]].
- migrate Unrelated.
- migrate Ex.
- migrate Ex'.
- migrate Protected.
- rewrite <- ProtPost in Protected.
- forget tr1.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- migrate Unrelated.
- assert (bor_local_seq
- {|seq_inv:=fun tr cids =>
- (forall it,
- tree_item_determined tg' it tr ->
- initialized (item_lazy_perm_at_loc it z) = PermInit)
- /\ call_is_active cid cids|}
- tr1' cids1' evts12 tr2 cids2) as GenActPost. {
- pose proof (bor_local_seq_always_perminit Ex' Unq' InitPost (bor_local_seq_forget Seq12)) as Seq12Init.
- eapply seq_always_build_weaken; [|exact (seq_always_merge Seq12Init Seq12)].
- simpl. move=> ?? [??]; auto.
- }
- pose replace ActPost with protected_during_seq_last_stays_active Ex' Unq' eq_refl Protected @ GenActPost.
- migrate Unq'; destruct Unq' as [post [Unq' ProtPost]].
- pose replace ActPost with @ post Unq'.
- migrate Ex'.
- migrate Protected.
- forget pre.
-
- (* read step 2 *)
- subst.
- pose proof (seq_always_destruct_last GenActPost) as [Init Call].
- destruct (protected_nonchild_read_initialized_active_to_ub
- Ex' Unq' Unrelated
- ltac:(eexists; split; [exact Protected|exact Call])
- (Init _ Unq') RContains2 eq_refl ActPost Read2).
-Qed.
-
-Lemma protected_fread_cwrite_disjoint
- {tg tg' cid pk range1 range2 tgp tr0 tr0' tr1 tr1' tr2 tr2' cids0 cids0' cids1 cids1' cids2 cids2'}
- (Ex : tree_contains tg tr0)
- (Retag0 : bor_local_step tr0 cids0 (RetagBLEvt tgp tg' pk cid FnEntry) tr0' cids0')
- (Seq01 : exists l, bor_local_seq {|seq_inv:=fun _ _ => True|} tr0' cids0' l tr1 cids1)
- (Call1 : call_is_active cid cids1)
- (Read1 : bor_local_step tr1 cids1 (AccessBLEvt AccessRead tg range1) tr1' cids1')
- (Seq12 : exists l, bor_local_seq {|seq_inv:=fun _ cids => call_is_active cid cids|} tr1' cids1' l tr2 cids2)
- (Write2 : bor_local_step tr2 cids2 (AccessBLEvt AccessWrite tg' range2) tr2' cids2')
- : ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-Proof.
- move=> [z [RContains1 RContains2]].
- (* reborrow step *)
- created tg' determined as [Ex' Unq'].
- created tg' protected as Protected.
- created tg' nonparent of tg as Unrelated.
- migrate Ex.
- forget tr0.
-
- (* opaque seq *)
- destruct Seq01 as [evts01 Seq01].
- migrate Unrelated.
- migrate Unq'; destruct Unq' as [post [Unq' Prot']].
- migrate Protected.
- migrate Ex'.
- migrate Ex.
- forget tr0'.
-
- (* write step 1 *)
- subst.
- rename post into pre.
- destruct (protected_nonchild_read_any_to_conflicted
- Ex' Unq'
- Unrelated
- ltac:(eexists; split; [exact Protected|exact Call1])
- RContains1 eq_refl Read1
- ) as [post [zpost [Unq'Post [ProtPost [PermPost FrzLikePost]]]]].
- migrate Ex'.
- rewrite <- ProtPost in Protected.
- forget tr1.
- forget pre.
-
- (* opaque seq *)
- subst.
- rename Unq'Post into Unq'.
- rename post into pre.
- destruct Seq12 as [evts12 Seq12].
- pose replace FrzLikePost with bor_local_seq_last_protected_freeze_like Ex' Unq' Protected @ Seq12.
- migrate Unq'; destruct Unq' as [post [Unq' Unq'Prot]].
- pose replace FrzLikePost with @ post Unq'.
- pose proof (seq_always_destruct_last Seq12) as Prot2; simpl in Prot2.
- destruct FrzLikePost as [ProtPost FrzLike].
- migrate Ex'.
-
- (* read step 2 *)
- destruct (child_write_protected_freeze_like_to_ub
- Ex' Unq'
- ltac:(left; reflexivity)
- RContains2 ltac:(exists cid; split; [exact ProtPost|exact Prot2]) eq_refl
- FrzLike
- Write2).
-Qed.
-
-(* rename bor_local_seq: bor_local_steps *)
-(* ghost state, ressource algebras, invariants *)
-
-Definition disjoint' range1 range2 := ~exists z, range'_contains range1 z /\ range'_contains range2 z.
-
-Lemma llvm_retagx_opaque_writey_writex_disjoint
- {tg_x tg_y tg_xparent tr_initial tr_final cids_initial cids_final cid pk opaque range_x range_y}
- (AlreadyExists_y : tree_contains tg_y tr_initial)
- (Seq : bor_local_seq
- {|seq_inv:=fun _ cids => call_is_active cid cids|}
- tr_initial cids_initial
- (
- [RetagBLEvt tg_xparent tg_x pk cid FnEntry]
- ++ opaque
- ++ [AccessBLEvt AccessWrite tg_y range_y]
- ++ [AccessBLEvt AccessWrite tg_x range_x]
- )
- tr_final cids_final)
- : disjoint' range_y range_x.
-Proof.
- destruct (proj1 bor_local_seq_split Seq) as [?[?[SeqRetag Seq']]]; clear Seq.
- destruct (proj1 bor_local_seq_split Seq') as [?[?[SeqOpaque Seq'']]]; clear Seq'.
- destruct (proj1 bor_local_seq_split Seq'') as [?[?[SeqWritey SeqWritex]]]; clear Seq''.
- inversion SeqRetag as [|?????? INV1 HEAD1 REST1]. subst.
- inversion SeqWritey as [|?????? INV2 HEAD2 REST2]; subst.
- inversion SeqWritex as [|?????? INV3 HEAD3 REST3]; subst.
- inversion REST1; subst.
- inversion HEAD1 as [| | |???????? COMPAT_CID1].
- eapply protected_fwrite_cwrite_disjoint.
- - exact AlreadyExists_y.
- - exact HEAD1.
- - exists opaque. exact (bor_local_seq_forget SeqOpaque).
- - exact INV2.
- - exact HEAD2.
- - exists []. exact (bor_local_seq_forget REST2).
- - exact HEAD3.
-Qed.
-
-Lemma llvm_retagx_opaque_writey_readx_disjoint
- {tg_x tg_y tg_xparent tr_initial tr_final cids_initial cids_final cid pk opaque range_x range_y}
- (AlreadyExists_y : tree_contains tg_y tr_initial)
- (Seq : bor_local_seq
- {|seq_inv:=fun _ cids => call_is_active cid cids|}
- tr_initial cids_initial
- (
- [RetagBLEvt tg_xparent tg_x pk cid FnEntry]
- ++ opaque
- ++ [AccessBLEvt AccessWrite tg_y range_y]
- ++ [AccessBLEvt AccessRead tg_x range_x]
- )
- tr_final cids_final)
- : disjoint' range_y range_x.
-Proof.
- destruct (proj1 bor_local_seq_split Seq) as [?[?[SeqRetag Seq']]]; clear Seq.
- destruct (proj1 bor_local_seq_split Seq') as [?[?[SeqOpaque Seq'']]]; clear Seq'.
- destruct (proj1 bor_local_seq_split Seq'') as [?[?[SeqWritey SeqReadx]]]; clear Seq''.
- inversion SeqRetag as [|?????? INV1 HEAD1 REST1]. subst.
- inversion SeqWritey as [|?????? INV2 HEAD2 REST2]; subst.
- inversion SeqReadx as [|?????? INV3 HEAD3 REST3]; subst.
- inversion REST1; subst.
- inversion HEAD1 as [| | |???????? COMPAT_CID1].
- eapply protected_fwrite_cread_disjoint.
- - exact AlreadyExists_y.
- - exact HEAD1.
- - exists opaque. exact (bor_local_seq_forget SeqOpaque).
- - exact INV2.
- - exact HEAD2.
- - exists []. exact (bor_local_seq_forget REST2).
- - exact HEAD3.
-Qed.
-
-Lemma llvm_retagx_opaque_readx_writey_disjoint
- {tg_x tg_y tg_xparent tr_initial tr_final cids_initial cids_final cid pk opaque range_x range_y}
- (AlreadyExists_y : tree_contains tg_y tr_initial)
- (Seq : bor_local_seq
- {|seq_inv:=fun _ cids => call_is_active cid cids|}
- tr_initial cids_initial
- (
- [RetagBLEvt tg_xparent tg_x pk cid FnEntry]
- ++ opaque
- ++ [AccessBLEvt AccessRead tg_x range_x]
- ++ [AccessBLEvt AccessWrite tg_y range_y]
- )
- tr_final cids_final)
- : disjoint' range_x range_y.
-Proof.
- destruct (proj1 bor_local_seq_split Seq) as [?[?[SeqRetag Seq']]]; clear Seq.
- destruct (proj1 bor_local_seq_split Seq') as [?[?[SeqOpaque Seq'']]]; clear Seq'.
- destruct (proj1 bor_local_seq_split Seq'') as [?[?[SeqWritey SeqReadx]]]; clear Seq''.
- inversion SeqRetag as [|?????? INV1 HEAD1 REST1]. subst.
- inversion SeqReadx as [|?????? INV2 HEAD2 REST2]; subst.
- inversion SeqWritey as [|?????? INV3 HEAD3 REST3]; subst.
- inversion REST1; subst.
- inversion HEAD1 as [| | |???????? COMPAT_CID1].
- eapply protected_cread_fwrite_disjoint.
- - exact AlreadyExists_y.
- - exact HEAD1.
- - exists opaque. exact (bor_local_seq_forget SeqOpaque).
- - exact HEAD3.
- - exists []. exact REST3.
- - exact HEAD2.
-Qed.
-
-Check neven_see_also_the_todo_for_the_local_step_semantics_which_is_missing_a_case.
-
-Lemma llvm_retagx_opaque_writex_writey_disjoint
- {tg_x tg_y tg_xparent tr_initial tr_final cids_initial cids_final cid pk opaque range_x range_y}
- (AlreadyExists_y : tree_contains tg_y tr_initial)
- (Seq : bor_local_seq
- {|seq_inv:=fun _ cids => call_is_active cid cids|}
- tr_initial cids_initial
- (
- [RetagBLEvt tg_xparent tg_x pk cid FnEntry]
- ++ opaque
- ++ [AccessBLEvt AccessWrite tg_x range_x]
- ++ [AccessBLEvt AccessWrite tg_y range_y]
- )
- tr_final cids_final)
- : disjoint' range_x range_y.
-Proof.
- destruct (proj1 bor_local_seq_split Seq) as [?[?[SeqRetag Seq']]]; clear Seq.
- destruct (proj1 bor_local_seq_split Seq') as [?[?[SeqOpaque Seq'']]]; clear Seq'.
- destruct (proj1 bor_local_seq_split Seq'') as [?[?[SeqWritex SeqWritey]]]; clear Seq''.
- inversion SeqRetag as [|?????? INV1 HEAD1 REST1]. subst.
- inversion SeqWritey as [|?????? INV3 HEAD2 REST2]; subst.
- inversion SeqWritex as [|?????? INV2 HEAD3 REST3]; subst.
- inversion REST1; subst.
- inversion HEAD1 as [| | |???????? COMPAT_CID1].
- eapply protected_cwrite_fwrite_disjoint.
- - exact AlreadyExists_y.
- - exact HEAD1.
- - exists opaque. exact (bor_local_seq_forget SeqOpaque).
- - exact HEAD3.
- - exists []. exact REST3.
- - exact HEAD2.
-Qed.
-
-Lemma llvm_retagx_opaque_writex_ready_disjoint
- {tg_x tg_y tg_xparent tr_initial tr_final cids_initial cids_final cid pk opaque range_x range_y}
- (AlreadyExists_y : tree_contains tg_y tr_initial)
- (Seq : bor_local_seq
- {|seq_inv:=fun _ cids => call_is_active cid cids|}
- tr_initial cids_initial
- (
- [RetagBLEvt tg_xparent tg_x pk cid FnEntry]
- ++ opaque
- ++ [AccessBLEvt AccessWrite tg_x range_x]
- ++ [AccessBLEvt AccessRead tg_y range_y]
- )
- tr_final cids_final)
- : disjoint' range_x range_y.
-Proof.
- destruct (proj1 bor_local_seq_split Seq) as [?[?[SeqRetag Seq']]]; clear Seq.
- destruct (proj1 bor_local_seq_split Seq') as [?[?[SeqOpaque Seq'']]]; clear Seq'.
- destruct (proj1 bor_local_seq_split Seq'') as [?[?[SeqWritex SeqReady]]]; clear Seq''.
- inversion SeqRetag as [|?????? INV1 HEAD1 REST1]. subst.
- inversion SeqWritex as [|?????? INV3 HEAD2 REST2]; subst.
- inversion SeqReady as [|?????? INV2 HEAD3 REST3]; subst.
- inversion REST1; subst.
- inversion HEAD1 as [| | |???????? COMPAT_CID1].
- eapply protected_cwrite_fread_disjoint.
- - exact AlreadyExists_y.
- - exact HEAD1.
- - exists opaque. exact (bor_local_seq_forget SeqOpaque).
- - exact HEAD2.
- - exists []. exact REST2.
- - exact HEAD3.
-Qed.
-
-Lemma llvm_retagx_opaque_ready_writex_disjoint
- {tg_x tg_y tg_xparent tr_initial tr_final cids_initial cids_final cid pk opaque range_x range_y}
- (AlreadyExists_y : tree_contains tg_y tr_initial)
- (Seq : bor_local_seq
- {|seq_inv:=fun _ cids => call_is_active cid cids|}
- tr_initial cids_initial
- (
- [RetagBLEvt tg_xparent tg_x pk cid FnEntry]
- ++ opaque
- ++ [AccessBLEvt AccessRead tg_y range_y]
- ++ [AccessBLEvt AccessWrite tg_x range_x]
- )
- tr_final cids_final)
- : disjoint' range_y range_x.
-Proof.
- destruct (proj1 bor_local_seq_split Seq) as [?[?[SeqRetag Seq']]]; clear Seq.
- destruct (proj1 bor_local_seq_split Seq') as [?[?[SeqOpaque Seq'']]]; clear Seq'.
- destruct (proj1 bor_local_seq_split Seq'') as [?[?[SeqReady SeqWritex]]]; clear Seq''.
- inversion SeqRetag as [|?????? INV1 HEAD1 REST1]. subst.
- inversion SeqReady as [|?????? INV3 HEAD2 REST2]; subst.
- inversion SeqWritex as [|?????? INV2 HEAD3 REST3]; subst.
- inversion REST1; subst.
- inversion HEAD1 as [| | |???????? COMPAT_CID1].
- eapply protected_fread_cwrite_disjoint.
- - exact AlreadyExists_y.
- - exact HEAD1.
- - exists opaque. exact (bor_local_seq_forget SeqOpaque).
- - exact INV3.
- - exact HEAD2.
- - exists []. exact REST2.
- - exact HEAD3.
-Qed.
-
-
-
-(* --- Reordering read-read --- *)
-
-Definition commutes {X}
- (fn1 fn2 : X -> option X)
- := forall x0 x1 x2,
- fn1 x0 = Some x1 ->
- fn2 x1 = Some x2 ->
- exists x1', (
- fn2 x0 = Some x1'
- /\ fn1 x1' = Some x2
- ).
-
-Definition commutes_option {X}
- (fn1 fn2 : option X -> option X)
- := forall x0 x1 x2,
- fn1 x0 = Some x1 ->
- fn2 (Some x1) = Some x2 ->
- exists x1', (
- fn2 x0 = Some x1'
- /\ fn1 (Some x1') = Some x2
- ).
-
-Lemma apply_access_perm_read_commutes
- {rel1 rel2 prot}
- : commutes
- (apply_access_perm AccessRead rel1 prot)
- (apply_access_perm AccessRead rel2 prot).
-Proof.
- move=> p0 p1 p2 Step01 Step12.
- unfold apply_access_perm in *.
- all: destruct p0 as [[][[][]| | |]].
- all: destruct prot; simpl in *.
- all: destruct rel1; simpl in *.
- all: try (inversion Step01; done).
- all: injection Step01; intros; subst.
- all: simpl.
- all: destruct rel2; simpl in *.
- all: try (inversion Step12; done).
- all: injection Step12; intros; subst; simpl.
- all: try (eexists; split; [reflexivity|]); simpl.
- all: reflexivity.
-Qed.
-
-Lemma mem_apply_loc_insert_ne
- {X} {fn : option X -> option X} {z mem mem' z0}
- (NE : ~z = z0)
- (Success : mem_apply_loc fn z mem = Some mem')
- v0
- : mem_apply_loc fn z (<[z0:=v0]>mem) = Some (<[z0:=v0]>mem').
-Proof.
- unfold mem_apply_loc in Success |- *; simpl in *.
- rewrite lookup_insert_ne; [|auto].
- destruct (option_bind_success_step _ _ _ Success) as [v [fnv mem'_spec]].
- injection mem'_spec; intros; subst.
- rewrite fnv; simpl.
- f_equal.
- rewrite insert_commute; auto.
-Qed.
-
-Lemma mem_apply_range'_insert_outside
- {X} {fn : option X -> option X} {z sz mem mem' z0}
- (OUT : ~range'_contains (z, sz) z0)
- (Success : mem_apply_locs fn z sz mem = Some mem')
- v0
- : mem_apply_locs fn z sz (<[z0:=v0]>mem) = Some (<[z0:=v0]>mem').
-Proof.
- unfold mem_apply_range' in *; simpl in *.
- generalize dependent z.
- generalize dependent mem.
- generalize dependent mem'.
- induction sz as [|sz IHsz]; move=> mem' mem z OUT Success.
- - injection Success; intros; subst.
- reflexivity.
- - destruct (proj1 (bind_Some _ _ _) Success) as [mem'' [SuccessStep SuccessRest]].
- simpl.
- erewrite mem_apply_loc_insert_ne; [| |eassumption].
- 2: { unfold range'_contains in OUT |- *; simpl in *; lia. }
- simpl.
- apply IHsz.
- + unfold range'_contains in OUT |- *; simpl in *; lia.
- + exact SuccessRest.
-Qed.
-
-Lemma mem_apply_range'_success_condition
- {X} {fn : option X -> option X} {range mem}
- (ALL_SOME : forall z, range'_contains range z -> is_Some (fn (mem !! z)))
- : exists mem', mem_apply_range' fn range mem = Some mem'.
-Proof.
- unfold mem_apply_range'.
- destruct range as [z sz]; simpl.
- generalize dependent z.
- induction sz as [|sz IHsz]; move=> z ALL_SOME.
- - eexists. simpl. reflexivity.
- - destruct (IHsz (z + 1)%Z
- ltac:(intros mem' H; apply ALL_SOME; unfold range'_contains; unfold range'_contains in H; simpl; simpl in H; lia))
- as [sub' Specsub'].
- destruct (ALL_SOME z ltac:(unfold range'_contains; simpl; lia)) as [fnz Specfnz].
- eexists (<[z:=fnz]>sub'); simpl.
- unfold mem_apply_loc.
- rewrite Specfnz; simpl.
- erewrite mem_apply_range'_insert_outside; [reflexivity| |assumption].
- unfold range'_contains; simpl; lia.
-Qed.
-
-Lemma mem_apply_range'_success_specification
- {X} {fn : option X -> option X} {range mem mem'}
- (ALL_SOME : forall z, range'_contains range z -> exists x', fn (mem !! z) = Some x' /\ mem' !! z = Some x')
- (REST_SAME : forall z, ~range'_contains range z -> mem !! z = mem' !! z)
- : mem_apply_range' fn range mem = Some mem'.
-Proof.
- assert (forall z, range'_contains range z -> is_Some (fn (mem !! z))) as ALL_SOME_weaker. {
- intros z R; destruct (ALL_SOME z R) as [?[??]]; auto.
- }
- destruct (mem_apply_range'_success_condition ALL_SOME_weaker) as [mem'' Spec''].
- rewrite Spec''; f_equal; apply map_eq.
- intro z.
- pose proof (mem_apply_range'_spec _ _ z _ _ Spec'') as Spec.
- destruct (decide (range'_contains range z)) as [R|nR].
- - destruct Spec as [v[vSpec fnvSpec]].
- destruct (ALL_SOME z R) as [v' [fnv'Spec v'Spec]].
- rewrite v'Spec.
- rewrite vSpec.
- rewrite <- fnv'Spec.
- rewrite <- fnvSpec.
- reflexivity.
- - rewrite <- (REST_SAME z nR).
- assumption.
-Qed.
-
-Lemma range_foreach_commutes
- {X}
- range1 range2
- (fn1 fn2 : option X -> option X)
- (FnCommutes : commutes_option fn1 fn2)
- : commutes
- (mem_apply_range' fn1 range1)
- (mem_apply_range' fn2 range2).
-Proof.
- intros mem0 mem1 mem2 Success01 Success12.
- assert (forall z, range'_contains range2 z -> exists x1', fn2 (mem0 !! z) = Some x1') as fn2mem0. {
- intros z R2.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
- destruct (decide (range'_contains range1 z)).
- - destruct Spec01 as [fn1z0 [z1Spec fn1z0Spec]].
- rewrite decide_True in Spec12; [|assumption].
- destruct Spec12 as [fn2z1 [z2Spec fn2z1Spec]].
- rewrite z1Spec in fn2z1Spec.
- destruct (FnCommutes _ _ _ fn1z0Spec fn2z1Spec) as [x1' [fn2z0Spec fn1x1'Spec]].
- exists x1'; assumption.
- - rewrite decide_True in Spec12; [|assumption].
- destruct Spec12 as [x2 [x2Spec fn2x1Spec]].
- exists x2; rewrite <- Spec01; assumption.
- }
- destruct (mem_apply_range'_success_condition fn2mem0) as [mem1' Success01'].
- exists mem1'.
- split; [assumption|].
- apply mem_apply_range'_success_specification.
- - intros z R1.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01') as Spec01'.
- destruct (decide (range'_contains range2 z)).
- + rewrite decide_True in Spec01; [|assumption].
- destruct Spec01 as [fn1z0 [z1Spec fn1z0Spec]].
- destruct Spec12 as [fn2z1 [z2Spec fn2z1Spec]].
- destruct Spec01' as [fn2z0 [z1'Spec fn2z0Spec]].
- rewrite z1Spec in fn2z1Spec.
- destruct (FnCommutes _ _ _ fn1z0Spec fn2z1Spec) as [x2' [fn2z0'Spec fn1x2'Spec]].
- rewrite z1'Spec.
- rewrite <- fn2z0Spec.
- exists fn2z1.
- split; [|assumption].
- destruct (FnCommutes _ _ _ fn1z0Spec fn2z1Spec) as [x1' [fn2z0Spec' fn1x1'Spec]].
- rewrite fn2z0Spec'.
- rewrite fn1x1'Spec.
- reflexivity.
- + rewrite decide_True in Spec01; [|assumption].
- destruct Spec01 as [fn1z0 [z1Spec fn1z0Spec]].
- rewrite Spec01'.
- rewrite Spec12.
- exists fn1z0; split; assumption.
- - intros z nR1.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01') as Spec01'.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
- destruct (decide (range'_contains range2 z)).
- + rewrite decide_False in Spec01; [|assumption].
- destruct Spec01' as [fn2z0 [z1'Spec fn2z0Spec]].
- destruct Spec12 as [fn2z1 [z2Spec fn2z1Spec]].
- rewrite z1'Spec.
- rewrite <- fn2z0Spec.
- rewrite <- Spec01.
- rewrite fn2z1Spec.
- rewrite z2Spec.
- reflexivity.
- + rewrite decide_False in Spec01; [|assumption].
- rewrite Spec01'.
- rewrite <- Spec01.
- rewrite Spec12.
- reflexivity.
-Qed.
-
-Lemma range_foreach_disjoint_commutes
- {X} {fn1 fn2 : option X -> option X} {range1 range2}
- (Disjoint : disjoint' range1 range2)
- : commutes
- (mem_apply_range' fn1 range1)
- (mem_apply_range' fn2 range2).
-Proof.
- intros mem0 mem1 mem2 Success01 Success12.
- assert (forall z, range'_contains range2 z -> exists x1', fn2 (mem0 !! z) = Some x1') as fn2mem0. {
- intros z R2.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
- destruct (decide (range'_contains range1 z)).
- - exfalso; apply Disjoint; eexists; eauto.
- - rewrite decide_True in Spec12; [|assumption].
- destruct Spec12 as [x2 [x2Spec fn2x1Spec]].
- exists x2; rewrite <- Spec01; assumption.
- }
- destruct (mem_apply_range'_success_condition fn2mem0) as [mem1' Success01'].
- exists mem1'.
- split; [assumption|].
- apply mem_apply_range'_success_specification.
- - intros z R1.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01') as Spec01'.
- destruct (decide (range'_contains range2 z)).
- + exfalso; apply Disjoint; eexists; eauto.
- + rewrite decide_True in Spec01; [|assumption].
- destruct Spec01 as [fn1z0 [z1Spec fn1z0Spec]].
- rewrite Spec01'.
- rewrite Spec12.
- exists fn1z0; split; assumption.
- - intros z nR1.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success01') as Spec01'.
- pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
- destruct (decide (range'_contains range2 z)).
- + rewrite decide_False in Spec01; [|assumption].
- destruct Spec01' as [fn2z0 [z1'Spec fn2z0Spec]].
- destruct Spec12 as [fn2z1 [z2Spec fn2z1Spec]].
- rewrite z1'Spec.
- rewrite <- fn2z0Spec.
- rewrite <- Spec01.
- rewrite fn2z1Spec.
- rewrite z2Spec.
- reflexivity.
- + rewrite decide_False in Spec01; [|assumption].
- rewrite Spec01'.
- rewrite <- Spec01.
- rewrite Spec12.
- reflexivity.
-Qed.
-
-Lemma commutes_option_build
- {X} {dflt : X} {fn1 fn2}
- (Commutes : commutes fn1 fn2)
- : commutes_option
- (fun ox => fn1 (default dflt ox))
- (fun ox => fn2 (default dflt ox)).
-Proof.
- intros x0 x1 x2 Step01 Step12.
- destruct (Commutes (default dflt x0) _ _ Step01 Step12) as [?[??]].
- eexists; eauto.
-Qed.
-
-Lemma permissions_foreach_commutes
- range1 range2
- (fn1 fn2 : lazy_permission -> option lazy_permission)
- dflt
- (FnCommutes : commutes fn1 fn2)
- : commutes
- (permissions_apply_range' dflt range1 fn1)
- (permissions_apply_range' dflt range2 fn2).
-Proof.
- apply range_foreach_commutes.
- apply commutes_option_build.
- assumption.
-Qed.
-
-Lemma permissions_foreach_disjoint_commutes
- range1 range2
- (fn1 fn2 : lazy_permission -> option lazy_permission)
- dflt
- (Disjoint : disjoint' range1 range2)
- : commutes
- (permissions_apply_range' dflt range1 fn1)
- (permissions_apply_range' dflt range2 fn2).
-Proof.
- apply range_foreach_disjoint_commutes.
- assumption.
-Qed.
-
-Lemma item_apply_access_read_commutes
- {cids rel1 rel2 range1 fn1 fn2 range2}
- (FnCommutes : forall isprot,
- commutes
- (fn1 rel1 isprot)
- (fn2 rel2 isprot))
- : commutes
- (item_apply_access fn1 cids rel1 range1)
- (item_apply_access fn2 cids rel2 range2).
-Proof.
- intros it0 it1 it2 Step01 Step12.
- option step in Step01 as ?:S1.
- option step in Step12 as ?:S2.
- injection Step01; destruct it1 as [??? iperm1]; intro H; injection H; intros; subst; simpl in *; clear Step01; clear H.
- injection Step12; destruct it2 as [??? iperm2]; intro H; injection H; intros; subst; simpl in *; clear Step12; clear H.
- destruct (permissions_foreach_commutes
- range1 range2
- (fn1 _ _) (fn2 _ _)
- {| initialized:=PermLazy; perm:=initp it0 |}
- (FnCommutes _)
- (*(apply_access_perm_read_commutes (rel1:=rel1) (rel2:=rel2) (prot:=bool_decide (protector_is_active (iprot it0) cids)))*)
- (iperm it0) iperm1 iperm2
- S1 S2) as [perms' [Pre Post]].
- unfold item_apply_access.
- rewrite Pre; simpl.
- eexists; split; [reflexivity|].
- simpl. rewrite Post; simpl.
- reflexivity.
-Qed.
-
-Lemma item_apply_access_disjoint_commutes
- {cids rel1 rel2 fn1 fn2 range1 range2}
- (Disjoint : disjoint' range1 range2)
- : commutes
- (item_apply_access fn1 cids rel1 range1)
- (item_apply_access fn2 cids rel2 range2).
-Proof.
- intros it0 it1 it2 Step01 Step12.
- option step in Step01 as ?:S1.
- option step in Step12 as ?:S2.
- injection Step01; destruct it1; intro H; injection H; intros; subst; simpl in *; clear Step01; clear H.
- injection Step12; destruct it2; intro H; injection H; intros; subst; simpl in *; clear Step12; clear H.
- edestruct (permissions_foreach_disjoint_commutes
- range1 range2
- (fn1 rel1 (bool_decide (protector_is_active (iprot it0) cids)))
- (fn2 rel2 (bool_decide (protector_is_active (iprot it0) cids)))
- {| initialized:=PermLazy; perm:=initp it0 |}
- ) as [?[Pre Post]]; eauto.
- unfold item_apply_access.
- rewrite Pre; simpl.
- eexists; split; [reflexivity|].
- simpl. rewrite Post; simpl.
- reflexivity.
-Qed.
-
-Lemma apply_access_success_condition
- {fn cids access_tag range tr}
- (ALL_SOME : every_node
- (fun it => is_Some (item_apply_access fn cids (rel_dec tr access_tag (itag it)) range it)) tr)
- : exists tr', tree_apply_access fn cids access_tag range tr = Some tr'.
-Proof.
- assert (every_node is_Some (map_nodes (fun it => item_apply_access fn cids (rel_dec tr access_tag (itag it)) range it) tr)) as AllSomeMap by (rewrite every_node_map; assumption).
- destruct (proj2 (join_success_condition _) AllSomeMap).
- eexists; eassumption.
-Qed.
-
-Lemma join_map_commutes
- {fn1 fn2 : call_id_set -> rel_pos -> Z * nat -> item -> option item} {cids access_tag1 access_tag2 range1 range2}
- (Fn1PreservesTag : forall it it' cids rel range, fn1 cids rel range it = Some it' -> itag it = itag it')
- (Fn2PreservesTag : forall it it' cids rel range, fn2 cids rel range it = Some it' -> itag it = itag it')
- (Commutes : forall rel1 rel2, commutes
- (fn1 cids rel1 range1)
- (fn2 cids rel2 range2))
- (* We need the two [rel_dec] to refer to the same tree otherwise the proof would be much more difficult *)
- : forall (tr0:tree item),
- commutes
- (fun tr => join_nodes (map_nodes (fun it => fn1 cids (rel_dec tr0 access_tag1 it.(itag)) range1 it) tr))
- (fun tr => join_nodes (map_nodes (fun it => fn2 cids (rel_dec tr0 access_tag2 it.(itag)) range2 it) tr)).
-Proof.
- intros tr tr0.
- induction tr0 as [|data0 left0 IHleft right0 IHright]; intros tr1 tr2 Step01 Step12.
- - simpl in Step01; injection Step01; intros; subst.
- simpl in Step12; injection Step12; intros; subst.
- exists tree.empty; simpl; tauto.
- - option step in Step01 as data1:Data01.
- option step in Step01 as left1:Left01.
- option step in Step01 as right1:Right01.
- injection Step01; intros; subst.
- option step in Step12 as data2:Data12.
- option step in Step12 as left2:Left12.
- option step in Step12 as right2:Right12.
- injection Step12; intros; subst.
- destruct (Commutes _ _ data0 data1 data2 Data01 Data12) as [data1' [Data01' Data1'2]].
- destruct (IHleft left1 left2 Left01 Left12) as [left1' [Left01' Left1'2]].
- destruct (IHright right1 right2 Right01 Right12) as [right1' [Right01' Right1'2]].
- exists (branch data1' left1' right1').
- simpl in *.
- assert (itag data0 = itag data1) as Tg01 by (eapply Fn1PreservesTag; eassumption).
- assert (itag data0 = itag data1') as Tg01' by (eapply Fn2PreservesTag; eassumption).
- rewrite Tg01; rewrite Data01'; simpl.
- rewrite Left01'; simpl.
- rewrite Right01'; simpl.
- rewrite <- Tg01'; rewrite Data1'2; simpl.
- rewrite Left1'2; simpl.
- rewrite Right1'2; simpl.
- tauto.
-Qed.
-
-Lemma tree_apply_access_only_cares_about_rel
- {tr} {fn : call_id_set -> rel_pos -> Z * nat -> item -> option item} {cids access_tag range}
- {tr1 tr2}
- (Agree : forall tg tg', ParentChildIn tg tg' tr1 <-> ParentChildIn tg tg' tr2)
- (RAgree : forall tg tg', ImmediateParentChildIn tg tg' tr1 <-> ImmediateParentChildIn tg tg' tr2)
- : join_nodes (map_nodes (fun it => fn cids (rel_dec tr1 access_tag it.(itag)) range it) tr)
- = join_nodes (map_nodes (fun it => fn cids (rel_dec tr2 access_tag it.(itag)) range it) tr).
-Proof.
- induction tr as [|data sibling IHsibling child IHchild]; [simpl; reflexivity|].
- simpl.
- rewrite IHsibling; clear IHsibling.
- rewrite IHchild; clear IHchild.
- unfold rel_dec.
- f_equal. f_equal.
- destruct (decide (ParentChildIn _ _ _)) as [R1|R1].
- all: destruct (decide (ParentChildIn _ _ _)) as [R1'|R1'].
- all: destruct (decide (ParentChildIn _ _ _)) as [R2|R2].
- all: destruct (decide (ParentChildIn _ _ _)) as [R2'|R2'].
- all: try reflexivity.
- all: rewrite <- Agree in R2'; auto; try contradiction.
- all: rewrite <- Agree in R2; auto; try contradiction.
- all: erewrite decide_ext; last apply RAgree.
- all: done.
-Qed.
-
-Lemma tree_apply_access_commutes
- {fn1 fn2 cids access_tag1 access_tag2 range1 range2}
- (Commutes : forall rel1 rel2, commutes
- (item_apply_access fn1 cids rel1 range1)
- (item_apply_access fn2 cids rel2 range2))
- : commutes
- (fun tr => tree_apply_access fn1 cids access_tag1 range1 tr)
- (fun tr => tree_apply_access fn2 cids access_tag2 range2 tr).
-Proof.
- unfold tree_apply_access.
- intros tr0 tr1 tr2 Step01 Step12.
- assert (forall (it it' : item) (cids : call_id_set) (rel : rel_pos) (range : Z * nat),
- item_apply_access fn1 cids rel range it = Some it'
- → itag it = itag it') as Fn1PreservesTag. {
- intros. eapply item_apply_access_preserves_metadata. eassumption.
- }
- assert (forall (it it' : item) (cids : call_id_set) (rel : rel_pos) (range : Z * nat),
- item_apply_access fn2 cids rel range it = Some it'
- → itag it = itag it') as Fn2PreservesTag. {
- intros. eapply item_apply_access_preserves_metadata. eassumption.
- }
-
- erewrite tree_apply_access_only_cares_about_rel in Step01.
- 1: erewrite tree_apply_access_only_cares_about_rel in Step12.
- 1: edestruct (join_map_commutes
- Fn1PreservesTag
- Fn2PreservesTag
- Commutes _ tr0 tr1 tr2 Step01 Step12) as [tr1' [Step01' Step1'2]]. 1: exists tr1'; split; [exact Step01'|].
- 1: erewrite tree_apply_access_only_cares_about_rel in Step1'2.
- 1: exact Step1'2.
- all: intros tg tg'.
- - eapply join_map_eqv_rel; [|eassumption]. intros it it' H. eapply Fn2PreservesTag. exact H.
- - eapply join_map_eqv_imm_rel; [|eassumption]. intros it it' H. eapply Fn2PreservesTag. exact H.
- - symmetry. eapply join_map_eqv_rel; [|eassumption]. intros it it' H. eapply Fn1PreservesTag. exact H.
- - symmetry. eapply join_map_eqv_imm_rel; [|eassumption]. intros it it' H. eapply Fn1PreservesTag. exact H.
- - tauto.
- - tauto.
-Qed.
-
-Lemma memory_access_read_commutes
- {cids access_tag1 access_tag2 range1 range2}
- : commutes
- (memory_access AccessRead cids access_tag1 range1)
- (memory_access AccessRead cids access_tag2 range2).
-Proof.
- unfold memory_access.
- apply tree_apply_access_commutes; intros.
- apply item_apply_access_read_commutes; intros.
- apply apply_access_perm_read_commutes.
-Qed.
-
-Lemma memory_access_disjoint_commutes
- {cids kind1 kind2 access_tag1 access_tag2 range1 range2}
- (Disjoint : disjoint' range1 range2)
- : commutes
- (memory_access kind1 cids access_tag1 range1)
- (memory_access kind2 cids access_tag2 range2).
-Proof.
- unfold memory_access.
- apply tree_apply_access_commutes; intros.
- apply item_apply_access_disjoint_commutes; intros.
- assumption.
-Qed.
-
-Lemma llvm_read_read_reorder
- {tr_initial cids_initial tr_final cids_final access_tag1 access_tag2 range1 range2}
- (Seq12 : bor_local_seq
- {|seq_inv:=fun _ _ => True|}
- tr_initial cids_initial
- (
- [AccessBLEvt AccessRead access_tag1 range1]
- ++ [AccessBLEvt AccessRead access_tag2 range2]
- )
- tr_final cids_final
- )
- : bor_local_seq
- {|seq_inv:=fun _ _ => True|}
- tr_initial cids_initial
- (
- [AccessBLEvt AccessRead access_tag2 range2]
- ++ [AccessBLEvt AccessRead access_tag1 range1]
- )
- tr_final cids_final.
-Proof.
- rewrite bor_local_seq_split.
- rewrite bor_local_seq_split in Seq12.
- destruct Seq12 as [tr_interm [cids_interm [Pre Post]]].
- inversion Pre as [|??????? HEAD1 REST1]; subst.
- inversion Post as [|??????? HEAD2 REST2]; subst.
- inversion REST1 as [INV1|]; subst.
- inversion REST2 as [INV2|]; subst.
- inversion HEAD1 as [????? ACC1| | |]; subst.
- inversion HEAD2 as [????? ACC2| | |]; subst.
- destruct (memory_access_read_commutes tr_initial tr_interm tr_final ACC1 ACC2) as [tr_alt [PreAlt PostAlt]].
- exists tr_alt, cids_final.
- split.
- - econstructor; [done|constructor; [|exact PreAlt]|constructor; done].
- erewrite access_preserves_tags; eauto; apply item_apply_access_preserves_metadata.
- - econstructor; [done|constructor; [|exact PostAlt]|constructor; done].
- erewrite <- access_preserves_tags; eauto; apply item_apply_access_preserves_metadata.
-Qed.
-
-Lemma disjoint'_sym {range1 range2} : disjoint' range1 range2 <-> disjoint' range2 range1.
-Proof. unfold disjoint'; split; intros P Q; apply P; destruct Q as [?[??]]; eexists; split; eauto. Qed.
-
-Lemma llvm_disjoint_reorder
- {tr_initial cids_initial tr_final cids_final access_tag1 access_tag2 range1 range2 kind1 kind2}
- (Disjoint : disjoint' range1 range2)
- (Seq12 : bor_local_seq
- {|seq_inv:=fun _ _ => True|}
- tr_initial cids_initial
- (
- [AccessBLEvt kind1 access_tag1 range1]
- ++ [AccessBLEvt kind2 access_tag2 range2]
- )
- tr_final cids_final
- )
- : bor_local_seq
- {|seq_inv:=fun _ _ => True|}
- tr_initial cids_initial
- (
- [AccessBLEvt kind2 access_tag2 range2]
- ++ [AccessBLEvt kind1 access_tag1 range1]
- )
- tr_final cids_final.
-Proof.
- rewrite bor_local_seq_split.
- rewrite bor_local_seq_split in Seq12.
- destruct Seq12 as [tr_interm [cids_interm [Pre Post]]].
- inversion Pre as [|??????? HEAD1 REST1]; subst.
- inversion Post as [|??????? HEAD2 REST2]; subst.
- inversion REST1 as [INV1|]; subst.
- inversion REST2 as [INV2|]; subst.
- inversion HEAD1 as [????? ACC1| | |]; subst.
- inversion HEAD2 as [????? ACC2| | |]; subst.
- destruct (memory_access_disjoint_commutes Disjoint tr_initial tr_interm tr_final ACC1 ACC2) as [tr_alt [PreAlt PostAlt]].
-
- exists tr_alt, cids_final.
- split.
- - econstructor; [done|constructor; [|exact PreAlt]|constructor; done].
- erewrite access_preserves_tags; eauto; apply item_apply_access_preserves_metadata.
- - econstructor; [done|constructor; [|exact PostAlt]|constructor; done].
- erewrite <- access_preserves_tags; eauto; apply item_apply_access_preserves_metadata.
-Qed.
-
-Lemma bor_local_seq_accesses_same_cids
- {tr cid cids evts tr' cids'}
- (StartsActive : call_is_active cid cids)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- (NoEndCall : Forall (fun evt => evt ≠EndCallBLEvt cid) evts)
- : bor_local_seq
- {|seq_inv:=fun _ cids => call_is_active cid cids|}
- tr cids evts tr' cids'.
-Proof.
- generalize dependent tr.
- generalize dependent cids.
- induction evts as [|?? IHevts]; move=> ??? Seq; inversion Seq as [|??????? HEAD]; subst.
- - constructor; assumption.
- - econstructor.
- + assumption.
- + eassumption.
- + eapply IHevts.
- * inversion NoEndCall; subst; assumption.
- * inversion HEAD as [| |cid0|]; subst.
- -- eassumption.
- -- unfold call_is_active. rewrite elem_of_union. right.
- assumption.
- -- assert (cid ≠cid0) as OtherCid by (intro; inversion NoEndCall as [|?? NE]; apply NE; subst; reflexivity).
- unfold call_is_active. rewrite elem_of_difference.
- split; [assumption|].
- rewrite not_elem_of_singleton; assumption.
- -- assumption.
- * assumption.
-Qed.
-
-Theorem llvm_noalias_reorder
- {tg_xparent pk cid}
- {tg_x kind_x range_x}
- {tg_y kind_y range_y}
- {tr_initial cids_initial opaque tr_final cids_final}
- (AlreadyExists_y : tree_contains tg_y tr_initial) :
- let retag_x := RetagBLEvt tg_xparent tg_x pk cid FnEntry in
- let access_y := AccessBLEvt kind_y tg_y range_y in
- let access_x := AccessBLEvt kind_x tg_x range_x in
- let invariant := {| seq_inv := fun _ cids => call_is_active cid cids |} in
- (bor_local_seq invariant tr_initial cids_initial ([retag_x] ++ opaque ++ [access_y] ++ [access_x]) tr_final cids_final)
- <->
- (bor_local_seq invariant tr_initial cids_initial ([retag_x] ++ opaque ++ [access_x] ++ [access_y]) tr_final cids_final).
-Proof.
- split; intro Seq.
- - destruct kind_x, kind_y.
- 2: assert (disjoint' range_y range_x) by (eapply llvm_retagx_opaque_writey_readx_disjoint; eassumption).
- 3: assert (disjoint' range_y range_x) by (eapply llvm_retagx_opaque_ready_writex_disjoint; eassumption).
- 4: assert (disjoint' range_y range_x) by (eapply llvm_retagx_opaque_writey_writex_disjoint; eassumption).
- all: rewrite bor_local_seq_split in Seq; destruct Seq as [?[? [Pre1 Seq]]].
- all: rewrite bor_local_seq_split in Seq; destruct Seq as [?[? [Pre2 Seq]]].
- all: rewrite bor_local_seq_split; eexists; eexists; split; [eassumption|].
- all: rewrite bor_local_seq_split; eexists; eexists; split; [eassumption|].
- all: eapply bor_local_seq_accesses_same_cids; [exact (seq_always_destruct_first Seq)| |simpl; auto].
- 1: apply llvm_read_read_reorder; eapply bor_local_seq_forget; eassumption.
- all: apply llvm_disjoint_reorder; [assumption|].
- all: eapply bor_local_seq_forget; eassumption.
- - destruct kind_x, kind_y.
- 2: assert (disjoint' range_x range_y) by (eapply llvm_retagx_opaque_readx_writey_disjoint; eassumption).
- 3: assert (disjoint' range_x range_y) by (eapply llvm_retagx_opaque_writex_ready_disjoint; eassumption).
- 4: assert (disjoint' range_x range_y) by (eapply llvm_retagx_opaque_writex_writey_disjoint; eassumption).
- all: rewrite bor_local_seq_split in Seq; destruct Seq as [?[? [Pre1 Seq]]].
- all: rewrite bor_local_seq_split in Seq; destruct Seq as [?[? [Pre2 Seq]]].
- all: rewrite bor_local_seq_split; eexists; eexists; split; [eassumption|].
- all: rewrite bor_local_seq_split; eexists; eexists; split; [eassumption|].
- all: eapply bor_local_seq_accesses_same_cids; [exact (seq_always_destruct_first Seq)| |simpl; auto].
- 1: apply llvm_read_read_reorder; eapply bor_local_seq_forget; eassumption.
- all: apply llvm_disjoint_reorder; [assumption|].
- all: eapply bor_local_seq_forget; eassumption.
-Qed.
-
-Check neven_see_also_the_todo_for_the_local_step_semantics_which_is_missing_a_case.
-*)
diff --git a/theories/tree_borrows/early_proofmode.v b/theories/tree_borrows/early_proofmode.v
index ac921fdaef4c191c6a4230a9ed01fef989219f35..d97906d38bd76ae1322b0102aacb3dde182d1fa2 100644
--- a/theories/tree_borrows/early_proofmode.v
+++ b/theories/tree_borrows/early_proofmode.v
@@ -378,7 +378,6 @@ Ltac sim_val := sim_finish; sim_result_head.
(** ** Pure reduction *)
Ltac solve_pure_sidecond :=
- (*TODO: have tactic adapted to our instances *)
fast_done || (left; fast_done) || (right; fast_done).
(** The argument [efoc] can be used to specify the construct that should be
diff --git a/theories/tree_borrows/examples/protected/mutable_reorder_read_down.v b/theories/tree_borrows/examples/protected/mutable_reorder_read_down.v
index 2c49abb349e078eba831d71c4d35adf5aed0a5e7..73d7c59688c60d32d20c389f02f67b402503b68c 100755
--- a/theories/tree_borrows/examples/protected/mutable_reorder_read_down.v
+++ b/theories/tree_borrows/examples/protected/mutable_reorder_read_down.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.simulation Require Import lifting.
From simuliris.tree_borrows Require Import primitive_laws proofmode examples.lib adequacy.
From iris.prelude Require Import options.
@@ -127,8 +123,10 @@ Section closed.
Qed.
End closed.
+(*
Check prot_mutable_reorder_read_down_ctx.
Print Assumptions prot_mutable_reorder_read_down_ctx.
+*)
(*
prot_mutable_reorder_read_down_ctx
: ctx_ref prot_mutable_reorder_read_down_opt prot_mutable_reorder_read_down_unopt
diff --git a/theories/tree_borrows/examples/protected/mutable_reorder_read_up.v b/theories/tree_borrows/examples/protected/mutable_reorder_read_up.v
index 39171b47828256ea4a1109befe0d43dd587da936..a31f72c9df7827cd121910b493307e39bcb353f4 100755
--- a/theories/tree_borrows/examples/protected/mutable_reorder_read_up.v
+++ b/theories/tree_borrows/examples/protected/mutable_reorder_read_up.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.simulation Require Import lifting.
From simuliris.tree_borrows Require Import primitive_laws proofmode examples.lib adequacy.
From iris.prelude Require Import options.
@@ -128,8 +124,10 @@ Section closed.
Qed.
End closed.
+(*
Check prot_mutable_reorder_read_up_ctx.
Print Assumptions prot_mutable_reorder_read_up_ctx.
+*)
(*
prot_mutable_reorder_read_up_ctx
: ctx_ref prot_mutable_reorder_read_up_opt prot_mutable_reorder_read_up_unopt
diff --git a/theories/tree_borrows/examples/protected/mutable_reorder_write_down_activated.v b/theories/tree_borrows/examples/protected/mutable_reorder_write_down_activated.v
index ae4933d020195ab3cdcf8b3b7736a7e87bf43f0e..41fd8d98f8f69ce21df03eb4580b5110c5d8d2af 100755
--- a/theories/tree_borrows/examples/protected/mutable_reorder_write_down_activated.v
+++ b/theories/tree_borrows/examples/protected/mutable_reorder_write_down_activated.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.simulation Require Import lifting.
From simuliris.tree_borrows Require Import proofmode lang adequacy examples.lib.
From iris.prelude Require Import options.
@@ -178,8 +174,10 @@ Section closed.
Qed.
End closed.
+(*
Check prot_mutable_reorder_write_down_activated_ctx.
Print Assumptions prot_mutable_reorder_write_down_activated_ctx.
+*)
(*
prot_mutable_reorder_write_down_activated_ctx
: ctx_ref prot_mutable_reorder_write_down_activated_opt prot_mutable_reorder_write_down_activated_unopt
diff --git a/theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated.v b/theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated.v
index a12caee72f3fa603437e194c583f7177dd7a106f..9c3532c516b738bc99b2fa3b350b69c6ec5de26f 100755
--- a/theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated.v
+++ b/theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.simulation Require Import lifting.
From simuliris.tree_borrows Require Import proofmode lang adequacy examples.lib.
From iris.prelude Require Import options.
@@ -136,8 +132,10 @@ Section closed.
Qed.
End closed.
+(*
Check prot_mutable_reorder_write_up_activated_ctx.
Print Assumptions prot_mutable_reorder_write_up_activated_ctx.
+*)
(*
prot_mutable_reorder_write_up_activated_ctx
: ctx_ref prot_mutable_reorder_write_up_activated_opt prot_mutable_reorder_write_up_activated_unopt
diff --git a/theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated_paper.v b/theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated_paper.v
new file mode 100644
index 0000000000000000000000000000000000000000..3a5ee20d6b10baf028a78dd5fae284796ee605ef
--- /dev/null
+++ b/theories/tree_borrows/examples/protected/mutable_reorder_write_up_activated_paper.v
@@ -0,0 +1,159 @@
+From simuliris.simulation Require Import lifting.
+From simuliris.tree_borrows Require Import proofmode lang adequacy examples.lib.
+From iris.prelude Require Import options.
+
+
+(** Moving a write to a mutable reference up across unknown code. *)
+
+(* Assuming x : &mut i32 *)
+Definition prot_mutable_reorder_write_up_activated_paper_unopt : expr :=
+ let: "c" := InitCall in
+ (* "x" is the local variable that stores the pointer value "i" *)
+ let: "x" := new_place sizeof_scalar "i" in
+
+ (* retag_place reborrows the pointer value stored in "x" (which is "i"),
+ then updates "x" with the new pointer value. This relies on protectors,
+ hence [FnEntry]. *)
+ retag_place "x" MutRef TyFrz sizeof_scalar FnEntry "c";;
+
+ (* Call the unknown function "f" *)
+ Call #[ScFnPtr "f"] "f_closure_arg" ;;
+
+ (* Write 10 to the cell pointed to by the pointer in "x" *)
+ *{sizeof_scalar} "x" <- #[10] ;;
+
+ (* Call the unknown function "g" *)
+ Call #[ScFnPtr "g"] "g_closure_arg" ;;
+
+ (* Write 0 to the cell pointed to by the pointer in "x" *)
+ *{sizeof_scalar} "x" <- #[0] ;;
+
+ (* Free the local variable *)
+ Free "x" ;;
+
+ (* Finally, return unit *)
+ EndCall "c";;
+ #[]
+ .
+
+Definition prot_mutable_reorder_write_up_activated_paper_opt : expr :=
+ let: "c" := InitCall in
+ let: "x" := new_place sizeof_scalar "i" in
+ retag_place "x" MutRef TyFrz sizeof_scalar FnEntry "c";;
+ Call #[ScFnPtr "f"] "f_closure_arg" ;;
+ *{sizeof_scalar} "x" <- #[0] ;;
+ Call #[ScFnPtr "g"] "g_closure_arg" ;;
+ Free "x" ;;
+ EndCall "c";;
+ #[]
+ .
+
+Lemma prot_mutable_reorder_write_up_activated_paper `{sborGS Σ} :
+ ⊢ log_rel prot_mutable_reorder_write_up_activated_paper_opt prot_mutable_reorder_write_up_activated_paper_unopt.
+Proof.
+ log_rel.
+ iIntros "%f_closure_t %f_closure_s #Hrel_f_closure".
+ iIntros "%r_t %r_s #Hrel".
+ iIntros "%g_closure_t %g_closure_s #Hrel_g_closure".
+ iIntros "!# %Ï€ _".
+ sim_pures.
+ rewrite !subst_result.
+ sim_apply InitCall InitCall sim_init_call "". iIntros (c) "Hcall". iApply sim_expr_base. sim_pures.
+
+ (* new place *)
+ simpl. source_bind (new_place _ _).
+ iApply source_red_safe_reach.
+ { intros. rewrite subst_result. eapply new_place_safe_reach. }
+ simpl. iIntros "(%v_s & -> & %Hsize)". destruct v_s as [|v_s [|?]]; try done.
+ iPoseProof (rrel_value_source with "Hrel") as (v_t) "(-> & #Hv)".
+ iPoseProof (value_rel_length with "Hv") as "%Hlen". destruct v_t as [|v_t [|?]]; try done.
+ iApply source_red_base. iModIntro. to_sim.
+ sim_apply (new_place _ _) (new_place _ _) sim_new_place_local "%t %l % % Htag Ht Hs"; first done.
+ sim_pures.
+
+ target_apply (Copy _) (target_copy_local with "Htag Ht") "Ht Htag". 2: done. 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ source_apply (Copy _) (source_copy_local with "Htag Hs") "Hs Htag". 2: done. 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+
+ (* do the retag *)
+ sim_bind (Retag _ _ _ _ _ _) (Retag _ _ _ _ _ _).
+ iApply sim_safe_implies.
+ iIntros ((_ & ot & i & [= ->] & _)).
+ iPoseProof (value_rel_singleton_source with "Hv") as (sc_t [= ->]) "Hscrel".
+ iPoseProof (sc_rel_ptr_source with "Hscrel") as ([= ->]) "Htagged".
+ iApply (sim_retag_fnentry with "Hscrel Hcall"). 1: by cbv.
+ iIntros (t_i v_t v_s _ Hlen_t Hlen_s) "Hcall #Hvrel Htag_i Hi_t Hi_s".
+ destruct v_t as [|v_t []]; try done.
+ destruct v_s as [|v_s []]; try done. iSimpl in "Hcall".
+ iApply sim_expr_base.
+ target_apply (Write _ _) (target_write_local with "Htag Ht") "Ht Htag".
+ 2-3: done. 1: rewrite /write_range bool_decide_true. 2: simpl; lia. 1: rewrite Z.sub_diag /= //.
+ source_apply (Write _ _) (source_write_local with "Htag Hs") "Hs Htag".
+ 2: done. 1: rewrite /write_range bool_decide_true. 2: simpl; lia. 1: rewrite Z.sub_diag /= //.
+ sim_pures.
+
+ (* arbitrary code (call to f) *)
+ rewrite !subst_result.
+ sim_apply (Call _ _) (Call _ _) (sim_call _ _ _) ""; first done.
+ iIntros (r_t_f r_s_f) "Hsamef". sim_pures.
+
+ (* do the activation write *)
+ source_apply (Copy (Place _ _ _)) (source_copy_local with "Htag Hs") "Hs Htag". 2: done.
+ 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ source_pures. source_finish.
+ target_apply (Copy (Place _ _ _)) (target_copy_local with "Htag Ht") "Ht Htag". 2: done.
+ 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ target_pures.
+
+ sim_apply (Write _ _) (Write _ _) (sim_write_activate_protected with "Htag_i Hi_t Hi_s Hcall") "Htag_i Hi_t Hi_s Hcall". 1-3: done.
+ { intros off Hoff. simpl in *. assert (off = 0)%nat as -> by lia. rewrite /shift_loc /= Z.add_0_r /call_set_in lookup_insert /=. do 2 eexists; split; first done.
+ by rewrite lookup_insert. }
+ sim_pures.
+
+ (* arbitrary code (call to g) *)
+ sim_apply (Call _ _) (Call _ _) (sim_call _ _ _) ""; first done.
+ iIntros (r_t r_s) "Hsame1". sim_pures.
+
+ (* do the source store *)
+ source_apply (Copy (Place _ _ _)) (source_copy_local with "Htag Hs") "Hs Htag". 2: done.
+ 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ source_pures.
+ source_apply (Write (Place _ _ _) _) (source_write_protected_active with "Hcall Htag_i Hi_s") "Hi_s Htag_i Hcall". 1,3,4: done.
+ 1: { rewrite write_range_to_to_list; last (simpl; lia). rewrite Z.sub_diag /= //. }
+ 2: rewrite lookup_insert //.
+ 1: intros off (?&?); assert (off = i.2) as -> by (simpl in *; lia); rewrite /shift_loc /= Z.add_0_r lookup_insert; by eexists.
+ source_pures. source_finish.
+
+ (* cleanup: remove the protector ghost state, make the external locations public, free the local locations*)
+ sim_apply (Free _) (Free _) (sim_free_local with "Htag Ht Hs") "Htag"; [done..|]. sim_pures.
+ iApply (sim_make_unique_public with "Hi_t Hi_s Htag_i Hcall []"). 1: by rewrite lookup_insert.
+ { iIntros "_". iApply value_rel_int. }
+ iIntros "Htag_i Hcall". iEval (rewrite !fmap_insert !fmap_empty !insert_insert /=) in "Hcall".
+ iApply (sim_protected_unprotect_public with "Hcall Htag_i"). 1: by rewrite lookup_insert.
+ iIntros "Hc". iEval (rewrite delete_insert) in "Hc".
+ sim_apply (EndCall _) (EndCall _) (sim_endcall_own with "Hc") "".
+ sim_pures.
+ sim_val. iModIntro. iSplit; first done.
+ by iApply big_sepL2_nil.
+Qed.
+
+Section closed.
+ (** Obtain a closed proof of [ctx_ref]. *)
+ Lemma prot_mutable_reorder_write_up_activated_paper_ctx : ctx_ref prot_mutable_reorder_write_up_activated_paper_opt prot_mutable_reorder_write_up_activated_paper_unopt.
+ Proof.
+ set Σ := #[sborΣ].
+ apply (log_rel_adequacy Σ)=>?.
+ apply prot_mutable_reorder_write_up_activated_paper.
+ Qed.
+End closed.
+
+(*
+Check prot_mutable_reorder_write_up_activated_paper_ctx.
+Print Assumptions prot_mutable_reorder_write_up_activated_paper_ctx.
+*)
+(*
+prot_mutable_reorder_write_up_activated_paper_ctx
+ : ctx_ref prot_mutable_reorder_write_up_activated_paper_opt prot_mutable_reorder_write_up_activated_paper_unopt
+Axioms:
+IndefiniteDescription.constructive_indefinite_description : ∀ (A : Type) (P : A → Prop), (∃ x : A, P x) → {x : A | P x}
+Classical_Prop.classic : ∀ P : Prop, P ∨ ¬ P
+*)
diff --git a/theories/tree_borrows/examples/protected/shared_insert_read.v b/theories/tree_borrows/examples/protected/shared_insert_read.v
new file mode 100644
index 0000000000000000000000000000000000000000..bdf9d3bbaf377b4847c6443de70e512338b30dab
--- /dev/null
+++ b/theories/tree_borrows/examples/protected/shared_insert_read.v
@@ -0,0 +1,171 @@
+From simuliris.simulation Require Import lifting.
+From simuliris.tree_borrows Require Import proofmode lang adequacy examples.lib.
+From iris.prelude Require Import options.
+
+
+
+(** Moving read of shared ref up across code that *may* use that ref. *)
+
+(** This is a variant using protectors.
+ See delete_read_pubic_escaped_unprotected.v for the original optimization without protectors and with deferred UB.
+ *)
+
+(* Assuming x : & i32 *)
+
+Definition prot_shared_insert_read_unopt : expr :=
+ let: "c" := InitCall in
+
+ (* "x" is the local variable that stores the pointer value "i" *)
+ let: "x" := new_place sizeof_scalar "i" in
+
+ (* retag_place reborrows the pointer value stored in "x" (which is "i"),
+ then updates "x" with the new pointer value.
+ Using a protector here.
+ *)
+ retag_place "x" ShrRef TyFrz sizeof_scalar FnEntry "c";;
+
+ (* The unknown code is represented by a call to an unknown function "f" *)
+ let: "tst" := Call #[ScFnPtr "f"] (#[]) in
+ (* if tst is negative, if so read from x, otherwise return tst *)
+ let: "result" := if: "tst" ≤ (#[0])%V
+ then Copy *{sizeof_scalar} "x"
+ else "tst" in
+
+ (* Free the local variable *)
+ Free "x" ;;
+
+ (* Finally, return the read value *)
+ EndCall "c";;
+ "result"
+ .
+
+Definition prot_shared_insert_read_opt : expr :=
+ let: "c" := InitCall in
+ let: "x" := new_place sizeof_scalar "i" in
+ retag_place "x" ShrRef TyFrz sizeof_scalar FnEntry "c";;
+ let: "tst" := Call #[ScFnPtr "f"] (#[]) in
+ let: "v" := Copy *{sizeof_scalar} "x" in
+ let: "result" := if: "tst" ≤ (#[0])%V then "v" else "tst" in
+ Free "x" ;;
+ EndCall "c";;
+ "result"
+ .
+
+Lemma prot_shared_insert_read `{sborGS Σ} :
+ ⊢ log_rel prot_shared_insert_read_opt prot_shared_insert_read_unopt.
+Proof.
+ log_rel.
+ iIntros "%r_t %r_s #Hrel !# %Ï€ _".
+ sim_pures.
+ sim_apply InitCall InitCall sim_init_call "". iIntros (c) "Hcall". iApply sim_expr_base. sim_pures.
+
+ (* new place *)
+ simpl. source_bind (new_place _ _).
+ iApply source_red_safe_reach.
+ { intros. rewrite subst_result. eapply new_place_safe_reach. }
+ simpl. iIntros "(%v_s & -> & %Hsize)". destruct v_s as [|v_s [|?]]; try done.
+ iPoseProof (rrel_value_source with "Hrel") as (v_t) "(-> & #Hv)".
+ iPoseProof (value_rel_length with "Hv") as "%Hlen". destruct v_t as [|v_t [|?]]; try done.
+ iApply source_red_base. iModIntro. to_sim.
+ sim_apply (new_place _ _) (new_place _ _) sim_new_place_local "%t %l % % Htag Ht Hs"; first done.
+ sim_pures.
+
+ target_apply (Copy _) (target_copy_local with "Htag Ht") "Ht Htag". 2: done. 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ source_apply (Copy _) (source_copy_local with "Htag Hs") "Hs Htag". 2: done. 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+
+ (* do the retag *)
+ sim_bind (Retag _ _ _ _ _ _) (Retag _ _ _ _ _ _).
+ iApply sim_safe_implies.
+ iIntros ((_ & ot & i & [= ->] & _)).
+ iPoseProof (value_rel_singleton_source with "Hv") as (sc_t [= ->]) "Hscrel".
+ iPoseProof (sc_rel_ptr_source with "Hscrel") as ([= ->]) "Htagged".
+ iApply (sim_retag_fnentry with "Hscrel Hcall"). 1: by cbv.
+ iIntros (t_i v_t v_s _ Hlen_t Hlen_s) "Hcall #Hvrel #Htag_i Hi_t Hi_s".
+ destruct v_t as [|v_t []]; try done.
+ destruct v_s as [|v_s []]; try done. iSimpl in "Hcall".
+ iApply sim_expr_base.
+ target_apply (Write _ _) (target_write_local with "Htag Ht") "Ht Htag".
+ 2-3: done. 1: rewrite /write_range bool_decide_true. 2: simpl; lia. 1: rewrite Z.sub_diag /= //.
+ source_apply (Write _ _) (source_write_local with "Htag Hs") "Hs Htag".
+ 2: done. 1: rewrite /write_range bool_decide_true. 2: simpl; lia. 1: rewrite Z.sub_diag /= //.
+ sim_pures.
+
+ (* do the call *)
+ sim_pures.
+ sim_apply (Call _ _) (Call _ _) (sim_call _ (ValR []) (ValR [])) "".
+ { iApply big_sepL2_nil. done. }
+ iIntros (r_t r_s) "#Hfres". sim_pures.
+
+ (* do the target load *)
+ target_apply (Copy (Place _ _ _)) (target_copy_local with "Htag Ht") "Ht Htag". 2: done.
+ 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ target_pures. target_bind (Copy _).
+ iApply (target_copy_protected with "Hcall Htag_i Hi_t"). 1: done.
+ 2: simpl; lia. 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ 2: by rewrite lookup_insert.
+ { intros off Hoff. simpl in *. rewrite /range'_contains /sizeof_scalar /= in Hoff. assert (off = i.2)%nat as -> by lia. rewrite /shift_loc /= Z.add_0_r /call_set_in lookup_insert /=. by eexists. }
+ iIntros "Hi_t _ Hcall". target_finish.
+ sim_pures. simpl. rewrite !subst_result.
+
+ source_bind (BinOp _ _ _).
+ iApply source_red_safe_implies. 1: eapply (safe_implies_le r_s (ValR [ScInt 0]%V)%V).
+ iIntros ((zres_s & z2 & -> & [= <-])).
+ destruct r_t as [[|zres_t []]|]; simpl; try done.
+ 2: { iExFalso. iPoseProof (big_sepL2_length with "Hfres") as "%HH". done. }
+ iEval (rewrite /value_rel /= /sc_rel) in "Hfres". iDestruct "Hfres" as "[Hfres _]".
+ destruct zres_t; try done. iPure "Hfres" as ->.
+ sim_pures. target_pures. sim_pures.
+ destruct (bool_decide (zres_s ≤ 0%nat)%Z).
+ - simpl. target_case; first done. source_case; first done. sim_pures.
+ (* do the source load *)
+ source_apply (Copy (Place _ _ _)) (source_copy_local with "Htag Hs") "Hs Htag". 2: done.
+ 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ source_pures. source_bind (Copy _).
+ iApply (source_copy_protected with "Hcall Htag_i Hi_s"). 1: done.
+ 2: simpl; lia. 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
+ 2: by rewrite lookup_insert.
+ { intros off Hoff. simpl in *. rewrite /range'_contains /sizeof_scalar /= in Hoff. assert (off = i.2)%nat as -> by lia. rewrite /shift_loc /= Z.add_0_r /call_set_in lookup_insert /=. by eexists. }
+ iIntros "Hi_s _ Hcall". source_finish.
+ sim_pures.
+
+ (* cleanup: remove the protector ghost state, make the external locations public, free the local locations*)
+ sim_apply (Free _) (Free _) (sim_free_local with "Htag Ht Hs") "Htag"; [done..|]. sim_pures.
+ iApply (sim_protected_unprotect_public with "Hcall Htag_i"). 1: by rewrite lookup_insert.
+ iIntros "Hc". iEval (rewrite delete_insert) in "Hc".
+ sim_apply (EndCall _) (EndCall _) (sim_endcall_own with "Hc") "".
+ sim_pures.
+ sim_val. iModIntro. iSplit; first done. done.
+ - simpl. target_case; first done. source_case; first done. sim_pures.
+
+ (* cleanup: remove the protector ghost state, make the external locations public, free the local locations*)
+ sim_apply (Free _) (Free _) (sim_free_local with "Htag Ht Hs") "Htag"; [done..|]. sim_pures.
+ iApply (sim_protected_unprotect_public with "Hcall Htag_i"). 1: by rewrite lookup_insert.
+ iIntros "Hc". iEval (rewrite delete_insert) in "Hc".
+ sim_apply (EndCall _) (EndCall _) (sim_endcall_own with "Hc") "".
+ sim_pures.
+ sim_val. iModIntro. iSplit; first done. iApply big_sepL2_singleton. done.
+Qed.
+
+
+Section closed.
+ (** Obtain a closed proof of [ctx_ref]. *)
+ Lemma prot_shared_insert_read_ctx : ctx_ref prot_shared_insert_read_opt prot_shared_insert_read_unopt.
+ Proof.
+ set Σ := #[sborΣ].
+ apply (log_rel_adequacy Σ)=>?.
+ apply prot_shared_insert_read.
+ Qed.
+End closed.
+
+(*
+Check prot_shared_insert_read_ctx.
+Print Assumptions prot_shared_insert_read_ctx.
+*)
+(*
+prot_shared_insert_read_ctx
+ : ctx_ref prot_shared_insert_read_opt prot_shared_insert_read_unopt
+Axioms:
+IndefiniteDescription.constructive_indefinite_description : ∀ (A : Type) (P : A → Prop), (∃ x : A, P x) → {x : A | P x}
+Classical_Prop.classic : ∀ P : Prop, P ∨ ¬ P
+*)
+
diff --git a/theories/tree_borrows/examples/protected/shared_reorder_read_down_escaped.v b/theories/tree_borrows/examples/protected/shared_reorder_read_down_escaped.v
index ffa0acf2a0b111dd0b52e550bc1f975f4ce03b54..4574666711631c6c3bfda780ff0df9ad1a63e957 100755
--- a/theories/tree_borrows/examples/protected/shared_reorder_read_down_escaped.v
+++ b/theories/tree_borrows/examples/protected/shared_reorder_read_down_escaped.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.simulation Require Import lifting.
From simuliris.tree_borrows Require Import proofmode lang examples.lib adequacy.
From iris.prelude Require Import options.
@@ -139,8 +135,10 @@ Section closed.
Qed.
End closed.
+(*
Check prot_shared_reorder_read_down_escaped_ctx.
Print Assumptions prot_shared_reorder_read_down_escaped_ctx.
+*)
(*
prot_shared_reorder_read_down_escaped_ctx
: ctx_ref prot_shared_reorder_read_down_escaped_opt prot_shared_reorder_read_down_escaped_unopt
diff --git a/theories/tree_borrows/examples/protected/shared_reorder_read_up_escaped.v b/theories/tree_borrows/examples/protected/shared_reorder_read_up_escaped.v
index 303d4c545b56d9f6e59da9c2dd145da4ae6d38ec..71e9eb6e283ba568e76edfeb6733fdfdeeae84fd 100755
--- a/theories/tree_borrows/examples/protected/shared_reorder_read_up_escaped.v
+++ b/theories/tree_borrows/examples/protected/shared_reorder_read_up_escaped.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.simulation Require Import lifting.
From simuliris.tree_borrows Require Import proofmode lang adequacy examples.lib.
From iris.prelude Require Import options.
@@ -142,9 +138,10 @@ Section closed.
apply prot_shared_reorder_read_up_escaped.
Qed.
End closed.
-
+(*
Check prot_shared_reorder_read_up_escaped_ctx.
Print Assumptions prot_shared_reorder_read_up_escaped_ctx.
+*)
(*
prot_shared_reorder_read_up_escaped_ctx
: ctx_ref prot_shared_reorder_read_up_escaped_opt prot_shared_reorder_read_up_escaped_unopt
diff --git a/theories/tree_borrows/examples/unprotected/mutable_delete_read.v b/theories/tree_borrows/examples/unprotected/mutable_delete_read.v
index 64b2cf7e67f2237bc2ba739a81f479335c352453..a8a40a91584eb3fd275cf8cd70883cb864d7bda3 100644
--- a/theories/tree_borrows/examples/unprotected/mutable_delete_read.v
+++ b/theories/tree_borrows/examples/unprotected/mutable_delete_read.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.simulation Require Import lifting.
From simuliris.tree_borrows Require Import proofmode lang adequacy examples.lib.
From iris.prelude Require Import options.
@@ -115,7 +111,7 @@ Proof.
iApply (source_copy_in_simulation with "[] Htag_i Hi_s"). 1: done.
2: simpl; lia. 1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
- { iLeft. iApply value_rel_int. }
+ { iApply value_rel_int. }
iIntros (v_res) "Hi_s Htag_i Hv_res". source_pures. source_finish.
sim_pures.
@@ -138,8 +134,10 @@ Section closed.
Qed.
End closed.
+(*
Check unprot_mutable_delete_read_ctx.
Print Assumptions unprot_mutable_delete_read_ctx.
+*)
(*
unprot_mutable_delete_read_ctx
: ctx_ref unprot_mutable_delete_read_opt unprot_mutable_delete_read_unopt
diff --git a/theories/tree_borrows/examples/unprotected/shared_delete_read_escaped.v b/theories/tree_borrows/examples/unprotected/shared_delete_read_escaped.v
index 1a18add3ffc301e3cc10c7d4a3ce8fecd54f6682..adc95c916df633dfce7c929950ff8f4e6ab649d1 100644
--- a/theories/tree_borrows/examples/unprotected/shared_delete_read_escaped.v
+++ b/theories/tree_borrows/examples/unprotected/shared_delete_read_escaped.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.simulation Require Import lifting.
From simuliris.tree_borrows Require Import proofmode lang adequacy examples.lib.
From iris.prelude Require Import options.
@@ -18,12 +14,12 @@ Definition unprot_shared_delete_read_escaped_unopt : expr :=
then updates "x" with the new pointer value. A [Default] retag is
sufficient for this, we don't need the protector. *)
retag_place "x" ShrRef TyFrz sizeof_scalar Default #[ScCallId 0];;
- (* a "dummy load" -- since we can not insert loads, we must have a load here to so that it can remain in the target *)
- (* This load is not used here, but later the target will use the value loaded here *)
- Copy *{sizeof_scalar} "x" ;;
+ (* Note that val is not actually used in the source, but it will be used in the target. *)
+ let: "val" := Copy *{sizeof_scalar} "x" in
(* The unknown code is represented by a call to an unknown function "f",
- which does take the pointer value from "x" as an argument. *)
- Call #[ScFnPtr "f"] (Copy "x") ;;
+ which does take the pointer value from "x" as an argument.
+ To simulate Rust closures, it also takes an arbitrary closure env. *)
+ Call #[ScFnPtr "f"] (Conc "f_closure_env" (Copy "x")) ;;
(* Read the value "v" from the cell pointed to by the pointer in "x" *)
let: "v" := Copy *{sizeof_scalar} "x" in
@@ -38,8 +34,9 @@ Definition unprot_shared_delete_read_escaped_unopt : expr :=
Definition unprot_shared_delete_read_escaped_opt : expr :=
let: "x" := new_place sizeof_scalar "i" in
retag_place "x" ShrRef TyFrz sizeof_scalar Default #[ScCallId 0];;
- let: "v" := Copy *{sizeof_scalar} "x" in
- Call #[ScFnPtr "f"] (Copy "x") ;;
+ let: "val" := Copy *{sizeof_scalar} "x" in
+ Call #[ScFnPtr "f"] (Conc "f_closure_env" (Copy "x")) ;;
+ let: "v" := "val" in
Free "x" ;;
"v"
.
@@ -49,8 +46,9 @@ Lemma unprot_shared_delete_read_escaped `{sborGS Σ} :
⊢ log_rel unprot_shared_delete_read_escaped_opt unprot_shared_delete_read_escaped_unopt.
Proof.
log_rel.
- iIntros "%r_t %r_s #Hrel !# %Ï€ _".
+ iIntros "%closure_env_t %closure_env_s #Hclosure_env_rel %r_t %r_s #Hrel !# %Ï€ _".
sim_pures.
+ rewrite !subst_result.
(* new place *)
simpl. source_bind (new_place _ _).
@@ -102,8 +100,14 @@ Proof.
1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //.
source_apply (Copy _) (source_copy_local with "Htag Hs") "Hs Htag". 2: done.
1: rewrite read_range_heaplet_to_list // Z.sub_diag /= //. sim_pures.
- sim_apply (Call _ _) (Call _ _) (sim_call _ (ValR [ScPtr i _]) (ValR [ScPtr i _])) "".
- { iApply big_sepL2_singleton. iFrame "Htag_i". done. }
+ rewrite !subst_result.
+ source_bind (Conc _ _).
+ iApply source_red_safe_implies. 1: eapply irred_conc with (r2 := ValR _).
+ iIntros ((closure_env_s_v & v2 & -> & [= <-])).
+ destruct closure_env_t as [closure_env_t_v|]; last done.
+ source_pures. to_sim. sim_pures.
+ sim_apply (Call _ _) (Call _ _) (sim_call _ (ValR _) (ValR _)) "".
+ { iApply big_sepL2_app; first iAssumption. iApply big_sepL2_singleton. iFrame "Htag_i". done. }
iIntros (r_t r_s) "_". sim_pures.
(* source load (not existing in the target) *)
@@ -134,8 +138,10 @@ Section closed.
Qed.
End closed.
+(*
Check unprot_shared_delete_read_escaped_ctx.
Print Assumptions unprot_shared_delete_read_escaped_ctx.
+*)
(*
unprot_shared_delete_read_escaped_ctx
: ctx_ref unprot_shared_delete_read_escaped_opt unprot_shared_delete_read_escaped_unopt
diff --git a/theories/tree_borrows/examples/unprotected/shared_delete_read_escaped_coinductive.v b/theories/tree_borrows/examples/unprotected/shared_delete_read_escaped_coinductive.v
index 4d17427ef202db8f0148b0da752a144768e1c3a8..72891e222eaeb2d65559044c15dd696d52cb1bf3 100755
--- a/theories/tree_borrows/examples/unprotected/shared_delete_read_escaped_coinductive.v
+++ b/theories/tree_borrows/examples/unprotected/shared_delete_read_escaped_coinductive.v
@@ -323,9 +323,10 @@ Section closed.
Qed.
End closed.
-
+(*
Check unprot_shared_delete_read_escaped_coinductive_ctx.
Print Assumptions unprot_shared_delete_read_escaped_coinductive_ctx.
+*)
(*
unprot_shared_delete_read_escaped_coinductive_ctx
: ctx_ref unprot_shared_delete_read_escaped_coinductive_opt unprot_shared_delete_read_escaped_coinductive_unopt
diff --git a/theories/tree_borrows/expr_semantics.v b/theories/tree_borrows/expr_semantics.v
index 330bbabfc65dc1995a68db26cf3fea8bd20a493f..d658e9918ce642613c8f19e53596f6b20bf2b110 100755
--- a/theories/tree_borrows/expr_semantics.v
+++ b/theories/tree_borrows/expr_semantics.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From Equations Require Import Equations.
From iris.prelude Require Import prelude options.
From stdpp Require Export gmap.
@@ -27,12 +23,8 @@ Fixpoint subst (x : string) (es : expr) (e : expr) : expr :=
| Write e1 e2 => Write (subst x es e1) (subst x es e2)
| Alloc T => Alloc T
| Free e => Free (subst x es e)
- (* | CAS e0 e1 e2 => CAS (subst x es e0) (subst x es e1) (subst x es e2) *)
- (* | AtomWrite e1 e2 => AtomWrite (subst x es e1) (subst x es e2) *)
- (* | AtomRead e => AtomRead (subst x es e) *)
| Deref e T => Deref (subst x es e) T
| Ref e => Ref (subst x es e)
- (* | Field e path => Field (subst x: es e) path *)
| Retag e1 e2 newp im sz kind => Retag (subst x es e1) (subst x es e2) newp im sz kind
| Let x1 e1 e2 =>
Let x1 (subst x es e1)
@@ -40,7 +32,6 @@ Fixpoint subst (x : string) (es : expr) (e : expr) : expr :=
| Case e el => Case (subst x es e) (fmap (subst x es) el)
| Fork e => Fork (subst x es e)
| While e1 e2 => While (subst x es e1) (subst x es e2)
- (* | SysCall id => SysCall id *)
end.
(* formal argument list substitution *)
@@ -111,7 +102,6 @@ Inductive ectx_item :=
| FreeEctx
| DerefEctx (sz : nat)
| RefEctx
-(* | FieldEctx (path : list nat) *)
| RetagREctx (e1 : expr) (pk : pointer_kind) (im : interior_mut) (sz : nat) (kind : retag_kind)
| RetagLEctx (r2 : result) (pk : pointer_kind) (im : interior_mut) (sz : nat) (kind : retag_kind)
| LetEctx (x : binder) (e2 : expr)
@@ -136,7 +126,6 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
| FreeEctx => Free e
| DerefEctx T => Deref e T
| RefEctx => Ref e
- (* | FieldEctx path => Field e path *)
| RetagLEctx r2 newp im sz kind => Retag e (of_result r2) newp im sz kind
| RetagREctx e1 newp im sz kind => Retag e1 e newp im sz kind
| LetEctx x e2 => Let x e e2
@@ -465,15 +454,9 @@ Inductive pure_expr_step (P : prog) (h : mem) : expr → expr → list expr →
pure_expr_step P h (Conc (Val v1) (Val v2))
(Val (v1 ++ v2)) []
| RefPS l lbor T :
- (* is_Some (h !! l) → *)
pure_expr_step P h (Ref (Place l lbor T)) #[ScPtr l lbor] []
-| DerefPS l lbor T
- (* (DEFINED: ∀ (i: nat), (i < tsize T)%nat → l +ₗ i ∈ dom h) *) :
+| DerefPS l lbor T :
pure_expr_step P h (Deref #[ScPtr l lbor] T) (Place l lbor T) []
-(* | FieldBS l lbor T path off T'
- (FIELD: field_access T path = Some (off, T')) :
- pure_expr_step FNs h (Field (Place l lbor T) path)
- SilentEvt (Place (l +â‚— off) lbor T') *)
| LetPS x e1 e2 e' :
is_Some (to_result e1) →
subst' x e1 e2 = e' →
@@ -506,10 +489,12 @@ Inductive mem_expr_step (h: mem) : expr → event → mem → expr → list expr
| CopyBS blk l lbor sz (v: value)
(READ: read_mem (blk, l) sz h = Some v) :
mem_expr_step h (Copy (Place (blk, l) lbor sz)) (CopyEvt blk lbor (l, sz) v) h (Val v) []
-| FailedCopyBS blk l lbor sz
+(* This was a poison semantics for failing reads. We have removed this to be
+ closer to the actual semantics described in Tree Borrows.
+ | FailedCopyBS blk l lbor sz
(READ: is_Some (read_mem (blk, l) sz h)) :
(* failed copies lead to poison, but still of the appropriate length *)
- mem_expr_step h (Copy (Place (blk, l) lbor sz)) (FailedCopyEvt blk lbor (l, sz)) h (Val $ replicate sz ScPoison) []
+ mem_expr_step h (Copy (Place (blk, l) lbor sz)) (FailedCopyEvt blk lbor (l, sz)) h (Val $ replicate sz ScPoison) []*)
| WriteBS blk l lbor sz v
(LEN: length v = sz)
(DEFINED: ∀ (i: nat), (i < length v)%nat → (blk,l) +ₗ i ∈ dom h) :
@@ -524,17 +509,17 @@ Inductive mem_expr_step (h: mem) : expr → event → mem → expr → list expr
(AllocEvt blk lbor (0, sz))
(init_mem (blk, 0) sz h) (Place (blk, 0) lbor sz) []
| DeallocBS blk l (sz:nat) lbor :
- (* FIXME: l here is an offset. But we usually want to deallocate at offset 0, right? *)
- (* FIXME: This is wrong because it allows double-free of zero-sized allocations
- Possible solutions:
- - Change the heap from `gmap loc scalar` to `gmap blk (gmap Z scalar)`
- - Require `sz > 0` <- probably this
- - special case for TB where if the size is zero we don't add a new tree
+ (* WARNING: If we are not careful here, it could allow double-free of zero-sized allocations.
+ Possible solutions that we have considered include
+ - changing the heap from `gmap loc scalar` to `gmap blk (gmap Z scalar)`
+ - requiring `sz . 0`
+ - having a special case for TB where if the size is zero we don't add a new tree.
+
+ We go for the second one and forbid zero-sized allocations, at the level of
+ `AllocIS` in `bor_semantics`.
+ FIXME: We could potentially be able to actually *prove* here that `sz > 0`
+ if we added this to `state_wf`. Until then it is UB to deallocate a zero-sized.
*)
- (* Actual solution: We forbid zero-sized allocations (see AllocIS in bor_semantics).
- If we track that in state_wf, we should be able to prove that sz > 0 here,
- instead of making it UB.
- TODO actually add it to state_wf, until then it is UB *)
(sz > 0)%nat →
(∀ m, is_Some (h !! ((blk,l) +ₗ m)) ↔ 0 ≤ m < sz) →
mem_expr_step
@@ -546,8 +531,4 @@ Inductive mem_expr_step (h: mem) : expr → event → mem → expr → list expr
h (Retag #[ScPtr l otag] #[ScCallId cid] pk im sz kind)
(RetagEvt l.1 (l.2, sz) otag ntag pk im cid kind)
h #[ScPtr l ntag] []
-
-(* observable behavior *)
-(* | SysCallBS id h:
- expr_step (SysCall id) h (SysCallEvt id) (Lit LitPoison) h [] *)
.
diff --git a/theories/tree_borrows/helpers.v b/theories/tree_borrows/helpers.v
index 7e2a01e0cc0579c10bdf5637f0f5a769c013fdfa..2da99c05e8514509d13a6dfe80edabc5d135ba84 100755
--- a/theories/tree_borrows/helpers.v
+++ b/theories/tree_borrows/helpers.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From Coq Require Import ssreflect.
From stdpp Require Export list gmap.
From iris.prelude Require Export prelude.
diff --git a/theories/tree_borrows/lang.v b/theories/tree_borrows/lang.v
index 0e10eacfd88c0a99b8b7a6900ae61f686c9c2289..89d58619b8e159d3b4a1fdfbe481f498ed87e04e 100755
--- a/theories/tree_borrows/lang.v
+++ b/theories/tree_borrows/lang.v
@@ -1,6 +1,5 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
+(** This file manages the interface between the expression semantics and
+ the borrow semantics. *)
From simuliris.simulation Require Export language.
From iris.algebra Require Import ofe.
@@ -15,7 +14,7 @@ Module bor_lang.
Record state := mkState {
(* Heap of scalars *)
shp : mem;
- (* Stacked borrows for the heap *)
+ (* Borrow trees for each allocation of the heap *)
strs : trees;
(* Set of active call ids *)
scs : call_id_set;
diff --git a/theories/tree_borrows/lang_base.v b/theories/tree_borrows/lang_base.v
index 4a784959631bd215e699e1ae19837c31e75475b9..d522aa9cc71173ad6f7ef1866507e434b09843c1 100755
--- a/theories/tree_borrows/lang_base.v
+++ b/theories/tree_borrows/lang_base.v
@@ -191,7 +191,6 @@ Definition item_lookup (it : item) (l : Z) :=
Definition trees := gmap block (tree item).
(** Retag kinds *)
-(* FIXME: simplify related stuff *)
Inductive retag_kind := FnEntry | Default.
(** Language base constructs *)
@@ -200,20 +199,9 @@ Inductive retag_kind := FnEntry | Default.
Inductive bin_op :=
| AddOp (* + addition *)
| SubOp (* - subtraction *)
-(* | MulOp (* * multiplication *)
- | DivOp (* / division *)
- | RemOp (* % modulus *)
- | BitXorOp (* ^ bit xor *)
- | BitAndOp (* & bit and *)
- | BitOrOp (* | bit or *)
- | ShlOp (* << shift left *)
- | ShrOp (* >> shift right *) *)
| EqOp (* == equality *)
| LtOp (* < less than *)
| LeOp (* <= less than or equal to *)
-(* | NeOp (* != not equal to *)
- | GeOp (* >= greater than or equal to *)
- | GtOp (* > greater than *) *)
| OffsetOp (* . offset *)
.
@@ -307,18 +295,11 @@ Inductive expr :=
presenting the location that `e` points to.
The location has the kind and size of `ptr`. *)
| Ref (e : expr) (* Turn a place `e` into a pointer value. *)
-(* | Field (e: expr) (path: list nat)(* Create a place that points to a component
- of the place `e`. `path` defines the path
- through the type. *) *)
(* mem op *)
| Copy (e : expr) (* Read from the place `e` *)
| Write (e1 e2 : expr) (* Write the value `e2` to the place `e1` *)
| Alloc (sz : nat) (* Allocate a place of type `T` *)
| Free (e : expr) (* Free the place `e` *)
-(* atomic mem op *)
-(* | CAS (e0 e1 e2 : expr) *) (* CAS the value `e2` for `e1` to the place `e0` *)
-(* | AtomWrite (e1 e2: expr) *)
-(* | AtomRead (e: expr) *)
(* retag *) (* Retag the memory pointed to by `e1` with
retag kind `kind`, for call_id `e2`. The new pointer should have pointer kind pk. *)
| Retag (e1 : expr) (e2 : expr) (pk : pointer_kind) (im : interior_mut) (sz : nat) (kind : retag_kind)
@@ -330,8 +311,6 @@ Inductive expr :=
| Fork (e : expr)
(* While *)
| While (e1 e2 : expr)
-(* observable behavior *)
-(* | SysCall (id: nat) *)
.
Bind Scope expr_scope with expr.
@@ -356,15 +335,15 @@ Arguments While _%_E _%_E.
(** Closedness *)
Fixpoint is_closed (X : list string) (e : expr) : bool :=
match e with
- | Val _ | Place _ _ _ | Alloc _ | InitCall (* | SysCall _ *) => true
+ | Val _ | Place _ _ _ | Alloc _ | InitCall => true
| Var x => bool_decide (x ∈ X)
| BinOp _ e1 e2 | Write e1 e2 | While e1 e2
| Conc e1 e2 | Proj e1 e2 | Call e1 e2 | Retag e1 e2 _ _ _ _ => is_closed X e1 && is_closed X e2
| Let x e1 e2 => is_closed X e1 && is_closed (x :b: X) e2
| Case e el
=> is_closed X e && forallb (is_closed X) el
- | Fork e | Copy e | Deref e _ | Ref e (* | Field e _ *)
- | Free e | EndCall e (* | AtomRead e | Fork e *)
+ | Fork e | Copy e | Deref e _ | Ref e
+ | Free e | EndCall e
=> is_closed X e
end.
@@ -446,30 +425,11 @@ Qed.
(** Main state: a heap of scalars, each with an associated lock to detect data races. *)
Definition mem := gmap loc scalar.
-(** Internal events *)
-
-(* Per-allocation events.
- This is only useful during the proofs against the operational semantics:
- if we drop support for [disjoint.v] we should also delete this definition. *)
-Inductive bor_local_event :=
- | AccessBLEvt (kind : access_kind) (tg : tag) (range : Z * nat)
- | InitCallBLEvt (cid : call_id)
- | EndCallBLEvt (cid : call_id)
- | RetagBLEvt (tgp tg : tag) (pk : pointer_kind) (im : interior_mut) (c : call_id) (rk : retag_kind)
- | SilentBLEvt.
-
-(* Events in all their generality.
- We use the point of view adopted by Stacked Borrows and regarded by LLVM
- as acceptable which is to make FAILED READS NOT UB.
- A failed read has its own event [FailedCopyEvt] which returns poison
- instead of triggering immediate UB. This is assumed to be a sound change
- w.r.t. the semantics and is expected to allow proving more optimizations
- (they would still be true, but they wouldn't be *provable* with our means) *)
+(* Arbitrary borrow events. *)
Inductive event :=
| AllocEvt (alloc : block) (lbor : tag) (range : Z * nat)
| DeallocEvt (alloc : block) (lbor: tag) (range : Z * nat)
| CopyEvt (alloc : block) (lbor : tag) (range : Z * nat) (v : value)
-| FailedCopyEvt (alloc : block) (lbor : tag) (range : Z * nat)
| WriteEvt (alloc : block) (lbor : tag) (range : Z * nat) (v : value)
| InitCallEvt (c : call_id)
| EndCallEvt (c : call_id)
diff --git a/theories/tree_borrows/locations.v b/theories/tree_borrows/locations.v
index 1b91d57ce2075557fdf1dbe0a800ce21fd3d7881..c2feb5335b2ffd3f7ad7f971a37e195a028f9ef2 100755
--- a/theories/tree_borrows/locations.v
+++ b/theories/tree_borrows/locations.v
@@ -1,6 +1,6 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
+(** Internal representation of memory.
+ We opt for a view in which a location is composed of
+ an allocation id and an offset into that allocation. *)
From iris.prelude Require Import prelude.
From iris.prelude Require Import options.
diff --git a/theories/tree_borrows/logical_state.v b/theories/tree_borrows/logical_state.v
index 6ccfadcc1ca53f6b429a5cf29976a92051ed5d55..48e8848e018b6df2ee5d6a5a292d7f15d6c67e0c 100755
--- a/theories/tree_borrows/logical_state.v
+++ b/theories/tree_borrows/logical_state.v
@@ -393,13 +393,12 @@ Section heap_defs.
∧ ((item_lookup it l.2).(initialized) = PermInit → (item_lookup it l.2).(perm) ≠Disabled)
end.
- (* FIXME: merge the two tk_unq ? *)
+ (* FIXME: Refactor potential: merge the two tk_unq *)
Lemma bor_state_pre_unq_or l t tk σ : (tk = tk_unq tk_act ∨ tk = tk_unq tk_res) →
bor_state_pre l t tk σ = bor_state_pre_unq l t σ.
Proof. intros [-> | ->]; done. Qed.
- (* TODO: we still want that the children are disabled and the cousins are not active even when this tag is frozen !protected. So perhaps we need 2 case distinctions here? *)
Definition bor_state_post_unq (l : loc) (t : tag) (σ : state) it tr tkk:=
let P := ((item_lookup it l.2).(perm) = Frozen → protector_is_active it.(iprot) σ.(scs)) in
( P →
@@ -449,38 +448,6 @@ Section heap_defs.
Definition loc_controlled (l : loc) (t : tag) (tk : tag_kind) (sc : scalar) (σ : state) :=
(bor_state_pre l t tk σ → bor_state_own l t tk σ ∧ σ.(shp) !! l = Some sc).
-(* Lemma loc_controlled_local l t sc σ :
- loc_controlled l t tk_local sc σ →
- σ.(sst) !! l = Some [mkItem Unique (Tagged t) None] ∧
- σ.(shp) !! l = Some sc.
- Proof. intros Him. specialize (Him I) as (Hbor & Hmem). split;done. Qed.
-
- Lemma loc_controlled_unq l t sc s σ :
- loc_controlled l t tk_unq sc σ →
- σ.(sst) !! l = Some s →
- (∃ pm opro, mkItem pm (Tagged t) opro ∈ s ∧ pm ≠Disabled) →
- (∃ s' op, s = (mkItem Unique (Tagged t) op) :: s') ∧
- σ.(shp) !! l = Some sc.
- Proof.
- intros Him Hstk (pm & opro & Hpm).
- edestruct Him as (Hown & ?). { rewrite /bor_state_pre. eauto. }
- split; last done.
- destruct Hown as (st' & opro' & st'' & Hst' & ->). simplify_eq. eauto.
- Qed.
-
- Lemma loc_controlled_pub l t sc σ s :
- loc_controlled l t tk_pub sc σ →
- σ.(sst) !! l = Some s →
- (∃ pm opro, mkItem pm (Tagged t) opro ∈ s ∧ pm ≠Disabled) →
- t ∈ active_SRO s ∧
- σ.(shp) !! l = Some sc.
- Proof.
- intros Him Hst (pm & opro & Hin & Hpm).
- edestruct Him as (Hown & ?). { rewrite /bor_state_pre; eauto 8. }
- split; last done. destruct Hown as (st' & Hst' & Hsro).
- simplify_eq. eauto.
- Qed. *)
-
Lemma loc_controlled_mem_insert_ne l l' t tk sc sc' σ :
l ≠l' →
loc_controlled l t tk sc σ →
@@ -497,82 +464,6 @@ Section heap_defs.
intros Him Hpre. apply Him in Hpre as [Hown Hmem]. split; first done.
rewrite lookup_insert; done.
Qed.
-(*
- Section local.
- (** Facts about local tags *)
- Lemma loc_controlled_local_unique l t t' sc sc' σ :
- loc_controlled l t tk_local sc σ →
- loc_controlled l t' tk_local sc' σ →
- t' = t ∧ sc' = sc.
- Proof.
- intros Hcontrol Hcontrol'. specialize (Hcontrol I) as [Hown Hmem].
- specialize (Hcontrol' I) as [Hown' Hmem'].
- split; last by simplify_eq.
- move : Hown Hown'. rewrite /bor_state_own // => -> [=] //.
- Qed.
-
- Lemma loc_controlled_local_pre l t t' tk' sc σ :
- loc_controlled l t tk_local sc σ →
- bor_state_pre l t' tk' σ →
- tk' = tk_local ∨ t' = t.
- Proof.
- intros [Heq _]%loc_controlled_local.
- destruct tk'; last by eauto.
- - intros (st' & pm & opro & Hst & Hin & Hpm).
- move : Hst Hin. rewrite Heq.
- move => [= <-] /elem_of_list_singleton [=]; eauto.
- - intros (st' & pm & opro & Hst & Hin & Hpm).
- move : Hst Hin. rewrite Heq.
- move => [= <-] /elem_of_list_singleton [=]; eauto.
- Qed.
- Lemma bor_state_local_own_exclusive l t t' tk' σ :
- bor_state_own l t tk_local σ →
- bor_state_own l t' tk' σ →
- (tk' = tk_unq ∨ tk' = tk_local) ∧ t = t'.
- Proof.
- intros Heq. destruct tk'.
- - move => [st' []]. rewrite Heq => [= <-] //.
- - move => [st' [Heq' [opro [st'' ]]]]. move : Heq'. rewrite Heq => [= <-] [= ->] //; eauto.
- - rewrite /bor_state_own Heq => [=]; eauto.
- Qed.
- Lemma bor_state_unq_own_exclusive l t t' tk' σ :
- bor_state_own l t tk_unq σ →
- bor_state_own l t' tk' σ →
- (tk' = tk_unq ∨ tk' = tk_local) ∧ t = t'.
- Proof.
- intros (stk & Hstk & (opro & stk' & ->)).
- destruct tk'; simpl.
- - intros (stk'' & Hstk'' & Hact). rewrite Hstk in Hstk''. injection Hstk'' as [= <-].
- simpl in Hact. done.
- - intros (stk'' & Hstk'' & (opro' & stk''' & ->)).
- rewrite Hstk'' in Hstk. injection Hstk as [= -> -> ->]. eauto.
- - rewrite Hstk. intros [= -> -> ->]. eauto.
- Qed.
-
- (* having local ownership of a location is authoritative, in the sense that we can update memory without hurting other tags that control this location. *)
- Lemma loc_controlled_local_authoritative l t t' tk' sc sc' σ f :
- loc_controlled l t tk_local sc (state_upd_mem f σ) →
- loc_controlled l t' tk' sc' σ →
- t ≠t' →
- loc_controlled l t' tk' sc' (state_upd_mem f σ).
- Proof.
- intros Hcontrol Hcontrol' Hneq [Hown Hmem]%Hcontrol'. split; first done.
- edestruct (bor_state_local_own_exclusive l t t' tk' (state_upd_mem f σ)) as [_ <-]; [apply Hcontrol |..]; done.
- Qed.
-
- Lemma loc_controlled_protected_authoritative l t t' tk' sc sc' σ f c :
- loc_protected_by (state_upd_mem f σ) t l c →
- loc_controlled l t tk_unq sc (state_upd_mem f σ) →
- loc_controlled l t' tk' sc' σ →
- t ≠t' →
- loc_controlled l t' tk' sc' (state_upd_mem f σ).
- Proof.
- intros Hprot Hcontrol Hcontrol' Hneq [Hown Hmem]%Hcontrol'. split; first done.
- specialize (loc_protected_bor_state_pre _ _ _ _ tk_unq Hprot) as Hpre.
- apply Hcontrol in Hpre as [Hown' Hmem'].
- edestruct (bor_state_unq_own_exclusive l t t' tk' (state_upd_mem f σ)) as [_ <-]; done.
- Qed.
- End local. *)
(** Domain agreement for the two heap views for source and target *)
Definition dom_agree_on_tag (M_t M_s : gmap (tag * block) (gmap Z scalar)) (t : tag) :=
@@ -681,56 +572,6 @@ Section heap_defs.
+ eapply H3r. rewrite /heaplet_lookup HMo /= HH //.
Qed.
-(*
- Lemma dom_agree_on_tag_upd_ne_source M_t M_s t t' l sc :
- t ≠t' →
- dom_agree_on_tag M_t M_s t' →
- dom_agree_on_tag M_t (<[(t, l) := sc]> M_s) t'.
- Proof.
- intros Hneq [Htgt Hsrc]. split => l'' Hsome.
- - apply lookup_insert_is_Some. right. split; first congruence. by apply Htgt.
- - apply Hsrc. move : Hsome. rewrite lookup_insert_is_Some. by intros [[= -> <-] | [_ ?]].
- Qed.
- Lemma dom_agree_on_tag_upd_target M_t M_s t l sc :
- is_Some (M_t !! (t, l)) →
- dom_agree_on_tag M_t M_s t →
- dom_agree_on_tag (<[(t, l) := sc]> M_t) M_s t.
- Proof.
- intros Hs [Htgt Hsrc]. split => l''.
- - rewrite lookup_insert_is_Some. intros [[= <-] | [_ ?]]; by apply Htgt.
- - intros Hsome. rewrite lookup_insert_is_Some'. right; by apply Hsrc.
- Qed.
- Lemma dom_agree_on_tag_upd_source M_t M_s t l sc :
- is_Some (M_s !! (t, l)) →
- dom_agree_on_tag M_t M_s t →
- dom_agree_on_tag M_t (<[(t, l) := sc]> M_s) t.
- Proof.
- intros Hs [Htgt Hsrc]. split => l''.
- - intros Hsome. rewrite lookup_insert_is_Some'. right; by apply Htgt.
- - rewrite lookup_insert_is_Some. intros [[= <-] | [_ ?]]; by apply Hsrc.
- Qed.
- Lemma dom_agree_on_tag_lookup_target M_t M_s t l :
- dom_agree_on_tag M_t M_s t → is_Some (M_t !! (t, l)) → is_Some (M_s !! (t, l)).
- Proof. intros Hag Hsome. apply Hag, Hsome. Qed.
- Lemma dom_agree_on_tag_lookup_source M_t M_s t l :
- dom_agree_on_tag M_t M_s t → is_Some (M_s !! (t, l)) → is_Some (M_t !! (t, l)).
- Proof. intros Hag Hsome. apply Hag, Hsome. Qed.
-
- Lemma dom_agree_on_tag_difference M1_t M1_s M2_t M2_s t :
- dom_agree_on_tag M1_t M1_s t → dom_agree_on_tag M2_t M2_s t →
- dom_agree_on_tag (M1_t ∖ M2_t) (M1_s ∖ M2_s) t.
- Proof.
- intros [H1a H1b] [H2a H2b]. split; intros l.
- all: rewrite !lookup_difference_is_Some !eq_None_not_Some; naive_solver.
- Qed.
-
- Lemma dom_agree_on_tag_union M1_t M1_s M2_t M2_s t :
- dom_agree_on_tag M1_t M1_s t → dom_agree_on_tag M2_t M2_s t →
- dom_agree_on_tag (M1_t ∪ M2_t) (M1_s ∪ M2_s) t.
- Proof.
- intros [H1a H1b] [H2a H2b]. split; intros l; rewrite !lookup_union_is_Some; naive_solver.
- Qed. *)
-
Definition dom_unique_per_tag (M : gmap (tag * block) (gmap Z scalar)) : Prop :=
∀ tg l1 l2, (tg, l1) ∈ dom M → (tg, l2) ∈ dom M → l1 = l2.
@@ -757,12 +598,6 @@ Definition tk_to_frac (tk : tag_kind) :=
| tk_pub => DfracDiscarded
| _ => DfracOwn 1
end.
-(*
-Notation "l '↦t[' tk ']{' t } sc" := (ghost_map_elem heap_view_target_name (t, l) (tk_to_frac tk) sc)
- (at level 20, format "l ↦t[ tk ]{ t } sc") : bi_scope.
-Notation "l '↦s[' tk ']{' t } sc" := (ghost_map_elem heap_view_source_name (t, l) (tk_to_frac tk) sc)
- (at level 20, format "l ↦s[ tk ]{ t } sc") : bi_scope.
-*)
Section public_call_ids.
Context `{bor_stateGS Σ}.
@@ -1385,124 +1220,6 @@ Proof.
rewrite IH. 2: lia. f_equal. f_equal. lia.
Qed.
-
-
-(*
-
-Lemma array_tag_map_lookup1 l t v t' l' r :
- array_tag_map l t v !! (t', l') = Some r →
- t' = t ∧ l.1 = l'.1 ∧ l.2 ≤ l'.2 < l.2 + length v.
-Proof.
- induction v as [ | sc v IH] in l,r |-*.
- - simpl. rewrite lookup_empty. intros [=].
- - simpl. rewrite lookup_insert_Some. move => [[[= <- <-] Heq] | [Hneq Ht]].
- + split; first done. lia.
- + move : (IH (l +â‚— 1) ltac:(eauto) ltac:(eauto)). destruct l. simpl. intros (H1&H2); split; first done; lia.
-Qed.
-Lemma array_tag_map_lookup1_is_Some l t v t' l' :
- is_Some (array_tag_map l t v !! (t', l')) →
- t' = t ∧ l.1 = l'.1 ∧ l.2 ≤ l'.2 < l.2 + length v.
-Proof.
- intros [x Hx]. by eapply array_tag_map_lookup1.
-Qed.
-
-Lemma array_tag_map_lookup2 l t v t' l' :
- is_Some (array_tag_map l t v !! (t', l')) →
- t' = t ∧ ∃ i, (i < length v)%nat ∧ l' = l +ₗ i.
-Proof.
- intros [x (-> & H1 & H2)%array_tag_map_lookup1].
- split; first done. exists (Z.to_nat (l'.2 - l.2)).
- destruct l, l'; rewrite /shift_loc; simpl in *. split.
- - lia.
- - apply pair_equal_spec. split; lia.
-Qed.
-
-Lemma array_tag_map_lookup_Some l t v (i : nat) :
- (i < length v)%nat →
- array_tag_map l t v !! (t, l +â‚— i) = v !! i.
-Proof.
- induction v as [ | sc v IH] in l, i |-*.
- - simpl. lia.
- - simpl. intros Hi. destruct i as [ | i].
- + rewrite shift_loc_0_nat. rewrite lookup_insert. done.
- + rewrite lookup_insert_ne; first last. { destruct l; simpl; intros [= ?]; lia. }
- move : (IH (l +â‚— 1) i ltac:(lia)). rewrite shift_loc_assoc.
- by replace (Z.of_nat (S i)) with (1 + i) by lia.
-Qed.
-
-Lemma array_tag_map_lookup_None t t' l v :
- t ≠t' → ∀ l', array_tag_map l t v !! (t', l') = None.
-Proof.
- intros Hneq l'. destruct (array_tag_map l t v !! (t', l')) eqn:Harr; last done.
- specialize (array_tag_map_lookup1 l t v t' l' ltac:(eauto) ltac:(eauto)) as [Heq _]; congruence.
-Qed.
-
-Lemma array_tag_map_lookup_None' l t v l' :
- (∀ i:nat, (i < length v)%nat → l +ₗ i ≠l') →
- array_tag_map l t v !! (t, l') = None.
-Proof.
- intros Hneq. destruct (array_tag_map _ _ _ !! _) eqn:Heq; last done. exfalso.
- specialize (array_tag_map_lookup2 l t v t l' ltac:(eauto)) as [_ (i & Hi & ->)].
- eapply Hneq; last reflexivity. done.
-Qed.
-
-Lemma array_tag_map_lookup_None2 l t t' v l' :
- array_tag_map l t v !! (t', l') = None →
- t ≠t' ∨ (∀ i: nat, (i < length v)%nat → l +ₗ i ≠l').
-Proof.
- induction v as [ | sc v IH] in l |-*; simpl.
- - intros _. right. intros i Hi; lia.
- - rewrite lookup_insert_None. intros [Ha%IH Hneq].
- destruct Ha; first by eauto. move: Hneq. rewrite pair_equal_spec not_and_l.
- intros [ ? | Hneq]; first by eauto.
- right. intros i Hi. destruct i as [ | i].
- + rewrite shift_loc_0_nat. done.
- + replace (Z.of_nat (S i)) with (1 + i)%Z by lia. rewrite -shift_loc_assoc.
- eauto with lia.
-Qed.
-
-Lemma dom_agree_on_tag_array_tag_map l t v_t v_s :
- length v_t = length v_s →
- dom_agree_on_tag (array_tag_map l t v_t) (array_tag_map l t v_s) t.
-Proof.
- intros Hlen. split; intros l'.
- - intros (_ & (i & Hi & ->))%array_tag_map_lookup2. rewrite array_tag_map_lookup_Some; last lia.
- apply lookup_lt_is_Some_2. lia.
- - intros (_ & (i & Hi & ->))%array_tag_map_lookup2. rewrite array_tag_map_lookup_Some; last lia.
- apply lookup_lt_is_Some_2. lia.
-Qed.
-
-(** Array update lemmas for the heap views *)
-Lemma ghost_map_array_tag_lookup `{!bor_stateGS Σ} (γh : gname) (q : Qp) (M : gmap (tag * block) (gmap Z scalar)) (v : list scalar) (t : tag) (l : loc) dq :
- ghost_map_auth γh q M -∗
- ([∗ list] i ↦ sc ∈ v, ghost_map_elem γh (t, l +ₗ i) dq sc) -∗
- ⌜∀ i : nat, (i < length v)%nat → M !! (t, l +â‚— i) = v !! iâŒ.
-Proof.
- iIntros "Hauth Helem". iInduction v as [ |sc v ] "IH" forall (l) "Hauth Helem".
- - iPureIntro; cbn. lia.
- - rewrite big_sepL_cons. iDestruct "Helem" as "[Hsc Hscs]".
- iPoseProof (ghost_map_lookup with "Hauth Hsc") as "%Hl".
- iDestruct ("IH" $! (l +â‚— 1) with "Hauth [Hscs]") as "%IH".
- { iApply (big_sepL_mono with "Hscs"). intros i sc' Hs. cbn. rewrite shift_loc_assoc.
- replace (Z.of_nat $ S i) with (1 + i)%Z by lia. done. }
- iPureIntro. intros i Hle. destruct i as [|i]; first done.
- replace (Z.of_nat $ S i) with (1 + i)%Z by lia. cbn in *. rewrite -(IH i); last lia.
- by rewrite shift_loc_assoc.
-Qed.
-
-Lemma array_tag_map_union_commute (l : loc) (sc : scalar) (t : tag) (v : list scalar) (M : gmap (tag * block) (gmap Z scalar)) (i : Z) :
- i > 0 →
- <[(t, l) := sc]> (array_tag_map (l +ₗ i) t v) ∪ M = array_tag_map (l +ₗ i) t v ∪ (<[(t, l) := sc]> M).
-Proof.
- intros Hi. induction v as [ | sc' v IH] in l, i, Hi |-*; simpl.
- - rewrite insert_union_singleton_l. rewrite -map_union_assoc. rewrite !map_empty_union.
- by rewrite insert_union_singleton_l.
- - rewrite insert_commute. 2: { intros [= Heq]. destruct l; simpl in *. injection Heq. lia. }
- rewrite shift_loc_assoc. rewrite -insert_union_l. rewrite (IH l (i + 1)%Z); last lia.
- rewrite -insert_union_l. done.
-Qed.
-*)
-
Lemma ghost_map_array_tag_update `{!bor_stateGS Σ} (γh : gname) (M : gmap (tag * block) (gmap Z scalar)) (v v' : list scalar) (t : tag) (l : loc) :
length v = length v' →
ghost_map_auth γh 1 M -∗
@@ -1529,66 +1246,6 @@ Proof.
all: by iFrame.
Qed.
-(*
-Lemma ghost_map_array_tag_insert `{!bor_stateGS Σ} (γh : gname) (M : gmap (tag * block) (gmap Z scalar)) (v : list scalar) (t : tag) (l : loc) :
- (∀ i : nat, (i < length v)%nat → M !! (t, l +ₗ i) = None) →
- ghost_map_auth γh 1 M ==∗
- ([∗ list] i ↦ sc ∈ v, ghost_map_elem γh (t, l +ₗ i) (DfracOwn 1) sc) ∗
- ghost_map_auth γh 1 (array_tag_map l t v ∪ M).
-Proof.
- iIntros (Hnone) "Hauth". iInduction v as [ | sc v ] "IH" forall (M l Hnone) "Hauth".
- - rewrite big_sepL_nil. iModIntro. rewrite map_empty_union. iFrame.
- - rewrite big_sepL_cons.
- iMod ("IH" $! M (l +â‚— 1) with "[] Hauth") as "[Helems Hauth]".
- { iPureIntro. intros i Hi. rewrite shift_loc_assoc. replace (1 + i)%Z with (Z.of_nat (S i)) by lia. apply Hnone.
- simpl; lia.
- }
- iMod (ghost_map_insert (t, l +â‚— 0%nat) sc with "Hauth") as "[Hauth Helem]".
- { rewrite lookup_union_None; split.
- - apply array_tag_map_lookup_None'. intros i Hi. destruct l; intros [= ?]. lia.
- - apply Hnone. simpl; lia.
- }
- iModIntro. iFrame "Helem". rewrite shift_loc_0_nat. simpl. rewrite insert_union_l. iFrame "Hauth".
- iApply (big_sepL_mono with "Helems"). intros i sc'' Hs. cbn. rewrite shift_loc_assoc.
- replace (Z.of_nat $ S i) with (1 + i)%Z by lia. done.
-Qed.
-
-Lemma ghost_map_array_tag_delete `{!bor_stateGS Σ} (γh : gname) (M : gmap (tag * block) (gmap Z scalar)) (v : list scalar) (t : tag) (l : loc) :
- ghost_map_auth γh 1 M -∗
- ([∗ list] i ↦ sc ∈ v, ghost_map_elem γh (t, l +ₗ i) (DfracOwn 1) sc) ==∗
- ghost_map_auth γh 1 (M ∖ array_tag_map l t v).
-Proof.
- iIntros "Hauth Helems".
- iApply (ghost_map_delete_big (array_tag_map l t v) with "Hauth [Helems]").
- iInduction v as [ | sc v] "IH" forall (l); first done.
- simpl. iApply big_sepM_insert.
- { destruct (_ !! _) eqn:Heq; last done.
- specialize (array_tag_map_lookup2 (l +â‚— 1) t v t l ltac:(eauto)) as [_ (i & _ & Hl)].
- destruct l. injection Hl. lia.
- }
- rewrite shift_loc_0_nat. iDestruct "Helems" as "[$ Helems]".
- iApply "IH". iApply (big_sepL_mono with "Helems").
- iIntros (i sc' Hi). simpl.
- rewrite shift_loc_assoc. replace (Z.of_nat (S i)) with (1 + i) by lia; done.
-Qed.
-
-Lemma ghost_map_array_tag_tk `{!bor_stateGS Σ} (γh : gname) (v : list scalar) (t : tag) (l : loc) tk :
- ([∗ list] i ↦ sc ∈ v, ghost_map_elem γh (t, l +ₗ i) (DfracOwn 1) sc) ==∗
- ([∗ list] i ↦ sc ∈ v, ghost_map_elem γh (t, l +ₗ i) (tk_to_frac tk) sc).
-Proof.
- destruct tk; cbn; [ | by eauto ..].
- iInduction v as [| sc v] "IH" forall (l); first by eauto.
- rewrite !big_sepL_cons. iIntros "[Hh Hr]".
- iMod (ghost_map_elem_persist with "Hh") as "$".
- iMod ("IH" $! (l +â‚— 1) with "[Hr]") as "Hr".
- - iApply (big_sepL_mono with "Hr"). intros i sc' Hs. simpl. rewrite shift_loc_assoc.
- by replace (Z.of_nat (S i)) with (1 + i) by lia.
- - iModIntro.
- iApply (big_sepL_mono with "Hr"). intros i sc' Hs. simpl. rewrite shift_loc_assoc.
- by replace (Z.of_nat (S i)) with (1 + i) by lia.
-Qed.
-*)
-
Section val_rel.
Context `{bor_stateGS Σ}.
(** Value relation *)
@@ -1601,7 +1258,7 @@ Section val_rel.
(* through [state_rel]:
* the stacks are the same,
* the allocation size is the same,
- * and the locations are related (i.e.: public) TODO: previously, scalars could be untagged. this no longer works.
+ * and the locations are related (i.e.: public)
*)
⌜l1 = l2⌠∗ ⌜p1 = p2⌠∗ p1 $$ tk_pub
| ScCallId c, ScCallId c' => ⌜c = c'⌠∗ pub_cid c
@@ -1799,8 +1456,8 @@ Section val_rel.
rewrite /value_rel. iApply (big_sepL2_app with "Hv1 Hv2").
Qed.
- Definition will_read_in_simulation v_src v_tgt l_rd t : iProp Σ :=
- value_rel v_tgt v_src ∨ (⌜length v_src = length v_tgt⌠∗ ispoison (replicate (length v_tgt) ScPoison) l_rd t (length v_tgt)).
+ Definition will_read_in_simulation v_src v_tgt (l_rd : loc) (t : tag) : iProp Σ :=
+ value_rel v_tgt v_src(* ∨ (⌜length v_src = length v_tgt⌠∗ ispoison (replicate (length v_tgt) ScPoison) l_rd t (length v_tgt))*).
End val_rel.
diff --git a/theories/tree_borrows/notation.v b/theories/tree_borrows/notation.v
index f46cea9598ebaca799011c55d43ae693632ed32a..d3bb1ec740cb20e421bdc10945651a5e10a48cc9 100755
--- a/theories/tree_borrows/notation.v
+++ b/theories/tree_borrows/notation.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From iris.prelude Require Import prelude options.
From simuliris.tree_borrows Require Export lang_base.
From iris.prelude Require Import options.
@@ -89,8 +85,6 @@ Notation "'let:' x := e1 'in' e2" := (Let x%binder e1%E e2%E)
Notation "e1 ;; e2" := (let: <> := e1 in e2)%R
(at level 100, e2 at level 200, format "e1 ;; e2") : result_scope.
-(*Notation "fun: xl , e" := (FunV xl%binder e%E)*)
- (*(at level 102, xl at level 1, e at level 200).*)
Ltac solve_closed :=
match goal with
diff --git a/theories/tree_borrows/read_read_reorder/README.md b/theories/tree_borrows/read_read_reorder/README.md
new file mode 100644
index 0000000000000000000000000000000000000000..39f1b8bea5fe519815c2e760c3e3a1e4bc261511
--- /dev/null
+++ b/theories/tree_borrows/read_read_reorder/README.md
@@ -0,0 +1,32 @@
+# Tree Borrows -- Read-read reorderings
+
+Example 18 focuses on the reordering of adjacent reads.
+We claim that Tree Borrows allows reordering of any two adjacent read accesses.
+The correctness of this optimization is trivial w.r.t. the state of the heap,
+but not so much w.r.t. the state of the trees of borrows.
+In fact this optimization is incorrect in Stacked Borrows!
+
+Our general framework is not at the moment capable of proving these optimizations because
+they require one of
+- absence of concurrency, or
+- ability to reason about data races.
+The latter has been demonstrated to be *possible* in simuliris (see `theories/simulang`),
+but combining this with Tree Borrows is outside of our current scope.
+Instead we opt for the former: this subdirectory has only sequential semantics,
+no concurrency.
+
+The main theorem for this proof is `read_reorder` in `read_reorder.v`,
+which states that the two example programs given that differ in the ordering
+of two reads are equivalent according to the notion defined in `equivalence_def.v`.
+In addition the intermediate lemmas in `low_level.v` should give confidence
+that this reordering is indeed a more general property of the model and not
+merely applicable to only this simple example.
+
+## Files
+
+In addition to the regular definitions of TB that are in the parent directory,
+this proof is subdivided into
+ * `equivalence_def.v`: definition of a simple notion of program equivalence for a sequential setting.
+ * `low_level.v`: lemmas against the operational semantics.
+ * `read_reorder.v`: actual proof of equivalence between two programs in which adjacent reads have been swapped. (Example 18)
+
diff --git a/theories/tree_borrows/read_read_reorder/equivalence_def.v b/theories/tree_borrows/read_read_reorder/equivalence_def.v
new file mode 100644
index 0000000000000000000000000000000000000000..4c3260d936355956bcc6214517418092325d9579
--- /dev/null
+++ b/theories/tree_borrows/read_read_reorder/equivalence_def.v
@@ -0,0 +1,36 @@
+From iris.prelude Require Import prelude options.
+From stdpp Require Export gmap.
+From simuliris.tree_borrows Require Import defs lang_base lang notation bor_semantics tree tactics class_instances.
+From simuliris.tree_borrows.read_read_reorder Require Import low_level.
+From iris.prelude Require Import options.
+
+(* [nsteps ... n] says that one can transition from one state to the other in exactly [n]
+primitive steps. *)
+(* This is similar to stdpp's [nsteps], except that this one computes more nicely for fixed [n]. *)
+Fixpoint nsteps P (e : expr) σ e'' σ'' n : Prop := match n with
+ 0 => e = e'' ∧ σ = σ''
+| S n => ∃ e' σ', prim_step P e σ e' σ' nil ∧ nsteps P e' σ' e'' σ'' n end.
+
+(* This says that after n steps, any state reachable in from e_1 in σ must be reachable from e_2 in σ.
+ This is just a helper definition used for [eventually_equal]; on its own it is not very meaningful. *)
+Definition identical_states_after P e1 e2 σ n :=
+ ∀ e' σ', nsteps P e1 σ e' σ' n → nsteps P e2 σ e' σ' n.
+
+(* This says that the program will not terminate within a number of steps.
+ It can, in that time, only make progress or have UB *)
+Inductive no_termination_within P : expr → state → nat → Prop :=
+ | no_steps_left e σ : no_termination_within P e σ 0
+ | no_termination_now e σ n :
+ to_result e = None →
+ (∀ e' σ', prim_step P e σ e' σ' nil → no_termination_within P e' σ' n) →
+ no_termination_within P e σ (S n).
+
+(* Two programs are eventually equal if there exists an n such that they
+ both do not terminate with n steps,
+ and after n steps, they are equal. *)
+Definition eventually_equal P e1 e2 :=
+ ∃ n, ∀ σ, state_wf σ →
+ no_termination_within P e1 σ n ∧
+ no_termination_within P e2 σ n ∧
+ identical_states_after P e1 e2 σ n ∧
+ identical_states_after P e2 e1 σ n.
diff --git a/theories/tree_borrows/read_read_reorder/low_level.v b/theories/tree_borrows/read_read_reorder/low_level.v
new file mode 100644
index 0000000000000000000000000000000000000000..3406e20301ab63bff80a75169a209ab45975414c
--- /dev/null
+++ b/theories/tree_borrows/read_read_reorder/low_level.v
@@ -0,0 +1,892 @@
+(** This file proves some simple reorderings directly against the operational semantics
+ in sequential code.
+
+ For example we prove here the fact that in any context, two adjacent read
+ accesses can be swapped and the resulting state is identical to the initial state.
+ Because these proofs use a different definition of bor_step and do not involve
+ parallelism, the lemmas established here are *definitely not useful* for the rest
+ of the project.
+
+ Results proven here:
+ * any pair of adjacent reads can be swapped to obtain an identical final state.
+ *)
+From iris.prelude Require Import prelude options.
+From stdpp Require Export gmap.
+From simuliris.tree_borrows Require Import lang_base notation bor_semantics tree tree_lemmas bor_lemmas steps_preserve defs.
+From iris.prelude Require Import options.
+
+Definition commutes {X}
+ (fn1 fn2 : X -> option X)
+ := forall x0 x1 x2,
+ fn1 x0 = Some x1 ->
+ fn2 x1 = Some x2 ->
+ exists x1', (
+ fn2 x0 = Some x1'
+ /\ fn1 x1' = Some x2
+ ).
+
+Definition commutes_option {X}
+ (fn1 fn2 : option X -> option X)
+ := forall x0 x1 x2,
+ fn1 x0 = Some x1 ->
+ fn2 (Some x1) = Some x2 ->
+ exists x1', (
+ fn2 x0 = Some x1'
+ /\ fn1 (Some x1') = Some x2
+ ).
+
+Definition persistent_if {X} (P : X -> Prop)
+ (fn1 fn2 : X -> option X)
+ := forall x x1 x2,
+ P x ->
+ fn1 x = Some x1 ->
+ fn2 x = Some x2 ->
+ exists x', fn2 x1 = Some x'.
+
+Definition persistent_if_option {X} (P : option X -> Prop)
+ (fn1 fn2 : option X -> option X)
+ := forall x x1 x2,
+ P x ->
+ fn1 x = Some x1 ->
+ fn2 x = Some x2 ->
+ exists x', fn2 (Some x1) = Some x'.
+
+Lemma apply_access_perm_read_commutes
+ {rel1 rel2 prot}
+ : commutes
+ (apply_access_perm AccessRead rel1 prot)
+ (apply_access_perm AccessRead rel2 prot).
+Proof.
+ move=> p0 p1 p2 Step01 Step12.
+ unfold apply_access_perm in *.
+ all: destruct p0 as [[] [[]| | | | ]].
+ all: destruct prot; simpl in *.
+ all: destruct rel1; simpl in *.
+ all: try (inversion Step01; done).
+ all: injection Step01; intros; subst.
+ all: simpl.
+ all: destruct rel2; simpl in *.
+ all: try (inversion Step12; done).
+ all: injection Step12; intros; subst; simpl.
+ all: try (eexists; split; [reflexivity|]); simpl.
+ all: reflexivity.
+Qed.
+
+Lemma apply_access_perm_read_persistent
+ {rel1 rel2 prot}
+ : persistent_if lazy_perm_wf
+ (apply_access_perm AccessRead rel1 prot)
+ (apply_access_perm AccessRead rel2 prot).
+Proof.
+ move=> p0 p1 p2 wf Step01 Step12.
+ unfold apply_access_perm in *.
+ all: destruct p0 as [[] [[]| | | | ]].
+ all: destruct prot; simpl in *.
+ all: destruct rel1; simpl in *.
+ all: try (inversion Step01; done).
+ all: injection Step01; intros; subst.
+ all: simpl.
+ all: destruct rel2; simpl in *.
+ all: try (inversion Step12; done).
+ all: injection Step12; intros; subst; simpl.
+ all: try (eexists; reflexivity).
+ (* Only the non-wf cases remain *)
+ - rewrite /lazy_perm_wf in wf; simpl in *. exfalso.
+ specialize (wf ltac:(auto)). discriminate.
+ - rewrite /lazy_perm_wf in wf; simpl in *. exfalso.
+ specialize (wf ltac:(auto)). discriminate.
+Qed.
+
+Lemma mem_apply_loc_insert_ne
+ {X} {fn : option X -> option X} {z mem mem' z0}
+ (NE : ~z = z0)
+ (Success : mem_apply_loc fn z mem = Some mem')
+ v0
+ : mem_apply_loc fn z (<[z0:=v0]>mem) = Some (<[z0:=v0]>mem').
+Proof.
+ unfold mem_apply_loc in Success |- *; simpl in *.
+ rewrite lookup_insert_ne; [|auto].
+ destruct (option_bind_success_step _ _ _ Success) as [v [fnv mem'_spec]].
+ injection mem'_spec; intros; subst.
+ rewrite fnv; simpl.
+ f_equal.
+ rewrite insert_commute; auto.
+Qed.
+
+Lemma mem_apply_range'_insert_outside
+ {X} {fn : option X -> option X} {z sz mem mem' z0}
+ (OUT : ~range'_contains (z, sz) z0)
+ (Success : mem_apply_locs fn z sz mem = Some mem')
+ v0
+ : mem_apply_locs fn z sz (<[z0:=v0]>mem) = Some (<[z0:=v0]>mem').
+Proof.
+ unfold mem_apply_range' in *; simpl in *.
+ generalize dependent z.
+ generalize dependent mem.
+ generalize dependent mem'.
+ induction sz as [|sz IHsz]; move=> mem' mem z OUT Success.
+ - injection Success; intros; subst.
+ reflexivity.
+ - destruct (proj1 (bind_Some _ _ _) Success) as [mem'' [SuccessStep SuccessRest]].
+ simpl.
+ erewrite mem_apply_loc_insert_ne; [| |eassumption].
+ 2: { unfold range'_contains in OUT |- *; simpl in *; lia. }
+ simpl.
+ apply IHsz.
+ + unfold range'_contains in OUT |- *; simpl in *; lia.
+ + exact SuccessRest.
+Qed.
+
+Lemma mem_apply_range'_success_condition
+ {X} {fn : option X -> option X} {range mem}
+ (ALL_SOME : forall z, range'_contains range z -> is_Some (fn (mem !! z)))
+ : exists mem', mem_apply_range' fn range mem = Some mem'.
+Proof.
+ unfold mem_apply_range'.
+ destruct range as [z sz]; simpl.
+ generalize dependent z.
+ induction sz as [|sz IHsz]; move=> z ALL_SOME.
+ - eexists. simpl. reflexivity.
+ - destruct (IHsz (z + 1)%Z
+ ltac:(intros mem' H; apply ALL_SOME; unfold range'_contains; unfold range'_contains in H; simpl; simpl in H; lia))
+ as [sub' Specsub'].
+ destruct (ALL_SOME z ltac:(unfold range'_contains; simpl; lia)) as [fnz Specfnz].
+ eexists (<[z:=fnz]>sub'); simpl.
+ unfold mem_apply_loc.
+ rewrite Specfnz; simpl.
+ erewrite mem_apply_range'_insert_outside; [reflexivity| |assumption].
+ unfold range'_contains; simpl; lia.
+Qed.
+
+Lemma mem_apply_range'_success_specification
+ {X} {fn : option X -> option X} {range mem mem'}
+ (ALL_SOME : forall z, range'_contains range z -> exists x', fn (mem !! z) = Some x' /\ mem' !! z = Some x')
+ (REST_SAME : forall z, ~range'_contains range z -> mem !! z = mem' !! z)
+ : mem_apply_range' fn range mem = Some mem'.
+Proof.
+ assert (forall z, range'_contains range z -> is_Some (fn (mem !! z))) as ALL_SOME_weaker. {
+ intros z R; destruct (ALL_SOME z R) as [?[??]]; auto.
+ }
+ destruct (mem_apply_range'_success_condition ALL_SOME_weaker) as [mem'' Spec''].
+ rewrite Spec''; f_equal; apply map_eq.
+ intro z.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Spec'') as Spec.
+ destruct (decide (range'_contains range z)) as [R|nR].
+ - destruct Spec as [v[vSpec fnvSpec]].
+ destruct (ALL_SOME z R) as [v' [fnv'Spec v'Spec]].
+ rewrite v'Spec.
+ rewrite vSpec.
+ rewrite <- fnv'Spec.
+ rewrite <- fnvSpec.
+ reflexivity.
+ - rewrite <- (REST_SAME z nR).
+ assumption.
+Qed.
+
+Lemma range_foreach_commutes
+ {X}
+ range1 range2
+ (fn1 fn2 : option X -> option X)
+ (FnCommutes : commutes_option fn1 fn2)
+ : commutes
+ (mem_apply_range' fn1 range1)
+ (mem_apply_range' fn2 range2).
+Proof.
+ intros mem0 mem1 mem2 Success01 Success12.
+ assert (forall z, range'_contains range2 z -> exists x1', fn2 (mem0 !! z) = Some x1') as fn2mem0. {
+ intros z R2.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
+ destruct (decide (range'_contains range1 z)).
+ - destruct Spec01 as [fn1z0 [z1Spec fn1z0Spec]].
+ rewrite decide_True in Spec12; [|assumption].
+ destruct Spec12 as [fn2z1 [z2Spec fn2z1Spec]].
+ rewrite z1Spec in fn2z1Spec.
+ destruct (FnCommutes _ _ _ fn1z0Spec fn2z1Spec) as [x1' [fn2z0Spec fn1x1'Spec]].
+ exists x1'; assumption.
+ - rewrite decide_True in Spec12; [|assumption].
+ destruct Spec12 as [x2 [x2Spec fn2x1Spec]].
+ exists x2; rewrite <- Spec01; assumption.
+ }
+ destruct (mem_apply_range'_success_condition fn2mem0) as [mem1' Success01'].
+ exists mem1'.
+ split; [assumption|].
+ apply mem_apply_range'_success_specification.
+ - intros z R1.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success01') as Spec01'.
+ destruct (decide (range'_contains range2 z)).
+ + rewrite decide_True in Spec01; [|assumption].
+ destruct Spec01 as [fn1z0 [z1Spec fn1z0Spec]].
+ destruct Spec12 as [fn2z1 [z2Spec fn2z1Spec]].
+ destruct Spec01' as [fn2z0 [z1'Spec fn2z0Spec]].
+ rewrite z1Spec in fn2z1Spec.
+ destruct (FnCommutes _ _ _ fn1z0Spec fn2z1Spec) as [x2' [fn2z0'Spec fn1x2'Spec]].
+ rewrite z1'Spec.
+ rewrite <- fn2z0Spec.
+ exists fn2z1.
+ split; [|assumption].
+ destruct (FnCommutes _ _ _ fn1z0Spec fn2z1Spec) as [x1' [fn2z0Spec' fn1x1'Spec]].
+ rewrite fn2z0Spec'.
+ rewrite fn1x1'Spec.
+ reflexivity.
+ + rewrite decide_True in Spec01; [|assumption].
+ destruct Spec01 as [fn1z0 [z1Spec fn1z0Spec]].
+ rewrite Spec01'.
+ rewrite Spec12.
+ exists fn1z0; split; assumption.
+ - intros z nR1.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success01') as Spec01'.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
+ destruct (decide (range'_contains range2 z)).
+ + rewrite decide_False in Spec01; [|assumption].
+ destruct Spec01' as [fn2z0 [z1'Spec fn2z0Spec]].
+ destruct Spec12 as [fn2z1 [z2Spec fn2z1Spec]].
+ rewrite z1'Spec.
+ rewrite <- fn2z0Spec.
+ rewrite <- Spec01.
+ rewrite fn2z1Spec.
+ rewrite z2Spec.
+ reflexivity.
+ + rewrite decide_False in Spec01; [|assumption].
+ rewrite Spec01'.
+ rewrite <- Spec01.
+ rewrite Spec12.
+ reflexivity.
+Qed.
+
+Definition if_some_then {X} (P : X -> Prop) o :=
+ match o with
+ | None => True
+ | Some x => P x
+ end.
+
+Lemma range_foreach_persistent
+ {X}
+ P
+ range1 range2
+ (fn1 fn2 : option X -> option X)
+ (FnCommutes : persistent_if_option (if_some_then P) fn1 fn2)
+ : persistent_if (fun m => forall i, if_some_then P (m !! i))
+ (mem_apply_range' fn1 range1)
+ (mem_apply_range' fn2 range2).
+Proof.
+ intros mem0 mem1 mem2 Wf Success01 Success12.
+ assert (forall z, range'_contains range2 z -> exists x', fn2 (mem1 !! z) = Some x') as fn2mem1. {
+ intros z R2.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success01) as Spec01.
+ pose proof (mem_apply_range'_spec _ _ z _ _ Success12) as Spec12.
+ destruct (decide (range'_contains range1 z)).
+ - destruct Spec01 as [fn1z0 [z1Spec fn1z0Spec]].
+ rewrite decide_True in Spec12; [|assumption].
+ pose proof (Wf z) as wfz.
+ destruct Spec12 as [fn2z1 [z2Spec fn2z1Spec]].
+ destruct (FnCommutes _ _ _ wfz fn1z0Spec fn2z1Spec) as [x1' fn2z0Spec].
+ exists x1'; rewrite z1Spec; assumption.
+ - rewrite decide_True in Spec12; [|assumption].
+ destruct Spec12 as [x2 [x2Spec fn2x1Spec]].
+ exists x2; rewrite Spec01; assumption.
+ }
+ destruct (mem_apply_range'_success_condition fn2mem1) as [mem1' Success01'].
+ exists mem1'. assumption.
+Qed.
+
+Lemma commutes_option_build
+ {X} {dflt : X} {fn1 fn2}
+ (Commutes : commutes fn1 fn2)
+ : commutes_option
+ (fun ox => fn1 (default dflt ox))
+ (fun ox => fn2 (default dflt ox)).
+Proof.
+ intros x0 x1 x2 Step01 Step12.
+ destruct (Commutes (default dflt x0) _ _ Step01 Step12) as [?[??]].
+ eexists; eauto.
+Qed.
+
+Lemma persistent_if_option_build
+ {X} {dflt : X} P {fn1 fn2}
+ (Commutes : persistent_if P fn1 fn2)
+ (Base : P dflt)
+ : persistent_if_option (if_some_then P)
+ (fun ox => fn1 (default dflt ox))
+ (fun ox => fn2 (default dflt ox)).
+Proof.
+ intros x0 x1 x2 Pre Step01 Step12.
+ destruct x0; simpl in *.
+ - destruct (Commutes _ _ _ Pre Step01 Step12) as [? ?].
+ eexists; eassumption.
+ - destruct (Commutes _ _ _ Base Step01 Step12) as [? ?].
+ eexists; eassumption.
+Qed.
+
+Lemma permissions_foreach_commutes
+ range1 range2
+ (fn1 fn2 : lazy_permission -> option lazy_permission)
+ dflt
+ (FnCommutes : commutes fn1 fn2)
+ : commutes
+ (permissions_apply_range' dflt range1 fn1)
+ (permissions_apply_range' dflt range2 fn2).
+Proof.
+ apply range_foreach_commutes.
+ apply commutes_option_build.
+ assumption.
+Qed.
+
+Lemma permissions_foreach_persistent
+ P
+ range1 range2
+ (fn1 fn2 : lazy_permission -> option lazy_permission)
+ dflt
+ (FnCommutes : persistent_if P fn1 fn2)
+ (Base : P dflt)
+ : persistent_if (fun m => forall i, if_some_then P (m !! i))
+ (permissions_apply_range' dflt range1 fn1)
+ (permissions_apply_range' dflt range2 fn2).
+Proof.
+ apply range_foreach_persistent.
+ apply persistent_if_option_build.
+ - assumption.
+ - assumption.
+Qed.
+
+Lemma item_apply_access_read_commutes
+ {cids rel1 rel2 range1 fn1 fn2 range2}
+ (FnCommutes : forall isprot,
+ commutes
+ (fn1 rel1 isprot)
+ (fn2 rel2 isprot))
+ : commutes
+ (item_apply_access fn1 cids rel1 range1)
+ (item_apply_access fn2 cids rel2 range2).
+Proof.
+ intros it0 it1 it2 Step01 Step12.
+ option step in Step01 as ?:S1.
+ option step in Step12 as ?:S2.
+ injection Step01; destruct it1 as [??? iperm1]; intro H; injection H; intros; subst; simpl in *; clear Step01; clear H.
+ injection Step12; destruct it2 as [??? iperm2]; intro H; injection H; intros; subst; simpl in *; clear Step12; clear H.
+ destruct (permissions_foreach_commutes
+ range1 range2
+ (fn1 _ _) (fn2 _ _)
+ {| initialized:=PermLazy; perm:=initp it0 |}
+ (FnCommutes _)
+ (*(apply_access_perm_read_commutes (rel1:=rel1) (rel2:=rel2) (prot:=bool_decide (protector_is_active (iprot it0) cids)))*)
+ (iperm it0) iperm1 iperm2
+ S1 S2) as [perms' [Pre Post]].
+ unfold item_apply_access.
+ rewrite Pre; simpl.
+ eexists; split; [reflexivity|].
+ simpl. rewrite Post; simpl.
+ reflexivity.
+Qed.
+
+Lemma item_apply_access_read_persistent
+ {cids rel1 rel2 range1 fn1 fn2 range2}
+ (FnCommutes : forall isprot,
+ persistent_if lazy_perm_wf
+ (fn1 rel1 isprot)
+ (fn2 rel2 isprot))
+ : persistent_if (fun it => exists nxtc nxtp, item_wf it nxtc nxtp)
+ (item_apply_access fn1 cids rel1 range1)
+ (item_apply_access fn2 cids rel2 range2).
+Proof.
+ intros it0 it1 it2 Pre Step01 Step12.
+ option step in Step01 as ?:S1.
+ option step in Step12 as ?:S2.
+ injection Step01; destruct it1 as [??? iperm1]; intro H; injection H; intros; subst; simpl in *; clear Step01; clear H.
+ injection Step12; destruct it2 as [??? iperm2]; intro H; injection H; intros; subst; simpl in *; clear Step12; clear H.
+ destruct Pre as [nxtc [nxtp itWf]].
+ assert (lazy_perm_wf {| initialized:=PermLazy; perm := initp it0 |}) as LazyWf. {
+ rewrite /lazy_perm_wf /=.
+ intro Absurd.
+ exfalso. eapply itWf.(item_default_perm_valid it0 _ _). assumption.
+ }
+ assert (forall i, if_some_then lazy_perm_wf (iperm it0 !! i)) as InitWf. {
+ pose proof (itWf.(item_perms_valid it0 _ _)) as AllWf.
+ intro i.
+ destruct (iperm it0 !! i) as [perm|] eqn:permSpec.
+ 2: simpl; done.
+ simpl.
+ apply (map_Forall_lookup_1 _ _ i perm AllWf permSpec).
+ }
+ destruct (permissions_foreach_persistent
+ lazy_perm_wf
+ range1 range2
+ (fn1 _ _) (fn2 _ _)
+ {| initialized:=PermLazy; perm:=initp it0 |}
+ (FnCommutes _)
+ LazyWf
+ (iperm it0) iperm1 iperm2
+ InitWf
+ S1 S2) as [perms' Res].
+ unfold item_apply_access; simpl.
+ eexists. rewrite Res; simpl.
+ reflexivity.
+Qed.
+
+Lemma apply_access_success_condition
+ {fn cids access_tag range tr}
+ (ALL_SOME : every_node
+ (fun it => is_Some (item_apply_access fn cids (rel_dec tr access_tag (itag it)) range it)) tr)
+ : exists tr', tree_apply_access fn cids access_tag range tr = Some tr'.
+Proof.
+ assert (every_node is_Some (map_nodes (fun it => item_apply_access fn cids (rel_dec tr access_tag (itag it)) range it) tr)) as AllSomeMap by (rewrite every_node_map; assumption).
+ destruct (proj2 (join_success_condition _) AllSomeMap).
+ eexists; eassumption.
+Qed.
+
+Lemma join_map_commutes
+ {fn1 fn2 : call_id_set -> rel_pos -> Z * nat -> item -> option item} {cids access_tag1 access_tag2 range1 range2}
+ (Fn1PreservesTag : forall it it' cids rel range, fn1 cids rel range it = Some it' -> itag it = itag it')
+ (Fn2PreservesTag : forall it it' cids rel range, fn2 cids rel range it = Some it' -> itag it = itag it')
+ (Commutes : forall rel1 rel2, commutes
+ (fn1 cids rel1 range1)
+ (fn2 cids rel2 range2))
+ (* We need the two [rel_dec] to refer to the same tree otherwise the proof would be much more difficult *)
+ : forall (tr0:tree item),
+ commutes
+ (fun tr => join_nodes (map_nodes (fun it => fn1 cids (rel_dec tr0 access_tag1 it.(itag)) range1 it) tr))
+ (fun tr => join_nodes (map_nodes (fun it => fn2 cids (rel_dec tr0 access_tag2 it.(itag)) range2 it) tr)).
+Proof.
+ intros tr tr0.
+ induction tr0 as [|data0 left0 IHleft right0 IHright]; intros tr1 tr2 Step01 Step12.
+ - simpl in Step01; injection Step01; intros; subst.
+ simpl in Step12; injection Step12; intros; subst.
+ exists tree.empty; simpl; tauto.
+ - option step in Step01 as data1:Data01.
+ option step in Step01 as left1:Left01.
+ option step in Step01 as right1:Right01.
+ injection Step01; intros; subst.
+ option step in Step12 as data2:Data12.
+ option step in Step12 as left2:Left12.
+ option step in Step12 as right2:Right12.
+ injection Step12; intros; subst.
+ destruct (Commutes _ _ data0 data1 data2 Data01 Data12) as [data1' [Data01' Data1'2]].
+ destruct (IHleft left1 left2 Left01 Left12) as [left1' [Left01' Left1'2]].
+ destruct (IHright right1 right2 Right01 Right12) as [right1' [Right01' Right1'2]].
+ exists (branch data1' left1' right1').
+ simpl in *.
+ assert (itag data0 = itag data1) as Tg01 by (eapply Fn1PreservesTag; eassumption).
+ assert (itag data0 = itag data1') as Tg01' by (eapply Fn2PreservesTag; eassumption).
+ rewrite Tg01; rewrite Data01'; simpl.
+ rewrite Left01'; simpl.
+ rewrite Right01'; simpl.
+ rewrite <- Tg01'; rewrite Data1'2; simpl.
+ rewrite Left1'2; simpl.
+ rewrite Right1'2; simpl.
+ tauto.
+Qed.
+
+Lemma join_map_persistent
+ {fn1 fn2 : call_id_set -> rel_pos -> Z * nat -> item -> option item} {cids access_tag1 access_tag2 range1 range2}
+ (Fn1PreservesTag : forall it it' cids rel range, fn1 cids rel range it = Some it' -> itag it = itag it')
+ (Fn2PreservesTag : forall it it' cids rel range, fn2 cids rel range it = Some it' -> itag it = itag it')
+ (Commutes : forall rel1 rel2, persistent_if (fun it => exists nxtp nxtc, item_wf it nxtp nxtc)
+ (fn1 cids rel1 range1)
+ (fn2 cids rel2 range2))
+ (* We need the two [rel_dec] to refer to the same tree otherwise the proof would be much more difficult *)
+ : forall (tr0:tree item),
+ persistent_if (fun tr => exists nxtp nxtc, tree_items_compat_nexts tr nxtp nxtc)
+ (fun tr => join_nodes (map_nodes (fun it => fn1 cids (rel_dec tr0 access_tag1 it.(itag)) range1 it) tr))
+ (fun tr => join_nodes (map_nodes (fun it => fn2 cids (rel_dec tr0 access_tag2 it.(itag)) range2 it) tr)).
+Proof.
+ intros tr tr0 tr1 tr2 Pre.
+ destruct Pre as [nxtp [nxtc AllWf]].
+ revert tr1 tr2.
+ induction tr0 as [|data0 left0 IHleft right0 IHright]; intros tr1 tr2 Step01 Step12.
+ - simpl in Step01; injection Step01; intros; subst.
+ simpl in Step12; injection Step12; intros; subst.
+ exists tree.empty; simpl; tauto.
+ - option step in Step01 as data1:Data01.
+ option step in Step01 as left1:Left01.
+ option step in Step01 as right1:Right01.
+ injection Step01; intros; subst.
+ option step in Step12 as data2:Data12.
+ option step in Step12 as left2:Left12.
+ option step in Step12 as right2:Right12.
+ injection Step12; intros; subst.
+ inversion AllWf as [RootWf [LeftWf RightWf]].
+ destruct (Commutes _ _ data0 data1 data2 ltac:(eexists; eexists; exact RootWf) Data01 Data12) as [data1' Res].
+ destruct (IHleft LeftWf left1 left2 Left01 Left12) as [left1' LeftRes].
+ destruct (IHright RightWf right1 right2 Right01 Right12) as [right1' RightRes].
+ exists (branch data1' left1' right1').
+ simpl in *.
+ assert (itag data0 = itag data1) as Tg01 by (eapply Fn1PreservesTag; eassumption).
+ rewrite -Tg01; rewrite Res; simpl.
+ rewrite LeftRes.
+ rewrite RightRes.
+ simpl.
+ reflexivity.
+Qed.
+
+Lemma tree_apply_access_only_cares_about_rel
+ {tr} {fn : call_id_set -> rel_pos -> Z * nat -> item -> option item} {cids access_tag range}
+ {tr1 tr2}
+ (Agree : forall tg tg', ParentChildIn tg tg' tr1 <-> ParentChildIn tg tg' tr2)
+ (RAgree : forall tg tg', ImmediateParentChildIn tg tg' tr1 <-> ImmediateParentChildIn tg tg' tr2)
+ : join_nodes (map_nodes (fun it => fn cids (rel_dec tr1 access_tag it.(itag)) range it) tr)
+ = join_nodes (map_nodes (fun it => fn cids (rel_dec tr2 access_tag it.(itag)) range it) tr).
+Proof.
+ induction tr as [|data sibling IHsibling child IHchild]; [simpl; reflexivity|].
+ simpl.
+ rewrite IHsibling; clear IHsibling.
+ rewrite IHchild; clear IHchild.
+ unfold rel_dec.
+ f_equal. f_equal.
+ destruct (decide (ParentChildIn _ _ _)) as [R1|R1].
+ all: destruct (decide (ParentChildIn _ _ _)) as [R1'|R1'].
+ all: destruct (decide (ParentChildIn _ _ _)) as [R2|R2].
+ all: destruct (decide (ParentChildIn _ _ _)) as [R2'|R2'].
+ all: try reflexivity.
+ all: rewrite <- Agree in R2'; auto; try contradiction.
+ all: rewrite <- Agree in R2; auto; try contradiction.
+ all: erewrite decide_ext; last apply RAgree.
+ all: done.
+Qed.
+
+Lemma tree_apply_access_commutes
+ {fn1 fn2 cids access_tag1 access_tag2 range1 range2}
+ (Commutes : forall rel1 rel2, commutes
+ (item_apply_access fn1 cids rel1 range1)
+ (item_apply_access fn2 cids rel2 range2))
+ : commutes
+ (fun tr => tree_apply_access fn1 cids access_tag1 range1 tr)
+ (fun tr => tree_apply_access fn2 cids access_tag2 range2 tr).
+Proof.
+ unfold tree_apply_access.
+ intros tr0 tr1 tr2 Step01 Step12.
+ assert (forall (it it' : item) (cids : call_id_set) (rel : rel_pos) (range : Z * nat),
+ item_apply_access fn1 cids rel range it = Some it'
+ → itag it = itag it') as Fn1PreservesTag. {
+ intros. eapply item_apply_access_preserves_metadata. eassumption.
+ }
+ assert (forall (it it' : item) (cids : call_id_set) (rel : rel_pos) (range : Z * nat),
+ item_apply_access fn2 cids rel range it = Some it'
+ → itag it = itag it') as Fn2PreservesTag. {
+ intros. eapply item_apply_access_preserves_metadata. eassumption.
+ }
+
+ erewrite tree_apply_access_only_cares_about_rel in Step01.
+ 1: erewrite tree_apply_access_only_cares_about_rel in Step12.
+ 1: edestruct (join_map_commutes
+ Fn1PreservesTag
+ Fn2PreservesTag
+ Commutes _ tr0 tr1 tr2 Step01 Step12) as [tr1' [Step01' Step1'2]]. 1: exists tr1'; split; [exact Step01'|].
+ 1: erewrite tree_apply_access_only_cares_about_rel in Step1'2.
+ 1: exact Step1'2.
+ all: intros tg tg'.
+ - eapply join_map_eqv_rel; [|eassumption]. intros it it' H. eapply Fn2PreservesTag. exact H.
+ - eapply join_map_eqv_imm_rel; [|eassumption]. intros it it' H. eapply Fn2PreservesTag. exact H.
+ - symmetry. eapply join_map_eqv_rel; [|eassumption]. intros it it' H. eapply Fn1PreservesTag. exact H.
+ - symmetry. eapply join_map_eqv_imm_rel; [|eassumption]. intros it it' H. eapply Fn1PreservesTag. exact H.
+ - tauto.
+ - tauto.
+Qed.
+
+Lemma tree_apply_access_persistent
+ {fn1 fn2 cids access_tag1 access_tag2 range1 range2}
+ (Commutes : forall rel1 rel2, persistent_if (fun it => exists nxtp nxtc, item_wf it nxtp nxtc)
+ (item_apply_access fn1 cids rel1 range1)
+ (item_apply_access fn2 cids rel2 range2))
+ : persistent_if (fun tr => exists nxtp nxtc, tree_items_compat_nexts tr nxtp nxtc)
+ (fun tr => tree_apply_access fn1 cids access_tag1 range1 tr)
+ (fun tr => tree_apply_access fn2 cids access_tag2 range2 tr).
+Proof.
+ unfold tree_apply_access.
+ intros tr0 tr1 tr2 Pre Step01 Step12.
+ assert (forall (it it' : item) (cids : call_id_set) (rel : rel_pos) (range : Z * nat),
+ item_apply_access fn1 cids rel range it = Some it'
+ → itag it = itag it') as Fn1PreservesTag. {
+ intros. eapply item_apply_access_preserves_metadata. eassumption.
+ }
+ assert (forall (it it' : item) (cids : call_id_set) (rel : rel_pos) (range : Z * nat),
+ item_apply_access fn2 cids rel range it = Some it'
+ → itag it = itag it') as Fn2PreservesTag. {
+ intros. eapply item_apply_access_preserves_metadata. eassumption.
+ }
+
+ erewrite tree_apply_access_only_cares_about_rel in Step01.
+ 1: erewrite tree_apply_access_only_cares_about_rel in Step12.
+ 1: edestruct (join_map_persistent
+ Fn1PreservesTag
+ Fn2PreservesTag
+ Commutes _ tr0 tr1 tr2 Pre Step01 Step12) as [tr1' Res].
+ 1: exists tr1'.
+ 1: exact Res.
+ all: intros tg tg'.
+ - eapply join_map_eqv_rel; [|eassumption]. intros it it' H. eapply Fn1PreservesTag. exact H.
+ - eapply join_map_eqv_imm_rel; [|eassumption]. intros it it' H. eapply Fn1PreservesTag. exact H.
+ - eapply join_map_eqv_rel; [|eassumption]. intros it it' H. eapply Fn1PreservesTag. exact H.
+ - eapply join_map_eqv_imm_rel; [|eassumption]. intros it it' H. eapply Fn1PreservesTag. exact H.
+Qed.
+
+
+Lemma memory_access_read_commutes
+ {cids access_tag1 access_tag2 range1 range2}
+ : commutes
+ (memory_access AccessRead cids access_tag1 range1)
+ (memory_access AccessRead cids access_tag2 range2).
+Proof.
+ unfold memory_access.
+ apply tree_apply_access_commutes; intros.
+ apply item_apply_access_read_commutes; intros.
+ apply apply_access_perm_read_commutes.
+Qed.
+
+Lemma memory_access_read_persistent
+ {cids access_tag1 access_tag2 range1 range2}
+ : persistent_if (fun tr => exists nxtp nxtc, tree_items_compat_nexts tr nxtp nxtc)
+ (memory_access AccessRead cids access_tag1 range1)
+ (memory_access AccessRead cids access_tag2 range2).
+Proof.
+ unfold memory_access.
+ apply tree_apply_access_persistent; intros.
+ apply item_apply_access_read_persistent; intros.
+ apply apply_access_perm_read_persistent.
+Qed.
+
+Lemma apply_within_trees_commutes
+ {fn1 fn2 alloc1 alloc2}
+ (Commutes : commutes fn1 fn2)
+ : commutes
+ (apply_within_trees fn1 alloc1)
+ (apply_within_trees fn2 alloc2)
+ .
+Proof.
+ intros trs0 trs1 trs2 App0 App1.
+ (* Move forward *)
+ rewrite bind_Some in App0. destruct App0 as [tr0 [tr0Spec App0]].
+ rewrite bind_Some in App0. destruct App0 as [tr1 [tr1Spec App0]].
+ injection App0; intros; clear App0; subst.
+ rewrite bind_Some in App1. destruct App1 as [tr1b [tr1bSpec App1]].
+ rewrite bind_Some in App1. destruct App1 as [tr2 [tr2Spec App1]].
+ injection App1; intros; clear App1; subst.
+ (* Now we do the interesting case distinction *)
+ destruct (decide (alloc1 = alloc2)).
+ - (* Same allocation *)
+ subst.
+ assert (tr1 = tr1b). {
+ rewrite lookup_insert in tr1bSpec. injection tr1bSpec. tauto.
+ }
+ subst.
+ destruct (Commutes _ _ _ tr1Spec tr2Spec) as [tr1' [tr1'SpecA tr1'SpecB]].
+ exists (<[alloc2:=tr1']> trs0).
+ split.
+ + rewrite bind_Some. exists tr0. split; first done.
+ rewrite tr1'SpecA; simpl; done.
+ + rewrite bind_Some. exists tr1'.
+ split.
+ * apply lookup_insert.
+ * rewrite tr1'SpecB; simpl.
+ f_equal.
+ do 2 rewrite insert_insert.
+ reflexivity.
+ - (* Not the same allocation *)
+ exists (<[alloc2:=tr2]> trs0).
+ split.
+ + rewrite bind_Some. exists tr1b.
+ split.
+ * rewrite <- tr1bSpec. rewrite lookup_insert_ne; done.
+ * rewrite tr2Spec; done.
+ + rewrite bind_Some. exists tr0.
+ split.
+ * rewrite <- tr0Spec. rewrite lookup_insert_ne; done.
+ * rewrite tr1Spec; simpl.
+ f_equal. apply insert_commute. done.
+Qed.
+
+Lemma apply_within_trees_persistent
+ {fn1 fn2 alloc1 alloc2}
+ (Commutes : persistent_if (fun tr => exists nxtp nxtc, tree_items_compat_nexts tr nxtp nxtc) fn1 fn2)
+ : persistent_if (fun trs => exists nxtp nxtc, trees_compat_nexts trs nxtp nxtc)
+ (apply_within_trees fn1 alloc1)
+ (apply_within_trees fn2 alloc2)
+ .
+Proof.
+ intros trs0 trs1 trs2 Pre App0 App1.
+ destruct Pre as [nxtp [nxtc AllWf]].
+ (* Move forward *)
+ rewrite bind_Some in App0. destruct App0 as [tr0 [tr0Spec App0]].
+ rewrite bind_Some in App0. destruct App0 as [tr1 [tr1Spec App0]].
+ injection App0; intros; clear App0; subst.
+ rewrite bind_Some in App1. destruct App1 as [tr1b [tr1bSpec App1]].
+ rewrite bind_Some in App1. destruct App1 as [tr2 [tr2Spec App1]].
+ injection App1; intros; clear App1; subst.
+ pose proof (AllWf alloc1 tr0 tr0Spec) as tr0Wf.
+ (* Now we do the interesting case distinction *)
+ destruct (decide (alloc1 = alloc2)).
+ - (* Same allocation *)
+ subst.
+ assert (tr0 = tr1b). {
+ rewrite tr0Spec in tr1bSpec.
+ injection tr1bSpec. tauto.
+ }
+ subst.
+ destruct (Commutes _ _ _ ltac:(eexists; eexists; apply tr0Wf) tr1Spec tr2Spec) as [tr1' Res].
+ eexists.
+ rewrite bind_Some. eexists.
+ split.
+ + rewrite lookup_insert; reflexivity.
+ + rewrite Res; simpl; reflexivity.
+ - (* Not the same allocation *)
+ eexists.
+ + rewrite bind_Some. exists tr1b.
+ split.
+ * rewrite <- tr1bSpec. rewrite lookup_insert_ne; done.
+ * rewrite tr2Spec; simpl. done.
+Qed.
+
+Lemma apply_read_within_trees_commutes
+ {cids tg1 range1 alloc1 tg2 range2 alloc2}
+ : commutes
+ (apply_within_trees (memory_access AccessRead cids tg1 range1) alloc1)
+ (apply_within_trees (memory_access AccessRead cids tg2 range2) alloc2)
+ .
+Proof.
+ apply apply_within_trees_commutes.
+ apply memory_access_read_commutes.
+Qed.
+
+Lemma apply_read_within_trees_persistent
+ {cids tg1 range1 alloc1 tg2 range2 alloc2}
+ : persistent_if (fun trs => exists nxtp nxtc, trees_compat_nexts trs nxtp nxtc)
+ (apply_within_trees (memory_access AccessRead cids tg1 range1) alloc1)
+ (apply_within_trees (memory_access AccessRead cids tg2 range2) alloc2)
+ .
+Proof.
+ apply apply_within_trees_persistent.
+ apply memory_access_read_persistent.
+Qed.
+
+Lemma read_failure_preserved
+ {cids tg1 range1 alloc1 tg2 range2 alloc2 trs0 trs1}
+ (Wf : exists nxtp nxtc, trees_compat_nexts trs0 nxtp nxtc)
+ (Read1 : apply_within_trees (memory_access AccessRead cids tg1 range1) alloc1 trs0 = Some trs1)
+ :
+ apply_within_trees (memory_access AccessRead cids tg2 range2) alloc2 trs0 = None
+ <->
+ apply_within_trees (memory_access AccessRead cids tg2 range2) alloc2 trs1 = None
+ .
+Proof.
+ split.
+ + intro Fail0.
+ destruct (apply_within_trees (memory_access AccessRead cids tg2 range2) alloc2 trs1) eqn:Acc1.
+ 2: reflexivity.
+ exfalso.
+ destruct (apply_read_within_trees_commutes _ _ _ Read1 Acc1) as [x1' [Read' _]].
+ rewrite Read' in Fail0. discriminate.
+ + intro Fail1.
+ destruct (apply_within_trees (memory_access AccessRead cids tg2 range2) alloc2 trs0) eqn:Acc0.
+ 2: reflexivity.
+ destruct (apply_read_within_trees_persistent _ _ _ Wf Read1 Acc0) as [x' Read'].
+ rewrite Read' in Fail1.
+ discriminate.
+Qed.
+
+Lemma apply_read_within_trees_same_tags
+ {tg trs trs' cids tg' range blk blk'}
+ (ACC : apply_within_trees (memory_access AccessRead cids tg' range) blk' trs = Some trs')
+ : trees_contain tg trs blk <-> trees_contain tg trs' blk.
+Proof.
+ rewrite bind_Some in ACC. destruct ACC as [tr [trSpec ACC]].
+ rewrite bind_Some in ACC. destruct ACC as [tr' [tr'Spec ACC]].
+ injection ACC; intros; clear ACC; subst.
+ rewrite /trees_contain /trees_at_block.
+ destruct (decide (blk = blk')).
+ + subst. rewrite lookup_insert. rewrite trSpec.
+ eapply access_preserves_tags.
+ apply tr'Spec.
+ + rewrite lookup_insert_ne; last done.
+ reflexivity.
+Qed.
+
+Lemma CopyEvt_commutes
+ { trs0 cids0 nxtp0 nxtc0
+ alloc1 tg1 range1 val1
+ trs1 cids1 nxtp1 nxtc1
+ alloc2 tg2 range2 val2
+ trs2 cids2 nxtp2 nxtc2
+ }
+ (Step1 :
+ bor_step
+ trs0 cids0 nxtp0 nxtc0
+ (CopyEvt alloc1 tg1 range1 val1)
+ trs1 cids1 nxtp1 nxtc1)
+ (Step2 :
+ bor_step
+ trs1 cids1 nxtp1 nxtc1
+ (CopyEvt alloc2 tg2 range2 val2)
+ trs2 cids2 nxtp2 nxtc2)
+ : exists trs1' cids1' nxtp1' nxtc1',
+ bor_step
+ trs0 cids0 nxtp0 nxtc0
+ (CopyEvt alloc2 tg2 range2 val2)
+ trs1' cids1' nxtp1' nxtc1'
+ /\
+ bor_step
+ trs1' cids1' nxtp1' nxtc1'
+ (CopyEvt alloc1 tg1 range1 val1)
+ trs2 cids2 nxtp2 nxtc2
+ .
+Proof.
+ inversion Step1 as [|????? EXISTS1 ACC1 SZ1| | | | | | | |].
+ - subst.
+ inversion Step2 as [|????? EXISTS2 ACC2 SZ2| | | | | | | |].
+ + subst.
+ destruct (apply_read_within_trees_commutes _ _ _ ACC1 ACC2) as [trs1' [ACC2' ACC1']].
+ exists trs1'. exists cids2. exists nxtp2. exists nxtc2.
+ split.
+ * econstructor; eauto.
+ rewrite apply_read_within_trees_same_tags; last exact ACC2'.
+ rewrite apply_read_within_trees_same_tags; last exact ACC1'.
+ rewrite- apply_read_within_trees_same_tags; last exact ACC2.
+ assumption.
+ * econstructor; eauto.
+ rewrite apply_read_within_trees_same_tags; last exact ACC1'.
+ rewrite- apply_read_within_trees_same_tags; last exact ACC2.
+ rewrite- apply_read_within_trees_same_tags; last exact ACC1.
+ assumption.
+ + subst.
+ repeat eexists.
+ 1: econstructor 3; auto.
+ econstructor; eauto.
+ - subst.
+ inversion Step2 as [|????? EXISTS2 ACC2 SZ2| | | | | | | |].
+ + subst.
+ repeat eexists.
+ 1: econstructor; eauto.
+ econstructor 3; eauto.
+ + subst.
+ repeat eexists.
+ all: econstructor 3; eauto.
+Qed.
+
+Lemma bor_steps_CopyEvt_commutes
+ { trs0 cids0 nxtp0 nxtc0
+ alloc1 tg1 range1 val1
+ alloc2 tg2 range2 val2
+ trs2 cids2 nxtp2 nxtc2
+ }
+ (Steps : bor_steps
+ trs0 cids0 nxtp0 nxtc0
+ [CopyEvt alloc1 tg1 range1 val1; CopyEvt alloc2 tg2 range2 val2]
+ trs2 cids2 nxtp2 nxtc2)
+ : bor_steps
+ trs0 cids0 nxtp0 nxtc0
+ [CopyEvt alloc2 tg2 range2 val2; CopyEvt alloc1 tg1 range1 val1]
+ trs2 cids2 nxtp2 nxtc2
+ .
+Proof.
+ inversion Steps as [|?????????? HEAD1 REST1].
+ inversion REST1 as [|?????????? HEAD2 REST2].
+ inversion REST2.
+ subst.
+ destruct (CopyEvt_commutes HEAD1 HEAD2) as [?[?[?[?[HEAD2' HEAD1']]]]].
+ econstructor; last econstructor; last constructor.
+ + apply HEAD2'.
+ + apply HEAD1'.
+Qed.
+
+
diff --git a/theories/tree_borrows/read_read_reorder/read_reorder.v b/theories/tree_borrows/read_read_reorder/read_reorder.v
new file mode 100644
index 0000000000000000000000000000000000000000..7c46d17b470650ca95dfcdb2288804b783634e16
--- /dev/null
+++ b/theories/tree_borrows/read_read_reorder/read_reorder.v
@@ -0,0 +1,233 @@
+From iris.prelude Require Import prelude options.
+From stdpp Require Export gmap.
+From simuliris.tree_borrows Require Import defs lang_base lang notation bor_semantics tree tree_lemmas bor_lemmas steps_preserve tactics class_instances.
+From simuliris.tree_borrows.read_read_reorder Require Import low_level equivalence_def.
+From iris.prelude Require Import options.
+
+Definition source (x1 x2 : string) l1 tg1 sz1 l2 tg2 sz2 erest : expr :=
+ let: x1 := Copy (Place l1 tg1 sz1) in
+ let: x2 := Copy (Place l2 tg2 sz2) in
+ erest.
+
+Definition target (x1 x2 : string) l1 tg1 sz1 l2 tg2 sz2 erest : expr :=
+ let: x2 := Copy (Place l2 tg2 sz2) in
+ let: x1 := Copy (Place l1 tg1 sz1) in
+ erest.
+
+
+Ltac solve_sub_redexes_are_values :=
+ let K := fresh "K" in
+ let e' := fresh "e'" in
+ let Heq := fresh "Heq" in
+ let Hv := fresh "Hv" in
+ let IH := fresh "IH" in
+ let Ki := fresh "Ki" in
+ let Ki' := fresh "Ki'" in
+ intros K e' Heq Hv;
+ destruct K as [ | Ki K]; first (done);
+ exfalso; induction K as [ | Ki' K IH] in e', Ki, Hv, Heq |-*;
+ [destruct Ki; inversion Heq; subst; cbn in *;
+ try rewrite to_val_of_result in Hv; congruence
+ | eapply IH; first (by rewrite Heq);
+ rewrite language_to_val_eq; apply fill_item_no_result;
+ by rewrite -language_to_val_eq].
+
+Lemma list_destruct_snoc {A} (l : list A) :
+ l = nil ∨ ∃ xt xh, l = xh ++ [xt].
+Proof.
+ rewrite -(rev_involutive l).
+ destruct (rev l) as [|xt xh]; first by left.
+ right. simpl. by repeat eexists.
+Qed.
+
+Lemma prim_step_let_inv x e es e' P σ σ' tt :
+ prim_step P (let: x := e in es) σ e' σ' tt →
+ (∃ ev, language.to_val e = Some ev ∧ tt = nil ∧ σ' = σ ∧ e' = subst' x e es) ∨
+ ∃ ei', language.to_val e = None ∧ prim_step P e σ ei' σ' tt ∧ e' = (let: x := ei' in es)%E.
+Proof.
+ destruct (language.to_val e) as [ev|] eqn:Hev.
+ - intros H%prim_base_step.
+ 2: solve_sub_redexes_are_values.
+ inversion H as [x1 x2 x3 x4 EE| x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 EE]; simplify_eq.
+ 2: by inversion EE.
+ inversion EE; simplify_eq. left. eexists. done.
+ - intros (K&e1'&e2'&He1&He2&H)%prim_step_inv.
+ destruct (list_destruct_snoc K) as [->|(xt & xh & ->)].
+ + simpl in *; simplify_eq.
+ inversion H as [x1 x2 x3 x4 EE| x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 EE]; simplify_eq.
+ 2: by inversion EE.
+ inversion EE; simplify_eq.
+ match goal with [HH : is_Some (to_result e) |- _ ] =>
+ rewrite -language_to_val_eq Hev in HH; by destruct HH end.
+ + subst e'. rewrite /= fill_app in He1.
+ destruct xt; simplify_eq.
+ replace (Let x e es) with (fill [LetEctx x es] e) in He1; last done.
+ simplify_eq. right. eexists.
+ rewrite /= fill_app /=.
+ split; first done.
+ split; last done.
+ eapply fill_prim_step. eapply base_prim_step. done.
+Qed.
+
+Lemma prim_step_copy_inv l tg sz P σ e' σ' tt :
+ prim_step P (Copy (Place l tg sz)) σ e' σ' tt →
+ (∃ v trs', e' = (#v)%E ∧ tt = nil ∧ read_mem l sz (shp σ) = Some v ∧ trees_contain tg (strs σ) l.1 ∧ apply_within_trees (memory_access AccessRead (scs σ) tg (l.2, sz)) l.1 (strs σ) = Some trs' ∧ sz ≠0 ∧ σ' = mkState (shp σ) trs' (scs σ) (snp σ) (snc σ))
+∨ (∃ v, e' = (#v)%E ∧ tt = nil ∧ read_mem l sz (shp σ) = Some v ∧ sz = 0 ∧ σ' = σ)
+(*∨ (e' = (#(replicate sz ☠%S))%E ∧ tt = nil ∧ is_Some (read_mem l sz (shp σ)) ∧ trees_contain tg (strs σ) l.1 ∧ apply_within_trees (memory_access AccessRead (scs σ) tg (l.2, sz)) l.1 (strs σ) = None ∧ σ' = σ)*).
+Proof.
+ intros H%prim_base_step.
+ 2: solve_sub_redexes_are_values.
+ inversion H as [x1 x2 x3 x4 EE| x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 ME IE]; simplify_eq.
+ 1: by inversion EE.
+ inversion ME; simplify_eq.
+ - inversion IE; simplify_eq.
+ + left. do 2 eexists. done.
+ + right. eexists. do 4 (split; first done). by destruct σ.
+(* - simpl in *.
+ inversion IE; simplify_eq. right. right.
+ do 5 (split; first done).
+ by destruct σ. *)
+Qed.
+
+Lemma subst_val_twice_exchange e x1 x2 v1 v2 :
+ x1 ≠x2 →
+ subst x1 (#v1)%E (subst' x2 (#v2)%E e) = subst x2 (#v2)%E (subst' x1 (#v1)%E e).
+Proof.
+ intros Hne.
+ simpl.
+ refine ((fix IH (e:expr) {struct e} : subst x1 #v1 (subst x2 #v2 e) = subst x2 #v2 (subst x1 #v1 e) := _) e).
+ destruct e as [| | | | | | | | | | | | | | | | |? el| | ]; simpl; try (f_equal; by eapply IH).
+ - clear IH. rewrite !bool_decide_decide. do 2 destruct decide; simplify_eq; simpl.
+ + rewrite bool_decide_decide decide_True //.
+ + rewrite bool_decide_decide decide_True //.
+ + do 2 rewrite bool_decide_decide decide_False //.
+ - f_equal. 1: apply IH. f_equal. rewrite !bool_decide_decide. do 2 destruct decide; simplify_eq; simpl; done.
+ - f_equal. 1: eapply IH.
+ induction el as [|?? IHel]; first done.
+ + simpl. f_equal. 2: apply IHel. apply IH.
+Qed.
+
+Lemma read_reorder_onesided x1 x2 l1 tg1 sz1 l2 tg2 sz2 erest P σ :
+ state_wf σ →
+ x1 ≠x2 →
+ identical_states_after P (source x1 x2 l1 tg1 sz1 l2 tg2 sz2 erest) (target x1 x2 l1 tg1 sz1 l2 tg2 sz2 erest) σ 4.
+Proof.
+ destruct l1 as [blk1 off1], l2 as [blk2 off2].
+ intros Hwf Hne.
+ intros e4 σ4 (e1' & σ1 & [(?&[=]&_)|(e1&_&[(v1&trs1&->&_&Hread1&Hcontain1&Happly1&Hne1&->)|(v1&->&_&Hrd1&->&->)]%prim_step_copy_inv&->)]%prim_step_let_inv & Hrst).
+ all: destruct Hrst as (e2 & σ2 & [(?&[= <-]&_&->&->)|(?&[=]&_)]%prim_step_let_inv & Hrst).
+ all: simpl in *|-.
+ all: destruct Hrst as (e3' & σ3 & [(?&[=]&_)|(e3&_&[(v3&trs3&->&_&Hread3&Hcontain3&Happly3&Hne2&->)|(v3&->&_&Hrd3&->&->)]%prim_step_copy_inv&->)]%prim_step_let_inv & Hrst).
+ all: simpl in *|-.
+ all: destruct Hrst as (e4' & σ4' & [(?&[= <-]&_&->&->)|(?&[=]&_)]%prim_step_let_inv & <- & <-).
+ all: rewrite /target.
+ all: rewrite bool_decide_decide decide_True; last congruence.
+ all: do 2 change (subst' (BNamed ?a) ?b ?c) with (subst a b c).
+ all: rewrite subst_val_twice_exchange //.
+ - (* read x1: succeed, read x2: succeed *)
+ odestruct CopyEvt_commutes as (y1&y2&y3&y4&HH1&HH2).
+ { econstructor. 1: eapply Hcontain1. 1: eapply Happly1. 1: done. }
+ { econstructor. 1: eapply Hcontain3. 1: eapply Happly3. 1: done. }
+ do 2 eexists. split.
+ { change (Let ?x2 ?a ?b) with (fill [LetEctx x2 b] a).
+ eapply fill_prim_step. eapply base_prim_step.
+ econstructor 2. 1: econstructor 3. 1: done.
+ eapply HH1. }
+ do 2 eexists. split.
+ { simpl. eapply base_prim_step.
+ econstructor 1. econstructor. 1: done. done. }
+ do 2 eexists. simpl. split.
+ { change (Let ?x2 ?a ?b) with (fill [LetEctx x2 b] a).
+ eapply fill_prim_step. eapply base_prim_step.
+ econstructor 2. 1: econstructor 3. 1: done. simpl. done. }
+ do 2 eexists. split.
+ { simpl. eapply base_prim_step.
+ econstructor 1. econstructor. 1: done. done. }
+ split; last done. rewrite bool_decide_decide decide_True //; congruence.
+ - (* read x1: succeed, read x2: zerosized *)
+ do 2 eexists. split.
+ { change (Let ?x2 ?a ?b) with (fill [LetEctx x2 b] a).
+ eapply fill_prim_step. eapply base_prim_step.
+ econstructor 2. 1: econstructor 3. 1: done.
+ econstructor; done. }
+ do 2 eexists. split.
+ { simpl. eapply base_prim_step.
+ econstructor 1. econstructor. 1: done. done. }
+ do 2 eexists. simpl. split.
+ { change (Let x1 ?a ?b) with (fill [LetEctx x1 b] a).
+ eapply fill_prim_step. eapply base_prim_step.
+ econstructor 2. 1: econstructor 3. 1: done. simpl.
+ econstructor; done. }
+ do 2 eexists. split.
+ { simpl. eapply base_prim_step.
+ econstructor 1. econstructor. 1: done. done. }
+ split; last done. rewrite bool_decide_decide decide_True //; congruence.
+ - (* read x1: zerosized, read x2: succeed *)
+ do 2 eexists. split.
+ { change (Let x2 ?a ?b) with (fill [LetEctx x2 b] a).
+ eapply fill_prim_step. eapply base_prim_step.
+ econstructor 2. 1: simpl; econstructor 3. 1: done.
+ econstructor; done. }
+ do 2 eexists. split.
+ { simpl. eapply base_prim_step.
+ econstructor 1. econstructor. 1: done. done. }
+ do 2 eexists. simpl. split.
+ { change (Let x1 ?a ?b) with (fill [LetEctx x1 b] a).
+ eapply fill_prim_step. eapply base_prim_step.
+ econstructor 2. 1: econstructor 3. 1: done. simpl.
+ econstructor; done. }
+ do 2 eexists. split.
+ { simpl. eapply base_prim_step.
+ econstructor 1. econstructor. 1: done. done. }
+ split; last done. rewrite bool_decide_decide decide_True //; congruence.
+ - (* read x1: zerosized, read x2: zerosized *)
+ do 2 eexists. simplify_eq. split.
+ { change (Let x2 ?a ?b) with (fill [LetEctx x2 b] a).
+ eapply fill_prim_step. eapply base_prim_step.
+ econstructor 2. 1: econstructor 3. 1: done.
+ econstructor; done. }
+ do 2 eexists. split.
+ { simpl. eapply base_prim_step.
+ econstructor 1. econstructor. 1: done. done. }
+ do 2 eexists. simpl. split.
+ { change (Let x1 ?a ?b) with (fill [LetEctx x1 b] a).
+ eapply fill_prim_step. eapply base_prim_step.
+ econstructor 2. 1: econstructor 3. 1: done. simpl.
+ econstructor; done. }
+ do 2 eexists. split.
+ { simpl. eapply base_prim_step.
+ econstructor 1. econstructor. 1: done. done. }
+ split; last by destruct σ. rewrite bool_decide_decide decide_True //; congruence.
+Qed.
+
+Lemma read_example_no_termination x1 x2 l1 tg1 sz1 l2 tg2 sz2 erest P σ :
+ x1 ≠x2 →
+ no_termination_within P (source x1 x2 l1 tg1 sz1 l2 tg2 sz2 erest) σ 4.
+Proof.
+ intros Hne.
+ econstructor; first done.
+ intros e' σ' [(?&[=]&_)|(e1&_&[(v1&trs1&->&_&Hread1&Hcontain1&Happly1&Hne1&->)|(v1&->&_&Hrd1&->&->)]%prim_step_copy_inv&->)]%prim_step_let_inv.
+ all: econstructor; first done.
+ all: intros e' σ' [(?&[= <-]&_&->&->)|(?&[=]&_)]%prim_step_let_inv.
+ all: econstructor; first done.
+ all: intros e' σ' [(?&[=]&_)|(e3&_&[(v3&trs3&->&_&Hread3&Hcontain3&Happly3&Hne2&->)|(v3&->&_&Hrd3&->&->)]%prim_step_copy_inv&->)]%prim_step_let_inv.
+ all: econstructor; first done.
+ all: intros e' σ' [(?&[= <-]&_&->&->)|(?&[=]&_)]%prim_step_let_inv.
+ all: econstructor.
+Qed.
+
+Theorem read_reorder x1 x2 l1 tg1 sz1 l2 tg2 sz2 erest P :
+ x1 ≠x2 →
+ eventually_equal P (source x1 x2 l1 tg1 sz1 l2 tg2 sz2 erest) (target x1 x2 l1 tg1 sz1 l2 tg2 sz2 erest).
+Proof.
+ intros H1.
+ exists 4.
+ intros σ Hσ.
+ split; first by eapply read_example_no_termination.
+ split; first by eapply read_example_no_termination.
+ split; eapply read_reorder_onesided; done.
+Qed.
+
+(*
+Print Assumptions read_reorder.
+*)
\ No newline at end of file
diff --git a/theories/tree_borrows/refl.v b/theories/tree_borrows/refl.v
index ba7acb4eec4e1024373cffdee195139c3c52ee6e..e9509dea0bf7fc6a41c857a7bc3f59d29cf6c046 100755
--- a/theories/tree_borrows/refl.v
+++ b/theories/tree_borrows/refl.v
@@ -277,7 +277,6 @@ Section log_rel.
iDestruct (value_rel_length with "Hv1") as %EqL.
iDestruct (value_rel_lookup with "Hv1") as (sc_t sc_s Eqt Eqs) "Hsc".
{ rewrite EqL. eapply Nat2Z.inj_lt, lookup_lt_Some; eauto. }
- (* TODO: I don't know how to fix sim_pures to do this. *)
target_proj; [done|]. source_proj; [done|]. solve_rrel_refl.
Qed.
@@ -373,8 +372,6 @@ Section log_rel.
iIntros (t) "Hv". sim_val. eauto.
Qed.
- (* TODO: this can be useful elsewhere. It's here because I'm relying on the
- several useful tactics defined here. *)
Local Lemma sim_case π e_t e_s el_t el_s Ψ :
e_t ⪯{π} e_s {{ rrel }} -∗
([∗ list] e_t';e_s' ∈ el_t;el_s, e_t' ⪯{π} e_s' [{ Ψ }]) -∗
@@ -389,7 +386,6 @@ Section log_rel.
rename select (_ !! _ = Some _) into Hls.
assert (∃ e_t', el_t !! Z.to_nat i = Some e_t') as [? Hlt].
{ apply lookup_lt_is_Some_2. apply lookup_lt_Some in Hls. by rewrite EqL. }
- (* TODO sim_pures? *)
target_case; [done|]. source_case; [done|]. sim_pures.
iApply (big_sepL2_lookup _ _ _ _ _ _ Hlt Hls with "Hle").
Qed.
diff --git a/theories/tree_borrows/step_laws/steps_local.v b/theories/tree_borrows/step_laws/steps_local.v
index b5f8c61987663cd9f6637567fba867a2404f87e6..512e4adb2c4d5439e7912a19beca28f00aef80f9 100644
--- a/theories/tree_borrows/step_laws/steps_local.v
+++ b/theories/tree_borrows/step_laws/steps_local.v
@@ -50,19 +50,19 @@ Proof.
{ iPureIntro. do 3 eexists. eapply copy_base_step'. 1: done. 2: exact READ_MEM. 2: exact TREES_NOCHANGE.
rewrite /trees_contain /trees_at_block /= Hit. subst t. cbv. tauto. }
iIntros (??? Hstep).
- eapply head_copy_inv in Hstep as (->&[((HNone&_&_&_)&_)|(trs'&v'&->&->&Hreadv'&[(_&Happly&Hnon)|(Hzero&->&->)])]).
- 1: rewrite /= TREES_NOCHANGE // in HNone.
+ eapply head_copy_inv in Hstep as (->&trs'&v'&->&->&Hreadv'&[(_&Happly&Hnon)|(Hzero&->&->)]).
- iModIntro. iSplitR; first done.
assert (v_rd = v') as -> by congruence.
iSplitR "Htag Ht Hsim"; last first.
1: iApply ("Hsim" with "Ht Htag").
- iFrame. simpl in Happly. assert (trs' = strs σ_t) as -> by congruence.
+ iFrame "HP_t HP_s".
+ simpl in Happly. assert (trs' = strs σ_t) as -> by congruence.
iExists _, _, _, _. destruct σ_t. iApply "Hbor".
- iModIntro. iSplitR; first done.
assert (v_rd = []) as -> by by destruct v_rd.
iSplitR "Htag Ht Hsim"; last first.
1: iApply ("Hsim" with "Ht Htag").
- iFrame.
+ iFrame "HP_t HP_s".
iExists _, _, _, _. destruct σ_t. iApply "Hbor".
Qed.
@@ -96,7 +96,7 @@ Proof.
iModIntro.
iSplitR "Htag Ht Hsim"; last first.
1: iApply ("Hsim" with "Ht Htag").
- iFrame. destruct σ_s; simpl.
+ iFrame "HP_t HP_s". destruct σ_s; simpl.
iExists _, _, _, _. iApply "Hbor".
Qed.
@@ -134,7 +134,8 @@ Proof.
iIntros (??? Hstep). pose proof Hstep as Hstep2.
eapply head_write_inv in Hstep2 as (trs'&->&->&->&_&Hiinv&[(Hcont&Happly&Hlen)|(Hlen&->)]); last first.
{ iModIntro. iSplit; first done.
- assert (v_wr = nil) as -> by by destruct v_wr. iFrame.
+ assert (v_wr = nil) as -> by by destruct v_wr.
+ iFrame "HP_t HP_s".
iSplitL "Hbor". 1: repeat iExists _; destruct σ_t; done.
eapply write_range_to_list_is_Some in Hwrite as (x&Hx&_). simpl in Hx. subst v_t'.
iApply ("Hsim" with "Ht Htag"). }
diff --git a/theories/tree_borrows/step_laws/steps_prot.v b/theories/tree_borrows/step_laws/steps_prot.v
index f83ce82d265e96dd57f1bc839e59cf716c202760..1b9df53a76b362a1d4a96bee2f1db18e25157a8d 100644
--- a/theories/tree_borrows/step_laws/steps_prot.v
+++ b/theories/tree_borrows/step_laws/steps_prot.v
@@ -54,8 +54,8 @@ Proof.
iSplit.
{ iPureIntro. do 3 eexists. eapply copy_base_step'. 1: done. 2: exact READ_MEM. 2: exact Htrs'. done. }
iIntros (??? Hstep). pose proof Hstep as Hstep2.
- eapply head_copy_inv in Hstep2 as (->&[((HNone&_&_&_)&_)|(trs''&v'&->&->&Hreadv'&[(_&Htrs''&Hnon)|(Hzero&->&->)])]).
- 1: rewrite /= Htrs' // in HNone. 2: done.
+ eapply head_copy_inv in Hstep2 as (->&trs''&v'&->&->&Hreadv'&[(_&Htrs''&Hnon)|(Hzero&->&->)]).
+ 2: done.
assert (trs'' = trs') as ->.
{ rewrite /memory_access Htrs' in Htrs''. congruence. }
assert (v_rd = v') as -> by congruence.
diff --git a/theories/tree_borrows/step_laws/steps_read_write_simple.v b/theories/tree_borrows/step_laws/steps_read_write_simple.v
index 458bff3772d72c0160f0f5240b513445aa942785..d839a85f9e7f00af6757310d2bffae3716eaaf81 100644
--- a/theories/tree_borrows/step_laws/steps_read_write_simple.v
+++ b/theories/tree_borrows/step_laws/steps_read_write_simple.v
@@ -33,9 +33,7 @@ Proof.
{ iPureIntro. do 3 eexists. econstructor 2. 1: eapply CopyBS. 1: done.
eapply ZeroCopyIS. done. }
iIntros (e_t' efs_t σ_t' Hstep).
- eapply head_copy_inv in Hstep as (->&[((HNone&->&->&HH1)&Hintree)|(trs'&v'&->&->&Hread&[(_&_&HH)|(_&->&->)])]).
- - iModIntro. iSplit; first done. simpl. iFrame "Hsim".
- iFrame.
+ eapply head_copy_inv in Hstep as (->&trs'&v'&->&->&Hread&[(_&_&HH)|(_&->&->)]).
- lia.
- iModIntro. iSplit; first done. simpl. iFrame "HP_s HP_t Hsim". do 4 iExists _. destruct σ_t. done.
Qed.
@@ -69,7 +67,7 @@ Proof.
eapply head_write_inv in Hstep as (trs'&->&->&->&_&_&[(_&_&?)|(_&->)]).
- lia.
- iModIntro. iSplit; first done. simpl. iFrame "Hsim".
- iFrame. destruct σ_t. by repeat iExists _.
+ iFrame "HP_t HP_s". destruct σ_t. by repeat iExists _.
Qed.
Lemma source_write_zero l t v π Ψ :
@@ -102,9 +100,9 @@ Proof.
destruct Hsafe as [Hpool Hsafe].
iPoseProof (bor_interp_get_pure with "Hbor") as "%Hp".
destruct Hp as (Hstrs_eq & Hsnp_eq & Hsnc_eq & Hscs_eq & Hwf_s & Hwf_t & Hdom_eq).
- specialize (pool_safe_implies Hsafe Hpool) as [(vr_s&Hreadmem&Hcontain_s&(trs_s'&Htrss)&_)|[(_&_&[]%Hne)|(Hcontain_s&Hnotrees&Hisval)]];
+ specialize (pool_safe_implies Hsafe Hpool) as [(vr_s&Hreadmem&Hcontain_s&(trs_s'&Htrss)&_)|(_&_&[]%Hne)];
pose proof Hcontain_s as Hcontain_t; rewrite trees_equal_same_tags in Hcontain_t; try done; last first.
- { (* We get poison *)
+(* { (* We get poison *)
assert (apply_within_trees (memory_access AccessRead (scs σ_s) bor_s (l_s.2, sz)) l_s.1 (strs σ_t) = None) as Hnotrees_t.
{ destruct apply_within_trees eqn:HSome in |-*; try done.
eapply mk_is_Some, trees_equal_allows_more_access in HSome as (x&Hx); first by erewrite Hnotrees in Hx.
@@ -120,7 +118,7 @@ Proof.
{ iPureIntro. subst e_t'. destruct σ_s, l_s. simpl. do 2 econstructor; by eauto. }
simpl. iFrame. iSplit; last done. subst e_t'.
iApply "Hsim". iApply big_sepL_sepL2_diag. iApply big_sepL_forall. by iIntros (k v (->&_)%lookup_replicate_1).
- }
+ } *)
edestruct trees_equal_allows_more_access as (trs_t'&Htrst).
1: done. 1: eapply Hwf_s. 1,2,3: rewrite ?Hscs_eq; eapply Hwf_t. 1: done. 1: done. 1: by eapply mk_is_Some.
opose proof (trees_equal_preserved_by_access _ _ _ _ _ _ _ Hstrs_eq _ Htrss Htrst) as Hstrs_eq'.
@@ -131,7 +129,7 @@ Proof.
{ iPureIntro. do 3 eexists. eapply copy_base_step'. 1-3: done. rewrite -Hscs_eq. done. }
(* we keep the base_step hypotheses to use the [base_step_wf] lemma below *)
iIntros (e_t' efs_t σ_t') "%Hhead_t".
- specialize (head_copy_inv _ _ _ _ _ _ _ _ Hhead_t) as (->&[((Hnotree&->&Hpoison&Hheapsome)&Hcontains_t)|(tr'&vr_t'&->&Hσ_t'&H3&[(Hcontains_t&H4&_)|([]%Hne&_&_)])]); first congruence.
+ specialize (head_copy_inv _ _ _ _ _ _ _ _ Hhead_t) as (->&tr'&vr_t'&->&Hσ_t'&H3&[(Hcontains_t&H4&_)|([]%Hne&_&_)]).
assert (vr_t' = vr_t) as -> by congruence.
assert (tr' = trs_t') as -> by congruence.
clear H3 H4.
diff --git a/theories/tree_borrows/step_laws/steps_retag.v b/theories/tree_borrows/step_laws/steps_retag.v
index 5ae3fb2147a46a3701a4bfa7911a41cfa0dd608b..2b2626cb4d19121a63ad6155c21b5551b42eb50b 100644
--- a/theories/tree_borrows/step_laws/steps_retag.v
+++ b/theories/tree_borrows/step_laws/steps_retag.v
@@ -21,8 +21,6 @@ Implicit Types l : loc.
Implicit Types f : fname.
-
-
(** ** Retags *)
Lemma tree_access_succeeds_heap_value σ b ak tg blk off sz :
diff --git a/theories/tree_borrows/step_laws/steps_source_only.v b/theories/tree_borrows/step_laws/steps_source_only.v
index c8f1ee6db2b25898a8abf53d54a1ab8f50a9ce18..b1c08a4e44195bf797e6d24ddb656cd18f4c5cd8 100644
--- a/theories/tree_borrows/step_laws/steps_source_only.v
+++ b/theories/tree_borrows/step_laws/steps_source_only.v
@@ -31,7 +31,7 @@ Lemma source_copy_any v_t v_rd sz l_hl l_rd t π Ψ tk :
l_hl.1 = l_rd.1 →
t $$ tk -∗
l_hl ↦s∗[tk]{t} v_t -∗
- (∀ v_res, l_hl ↦s∗[tk]{t} v_t -∗ t $$ tk -∗ (⌜v_res = v_rd⌠∨ ispoison v_res l_rd t sz) -∗ source_red #v_res π Ψ)%E -∗
+ (∀ v_res, l_hl ↦s∗[tk]{t} v_t -∗ t $$ tk -∗ (⌜v_res = v_rdâŒ) -∗ source_red #v_res Ï€ Ψ)%E -∗
source_red (Copy (Place l_rd t sz)) π Ψ.
Proof.
iIntros (Hnz Hread Hsameblk) "Htag Hs Hsim". eapply read_range_length in Hread as HH. subst sz.
@@ -40,9 +40,9 @@ Proof.
destruct Hp as (Hstrs_eq & Hsnp_eq & Hsnc_eq & Hscs_eq & Hwf_s & Hwf_t & Hdom_eq).
iModIntro. iDestruct "Hbor" as "(%M_call & %M_tag & %M_t & %M_s & Hbor)".
eapply pool_safe_implies in Ht_s as Hfoo. 2: done.
- destruct Hfoo as [(v_rd'&Hv_rd&Hcont&Hreadsome&_)|[(v_nil&Hread_nil&Hiszero)|(Hcont&Happly_none&Hmemsome)]]; last first.
+ destruct Hfoo as [(v_rd'&Hv_rd&Hcont&Hreadsome&_)|(v_nil&Hread_nil&Hiszero)].
2: lia.
- { (* poison *)
+(* { (* poison *)
pose proof Happly_none as Hn2.
rewrite /apply_within_trees in Hn2.
rewrite /trees_contain /trees_at_block in Hcont.
@@ -88,7 +88,7 @@ Proof.
1: simpl; lia. simpl. assert ((l_rd +â‚— Z.to_nat (l - l_rd.2) = (l_rd.1, l))) as ->. 2: done.
rewrite /shift_loc /=. simpl. f_equal. lia. }
1: iSplitR "Hsim"; last by iApply "Hsim".
- do 4 iExists _; destruct σ_s; iFrame. iFrame "Hsrel". done. }
+ do 4 iExists _; destruct σ_s; iFrame. iFrame "Hsrel". done. } *)
iPoseProof (bor_interp_readN_source_after_accesss with "Hbor Hs Htag") as "(%it&%tr&%Hit&%Htr&%Hown)".
1: exact Hread. 1: done. 1: done. 1: done. 1: exact Hreadsome.
opose proof* (read_range_list_to_heaplet_read_memory_strict) as READ_MEM. 1: exact Hread. 1: done.
@@ -122,7 +122,7 @@ Proof.
iModIntro.
iSplitR "Hs Htag Hsim".
- 2: { iApply ("Hsim" with "Hs Htag"). iLeft. by iPureIntro. }
+ 2: { iApply ("Hsim" with "Hs Htag"). by iPureIntro. }
iFrame "HP_t HP_s". iExists M_call, M_tag, M_t, M_s.
iFrame "Hc Htag_auth Htag_t_auth Htag_s_auth".
iSplitL "Htainted"; last iSplitL "Hpub_cid". 3: iSplit; last iSplit; last (iPureIntro; split_and!).
@@ -145,7 +145,7 @@ Proof.
- eapply (base_step_wf P_s). 2: exact Hwf_s. eapply copy_base_step'. 1: done. 2: exact READ_MEM. 2: exact Htrs'. done.
- done.
Qed.
-
+(*
Lemma source_copy_poison v_t v_rd sz l_hl l_rd t π Ψ tk v_read_earlier :
sz ≠0%nat → (* if it is 0, it will not be poison *)
read_range l_rd.2 sz (list_to_heaplet v_t l_hl.2) = Some v_rd →
@@ -183,7 +183,7 @@ Proof.
opose proof (disabled_tag_no_access _ false _ AccessRead _ (l_rd.2 + i) (l_rd.2, length v_rd) _ HH _) as HNone.
1: by eapply Hwf_s. 1: split; simpl in *; lia.
rewrite /memory_access HNone in Hreadsome. simpl in Hreadsome. by destruct Hreadsome.
-Qed.
+Qed. *)
Lemma source_copy_in_simulation v_t v_rd v_tgt sz l_hl l_rd t π Ψ tk :
@@ -198,12 +198,13 @@ Lemma source_copy_in_simulation v_t v_rd v_tgt sz l_hl l_rd t π Ψ tk :
Proof.
iIntros (Hsz Hrr Hhl).
eapply read_range_length in Hrr as Hszlen.
- iIntros "#[Hrel|Hpoison] Htk Hhl Hsim".
+ iIntros "#Hrel Htk Hhl Hsim".
+ rewrite /will_read_in_simulation.
- iPoseProof (value_rel_length with "Hrel") as "%Hlen".
iApply (source_copy_any with "Htk Hhl [Hsim]"). 1-3: done.
- iIntros (v_res) "Hhl Htk [->|#(%i&(%Hp1&%Hp2)&Hpoison2)]";
+ iIntros (v_res) "Hhl Htk ->";
iApply ("Hsim" with "Hhl Htk").
- + done.
+ + done. (*
+ rewrite Hp2. iApply big_sepL2_forall. iSplit. 1: iPureIntro; rewrite length_replicate; lia.
iIntros (k sc1 sc2 _ (->&HH2)%lookup_replicate_1). iApply sc_rel_source_poison.
- subst sz. iDestruct "Hpoison" as "(%Hlen&Hpoison)".
@@ -212,7 +213,7 @@ Proof.
iIntros (v_res) "Hhl Htk #(%i&(%Hp1&%Hp2)&Hpoison2)".
iApply ("Hsim" with "Hhl Htk").
rewrite Hp2. iApply big_sepL2_forall. iSplit. 1: iPureIntro; rewrite length_replicate; lia.
- iIntros (k sc1 sc2 _ (->&HH2)%lookup_replicate_1). iApply sc_rel_source_poison.
+ iIntros (k sc1 sc2 _ (->&HH2)%lookup_replicate_1). iApply sc_rel_source_poison. *)
Qed.
diff --git a/theories/tree_borrows/step_laws/steps_unique.v b/theories/tree_borrows/step_laws/steps_unique.v
index 3f067ec989d8b903d10a0add74c94c0e61ce7041..03cede0bdaed34d5d9a0235f5685500bdb5ed927 100644
--- a/theories/tree_borrows/step_laws/steps_unique.v
+++ b/theories/tree_borrows/step_laws/steps_unique.v
@@ -34,7 +34,7 @@ Lemma sim_copy v_t v_s v_rd_t v_rd_s sz l_hl l_rd t π tk Φ :
t $$ tk -∗
l_hl ↦s∗[tk]{t} v_s -∗
l_hl ↦t∗[tk]{t} v_t -∗
- (∀ v_res_s v_res_t, l_hl ↦s∗[tk]{t} v_s -∗ l_hl ↦t∗[tk]{t} v_t -∗ t $$ tk -∗ (⌜v_res_s = v_rd_s ∧ v_res_t = v_rd_t⌠∨ ispoison v_res_s l_rd t sz ∗ ispoison v_res_t l_rd t sz) -∗ #v_res_t ⪯{π} #v_res_s [{ Φ }])%E -∗
+ (∀ v_res_s v_res_t, l_hl ↦s∗[tk]{t} v_s -∗ l_hl ↦t∗[tk]{t} v_t -∗ t $$ tk -∗ (⌜v_res_s = v_rd_s ∧ v_res_t = v_rd_t⌠(*∨ ispoison v_res_s l_rd t sz ∗ ispoison v_res_t l_rd t sz*)) -∗ #v_res_t ⪯{π} #v_res_s [{ Φ }])%E -∗
(Copy (Place l_rd t sz)) ⪯{π} (Copy (Place l_rd t sz)) [{ Φ }].
Proof.
iIntros (Hsz Hreadt Hreads Hl) "Htk Hs Ht Hsim".
@@ -43,9 +43,9 @@ Proof.
destruct Hsafe as [Hpool Hsafe].
iPoseProof (bor_interp_get_pure with "Hbor") as "%Hp".
destruct Hp as (Hstrs_eq & Hsnp_eq & Hsnc_eq & Hscs_eq & Hwf_s & Hwf_t & Hdom_eq).
- specialize (pool_safe_implies Hsafe Hpool) as [(vr_s&Hreadmem&Hcontain_s&(trs_s'&Htrss)&_)|[(_&_&[]%Hsz)|(Hcontain_s&Hnotrees&Hisval)]];
+ specialize (pool_safe_implies Hsafe Hpool) as [(vr_s&Hreadmem&Hcontain_s&(trs_s'&Htrss)&_)|(_&_&[]%Hsz)];
pose proof Hcontain_s as Hcontain_t; rewrite trees_equal_same_tags in Hcontain_t; try done; last first.
- { (* We get poison *)
+(* { (* We get poison *)
assert (apply_within_trees (memory_access AccessRead (scs σ_s) t (l_rd.2, sz)) l_rd.1 (strs σ_t) = None) as Hnotrees_t.
{ destruct apply_within_trees eqn:HSome in |-*; try done.
eapply mk_is_Some, trees_equal_allows_more_access in HSome as (x&Hx); first by erewrite Hnotrees in Hx.
@@ -112,7 +112,7 @@ Proof.
iSplitR "Hsim".
{ do 4 iExists _; destruct σ_s; iFrame. iFrame "Hsrel". done. }
simpl. rewrite Hpoison. subst sz. iSplit; last done. iApply "Hsim".
- }
+ } *)
edestruct trees_equal_allows_more_access as (trs_t'&Htrst).
1: done. 1: eapply Hwf_s. 1,2,3: rewrite ?Hscs_eq; eapply Hwf_t. 1: done. 1: done. 1: by eapply mk_is_Some.
opose proof (trees_equal_preserved_by_access _ _ _ _ _ _ _ Hstrs_eq _ Htrss Htrst) as Hstrs_eq'.
@@ -123,7 +123,7 @@ Proof.
{ iPureIntro. do 3 eexists. eapply copy_base_step'. 1-3: done. rewrite -Hscs_eq. done. }
(* we keep the base_step hypotheses to use the [base_step_wf] lemma below *)
iIntros (e_t' efs_t σ_t') "%Hhead_t".
- specialize (head_copy_inv _ _ _ _ _ _ _ _ Hhead_t) as (->&[((Hnotree&->&Hpoison&Hheapsome)&Hcontains_t)|(tr'&vr_t'&->&Hσ_t'&H3&[(Hcontains_t&H4&_)|([]%Hsz&_&_)])]); first congruence.
+ specialize (head_copy_inv _ _ _ _ _ _ _ _ Hhead_t) as (->&tr'&vr_t'&->&Hσ_t'&H3&[(Hcontains_t&H4&_)|([]%Hsz&_&_)]).
assert (vr_t' = vr_t) as -> by congruence.
assert (tr' = trs_t') as -> by congruence.
clear H3 H4.
@@ -190,7 +190,7 @@ Proof.
}
iSplitL; last done.
- iApply ("Hsim" with "Hs Ht Htk"). iLeft. iPureIntro.
+ iApply ("Hsim" with "Hs Ht Htk"). iPureIntro.
eapply read_range_list_to_heaplet_read_memory_strict in Hreads. 2: done.
2: intros i Hi; specialize (Howns i Hi) as (_&H); exact H.
eapply read_range_list_to_heaplet_read_memory_strict in Hreadt. 2: done.
@@ -203,37 +203,37 @@ Qed.
Lemma sim_into_read_for_simulation v_res_t v_res_s v_rd_t v_rd_s l_rd t :
let sz := length v_rd_t in
value_rel v_rd_t v_rd_s -∗
- (⌜v_res_s = v_rd_s ∧ v_res_t = v_rd_t⌠∨ ispoison v_res_s l_rd t sz ∗ ispoison v_res_t l_rd t sz) -∗
+ (⌜v_res_s = v_rd_s ∧ v_res_t = v_rd_t⌠(*∨ ispoison v_res_s l_rd t sz ∗ ispoison v_res_t l_rd t sz*)) -∗
will_read_in_simulation v_rd_s v_res_t l_rd t.
Proof.
intros sz. iIntros "Hv1 Hor".
iPoseProof (value_rel_length with "Hv1") as "%Hlen".
- iDestruct "Hor" as "[(->&->)|(Hp1&Hp2)]".
- { iLeft. done. }
+ iDestruct "Hor" as "(->&->)".
+ { done. } (*
iRight. subst sz.
iDestruct "Hp2" as "(%i&(_&%HH)&_)". rewrite HH.
rewrite length_replicate Hlen. iSplit; first done.
iDestruct "Hp1" as "(%ip&(%H1&%H2)&Hpp)". iExists ip. iSplit; last done.
rewrite length_replicate. iPureIntro; split. 2: done.
- rewrite H2 length_replicate in H1. lia.
+ rewrite H2 length_replicate in H1. lia. *)
Qed.
-Lemma sim_read_result_value_rel v_res_t v_res_s v_rd_t v_rd_s l_rd t :
+Lemma sim_read_result_value_rel v_res_t v_res_s v_rd_t v_rd_s :
let sz := length v_rd_t in
value_rel v_rd_t v_rd_s -∗
- (⌜v_res_s = v_rd_s ∧ v_res_t = v_rd_t⌠∨ ispoison v_res_s l_rd t sz ∗ ispoison v_res_t l_rd t sz) -∗
+ (⌜v_res_s = v_rd_s ∧ v_res_t = v_rd_t⌠(* ∨ ispoison v_res_s l_rd t sz ∗ ispoison v_res_t l_rd t sz *) ) -∗
value_rel v_res_t v_res_s.
Proof.
intros sz. iIntros "Hv1 Hor".
iPoseProof (value_rel_length with "Hv1") as "%Hlen".
- iDestruct "Hor" as "[(->&->)|(Hp1&Hp2)]".
- { done. }
+ iDestruct "Hor" as "(->&->)".
+ { done. } (*
subst sz.
iDestruct "Hp2" as "(%i&(_&%HH)&_)". rewrite HH.
iDestruct "Hp1" as "(%ip&(%H1&%H2)&Hpp)". rewrite H2.
iApply big_sepL2_forall. iSplit.
{ rewrite length_replicate //. }
- iIntros (k x1 x2 (->&_)%lookup_replicate_1 (->&_)%lookup_replicate_1). done.
+ iIntros (k x1 x2 (->&_)%lookup_replicate_1 (->&_)%lookup_replicate_1). done. *)
Qed.
diff --git a/theories/tree_borrows/steps_access.v b/theories/tree_borrows/steps_access.v
deleted file mode 100755
index e894619c123a49fdb77b0cfb93a8c0de000e1060..0000000000000000000000000000000000000000
--- a/theories/tree_borrows/steps_access.v
+++ /dev/null
@@ -1,282 +0,0 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
-From simuliris.tree_borrows Require Export defs steps_foreach.
-From iris.prelude Require Import options.
-
-(* Kept for now as an easy reference of the lemmas that SB needed
-Lemma access1_in_stack stk kind t cids n stk' :
- access1 stk kind t cids = Some (n, stk') →
- ∃ it, it ∈ stk ∧ it.(tg) = t ∧ it.(perm) ≠Disabled.
-Proof.
- rewrite /access1. case find_granting as [gip|] eqn:Eq1; [|done].
- apply fmap_Some in Eq1 as [[i it] [(IN & [GR Eq] & FR)%list_find_Some EQ]].
- intros ?. exists it. split; last split; [|done|].
- - by eapply elem_of_list_lookup_2.
- - intros Eq1. by rewrite Eq1 in GR.
-Qed.
-
-Lemma access1_tagged_sublist stk kind bor cids n stk' :
- access1 stk kind bor cids = Some (n, stk') → tagged_sublist stk' stk.
-Proof.
- rewrite /access1. case find_granting as [gip|]; [|done]. simpl.
- destruct kind.
- - case replace_check as [stk1|] eqn:Eq; [|done].
- simpl. intros. simplify_eq.
- rewrite -{2}(take_drop gip.1 stk). apply tagged_sublist_app; [|done].
- move : Eq. by apply replace_check_tagged_sublist.
- - case find_first_write_incompatible as [idx|]; [|done]. simpl.
- case remove_check as [stk1|] eqn:Eq; [|done].
- simpl. intros. simplify_eq.
- rewrite -{2}(take_drop gip.1 stk). apply tagged_sublist_app; [|done].
- move : Eq. by apply remove_check_tagged_sublist.
-Qed.
-
-Lemma access1_non_empty stk kind bor cids n stk' :
- access1 stk kind bor cids = Some (n, stk') → stk' ≠[].
-Proof.
- rewrite /access1. case find_granting as [gip|] eqn:Eq1; [|done].
- apply fmap_Some in Eq1 as [[i it] [[IN ?]%list_find_Some EQ]].
- subst gip; simpl.
- have ?: drop i stk ≠[].
- { move => ND. move : IN. by rewrite -(Nat.add_0_r i) -(lookup_drop) ND /=. }
- destruct kind.
- - case replace_check as [stk1|]; [|done].
- simpl. intros ?. simplify_eq => /app_nil [_ ?]. by subst.
- - case find_first_write_incompatible as [?|]; [|done]. simpl.
- case remove_check as [?|]; [|done].
- simpl. intros ?. simplify_eq => /app_nil [_ ?]. by subst.
-Qed.
-
-Lemma for_each_access1 α nxtc l n tg kind α' :
- for_each α l n false
- (λ stk, nstk' ↠access1 stk kind tg nxtc; Some nstk'.2) = Some α' →
- ∀ (l: loc) stk', α' !! l = Some stk' → ∃ stk, α !! l = Some stk ∧
- tagged_sublist stk' stk ∧ (stk ≠[] → stk' ≠[]).
-Proof.
- intros EQ. destruct (for_each_lookup _ _ _ _ _ EQ) as [EQ1 [EQ2 EQ3]].
- intros l1 stk1 Eq1.
- case (decide (l1.1 = l.1)) => [Eql|NEql];
- [case (decide (l.2 ≤ l1.2 < l.2 + n)) => [[Le Lt]|NIN]|].
- - have Eql2: l1 = l +â‚— Z.of_nat (Z.to_nat (l1.2 - l.2)). {
- destruct l, l1. move : Eql Le => /= -> ?.
- rewrite /shift_loc /= Z2Nat.id; [|lia]. f_equal. lia. }
- destruct (EQ2 (Z.to_nat (l1.2 - l.2)) stk1)
- as [stk [Eq [[n1 stk'] [Eq' Eq0]]%bind_Some]];
- [rewrite -(Nat2Z.id n) -Z2Nat.inj_lt; lia|by rewrite -Eql2|].
- exists stk. split; [by rewrite Eql2|]. simplify_eq.
- split; [by eapply access1_tagged_sublist|intros; by eapply access1_non_empty].
- - exists stk1. split; [|done]. rewrite -EQ3; [done|].
- intros i Lt Eq. apply NIN. rewrite Eq /=. lia.
- - exists stk1. split; [|done]. rewrite -EQ3; [done|].
- intros i Lt Eq. apply NEql. by rewrite Eq.
-Qed.
-
-Lemma for_each_access1_non_empty α cids l n tg kind α' :
- for_each α l n false
- (λ stk, nstk' ↠access1 stk kind tg cids; Some nstk'.2) = Some α' →
- wf_non_empty α → wf_non_empty α'.
-Proof.
- move => /for_each_access1 EQ1 WF ?? /EQ1 [? [? [? NE]]]. by eapply NE, WF.
-Qed.
-
-Lemma access1_stack_item_tagged_NoDup stk kind bor cids n stk' :
- access1 stk kind bor cids = Some (n, stk') →
- stack_item_tagged_NoDup stk → stack_item_tagged_NoDup stk'.
-Proof.
- rewrite /access1. case find_granting as [gip|] eqn:Eq1; [|done].
- apply fmap_Some in Eq1 as [[i it] [[IN ?]%list_find_Some EQ]].
- subst gip; simpl.
- destruct kind.
- - case replace_check as [stk1|] eqn:Eqc ; [|done].
- simpl. intros ?. simplify_eq.
- rewrite -{1}(take_drop n stk). move : Eqc.
- by apply replace_check_stack_item_tagged_NoDup_2.
- - case find_first_write_incompatible as [?|]; [|done]. simpl.
- case remove_check as [?|] eqn:Eqc ; [|done].
- simpl. intros ?. simplify_eq.
- rewrite -{1}(take_drop n stk). move : Eqc.
- apply remove_check_stack_item_tagged_NoDup_2.
-Qed.
-
-Lemma access1_read_eq it1 it2 stk tag t cids n stk':
- stack_item_tagged_NoDup stk →
- access1 stk AccessRead tag cids = Some (n, stk') →
- it1 ∈ stk → it2 ∈ stk' →
- it2.(perm) ≠Disabled →
- it1.(tg) = Tagged t → it2.(tg) = Tagged t → it1 = it2.
-Proof.
- intros ND ACC.
- have ND' := access1_stack_item_tagged_NoDup _ _ _ _ _ _ ACC ND.
- move : ACC. rewrite /= /access1 /=.
- case find_granting as [[idx pm]|] eqn:Eq1; [|done]. simpl.
- case replace_check as [stk1|] eqn:Eq2; [|done].
- simpl. intros ?. simplify_eq. intros In1.
- have SUB:= replace_check_tagged_sublist _ _ _ Eq2.
- rewrite elem_of_app. intros In2 ND2.
- destruct In2 as [In2|In2].
- - specialize (SUB _ In2) as (it3 & In3 & Eqt3 & Eqp3 & ND3).
- specialize (ND3 ND2).
- have ?: it3 = it2.
- { destruct it2, it3. simpl in *. by simplify_eq. }
- subst it3.
- apply (stack_item_tagged_NoDup_eq _ _ _ _ ND); [done|].
- rewrite -{1}(take_drop n stk) elem_of_app. by left.
- - apply (stack_item_tagged_NoDup_eq _ _ _ _ ND); [done|].
- rewrite -{1}(take_drop n stk) elem_of_app. by right.
-Qed.
-
-Lemma for_each_access1_stack_item α nxtc cids nxtp l n tg kind α' :
- for_each α l n false
- (λ stk, nstk' ↠access1 stk kind tg cids; Some nstk'.2) = Some α' →
- wf_stacks α nxtp nxtc → wf_stacks α' nxtp nxtc.
-Proof.
- intros ACC WF l' stk' Eq'.
- destruct (for_each_access1 _ _ _ _ _ _ _ ACC _ _ Eq') as [stk [Eq [SUB NN]]].
- split.
- - move => ? /SUB [? [IN [-> [-> ?]]]]. by apply (proj1 (WF _ _ Eq) _ IN).
- - clear SUB NN.
- destruct (for_each_lookup_case _ _ _ _ _ ACC _ _ _ Eq Eq') as [?|[Eqf ?]].
- { subst. by apply (WF _ _ Eq). }
- destruct (access1 stk kind tg cids) as [[]|] eqn:Eqf'; [|done].
- simpl in Eqf. simplify_eq.
- eapply access1_stack_item_tagged_NoDup; eauto. by apply (WF _ _ Eq).
-Qed.
-*)
-
-(** Dealloc *)
-(*
-Lemma for_each_dealloc_lookup α l n f α' :
- for_each α l n true f = Some α' →
- (∀ (i: nat), (i < n)%nat → α' !! (l +ₗ i) = None) ∧
- (∀ (l': loc), (∀ (i: nat), (i < n)%nat → l' ≠l +ₗ i) → α' !! l' = α !! l').
-Proof.
- revert α. induction n as [|n IH]; intros α; simpl.
- { move => [<-]. split; intros ??; by [lia|]. }
- case (α !! (l +ₗ n)) as [stkn|] eqn:Eqn; [|done] => /=.
- case f as [stkn'|] eqn: Eqn'; [|done] => /= /IH [IH1 IH2]. split.
- - intros i Lt. case (decide (i = n)) => Eq'; [subst i|].
- + rewrite IH2; [by apply lookup_delete|].
- move => ?? /shift_loc_inj /Nat2Z.inj ?. by lia.
- + apply IH1. by lia.
- - intros l' Lt. rewrite IH2.
- + rewrite lookup_delete_ne; [done|]. move => Eql'. apply (Lt n); by [lia|].
- + move => ??. apply Lt. lia.
-Qed.
-
-Lemma for_each_dealloc_lookup_Some α l n f α' :
- for_each α l n true f = Some α' →
- ∀ l' stk', α' !! l' = Some stk' →
- (∀ i : nat, (i < n)%nat → l' ≠l +ₗ i) ∧ α !! l' = Some stk'.
-Proof.
- intros EQ. destruct (for_each_dealloc_lookup _ _ _ _ _ EQ) as [EQ1 EQ2].
- intros l1 stk1 Eq1.
- destruct (block_case l l1 n) as [NEql|Eql].
- - rewrite -EQ2 //.
- - destruct Eql as (i & Lt & ?). subst l1. rewrite EQ1 // in Eq1.
-Qed.
-*)
-
-Lemma free_mem_lookup l n h :
- (∀ (i: nat), (i < n)%nat → free_mem l n h !! (l +ₗ i) = None) ∧
- (∀ (l': loc), (∀ (i: nat), (i < n)%nat → l' ≠l +ₗ i) →
- free_mem l n h !! l' = h !! l').
-Proof.
- revert l. induction n as [|n IH]; intros l; simpl.
- { split; intros ??; by [lia|]. } split.
- - intros i Lt. destruct i as [|i].
- + rewrite shift_loc_0 lookup_delete //.
- + rewrite lookup_delete_ne.
- * specialize (IH (l +â‚— 1))as [IH _].
- rewrite (_: l +â‚— S i = l +â‚— 1 +â‚— i).
- { apply IH. lia. }
- { rewrite shift_loc_assoc. f_equal. lia. }
- * rewrite -{1}(shift_loc_0 l).
- move => /shift_loc_inj ?. lia.
- - intros l' Lt.
- rewrite lookup_delete_ne.
- + apply IH. intros i Lti.
- rewrite (_: l +â‚— 1 +â‚— i = l +â‚— S i).
- * apply Lt. lia.
- * rewrite shift_loc_assoc. f_equal. lia.
- + rewrite -(shift_loc_0_nat l). intros ?. subst l'. apply (Lt O); [lia|done].
-Qed.
-
-Lemma free_mem_lookup_case l' l n h :
- (∀ i : nat, (i < n)%nat → l' ≠l +ₗ i) ∧ free_mem l n h !! l' = h !! l' ∨
- ∃ i : nat, (i < n)%nat ∧ l' = l +ₗ i ∧ free_mem l n h !! (l +ₗ i) = None.
-Proof.
- destruct (free_mem_lookup l n h) as [EQ1 EQ2].
- destruct (block_case l l' n) as [NEql|Eql].
- - left. rewrite -EQ2 //.
- - right. destruct Eql as (i & Lt & ?). exists i. do 2 (split; [done|]).
- subst l'. by apply EQ1.
-Qed.
-
-Lemma free_mem_dom_inv l' l n h:
- l' ∈ dom (free_mem l n h) →
- l' ∈ dom h ∧
- (∀ i : nat, (i < n)%nat → l' ≠l +ₗ i) ∧ free_mem l n h !! l' = h !! l'.
-Proof.
- intros [? EqD]%elem_of_dom.
- destruct (free_mem_lookup_case l' l n h) as [Eqn|(i & Lt & ? & EqN)].
- - split; [|done]. apply elem_of_dom. destruct Eqn as [? Eqn].
- rewrite -Eqn. by eexists.
- - exfalso. subst l'. by rewrite EqD in EqN.
-Qed.
-
-
-
-Lemma init_mem_lookup_fresh_poison blk off (n:nat) h :
- 0 ≤ off ∧ off < n →
- init_mem (blk, 0) n h !! (blk, off) = Some ScPoison.
-Proof.
- intros (Hpos & Hlt).
- pose proof (init_mem_lookup (blk, 0) n h) as (Hinit1&_).
- ospecialize (Hinit1 (Z.to_nat off) _); first lia.
- rewrite /= /shift_loc /= Z.add_0_l Z2Nat.id // in Hinit1.
-Qed.
-
-Lemma init_mem_lookup_fresh_None blk off (n:nat) h :
- (forall off, (blk, off) ∉ dom h) →
- (off < 0 ∨ n ≤ off) →
- init_mem (blk, 0) n h !! (blk, off) = None.
-Proof.
- intros Hfresh Hout.
- pose proof (init_mem_lookup (blk, 0) n h) as (_&Hinit2).
- rewrite (Hinit2 (blk, off)).
- + eapply not_elem_of_dom, Hfresh.
- + intros i Hlt.
- rewrite /= /shift_loc /= Z.add_0_l.
- intros [= ->]. destruct Hout as [Hout|Hout]; lia.
-Qed.
-
-Lemma init_mem_lookup_fresh_old blk blk' off (n:nat) h :
- blk ≠blk' →
- init_mem (blk, 0) n h !! (blk', off) = h !! (blk', off).
-Proof.
- intros Hfresh.
- pose proof (init_mem_lookup (blk, 0) n h) as (_&Hinit2).
- apply Hinit2.
- intros ? _ [=]. done.
-Qed.
-
-
-Lemma init_mem_lookup_fresh_inv blk blk' off (n:nat) h k :
- (forall off, (blk, off) ∉ dom h) →
- init_mem (blk, 0) n h !! (blk', off) = k →
- (k = Some ScPoison ∧ blk = blk' ∧ 0 ≤ off ∧ off < n)
-∨ (k = None ∧ blk = blk' ∧ (off < 0 ∨ n ≤ off))
-∨ (k = h !! (blk', off) ∧ blk ≠blk').
-Proof.
- intros Hfresh Hinit.
- destruct (decide (blk = blk')) as [Heqblk|Hne].
- 1: subst blk'; destruct (decide (0 ≤ off)) as [Hpos|Hneg].
- 1: destruct (decide (off < n)) as [Hlt|Hge].
- { left. subst k. split_and!; try done. by rewrite init_mem_lookup_fresh_poison. }
- 1-2: right; left; split_and!; try done; last lia.
- 1-2: subst k; rewrite init_mem_lookup_fresh_None; try done; lia.
- { right. right. split; last done. subst k. by apply init_mem_lookup_fresh_old. }
-Qed.
-
diff --git a/theories/tree_borrows/steps_foreach.v b/theories/tree_borrows/steps_foreach.v
index fd2b12066bcc5259093ccdf83fd12d00ddfaabcc..ba77c310d12e413f4beb5df0e52883e99a37a252 100755
--- a/theories/tree_borrows/steps_foreach.v
+++ b/theories/tree_borrows/steps_foreach.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
-
From simuliris.tree_borrows Require Export defs.
From iris.prelude Require Import options.
@@ -139,3 +135,105 @@ Lemma extend_trees_lookup_ne trs tg off sz blk blk' :
Proof. apply lookup_insert_ne. Qed.
+Lemma free_mem_lookup l n h :
+ (∀ (i: nat), (i < n)%nat → free_mem l n h !! (l +ₗ i) = None) ∧
+ (∀ (l': loc), (∀ (i: nat), (i < n)%nat → l' ≠l +ₗ i) →
+ free_mem l n h !! l' = h !! l').
+Proof.
+ revert l. induction n as [|n IH]; intros l; simpl.
+ { split; intros ??; by [lia|]. } split.
+ - intros i Lt. destruct i as [|i].
+ + rewrite shift_loc_0 lookup_delete //.
+ + rewrite lookup_delete_ne.
+ * specialize (IH (l +â‚— 1))as [IH _].
+ rewrite (_: l +â‚— S i = l +â‚— 1 +â‚— i).
+ { apply IH. lia. }
+ { rewrite shift_loc_assoc. f_equal. lia. }
+ * rewrite -{1}(shift_loc_0 l).
+ move => /shift_loc_inj ?. lia.
+ - intros l' Lt.
+ rewrite lookup_delete_ne.
+ + apply IH. intros i Lti.
+ rewrite (_: l +â‚— 1 +â‚— i = l +â‚— S i).
+ * apply Lt. lia.
+ * rewrite shift_loc_assoc. f_equal. lia.
+ + rewrite -(shift_loc_0_nat l). intros ?. subst l'. apply (Lt O); [lia|done].
+Qed.
+
+Lemma free_mem_lookup_case l' l n h :
+ (∀ i : nat, (i < n)%nat → l' ≠l +ₗ i) ∧ free_mem l n h !! l' = h !! l' ∨
+ ∃ i : nat, (i < n)%nat ∧ l' = l +ₗ i ∧ free_mem l n h !! (l +ₗ i) = None.
+Proof.
+ destruct (free_mem_lookup l n h) as [EQ1 EQ2].
+ destruct (block_case l l' n) as [NEql|Eql].
+ - left. rewrite -EQ2 //.
+ - right. destruct Eql as (i & Lt & ?). exists i. do 2 (split; [done|]).
+ subst l'. by apply EQ1.
+Qed.
+
+Lemma free_mem_dom_inv l' l n h:
+ l' ∈ dom (free_mem l n h) →
+ l' ∈ dom h ∧
+ (∀ i : nat, (i < n)%nat → l' ≠l +ₗ i) ∧ free_mem l n h !! l' = h !! l'.
+Proof.
+ intros [? EqD]%elem_of_dom.
+ destruct (free_mem_lookup_case l' l n h) as [Eqn|(i & Lt & ? & EqN)].
+ - split; [|done]. apply elem_of_dom. destruct Eqn as [? Eqn].
+ rewrite -Eqn. by eexists.
+ - exfalso. subst l'. by rewrite EqD in EqN.
+Qed.
+
+
+
+Lemma init_mem_lookup_fresh_poison blk off (n:nat) h :
+ 0 ≤ off ∧ off < n →
+ init_mem (blk, 0) n h !! (blk, off) = Some ScPoison.
+Proof.
+ intros (Hpos & Hlt).
+ pose proof (init_mem_lookup (blk, 0) n h) as (Hinit1&_).
+ ospecialize (Hinit1 (Z.to_nat off) _); first lia.
+ rewrite /= /shift_loc /= Z.add_0_l Z2Nat.id // in Hinit1.
+Qed.
+
+Lemma init_mem_lookup_fresh_None blk off (n:nat) h :
+ (forall off, (blk, off) ∉ dom h) →
+ (off < 0 ∨ n ≤ off) →
+ init_mem (blk, 0) n h !! (blk, off) = None.
+Proof.
+ intros Hfresh Hout.
+ pose proof (init_mem_lookup (blk, 0) n h) as (_&Hinit2).
+ rewrite (Hinit2 (blk, off)).
+ + eapply not_elem_of_dom, Hfresh.
+ + intros i Hlt.
+ rewrite /= /shift_loc /= Z.add_0_l.
+ intros [= ->]. destruct Hout as [Hout|Hout]; lia.
+Qed.
+
+Lemma init_mem_lookup_fresh_old blk blk' off (n:nat) h :
+ blk ≠blk' →
+ init_mem (blk, 0) n h !! (blk', off) = h !! (blk', off).
+Proof.
+ intros Hfresh.
+ pose proof (init_mem_lookup (blk, 0) n h) as (_&Hinit2).
+ apply Hinit2.
+ intros ? _ [=]. done.
+Qed.
+
+
+Lemma init_mem_lookup_fresh_inv blk blk' off (n:nat) h k :
+ (forall off, (blk, off) ∉ dom h) →
+ init_mem (blk, 0) n h !! (blk', off) = k →
+ (k = Some ScPoison ∧ blk = blk' ∧ 0 ≤ off ∧ off < n)
+∨ (k = None ∧ blk = blk' ∧ (off < 0 ∨ n ≤ off))
+∨ (k = h !! (blk', off) ∧ blk ≠blk').
+Proof.
+ intros Hfresh Hinit.
+ destruct (decide (blk = blk')) as [Heqblk|Hne].
+ 1: subst blk'; destruct (decide (0 ≤ off)) as [Hpos|Hneg].
+ 1: destruct (decide (off < n)) as [Hlt|Hge].
+ { left. subst k. split_and!; try done. by rewrite init_mem_lookup_fresh_poison. }
+ 1-2: right; left; split_and!; try done; last lia.
+ 1-2: subst k; rewrite init_mem_lookup_fresh_None; try done; lia.
+ { right. right. split; last done. subst k. by apply init_mem_lookup_fresh_old. }
+Qed.
+
diff --git a/theories/tree_borrows/steps_inv.v b/theories/tree_borrows/steps_inv.v
index 998037c114e8cfe56efb74d009881fbdbe3d6702..bfbd451b3aca0a6a9588eec7cb7096b585d2461d 100755
--- a/theories/tree_borrows/steps_inv.v
+++ b/theories/tree_borrows/steps_inv.v
@@ -17,11 +17,11 @@ Proof. intros Hhead. inv_base_step. eauto 8. Qed.
Lemma head_copy_inv (P : prog) l bor sz σ σ' e' efs :
base_step P (Copy (Place l bor sz)) σ e' σ' efs →
efs = [] ∧
-((apply_within_trees (memory_access AccessRead (scs σ) bor (l.2, sz)) l.1 σ.(strs) = None ∧
+((*(apply_within_trees (memory_access AccessRead (scs σ) bor (l.2, sz)) l.1 σ.(strs) = None ∧
σ = σ' ∧
e' = ValR (replicate sz ScPoison)%V ∧
is_Some (read_mem l sz σ.(shp))) ∧
- trees_contain bor σ.(strs) l.1 ∨
+ trees_contain bor σ.(strs) l.1 ∨ *)
∃ trs' (v':value),
e' = (v')%E ∧
σ' = mkState σ.(shp) trs' σ.(scs) σ.(snp) σ.(snc) ∧
diff --git a/theories/tree_borrows/steps_preserve.v b/theories/tree_borrows/steps_preserve.v
index 15d61d4562bd31bc767bfdaa1843c1a5ff8d4ba2..0bddf4e972046c2809aedeaf9b99c1f64c177853 100644
--- a/theories/tree_borrows/steps_preserve.v
+++ b/theories/tree_borrows/steps_preserve.v
@@ -2,9 +2,18 @@ From iris.prelude Require Import prelude options.
From simuliris.tree_borrows Require Import lang_base notation bor_semantics tree tree_lemmas bor_lemmas defs.
From iris.prelude Require Import options.
+(** Lemmas about borrow steps preserving properties of the tree.
+ This is related to [steps_wf.v], but where [steps_wf] states lemmas about
+ preservation of well-formedness by all borrow steps, these are lower-level.
+ Many lemmas here will seem trivial (e.g. if you have a tree in which a tag
+ is unique and you apply a tag-preserving function, the tag is still unique). *)
+
(* Any function that operates only on permissions (which is all transitions steps)
leaves the tag and protector unchanged which means that most of the preservation lemmas
- are trivial once we get to the level of items *)
+ are trivial once we get to the level of items.
+ Preservation of metadata includes preservation of relationships since
+ the parent-child relation is defined by the relative location of tags
+ (which are metadata). *)
Definition preserve_item_metadata (fn:item -> option item) :=
forall it it', fn it = Some it' -> it.(itag) = it'.(itag) /\ it.(iprot) = it'.(iprot) /\ it.(initp) = it'.(initp).
@@ -140,9 +149,10 @@ Proof.
erewrite new_item_has_tag; done.
Qed.
+(** Detailed specification of the effects of one access.
+ This is to trees what [mem_apply_range'_spec] is to ranges. *)
Lemma apply_access_spec_per_node
{tr affected_tag access_tag pre fn cids range tr'}
- (*(ExAcc : tree_contains access_tag tr)*)
(ExAff : tree_contains affected_tag tr)
(UnqAff : tree_item_determined affected_tag pre tr)
(Access : tree_apply_access fn cids access_tag range tr = Some tr')
@@ -182,147 +192,8 @@ Proof.
tauto.
Qed.
-Lemma bor_local_step_preserves_contains
- {tg tr tr' cids cids' evt}
- (Ex : tree_contains tg tr)
- (Step : bor_local_step
- tr cids
- evt
- tr' cids')
- : tree_contains tg tr'.
-Proof.
- inversion Step as [????? ACC| | |]; subst.
- - (* Access *)
- erewrite <- access_preserves_tags; [eassumption|exact ACC].
- - (* InitCall *) assumption.
- - (* EndCall *) assumption.
- - (* Retag *)
- eapply insertion_preserves_tags; eauto.
-Qed.
-
-Lemma bor_local_step_retag_produces_contains_determined
- {tgp tg tr tr' cids cids' pk im rk cid}
- (Step : bor_local_step
- tr cids
- (RetagBLEvt tgp tg pk im cid rk)
- tr' cids')
- : ∃ it, create_new_item tg pk im rk cid = Some it ∧ tree_contains tg tr'
- /\ tree_item_determined tg it tr'.
-Proof.
- inversion Step as [| | |?????????? (it&Hit&RETAG_EFFECT)%bind_Some]; subst.
- exists it. split; first done.
- split.
- - eapply (insertion_contains) with (cids := cids'); first done.
- eapply bind_Some. by exists it.
- - injection RETAG_EFFECT; intros; subst.
- eapply inserted_determined. 2: done.
- erewrite new_item_has_tag. 2: exact Hit. done.
-Qed.
-
-Lemma bor_local_step_preserves_determined_easy
- {tg tr it tr' cids cids' evt}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg it tr)
- (Step : bor_local_step tr cids evt tr' cids')
- : exists it',
- tree_item_determined tg it' tr'
- /\ match evt with
- | AccessBLEvt _ _ _ => iprot it = iprot it'
- | InitCallBLEvt _
- | EndCallBLEvt _
- | RetagBLEvt _ _ _ _ _ _
- | SilentBLEvt => it = it'
- end.
-Proof.
- inversion Step as [???? EXISTS_TAG ACC| | |????????? FRESH_CHILD RETAG_EFFECT]; subst.
- - (* Access *)
- destruct (apply_access_spec_per_node Ex Unq ACC) as [?[Spec[_?]]].
- eexists; split; eauto.
- symmetry in Spec. eapply item_apply_access_preserves_metadata; exact Spec.
- - eexists; split; [|reflexivity]; assumption.
- - eexists; split; [|reflexivity]; assumption.
- - (* Retag *)
- eexists; split; [|reflexivity].
- eapply create_child_preserves_determined; [|exact Unq|exact RETAG_EFFECT].
- intro; subst. destruct (FRESH_CHILD Ex).
-Qed.
-
-Lemma bor_local_step_eqv_rel
- {tg tg' tr tr' cids cids' evt}
- (Ex : tree_contains tg tr)
- (Ex' : tree_contains tg' tr)
- (Step : bor_local_step tr cids evt tr' cids')
- : ParentChildIn tg tg' tr <-> ParentChildIn tg tg' tr'.
-Proof.
- inversion Step as [????? ACC| | |????????? FRESH_CHILD (x&Hx&RETAG_EFFECT)%bind_Some]; subst.
- - (* Access *)
- rewrite access_eqv_rel; [|apply ACC].
- tauto.
- - tauto.
- - tauto.
- - (* Retag *)
- injection RETAG_EFFECT; intros; subst.
- rewrite <- insert_eqv_rel.
- * tauto.
- * erewrite new_item_has_tag; last done.
- intro; subst; destruct (FRESH_CHILD Ex).
- * erewrite new_item_has_tag; last done.
- intro; subst; destruct (FRESH_CHILD Ex').
-Qed.
-
-Lemma bor_local_step_eqv_imm_rel
- {tg tg' tr tr' cids cids' evt}
- (Ex : tree_contains tg tr)
- (Ex' : tree_contains tg' tr)
- (Step : bor_local_step tr cids evt tr' cids')
- : ImmediateParentChildIn tg tg' tr <-> ImmediateParentChildIn tg tg' tr'.
-Proof.
- inversion Step as [????? ACC| | |????????? FRESH_CHILD (x&Hx&RETAG_EFFECT)%bind_Some]; subst.
- - (* Access *)
- rewrite access_eqv_immediate_rel; [|apply ACC].
- tauto.
- - tauto.
- - tauto.
- - (* Retag *)
- injection RETAG_EFFECT; intros; subst.
- rewrite <- insert_eqv_imm_rel.
- * tauto.
- * erewrite new_item_has_tag; last done.
- intro; subst; destruct (FRESH_CHILD Ex).
- * erewrite new_item_has_tag; last done.
- intro; subst; destruct (FRESH_CHILD Ex').
-Qed.
-
-Lemma bor_local_step_retag_produces_rel
- {tgp tg tr tr' cids cids' pk im rk cid}
- (Step : bor_local_step
- tr cids
- (RetagBLEvt tgp tg pk im rk cid)
- tr' cids')
- : ParentChildIn tgp tg tr'.
-Proof.
- inversion Step as [????? ACC| | |???????? EXISTS_PARENT FRESH_CHILD (x&Hx&RETAG_EFFECT)%bind_Some]; subst.
- injection RETAG_EFFECT; intros; subst.
- eapply insert_produces_ParentChild.
- * eapply new_item_has_tag. done.
- * intro; subst; destruct (FRESH_CHILD EXISTS_PARENT).
-Qed.
-
-Lemma bor_local_step_retag_order_nonparent
- {tgp tg tg' tr tr' cids cids' pk im rk cid}
- (Ex' : tree_contains tg' tr)
- (Step : bor_local_step
- tr cids
- (RetagBLEvt tgp tg pk im rk cid)
- tr' cids')
- : ~ParentChildIn tg tg' tr'.
-Proof.
- inversion Step as [????? ACC| | |???????? EXISTS_PARENT FRESH_CHILD (x&Hx&RETAG_EFFECT)%bind_Some]; subst.
- injection RETAG_EFFECT; intros; subst.
- eapply insertion_order_nonparent with (cids:=cids'). 1-3: eassumption.
- eapply bind_Some; by eexists.
-Qed.
-
+(** Reachability of a state behaves as expected in between applications
+ of functions compatible with [reach]. *)
Lemma apply_access_perm_preserves_backward_reach
{pre post kind rel b p0}
(Access : apply_access_perm kind rel b pre = Some post)
@@ -442,415 +313,6 @@ Proof.
- rewrite Spec; tauto.
Qed.
-Lemma bor_local_step_preserves_backward_reach
- {tg tr tr' cids cids' pre post evt p0 z}
- (Ex : tree_contains tg tr)
- (UnqPre : tree_item_determined tg pre tr)
- (Step : bor_local_step tr cids evt tr' cids')
- (UnqPost : tree_item_determined tg post tr')
- : reach p0 (item_perm_at_loc pre z) -> reach p0 (item_perm_at_loc post z).
-Proof.
- inversion Step as [???? EXISTS_TAG ACC| | |]; subst.
- - apply (memory_access_preserves_backward_reach Ex UnqPre EXISTS_TAG ACC UnqPost).
- - rewrite (tree_determined_unify Ex UnqPre UnqPost); tauto.
- - rewrite (tree_determined_unify Ex UnqPre UnqPost); tauto.
- - pose proof (bor_local_step_preserves_contains Ex Step) as ExPost'.
- pose proof (bor_local_step_preserves_determined_easy Ex UnqPre Step) as [it' [UnqPost' Eq]]; subst; simpl in UnqPost'.
- rewrite (tree_determined_unify ExPost' UnqPost' UnqPost); tauto.
-Qed.
-
-Lemma bor_local_step_preserves_forward_unreach
- {tg tr tr' cids cids' pre post evt p0 z}
- (Ex : tree_contains tg tr)
- (UnqPre : tree_item_determined tg pre tr)
- (Step : bor_local_step tr cids evt tr' cids')
- (UnqPost : tree_item_determined tg post tr')
- : ~reach (item_perm_at_loc pre z) p0 -> ~reach (item_perm_at_loc post z) p0.
-Proof.
- inversion Step as [???? EXISTS_TAG ACC| | |]; subst.
- - apply (memory_access_preserves_forward_unreach Ex UnqPre EXISTS_TAG ACC UnqPost).
- - rewrite (tree_determined_unify Ex UnqPre UnqPost); tauto.
- - rewrite (tree_determined_unify Ex UnqPre UnqPost); tauto.
- - pose proof (bor_local_step_preserves_contains Ex Step) as ExPost'.
- pose proof (bor_local_step_preserves_determined_easy Ex UnqPre Step) as [it' [UnqPost' Eq]]; subst; simpl in UnqPost'.
- rewrite (tree_determined_unify ExPost' UnqPost' UnqPost); tauto.
-Qed.
-
-Lemma bor_local_step_preserves_protected_freeze_like
- {tg tr tr' cids cids' pre post evt z}
- (Ex : tree_contains tg tr)
- (UnqPre : tree_item_determined tg pre tr)
- (Prot : protector_is_active (iprot pre) cids)
- (Step : bor_local_step tr cids evt tr' cids')
- (UnqPost : tree_item_determined tg post tr')
- : freeze_like (item_perm_at_loc pre z) -> freeze_like (item_perm_at_loc post z).
-Proof.
- inversion Step as [???? EXISTS_TAG ACC| | |]; subst.
- - apply (memory_access_preserves_protected_freeze_like Ex UnqPre EXISTS_TAG Prot ACC UnqPost).
- - rewrite (tree_determined_unify Ex UnqPre UnqPost); tauto.
- - rewrite (tree_determined_unify Ex UnqPre UnqPost); tauto.
- - pose proof (bor_local_step_preserves_contains Ex Step) as ExPost'.
- pose proof (bor_local_step_preserves_determined_easy Ex UnqPre Step) as [it' [UnqPost' Eq]]; subst; simpl in UnqPost'.
- rewrite (tree_determined_unify ExPost' UnqPost' UnqPost); tauto.
-Qed.
-
-Lemma seq_always_build_forward
- {invariant invariant'}
- {tr cids evts tr' cids'}
- (INV0 : invariant'.(seq_inv) tr cids)
- (Preserve : forall tr cids tr' cids' evt,
- bor_local_step tr cids evt tr' cids' ->
- invariant.(seq_inv) tr cids ->
- invariant'.(seq_inv) tr cids ->
- invariant'.(seq_inv) tr' cids'
- )
- (Seq : bor_local_seq invariant tr cids evts tr' cids')
- : bor_local_seq invariant' tr cids evts tr' cids'.
-Proof.
- generalize dependent tr.
- generalize dependent tr'.
- generalize dependent cids.
- generalize dependent cids'.
- induction evts; move=> ????? Seq; inversion Seq; subst.
- - constructor; assumption.
- - econstructor; eauto.
-Qed.
-
-Lemma seq_always_destruct_first
- {invariant}
- {tr cids evts tr' cids'}
- (Seq : bor_local_seq invariant tr cids evts tr' cids')
- : invariant.(seq_inv) tr cids.
-Proof. inversion Seq; subst; assumption. Qed.
-
-Lemma seq_always_destruct_last
- {invariant}
- {tr cids evts tr' cids'}
- (Seq : bor_local_seq invariant tr cids evts tr' cids')
- : invariant.(seq_inv) tr' cids'.
-Proof.
- generalize dependent tr.
- generalize dependent cids.
- induction evts as [|?? IHevts]; move=> ?? Seq; inversion Seq; subst.
- - assumption.
- - eapply IHevts; eauto.
-Qed.
-
-Lemma bor_local_step_deterministic
- {tr cids evt tr1 cids1 tr2 cids2}
- (Step1 : bor_local_step tr cids evt tr1 cids1)
- (Step2 : bor_local_step tr cids evt tr2 cids2)
- : tr1 = tr2 /\ cids1 = cids2.
-Proof.
- destruct evt; inversion Step1 as [????? ACC1| | |?????????? RETAG_EFFECT1];
- inversion Step2 as [????? ACC2| | |?????????? RETAG_EFFECT2]; subst.
- - rewrite ACC1 in ACC2; injection ACC2; tauto.
- - tauto.
- - tauto.
- - rewrite RETAG_EFFECT1 in RETAG_EFFECT2; injection RETAG_EFFECT2; tauto.
-Qed.
-
-Lemma bor_local_seq_deterministic
- {invariant tr cids evts tr1 cids1 tr2 cids2}
- (Seq1 : bor_local_seq invariant tr cids evts tr1 cids1)
- (Seq2 : bor_local_seq invariant tr cids evts tr2 cids2)
- : tr1 = tr2 /\ cids1 = cids2.
-Proof.
- generalize dependent tr.
- generalize dependent cids.
- generalize dependent tr1.
- generalize dependent cids1.
- generalize dependent tr2.
- generalize dependent cids2.
- induction evts as [|?? IHevts]; move=> ?????? Seq1 Seq2; inversion Seq1 as [|??????? HEAD1]; inversion Seq2 as [|??????? HEAD2].
- - subst. tauto.
- - pose proof (bor_local_step_deterministic HEAD1 HEAD2) as [??]; subst.
- eapply IHevts; eauto.
-Qed.
-
-Lemma bor_local_seq_forget
- {invariant tr cids evts tr' cids'}
- (Seq : bor_local_seq invariant tr cids evts tr' cids')
- : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids'.
-Proof.
- generalize dependent tr.
- generalize dependent cids.
- induction evts as [|?? IHevts]; move=> ?? Seq; inversion Seq as [|??????? HEAD1]; subst.
- - constructor; done.
- - econstructor; [done|exact HEAD1|].
- eapply IHevts; assumption.
-Qed.
-
-Lemma seq_always_build_direct
- {invariant tr cids evts tr' cids'}
- (PTR : forall tr cids, invariant.(seq_inv) tr cids)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : bor_local_seq invariant tr cids evts tr' cids'.
-Proof.
- generalize dependent tr.
- generalize dependent cids.
- induction evts; move=> ?? Seq; inversion Seq; subst.
- + constructor; auto.
- + econstructor; eauto.
-Qed.
-
-Lemma seq_always_build_weaken
- {invariant invariant' tr cids evts tr' cids'}
- (WEAKEN : forall tr cids, invariant.(seq_inv) tr cids -> invariant'.(seq_inv) tr cids)
- (Seq : bor_local_seq invariant tr cids evts tr' cids')
- : bor_local_seq invariant' tr cids evts tr' cids'.
-Proof.
- generalize dependent tr.
- generalize dependent cids.
- induction evts; move=> ?? Seq; inversion Seq; subst.
- + constructor; auto.
- + econstructor; eauto.
-Qed.
-
-Lemma seq_always_merge
- {invariant1 invariant2 tr cids evts tr' cids'}
- (Seq1 : bor_local_seq invariant1 tr cids evts tr' cids')
- (Seq2 : bor_local_seq invariant2 tr cids evts tr' cids')
- : bor_local_seq {| seq_inv:=fun tr cids => invariant1.(seq_inv) tr cids /\ invariant2.(seq_inv) tr cids|} tr cids evts tr' cids'.
-Proof.
- generalize dependent tr.
- generalize dependent cids.
- induction evts; move=> ?? Seq1 Seq2; inversion Seq1 as [|??????? HEAD1 REST1]; inversion Seq2 as [|??????? HEAD2 REST2].
- - constructor; split; assumption.
- - pose proof (bor_local_step_deterministic HEAD1 HEAD2) as [??]; subst.
- pose proof (bor_local_seq_deterministic (bor_local_seq_forget REST1) (bor_local_seq_forget REST2)) as [??]; subst.
- econstructor; simpl; eauto.
-Qed.
-
-Lemma bor_local_seq_always_contains
- {tg tr cids tr' cids' evts}
- (Ex : tree_contains tg tr)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : bor_local_seq {|seq_inv:=fun tr _ => (tree_contains tg) tr|} tr cids evts tr' cids'.
-Proof.
- eapply seq_always_build_forward; [assumption| |exact Seq].
- clear.
- move=> ????? Step _ Ex; simpl in *.
- eapply bor_local_step_preserves_contains; eassumption.
-Qed.
-
-Lemma bor_local_seq_last_contains
- {tg tr cids tr' cids' evts}
- (Ex : tree_contains tg tr)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : tree_contains tg tr'.
-Proof.
- pose proof (seq_always_destruct_last (bor_local_seq_always_contains Ex Seq)).
- assumption.
-Qed.
-
-Lemma bor_local_seq_always_determined
- {tg tr tr' prot cids cids' evts pre}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg pre tr)
- (ProtEq : iprot pre = prot)
- (Seq : bor_local_seq {|seq_inv:=fun tr _ => (tree_contains tg) tr|} tr cids evts tr' cids')
- : bor_local_seq {|seq_inv:=fun tr _ => exists it, tree_item_determined tg it tr /\ iprot it = prot|} tr cids evts tr' cids'.
-Proof.
- eapply seq_always_build_forward; [| |exact Seq].
- - eexists; split; eassumption.
- - clear. simpl. move=> ???? evt Step Ex [?[Unq Prot]].
- destruct (bor_local_step_preserves_determined_easy Ex Unq Step) as [?[??]].
- eexists.
- split; [eassumption|].
- destruct evt; subst; auto.
-Qed.
-
-Lemma bor_local_seq_last_determined
- {tg tr tr' cids cids' evts pre}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg pre tr)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : exists post, tree_item_determined tg post tr' /\ iprot pre = iprot post.
-Proof.
- pose proof (bor_local_seq_always_contains Ex Seq) as AllEx.
- destruct (seq_always_destruct_last (bor_local_seq_always_determined Ex Unq eq_refl AllEx)) as [?[??]].
- eexists; split; subst; eauto.
-Qed.
-
-Lemma bor_local_seq_always_rel
- {tg tg' tr tr' cids cids' evts}
- (Rel : ParentChildIn tg tg' tr)
- (Ex : tree_contains tg tr)
- (Ex' : tree_contains tg' tr)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : bor_local_seq {|seq_inv:=fun tr _ => (ParentChildIn tg tg') tr|} tr cids evts tr' cids'.
-Proof.
- pose proof (seq_always_merge
- (bor_local_seq_always_contains Ex Seq)
- (bor_local_seq_always_contains Ex' Seq)) as AllExEx'.
- eapply seq_always_build_forward; [assumption| |exact AllExEx'].
- clear; simpl; move=> ????? Step [Ex Ex'] Rel.
- rewrite <- (bor_local_step_eqv_rel Ex Ex' Step).
- assumption.
-Qed.
-
-Lemma bor_local_seq_always_unrel
- {tg tg' tr tr' cids cids' evts}
- (Rel : ~ParentChildIn tg tg' tr)
- (Ex : tree_contains tg tr)
- (Ex' : tree_contains tg' tr)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : bor_local_seq {|seq_inv:=fun tr _ => ~ParentChildIn tg tg' tr|} tr cids evts tr' cids'.
-Proof.
- pose proof (seq_always_merge
- (bor_local_seq_always_contains Ex Seq)
- (bor_local_seq_always_contains Ex' Seq)) as AllExEx'.
- eapply seq_always_build_forward; [assumption| |exact AllExEx'].
- clear; simpl; move=> ????? Step [Ex Ex'] Rel.
- rewrite <- (bor_local_step_eqv_rel Ex Ex' Step).
- assumption.
-Qed.
-
-Lemma bor_local_seq_last_eqv_rel
- {tg tg' tr tr' cids cids' evts}
- (Ex : tree_contains tg tr)
- (Ex' : tree_contains tg' tr)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : ParentChildIn tg tg' tr <-> ParentChildIn tg tg' tr'.
-Proof.
- destruct (decide (ParentChildIn tg tg' tr)) as [Rel|Unrel].
- - pose proof (seq_always_destruct_last (bor_local_seq_always_rel Rel Ex Ex' Seq)).
- tauto.
- - pose proof (seq_always_destruct_last (bor_local_seq_always_unrel Unrel Ex Ex' Seq)).
- simpl in *.
- tauto.
-Qed.
-
-Lemma bor_local_seq_always_backward_reach
- {tg tr tr' cids cids' pre evts p0 z}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg pre tr)
- (Reach : reach p0 (item_perm_at_loc pre z))
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : bor_local_seq {|seq_inv:=fun tr _ => forall post (UnqPost : tree_item_determined tg post tr), reach p0 (item_perm_at_loc post z)|}
- tr cids evts tr' cids'.
-Proof.
- pose proof (bor_local_seq_always_contains Ex Seq) as AllEx.
- pose proof (seq_always_merge AllEx (bor_local_seq_always_determined Ex Unq eq_refl AllEx)) as AllExUnq.
- eapply seq_always_build_forward; [| |exact AllExUnq].
- + move=> ? Unq'. pose proof (tree_determined_unify Ex Unq Unq'); subst. assumption.
- + clear; simpl; move=> ????? Step [Ex [?[Unq _]]] Reach.
- move=> ? Unq'.
- eapply bor_local_step_preserves_backward_reach; eauto.
-Qed.
-
-Lemma bor_local_seq_always_protected_freeze_like
- {tg tr tr' cids cids' pre evts cid z}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg pre tr)
- (Prot : protector_is_for_call cid (iprot pre))
- (Reach : freeze_like (item_perm_at_loc pre z))
- (Seq : bor_local_seq {|seq_inv:=fun _ cids => call_is_active cid cids|} tr cids evts tr' cids')
- : bor_local_seq {|seq_inv:=fun tr _ => forall post (UnqPost : tree_item_determined tg post tr), protector_is_for_call cid (iprot post) /\ freeze_like (item_perm_at_loc post z)|}
- tr cids evts tr' cids'.
-Proof.
- pose proof (bor_local_seq_always_contains Ex (bor_local_seq_forget Seq)) as AllEx.
- pose proof (seq_always_merge Seq (seq_always_merge AllEx (bor_local_seq_always_determined Ex Unq eq_refl AllEx))) as AllExUnqProt.
- eapply seq_always_build_forward; [| |exact AllExUnqProt].
- + move=> ? Unq'. pose proof (tree_determined_unify Ex Unq Unq'); subst. split; assumption.
- + clear; simpl; move=> ???? evt Step [Prot [Ex [? [Unq _]]]] Reach.
- move=> ? Unq'.
- destruct (Reach _ Unq) as [SameProt FrzLike].
- split.
- * pose proof (bor_local_step_preserves_contains Ex Step) as Ex'.
- destruct (bor_local_step_preserves_determined_easy Ex Unq Step) as [x [Unqx Protx]].
- pose proof (tree_determined_unify Ex' Unq' Unqx); subst.
- destruct evt; rewrite <- Protx; assumption.
- * eapply bor_local_step_preserves_protected_freeze_like; eauto.
- exists cid; split; assumption.
-Qed.
-
-Lemma bor_local_seq_last_backward_reach
- {tg tr tr' cids cids' pre evts p0 z}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg pre tr)
- (Reach : reach p0 (item_perm_at_loc pre z))
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : forall post (UnqPost : tree_item_determined tg post tr'), reach p0 (item_perm_at_loc post z).
-Proof.
- pose proof (seq_always_destruct_last (bor_local_seq_always_backward_reach Ex Unq Reach Seq)).
- assumption.
-Qed.
-
-Lemma bor_local_seq_last_protected_freeze_like
- {tg tr tr' cids cids' pre evts cid z}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg pre tr)
- (Prot : protector_is_for_call cid (iprot pre))
- (FrzLike : freeze_like (item_perm_at_loc pre z))
- (Seq : bor_local_seq {|seq_inv:=fun _ cids => call_is_active cid cids|} tr cids evts tr' cids')
- : forall post (UnqPost : tree_item_determined tg post tr'), protector_is_for_call cid (iprot post) /\ freeze_like (item_perm_at_loc post z).
-Proof.
- pose proof (seq_always_destruct_last (bor_local_seq_always_protected_freeze_like Ex Unq Prot FrzLike Seq)).
- assumption.
-Qed.
-
-Lemma bor_local_seq_always_forward_unreach
- {tg tr tr' cids cids' pre evts p0 z}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg pre tr)
- (Unreach : ~reach (item_perm_at_loc pre z) p0)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : bor_local_seq {|seq_inv:=fun tr _ => forall post (UnqPost : tree_item_determined tg post tr), ~reach (item_perm_at_loc post z) p0|}
- tr cids evts tr' cids'.
-Proof.
- pose proof (bor_local_seq_always_contains Ex Seq) as AllEx.
- pose proof (seq_always_merge AllEx (bor_local_seq_always_determined Ex Unq eq_refl AllEx)) as AllExUnq.
- eapply seq_always_build_forward; [| |exact AllExUnq].
- + move=> ? Unq'. pose proof (tree_determined_unify Ex Unq Unq'); subst. assumption.
- + clear; move=> ????? Step [Ex [?[Unq _]]] Reach.
- move=> ? Unq'.
- eapply bor_local_step_preserves_forward_unreach; eauto.
-Qed.
-
-Lemma bor_local_seq_last_forward_unreach
- {tg tr tr' cids cids' pre evts p0 z}
- (Ex : tree_contains tg tr)
- (Unq : tree_item_determined tg pre tr)
- (Unreach : ~reach (item_perm_at_loc pre z) p0)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : forall post (UnqPost : tree_item_determined tg post tr'), ~reach (item_perm_at_loc post z) p0.
-Proof.
- pose proof (seq_always_destruct_last (bor_local_seq_always_forward_unreach Ex Unq Unreach Seq)).
- assumption.
-Qed.
-
-Lemma bor_local_seq_split
- {invariant tr tr' cids cids' l l'}
- : bor_local_seq invariant tr cids (l ++ l') tr' cids'
- <-> exists tr'' cids'', bor_local_seq invariant tr cids l tr'' cids'' /\ bor_local_seq invariant tr'' cids'' l' tr' cids'.
-Proof.
- generalize dependent tr.
- generalize dependent cids.
- induction l as [|?? IHl]; move=> ??.
- - simpl; split; intro Hyp.
- + eexists. eexists. split; [constructor|assumption].
- all: inversion Hyp; subst; auto.
- + destruct Hyp as [?[?[S S']]].
- inversion S; subst.
- exact S'.
- - simpl; split; intro Hyp.
- + inversion Hyp as [|??????? HEAD REST]; subst.
- rewrite IHl in REST.
- destruct REST as [?[?[S' S'']]].
- eexists. eexists.
- split.
- * econstructor; [assumption|exact HEAD|exact S'].
- * assumption.
- + destruct Hyp as [?[?[S S']]].
- inversion S as [|??????? HEAD REST]; subst.
- econstructor; [assumption|exact HEAD|].
- rewrite IHl.
- eexists. eexists.
- split; eassumption.
-Qed.
-
Lemma apply_access_perm_preserves_perminit
{pre post kind rel b}
(Access : apply_access_perm kind rel b pre = Some post)
@@ -864,7 +326,7 @@ Proof.
all: intros H H'; inversion H'; inversion H.
Qed.
-
+(** Initialized status is monotonous: an initialized location stays initialized. *)
Lemma memory_access_preserves_perminit
{access_tag affected_tag pre tr post tr' kind cids range z zpre zpost}
(ExAff : tree_contains affected_tag tr)
@@ -894,6 +356,7 @@ Proof.
all: rewrite Lkup; simpl; try exact Apply.
Qed.
+(** Furthermore a child access produces an initialized. *)
Lemma apply_access_perm_child_produces_perminit
{pre post kind b rel}
(CHILD : if rel is Child _ then True else False)
@@ -940,82 +403,7 @@ Proof.
all: simpl; done.
Qed.
-Lemma bor_local_step_preserves_perminit
- {affected_tag tr cids evt tr' cids' pre z zpre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (ItemPre : item_lazy_perm_at_loc pre z = zpre)
- (Initialized : initialized zpre = PermInit)
- (Step : bor_local_step tr cids evt tr' cids')
- : forall post,
- tree_item_determined affected_tag post tr' ->
- initialized (item_lazy_perm_at_loc post z) = PermInit.
-Proof.
- move=> post Unq'.
- inversion Step as [???? EXISTS_TAG ACC| | |?? tg????? FRESH_CHILD ? RETAG_EFFECT]; subst.
- - eapply memory_access_preserves_perminit.
- + exact Ex.
- + exact Unq.
- + exact EXISTS_TAG.
- + exact ACC.
- + exact Unq'.
- + reflexivity.
- + reflexivity.
- + exact Initialized.
- - pose proof (tree_determined_unify Ex Unq Unq'); subst.
- assumption.
- - pose proof (tree_determined_unify Ex Unq Unq'); subst.
- assumption.
- - assert (affected_tag ≠tg) as Ne by (intro; subst; contradiction).
- pose proof (create_child_preserves_determined _ _ _ _ _ _ _ _ _ _ _ Ne Unq RETAG_EFFECT) as UnqPost.
- pose proof (insertion_preserves_tags Ex RETAG_EFFECT) as Ex'.
- pose proof (tree_determined_unify Ex' UnqPost Unq'); subst.
- assumption.
-Qed.
-
-Lemma bor_local_step_child_produces_perminit
- {access_tag affected_tag pre tr tr' kind cids cids' z range}
- (ExAff : tree_contains affected_tag tr)
- (UnqAff : tree_item_determined affected_tag pre tr)
- (Rel : ParentChildIn affected_tag access_tag tr)
- (WithinRange : range'_contains range z)
- (Step : bor_local_step tr cids (AccessBLEvt kind access_tag range) tr' cids')
- : forall post,
- tree_item_determined affected_tag post tr' ->
- initialized (item_lazy_perm_at_loc post z) = PermInit.
-Proof.
- inversion Step; subst.
- intros.
- eapply memory_access_child_produces_perminit.
- 1: exact ExAff.
- all: eauto.
-Qed.
-
-Lemma bor_local_seq_always_perminit
- {affected_tag tr tr' cids cids' evts pre z}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (InitPre : initialized (item_lazy_perm_at_loc pre z) = PermInit)
- (Seq : bor_local_seq {|seq_inv:=fun _ _ => True|} tr cids evts tr' cids')
- : bor_local_seq
- {|seq_inv:=fun tr _ =>
- forall it,
- tree_item_determined affected_tag it tr ->
- initialized (item_lazy_perm_at_loc it z) = PermInit|}
- tr cids evts tr' cids'.
-Proof.
- pose proof (bor_local_seq_always_contains Ex Seq) as SeqEx.
- pose proof (bor_local_seq_always_determined Ex Unq eq_refl SeqEx) as SeqUnq.
- eapply seq_always_build_forward; simpl; [| |exact (seq_always_merge SeqEx SeqUnq)].
- - intros pre' Unq'. pose proof (tree_determined_unify Ex Unq Unq'); subst.
- assumption.
- - intros ????? Step Inv Init.
- simpl in Inv; destruct Inv as [Exi [?[Unqi ?]]].
- eapply bor_local_step_preserves_perminit.
- 1: exact Exi.
- all: eauto.
-Qed.
-
+(** Protected + initialized prevents loss of [Active]. *)
Lemma apply_access_perm_protected_initialized_preserves_active
{pre post kind rel}
(Access : apply_access_perm kind rel true pre = Some post)
@@ -1061,73 +449,6 @@ Proof.
- rewrite Spec; tauto.
Qed.
-Lemma protected_during_step_stays_active
- {affected_tag tr cids evt tr' cids' pre z zpre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Prot : protector_is_active (iprot pre) cids)
- (ItemPre : item_lazy_perm_at_loc pre z = zpre)
- (Init : initialized zpre = PermInit)
- (ActPre : perm zpre = Active)
- (Step : bor_local_step tr cids evt tr' cids')
- : forall post, tree_item_determined affected_tag post tr' -> item_perm_at_loc post z = Active.
-Proof.
- move=> ? Unq'.
- inversion Step as [???? EXISTS_TAG ACC| | |?? tg???? FRESH_CHILD ? RETAG_EFFECT]; subst.
- - apply (memory_access_protected_initialized_preserves_active Ex Unq EXISTS_TAG ACC Unq' Prot eq_refl eq_refl Init ActPre).
- - rewrite <- (tree_determined_unify Ex Unq Unq'); tauto.
- - rewrite <- (tree_determined_unify Ex Unq Unq'); tauto.
- - pose proof (bor_local_step_preserves_contains Ex Step) as ExPost'.
- pose proof (bor_local_step_preserves_determined_easy Ex Unq Step) as [it' [UnqPost' Eq]]; subst; simpl in UnqPost'.
- rewrite <- (tree_determined_unify ExPost' UnqPost' Unq'); tauto.
-Qed.
-
-Lemma protected_during_seq_always_stays_active
- {affected_tag tr cids evts tr' cid cids' prot pre z}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Prot : iprot pre = prot)
- (Call : protector_is_for_call cid prot)
- (StartsActive : item_perm_at_loc pre z = Active)
- (Seq : bor_local_seq
- {|seq_inv:=fun tr cids =>
- (forall it, tree_item_determined affected_tag it tr -> initialized (item_lazy_perm_at_loc it z) = PermInit)
- /\ call_is_active cid cids|}
- tr cids evts tr' cids')
- : bor_local_seq
- {|seq_inv:=fun tr _ => forall it, tree_item_determined affected_tag it tr -> perm (item_lazy_perm_at_loc it z) = Active|}
- tr cids evts tr' cids'.
-Proof.
- pose proof (bor_local_seq_always_contains Ex (bor_local_seq_forget Seq)) as AllEx.
- pose proof (bor_local_seq_always_determined Ex Unq Prot AllEx) as AllUnq.
- pose proof (seq_always_merge AllEx (seq_always_merge Seq AllUnq)) as AllExUnqInitProt.
- eapply seq_always_build_forward; [| |exact AllExUnqInitProt].
- + move=> it Unq'. pose proof (tree_determined_unify Ex Unq Unq'); subst. assumption.
- + generalize Call; clear; simpl; move=> Call ????? Step [Ex [[Init CallAct] [?[Unq ProtEq]]]] Act.
- move=> ? Unq'.
- subst.
- eapply protected_during_step_stays_active; eauto.
- eexists; split; eauto.
-Qed.
-
-Lemma protected_during_seq_last_stays_active
- {affected_tag tr cids evts tr' cids' cid prot pre z}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Prot : iprot pre = prot)
- (Call : protector_is_for_call cid prot)
- (StartsActive : item_perm_at_loc pre z = Active)
- (Seq : bor_local_seq
- {|seq_inv:=fun tr cids =>
- (forall it, tree_item_determined affected_tag it tr -> initialized (item_lazy_perm_at_loc it z) = PermInit)
- /\ call_is_active cid cids|}
- tr cids evts tr' cids')
- : forall post, tree_item_determined affected_tag post tr' -> perm (item_lazy_perm_at_loc post z) = Active.
-Proof.
- pose proof (seq_always_destruct_last (protected_during_seq_always_stays_active Ex Unq Prot Call StartsActive Seq)).
- assumption.
-Qed.
-
Lemma apply_access_perm_protected_initialized_preserves_nondis
{pre post kind rel}
(Access : apply_access_perm kind rel true pre = Some post)
@@ -1172,89 +493,3 @@ Proof.
+ assumption.
- rewrite Spec; tauto.
Qed.
-
-Lemma protected_during_step_stays_nondis
- {affected_tag tr cids evt tr' cids' pre z zpre}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Prot : protector_is_active (iprot pre) cids)
- (ItemPre : item_lazy_perm_at_loc pre z = zpre)
- (Init : initialized zpre = PermInit)
- (NonDisPre : ~reach Disabled (perm zpre))
- (Step : bor_local_step tr cids evt tr' cids')
- : forall post, tree_item_determined affected_tag post tr' -> ~reach Disabled (item_perm_at_loc post z).
-Proof.
- move=> ? Unq'.
- inversion Step as [???? EXISTS_TAG ACC| | |?? tg???? FRESH_CHILD ? RETAG_EFFECT]; subst.
- - apply (memory_access_protected_initialized_preserves_nondis Ex Unq EXISTS_TAG ACC Unq' Prot eq_refl eq_refl Init NonDisPre).
- - rewrite <- (tree_determined_unify Ex Unq Unq'); tauto.
- - rewrite <- (tree_determined_unify Ex Unq Unq'); tauto.
- - pose proof (bor_local_step_preserves_contains Ex Step) as ExPost'.
- pose proof (bor_local_step_preserves_determined_easy Ex Unq Step) as [it' [UnqPost' Eq]]; subst; simpl in UnqPost'.
- rewrite <- (tree_determined_unify ExPost' UnqPost' Unq'); tauto.
-Qed.
-
-Lemma protected_during_seq_always_stays_nondis
- {affected_tag tr cids evts tr' cid cids' prot pre z}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Prot : iprot pre = prot)
- (Call : protector_is_for_call cid prot)
- (StartsNonDis : ~reach Disabled (item_perm_at_loc pre z))
- (Seq : bor_local_seq
- {|seq_inv:=fun tr cids =>
- (forall it, tree_item_determined affected_tag it tr -> initialized (item_lazy_perm_at_loc it z) = PermInit)
- /\ call_is_active cid cids|}
- tr cids evts tr' cids')
- : bor_local_seq
- {|seq_inv:=fun tr _ => forall it, tree_item_determined affected_tag it tr -> ~reach Disabled (perm (item_lazy_perm_at_loc it z))|}
- tr cids evts tr' cids'.
-Proof.
- pose proof (bor_local_seq_always_contains Ex (bor_local_seq_forget Seq)) as AllEx.
- pose proof (bor_local_seq_always_determined Ex Unq Prot AllEx) as AllUnq.
- pose proof (seq_always_merge AllEx (seq_always_merge Seq AllUnq)) as AllExUnqInitProt.
- eapply seq_always_build_forward; [| |exact AllExUnqInitProt].
- + move=> it Unq'. pose proof (tree_determined_unify Ex Unq Unq'); subst. assumption.
- + generalize Call; clear; simpl; move=> Call ????? Step [Ex [[Init CallAct] [?[Unq ProtEq]]]] Act.
- move=> ? Unq'.
- subst.
- eapply protected_during_step_stays_nondis; eauto.
- eexists; split; eauto.
-Qed.
-
-Lemma protected_during_seq_last_stays_nondis
- {affected_tag tr cids evts tr' cids' cid prot pre z}
- (Ex : tree_contains affected_tag tr)
- (Unq : tree_item_determined affected_tag pre tr)
- (Prot : iprot pre = prot)
- (Call : protector_is_for_call cid prot)
- (StartsNonDis : ~reach Disabled (item_perm_at_loc pre z))
- (Seq : bor_local_seq
- {|seq_inv:=fun tr cids =>
- (forall it, tree_item_determined affected_tag it tr -> initialized (item_lazy_perm_at_loc it z) = PermInit)
- /\ call_is_active cid cids|}
- tr cids evts tr' cids')
- : forall post, tree_item_determined affected_tag post tr' -> ~reach Disabled (perm (item_lazy_perm_at_loc post z)).
-Proof.
- pose proof (seq_always_destruct_last (protected_during_seq_always_stays_nondis Ex Unq Prot Call StartsNonDis Seq)).
- assumption.
-Qed.
-
-(* For bor_seq
-
-== Preservation lemmas ==
-[X] contains
-[X] determined (quantified)
-[X] reach, unreach
-[X] when protected: stays active, stays frozen
-[X] stays initialized
-
-== Lookahead lemmas ==
-[ ] future EndCall implies call currently active
-[ ] future retag implies currently fresh
-[ ] future retag implies parent exists
-
-== Other lemmas ==
-[X] split/merge list manipulations
-
-*)
diff --git a/theories/tree_borrows/steps_progress.v b/theories/tree_borrows/steps_progress.v
index 455b3620788b349ef60647a9115c9d41dd1b56d4..2fca45fb02a394a6fa3773501abffe7e791cbe57 100755
--- a/theories/tree_borrows/steps_progress.v
+++ b/theories/tree_borrows/steps_progress.v
@@ -1,12 +1,10 @@
-(** This file has been adapted from the Stacked Borrows development, available at
- https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
+(** Statements of success conditions for borrow steps.
+ The goal is to be able to prove a [bor_step] statement. *)
From simuliris.tree_borrows Require Export steps_wf.
From Equations Require Import Equations.
From iris.prelude Require Import options.
-(* TODO: do we need non-empty condition? ie (sizeof ptr) > 0? *)
Lemma alloc_base_step P σ sz :
state_wf σ ->
(sz > 0)%nat ->
@@ -30,7 +28,7 @@ Proof.
exact Dom.
Qed.
-
+(* Basically, [tree_apply_access] works iff every node accepts the inner function being applied *)
Lemma apply_access_success_condition tr cids access_tag range fn :
every_node (fun it => is_Some (item_apply_access fn cids (rel_dec tr access_tag (itag it)) range it)) tr
<-> is_Some (tree_apply_access fn cids access_tag range tr).
@@ -41,7 +39,6 @@ Proof.
tauto.
Qed.
-
Lemma apply_access_fail_condition tr cids access_tag range fn :
exists_node (fun it => item_apply_access fn cids (rel_dec tr access_tag (itag it)) range it = None) tr
<-> tree_apply_access fn cids access_tag range tr = None.
@@ -52,6 +49,7 @@ Proof.
tauto.
Qed.
+(* [mem_apply_range'] succeeds iff every offset succeeds. *)
Lemma mem_apply_range'_success_condition {X} (map : gmap Z X) fn range :
(forall l, range'_contains range l -> is_Some (fn (map !! l))) <->
is_Some (mem_apply_range' fn range map).
@@ -180,46 +178,6 @@ Proof.
destruct (ProtVulnerable ltac:(reflexivity)); discriminate.
Qed.
-
-
-(*
-Lemma dealloc1_progress stk bor cids
- (PR: Forall (λ it, ¬ is_active_protector cids it) stk)
- (BOR: ∃ it, it ∈ stk ∧ it.(tg) = bor ∧
- it.(perm) ≠Disabled ∧ it.(perm) ≠SharedReadOnly) :
- is_Some (dealloc1 stk bor cids).
-Proof.
- rewrite /dealloc1.
- destruct (find_granting_is_Some stk AccessWrite bor) as [? Eq]; [naive_solver|].
- rewrite Eq /find_top_active_protector list_find_None_inv;
- [by eexists|done].
-Qed.
-
-Lemma for_each_is_Some α l (n: nat) b f :
- (∀ m : Z, 0 ≤ m ∧ m < n → l +ₗ m ∈ dom α) →
- (∀ (m: nat) stk, (m < n)%nat → α !! (l +ₗ m) = Some stk → is_Some (f stk)) →
- is_Some (for_each α l n b f).
-Proof.
- revert α. induction n as [|n IHn]; intros α IN Hf; [by eexists|]. simpl.
- assert (is_Some (α !! (l +ₗ n))) as [stk Eq].
- { apply (elem_of_dom (D:=gset loc)), IN. by lia. }
- rewrite Eq /=. destruct (Hf n stk) as [stk' Eq']; [lia|done|].
- rewrite Eq' /=. destruct b; apply IHn.
- - intros. apply elem_of_dom. rewrite lookup_delete_ne.
- + apply (elem_of_dom (D:=gset loc)), IN. lia.
- + move => /shift_loc_inj. lia.
- - intros ???. rewrite lookup_delete_ne.
- + apply Hf. lia.
- + move => /shift_loc_inj. lia.
- - intros. apply elem_of_dom. rewrite lookup_insert_ne.
- + apply (elem_of_dom (D:=gset loc)), IN. lia.
- + move => /shift_loc_inj. lia.
- - intros ???. rewrite lookup_insert_ne.
- + apply Hf. lia.
- + move => /shift_loc_inj. lia.
-Qed.
-*)
-
(* For a protector to allow deallocation it must be weak or inactive *)
Definition item_deallocateable_protector cids (it: item) :=
match it.(iprot) with
@@ -227,47 +185,6 @@ Definition item_deallocateable_protector cids (it: item) :=
| _ => True
end.
-(* Deallocation progress is going to be a bit more tricky because we need the success of the write *)
-(*
-Lemma memory_deallocated_progress α cids l bor (n: nat) :
- (∀ m : Z, 0 ≤ m ∧ m < n → l +ₗ m ∈ dom α) →
- (∀ (m: nat) stk, (m < n)%nat → α !! (l +ₗ m) = Some stk →
- (∃ it, it ∈ stk ∧ it.(itag) = bor ∧
- it.(perm) ≠Disabled ∧ it.(perm) ≠SharedReadOnly) ∧
- ∀ it, it ∈ stk → item_inactive_protector cids it) →
- is_Some (memory_deallocated α cids l bor n).
-Proof.
- intros IN IT. apply for_each_is_Some; [done|].
- intros m stk Lt Eq. destruct (IT _ _ Lt Eq) as [In PR].
- destruct (dealloc1_progress stk bor cids) as [? Eq1];
- [|done|rewrite Eq1; by eexists].
- apply Forall_forall. move => it /PR.
- rewrite /item_inactive_protector /is_active_protector /is_active.
- case protector; naive_solver.
-Qed.
-*)
-(*
-Lemma memory_deallocate_progress (σ: state) l tg (sz:nat) (WF: state_wf σ) :
- (∀ m : Z, is_Some (σ.(shp) !! (l +ₗ m)) ↔ 0 ≤ m ∧ m < sz) →
- (sz > 0)%nat →
- trees_contain tg (strs σ) l.1 →
- is_Some (apply_within_trees (memory_deallocate σ.(scs) tg (l.2, sz)) l.1 σ.(strs)).
-Proof.
- intros Hfoo Hbar Hcont.
- eexists. Locate trees_contain. unfold trees_contain in Hcont. unfold trees_at_block in Hcont.
- destruct (strs σ !! l.1) as [tr|] eqn:Heqtr; last done.
- rewrite /apply_within_trees /memory_deallocate Heqtr /=.
- unfold tree_apply_access.
- Print join_nodes.
- Print map_nodes.
- Search join_nodes.
- simpl.
- Print apply_within_trees.
- Print memory_deallocate.
- Print tree_apply_access.
- Print item_apply_access.
- Print memory_deallocate.
-*)
Lemma dealloc_base_step' P (σ: state) l tg (sz:nat) α' (WF: state_wf σ) :
(∀ m : Z, is_Some (σ.(shp) !! (l +ₗ m)) ↔ 0 ≤ m ∧ m < sz) →
(sz > 0)%nat →
@@ -279,25 +196,6 @@ Proof.
intros Hdom Hpos Hcont Happly. destruct l as [blk off].
econstructor; econstructor; auto.
Qed.
-(*
-Lemma dealloc_base_step P (σ: state) T l bor
- (WF: state_wf σ)
- (BLK: ∀ m : Z, l +ₗ m ∈ dom σ.(shp) ↔ 0 ≤ m ∧ m < tsize T)
- (BOR: ∀ (n: nat) stk, (n < tsize T)%nat →
- σ.(sst) !! (l +ₗ n) = Some stk →
- (∃ it, it ∈ stk ∧ it.(tg) = bor ∧
- it.(perm) ≠Disabled ∧ it.(perm) ≠SharedReadOnly) ∧
- ∀ it, it ∈ stk → item_inactive_protector σ.(scs) it) :
- ∃ σ',
- base_step P (Free (Place l bor T)) σ #[☠] σ' [].
-Proof.
- destruct (memory_deallocated_progress σ.(sst) σ.(scs) l bor (tsize T))
- as [α' Eq']; [|done|].
- - intros. rewrite -(state_wf_dom _ WF). by apply BLK.
- - eexists. econstructor; econstructor; [|done].
- intros. by rewrite -(elem_of_dom (D:= gset loc) σ.(shp)).
-Qed.
-*)
(* Success of `read_mem` on the heap is unchanged. *)
Lemma read_mem_is_Some' l n h :
@@ -362,147 +260,8 @@ Proof.
rewrite -Hs; last lia. rewrite -Hv'; last lia. intros -> [= ->]. done.
Qed.
-(*
-Lemma replace_check'_is_Some cids acc stk :
- (∀ it, it ∈ stk → it.(perm) = Unique → item_inactive_protector cids it) →
- is_Some (replace_check' cids acc stk).
-Proof.
- revert acc. induction stk as [|si stk IH]; intros acc PR; simpl; [by eexists|].
- case decide => EqU; last by (apply IH; set_solver).
- rewrite (Is_true_eq_true (check_protector cids si)); first by (apply IH; set_solver).
- have IN: si ∈ si :: stk by set_solver. apply PR in IN; [|done].
- move : IN. rewrite /check_protector /item_inactive_protector.
- case si.(protector) => [? /negb_prop_intro|//]. by case is_active.
-Qed.
-
-Lemma replace_check_is_Some cids stk :
- (∀ it, it ∈ stk → it.(perm) = Unique → item_inactive_protector cids it) →
- is_Some (replace_check cids stk).
-Proof. move => /replace_check'_is_Some IS. by apply IS. Qed.
-
-*)
-
-
-(*
-Definition access1_read_pre cids (stk: stack) (bor: tag) :=
- ∃ (i: nat) it, stk !! i = Some it ∧ it.(tg) = bor ∧ it.(perm) ≠Disabled ∧
- ∀ (j: nat) jt, (j < i)%nat → stk !! j = Some jt →
- (jt.(perm) = Disabled ∨ jt.(tg) ≠bor) ∧
- match jt.(perm) with
- | Unique => item_inactive_protector cids jt
- | _ => True
- end.
-
-Definition access1_write_pre cids (stk: stack) (bor: tag) :=
- ∃ (i: nat) it, stk !! i = Some it ∧ it.(perm) ≠Disabled ∧
- it.(perm) ≠SharedReadOnly ∧ it.(tg) = bor ∧
- ∀ (j: nat) jt, (j < i)%nat → stk !! j = Some jt →
- (jt.(perm) = Disabled ∨ jt.(perm) = SharedReadOnly ∨ jt.(tg) ≠bor) ∧
- match find_first_write_incompatible (take i stk) it.(perm) with
- | Some idx =>
- if decide (j < idx)%nat then
- (* Note: if a Disabled item is already in the stack, then its protector
- must have been inactive since its insertion, so this condition is
- unneccessary. *)
- item_inactive_protector cids jt
- else True
- | _ => True
- end.
- *)
-
Definition is_write (access: access_kind) : bool :=
match access with AccessWrite => true | _ => false end.
-(*
-Definition access1_pre
- cids (stk: stack) (access: access_kind) (bor: tag) :=
- ∃ (i: nat) it, stk !! i = Some it ∧ it.(perm) ≠Disabled ∧
- (is_write access → it.(perm) ≠SharedReadOnly) ∧ it.(tg) = bor ∧
- ∀ (j: nat) jt, (j < i)%nat → stk !! j = Some jt →
- (jt.(perm) = Disabled ∨
- (if is_write access then jt.(perm) = SharedReadOnly ∨ jt.(tg) ≠bor
- else jt.(tg) ≠bor)) ∧
- if is_write access then
- match find_first_write_incompatible (take i stk) it.(perm) with
- | Some idx =>
- if decide (j < idx)%nat then
- (* Note: if a Disabled item is already in the stack, then its protector
- must have been inactive since its insertion, so this condition is
- unneccessary. *)
- item_inactive_protector cids jt
- else True
- | _ => True
- end
- else
- match jt.(perm) with
- | Unique => item_inactive_protector cids jt
- | _ => True
- end.
- *)
-
-(*
-Lemma access1_is_Some cids stk kind bor
- (BOR: access1_pre cids stk kind bor) :
- is_Some (access1 stk kind bor cids).
-Proof.
- destruct BOR as (i & it & Eqi & ND & IW & Eqit & Lti).
- rewrite /access1 /find_granting.
- rewrite (_: list_find (matched_grant kind bor) stk = Some (i, it)); last first.
- { apply list_find_Some_not_earlier. split; last split; [done|..].
- - split; [|done].
- destruct kind; [by apply grants_access_all|by apply grants_write_all, IW].
- - intros ?? Lt Eq GR. destruct (Lti _ _ Lt Eq) as [[Eq1|NEq1] NEq2].
- { move : GR. rewrite /matched_grant Eq1 /=. naive_solver. }
- destruct kind; [by apply NEq1, GR|]. destruct NEq1 as [OR|OR].
- + move : GR. rewrite /matched_grant OR /=. naive_solver.
- + by apply OR, GR. } simpl.
- have ?: (i ≤ length stk)%nat. { by eapply Nat.lt_le_incl, lookup_lt_Some. }
- destruct kind.
- - destruct (replace_check_is_Some cids (take i stk)) as [? Eq2];
- [|rewrite Eq2 /=; by eexists].
- intros jt [j Eqj]%elem_of_list_lookup_1 IU.
- have ?: (j < i)%nat.
- { rewrite -(length_take_le stk i); [|done]. by eapply lookup_lt_Some. }
- destruct (Lti j jt) as [Eq1 PR]; [done|..].
- + symmetry. by rewrite -Eqj lookup_take.
- + move : PR. by rewrite /= IU.
- - destruct (find_first_write_incompatible_is_Some (take i stk) it.(perm))
- as [idx Eqx]; [done|by apply IW|]. rewrite Eqx /=.
- destruct (remove_check_is_Some cids (take i stk) idx) as [stk' Eq'];
- [..|rewrite Eq'; by eexists].
- + move : Eqx. apply find_first_write_incompatible_length.
- + intros j jt Lt Eqj.
- have ?: (j < i)%nat.
- { rewrite -(length_take_le stk i); [|done]. by eapply lookup_lt_Some. }
- destruct (Lti j jt) as [Eq1 PR]; [done|..].
- * symmetry. by rewrite -Eqj lookup_take.
- * move : PR. by rewrite /= Eqx decide_True.
-Qed.
-
-Lemma access1_read_is_Some cids stk bor
- (BOR: access1_read_pre cids stk bor) :
- is_Some (access1 stk AccessRead bor cids).
-Proof.
- destruct BOR as (i & it & Eqi & Eqit & ND & Lti).
- apply access1_is_Some. exists i, it. do 4 (split; [done|]).
- intros j jt Lt Eq. by destruct (Lti _ _ Lt Eq).
-Qed.
- *)
-
-(*
-Lemma memory_read_is_Some α cids l bor (n: nat) :
- (∀ m, (m < n)%nat → l +ₗ m ∈ dom α) →
- (∀ (m: nat) stk, (m < n)%nat →
- α !! (l +ₗ m) = Some stk → access1_read_pre cids stk bor) →
- is_Some (memory_read α cids l bor n).
-Proof.
- intros IN STK. apply for_each_is_Some.
- - intros m []. rewrite -(Z2Nat.id m); [|done]. apply IN.
- rewrite -(Nat2Z.id n) -Z2Nat.inj_lt; [done..|lia].
- - intros m stk Lt Eq.
- specialize (STK _ _ Lt Eq).
- destruct (access1_read_is_Some _ _ _ STK) as [? Eq2]. rewrite Eq2. by eexists.
-Qed.
- *)
Lemma apply_within_trees_unchanged fn blk trs trs' :
(∀ tr, trs !! blk = Some tr → fn tr = Some tr) →
@@ -528,59 +287,7 @@ Proof.
intros tr Htr. simpl in Htr|-*. eapply (zero_sized_memory_access_unchanged false).
- do 2 econstructor. all: eauto.
Qed.
-(* TODO remove?
-Lemma copy_base_step P (σ: state) l bor T
- (WF: state_wf σ)
- (BLK: ∀ n, (n < tsize T)%nat → l +ₗ n ∈ dom σ.(shp))
- (BOR: ∀ m stk, (m < tsize T)%nat → σ.(sst) !! (l +ₗ m) = Some stk →
- access1_read_pre σ.(scs) stk bor) :
- ∃ v α,
- read_mem l (tsize T) σ.(shp) = Some v ∧
- memory_read σ.(sst) σ.(scs) l bor (tsize T) = Some α ∧
- let σ' := mkState σ.(shp) α σ.(scs) σ.(snp) σ.(snc) in
- base_step P (Copy (Place l bor T)) σ (Val v) σ' [].
-Proof.
- destruct (read_mem_is_Some _ _ _ BLK) as [v RM].
- destruct (memory_read_is_Some σ.(sst) σ.(scs) l bor (tsize T));[|done|].
- { move => ? /BLK. by rewrite (state_wf_dom _ WF). }
- do 2 eexists. do 2 (split; [done|]). intros σ'.
- eapply copy_base_step'; eauto.
-Qed. *)
-Lemma failed_copy_base_step' P (σ: state) l tg sz (WF: state_wf σ) :
- trees_contain tg σ.(strs) l.1 →
- apply_within_trees (memory_access AccessRead σ.(scs) tg (l.2, sz)) l.1 σ.(strs) = None →
- is_Some (read_mem l sz σ.(shp)) →
- base_step P (Copy (Place l tg sz)) σ (Val $ replicate sz ScPoison) σ [].
-Proof.
- intros TC Happly. destruct l, σ. do 2 econstructor; by eauto.
-Qed.
-
-(*
-
-Lemma access1_write_is_Some cids stk bor
- (BOR: access1_write_pre cids stk bor) :
- is_Some (access1 stk AccessWrite bor cids).
-Proof.
- destruct BOR as (i & it & Eqi & ND & Neqi & Eqit & Lti).
- apply access1_is_Some. exists i, it. do 4 (split; [done|]).
- intros j jt Lt Eq. by destruct (Lti _ _ Lt Eq).
-Qed.
-
-Lemma memory_written_is_Some α cids l bor (n: nat) :
- (∀ m, (m < n)%nat → l +ₗ m ∈ dom α) →
- (∀ (m: nat) stk, (m < n)%nat →
- α !! (l +ₗ m) = Some stk → access1_write_pre cids stk bor) →
- is_Some (memory_written α cids l bor n).
-Proof.
- intros IN STK. apply for_each_is_Some.
- - intros m []. rewrite -(Z2Nat.id m); [|done]. apply IN.
- rewrite -(Nat2Z.id n) -Z2Nat.inj_lt; [done..|lia].
- - intros m stk Lt Eq.
- specialize (STK _ _ Lt Eq).
- destruct (access1_write_is_Some _ _ _ STK) as [? Eq2]. rewrite Eq2. by eexists.
-Qed.
-*)
Lemma write_base_step' P (σ: state) l bor sz v trs'
(LEN: length v = sz)
(BLK: ∀ n, (n < sz)%nat → l +ₗ n ∈ dom σ.(shp))
@@ -597,25 +304,6 @@ Proof.
- econstructor 2; econstructor; eauto. by rewrite LEN.
Qed.
-(*
-Lemma write_base_step P (σ: state) l bor T v
- (WF: state_wf σ)
- (LEN: length v = tsize T)
- (*(LOCVAL: v <<t σ.(snp))*)
- (BLK: ∀ n, (n < tsize T)%nat → l +ₗ n ∈ dom σ.(shp))
- (STK: ∀ m stk, (m < tsize T)%nat → σ.(sst) !! (l +ₗ m) = Some stk →
- access1_write_pre σ.(scs) stk bor) :
- ∃ α,
- memory_written σ.(sst) σ.(scs) l bor (tsize T) = Some α ∧
- let σ' := mkState (write_mem l v σ.(shp)) α σ.(scs) σ.(snp) σ.(snc) in
- base_step P (Write (Place l bor T) (Val v)) σ #[☠] σ' [].
-Proof.
- destruct (memory_written_is_Some σ.(sst) σ.(scs) l bor (tsize T)); [|done|].
- { move => ? /BLK. by rewrite (state_wf_dom _ WF). }
- eexists. split; [done|]. by eapply write_base_step'.
-Qed.
- *)
-
Lemma call_base_step P σ name e r fn :
P !! name = Some fn →
to_result e = Some r →
@@ -636,363 +324,3 @@ Lemma end_call_base_step P (σ: state) trs' c :
base_step P (EndCall #[ScCallId c]) σ #[☠] σ' [].
Proof. intros ??. by econstructor; econstructor. Qed.
-(*
-
-Lemma unsafe_action_is_Some_weak {A} (GI: A → nat → Prop)
- (f: A → _ → nat → _ → _) a l last cur_dist n
- (HF: ∀ a i j b, (last ≤ i ≤ j ∧ j ≤ last + cur_dist + n)%nat → GI a i →
- ∃ a', f a (l +ₗ i) (Z.to_nat (j - i)) b = Some a' ∧ GI a' j) :
- GI a last → ∃ a' last' cur_dist',
- unsafe_action f a l last cur_dist n = Some (a', (last', cur_dist')) ∧ GI a' last'.
-Proof.
- intros HI. rewrite /unsafe_action.
- destruct (HF a last (last + cur_dist)%nat true) as [a' Eq1]; [lia|done|].
- move : Eq1.
- rewrite (_: Z.to_nat (Z.of_nat (last + cur_dist) - Z.of_nat last) = cur_dist);
- last by rewrite Nat2Z.inj_add Z.add_simpl_l Nat2Z.id.
- move => [-> HI'] /=.
- destruct (HF a' (last + cur_dist)%nat (last + cur_dist + n)%nat false)
- as [? [Eq2 HI2]]; [lia|done|].
- move : Eq2.
- rewrite (_: Z.to_nat (Z.of_nat (last + cur_dist + n) -
- Z.of_nat (last + cur_dist)) = n);
- last by rewrite Nat2Z.inj_add Z.add_simpl_l Nat2Z.id.
- move => -> /=. by do 3 eexists.
-Qed.
-
-
-Lemma visit_freeze_sensitive'_is_Some {A} (GI: A → nat → Prop)
- l (f: A → _ → nat → _ → _) a (last cur_dist: nat) T
- (HF: ∀ a i j b, (last ≤ i ≤ j ∧ j ≤ last + cur_dist + tsize T)%nat → GI a i →
- ∃ a', f a (l +ₗ i) (Z.to_nat (j - i)) b = Some a' ∧ GI a' j) :
- GI a last → ∃ a' last' cur_dist',
- visit_freeze_sensitive' l f a last cur_dist T = Some (a', (last', cur_dist')) ∧
- GI a' last'.
-Proof.
- revert HF.
- apply (visit_freeze_sensitive'_elim
- (* general goal P *)
- (λ l f a last cur_dist T oalc,
- (∀ a i j b,(last ≤ i ≤ j ∧ j ≤ last + cur_dist + tsize T)%nat → GI a i →
- ∃ a', f a (l +ₗ i) (Z.to_nat (j - i)) b = Some a' ∧ GI a' j) →
- GI a last → ∃ a' last' cur', oalc = Some (a', (last', cur')) ∧ GI a' last')
- (λ l f _ _ _ _ a last cur_dist Ts oalc,
- (∀ a i j b, (last ≤ i ≤ j ∧ j ≤ last + cur_dist + tsize (Product Ts))%nat →
- GI a i → ∃ a', f a (l +ₗ i) (Z.to_nat (j - i)) b = Some a' ∧ GI a' j) →
- GI a last → ∃ a' last' cur', oalc = Some (a', (last', cur')) ∧ GI a' last')).
- - naive_solver.
- - naive_solver.
- - clear. intros ?????? HF. by apply unsafe_action_is_Some_weak.
- - clear. intros l f a last cur_dist T HF.
- case is_freeze; [by do 3 eexists|]. by apply unsafe_action_is_Some_weak.
- - clear. intros l f a last cur_dist Ts IH Hf HI.
- case is_freeze; [intros; simplify_eq/=; exists a, last; by eexists|by apply IH].
- - clear. intros l f a last cur_dist T HF.
- case is_freeze; [by do 3 eexists|]. by apply unsafe_action_is_Some_weak.
- - naive_solver.
- - clear.
- intros l f a last cur_dist Ts a1 last1 cur_dist1 T1 Ts1 IH1 IH2 HF HI.
- destruct IH2 as (a2 & last2 & cur_dist2 & Eq1 & HI2); [..|done|].
- { intros ???? [? Le]. apply HF. split; [done|]. clear -Le.
- rewrite tsize_product_cons. by lia. }
- destruct (visit_freeze_sensitive'_offsets _ _ _ _ _ _ _ _ _ Eq1)
- as [LeO EqO].
- rewrite Eq1 /=. apply (IH1 (a2, (last2,cur_dist2))); [..|done].
- intros a' i j b. cbn -[tsize]. intros Lej. apply HF.
- clear -LeO EqO Lej. destruct Lej as [[Le2 Lei] Lej].
- split; [lia|]. move : Lej. rewrite EqO tsize_product_cons. lia.
-Qed.
-
-Lemma visit_freeze_sensitive_is_Some' {A} (GI: A → nat → Prop)
- l (f: A → _ → nat → _ → _) a T
- (HF: ∀ a i j b, (i ≤ j ∧ j ≤ tsize T)%nat → GI a i →
- ∃ a', f a (l +ₗ i) (Z.to_nat (j - i)) b = Some a' ∧ GI a' j) :
- GI a O → ∃ a', visit_freeze_sensitive l T f a = Some a' ∧ GI a' (tsize T).
-Proof.
- intros HI. rewrite /visit_freeze_sensitive.
- destruct (visit_freeze_sensitive'_is_Some GI l f a O O T)
- as (a1 & l1 & c1 & Eq1 & HI1); [|done|].
- { rewrite 2!Nat.add_0_l. intros ???? [[??]?]. by apply HF. }
- rewrite Eq1 -(Nat.add_sub c1 l1) -(Nat2Z.id (c1 + l1 - l1))
- Nat2Z.inj_sub; [|lia].
- move : Eq1. intros [? Eq]%visit_freeze_sensitive'_offsets.
- destruct (HF a1 l1 (c1 + l1)%nat true) as (a2 & Eq2 & HI2); [|done|].
- { split; [lia|]. move : Eq. rewrite 2!Nat.add_0_l. lia. }
- exists a2. split; [done|].
- move : Eq. by rewrite 2!Nat.add_0_l Nat.add_comm => [<-].
-Qed.
-
-Lemma visit_freeze_sensitive_is_Some'_2 {A} (GI: A → nat → Prop)
- l (f: A → _ → nat → _ → _) a T
- (HF: ∀ a i j b, (i ≤ j ∧ j ≤ tsize T)%nat → GI a i →
- ∃ a', f a (l +ₗ i) (Z.to_nat (j - i)) b = Some a' ∧ GI a' j) :
- GI a O → is_Some (visit_freeze_sensitive l T f a).
-Proof.
- intros HI. destruct (visit_freeze_sensitive_is_Some' GI l f a T)
- as [a' [Eq _]]; [done..|by eexists].
-Qed.
-
-Lemma visit_freeze_sensitive_is_Some {A}
- l (f: A → _ → nat → _ → _) a T
- (HF: ∀ a i j b, (i ≤ j ∧ j ≤ tsize T)%nat →
- is_Some (f a (l +â‚— i) (Z.to_nat (j - i)) b)) :
- is_Some (visit_freeze_sensitive l T f a).
-Proof.
- destruct (visit_freeze_sensitive_is_Some' (λ _ _, True) l f a T)
- as [a' [Eq _]]; [|done..|by eexists].
- intros a1 i j b Le _. destruct (HF a1 i j b Le). by eexists.
-Qed.
-
-Lemma access1_find_granting_agree stk kind bor cids i1 i2 pm1 stk2:
- find_granting stk kind bor = Some (i1, pm1) →
- access1 stk kind bor cids = Some (i2, stk2) →
- i1 = i2.
-Proof.
- intros FI. rewrite /access1 FI /=.
- destruct kind.
- - case replace_check => [? /= ?|//]. by simplify_eq/=.
- - case find_first_write_incompatible => [? /=|//].
- case remove_check => [? /= ?|//]. by simplify_eq/=.
-Qed.
-
-Lemma find_granting_write stk bor i pi:
- find_granting stk AccessWrite bor = Some (i, pi) →
- pi ≠Disabled ∧ pi ≠SharedReadOnly.
-Proof.
- move => /fmap_Some [[??] /= [IS ?]]. simplify_eq/=.
- apply list_find_Some in IS as (? & [IS ?] & ?).
- move : IS. rewrite /grants. case perm; naive_solver.
-Qed.
-
-(* The precondition `access1_pre` is too strong for the SharedReadWrite case:
- we only need a granting item for that case, we don't need the access check. *)
-Lemma grant_is_Some stk old new cids :
- let access :=
- if grants new.(perm) AccessWrite then AccessWrite else AccessRead in
- access1_pre cids stk access old →
- is_Some (grant stk old new cids).
-Proof.
- intros access ACC. rewrite /grant.
- destruct (find_granting_is_Some stk access old) as [[i pi] Eqi].
- { destruct ACC as (i & it & Eqi & ND & NEq & Eqt & Lt).
- exists it. split; [by eapply elem_of_list_lookup_2|].
- do 2 (split; [done|]). intros Eqa. apply NEq. by rewrite Eqa. }
- rewrite Eqi. cbn -[item_insert_dedup].
- destruct (access1_is_Some _ _ _ _ ACC) as [[i' stk'] Eq].
- rewrite Eq. cbn -[item_insert_dedup].
- destruct new.(perm); try by eexists.
- apply find_granting_write in Eqi as [].
- destruct (find_first_write_incompatible_is_Some (take i stk) pi) as [? Eq2];
- [done..|rewrite Eq2; by eexists].
-Qed.
-
-Lemma reborrowN_is_Some α cids l n old new pm protector
- (BLK: ∀ m, (m < n)%nat → l +ₗ m ∈ dom α):
- let access := if grants pm AccessWrite then AccessWrite else AccessRead in
- (∀ (m: nat) stk, (m < n)%nat → α !! (l +ₗ m) = Some stk →
- access1_pre cids stk access old) →
- is_Some (reborrowN α cids l n old new pm protector).
-Proof.
- intros access STK.
- rewrite /reborrowN. apply for_each_is_Some.
- - intros m []. rewrite -(Z2Nat.id m); [|done]. apply BLK.
- rewrite -(Nat2Z.id n) -Z2Nat.inj_lt; [done..|lia].
- - intros m stk Lt Eq. apply grant_is_Some. by apply (STK _ _ Lt Eq).
-Qed.
-
-Lemma reborrowN_lookup (α1 α2 : stacks) cids l n old new pm protector
- (EQB : reborrowN α1 cids l n old new pm protector = Some α2) :
- (∀ m, (n ≤ m)%nat → α2 !! (l +ₗ m) = α1 !! (l +ₗ m)) ∧
- (∀ m stk, (m < n)%nat → α1 !! (l +ₗ m) = Some stk →
- ∃ stk', α2 !! (l +ₗ m) = Some stk' ∧
- let item := mkItem pm new protector in
- grant stk old item cids = Some stk') ∧
- (∀ m stk', (m < n)%nat → α2 !! (l +ₗ m) = Some stk' →
- ∃ stk, α1 !! (l +ₗ m) = Some stk ∧
- let item := mkItem pm new protector in
- grant stk old item cids = Some stk').
-Proof.
- destruct (for_each_lookup _ _ _ _ _ EQB) as [HL1 [HL2 HL3]]. split; last split.
- - intros m Ge. apply HL3. intros i Lt Eq%shift_loc_inj. subst. lia.
- - by apply HL1.
- - by apply HL2.
-Qed.
-
-Lemma visit_freeze_sensitive'_is_freeze {A}
- l (f: A → _ → nat → _ → _) a (last cur_dist: nat) T :
- is_freeze T →
- visit_freeze_sensitive' l f a last cur_dist T
- = Some (a, (last, (cur_dist + tsize T)%nat)).
-Proof.
- apply (visit_freeze_sensitive'_elim
- (* general goal P *)
- (λ l f a last cur_dist T oalc,
- is_freeze T → oalc = Some (a, (last, (cur_dist + tsize T)%nat)))
- (λ l f _ _ _ _ a last cur_dist Ts oalc,
- is_freeze (Product Ts) →
- oalc = Some (a, (last, (cur_dist + tsize (Product Ts))%nat)))).
- - done.
- - clear. intros ??????? _. by rewrite /= Nat.add_1_r.
- - done.
- - clear. intros ??????. by move => /Is_true_eq_true ->.
- - clear. intros ?????? _. by move => /Is_true_eq_true ->.
- - clear. intros ??????. by move => /Is_true_eq_true ->.
- - clear. intros _ _ _ _ _ _ ??? _. by rewrite /= Nat.add_0_r.
- - clear. intros l f a last cur_dist Ts a' l1 c1 T Ts' IH1 IH2 FRZ.
- rewrite IH2; first rewrite /= (IH1 (a', (l1, c1 + tsize T)%nat)).
- + simpl. do 3 f_equal. change (tsize T) with (0 + tsize T)%nat.
- rewrite -(foldl_fmap_shift_init _ (λ n, n + tsize T)%nat);
- [by lia|intros ?? _; by lia].
- + by eapply is_freeze_cons_product_inv.
- + by eapply is_freeze_cons_product_inv.
-Qed.
-
-Lemma visit_freeze_sensitive_is_freeze {A}
- l (f: A → _ → nat → _ → _) a T :
- is_freeze T → visit_freeze_sensitive l T f a = f a l (tsize T) true.
-Proof.
- intros FRZ. rewrite /visit_freeze_sensitive visit_freeze_sensitive'_is_freeze;
- [by rewrite shift_loc_0_nat Nat.add_0_l|done].
-Qed.
-
-Lemma reborrow_is_freeze_is_Some α cids l old T kind new prot
- (BLK: ∀ m, (m < tsize T)%nat → l +ₗ m ∈ dom α)
- (FRZ: is_freeze T)
- (STK: ∀ m stk, (m < tsize T)%nat → α !! (l +ₗ m) = Some stk →
- let access := match kind with
- | SharedRef | RawRef false => AccessRead
- | _ => AccessWrite
- end in access1_pre cids stk access old) :
- is_Some (reborrow α cids l old T kind new prot).
-Proof.
- rewrite /reborrow. destruct kind as [[]| |[]].
- - by apply reborrowN_is_Some.
- - by apply reborrowN_is_Some.
- - rewrite visit_freeze_sensitive_is_freeze //. by apply reborrowN_is_Some.
- - by apply reborrowN_is_Some.
- - rewrite visit_freeze_sensitive_is_freeze //. by apply reborrowN_is_Some.
-Qed.
-
-Lemma reborrow_is_freeze_lookup α cids l old T kind new prot α'
- (FRZ: is_freeze T) :
- reborrow α cids l old T kind new prot = Some α' →
- ∀ m stk', (m < tsize T)%nat → α' !! (l +ₗ m) = Some stk' →
- ∃ stk, α !! (l +ₗ m) = Some stk ∧
- let pm := match kind with
- | SharedRef | RawRef false => SharedReadOnly
- | UniqueRef false => Unique
- | UniqueRef true | RawRef true => SharedReadWrite
- end in
- let item := mkItem pm new prot in
- grant stk old item cids = Some stk'.
-Proof.
- rewrite /reborrow. destruct kind as [[]| |[]]; intros EQB m stk' Lt Eq'.
- - apply reborrowN_lookup in EQB as [_ [_ HL]]. by apply HL.
- - apply reborrowN_lookup in EQB as [_ [_ HL]]. by apply HL.
- - move : EQB. rewrite visit_freeze_sensitive_is_freeze; [|done].
- move => /reborrowN_lookup [_ [_ HL]]. by apply HL.
- - apply reborrowN_lookup in EQB as [_ [_ HL]]. by apply HL.
- - move : EQB. rewrite visit_freeze_sensitive_is_freeze; [|done].
- move => /reborrowN_lookup [_ [_ HL]]. by apply HL.
-Qed.
-
-
-Lemma retag_ref_is_freeze_is_Some α cids nxtp l old T kind prot
- (BLK: ∀ n, (n < tsize T)%nat → l +ₗ n ∈ dom α)
- (FRZ: is_freeze T)
- (STK: ∀ m stk, (m < tsize T)%nat → α !! (l +ₗ m) = Some stk →
- let access := match kind with
- | SharedRef | RawRef false => AccessRead
- | _ => AccessWrite
- end in access1_pre cids stk access old) :
- is_Some (retag_ref α cids nxtp l old T kind prot).
-Proof.
- rewrite /retag_ref. destruct (tsize T) as [|sT] eqn:Eqs; [by eexists|].
- set new := match kind with
- | RawRef _ => Untagged
- | _ => Tagged nxtp
- end.
- destruct (reborrow_is_freeze_is_Some α cids l old T kind new prot)
- as [α1 Eq1]; [by rewrite Eqs|..|done| |].
- { intros m stk Lt. apply STK. by rewrite -Eqs. }
- rewrite Eq1 /=. by eexists.
-Qed.
-
-Definition valid_protector rkind (cids: call_id_set) c :=
- match rkind with | FnEntry => c ∈ cids | _ => True end.
-Definition pointer_kind_access pk :=
- match pk with
- | RefPtr Mutable | RawPtr Mutable | BoxPtr => AccessWrite
- | _ => AccessRead
- end.
-Definition valid_block (α: stacks) cids (l: loc) (tg: tag) pk T :=
- is_freeze T ∧
- (∀ m, (m < tsize T)%nat → l +ₗ m ∈ dom α ∧ ∃ stk,
- α !! (l +ₗ m) = Some stk ∧ access1_pre cids stk (pointer_kind_access pk) tg).
-
-Lemma retag_is_freeze_is_Some α nxtp cids c l otg kind pk T
- (LOC: valid_block α cids l otg pk T) :
- is_Some (retag α nxtp cids c l otg kind pk T).
-Proof.
- destruct LOC as (FRZ & EQD).
- destruct pk as [[]|mut|]; simpl.
- - destruct (retag_ref_is_freeze_is_Some α cids nxtp l otg T
- (UniqueRef (is_two_phase kind)) (adding_protector kind c))
- as [bac Eq]; [by apply EQD|done..| |by eexists].
- simpl. clear -EQD. intros m stk Lt Eq.
- destruct (EQD _ Lt) as [_ [stk' [Eq' ?]]]. by simplify_eq/=.
- - destruct (retag_ref_is_freeze_is_Some α cids nxtp l otg T SharedRef
- (adding_protector kind c))
- as [bac Eq]; [by apply EQD|done..| |by eexists].
- simpl. clear -EQD. intros m stk Lt Eq.
- destruct (EQD _ Lt) as [_ [stk' [Eq' ?]]]. by simplify_eq/=.
- - destruct kind; [by eexists..| |by eexists].
- destruct (retag_ref_is_freeze_is_Some α cids nxtp l otg T
- (RawRef (bool_decide (mut = Mutable))) None)
- as [bac Eq]; [by apply EQD|done..| |by eexists].
- simpl. clear -EQD. intros m stk Lt Eq.
- destruct (EQD _ Lt) as [_ [stk' [Eq' ?]]]. simplify_eq/=. by destruct mut.
- - destruct (retag_ref_is_freeze_is_Some α cids nxtp l otg T
- (UniqueRef false) None)
- as [bac Eq]; [by apply EQD|done..| |by eexists].
- simpl. clear -EQD. intros m stk Lt Eq.
- destruct (EQD _ Lt) as [_ [stk' [Eq' ?]]]. by simplify_eq/=.
-Qed.
-
-
-Lemma retag_base_step' P σ l otg ntg pk T kind c' α' nxtp':
- c' ∈ σ.(scs) →
- retag σ.(sst) σ.(snp) σ.(scs) c' l otg kind pk T =
- Some (ntg, α', nxtp') →
- let σ' := mkState σ.(shp) α' σ.(scs) nxtp' σ.(snc) in
- base_step P (Retag #[ScPtr l otg] #[ScCallId c'] pk T kind) σ #[ScPtr l ntg] σ' [].
-Proof.
- econstructor. { econstructor; eauto. } simpl.
- econstructor; eauto.
-Qed.
-
-Lemma retag_base_step P σ l c otg pk T kind
- (BAR: c ∈ σ.(scs))
- (LOC: valid_block σ.(sst) σ.(scs) l otg pk T)
- (WF: state_wf σ) :
- ∃ ntg α' nxtp',
- retag σ.(sst) σ.(snp) σ.(scs) c l otg kind pk T =
- Some (ntg, α', nxtp') ∧
- let σ' := mkState σ.(shp) α' σ.(scs) nxtp' σ.(snc) in
- base_step P (Retag #[ScPtr l otg] #[ScCallId c] pk T kind) σ #[ScPtr l ntg] σ' [].
-Proof.
- destruct σ as [h α cids nxtp nxtc]; simpl in *.
- destruct (retag_is_freeze_is_Some α nxtp cids c l otg kind pk T)
- as [[[h' α'] nxtp'] Eq]; [done|].
- exists h', α' , nxtp'. split; [done|].
- eapply retag_base_step'; eauto.
-Qed.
- *)
-
-(* Lemma syscall_base_step σ id :
- base_step (SysCall id) σ [SysCallEvt id] #☠σ [].
-Proof.
- have EE: ∃ σ', base_step (SysCall id) σ [SysCallEvt id] #☠σ' [] ∧ σ' = σ.
- { eexists. split. econstructor; econstructor. by destruct σ. }
- destruct EE as [? [? ?]]. by subst.
-Qed. *)
diff --git a/theories/tree_borrows/steps_wf.v b/theories/tree_borrows/steps_wf.v
index 2d4409a92391365c4019134ddd00e36fcd0053b7..4a2644ab6123e17c4b61538f4127e5af93f83e03 100755
--- a/theories/tree_borrows/steps_wf.v
+++ b/theories/tree_borrows/steps_wf.v
@@ -1,62 +1,22 @@
-(** This file has been adapted from the Stacked Borrows development, available at
-https://gitlab.mpi-sws.org/FP/stacked-borrows
-*)
+(** The core idea of this file is to prove that all borrow steps preserve
+ well-formedness of trees. *)
-From simuliris.tree_borrows Require Import helpers.
-From simuliris.tree_borrows Require Export defs steps_foreach steps_access steps_preserve bor_lemmas.
+From simuliris.tree_borrows Require Export defs tree_lemmas steps_foreach steps_preserve bor_lemmas.
From iris.prelude Require Import options.
(* weird GMAP stuff *)
-Lemma gmap_dep_fold_ind_strong {B A P} (f : positive → A → B → B) (Q : B → gmap_dep A P → Prop) (b : B) j :
- Q b GEmpty →
- (∀ i p x mt r, gmap.gmap_dep_lookup i mt = None →
- r = gmap.gmap_dep_fold f j b mt →
- (∀ B' f' (b':B'), (f' (Pos.reverse_go i j) x (gmap.gmap_dep_fold f' j b' mt)) = gmap.gmap_dep_fold f' j b' (gmap.gmap_dep_partial_alter (λ _, Some x) i p mt)) →
- Q r mt →
- Q (f (Pos.reverse_go i j) x r) (gmap.gmap_dep_partial_alter (λ _, Some x) i p mt)) →
- ∀ mt, Q (gmap.gmap_dep_fold f j b mt) mt.
-Proof.
- intros Hemp Hinsert mt. revert Q b j Hemp Hinsert.
- induction mt as [|P ml mx mr ? IHl IHr] using gmap.gmap_dep_ind;
- intros Q b j Hemp Hinsert; [done|].
- rewrite gmap.gmap_dep_fold_GNode; try done.
- apply (IHr (λ y mt, Q y (gmap.GNode ml mx mt))).
- { apply (IHl (λ y mt, Q y (gmap.GNode mt mx GEmpty))).
- { destruct mx as [[p x]|]; [|done].
- replace (gmap.GNode gmap.GEmpty (Some (p,x)) gmap.GEmpty) with
- (gmap.gmap_dep_partial_alter (λ _, Some x) 1 p gmap.GEmpty) by done.
- by apply Hinsert. }
- intros i p x mt r H1 H2 H3 H4.
- replace (gmap.GNode (gmap.gmap_dep_partial_alter (λ _, Some x) i p mt) mx gmap.GEmpty)
- with (gmap.gmap_dep_partial_alter (λ _, Some x) (i~0) p (gmap.GNode mt mx gmap.GEmpty))
- by (by destruct mt, mx as [[]|]).
- apply Hinsert. 1,4: by rewrite ?gmap.gmap_dep_lookup_GNode.
- 1: by destruct mt, mx as [[]|]; done.
- intros B' f' b'. destruct mt, mx as [[]|]; simpl in *.
- 1: done. 1: done. all: rewrite H3; by destruct gmap.gmap_dep_ne_partial_alter. }
- intros i p x mt r H1 H2 H3 H4.
- replace (gmap.GNode ml mx (gmap.gmap_dep_partial_alter (λ _, Some x) i p mt))
- with (gmap.gmap_dep_partial_alter (λ _, Some x) (i~1) p (gmap.GNode ml mx mt))
- by (by destruct ml, mx as [[]|], mt).
- apply Hinsert. all: rewrite ?gmap.gmap_dep_lookup_GNode; try done.
- 1: destruct ml, mx as [[]|], mt; simpl in *; done.
- intros B' f' b'. destruct ml, mx as [[]|], mt; simpl in *.
- 1,3,5,7: done. all: rewrite H3; by destruct gmap.gmap_dep_ne_partial_alter.
-Qed.
Lemma map_fold_ind_strong {K V B} `{Countable K} (P : B → gmap K V → Prop) (f : K → V → B → B) (b:B) (M : gmap K V) :
P b ∅ →
(∀ k v M, M !! k = None → (∀ B' f' (b':B'), map_fold f' b' (<[k:=v]> M) = f' k v (map_fold f' b' M)) → P (map_fold f b M) M → P (f k v (map_fold f b M)) (<[k:=v]> M)) →
P (map_fold f b M) M.
Proof.
- intros H1 H2. destruct M as [M]. rewrite /map_fold /=.
- apply (gmap_dep_fold_ind_strong _ (λ r M, P r (GMap M))); clear M; [done|].
- intros i [Hk] x mt r H0 -> H3; simpl. destruct (fmap_Some_1 _ _ _ Hk) as (k&Hk1&Hk2). subst i.
- rewrite Hk1.
- assert (GMapKey Hk = gmap_key_encode k) as Hk3 by (apply proof_irrel). rewrite Hk3.
- apply (H2 _ _ (GMap mt)). 1: done.
- intros ???. simpl. rewrite /map_fold /gmap_fold /= -Hk3 -H3 /= Hk1 //.
+ intros Hbase Hstep. eapply (map_first_key_ind (fun mm => P (map_fold f b mm) mm)).
+ - rewrite map_fold_empty. apply Hbase.
+ - intros k v m Hnone Hfirstkey HIH.
+ rewrite map_fold_insert_first_key //. eapply Hstep; [done| |done].
+ intros B' f' b'. rewrite map_fold_insert_first_key //.
Qed.
@@ -888,7 +848,7 @@ Proof.
destruct σ as [h trs cids nxtp nxtc].
destruct σ' as [h' trs' cids' nxtp' nxtc']. simpl.
intros BS IS WF. inversion BS. clear BS. simplify_eq.
- inversion IS as [x| | | | | | | | | |]; clear IS. simpl in *; simplify_eq. constructor; simpl.
+ inversion IS as [x| | | | | | | | |]; clear IS. simpl in *; simplify_eq. constructor; simpl.
- apply same_blocks_init_extend; [lia|].
apply WF.
- apply extend_trees_wf.
@@ -1758,7 +1718,7 @@ Proof.
destruct σ' as [h' trs' cids' nxtp' nxtc']. simpl.
intros BS IS WF.
inversion BS; clear BS; simplify_eq.
- inversion IS as [ | | | | | | | |trs'' ???? ACC | | ]; clear IS; simplify_eq.
+ inversion IS as [ | | | | | | |trs'' ???? ACC | | ]; clear IS; simplify_eq.
destruct (trees_deallocate_isSome _ _ _ _ _ _ (mk_is_Some _ _ ACC)) as [x [Lookup Update]].
assert (each_tree_parents_more_init trs'') as HH1.
{ eapply apply_within_trees_deallocate_compat_parents_more_init; try done.
@@ -1845,26 +1805,11 @@ Proof.
destruct σ' as [h' trs' cids' nxtp' nxtc']. simpl.
intros BS IS WF.
inversion BS; clear BS; simplify_eq.
- inversion IS as [ |?????? ACC| | | | | | | | | ]; clear IS; simplify_eq.
+ inversion IS as [ |?????? ACC| | | | | | | | ]; clear IS; simplify_eq.
- eapply (access_step_wf_inner σ false); done.
- by destruct σ.
Qed.
-Lemma failed_copy_step_wf σ σ' e e' l bor T efs :
- mem_expr_step σ.(shp) e (FailedCopyEvt l bor T) σ'.(shp) e' efs →
- bor_step σ.(strs) σ.(scs) σ.(snp) σ.(snc)
- (FailedCopyEvt l bor T)
- σ'.(strs) σ'.(scs) σ'.(snp) σ'.(snc) →
- state_wf σ → state_wf σ'.
-Proof.
- destruct σ as [h α cids nxtp nxtc].
- destruct σ' as [h' α' cids' nxtp' nxtc']. simpl.
- intros BS IS WF.
- inversion BS. clear BS. simplify_eq.
- inversion IS; clear IS; simplify_eq.
- done.
-Qed.
-
(* TODO less equalities makes applying the rule easier, see _sane version below *)
Lemma write_mem_dom l (vl : value) h h'
(DEFINED: ∀ i : nat, (i < length vl)%nat → (l +ₗ i) ∈ dom h)
@@ -2004,7 +1949,7 @@ Proof.
destruct σ' as [h' trs' cids' nxtp' nxtc']. simpl.
intros BS IS WF.
inversion BS; clear BS; simplify_eq.
- inversion IS as [ | | | |?????? ACC |???? RANGE_SIZE| | | | | ]; clear IS; simplify_eq.
+ inversion IS as [ | | |?????? ACC |???? RANGE_SIZE| | | | | ]; clear IS; simplify_eq.
2: { simpl in RANGE_SIZE. destruct vl; last done. simpl. done. }
constructor; simpl.
- rewrite /same_blocks.
@@ -3217,7 +3162,7 @@ Proof.
destruct σ' as [h' trs' cids' nxtp' nxtc']. simpl.
intros BS IS WF.
inversion BS. clear BS. simplify_eq.
- inversion IS as [| | | | | |trsmid ???????? EXISTS_TAG FRESH_CHILD RETAG_EFFECT READ_ON_REBOR| | | |].
+ inversion IS as [| | | | |trsmid ???????? EXISTS_TAG FRESH_CHILD RETAG_EFFECT READ_ON_REBOR| | | |].
2: by simplify_eq. simplify_eq.
eapply retag_step_wf_inner in WF as (WF&TAG_AFTER_ADD); simpl in WF|-*. 2-5: try done.
eapply access_step_wf_inner in WF. all: done.
@@ -3231,7 +3176,7 @@ Proof.
- eapply alloc_step_wf; eauto.
- eapply dealloc_step_wf; eauto.
- eapply read_step_wf; eauto.
- - eapply failed_copy_step_wf; eauto.
+ (* - eapply failed_copy_step_wf; eauto. *)
- eapply write_step_wf; eauto.
- eapply initcall_step_wf; eauto.
- eapply endcall_step_wf; eauto.
diff --git a/theories/tree_borrows/tkmap_view.v b/theories/tree_borrows/tkmap_view.v
index 1e2e3bf2fc7874a19492ab906eda7a0179119d99..51c4c5fcfbc198490db1be440dd50398e5b3f091 100755
--- a/theories/tree_borrows/tkmap_view.v
+++ b/theories/tree_borrows/tkmap_view.v
@@ -1,7 +1,3 @@
-(** This file has been adapted from the Iris development, available at
- https://gitlab.mpi-sws.org/iris/iris
-*)
-
From Coq.QArith Require Import Qcanon.
From iris.algebra Require Export view gmap frac dfrac.
From iris.algebra Require Import local_updates proofmode_classes big_op.
@@ -13,16 +9,14 @@ From simuliris.tree_borrows Require Export defs.
(gmap_view has since been updated so we could now use it directly, but this code predates the generalized gmap_view for arbitrary CRMA.) *)
(* Currently, we place a strong restriction on the shape of a location's stack:
- A tag can be of one of two kinds:
+ A tag can be of one of several kinds:
- tk_pub: the tag is public (can be shared, assertion is persistent)
- - tk_unq: the tag is unique (cannot be shared, assertion is not persistent).
- - tk_loc: the tag is local
+ - tk_unq: the tag is unique (cannot be shared, assertion is not persistent). This is further parameterized by whether it is reserved or activated.
+ - tk_loc: the tag is local (a local variable whose address has not been taken)
*)
-(* TODO: allow a local update from tk_unq to tk_pub *)
Definition tagKindR := csumR (exclR unitO) (csumR (csumR (exclR unitO) (exclR unitO)) unitR).
-
Canonical Structure tag_kindO := leibnizO tag_kind.
Global Instance tagKindR_discrete : CmraDiscrete tagKindR.
diff --git a/theories/tree_borrows/tree.v b/theories/tree_borrows/tree.v
index 72039ac16fea00c9b9f15b2538fdb838f62a1305..400ee57e927b73d56d066ffbfdef4cfc18143be0 100644
--- a/theories/tree_borrows/tree.v
+++ b/theories/tree_borrows/tree.v
@@ -19,30 +19,36 @@ Proof.
Qed.
-(* Generic tree
- Note: we are using the "tilted" representation of n-ary trees
- where the binary children are the next n-ary sibling and
- the first n-ary child.
- This is motivated by the much nicer induction principles
- we get, but requires more careful definition of the
- parent-child relationship.
+(* Generic tree *)
+(* NOTE: we are using the "tilted" representation of n-ary trees
+ where the binary children are the next n-ary sibling and the first n-ary child.
+ This is motivated by the much nicer induction principles we get,
+ but requires more careful definition of the parent-child relationship.
+ In any case anything we do here is abstracted away as far as the more
+ high-level principles are concerned.
*)
Inductive tree X :=
| empty
| branch (data:X) (sibling child:tree X)
.
-(* x
+(* EXAMPLE:
+
+ the n-ary tree of width 4 and height 2
+
+ x
|- y1
|- y2
|- y3
|- y4
+ is encoded by a binary tree of height 5
+
branch x
empty
(branch y1
(branch y2
(branch y3
- (branch y4)
+ (branch y4 empty empty)
empty
empty
empty
@@ -56,6 +62,11 @@ Definition of_branch {X} (br:tbranch X)
: tree X :=
let '(root, lt, rt) := br in branch root lt rt.
+Definition root {X} (br:tbranch X)
+ : X := let '(r, _, _) := br in r.
+
+(** The main traversal operation is the folding. *)
+
Definition fold_subtrees {X Y} (unit:Y) (combine:tbranch X -> Y -> Y -> Y)
: tree X -> Y := fix aux tr : Y :=
match tr with
@@ -63,13 +74,13 @@ Definition fold_subtrees {X Y} (unit:Y) (combine:tbranch X -> Y -> Y -> Y)
| branch data sibling child => combine (data, sibling, child) (aux sibling) (aux child)
end.
-Definition root {X} (br:tbranch X)
- : X := let '(r, _, _) := br in r.
-
Definition fold_nodes {X Y} (unit:Y) (combine:X -> Y -> Y -> Y)
: tree X -> Y := fold_subtrees unit (fun subtree sibling child => combine (root subtree) sibling child).
-Definition map_nodes {X Y} (fn:X -> Y) : tree X -> tree Y := fold_nodes empty (compose branch fn).
+(** From which we define [map] as is standard. *)
+
+Definition map_nodes {X Y} (fn:X -> Y) : tree X -> tree Y :=
+ fold_nodes empty (compose branch fn).
Definition join_nodes {X}
: tree (option X) -> option (tree X) := fix aux tr {struct tr} : option (tree X) :=
@@ -82,6 +93,9 @@ Definition join_nodes {X}
Some $ branch data sibling child
end.
+(** Quantifiers over trees, universal and existential.
+ All of them are of course decidable. *)
+
Definition every_subtree {X} (prop:tbranch X -> Prop) (tr:tree X)
:= fold_subtrees True (fun sub lt rt => prop sub /\ lt /\ rt) tr.
Global Instance every_subtree_dec {X} prop (tr:tree X) : (forall x, Decision (prop x)) -> Decision (every_subtree prop tr).
@@ -100,9 +114,14 @@ Definition exists_node {X} (prop:X -> Prop) (tr:tree X) := fold_nodes False (fun
Global Instance exists_node_dec {X} prop (tr:tree X) : (forall x, Decision (prop x)) -> Decision (exists_node prop tr).
Proof. intro. induction tr; solve_decision. Defined.
+
+(** Alternative to a quantifier, we can state exactly how many nodes
+ satisfy a certain property. From this we derive unique existential quantification. *)
Definition count_nodes {X} (prop:X -> bool) :=
fold_nodes 0 (fun data lt rt => (if prop data then 1 else 0) + lt + rt).
+(* As a consequence of the representation, strict children are all
+ the nodes from the right subtree. *)
Definition exists_strict_child {X} (prop:X -> Prop)
: tbranch X -> Prop := fun '(_, _, child) => exists_node prop child.
Global Instance exists_strict_child_dec {X} prop (tr:tbranch X) :
@@ -114,6 +133,11 @@ Definition empty_children {X} (tr:tbranch X)
let '(_, _, children) := tr in
children = empty.
+(** Other main tree operation is insertion.
+ We use a somewhat nonstandard definition in which insertion occurs
+ as a child of every node that satisfies a certain property.
+ You will need quantifiers about the existence of nodes that satisfy
+ [search_dec] if you want to make sure that the node is actually inserted. *)
Definition insert_child_at {X} (tr:tree X) (ins:X) (search:X -> Prop) {search_dec:forall x, Decision (search x)} : tree X :=
(fix aux tr : tree X :=
match tr with
@@ -128,7 +152,10 @@ Definition insert_child_at {X} (tr:tree X) (ins:X) (search:X -> Prop) {search_de
) tr.
Definition fold_siblings {X Y} (empty:Y) (fn : X -> Y -> Y) (tr : tree X) : Y :=
- fold_nodes empty (λ x tl _, fn x tl) tr.
+ fold_nodes empty (λ this siblings _, fn this siblings) tr.
+
+(** Immediate children are a bit more tricky to reason about.
+ They are the entire leftmost *branch* of the right subtree. *)
Fixpoint fold_immediate_children_at {X Y} (prop:X -> bool) (empty:Y) (fn : X -> Y -> Y) (tr : tree X) : list Y :=
match tr with empty => nil
| branch x tl tr => (if prop x then [fold_siblings empty fn tr] else nil) ++
diff --git a/theories/tree_borrows/tree_access_laws.v b/theories/tree_borrows/tree_access_laws.v
index 3f01f843e3dd78c40271b7d439c7c889c8d97ecb..b99f619f911499eb7ad08bf1e36d80c940af8e78 100644
--- a/theories/tree_borrows/tree_access_laws.v
+++ b/theories/tree_borrows/tree_access_laws.v
@@ -25,7 +25,7 @@ Proof.
destruct (trs !! blk); [|tauto].
intros Ex Eq. injection Eq; intros; subst. assumption.
Qed.
-(***** not part of the API *****)
+(***** END not part of the API *****)
Lemma trees_contain_trees_lookup_1 trs blk tg :
wf_trees trs →
@@ -329,8 +329,8 @@ Proof.
Qed.
(* Reverse lifting to single trees.
- This is a roundabout of proving these, but we started with the lemmas above and this way there is the least refactoring effort. *)
-
+ This is a roundabout of proving these, but we started with the lemmas above
+ and this way there is the least refactoring effort. *)
Lemma wf_tree_wf_singleton_any z tr : wf_tree tr → wf_trees (singletonM z tr).
Proof.
@@ -427,7 +427,8 @@ Proof.
Qed.
-(* Some more facts about trees. These could be refactored, maybe? *)
+(* Some more facts about trees. *)
+(* TODO: These could be refactored, maybe? *)
Lemma apply_access_perm_access_remains_disabled b acc rel isprot itmo itmn :
maybe_non_children_only b (apply_access_perm acc) rel isprot itmo = Some itmn →
@@ -768,4 +769,4 @@ Proof.
2: done. 2: by eapply Hwf. 2: done. 2: done.
- rewrite /= insert_id //.
- by exists it.
-Qed.
\ No newline at end of file
+Qed.
diff --git a/theories/tree_borrows/tree_lemmas.v b/theories/tree_borrows/tree_lemmas.v
index b0470ca7cc6f46af96a3b25c25fa87215563e2ad..2eb5bf0dba6bb863eb05af30d48ef3974bae97b1 100644
--- a/theories/tree_borrows/tree_lemmas.v
+++ b/theories/tree_borrows/tree_lemmas.v
@@ -1,7 +1,7 @@
From Equations Require Import Equations.
From iris.prelude Require Import prelude options.
From stdpp Require Export gmap.
-From simuliris.tree_borrows Require Export lang_base notation tree.
+From simuliris.tree_borrows Require Export tree.
From iris.prelude Require Import options.
Implicit Type (V W X Y:Type).
@@ -246,42 +246,6 @@ Proof.
all: simpl; auto.
Qed.
-(*
-Lemma exists_child_transitive {X} (search search':Tprop X) :
- forall tr,
- exists_node search tr ->
- tree_AtNode search (tree_ChildExists search') tr ->
- exists_node search' tr.
-Proof.
- intros tr Exists Search.
- induction tr; simpl; auto.
- destruct Search as [Search0 [Search1 Search2]].
- destruct Exists as [Exists0 | [Exists1 | Exists2]]; auto.
- destruct (Search0 Exists0); auto.
-Qed.
-
-Lemma AtNodeExists_transitive {X} (search search' search'':Tprop X) :
- forall tr,
- tree_AtNode search (tree_ChildExists search') tr ->
- tree_AtNode search' (tree_ChildExists search'') tr ->
- tree_AtNode search (tree_ChildExists search'') tr.
-Proof.
- intros tr Search Search'.
- induction tr; auto.
- destruct Search' as [Search' [Search'1 Search'2]].
- destruct Search as [Search [Search1 Search2]].
- pose Found1 := (IHtr1 Search1 Search'1).
- pose Found2 := (IHtr2 Search2 Search'2).
- simpl; try repeat split; auto.
- clear Found1; clear Found2; clear IHtr1; clear IHtr2.
- intro Found; destruct (Search Found) as [Found' | FoundSub].
- - destruct (Search' Found') as [Found'' | Found'Sub]; auto.
- - right; clear Found; clear Search; clear Search1; clear Search2.
- clear Search'.
- apply (ExistsAtNode_transitive search'); auto.
-Qed.
-*)
-
Lemma insert_true_preserves_every {X} (tr:tree X) (ins:X) (search prop:X -> Prop)
{search_dec:forall x, Decision (search x)} :
prop ins ->
@@ -370,21 +334,6 @@ Proof.
* right; right; auto.
Qed.
-(*
-Lemma insert_preserves_ChildExists {X} (ins:X) (tr:tree X) (search prop:Tprop X)
- {search_dec:forall x, Decision (search x)} :
- tree_ChildExists prop tr -> tree_ChildExists prop (insert_child_at tr ins search).
-Proof.
- intro Exists.
- destruct tr; simpl; auto.
- destruct (decide (search data)) eqn:Found; simpl; auto.
- all: simpl in Exists.
- all: inversion Exists as [Ex0 | Ex2]; auto.
- 1: right; right; left; apply insert_preserves_Exists; auto.
- right; apply insert_preserves_Exists; auto.
-Qed.
-*)
-
Lemma exists_insert_requires_parent {X} (ins:X) (search prop:X -> Prop)
{search_dec:forall x, Decision (search x)} :
forall tr,
@@ -414,7 +363,7 @@ Proof.
right; right. destruct Hyp2 as [Contra | [Hyp2Sub | Hyp2Empty]]; auto; contradiction.
Qed.
-Lemma exists_subtree_transitive br prop (tr:tree item) :
+Lemma exists_subtree_transitive T br prop (tr:tree T) :
exists_subtree (eq br) tr ->
exists_subtree prop (of_branch br) ->
exists_subtree prop tr.
@@ -428,7 +377,7 @@ Proof.
- right; right. apply IHtr2; auto.
Qed.
-Lemma every_subtree_transitive br prop (tr:tree item) :
+Lemma every_subtree_transitive T br prop (tr:tree T) :
every_subtree (eq br) tr ->
every_subtree prop (of_branch br) ->
every_subtree prop tr.
@@ -442,7 +391,7 @@ Proof.
try repeat split; auto.
Qed.
-Lemma exists_node_transitive br prop (tr:tree item) :
+Lemma exists_node_transitive T br prop (tr:tree T) :
exists_subtree (eq br) tr ->
exists_node prop (of_branch br) ->
exists_node prop tr.
diff --git a/theories/tree_borrows/trees_equal/disabled_in_practice.v b/theories/tree_borrows/trees_equal/disabled_in_practice.v
index 6bdb6d5be7b7c86b38b420d876dc78bc07ac225b..9e635cd1f8421b380ce331273814b6a179e8e6d6 100644
--- a/theories/tree_borrows/trees_equal/disabled_in_practice.v
+++ b/theories/tree_borrows/trees_equal/disabled_in_practice.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
diff --git a/theories/tree_borrows/trees_equal/random_lemmas.v b/theories/tree_borrows/trees_equal/random_lemmas.v
index 6a745b9d77d59f30e91d744b643d021e789a51c3..7abccdfb6156b37c222dffa7f93d225eb1ef9d17 100644
--- a/theories/tree_borrows/trees_equal/random_lemmas.v
+++ b/theories/tree_borrows/trees_equal/random_lemmas.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -13,7 +12,6 @@ From simuliris.tree_borrows.trees_equal Require Import trees_equal_base.
From iris.prelude Require Import options.
-(* TODO cleanup *)
Section utils.
Lemma every_node_iff_every_lookup
@@ -270,7 +268,7 @@ Section utils.
Qed.
- (* FIXME: move this elsewhere *)
+ (* FIXME: This is a very low level lemma, move this elsewhere ? *)
Lemma if_fun_absorb_args {X Y} {b : bool} {x : X} {f g : X -> Y} :
(if b then f else g) x = if b then f x else g x.
Proof. destruct b; reflexivity. Qed.
@@ -443,4 +441,4 @@ Section utils.
Qed.
-End utils.
\ No newline at end of file
+End utils.
diff --git a/theories/tree_borrows/trees_equal/trees_equal.v b/theories/tree_borrows/trees_equal/trees_equal.v
deleted file mode 100644
index c80419ce21dadf9cce1c612d7f9880feb2244b0c..0000000000000000000000000000000000000000
--- a/theories/tree_borrows/trees_equal/trees_equal.v
+++ /dev/null
@@ -1,4167 +0,0 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
-From iris.proofmode Require Export proofmode.
-From iris.bi.lib Require Import fractional.
-From iris.base_logic.lib Require Import ghost_map.
-From simuliris.base_logic Require Export gen_sim_prog.
-From simuliris.simulation Require Export slsls gen_log_rel.
-From simuliris.simulation Require Import lifting.
-From simuliris.tree_borrows Require Import tkmap_view.
-From simuliris.tree_borrows Require Export defs.
-From simuliris.tree_borrows Require Export steps_wf.
-From simuliris.tree_borrows Require Import steps_progress.
-From iris.prelude Require Import options.
-
-
-(* TODO cleanup *)
-Section utils.
-
- Definition tag_valid (upper : tag) (n : tag) : Prop := (n < upper)%nat.
-
- Lemma tag_valid_mono upper1 upper2 n1 n2 :
- tag_valid upper1 n1 →
- (upper1 ≤ upper2)%nat →
- (n2 ≤ n1)%nat →
- tag_valid upper2 n2.
- Proof.
- rewrite /tag_valid. lia.
- Qed.
-
- Context (C : gset call_id).
-
- (* trees_equal is almost symmetric. To still get nice reasoning rules around symmetry and stuff,
- we add a directionality flags for all rules that hold on both sides, so that we can reason by
- symmetry -> foo -> symmetry and so only have to formulate foo to operate on one side *)
- Inductive direction := Forwards | Backwards.
-
- Inductive pseudo_conflicted (tr : tree item) (tg : tag) (l : Z)
- : res_conflicted → Prop :=
- | pseudo_conflicted_conflicted :
- (* a Conflicted marker makes the permission literally conflicted *)
- pseudo_conflicted tr tg l ResConflicted
- | pseudo_conflicted_cousin_init tg_cous it_cous :
- (* If it's not actually conflicted, it can be pseudo conflicted if there is *)
- (* A cousin that is protected *)
- rel_dec tr tg tg_cous = Foreign Cousin ->
- tree_lookup tr tg_cous it_cous ->
- protector_is_active it_cous.(iprot) C ->
- (* and who on this location is initalized not disabled *)
- (item_lookup it_cous l).(perm) ≠Disabled ->
- (item_lookup it_cous l).(initialized) = PermInit ->
- pseudo_conflicted tr tg l ResActivable
- .
-
- Inductive pseudo_disabled (tr : tree item) (tg : tag) (l : Z) : permission → (option protector) → Prop :=
- | pseudo_disabled_disabled prot :
- (* a Disabled it also pseudo-disabled *)
- pseudo_disabled _ _ _ Disabled prot
- | pseudo_disabled_cousin_active tg_cous it_cous lp prot :
- rel_dec tr tg tg_cous = Foreign Cousin ->
- tree_lookup tr tg_cous it_cous ->
- protector_is_active it_cous.(iprot) C ->
- (item_lookup it_cous l) = mkPerm PermInit Active ->
- (* This is not allowed, since it actually survives foreign writes. *)
- lp ≠ReservedIM ->
- pseudo_disabled _ _ _ lp prot
- .
-
- (* this implicitly requires (by state_wf) that it's not (protected and initialized) *)
- (* it also implies (via state_wf) that all children are not (protected and initialized) *)
- Inductive is_disabled (tr : tree item) (tg : tag) (l : Z) : lazy_permission → option protector → Prop :=
- | disabled_init prot :
- is_disabled _ _ _ (mkPerm PermInit Disabled) prot
- | disabled_pseudo lp prot :
- pseudo_disabled tr tg l lp prot →
- is_disabled _ _ _ (mkPerm PermLazy lp) prot.
-
- Inductive disabled_in_practice (tr : tree item) (tg : tag) (witness : tag) (l : Z)
- : Prop :=
- | disabled_parent it_witness inclusive :
- (* Doesn't have to be immediate, just any parent is Disabled *)
- rel_dec tr tg witness = Child inclusive ->
- tree_lookup tr witness it_witness ->
- is_disabled tr witness l (item_lookup it_witness l) (iprot it_witness) ->
- disabled_in_practice tr tg witness l
- .
-
- Inductive parent_has_perm p (tr : tree item) (tg : tag) (witness : tag) (l : Z)
- : Prop :=
- (* This means being Reserved and having a parent that is exactly Frozen.
- [frozen_in_practice] behaves indistinguishably from Frozen.
- We could probably make [Frozen] and [frozen_in_practice] equivalent, but
- this shouldn't turn up in practice. *)
- | mk_parent_has_perm it_witness inclusive :
- rel_dec tr tg witness = Child inclusive ->
- tree_lookup tr witness it_witness ->
- (item_lookup it_witness l).(perm) = p ->
- (* be initialized so that protectors trigger if applicable *)
- (item_lookup it_witness l).(initialized) = PermInit ->
- parent_has_perm p tr tg witness l
- .
-
- Definition frozen_in_practice := parent_has_perm Frozen.
-
- Inductive one_sided_sim : Prop -> permission -> permission -> Prop :=
- | one_sided_sim_active isprot :
- ¬ isprot ->
- one_sided_sim isprot Frozen Active
- | one_sided_sim_res_confl isprot :
- isprot ->
- one_sided_sim isprot (Reserved ResConflicted) (Reserved ResActivable).
-
- Definition directional_simulation d isprot p1 p2 : Prop :=
- match d with
- | Forwards => one_sided_sim isprot p1 p2
- | Backwards => one_sided_sim isprot p2 p1
- end.
-
- Inductive perm_eq_up_to_C (tr1 tr2 : tree item) (tg : tag) (l : Z) cid d
- : lazy_permission -> lazy_permission -> Prop :=
- | perm_eq_up_to_C_refl p :
- (* Usually the permissions will be equal *)
- perm_eq_up_to_C tr1 tr2 tg l cid d p p
- | perm_eq_up_to_C_pseudo ini confl1 confl2 :
- (* But if they are protected *)
- protector_is_active cid C ->
- (* And both pseudo-conflicted *)
- pseudo_conflicted tr1 tg l confl1 ->
- pseudo_conflicted tr2 tg l confl2 ->
- (* then we can allow a small difference *)
- perm_eq_up_to_C tr1 tr2 tg l cid d
- {| initialized := ini; perm := Reserved confl1 |}
- {| initialized := ini; perm := Reserved confl2 |}
- | perm_eq_up_to_C_pseudo_post_prot ini confl1 confl2 :
- (* But if they are not protected *)
- ¬ protector_is_active cid C ->
- (* then we can allow a small difference *)
- perm_eq_up_to_C tr1 tr2 tg l cid d
- {| initialized := ini; perm := Reserved confl1 |}
- {| initialized := ini; perm := Reserved confl2 |}
- | perm_eq_up_to_C_pseudo_disabled p1 p2 :
- (* A pseudo-disabled tag is one that's lazy, does not support child accesses due to a protected Active cousin,
- and will become Disabled on protector-end write for that cousin.
- It must be lazy, because a protected active has no non-disabled initialized cousins.
- Only exception: ¬prot Reserved InteriorMut, for which this case here does not apply. *)
- pseudo_disabled tr1 tg l p1 cid ->
- pseudo_disabled tr2 tg l p2 cid ->
- perm_eq_up_to_C tr1 tr2 tg l cid d
- {| initialized := PermLazy; perm := p1 |}
- {| initialized := PermLazy; perm := p2 |}
- | perm_eq_up_to_C_disabled_parent witness_tg p p' :
- (* Finally if they have a Disabled parent we allow anything (unprotected) since
- nothing is possible through this tag anyway *)
- disabled_in_practice tr1 tg witness_tg l ->
- disabled_in_practice tr2 tg witness_tg l ->
- (* Added initialization requirement to help with the lemma [perm_eq_up_to_C_same_init] *)
- (initialized p = initialized p') ->
- perm_eq_up_to_C tr1 tr2 tg l cid d p p'
- | perm_eq_up_to_C_frozen_parent ini confl1 confl2 witness_tg :
- (* not needed for IM, that's already covered by refl *)
- (* only the source side must be Frozen. This already implies the other side is frozen in practice,
- or the same with Active, or we're disabled on both. *)
- frozen_in_practice (match d with Forwards => tr1 | _ => tr2 end) tg witness_tg l ->
- perm_eq_up_to_C tr1 tr2 tg l cid d
- {| initialized := ini; perm := Reserved confl1 |}
- {| initialized := ini; perm := Reserved confl2 |}
- | perm_eq_up_to_C_directional p1 p2 ini :
- directional_simulation d (protector_is_active cid C) p1 p2 ->
- perm_eq_up_to_C tr1 tr2 tg l cid d
- {| initialized := ini; perm := p1 |}
- {| initialized := ini; perm := p2 |}
- .
-
- Definition loc_eq_up_to_C (tr1 tr2 : tree item) (tg : tag) d (it1 it2 : item) (l : Z) :=
- it1.(iprot) = it2.(iprot)
- /\ perm_eq_up_to_C tr1 tr2 tg l it1.(iprot) d (item_lookup it1 l) (item_lookup it2 l).
-
- Definition item_eq_up_to_C (tr1 tr2 : tree item) (tg : tag) d (it1 it2 : item) :=
- forall l, loc_eq_up_to_C tr1 tr2 tg d it1 it2 l.
-
- Definition tree_equal d (tr1 tr2 : tree item) :=
- (* To be equal trees must have exactly the same tags *)
- (forall tg, tree_contains tg tr1 <-> tree_contains tg tr2)
- (* and define all the same relationships between those tags *)
- /\ (forall tg tg', rel_dec tr1 tg tg' = rel_dec tr2 tg tg')
- (* and have their permissions be equal up to C on all locations *)
- (* FIXME: maybe think about reformulating ∧ (∀ t it1 it2, tree_lookup t it1 tr1 -> tree_lookup t it2 tr2 -> it_rel it1 it2) *)
- /\ (forall tg, tree_contains tg tr1 ->
- exists it1 it2,
- tree_lookup tr1 tg it1
- /\ tree_lookup tr2 tg it2
- /\ item_eq_up_to_C tr1 tr2 tg d it1 it2
- ).
-
- Definition trees_equal d (t1 t2 : trees) :=
- ∀ blk, option_Forall2 (tree_equal d) (t1 !! blk) (t2 !! blk).
-
-
- Lemma loc_eq_up_to_C_reflexive
- {d tr1 tr2 tg it l}
- : loc_eq_up_to_C tr1 tr2 tg d it it l.
- Proof.
- split.
- + reflexivity.
- + apply perm_eq_up_to_C_refl.
- Qed.
-
- Lemma item_eq_up_to_C_reflexive
- {d tr1 tr2 tg it}
- : item_eq_up_to_C tr1 tr2 tg d it it.
- Proof.
- intro l.
- apply loc_eq_up_to_C_reflexive.
- Qed.
-
- Lemma tree_equal_reflexive d tr
- (AllUnique : forall tg, tree_contains tg tr -> exists it, tree_item_determined tg it tr)
- : tree_equal d tr tr.
- Proof.
- try repeat split.
- - tauto.
- - tauto.
- - intros tg Ex.
- destruct (AllUnique tg Ex).
- eexists. eexists.
- try repeat split.
- + assumption.
- + eassumption.
- + assumption.
- + eassumption.
- + apply item_eq_up_to_C_reflexive.
- Qed.
-
-
- Lemma trees_equal_reflexive d trs
- (AllUnique : forall blk tr tg,
- trs !! blk = Some tr ->
- tree_contains tg tr ->
- exists it, tree_item_determined tg it tr)
- : trees_equal d trs trs.
- Proof.
- intros blk.
- specialize (AllUnique blk).
- remember (trs !! blk) as at_blk.
- destruct at_blk.
- - apply Some_Forall2.
- apply tree_equal_reflexive.
- intro tg.
- eapply AllUnique.
- reflexivity.
- - apply None_Forall2.
- Qed.
-
-
- Lemma trees_equal_same_tags d (trs1 trs2 : trees) (tg : tag) (blk : block) :
- trees_equal d trs1 trs2 ->
- trees_contain tg trs1 blk <-> trees_contain tg trs2 blk.
- Proof.
- intro Equals.
- rewrite /trees_equal in Equals.
- specialize (Equals blk).
- rewrite /trees_contain /trees_at_block.
- destruct (trs1 !! blk) as [tr1|];
- destruct (trs2 !! blk) as [tr2|];
- inversion Equals as [?? Equal|].
- 2: tauto.
- subst.
- destruct Equal as [SameTags _].
- apply SameTags.
- Qed.
-
- Lemma trees_equal_empty d : trees_equal d ∅ ∅.
- Proof.
- apply trees_equal_reflexive.
- intros blk tr tg LookupEmp.
- inversion LookupEmp.
- Qed.
-
- Definition direction_flip d := match d with
- Forwards => Backwards
- | Backwards => Forwards end.
-
- Lemma direction_flip_inv d : direction_flip (direction_flip d) = d.
- Proof. by destruct d. Qed.
-
- Lemma perm_eq_up_to_C_sym
- {d tr1 tr2 tg l cid perm1 perm2}
- : perm_eq_up_to_C tr1 tr2 tg l cid d perm1 perm2
- -> perm_eq_up_to_C tr2 tr1 tg l cid (direction_flip d) perm2 perm1.
- Proof.
- intro EqC.
- inversion EqC.
- + econstructor 1.
- + econstructor 2; eassumption.
- + econstructor 3; eassumption.
- + econstructor 4; eassumption.
- + econstructor 5; try eassumption.
- done.
- + econstructor 6; destruct d; eassumption.
- + econstructor 7; destruct d; eassumption.
- Qed.
-
- Lemma loc_eq_up_to_C_sym
- {d tr1 tr2 tg it1 it2 l}
- : loc_eq_up_to_C tr1 tr2 tg d it1 it2 l
- -> loc_eq_up_to_C tr2 tr1 tg (direction_flip d) it2 it1 l.
- Proof.
- intros [SameProt EqC].
- split.
- + auto.
- + apply perm_eq_up_to_C_sym.
- rewrite <- SameProt.
- assumption.
- Qed.
-
- Lemma item_eq_up_to_C_sym
- {d tr1 tr2 tg it1 it2}
- : item_eq_up_to_C tr1 tr2 tg d it1 it2
- -> item_eq_up_to_C tr2 tr1 tg (direction_flip d) it2 it1.
- Proof.
- intros EqC l.
- apply loc_eq_up_to_C_sym.
- auto.
- Qed.
-
- Lemma tree_equal_sym {d} tr1 tr2 : tree_equal d tr1 tr2 → tree_equal (direction_flip d) tr2 tr1.
- Proof.
- rewrite /tree_equal.
- intros [SameTg [SameRel EqC]].
- split; [|split].
- + intro tg. rewrite SameTg. tauto.
- + intros tg tg'. rewrite SameRel. tauto.
- + intros tg Ex.
- rewrite <- SameTg in Ex.
- destruct (EqC tg Ex) as [it1 [it2 [Lookup1 [Lookup2 EqCsub]]]].
- exists it2, it1.
- split; [|split].
- * assumption.
- * assumption.
- * apply item_eq_up_to_C_sym.
- assumption.
- Qed.
-
- Lemma trees_equal_sym {d} trs1 trs2 : trees_equal d trs1 trs2 → trees_equal (direction_flip d) trs2 trs1.
- Proof.
- rewrite /trees_equal.
- intros Equals blk.
- specialize (Equals blk).
- inversion Equals; simplify_eq; econstructor.
- by eapply tree_equal_sym.
- Qed.
-
- Lemma every_node_iff_every_lookup
- {tr prop}
- (GloballyUnique : forall tg, tree_contains tg tr -> exists it, tree_item_determined tg it tr)
- : every_node prop tr <-> forall tg it, tree_lookup tr tg it -> prop it.
- Proof.
- rewrite every_node_eqv_universal.
- split.
- - intros Every tg it [Ex Unq].
- apply Every.
- eapply exists_node_increasing; [eassumption|].
- eapply every_node_increasing; [eassumption|].
- erewrite every_node_eqv_universal.
- intros. symmetry. auto.
- - intros Lookup it Exists.
- apply (Lookup (itag it)).
- assert (tree_contains it.(itag) tr) as Ex. {
- eapply exists_node_increasing; [eassumption|].
- erewrite every_node_eqv_universal.
- intros. subst. auto.
- }
- destruct (GloballyUnique _ Ex) as [it' Unq'].
- assert (it = it') as Eq. {
- apply (proj1 (every_node_eqv_universal _ _) Unq' it Exists).
- auto.
- }
- rewrite -Eq in Unq'.
- split; assumption.
- Qed.
-
- Lemma tree_equal_implies_globally_unique_1
- {d tr1 tr2} :
- tree_equal d tr1 tr2 ->
- forall tg, tree_contains tg tr1 -> exists it, tree_item_determined tg it tr1.
- Proof.
- intros [ExIff [SameRel Lookup]] tg Ex.
- destruct (Lookup _ Ex) as [it1 [it2 [Lookup1 [Lookup2 EqC]]]].
- exists it1.
- apply Lookup1.
- Qed.
-
- Lemma tree_equal_implies_globally_unique_2
- {d tr1 tr2} :
- tree_equal d tr1 tr2 ->
- forall tg, tree_contains tg tr2 -> exists it, tree_item_determined tg it tr2.
- Proof.
- intro Eq.
- pose proof (tree_equal_sym _ _ Eq) as Eq'.
- revert Eq'.
- apply tree_equal_implies_globally_unique_1.
- Qed.
-
-
- Lemma tree_equal_transfer_lookup_1
- {d tr1 tr2 tg it1} :
- tree_equal d tr1 tr2 ->
- tree_lookup tr1 tg it1 ->
- exists it2,
- tree_lookup tr2 tg it2
- /\ item_eq_up_to_C tr1 tr2 tg d it1 it2.
- Proof.
- intros [SameTg [SameRel MkLookup]] [Ex1 Unq1].
- destruct (MkLookup _ Ex1) as [it1' [it2 [Lookup1' [Lookup2 EqC']]]].
- assert (it1 = it1') by (eapply tree_determined_unify; [eassumption|apply Unq1|apply Lookup1']).
- subst it1'.
- exists it2.
- split; assumption.
- Qed.
-
- Lemma tree_equal_transfer_lookup_2
- {d tr1 tr2 tg it2} :
- tree_equal d tr1 tr2 ->
- tree_lookup tr2 tg it2 ->
- exists it1,
- tree_lookup tr1 tg it1
- /\ item_eq_up_to_C tr1 tr2 tg d it1 it2.
- Proof.
- intros Eq Lookup2.
- pose proof (tree_equal_sym _ _ Eq) as Eq'.
- destruct (tree_equal_transfer_lookup_1 Eq' Lookup2) as [it1 [Lookup1 EqC']].
- exists it1; split; [assumption|].
- rewrite -(direction_flip_inv d).
- apply item_eq_up_to_C_sym.
- assumption.
- Qed.
-
- Lemma is_Some_ignore_bind
- {X Y} {o : option X} {g : X -> Y} :
- is_Some (o ≫= fun x => Some (g x)) <-> is_Some o.
- Proof.
- destruct o; simpl; split; intro H.
- - auto.
- - auto.
- - inversion H; discriminate.
- - inversion H; discriminate.
- Qed.
-
- Lemma mutual_parent_child_both_or_neither
- {tg tg' tr} :
- StrictParentChildIn tg tg' tr ->
- StrictParentChildIn tg' tg tr ->
- forall br,
- exists_subtree (eq br) tr ->
- (tree_contains tg (of_branch br) <-> tree_contains tg' (of_branch br)).
- Proof.
- intros Rel Rel' br ExBr.
- destruct (decide (tree_contains tg (of_branch br))) as [Ex|nEx].
- all: destruct (decide (tree_contains tg' (of_branch br))) as [Ex'|nEx'].
- all: try tauto.
- all: exfalso.
- - enough (tree_contains tg' (of_branch br)) by contradiction.
- rewrite /StrictParentChildIn every_subtree_eqv_universal in Rel.
- pose proof (proj1 (exists_node_iff_exists_root _ _) Ex) as WitnessSubtree.
- rewrite exists_subtree_eqv_existential in WitnessSubtree.
- destruct WitnessSubtree as [br' [ExBr' TgRoot]].
- assert (exists_subtree (eq br') tr) as ExBr'' by (eapply exists_subtree_transitive; eauto).
- specialize (Rel br' ExBr'' TgRoot).
- eapply exists_node_transitive.
- + eassumption.
- + simpl in TgRoot.
- destruct br' as [[]]; simpl in *.
- right; right; assumption.
- - enough (tree_contains tg (of_branch br)) by contradiction.
- rewrite /StrictParentChildIn every_subtree_eqv_universal in Rel'.
- pose proof (proj1 (exists_node_iff_exists_root _ _) Ex') as WitnessSubtree.
- rewrite exists_subtree_eqv_existential in WitnessSubtree.
- destruct WitnessSubtree as [br' [ExBr' TgRoot]].
- assert (exists_subtree (eq br') tr) as ExBr'' by (eapply exists_subtree_transitive; eauto).
- specialize (Rel' br' ExBr'' TgRoot).
- eapply exists_node_transitive.
- + eassumption.
- + simpl in TgRoot.
- destruct br' as [[]]; simpl in *.
- right; right; assumption.
- Qed.
-
- Lemma involution_of_branch
- {X} {data : X} {tr1 tr2}
- : branch data tr1 tr2 = of_branch (data, tr1, tr2).
- Proof. reflexivity. Qed.
-
- Lemma strict_parent_self_impossible
- {tg tr} :
- tree_contains tg tr ->
- StrictParentChildIn tg tg tr ->
- False.
- Proof.
- intros Ex Strict.
- induction tr as [|? ? IHtr1 ? IHtr2]; [inversion Ex|].
- inversion Strict as [Strict0 [Strict1 Strict2]].
- inversion Ex as [Ex0 | [Ex1 | Ex2]].
- - apply IHtr2.
- + apply Strict0. assumption.
- + assumption.
- - apply IHtr1; assumption.
- - apply IHtr2; assumption.
- Qed.
-
- Lemma mutual_strict_parent_child_impossible
- {tg tg' tr} :
- tree_contains tg tr ->
- tree_contains tg' tr ->
- StrictParentChildIn tg tg' tr ->
- StrictParentChildIn tg' tg tr ->
- False.
- Proof.
- intros Ex Ex' Rel Rel'.
- enough (StrictParentChildIn tg tg tr).
- + eapply strict_parent_self_impossible.
- * exact Ex.
- * assumption.
- + eapply StrictParentChild_transitive; eassumption.
- Qed.
-
- Lemma mutual_parent_child_implies_equal
- {tg tg' tr} :
- tree_contains tg tr ->
- tree_contains tg' tr ->
- ParentChildIn tg tg' tr ->
- ParentChildIn tg' tg tr ->
- tg' = tg.
- Proof.
- rewrite /ParentChildIn.
- intros Ex Ex'.
- intros [|StrictRel]; [auto|].
- intros [|StrictRel']; [auto|].
- exfalso.
- eapply mutual_strict_parent_child_impossible.
- + exact Ex.
- + exact Ex'.
- + assumption.
- + assumption.
- Qed.
-
- Lemma rel_this_antisym
- {tr tg tg'} :
- tree_contains tg tr ->
- tree_contains tg' tr ->
- rel_dec tr tg tg' = Child This -> tg = tg'.
- Proof.
- rewrite /rel_dec.
- remember (decide (ParentChildIn tg tg' tr)) as Rel.
- remember (decide (ParentChildIn tg' tg tr)) as Rel'.
- destruct Rel; destruct Rel'.
- all: try (intro; discriminate).
- intros Ex Ex' _.
- eapply mutual_parent_child_implies_equal; eauto.
- Qed.
-
- Lemma rel_dec_refl tr tg :
- rel_dec tr tg tg = Child This.
- Proof.
- rewrite /rel_dec.
- rewrite decide_True; [|left; reflexivity].
- rewrite decide_True; [|left; reflexivity].
- reflexivity.
- Qed.
-
- Lemma child_of_this_is_foreign_for_cousin
- {tr tg_this tg_cous tg_child} :
- tree_unique tg_this tr ->
- tree_unique tg_cous tr ->
- tree_unique tg_child tr ->
- rel_dec tr tg_this tg_cous = Foreign Cousin ->
- (if rel_dec tr tg_child tg_this is Child _ then True else False) ->
- rel_dec tr tg_child tg_cous = Foreign Cousin.
- Proof.
- intros Ex_this Ex_cous Ex_child.
- intros Rel_this_cous Rel_child_this_Foreign.
- destruct (rel_dec _ tg_child _) as [|pos] eqn:Rel_child_this; [contradiction|].
- destruct pos.
- + rewrite /rel_dec in Rel_this_cous, Rel_child_this |- *.
- repeat destruct (decide (ParentChildIn _ _ _)); try discriminate.
- - enough (ParentChildIn tg_this tg_cous tr) by contradiction.
- eapply ParentChild_transitive; eassumption.
- - exfalso.
- eapply cousins_have_disjoint_children with (tg1 := tg_this) (tg2 := tg_cous).
- * eassumption.
- * assumption.
- * assumption.
- * rewrite /rel_dec.
- rewrite decide_False; [|eassumption].
- rewrite decide_False; [|eassumption].
- reflexivity.
- * eassumption.
- * eassumption.
- - enough (ParentChildIn tg_this tg_cous tr) by contradiction.
- eapply ParentChild_transitive; eassumption.
- - reflexivity.
- + rewrite (rel_this_antisym _ _ Rel_child_this); first assumption.
- all: apply unique_exists; assumption.
- Qed.
-
- Lemma cousin_write_for_initialized_protected_nondisabled_is_ub
- {it l acc_tg tr range tg b}
- (Lookup : tree_lookup tr tg it)
- (Protected : protector_is_active (iprot it) C)
- (IsInit : initialized (item_lookup it l) = PermInit)
- (IsCousin : rel_dec tr acc_tg tg = Foreign Cousin)
- (InRange : range'_contains range l)
- : ~ is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm AccessWrite)) C acc_tg range tr).
- Proof.
- intro Absurd.
- rewrite -apply_access_success_condition in Absurd.
- rewrite every_node_eqv_universal in Absurd.
- specialize (Absurd it).
- assert (itag it = tg) as Tg. { eapply tree_determined_specifies_tag; apply Lookup. }
- rewrite Tg in Absurd.
- rewrite IsCousin in Absurd.
- rewrite /item_apply_access /permissions_apply_range' in Absurd.
- rewrite is_Some_ignore_bind in Absurd.
- rewrite -mem_apply_range'_success_condition in Absurd.
- rewrite bool_decide_eq_true_2 in Absurd; [|auto].
- enough (is_Some (apply_access_perm AccessWrite (Foreign Cousin) true (item_lookup it l))) as Absurd'.
- - rewrite /apply_access_perm in Absurd'.
- destruct (item_lookup _ _) as [[] [[]| | | |]], b; simpl in Absurd'.
- all: try inversion Absurd'; discriminate.
- - rewrite /item_lookup. setoid_rewrite maybe_non_children_only_no_effect in Absurd; last done.
- apply Absurd; [|done].
- eapply exists_determined_exists; apply Lookup.
- Qed.
-
- Lemma pseudo_conflicted_allows_more_access
- {tr1 tr2 tg l confl1 confl2 kind rel isprot ini acc_tg range it1 b}
- (* Main hypotheses *)
- (Confl1 : pseudo_conflicted tr1 tg l confl1)
- (Confl2 : pseudo_conflicted tr2 tg l confl2)
- (AccEx : tree_unique acc_tg tr1)
- (TgEx : tree_unique tg tr1)
- (* Auxiliary stuff to bind the local access to the global success for the pseudo conflicted case *)
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GlobalSuccess : is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1))
- (ProtSpec : isprot = bool_decide (protector_is_active (iprot it1) C))
- (RelSpec : rel = rel_dec tr1 acc_tg tg)
- (PermSpec : item_lookup it1 l = {| initialized := ini; perm := Reserved confl1 |})
- (InRange : range'_contains range l)
- : is_Some
- (apply_access_perm kind rel isprot
- {| initialized := ini; perm := Reserved confl1 |})
- -> is_Some
- (apply_access_perm kind rel isprot
- {| initialized := ini; perm := Reserved confl2 |}).
- Proof.
- rewrite /apply_access_perm /apply_access_perm_inner; simpl.
- (* Most cases are by reflexivity. *)
- destruct kind, rel; simpl.
- all: destruct ini, isprot; simpl; try auto.
- all: inversion Confl1 as [|?? RelCous LookupCous].
- all: inversion Confl2.
- all: subst; simpl; try auto.
- (* Once we get reflexivity out of the way we are left with the accesses
- where there is UB in the target because of the conflicted.
- We now need to prove that actually there is also UB in the source,
- just not _here_, instead it occured at the cousin that creates the conflict. *)
- all: exfalso.
- (* FIXME: here we need a lemma that shows
- 1. a Child/This access for tg is Foreign for tg_cous who is Cousin of tg
- 2. a Foreign access for such tg_cous is UB globally.
- We can indeed check that in all of the following cases we have
- rel = This or rel = Child and kind = AccessWrite. *)
- all: eapply cousin_write_for_initialized_protected_nondisabled_is_ub.
- all: try exact GlobalSuccess.
- all: try eassumption.
- all: eapply child_of_this_is_foreign_for_cousin.
- all: try apply RelCous.
- all: try assumption.
- all: try rewrite -RelSpec; auto.
- all: apply GloballyUnique1; apply LookupCous.
- Qed.
-
- Lemma pseudo_conflicted_post_prot_allows_more_access
- {tr1 tg l confl1 confl2 kind rel isprot ini acc_tg range it1 b}
- (* Main hypotheses *)
- (AccEx : tree_unique acc_tg tr1)
- (TgEx : tree_unique tg tr1)
- (* Auxiliary stuff to bind the local access to the global success for the pseudo conflicted case *)
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GlobalSuccess : is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1))
- (NoProp : ¬ protector_is_active (iprot it1) C)
- (ProtSpec : isprot = bool_decide (protector_is_active (iprot it1) C))
- (RelSpec : rel = rel_dec tr1 acc_tg tg)
- (PermSpec : item_lookup it1 l = {| initialized := ini; perm := Reserved confl1 |})
- (InRange : range'_contains range l)
- : is_Some
- (apply_access_perm kind rel isprot
- {| initialized := ini; perm := Reserved confl1 |})
- -> is_Some
- (apply_access_perm kind rel isprot
- {| initialized := ini; perm := Reserved confl2 |}).
- Proof.
- rewrite /apply_access_perm /apply_access_perm_inner; simpl.
- rewrite bool_decide_false in ProtSpec; last done. subst isprot.
- (* Most cases are by reflexivity. *)
- destruct kind, rel; simpl.
- all: destruct ini; simpl; try auto.
- all: subst; simpl; try auto.
- all: destruct confl1, confl2.
- all: subst; simpl; try auto.
- Qed.
-
- Lemma pseudo_disabled_allows_more_access
- {tr1 tr2 tg l p1 p2 kind rel isprot acc_tg range it1 b}
- (* Main hypotheses *)
- (Confl1 : pseudo_disabled tr1 tg l p1 (iprot it1))
- (Confl2 : pseudo_disabled tr2 tg l p2 (iprot it1))
- (AccEx : tree_unique acc_tg tr1)
- (TgEx : tree_unique tg tr1)
- (* Auxiliary stuff to bind the local access to the global success for the pseudo conflicted case *)
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GlobalSuccess : is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1))
- (ProtSpec : isprot = bool_decide (protector_is_active (iprot it1) C))
- (RelSpec : rel = rel_dec tr1 acc_tg tg)
- (PermSpec : item_lookup it1 l = {| initialized := PermLazy; perm := p1 |})
- (InRange : range'_contains range l)
- : is_Some
- (apply_access_perm kind rel isprot
- {| initialized := PermLazy; perm := p1 |})
- -> is_Some
- (apply_access_perm kind rel isprot
- {| initialized := PermLazy; perm := p2 |}).
- Proof.
- rewrite /apply_access_perm /apply_access_perm_inner; simpl.
- destruct rel; last first.
- - inversion Confl1 as [H1 H2|tg_cs it_cs X1 X2 Hcs Hlu Hluact Hpp XX X3]; simplify_eq.
- 1: destruct kind; simpl; intros [? [=]].
- exfalso. eapply apply_access_success_condition in GlobalSuccess.
- eapply every_node_eqv_universal in GlobalSuccess.
- 2: eapply tree_lookup_to_exists_node, Hlu.
- rewrite /item_apply_access /permissions_apply_range' in GlobalSuccess.
- erewrite is_Some_ignore_bind in GlobalSuccess.
- eapply mem_apply_range'_success_condition in GlobalSuccess.
- 2: exact InRange.
- rewrite /rel_dec in GlobalSuccess.
- assert (itag it_cs = tg_cs) as Hcstg by by eapply tree_lookup_correct_tag.
- rewrite decide_False in GlobalSuccess.
- 2: { intros HPC. eapply cousins_have_disjoint_children.
- 4: exact Hcs. 2: done. 1: exact AccEx.
- 1: eapply GloballyUnique1, Hlu. 2: by subst.
- rewrite /rel_dec in RelSpec. destruct decide in RelSpec; done. }
- rewrite decide_False in GlobalSuccess.
- 2: { intros HPC. rewrite /rel_dec in RelSpec Hcs.
- destruct decide as [HP1|?] in RelSpec; try done.
- destruct decide as [?|HnP1] in Hcs; try done.
- destruct decide as [?|HnP2] in Hcs; try done.
- eapply HnP2. eapply ParentChild_transitive.
- 1: exact HP1. subst. done. }
- rewrite /item_lookup in Hpp.
- rewrite Hpp bool_decide_true // in GlobalSuccess.
- rewrite maybe_non_children_only_no_effect // in GlobalSuccess.
- destruct kind; destruct GlobalSuccess as [x [=]].
- - rewrite /=. intros _. destruct kind, isprot, p2 as [[]| | | |]; simpl; done.
- Qed.
-
- (* FIXME: move this elsewhere *)
- Lemma if_fun_absorb_args {X Y} {b : bool} {x : X} {f g : X -> Y} :
- (if b then f else g) x = if b then f x else g x.
- Proof. destruct b; reflexivity. Qed.
-
- Lemma rel_dec_child_transitive
- {tr tg1 tg2 tg3 incl1 incl2}
- : rel_dec tr tg1 tg2 = Child incl1 ->
- rel_dec tr tg2 tg3 = Child incl2 ->
- exists incl3, rel_dec tr tg1 tg3 = Child incl3.
- Proof.
- intros Rel12 Rel23.
- unfold rel_dec in *.
- destruct (decide (ParentChildIn tg2 tg1 tr)); last congruence.
- destruct (decide (ParentChildIn tg3 tg2 tr)); last congruence.
- assert (ParentChildIn tg3 tg1 tr) by (eapply ParentChild_transitive; eassumption).
- eexists.
- destruct (decide (ParentChildIn tg3 tg1 tr)); last contradiction.
- f_equal.
- Qed.
-
- Lemma frozen_in_practice_rejects_child_write
- {tr tg witness l b acc_tg range}
- (InRange : range'_contains range l)
- (GloballyUnique : forall tg, tree_contains tg tr -> tree_unique tg tr)
- (Frz : frozen_in_practice tr tg witness l)
- (Acc : is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm AccessWrite)) C acc_tg range tr))
- (Rel : exists x, rel_dec tr acc_tg tg = Child x)
- : False.
- Proof.
- inversion Frz as [it_witness ? Rel' Lkup Perm].
- rewrite -apply_access_success_condition in Acc.
- rewrite every_node_iff_every_lookup in Acc. 2: {
- intros tg0 Ex0. apply unique_lookup. apply GloballyUnique. assumption.
- }
- specialize (Acc _ _ Lkup).
- assert (exists x, rel_dec tr acc_tg witness = Child x) as FullRel. 1: {
- destruct Rel as [? Rel].
- eapply rel_dec_child_transitive; eassumption.
- }
- destruct FullRel as [? FullRel].
- assert (itag it_witness = witness) as WitnessTg. {
- eapply tree_determined_specifies_tag; apply Lkup.
- }
- rewrite WitnessTg FullRel in Acc.
- unfold item_apply_access, maybe_non_children_only in Acc.
- unfold is_Some in Acc.
- destruct Acc as [? Acc].
- rewrite bind_Some in Acc.
- destruct Acc as [? [Acc Res]].
- injection Res; clear Res; intros; subst.
- unfold permissions_apply_range' in Acc.
- pose proof (mk_is_Some _ _ Acc) as AccSome; clear Acc.
- rewrite -mem_apply_range'_success_condition in AccSome.
- specialize (AccSome l InRange).
- do 4 rewrite if_fun_absorb_args in AccSome.
- unfold nonchildren_only in AccSome.
- rewrite Tauto.if_same in AccSome.
- unfold apply_access_perm, apply_access_perm_inner in AccSome.
- rewrite Perm in AccSome.
- simpl in AccSome.
- inversion AccSome; congruence.
- Qed.
-
- Lemma loc_eq_up_to_C_allows_more_access
- {d tr1 tr2 tg it1 it2 l kind acc_tg range b}
- (Tg1 : itag it1 = tg)
- (Tg2 : itag it2 = tg)
- (UnqAcc : tree_unique acc_tg tr1)
- (UnqAcc2 : tree_unique acc_tg tr2)
- (Ex1 : tree_unique tg tr1)
- (Ex2 : tree_lookup tr2 tg it2)
- (SameRel : forall tg tg', rel_dec tr1 tg tg' = rel_dec tr2 tg tg')
- (ProtParentsNonDis : protected_parents_not_disabled C tr2)
- (ParentsMoreInit : parents_more_init tr2)
- (GlobalSuccess : is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1))
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- (InRange : range'_contains range l)
- (Hrestrict : kind = AccessWrite → d = Forwards)
- :
- loc_eq_up_to_C tr1 tr2 tg d it1 it2 l ->
- is_Some (maybe_non_children_only b (apply_access_perm kind) (rel_dec tr1 acc_tg (itag it1))
- (bool_decide (protector_is_active (iprot it1) C))
- (item_lookup it1 l))
- ->
- is_Some (maybe_non_children_only b (apply_access_perm kind) (rel_dec tr2 acc_tg (itag it2))
- (bool_decide (protector_is_active (iprot it2) C))
- (item_lookup it2 l)).
- Proof.
- intros EqC Acc1.
- inversion EqC as [EqProt EqCLookup].
- inversion EqCLookup as
- [perm Lookup EqLookup
- |??? Prot Confl1 Confl2 Lookup1 Lookup2
- |??? Prot Lookup1 Lookup2
- |p1 p2 Confl1 Confl2 Lookup1 Lookup2
- |witness_tg ?? Dis1 Dis2 Lookup1 Lookup2
- |ini ?? witness_tg Frz Lookup1 Lookup2
- |p1 p2 ini Hd Lookup1 Lookup2
- ].
- - rewrite Tg2 -Tg1.
- rewrite -SameRel.
- rewrite -EqProt.
- apply Acc1.
- - rewrite Lookup2.
- rewrite -Lookup1 in Acc1.
- edestruct maybe_non_children_only_effect_or_nop as [Heq|Heq].
- 2: by erewrite Heq.
- rewrite Heq. rewrite -Lookup2.
- eapply (pseudo_conflicted_allows_more_access Confl1 Confl2 UnqAcc Ex1 GloballyUnique1 GlobalSuccess).
- + rewrite -EqProt; reflexivity.
- + rewrite SameRel -Tg2 //=.
- + rewrite /item_lookup Lookup1 //=.
- + exact InRange.
- + rewrite Tg1 -Tg2 SameRel EqProt Heq // in Acc1.
- - rewrite Lookup2.
- rewrite -Lookup1 in Acc1.
- edestruct maybe_non_children_only_effect_or_nop as [Heq|Heq].
- 2: by erewrite Heq.
- rewrite Heq. rewrite -Lookup2.
- eapply (pseudo_conflicted_post_prot_allows_more_access UnqAcc Ex1 GloballyUnique1 GlobalSuccess).
- + done.
- + rewrite -EqProt; reflexivity.
- + rewrite SameRel -Tg2 //=.
- + symmetry. apply Lookup1.
- + exact InRange.
- + rewrite Tg1 -Tg2 SameRel EqProt Heq // in Acc1.
- - rewrite Lookup2.
- rewrite -Lookup1 in Acc1.
- edestruct maybe_non_children_only_effect_or_nop as [Heq|Heq].
- 2: by erewrite Heq.
- rewrite Heq. rewrite -Lookup2.
- eapply (pseudo_disabled_allows_more_access Confl1 Confl2 UnqAcc Ex1 GloballyUnique1 GlobalSuccess).
- + rewrite -EqProt; reflexivity.
- + rewrite SameRel -Tg2 //=.
- + rewrite /item_lookup Lookup1 //=.
- + exact InRange.
- + rewrite Tg1 -Tg2 SameRel EqProt Heq // in Acc1.
- - (* FIXME: there has to be a shorter proof *)
- (* This has to be a foreign access *)
- destruct (rel_dec tr1 acc_tg (itag it1)) eqn:AccRel; last first.
- + (* If it's a child access then it's also a child access for the Disabled parent. *)
- inversion Dis1 as [it_witness ? RelWitness LookupWitness DisWitnessPre].
- destruct (decide (perm (item_lookup it_witness l) = Disabled)) as [Hdis|HNonDis]; simplify_eq.
- * rewrite <- apply_access_success_condition in GlobalSuccess.
- rewrite every_node_iff_every_lookup in GlobalSuccess. 2: {
- intros tg0 Ex0. apply unique_lookup. apply GloballyUnique1. assumption.
- }
- specialize (GlobalSuccess _ _ LookupWitness).
- pose proof (tree_determined_specifies_tag _ _ _ (proj1 LookupWitness) (proj2 LookupWitness))
- as WitnessTg.
- subst witness_tg.
- assert (match rel_dec tr1 acc_tg (itag it_witness) with
- | Child _ => True
- | Foreign _ => False
- end
- ). {
- unfold rel_dec in RelWitness.
- destruct (decide _); last discriminate.
- unfold rel_dec in AccRel.
- destruct (decide _); last discriminate.
- unfold rel_dec.
- destruct (decide (ParentChildIn (itag it_witness) acc_tg tr1)) as [|WitnessAccRel]; first done.
- apply WitnessAccRel.
- eapply ParentChild_transitive.
- + eassumption.
- + eassumption.
- }
- destruct (rel_dec _ acc_tg (itag it_witness)); first contradiction.
- (* Finally we have all the ingredients of the contradiction *)
- rewrite /item_apply_access in GlobalSuccess.
- destruct GlobalSuccess as [? GlobalSuccess].
- rewrite bind_Some in GlobalSuccess.
- destruct GlobalSuccess as [tmp_perms [PermissionsApply Wrapper]].
- injection Wrapper; clear Wrapper; intros; subst.
- rewrite /permissions_apply_range' in PermissionsApply.
- pose proof (proj2 (mem_apply_range'_success_condition _ _ _) (mk_is_Some _ _ PermissionsApply))
- as PermissionApply.
- specialize (PermissionApply l InRange).
- unfold item_lookup in Hdis.
- rewrite /maybe_non_children_only in PermissionApply.
- rewrite /nonchildren_only /= in PermissionApply.
- repeat rewrite if_fun_absorb_args in PermissionApply.
- rewrite Tauto.if_same in PermissionApply.
- rewrite /apply_access_perm /= in PermissionApply.
- destruct PermissionApply as [tmp_lazy PermissionApply].
- rewrite bind_Some in PermissionApply.
- destruct PermissionApply as [tmp_perm [ApplyAccessInner ValidateProt]].
- rewrite Hdis in ApplyAccessInner.
- rewrite /apply_access_perm_inner in ApplyAccessInner.
- case_match; discriminate.
- * inversion DisWitnessPre as [HX DisWitness|lp HDis Hlookup HX]; simplify_eq.
- 1: rewrite -DisWitness in HNonDis; done.
- inversion Hlookup as [HX1 HX2|tg_w2 it_w2 x1 x2 Hcs2 Hlu2 Hprot2 Hperm2 Hlp]; simplify_eq.
- 1: rewrite -HX // in HNonDis.
- rewrite <- apply_access_success_condition in GlobalSuccess.
- rewrite every_node_iff_every_lookup in GlobalSuccess. 2: {
- intros tg0 Ex0. apply unique_lookup. apply GloballyUnique1. assumption.
- }
- specialize (GlobalSuccess _ _ Hlu2).
- pose proof (tree_determined_specifies_tag _ _ _ (proj1 Hlu2) (proj2 Hlu2))
- as <-.
- rewrite /rel_dec in RelWitness.
- destruct decide as [HPC1|] in RelWitness; last done. clear RelWitness.
- rewrite /rel_dec in AccRel.
- destruct decide as [HPC2|] in AccRel; last done. clear AccRel.
- rewrite /rel_dec decide_False in GlobalSuccess; last first.
- { intros HH. exfalso. eapply cousins_have_disjoint_children. 4: exact Hcs2.
- 5: exact HH. 4: eapply ParentChild_transitive; eassumption.
- 1: done. all: eapply GloballyUnique1. 2: eapply Hlu2. eapply LookupWitness. }
- rewrite decide_False in GlobalSuccess; last first.
- { intros HH. rewrite /rel_dec in Hcs2.
- destruct decide as [|HHH] in Hcs2; first done.
- destruct decide as [|HHH2] in Hcs2; first done.
- eapply HHH2. do 3 (eapply ParentChild_transitive; first done). by left. }
- exfalso. rewrite /item_apply_access in GlobalSuccess.
- rewrite is_Some_ignore_bind in GlobalSuccess.
- eapply mem_apply_range'_success_condition in GlobalSuccess. 2: done.
- rewrite maybe_non_children_only_no_effect // in GlobalSuccess.
- rewrite /item_lookup in Hperm2. rewrite Hperm2 in GlobalSuccess.
- rewrite bool_decide_true // in GlobalSuccess.
- destruct kind; cbv in GlobalSuccess; by destruct GlobalSuccess.
- + rewrite <- EqProt.
- destruct (bool_decide (protector_is_active (iprot it1) C)) eqn:Heq; last first.
- { rewrite Tg2 -Tg1 -SameRel AccRel.
- rewrite /maybe_non_children_only /nonchildren_only.
- repeat rewrite if_fun_absorb_args.
- repeat case_match; first done.
- all: rewrite /apply_access_perm /apply_access_perm_inner //=.
- all: repeat case_match; done. }
- rewrite Tg2 -Tg1 -SameRel AccRel.
- rewrite /maybe_non_children_only /nonchildren_only.
- repeat rewrite if_fun_absorb_args.
- inversion Dis2 as [it_witness ? RelWitness LookupWitness DisWitnessPre].
- (* we are protected. this means we are not initalized by state_wf *)
- assert (initialized (item_lookup it2 l) = PermLazy) as HH.
- 1: inversion DisWitnessPre as [HX DisWitness|lp HX HDis Hlookup]; simplify_eq.
- { specialize (ProtParentsNonDis witness_tg). eapply every_child_ParentChildIn in ProtParentsNonDis.
- 2: done. 2: eapply GloballyUnique2, LookupWitness. 2: eapply LookupWitness. 2: eapply GloballyUnique2, Ex2.
- 2: rewrite /rel_dec in RelWitness; by destruct (decide (ParentChildIn witness_tg (itag it1) tr2)).
- setoid_rewrite every_node_eqv_universal in ProtParentsNonDis.
- ospecialize (ProtParentsNonDis it2 _ _).
- 1: eapply exists_determined_exists; eapply Ex2. 1: by eapply tree_lookup_correct_tag.
- rewrite /item_protected_all_parents_not_disabled in ProtParentsNonDis.
- ospecialize (ProtParentsNonDis l). destruct (initialized (item_lookup it2 l)); last done.
- rewrite -EqProt -DisWitness in ProtParentsNonDis. ospecialize (ProtParentsNonDis _ _).
- 1: done. 1: by eapply bool_decide_eq_true_1. 1: done. }
- { specialize (ParentsMoreInit witness_tg). eapply every_child_ParentChildIn in ParentsMoreInit.
- 2: done. 2: eapply GloballyUnique2, LookupWitness. 2: eapply LookupWitness. 2: eapply GloballyUnique2, Ex2.
- 2: rewrite /rel_dec in RelWitness; by destruct (decide (ParentChildIn witness_tg (itag it1) tr2)).
- setoid_rewrite every_node_eqv_universal in ParentsMoreInit.
- ospecialize (ParentsMoreInit it2 _ _).
- 1: eapply exists_determined_exists; eapply Ex2. 1: by eapply tree_lookup_correct_tag.
- ospecialize (ParentsMoreInit l). destruct (initialized (item_lookup it2 l)); last done.
- rewrite -Hlookup in ParentsMoreInit. ospecialize (ParentsMoreInit _).
- 1: done. 1: done. }
- all: rewrite /apply_access_perm /apply_access_perm_inner HH //=.
- all: repeat case_match; done.
- - (* Frozen in practice case.
- Before we do the usual manipulations we make both the left and right access use
- the same [rel_dec] so that the [maybe_non_children_only] case distinction works
- on both simultaneously. *)
- rewrite SameRel in Acc1.
- edestruct maybe_non_children_only_effect_or_nop as [Heq|Heq].
- 2: by erewrite Heq. (* Noop case, easy. *)
- rewrite Heq.
- rewrite Tg1 -Tg2 Heq in Acc1.
- destruct kind, (rel_dec tr2 _ _) eqn:Rel.
- + (* Foreign read is allowed *)
- unfold apply_access_perm, apply_access_perm_inner.
- repeat (case_match; simpl; try auto).
- + (* Child read is allowed *)
- unfold apply_access_perm, apply_access_perm_inner.
- repeat (case_match; simpl; try auto).
- + (* Foreign write is allowed, except when there is a protector.
- Once we eliminate all other cases we'll have to prove that the protector is inactive by
- using the left tree in which the access suceeded. *)
- unfold apply_access_perm, apply_access_perm_inner.
- repeat (case_match; simpl; try auto).
- (* Now we have a goal that is definitely not provable, but we have gained
- a hypothesis [protector_is_active] in the context. We can derive a contradiction. *)
- all: exfalso.
- all: unfold apply_access_perm, apply_access_perm_inner in Acc1.
- all: repeat (case_match; simpl in Acc1; try auto).
- all: try (inversion Acc1; congruence).
- (* We have all the elements of the contradiction, but a bit of rewriting is necessary
- to get them in a shape that is obviously conflicting.
- At that point there are two kinds of goals
- - some where the protector is active only on one side, solve them using [EqProt],
- - others whene [initialized] returns inconsistent results, solve them by
- unifying the same [ini] everywhere. *)
- all: repeat multimatch goal with
- | H : bool_decide _ = true |- _ => pose proof (bool_decide_eq_true_1 _ H); clear H
- | H : bool_decide _ = false |- _ => pose proof (bool_decide_eq_false_1 _ H); clear H
- | H : context [ iprot _ ] |- _ => rewrite EqProt in H
- | |- _ => try contradiction
- end.
- all: assert (initialized (item_lookup it1 l) = ini) as Ini1 by (rewrite -Lookup1; done).
- all: simpl in *; congruence.
- + (* Child write is necessarily UB due to the Frozen parent *)
- exfalso.
- specialize (Hrestrict eq_refl). subst d.
- eapply frozen_in_practice_rejects_child_write. 4: exact GlobalSuccess.
- * eassumption.
- * eassumption.
- * eassumption.
- * eexists. rewrite SameRel. rewrite -Tg2. apply Rel.
- - rewrite -SameRel Tg2 -Tg1 -EqProt. edestruct maybe_non_children_only_effect_or_nop as [Heq|Heq];
- erewrite Heq in Acc1; erewrite Heq; clear Heq. 2: done.
- rewrite -Lookup1 in Acc1. destruct kind.
- + destruct d; (inversion Hd as [P Hprot|P Hnoprot]; subst P p1 p2;
- [ rewrite bool_decide_eq_false_2 // in Acc1|-*
- | rewrite bool_decide_eq_true_2 // in Acc1|-*]).
- all: destruct (rel_dec tr1 acc_tg (itag it1)), ini.
- all: rewrite /apply_access_perm /apply_access_perm_inner /= in Acc1|-*; done.
- + specialize (Hrestrict eq_refl). subst d.
- inversion Hd as [P Hprot|P Hnoprot]; subst P p1 p2.
- 1: rewrite bool_decide_eq_false_2 // in Acc1|-*.
- 2: rewrite bool_decide_eq_true_2 // in Acc1|-*.
- all: destruct (rel_dec tr1 acc_tg (itag it1)), ini.
- all: rewrite /apply_access_perm /apply_access_perm_inner /= in Acc1|-*; done.
- Qed.
-
- Lemma item_eq_up_to_C_allows_more_access (b:bool)
- {d tr1 tr2 tg it1 it2 kind acc_tg range}
- (Tg1 : itag it1 = tg)
- (Tg2 : itag it2 = tg)
- (UnqAcc : tree_unique acc_tg tr1)
- (UnqAcc2 : tree_unique acc_tg tr2)
- (Ex1 : tree_unique tg tr1)
- (Ex2 : tree_lookup tr2 tg it2)
- (SameRel : forall tg tg', rel_dec tr1 tg tg' = rel_dec tr2 tg tg')
- (ProtParentsNonDis : protected_parents_not_disabled C tr2)
- (ParentsMoreInit : parents_more_init tr2)
- (GlobalSuccess : is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1))
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- (Hrestrict : kind = AccessWrite → d = Forwards)
- :
- item_eq_up_to_C tr1 tr2 tg d it1 it2 ->
- is_Some (item_apply_access (maybe_non_children_only b (apply_access_perm kind)) C (rel_dec tr1 acc_tg (itag it1)) range it1) ->
- is_Some (item_apply_access (maybe_non_children_only b (apply_access_perm kind)) C (rel_dec tr2 acc_tg (itag it2)) range it2).
- Proof.
- rewrite /item_apply_access /permissions_apply_range'.
- rewrite is_Some_ignore_bind.
- rewrite is_Some_ignore_bind.
- intros EqC.
- intro App1.
- rewrite -mem_apply_range'_success_condition in App1.
- rewrite -mem_apply_range'_success_condition.
- intros l InRange.
- specialize (App1 l InRange).
- specialize (EqC l).
- eapply (loc_eq_up_to_C_allows_more_access Tg1 Tg2 UnqAcc UnqAcc2 Ex1 Ex2 SameRel); done.
- Qed.
-
- Lemma tree_equal_allows_more_access_maybe_nonchildren_only (b:bool)
- {d tr1 tr2 kind acc_tg range}
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- (ProtParentsNonDis : protected_parents_not_disabled C tr2)
- (ParentsMoreInit : parents_more_init tr2)
- (Hrestrict : kind = AccessWrite → d = Forwards) :
- tree_equal d tr1 tr2 ->
- tree_unique acc_tg tr1 ->
- is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1) ->
- is_Some (tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr2).
- Proof.
- intros Eq UnqAcc Acc1.
- apply apply_access_success_condition.
- pose proof (proj2 (apply_access_success_condition _ _ _ _ _) Acc1) as Every1.
- (* Get it into a more usable form *)
- rewrite every_node_iff_every_lookup in Every1.
- 2: eapply tree_equal_implies_globally_unique_1; eassumption.
- rewrite every_node_iff_every_lookup.
- 2: eapply tree_equal_implies_globally_unique_2; eassumption.
- (* And now we can unfold the definitions more *)
- intros tg it Lookup2.
- pose proof Eq as EqCopy.
- destruct EqCopy as [ExIff [SameRel Lookup]].
- destruct (tree_equal_transfer_lookup_2 Eq Lookup2) as [it1 [Lookup1 EqC]].
- eapply (item_eq_up_to_C_allows_more_access b).
- - erewrite tree_determined_specifies_tag. 2,3: eapply Lookup1. reflexivity.
- - erewrite tree_determined_specifies_tag. 2,3: eapply Lookup2. reflexivity.
- - apply UnqAcc.
- - eapply GloballyUnique2. destruct Eq as (H1&H2&H3). eapply H1. by eapply unique_exists.
- - apply GloballyUnique1. apply Lookup1.
- - done.
- - eassumption.
- - eapply ProtParentsNonDis.
- - done.
- - apply Acc1.
- - exact GloballyUnique1.
- - exact GloballyUnique2.
- - done.
- - done.
- - eapply Every1; eassumption.
- Qed.
-
- Lemma tree_equal_allows_more_access
- {d tr1 tr2 kind acc_tg range}
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- (ProtParentsNonDis : protected_parents_not_disabled C tr2)
- (ParentsMoreInit : parents_more_init tr2)
- (Hrestrict : kind = AccessWrite → d = Forwards) :
- tree_equal d tr1 tr2 ->
- tree_unique acc_tg tr1 ->
- is_Some (memory_access kind C acc_tg range tr1) ->
- is_Some (memory_access kind C acc_tg range tr2).
- Proof.
- by eapply (tree_equal_allows_more_access_maybe_nonchildren_only false).
- Qed.
-
- Lemma tree_equal_allows_more_access_nonchildren_only
- {d tr1 tr2 kind acc_tg range}
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- (ProtParentsNonDis : protected_parents_not_disabled C tr2)
- (ParentsMoreInit : parents_more_init tr2)
- (Hrestrict : kind = AccessWrite → d = Forwards) :
- tree_equal d tr1 tr2 ->
- tree_unique acc_tg tr1 ->
- is_Some (memory_access_nonchildren_only kind C acc_tg range tr1) ->
- is_Some (memory_access_nonchildren_only kind C acc_tg range tr2).
- Proof.
- by eapply (tree_equal_allows_more_access_maybe_nonchildren_only true).
- Qed.
-
- Lemma memory_access_same_rel_dec
- {tr tr' acc cids acc_tg range} b
- : memory_access_maybe_nonchildren_only b acc cids acc_tg range tr = Some tr' ->
- forall tg tg', rel_dec tr tg tg' = rel_dec tr' tg tg'.
- Proof. eapply access_same_rel_dec. Qed.
-
- Lemma access_preserves_pseudo_conflicted_activable (b:bool)
- {tr tg l kind acc_tg range tr'} :
- pseudo_conflicted tr tg l ResActivable ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr' ->
- pseudo_conflicted tr' tg l ResActivable.
- Proof.
- intros PseudoC Acc.
- inversion PseudoC as [|tg_cous it_cous cous_rel [cous_ex cous_det] cous_prot cous_nondis cous_init].
- destruct (apply_access_spec_per_node cous_ex cous_det Acc)
- as (cous' & cous'_spec & cous'_ex & cous'_det).
- symmetry in cous'_spec.
- rewrite bind_Some in cous'_spec.
- destruct cous'_spec as (perms' & perms'_spec & cous'_build).
- injection cous'_build; intros; subst; clear cous'_build.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms'_spec) as effect_at_l.
- destruct (decide _).
- + (* within range. Big case analysis incoming. *)
- destruct effect_at_l as (perm' & perm'_lookup & perm'_spec).
- edestruct (maybe_non_children_only_effect_or_nop b (apply_access_perm kind) (rel_dec tr acc_tg (itag it_cous))) as [Heff|Heff].
- all: rewrite Heff in perm'_spec.
- 1: rewrite bind_Some in perm'_spec;
- destruct perm'_spec as (perm & perm_apply_inner & perm'_spec);
- rewrite bind_Some in perm'_spec;
- destruct perm'_spec as (perm_validated & perm_check_prot & perm'_spec).
- all: pose proof perm'_spec as [= <-].
- all: (econstructor; [
- erewrite <- access_same_rel_dec; eassumption
- | done
- | done
- | .. ]).
- * rewrite /item_lookup /= perm'_lookup /=.
- rewrite /item_lookup in cous_init.
- destruct (iperm it_cous !! l) eqn:it_cous_defined.
- all: rewrite it_cous_defined !cous_init in perm_check_prot.
- all: rewrite bool_decide_eq_true_2 in perm_check_prot; last assumption.
- all: destruct perm; try discriminate.
- all: injection perm_check_prot; intros; subst; congruence.
- * rewrite /item_lookup /= perm'_lookup /=.
- rewrite /item_lookup in cous_init.
- destruct (iperm it_cous !! l) eqn:it_cous_defined;
- rewrite it_cous_defined cous_init //=.
- * rewrite /item_lookup /= perm'_lookup //.
- * rewrite /item_lookup /= perm'_lookup //.
- + (* out of range is a lot easier *)
- econstructor.
- * erewrite <- access_same_rel_dec; eassumption.
- * split; eassumption.
- * eassumption.
- * rewrite /item_lookup /= effect_at_l. assumption.
- * rewrite /item_lookup /= effect_at_l. assumption.
- Qed.
-
- Lemma access_preserves_pseudo_conflicted (b:bool)
- {tr tg l kind acc_tg range conf tr'} :
- pseudo_conflicted tr tg l conf ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr' ->
- pseudo_conflicted tr' tg l conf.
- Proof.
- intros Hpc Haccess. destruct conf.
- 2: by eapply access_preserves_pseudo_conflicted_activable.
- inversion Hpc; by econstructor.
- Qed.
-
- Lemma access_preserves_pseudo_disabled lp pr (b:bool)
- {tr tg l kind acc_tg range tr'} :
- pseudo_disabled tr tg l lp pr ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr' ->
- pseudo_disabled tr' tg l lp pr.
- Proof.
- intros PseudoC Acc.
- inversion PseudoC as [|tg_cous it_cous X1 X2 cous_rel [cous_ex cous_det] cous_nondis cous_init Hextra]; simplify_eq.
- 1: econstructor 1.
- destruct (apply_access_spec_per_node cous_ex cous_det Acc)
- as (cous' & cous'_spec & cous'_ex & cous'_det).
- symmetry in cous'_spec.
- rewrite bind_Some in cous'_spec.
- destruct cous'_spec as (perms' & perms'_spec & cous'_build).
- injection cous'_build; intros; subst; clear cous'_build.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms'_spec) as effect_at_l.
- destruct (decide _); last first.
- + (* out of range is a lot easier *)
- econstructor 2.
- * erewrite <- access_same_rel_dec; eassumption.
- * split; eassumption.
- * eassumption.
- * rewrite /item_lookup /= effect_at_l. assumption.
- * done.
- + (* within range. Big case analysis incoming. *)
- destruct effect_at_l as (perm' & perm'_lookup & perm'_spec).
- rewrite /item_lookup in cous_init. rewrite cous_init in perm'_spec.
- rewrite bool_decide_true in perm'_spec. 2: done.
- destruct b, kind, rel_dec as [[]|] in perm'_spec; cbv in perm'_spec.
- all: try discriminate perm'_spec.
- all: injection perm'_spec as <-.
- all: econstructor 2;
- [ erewrite <- access_same_rel_dec; eassumption
- | split; eassumption
- | done
- | rewrite /item_lookup perm'_lookup /= //
- | done
- ].
- Qed.
-
- Lemma tree_apply_access_preserves_protector
- {tr tr' tg acc_tg kind range b it it'}
- (Lookup : tree_lookup tr tg it)
- (Lookup' : tree_lookup tr' tg it')
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : iprot it' = iprot it.
- Proof.
- destruct (apply_access_spec_per_node (proj1 Lookup) (proj2 Lookup) Acc) as [it'' [Spec'' [Ex'' Det'']]].
- symmetry in Spec''.
- destruct (item_apply_access_preserves_metadata it it'' Spec'') as [?[]].
- rewrite (tree_determined_unify (proj1 Lookup') (proj2 Lookup') Det'').
- done.
- Qed.
-
- Lemma disabled_tree_apply_access_irreversible
- {tr tr' tg acc_tg kind range loc b it}
- (Lookup : tree_lookup tr tg it)
- (Dis : perm (item_lookup it loc) = Disabled)
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : exists it',
- tree_lookup tr' tg it'
- /\ perm (item_lookup it' loc) = Disabled.
- Proof.
- destruct (apply_access_spec_per_node (proj1 Lookup) (proj2 Lookup) Acc) as [it' [Spec' [Ex' Det']]].
- exists it'.
- split; first done.
- symmetry in Spec'.
- rewrite bind_Some in Spec'. destruct Spec' as [tmp [PermsApp Build]].
- injection Build; intros; subst; clear Build.
- pose proof (mem_apply_range'_spec _ _ loc _ _ PermsApp) as LocSpec.
- destruct (decide _).
- + destruct LocSpec as [val [LookupVal SpecVal]].
- rewrite /item_lookup LookupVal /=.
- rewrite /maybe_non_children_only /nonchildren_only in SpecVal.
- repeat case_match.
- 1: { injection SpecVal; intros; subst; done. }
- all: rewrite /apply_access_perm /apply_access_perm_inner /= in SpecVal.
- all: rewrite Dis /= in SpecVal.
- all: repeat case_match; simpl in *; try congruence.
- all: injection SpecVal; intros; subst; simpl; done.
- + rewrite /item_lookup /= LocSpec Dis //.
- Qed.
-
- Lemma is_disabled_tree_apply_access_child
- {tr tr' tg acc_tg kind range loc b it}
- (Lookup : tree_lookup tr tg it)
- (Dis : is_disabled tr tg loc (item_lookup it loc) (iprot it))
- (Cont : tree_contains acc_tg tr)
- (Uni : wf_tree tr)
- (Inside : range'_contains range loc)
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : ¬ ParentChildIn tg acc_tg tr.
- Proof.
- intros HPC.
- destruct (apply_access_spec_per_node (proj1 Lookup) (proj2 Lookup) Acc) as [it' [Spec' [Ex' Det']]].
- symmetry in Spec'.
- rewrite bind_Some in Spec'. destruct Spec' as [tmp [PermsApp Build]].
- injection Build; intros; subst; clear Build.
- pose proof (mem_apply_range'_spec _ _ loc _ _ PermsApp) as LocSpec.
- eapply tree_lookup_correct_tag in Lookup as HH; subst tg.
- rewrite decide_True // in LocSpec.
- destruct LocSpec as (v&Hv&HHv).
- destruct (decide (perm (item_lookup it loc) = Disabled)) as [Hdis|Hnondis].
- { rewrite /rel_dec decide_True // in HHv.
- rewrite maybe_non_children_only_no_effect // in HHv.
- rewrite /apply_access_perm /apply_access_perm_inner /= Hdis in HHv.
- by destruct kind. }
- inversion Dis as [X1 Hlu X2|lp X1 Hdis Hlu X2]; simplify_eq.
- 1: rewrite -Hlu in Hnondis; done.
- inversion Hdis as [X1 X2 X3|tg_cs it_cs X1 X2 Hcs Hlucs Hprotcs Hppcs Hcsfoo X3 X4]; simplify_eq.
- 1: rewrite -Hlu in Hnondis; done.
- destruct (apply_access_spec_per_node (proj1 Hlucs) (proj2 Hlucs) Acc) as [itcs' [Speccs' Hlucs']].
- symmetry in Speccs'.
- rewrite bind_Some in Speccs'. destruct Speccs' as [tmpcs [PermsAppcs [= <-]]].
- pose proof (mem_apply_range'_spec _ _ loc _ _ PermsAppcs) as LocSpeccs.
- rewrite decide_True // in LocSpeccs.
- destruct LocSpeccs as [valcs [Hvcs HHvcs]].
- rewrite /rel_dec in HHvcs.
- eapply tree_lookup_correct_tag in Hlucs' as HH; subst tg_cs.
- rewrite decide_False in HHvcs; last first.
- { intros HnPCI1. eapply cousins_have_disjoint_children in Hcs. 5: done. 5: done.
- 1: done. all: simpl; eapply Uni. 1: done. 1: apply Lookup. 1: eapply Hlucs. }
- rewrite decide_False in HHvcs; last first.
- { intros HnPCI1.
- rewrite /rel_dec in Hcs.
- destruct decide as [?|HNP2] in Hcs; first done.
- destruct decide as [?|HNP3] in Hcs; first done.
- eapply HNP3; simpl. eapply ParentChild_transitive.
- 1: done. done. }
- rewrite maybe_non_children_only_no_effect // in HHvcs.
- rewrite bool_decide_true // in HHvcs.
- rewrite /item_lookup in Hppcs.
- rewrite Hppcs in HHvcs. destruct kind; done.
- Qed.
-
- Lemma is_disabled_tree_apply_access_irreversible
- {tr tr' tg acc_tg kind range loc b it}
- (Lookup : tree_lookup tr tg it)
- (Dis : is_disabled tr tg loc (item_lookup it loc) (iprot it))
- (Cont : tree_contains acc_tg tr)
- (Uni : wf_tree tr)
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : exists it',
- tree_lookup tr' tg it' ∧ iprot it = iprot it' ∧
- is_disabled tr' tg loc (item_lookup it' loc) (iprot it').
- Proof.
- destruct (apply_access_spec_per_node (proj1 Lookup) (proj2 Lookup) Acc) as [it' [Spec' [Ex' Det']]].
- exists it'.
- split; first done.
- symmetry in Spec'.
- rewrite bind_Some in Spec'. destruct Spec' as [tmp [PermsApp Build]].
- injection Build; intros; subst; clear Build. split; first done.
- destruct (decide (perm (item_lookup it loc) = Disabled)) as [Hdis|Hnondis].
- { eapply disabled_tree_apply_access_irreversible in Hdis as (it'&Htr'&Hit'). 2-3: done.
- eapply tree_determined_unify in Det'. 2: done. 2: apply Htr'.
- destruct (item_lookup it' loc) as [[] pp] eqn:Hini; subst it'.
- all: rewrite Hini. all: simpl in Hit'; subst pp.
- 1: econstructor 1. 1: econstructor 2. econstructor 1. }
- pose proof (mem_apply_range'_spec _ _ loc _ _ PermsApp) as LocSpec.
- inversion Dis as [X1 Hlu X2|lp X1 Hdis Hlu X2]; simplify_eq.
- 1: rewrite -Hlu in Hnondis; done.
- inversion Hdis as [X1 X2 X3|tg_cs it_cs X1 X2 Hcs Hlucs Hprotcs Hppcs Hcsfoo X3 X4]; simplify_eq.
- 1: rewrite -Hlu in Hnondis; done.
- destruct (apply_access_spec_per_node (proj1 Hlucs) (proj2 Hlucs) Acc) as [itcs' [Speccs' Hlucs']].
- symmetry in Speccs'.
- rewrite bind_Some in Speccs'. destruct Speccs' as [tmpcs [PermsAppcs [= <-]]].
- pose proof (mem_apply_range'_spec _ _ loc _ _ PermsAppcs) as LocSpeccs.
- destruct (decide _) as [In|Out]; last first.
- + rewrite /item_lookup /= LocSpec.
- rewrite /item_lookup in Hlu. rewrite -Hlu.
- econstructor. eapply access_preserves_pseudo_disabled. 1: done. done.
- + destruct LocSpec as [val [LookupVal SpecVal]].
- destruct LocSpeccs as [valcs [LookupValcs SpecValcs]].
- rewrite /rel_dec in SpecVal.
- eapply tree_lookup_correct_tag in Lookup as HH; subst tg.
- eapply tree_lookup_correct_tag in Hlucs' as HH; subst tg_cs.
- rewrite decide_False in SpecVal.
- 2: { eapply is_disabled_tree_apply_access_child. 6: done. 2: done. all: done. }
- edestruct maybe_non_children_only_effect_or_nop as [Heff|Heff];
- erewrite Heff in SpecVal; clear Heff.
- 2: { injection SpecVal as <-. simpl.
- rewrite /item_lookup /= in Hlu|-*.
- rewrite LookupVal /= -Hlu.
- econstructor 2. eapply access_preserves_pseudo_disabled; last done.
- done. }
- rewrite /item_lookup in Hlu. rewrite -Hlu in SpecVal.
- rewrite /apply_access_perm /apply_access_perm_inner most_init_comm /= in SpecVal.
- destruct kind, bool_decide eqn:Hbdc, lp as [[]| | | |] eqn:Hpm in SpecVal.
- all: simpl in SpecVal. all: try discriminate SpecVal.
- all: injection SpecVal as <-.
- all: rewrite /= /item_lookup /= LookupVal /=.
- all: econstructor 2.
- all: eapply access_preserves_pseudo_disabled; last done.
- all: econstructor; [exact Hcs|exact Hlucs|exact Hprotcs|exact Hppcs|].
- all: intros [=].
- all: subst lp; eapply Hcsfoo; done.
- Qed.
-
- Lemma create_child_irreversible
- {tr tr' tg tg_old tg_new it pk im rk cid}
- (Lookup : tree_lookup tr tg it)
- (Fresh : tg_new ≠tg)
- (Ins : create_child C tg_old tg_new pk im rk cid tr = Some tr')
- : tree_lookup tr' tg it.
- Proof.
- pose proof Ins as (x&<-%new_item_has_tag&[= <-])%bind_Some.
- destruct Lookup as [Ex Det]. split.
- - apply insert_preserves_exists; assumption.
- - apply insert_true_preserves_every; last assumption.
- intro SameTg. done.
- Qed.
-
- Definition becomes_frozen (kind : access_kind) (range : Z * nat) (loc : Z) (b:bool) tr acc_tg it_tg: Prop :=
- if decide (range'_contains range loc) then kind = AccessRead ∨ (∃ k, b = true ∧ rel_dec tr acc_tg it_tg = Foreign (Parent k)) else True.
- Definition becomes_disabled (kind : access_kind) (range : Z * nat) (loc : Z) (b:bool) tr acc_tg it_tg: Prop :=
- if decide (range'_contains range loc) then kind = AccessWrite ∧ (∃ f, rel_dec tr acc_tg it_tg = Foreign f ∧ ∀ p, f = Parent p → b = false) else False.
-
- Lemma becomes_not_both kind range loc b tr acc_tg it_tg :
- becomes_frozen kind range loc b tr acc_tg it_tg →
- becomes_disabled kind range loc b tr acc_tg it_tg →
- False.
- Proof.
- intros H1 H2.
- rewrite /becomes_frozen /becomes_disabled in H1,H2.
- destruct decide. 2: done.
- destruct H2 as (->&f&Hff&Hfb).
- destruct H1 as [[=]|(k&->&Hk)].
- rewrite Hk in Hff. simplify_eq.
- by specialize (Hfb _ eq_refl).
- Qed.
-
- Lemma frozen_tree_apply_access_irreversible
- {tr tr' tg acc_tg kind range loc b it}
- (Lookup : tree_lookup tr tg it)
- (Frz : (item_lookup it loc).(perm) = Frozen)
- (Ini : (item_lookup it loc).(initialized) = PermInit)
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : exists it',
- tree_lookup tr' tg it'
- /\ let k := (item_lookup it' loc) in let bf := becomes_frozen kind range loc b tr acc_tg (itag it) in let bd := becomes_disabled kind range loc b tr acc_tg (itag it) in
- k.(initialized) = PermInit
- /\ (k.(perm) = Frozen ∧ bf ∨ (k.(perm) = Disabled ∧ bd ∧ ¬ protector_is_active it'.(iprot) C)).
- Proof.
- destruct (apply_access_spec_per_node (proj1 Lookup) (proj2 Lookup) Acc) as [it' [Spec' [Ex' Det']]].
- exists it'.
- split; first done.
- symmetry in Spec'.
- rewrite bind_Some in Spec'. destruct Spec' as [tmp [PermsApp Build]].
- intros k bf bd.
- injection Build; intros; subst; clear Build.
- pose proof (mem_apply_range'_spec _ _ loc _ _ PermsApp) as LocSpec. subst bf bd. rewrite /becomes_frozen /becomes_disabled.
- destruct (decide _); last first.
- + subst k. rewrite /item_lookup /= LocSpec Frz Ini //. split; first done. by left.
- + destruct LocSpec as [val [LookupVal SpecVal]]. subst k.
- rewrite /item_lookup LookupVal /=.
- rewrite /maybe_non_children_only /nonchildren_only in SpecVal.
- repeat case_match.
- 1: { injection SpecVal; intros; subst; split; first done. left. split; first done. eauto. }
- all: rewrite /apply_access_perm /apply_access_perm_inner /= in SpecVal.
- all: rewrite Frz /= Ini /= in SpecVal.
- all: repeat case_match; simpl in *; try congruence.
- all: injection SpecVal; intros; subst; simpl; split; first done.
- all: first [ left; split; first done; eauto | right; split; first done; split ].
- 2, 4: by eapply bool_decide_eq_false_1.
- all: split; first done.
- all: eexists; split; first done.
- 1: intros ? [=]. done.
- Qed.
-
- Lemma parent_has_perm_similarly_disabled_after_access
- {pp tr tr' tg acc_tg kind range loc b it}
- (Lookup : tree_lookup tr tg it)
- (Frz : (item_lookup it loc).(perm) = pp)
- (nRIM : pp ≠ReservedIM)
- (Ini : (item_lookup it loc).(initialized) = PermInit)
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : exists it',
- tree_lookup tr' tg it'
- /\ let k := (item_lookup it' loc) in let bd := becomes_disabled kind range loc b tr acc_tg (itag it) in
- k.(initialized) = PermInit
- /\ (bd → (k.(perm) = Disabled ∧ ¬ protector_is_active it'.(iprot) C)).
- Proof.
- destruct (apply_access_spec_per_node (proj1 Lookup) (proj2 Lookup) Acc) as [it' [Spec' [Ex' Det']]].
- exists it'.
- split; first done.
- symmetry in Spec'.
- rewrite bind_Some in Spec'. destruct Spec' as [tmp [PermsApp Build]].
- intros k bd.
- injection Build; intros; subst; clear Build.
- pose proof (mem_apply_range'_spec _ _ loc _ _ PermsApp) as LocSpec. subst bd. rewrite /becomes_disabled.
- destruct (decide _); last first.
- + subst k. rewrite /item_lookup /= LocSpec Ini //.
- + destruct LocSpec as [val [LookupVal SpecVal]]. subst k.
- rewrite /item_lookup LookupVal /=.
- rewrite /maybe_non_children_only /nonchildren_only in SpecVal.
- repeat case_match.
- 1: { injection SpecVal; intros; subst; split; first done. intros (->&f&[= <-]&HH). by specialize (HH _ eq_refl). }
- all: rewrite /apply_access_perm /apply_access_perm_inner /= in SpecVal.
- all: rewrite /= Ini /= in SpecVal.
- all: repeat case_match; simpl in *; try congruence.
- all: injection SpecVal; intros; subst; simpl; split; first done.
- all: intros (Heq1&Hf&Heq2&HHf); simplify_eq.
- all: split; last try by eapply bool_decide_eq_false_1.
- all: done.
- Qed.
-
- Lemma disabled_in_practice_tree_apply_access_irreversible
- {tr tr' tg acc_tg kind range witness loc b}
- (Dis : disabled_in_practice tr tg witness loc)
- (Cont : tree_contains acc_tg tr)
- (Uni : wf_tree tr)
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : disabled_in_practice tr' tg witness loc.
- Proof.
- inversion Dis as [?? Rel Lookup Perm].
- destruct (is_disabled_tree_apply_access_irreversible Lookup Perm Cont Uni Acc) as [it' [Lookup' Perm']].
- econstructor.
- + erewrite <- access_same_rel_dec; eassumption.
- + apply Lookup'.
- + apply Perm'.
- Qed.
-
- Lemma frozen_in_practice_tree_apply_access_irreversible
- {tr tr' tg acc_tg kind range witness loc b}
- (Frz : frozen_in_practice tr tg witness loc)
- (Cont : tree_contains acc_tg tr)
- (Uni : wf_tree tr)
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : let bf := becomes_frozen kind range loc b tr acc_tg witness in
- let bd := becomes_disabled kind range loc b tr acc_tg witness in
- (frozen_in_practice tr' tg witness loc ∧ bf) ∨ (parent_has_perm Disabled tr' tg witness loc ∧ bd).
- Proof.
- inversion Frz as [it_witness incl Rel Lookup Perm Init].
- assert (itag it_witness = witness) as <- by by eapply tree_lookup_correct_tag.
- destruct (frozen_tree_apply_access_irreversible Lookup Perm Init Acc) as [it' [Lookup' [Init' [[Perm' BF]|[Perm' [BF NoProt]]]]]].
- - left. split; last done. econstructor.
- + erewrite <- access_same_rel_dec; eassumption.
- + apply Lookup'.
- + apply Perm'.
- + apply Init'.
- - right. split; last done. econstructor.
- + erewrite <- access_same_rel_dec; eassumption.
- + apply Lookup'.
- + destruct (item_lookup it' loc) as [lp pp]; simpl in Init',Perm'; subst. done.
- + destruct (item_lookup it' loc) as [lp pp]; simpl in Init',Perm'; subst. done.
- Qed.
-
- Lemma parent_has_disabled_perm_is_pseudo_disabled tr tg witness loc :
- parent_has_perm Disabled tr tg witness loc →
- disabled_in_practice tr tg witness loc.
- Proof.
- inversion 1 as [it incl H0 H1 H2 H3]; simplify_eq.
- econstructor. 1-2: done.
- destruct (item_lookup it loc); simpl in H2,H3; simplify_eq.
- econstructor 1.
- Qed.
-
- Lemma parent_has_perm_similarly_disabled
- {p tr tr' tg acc_tg kind range witness loc b}
- (Frz : parent_has_perm p tr tg witness loc)
- (nRIM : p ≠ReservedIM)
- (Cont : tree_contains acc_tg tr)
- (Uni : wf_tree tr)
- (Acc : tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr = Some tr')
- : let bd := becomes_disabled kind range loc b tr acc_tg witness in
- bd → parent_has_perm Disabled tr' tg witness loc.
- Proof.
- inversion Frz as [it_witness incl Rel Lookup Perm Init].
- assert (itag it_witness = witness) as <- by by eapply tree_lookup_correct_tag.
- destruct (parent_has_perm_similarly_disabled_after_access Lookup Perm nRIM Init Acc) as [it' [Lookup' [Init' Perm']]].
- intros bd. subst bd. intros Hbd. specialize (Perm' Hbd) as (Hd&Hnoprot).
- econstructor.
- + erewrite <- access_same_rel_dec; eassumption.
- + apply Lookup'.
- + destruct (item_lookup it' loc) as [lp pp]; simpl in Init',Hd; subst. done.
- + destruct (item_lookup it' loc) as [lp pp]; simpl in Init',Hd; subst. done.
- Qed.
-
- Lemma if_same_guard_equal
- {P Q : Prop} {T} {x y x' y' : T} `{Decision P} `{Decision Q}
- (Iff : P <-> Q)
- (Ex : x = x')
- (Ey : y = y')
- : (if decide P then x else y) = (if decide Q then x' else y').
- Proof.
- repeat destruct (decide _); tauto.
- Qed.
-
- Lemma disabled_in_practice_create_child_irreversible
- {tr tr' tg tg_old tg_new pk im rk cid witness loc}
- (Ne : tg_new ≠tg)
- (Ne' : tg_new ≠witness)
- (Nc : ¬ tree_contains tg_new tr)
- (Dis : disabled_in_practice tr tg witness loc)
- (Ins : create_child C tg_old tg_new pk im rk cid tr = Some tr')
- : disabled_in_practice tr' tg witness loc.
- Proof.
- inversion Dis as [it_witness ? Rel Lookup Perm].
- econstructor.
- - erewrite <-create_child_same_rel_dec. 1: exact Rel. 3: done. 1-2: done.
- - eapply create_child_irreversible.
- 1: done. 2: done. done.
- - inversion Perm as [|lp X H1 H2 X2]; simplify_eq. 1: econstructor 1.
- econstructor 2. inversion H1 as [|tgcs itcs X1 X2 H1' H2' H3 H4 H5 X3 X4]; simplify_eq. 1: econstructor 1.
- destruct (decide (tgcs = tg_new)) as [->|Hne].
- { exfalso. eapply Nc, H2'. }
- econstructor 2.
- + erewrite <-create_child_same_rel_dec. 1: exact H1'. 3: done. 1-2: done.
- + eapply create_child_irreversible. 1: exact H2'. 2: done. done.
- + done.
- + done.
- + done.
- Qed.
-
- Lemma frozen_in_practice_create_child_irreversible
- {tr tr' tg tg_old tg_new pk im rk cid witness loc}
- (Ne : tg_new ≠tg)
- (Ne' : tg_new ≠witness)
- (Frz : frozen_in_practice tr tg witness loc)
- (Ins : create_child C tg_old tg_new pk im rk cid tr = Some tr')
- : frozen_in_practice tr' tg witness loc.
- Proof.
- inversion Frz as [it_witness ? Rel Lookup Perm Ini].
- opose proof (create_child_irreversible Lookup Ne' Ins) as Lookup'.
- econstructor.
- + erewrite <- create_child_same_rel_dec; first eassumption.
- - eassumption.
- - eassumption.
- - eassumption.
- + apply Lookup'.
- + done.
- + done.
- Qed.
-
- Lemma most_init_comm {i i'} :
- most_init i i' = most_init i' i.
- Proof.
- unfold most_init.
- repeat case_match; reflexivity.
- Qed.
-
- Lemma most_init_noop {i} :
- most_init i PermLazy = i.
- Proof.
- unfold most_init.
- case_match; reflexivity.
- Qed.
-
- Lemma most_init_absorb {i} :
- most_init i PermInit = PermInit.
- Proof.
- unfold most_init.
- case_match; reflexivity.
- Qed.
-
- Lemma trees_equal_find_equal_tag_protected_initialized_not_disabled d trs1 trs2 it1 tg blk off:
- each_tree_protected_parents_not_disabled C trs2 →
- wf_trees trs2 →
- trees_equal d trs1 trs2 →
- trees_lookup trs1 blk tg it1 →
- (initialized (item_lookup it1 off) = PermInit → perm (item_lookup it1 off) ≠Disabled) →
- protector_is_active it1.(iprot) C →
- ∃ it2, trees_lookup trs2 blk tg it2 ∧
- (initialized (item_lookup it2 off) = PermInit → perm (item_lookup it2 off) ≠Disabled) ∧
- protector_is_active it2.(iprot) C.
- Proof.
- intros Heach Hwf Heq (tr1&Htr1&Hit) Hperm Hactive.
- specialize (Heq blk). rewrite Htr1 in Heq. inversion Heq as [x tr2 Heq' Hx Htr2|]. subst x.
- destruct Heq' as (Heq1&Heq2&Heq3).
- pose proof Hit as (Hitin&Hitdet).
- specialize (Heq3 _ Hitin) as (it1'&it2&Hit1'&Hit2&Heqit).
- assert (it1 = it1') as <-.
- { eapply tree_determined_unify. 2: done. 1: done. apply Hit1'. }
- exists it2. specialize (Heqit off) as (Hprotit&Hlocit).
- split. 1: exists tr2; done.
- rewrite -Hprotit. inversion Hlocit as [|e c1 c2 H H1 H2 H3 H4| | | | |p1 p2 ini H]; simplify_eq.
- - done.
- - rewrite -!H3 /= in Hperm. simpl. done.
- - exfalso. done.
- - done.
- - split; last done. intros Hinit Hdis.
- ospecialize (Heach _ _ _ tg). 1: symmetry; exact Htr2.
- eapply every_child_ParentChildIn in Heach. 2: by eapply Hwf. 2,4: eapply Hwf; first done; eapply Hit2.
- 2: eapply Hit2. 2: by left.
- rewrite every_node_eqv_universal in Heach. ospecialize (Heach it2 _ _ off _ _ Hdis).
- 1: eapply exists_determined_exists; eapply Hit2. 1: by eapply tree_lookup_correct_tag.
- 1: done. 1: by rewrite -Hprotit. done.
- - split; last done. simpl. done.
- - split; last done. simpl. intros ->. destruct d; by inversion H.
- Qed.
-
- Lemma tree_lookup_IsTag tr tg it : tree_lookup tr tg it → IsTag tg it.
- Proof.
- intros (H1 & H2).
- eapply exists_node_eqv_existential in H1 as (it2 & Hit2 & Histag).
- eapply every_node_eqv_universal in H2; last done.
- by rewrite -H2.
- Qed.
-
- Lemma tree_lookup_unique tr tg it1 it2 : tree_lookup tr tg it1 → tree_lookup tr tg it2 → it1 = it2.
- Proof.
- intros Hlu (H1 & H2).
- eapply every_node_eqv_universal in H2; first apply H2.
- 1: by eapply tree_lookup_IsTag.
- eapply exists_determined_exists; first done.
- apply Hlu.
- Qed.
-
- Lemma tree_equal_transfer_item_non_disabled d tr1 tr2 tg it off :
- protected_parents_not_disabled C tr1 →
- no_active_cousins C tr1 →
- (∀ tg, tree_contains tg tr1 → tree_unique tg tr1) →
- tree_equal d tr1 tr2 →
- tree_lookup tr1 tg it →
- protector_is_active (iprot it) C ∧ perm (item_lookup it off) ≠Disabled ∧ initialized (item_lookup it off) = PermInit →
- ∃ it2, tree_lookup tr2 tg it2 ∧ protector_is_active (iprot it2) C ∧ perm (item_lookup it2 off) ≠Disabled ∧ initialized (item_lookup it2 off) = PermInit.
- Proof.
- intros Hpnd Hnac Hunq (He1&He2&He3) Hlu (Hprot&Hndis&Hini).
- destruct (He3 tg) as (it1&it2&Hlu1&Hlu2&Heq).
- 1: eapply Hlu.
- assert (it = it1) as -> by by eapply tree_lookup_unique.
- exists it2. specialize (Heq off) as (Hproteq&Hiteq). split; first done.
- split. 1: by rewrite -Hproteq.
- inversion Hiteq as [pp1|ini1 confl1 confl2 HprotX HP1 HP2 Heq1 Heq2|ini1 confl1 confl2 HnoProt|p1 p2 HP1 HP2 Heq1 Heq2|wit_tg lp1 lp2 Hdip1 Hdip2 HiniX Heq1 Heq2|ini1 confl1 confl2 wit_tg HF Heq1 Heq2|p1 p2 ini Hd Heq1 Heq2]; simplify_eq.
- - done.
- - split; first done. rewrite -Heq1 /= in Hini. rewrite /= Hini //.
- - rewrite -Heq1 in Hini. done.
- - exfalso.
- inversion Hdip1 as [itw p Hreldec Hluw Hdisw].
- rewrite /rel_dec in Hreldec. destruct decide; last done.
- eapply tree_lookup_correct_tag in Hlu as HH. subst tg.
- specialize (Hpnd wit_tg). eapply every_child_ParentChildIn in Hpnd.
- 2: eapply Hunq. 2: eapply Hunq, Hluw. 2: eapply Hluw. 2: eapply Hunq, Hlu.
- 2: done.
- eapply every_node_eqv_universal in Hpnd.
- 2: { eapply tree_lookup_to_exists_node. eapply Hlu. }
- inversion Hdisw as [X1 HH X2|pp X2 Hdis Hlazy X5]; simplify_eq.
- { unshelve eapply (Hpnd _ off); [done..|by rewrite -HH]. }
- inversion Hdis as [X1 HH X2|tgcs itcs lp X1 Hcs Hlucs Hprotcs Hactcs HH X2 X3]; simplify_eq.
- { unshelve eapply (Hpnd _ off). 1-3: done. rewrite -Hlazy. done. }
- eapply Hnac. 2: eapply Hlucs. 1: eapply Hlu. 3: by erewrite Hactcs.
- 2: right; split; done.
- eapply child_of_this_is_foreign_for_cousin. 4: exact Hcs.
- 1-3: eapply Hunq. 1: eapply Hluw. 1: eapply Hlucs. 1: eapply Hlu.
- rewrite /rel_dec decide_True //.
- - split; first done. rewrite -Heq1 /= in Hini. rewrite /= Hini //.
- - rewrite -Heq1 /= in Hini Hndis. simplify_eq. split; last done.
- simpl. destruct d; inversion Hd; done.
- Qed.
-
- Lemma tree_equal_transfer_pseudo_conflicted d tr1 tr2 tg off confl :
- protected_parents_not_disabled C tr1 →
- no_active_cousins C tr1 →
- (∀ tg, tree_contains tg tr1 → tree_unique tg tr1) →
- tree_equal d tr1 tr2 →
- pseudo_conflicted tr1 tg off confl →
- pseudo_conflicted tr2 tg off confl.
- Proof.
- intros Hpnd Hnac Hunq (HH1&HH2&HH3) Hconfl.
- inversion Hconfl as [|tg_cs it_cs Hcs Hlu Hprot Hperm Hini]; simplify_eq.
- - econstructor 1.
- - edestruct tree_equal_transfer_item_non_disabled as (it2&Hit2&Hprot2&Hndis2&Hini2).
- 1: exact Hpnd. 1: exact Hnac. 1: exact Hunq. 1: split; done. 1: exact Hlu.
- 1: split; done.
- econstructor 2. 1: by erewrite <- HH2. 1: exact Hit2.
- all: done.
- Qed.
-
- Global Instance pseudo_disabled_dec tr tg off pp oprot : Decision (pseudo_disabled tr tg off pp oprot).
- Proof.
- destruct (decide (pp = Disabled)) as [->|Hne].
- 1: left; econstructor 1.
- pose (P it_cs := let tg_cs := itag it_cs in
- rel_dec tr tg tg_cs = Foreign Cousin ∧
- tree_item_determined tg_cs it_cs tr ∧
- protector_is_active (iprot it_cs) C ∧
- item_lookup it_cs off = mkPerm PermInit Active ∧
- match pp with ReservedIM => False | _ => True end).
- assert (∀ it, Decision (P it)) as DecP.
- { intros it.
- rewrite /P.
- do 4 (eapply and_dec; first eapply _).
- destruct pp.
- all: eapply _. }
- destruct (decide (exists_node P tr)) as [HP|HnP].
- - left. eapply exists_node_eqv_existential in HP as (it&Htgit&H1&H2&H3&H4&H5).
- econstructor 2.
- 1: exact H1. 1: split. 2: exact H2.
- 1: eapply exists_node_eqv_existential; exists it; done.
- 1: done. 1: done.
- 1: intros ->. done.
- - right. intros Hdis.
- induction Hdis as [|tg_cs it_cs lp Hlp H1 H2 H3 H4 H5]; first done.
- eapply HnP. eapply exists_node_eqv_existential.
- exists it_cs. split. 1: eapply tree_lookup_to_exists_node; done.
- assert (itag it_cs = tg_cs) as <- by by eapply tree_lookup_correct_tag.
- split; first done.
- split; first eapply H2.
- split; first done.
- split; first done.
- destruct lp as [| | | |]; try done.
- Defined.
-
- Global Instance is_disabled_dec tr tg off lp oprot : Decision (is_disabled tr tg off lp oprot).
- Proof.
- destruct (decide (lp = mkPerm PermInit Disabled)) as [->|Hne].
- 1: left; econstructor 1.
- destruct lp as [[] pp].
- 1: { right. intros HH. inversion HH. subst pp. done. }
- destruct (decide (pseudo_disabled tr tg off pp oprot)) as [Hpd|Hnpd].
- 1: left; econstructor 2; done.
- right.
- intros HH. inversion HH; simplify_eq.
- Qed.
-
- Lemma exists_node_to_tree_lookup tr itm
- (GloballyUnique : forall tg, tree_contains tg tr -> tree_unique tg tr) :
- exists_node (eq itm) tr →
- tree_lookup tr (itag itm) itm.
- Proof.
- intros Hexi. assert (tree_contains (itag itm) tr) as Hcontain.
- - eapply exists_node_increasing; first done.
- eapply every_node_eqv_universal; intros ? _ <-. done.
- - split; first done.
- eapply GloballyUnique, unique_lookup in Hcontain as (it2 & Hit2).
- enough (itm = it2) by by subst itm.
- eapply every_node_eqv_universal in Hit2; first eapply Hit2.
- all: done.
- Qed.
-
- Lemma trees_equal_decide_disabled_in_practice tr tg off :
- (∀ tg, tree_contains tg tr → tree_unique tg tr) →
- tree_contains tg tr →
- (∃ tgp itp, tree_lookup tr tgp itp ∧ is_disabled tr tgp off (item_lookup itp off) (iprot itp) ∧ ParentChildIn tgp tg tr ∧
- ∀ tgpp itpp, tree_lookup tr tgpp itpp → StrictParentChildIn tgpp tgp tr → ¬ is_disabled tr tgpp off (item_lookup itpp off) (iprot itpp))
- + (∀ tgp itp, tree_lookup tr tgp itp → ParentChildIn tgp tg tr → ¬ is_disabled tr tgp off (item_lookup itp off) (iprot itp)).
- Proof.
- intros Hunq H.
- assert (Decision (exists_node (λ it, is_disabled tr (itag it) off (item_lookup it off) (iprot it) ∧ ParentChildIn (itag it) tg tr) tr)) as Hdec.
- { eapply exists_node_dec. intros itx. eapply and_dec. 2: by eapply ParentChildIn_dec. apply _. }
- destruct Hdec as [Hleft|Hright].
- - left.
- edestruct (find_highest_parent_with_property (λ x, is_disabled tr (itag x) off (item_lookup x off) (iprot x) ∧ ParentChildIn (itag x) tg tr)) as (tgpp&Htgpp&Hppp).
- { intros x. eapply and_dec. 2: by eapply ParentChildIn_dec. apply _. }
- { done. }
- { done. }
- eapply exists_node_eqv_existential in Htgpp. destruct Htgpp as (itpp&Hitpp&(HHitpp1&HHitpp2)&<-).
- eapply exists_node_to_tree_lookup in Hitpp. 2: done.
- exists (itag itpp), itpp. do 3 (split; first done).
- intros tgppp itppp Hitppp HSPppp Hdis.
- eapply Hppp. 2: exact HSPppp.
- eapply tree_lookup_correct_tag in Hitppp as Htg. subst tgppp.
- eapply exists_node_eqv_existential. exists itppp.
- split. 2: split_and!; try done. 1: by eapply tree_lookup_to_exists_node.
- eapply ParentChild_transitive; [|exact HHitpp2]; right; done.
- - right. intros tgp itp Hlu HPC Hdis. eapply tree_lookup_correct_tag in Hlu as Htg; subst tgp.
- eapply Hright. eapply exists_node_eqv_existential.
- eexists. split. 1: eapply tree_lookup_to_exists_node, Hlu. split; done.
- Qed.
-
- Lemma item_eq_up_to_C_same_iprot d tr1 tr2 tg it1 it2 :
- item_eq_up_to_C tr1 tr2 tg d it1 it2 →
- it1.(iprot) = it2.(iprot).
- Proof.
- intros H. specialize (H 0). inversion H. done.
- Qed.
-
- Lemma perm_eq_up_to_C_same_init d tr1 tr2 tg off prot lp1 lp2 :
- perm_eq_up_to_C tr1 tr2 tg off prot d lp1 lp2 →
- initialized lp1 = initialized lp2.
- Proof.
- intros H. try by inversion H.
- Qed.
-
- Lemma parents_not_disabled_child_not_active tr tg1 tg2 it1 it2 off
- (Hwf : wf_tree tr)
- (HPP : parents_more_active tr) :
- tree_lookup tr tg1 it1 →
- tree_lookup tr tg2 it2 →
- ParentChildIn tg1 tg2 tr →
- perm (item_lookup it1 off) = Disabled →
- perm (item_lookup it2 off) = Active →
- False.
- Proof.
- intros Hl1 Hl2 HPC Hp1 Hp2.
- specialize (HPP tg1). eapply every_child_ParentChildIn in HPP.
- 2: done. 2, 4: eapply Hwf. 2,4: eapply Hl1. 2: eapply Hl2. 2: done.
- assert (tg1 = itag it1) as -> by by eapply tree_lookup_correct_tag in Hl1.
- assert (tg2 = itag it2) as -> by by eapply tree_lookup_correct_tag in Hl2.
- eapply every_node_eqv_universal in HPP.
- 2: eapply tree_lookup_to_exists_node, Hl2.
- ospecialize (HPP _ _ Hp2). 1: done. congruence.
- Qed.
-
- Lemma disabled_in_practice_not_active tr tg1 tg2 it off
- (Hwf : wf_tree tr)
- (HPP : parents_more_active tr)
- (HNC : no_active_cousins C tr) :
- tree_lookup tr tg2 it →
- perm (item_lookup it off) = Active →
- disabled_in_practice tr tg2 tg1 off →
- False.
- Proof.
- intros Hl1 Hact [it_witness incl H1 H2 H3].
- destruct (decide (perm (item_lookup it_witness off) = Disabled)) as [Hdis|Hnondis].
- + eapply parents_not_disabled_child_not_active. 1: exact Hwf. 1: done. 4: exact Hdis. 4: exact Hact.
- 1-2: done.
- rewrite /rel_dec in H1. destruct decide; done.
- + inversion H3 as [X1 X2 X3|lp X HH1 HH2 X2]; simplify_eq.
- { rewrite -X2 in Hnondis. done. }
- inversion HH1 as [|tgcs itcs X1 X2 H1' H2' H3' H4 H5 X3 X4]; simplify_eq.
- { rewrite -HH2 in Hnondis. done. }
- eapply HNC. 1: exact H2'. 1: exact Hl1. 3: exact Hact. 2: right; split; first done.
- 2: by rewrite H4.
- rewrite /rel_dec in H1|-*.
- destruct decide as [HPC1|] in H1; last done. clear H1.
- rewrite decide_False; last first.
- { intros HPC2. rewrite /rel_dec in H1'.
- destruct decide in H1'; try done.
- rewrite decide_True // in H1'.
- eapply ParentChild_transitive. 1: exact HPC1. done. }
- rewrite decide_False //.
- intros HPC2.
- eapply cousins_have_disjoint_children. 4: exact H1'. 4: exact HPC1. 4: done.
- all: eapply Hwf. 1: eapply Hl1. 1: eapply H2. 1: eapply H2'.
- Qed.
-
- Lemma tree_equal_transfer_pseudo_disabled {d tr tr2 tgcld off lp pp} :
- (∀ tg, tree_contains tg tr2 → tree_unique tg tr2) →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- pseudo_disabled tr2 tgcld off lp pp →
- tree_equal d tr tr2 → pseudo_disabled tr tgcld off lp pp.
- Proof.
- intros Hunq Hwf1 Hwf2 HH (He1&He2&He3).
- induction HH as [|tg_cs it_cs lp prot H1 H2 H3 H4 H5].
- 1: econstructor 1.
- edestruct He3 as (it_cs1&X&Hit_cs1&HX&Hiteq).
- 1: eapply He1, H2.
- assert (X = it_cs) as -> by by eapply tree_lookup_unique.
- specialize (Hiteq off) as (Hprot&Hiteq).
- econstructor 2. 2: exact Hit_cs1.
- 1: by rewrite He2.
- 1: rewrite Hprot //.
- 2: done.
- rewrite H4 in Hiteq.
- inversion Hiteq as [| | | | | |p1 p2 ini Hd]; simplify_eq.
- - congruence.
- - exfalso. eapply disabled_in_practice_not_active.
- 5: erewrite H4; done.
- 4: done. 1: done. 3: eassumption. all: done.
- - rewrite -Hprot in H3. f_equal.
- destruct d; inversion Hd; done.
- Qed.
-
- Lemma transfer_pseudo_disabled_notimm p1 p2 tr tg off pp :
- pseudo_disabled tr tg off p1 pp →
- p2 ≠ReservedIM → p1 ≠Disabled →
- pseudo_disabled tr tg off p2 pp.
- Proof.
- intros H Hne1 Hne2.
- inversion H as [|X1 X2 X3 X4 X5 X6 X7 X8 X9]. 1: done. econstructor 2.
- 1-4: done. done.
- Qed.
-
- Lemma conflicted_transfer_pseudo_disabled c1 c2 tr tg off pp :
- pseudo_disabled tr tg off (Reserved c1) pp →
- pseudo_disabled tr tg off (Reserved c2) pp.
- Proof.
- intros HH. eapply transfer_pseudo_disabled_notimm. 1: done. all: done.
- Qed.
-
- Lemma tree_equal_transfer_is_disabled {d tr tr2 tgcld off lp pp} :
- (∀ tg, tree_contains tg tr2 → tree_unique tg tr2) →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- is_disabled tr2 tgcld off lp pp →
- tree_equal d tr tr2 → is_disabled tr tgcld off lp pp.
- Proof.
- intros Hunq ?? Hdis Heq.
- induction Hdis as [|lp prot HH].
- 1: econstructor 1.
- econstructor 2.
- by eapply tree_equal_transfer_pseudo_disabled.
- Qed.
-
-
- Lemma trees_equal_transfer_disabled_in_practice_many {tr2 tgpar tgcld off} :
- (∀ tg, tree_contains tg tr2 → tree_unique tg tr2) →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- disabled_in_practice tr2 tgcld tgpar off →
- ∃ tgpar',
- disabled_in_practice tr2 tgcld tgpar' off ∧
- ∀ d tr', tree_equal d tr2 tr' → disabled_in_practice tr' tgcld tgpar' off.
- Proof.
- intros Hunq1 Hwf1 Hwf2 Hdip.
- inversion Hdip as [itw incl Hrel Hlu Hperm].
- rewrite /rel_dec in Hrel. destruct decide as [HPCo|?]; try done.
- destruct (trees_equal_decide_disabled_in_practice tr2 tgcld off) as [(tgp&itp&Hlup&Hdisp&HPC&Hothers)|HR].
- 1: done.
- { eapply contains_child. 1: done. eapply Hlu. }
- 2: { exfalso. eapply HR. 1: exact Hlu. 1: done. done. }
- exists tgp. split_and!.
- { econstructor. 2: exact Hlup. 2: done. rewrite /rel_dec decide_True //. }
- intros d tr1 (Heq1&Heq2&Heq3).
- destruct (Heq3 tgp) as (itp'&itp2&Hitp'&Hitp2&Heq).
- 1: eapply Hlup.
- assert (itp = itp') as <- by by eapply tree_lookup_unique.
- specialize (Heq off) as (Hprot&Heq).
- inversion Heq as [pp1 X1 HH|ini1 confl1 confl2 HprotX HP1 HP2 HeqX1 HeqX2|ini1 confl1 confl2 HnoProt HeqX1 HeqX2|p1 p2 HP1 HP2 HeqX1 HeqX2|wit_tg lp1 lp2 Hdip1 Hdip2 HiniX HeqX1 HeqX2|ini1 confl1 confl2 wit_tg HF1 HeqX1 HeqX2|p1 p2 ini Hd HeqX1 HeqX2]; simplify_eq.
- - econstructor. 2: exact Hitp2.
- 1: rewrite -Heq2 /rel_dec decide_True //.
- rewrite -HH -Hprot.
- eapply tree_equal_transfer_is_disabled. 1-3: eassumption. 2: eapply tree_equal_sym; done. done.
- - rewrite -HeqX1 in Hdisp.
- econstructor. 2: exact Hitp2.
- 1: rewrite -Heq2 /rel_dec decide_True //.
- inversion Hdisp as [|lp prot HH1 HH2 HH3]; simplify_eq.
- rewrite -HeqX2 -Hprot. econstructor 2.
- eapply tree_equal_transfer_pseudo_disabled in HH1. 2-4: done. 2: by eapply tree_equal_sym.
- by eapply conflicted_transfer_pseudo_disabled.
- - rewrite -HeqX1 in Hdisp.
- econstructor. 2: exact Hitp2.
- 1: rewrite -Heq2 /rel_dec decide_True //.
- inversion Hdisp as [|lp prot HH1 HH2 HH3]; simplify_eq.
- rewrite -HeqX2 -Hprot. econstructor 2.
- eapply tree_equal_transfer_pseudo_disabled in HH1. 2-4: done. 2: by eapply tree_equal_sym.
- by eapply conflicted_transfer_pseudo_disabled.
- - econstructor. 2: exact Hitp2.
- 1: rewrite -Heq2 /rel_dec decide_True //.
- rewrite -HeqX2. econstructor 2. rewrite -Hprot. done.
- - inversion Hdip2 as [itwF incl H1 H2 H3].
- inversion Hdip1 as [itwF' incl' H1' H2' H3'].
- assert (incl = incl') as <-.
- { rewrite Heq2 H1 in H1'. by simplify_eq. }
- rewrite /rel_dec in H1'. destruct decide as [HPCF|] in H1'; last done.
- clear H1'. destruct HPCF as [<-|Hne].
- 1: { assert (itwF = itp2) as <- by by eapply tree_lookup_unique.
- econstructor. 2: exact Hitp2.
- 1: rewrite -Heq2 /rel_dec decide_True //. done. }
- exfalso. eapply Hothers. 2: exact Hne. 1: done. done.
- - rewrite -HeqX1 in Hdisp.
- econstructor. 2: exact Hitp2.
- 1: rewrite -Heq2 /rel_dec decide_True //.
- inversion Hdisp as [|lp prot HH1 HH2 HH3]; simplify_eq.
- rewrite -HeqX2 -Hprot. econstructor 2.
- eapply tree_equal_transfer_pseudo_disabled in HH1. 2-4: done. 2: by eapply tree_equal_sym.
- by eapply conflicted_transfer_pseudo_disabled.
- - rewrite -HeqX1 in Hdisp.
- econstructor. 2: exact Hitp2.
- 1: rewrite -Heq2 /rel_dec decide_True //.
- inversion Hdisp as [|lp prot HH1 HH2 HH3]; simplify_eq.
- 1: destruct d; inversion Hd; done.
- rewrite -HeqX2 -Hprot. econstructor 2.
- eapply tree_equal_transfer_pseudo_disabled in HH1. 2-4: done. 2: by eapply tree_equal_sym.
- eapply transfer_pseudo_disabled_notimm. 1: exact HH1. all: destruct d; inversion Hd; done.
- Qed.
-
- Lemma trees_equal_transfer_disabled_in_practice_twice {d1 d2 tr1 tr2 tr3 tgpar tgcld off} :
- (∀ tg, tree_contains tg tr2 → tree_unique tg tr2) →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- tree_equal d1 tr1 tr2 →
- tree_equal d2 tr2 tr3 →
- disabled_in_practice tr2 tgcld tgpar off →
- ∃ tgpar',
- disabled_in_practice tr1 tgcld tgpar' off ∧
- disabled_in_practice tr2 tgcld tgpar' off ∧
- disabled_in_practice tr3 tgcld tgpar' off.
- Proof.
- intros H1 Hu1 Hu2 H2%tree_equal_sym H3 Hdip.
- odestruct trees_equal_transfer_disabled_in_practice_many as (tg&Htg&Htg2).
- 1: exact H1. 1-2: done. 1: exact Hdip.
- exists tg. split_and!.
- - by eapply Htg2.
- - done.
- - eapply Htg2. done.
- Qed.
-
- Lemma trees_equal_transfer_frozen_in_practice_many {tr2 tgpar tgcld off} :
- (∀ tg, tree_contains tg tr2 → tree_unique tg tr2) →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- frozen_in_practice tr2 tgcld tgpar off →
- (frozen_in_practice tr2 tgcld tgpar off ∧
- (∀ d tr', tree_equal d tr2 tr' → ∃ p, parent_has_perm p tr' tgcld tgpar off ∧ (p = Frozen ∨ p = Active ∧ d = Forwards))) ∨
- (∃ tgpar', disabled_in_practice tr2 tgcld tgpar' off ∧
- ∀ d tr', tree_equal d tr2 tr' → disabled_in_practice tr' tgcld tgpar' off).
- Proof.
- intros Hunq1 Hwf1 Hwf2 Hdip.
- inversion Hdip as [itw incl Hrel Hlu Hperm Hinit].
- rewrite /rel_dec in Hrel. destruct decide as [HPCo|?]; try done.
- destruct (trees_equal_decide_disabled_in_practice tr2 tgcld off) as [(tgp&itp&Hlup&Hdisp&HPC&Hothers)|HR].
- 1: done.
- { eapply contains_child. 1: done. eapply Hlu. }
- - odestruct trees_equal_transfer_disabled_in_practice_many as (tg&Htg).
- 1: exact Hunq1. 1-2: done. 2: { right. exists tg. exact Htg. }
- econstructor. 3: done. 2: done. rewrite /rel_dec decide_True //.
- - left. split.
- 1: done.
- intros d tr1 (Heq1&Heq2&Heq3).
- destruct (Heq3 tgpar) as (itw'&itw2&Hitw'&Hitw2&Heq).
- 1: eapply Hlu.
- assert (itw = itw') as <- by by eapply tree_lookup_unique.
- assert (∃ p, item_lookup itw2 off = mkPerm PermInit p ∧ (p = Frozen ∨ p = Active ∧ d = Forwards)) as (p&Hitlu&Hp).
- { specialize (Heq off) as (HeqL1&HeqL2).
- inversion HeqL2 as [pp1|ini1 confl1 confl2 HprotX HP1 HP2 HeqX1 HeqX2|ini1 confl1 confl2 HnoProt HeqX1 HeqX2|lp1 lp2 Hdip1 Hdip2 HeqX1 HeqX2|wit_tg lp1 lp2 Hdip1 Hdip2 HiniX HeqX1 HeqX2|ini1 confl1 confl2 wit_tg HF1 HeqX1 HeqX2|p1 p2 ini Hd HeqX1 HeqX2]; simplify_eq.
- + exists Frozen; split; last tauto. destruct item_lookup; simpl in *; simplify_eq. done.
- + rewrite -HeqX1 // in Hperm.
- + rewrite -HeqX1 // in Hperm.
- + rewrite -HeqX1 // in Hinit.
- + exists Frozen; split; last tauto. inversion Hdip1 as [itw1' incl1 Hrel1 Hlu1 Hperm1].
- rewrite /rel_dec in Hrel1. destruct decide as [HPC1|?] in Hrel1; last done.
- eapply HR in Hperm1. 1: done. 1: done.
- eapply ParentChild_transitive. 2: eassumption. done.
- + rewrite -HeqX1 // in Hperm.
- + rewrite -HeqX1 /= in Hperm Hinit; subst ini.
- f_equal. destruct d; inversion Hd; simplify_eq.
- eexists; split; first done. by right. }
- exists p. split; last done. econstructor. 2: exact Hitw2.
- 1: rewrite -Heq2 /rel_dec decide_True //.
- all: by rewrite Hitlu.
- Qed.
-
- Lemma item_apply_access_effect_on_initialized
- {it it' l b kind rel range}
- (Acc : item_apply_access (maybe_non_children_only b (apply_access_perm kind)) C rel range it = Some it')
- : initialized (item_lookup it' l)
- = if decide (range'_contains range l)
- then most_init (initialized (item_lookup it l)) (requires_init rel)
- else initialized (item_lookup it l).
- Proof.
- unfold item_apply_access, permissions_apply_range' in Acc.
- rewrite bind_Some in Acc; destruct Acc as [iperm' [iperm'Spec Inj]].
- injection Inj; clear Inj; intros; subst.
- pose proof (mem_apply_range'_spec _ _ l _ _ iperm'Spec) as LocalSpec.
- case_match.
- 2: { rewrite /item_lookup /=. f_equal. f_equal. assumption. }
- destruct LocalSpec as [val [valSpec MaybeApply]].
- unfold item_lookup; simpl.
- rewrite valSpec; clear valSpec; simpl.
- (* Now it's time to actually unfold [maybe_non_children_only] and [apply_access_perm] where
- [initialized] *might* be modified. *)
- unfold maybe_non_children_only in MaybeApply. rewrite most_init_comm. case_match.
- - unfold nonchildren_only in MaybeApply. case_match.
- + simpl. case_match.
- * injection MaybeApply; intros; subst; reflexivity.
- * unfold apply_access_perm in MaybeApply.
- destruct (apply_access_perm_inner _ _ _ _); simpl in *; last congruence.
- destruct (if most_init _ _ then _ else _); simpl in MaybeApply; last congruence.
- injection MaybeApply; clear MaybeApply; intros; subst.
- simpl. rewrite most_init_noop. reflexivity.
- + unfold apply_access_perm in MaybeApply.
- destruct (apply_access_perm_inner _ _ _ _); simpl in *; last congruence.
- destruct (if most_init _ _ then _ else _); simpl in MaybeApply; last congruence.
- injection MaybeApply; clear MaybeApply; intros; subst.
- simpl. rewrite most_init_absorb. reflexivity.
- - unfold apply_access_perm in MaybeApply.
- destruct (apply_access_perm_inner _ _ _ _); simpl in *; last congruence.
- destruct (if most_init _ _ then _ else _); simpl in MaybeApply; last congruence.
- injection MaybeApply; clear MaybeApply; intros; subst.
- simpl. rewrite most_init_comm. reflexivity.
- Qed.
-
- Lemma perm_eq_up_to_C_preserved_by_access (b:bool)
- {d tr1 tr1' tr2 tr2' it1 it1' it2 it2' tg l acc_tg kind range} (Hunq : wf_tree tr2)
- (SameProt : iprot it1 = iprot it2)
- (SameTg : itag it1 = itag it2) (* note: redundant *)
- (SameRel : forall tg tg', rel_dec tr1 tg tg' = rel_dec tr2 tg tg')
- (Unq1 : wf_tree tr1)
- (Unq2 : wf_tree tr2)
- :
- parents_more_active tr1 →
- no_active_cousins C tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- tree_equal d tr1 tr2 →
- perm_eq_up_to_C tr1 tr2 tg l (iprot it1) d (item_lookup it1 l) (item_lookup it2 l) ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1 = Some tr1' ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr2 = Some tr2' ->
- tree_lookup tr1 tg it1 ->
- tree_lookup tr1' tg it1' ->
- tree_lookup tr2 tg it2 ->
- tree_lookup tr2' tg it2' ->
- tree_contains acc_tg tr2 ->
- tree_contains acc_tg tr1 ->
- item_apply_access (maybe_non_children_only b (apply_access_perm kind)) C (rel_dec tr1 acc_tg (itag it1)) range it1 = Some it1' ->
- item_apply_access (maybe_non_children_only b (apply_access_perm kind)) C (rel_dec tr2 acc_tg (itag it2)) range it2 = Some it2' ->
- perm_eq_up_to_C tr1' tr2' tg l (iprot it1') d (item_lookup it1' l) (item_lookup it2' l).
- Proof.
- intros Hpma1 Hnac1 Hpma2 Hnac2 HeqTree EqC Acc1 Acc2 Lookup1 Lookup1' Lookup2 Lookup2' Hacctg1 Hacctg2 ItAcc1 ItAcc2.
- inversion EqC as [
- p pSpec Equal
- |ini confl1 confl2 Prot Confl1 Confl2 itLookup1 itLookup2
- |ini confl1 confl2 NoProt itLookup1 itLookup2
- |p1 p2 Confl1 Confl2 itLookup1 itLookup2
- |????? SameInit
- |ini confl1 confl2 witness_tg Hfrz itLookup1 itLookup2
- |p1 p2 ini H1 itLookup1 itLookup2
- ].
- - (* reflexive case *)
- rewrite bind_Some in ItAcc1; destruct ItAcc1 as [perms1' [PermsAcc1 it1'Spec]].
- injection it1'Spec; intros; subst; clear it1'Spec.
- rewrite bind_Some in ItAcc2; destruct ItAcc2 as [perms2' [PermsAcc2 it2'Spec]].
- injection it2'Spec; intros; subst; clear it2'Spec.
- simpl.
- pose proof (mem_apply_range'_spec _ _ l _ _ PermsAcc1) as Perms1'Spec.
- pose proof (mem_apply_range'_spec _ _ l _ _ PermsAcc2) as Perms2'Spec.
- destruct (decide _).
- + (* within range *)
- destruct Perms1'Spec as [p1 [LookupSome1' PermAcc1]].
- destruct Perms2'Spec as [p2 [LookupSome2' PermAcc2]].
- rewrite /item_lookup LookupSome1' LookupSome2' /=.
- rewrite /item_lookup in Equal.
- rewrite Equal SameRel SameProt SameTg in PermAcc1.
- rewrite PermAcc1 in PermAcc2.
- injection PermAcc2; intros; subst. constructor.
- + (* outside range *)
- rewrite /item_lookup in Equal.
- rewrite /item_lookup /= Perms1'Spec Perms2'Spec Equal.
- constructor.
- - (* The permissions are pseudo-conflicted, this restricts the possible accesses. *)
- rewrite SameRel SameTg in ItAcc1.
- rewrite bind_Some in ItAcc1; destruct ItAcc1 as [perms1' [perms1'Spec it1'Spec]].
- rewrite bind_Some in ItAcc2; destruct ItAcc2 as [perms2' [perms2'Spec it2'Spec]].
- injection it1'Spec; intros; subst; clear it1'Spec.
- injection it2'Spec; intros; subst; clear it2'Spec.
- rewrite /item_lookup /=.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms1'Spec) as perm1'Spec; clear perms1'Spec.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms2'Spec) as perm2'Spec; clear perms2'Spec.
- (* Now we do the case analysis of the access that occured *)
- (* First off, if we're out of range then we can take the exact same witness. *)
- destruct (decide (range'_contains range l)).
- 2: {
- rewrite perm1'Spec.
- rewrite perm2'Spec.
- rewrite /item_lookup in itLookup1, itLookup2.
- rewrite -itLookup1 -itLookup2.
- econstructor.
- + assumption.
- + inversion Confl1; subst.
- * constructor.
- * eapply access_preserves_pseudo_conflicted_activable; eassumption.
- + inversion Confl2; subst.
- * constructor.
- * eapply access_preserves_pseudo_conflicted_activable; eassumption.
- }
- (* Now we're within range *)
- destruct perm1'Spec as [perm1' [perm1'Lookup perm1'Spec]].
- destruct perm2'Spec as [perm2' [perm2'Lookup perm2'Spec]].
- rewrite perm1'Lookup perm2'Lookup; clear perm1'Lookup perm2'Lookup.
- simpl.
- rewrite bool_decide_eq_true_2 in perm1'Spec; [|assumption].
- rewrite bool_decide_eq_true_2 in perm2'Spec; [|rewrite -SameProt; assumption].
- rewrite /item_lookup in itLookup1, itLookup2.
- rewrite -itLookup1 in perm1'Spec; clear itLookup1.
- rewrite -itLookup2 in perm2'Spec; clear itLookup2.
- destruct (maybe_non_children_only_effect_or_nop b (apply_access_perm kind) (rel_dec tr2 acc_tg (itag it2))) as [Heff|Heff].
- all: rewrite !Heff /= in perm1'Spec,perm2'Spec.
- 2: { simplify_eq. econstructor; first done. all: by eapply access_preserves_pseudo_conflicted. }
- (* Next we need to unwrap the apply_access_perm to get to apply_access_perm_inner *)
- rewrite bind_Some in perm1'Spec; destruct perm1'Spec as [perm1 [perm1Spec perm1'Spec]].
- rewrite bind_Some in perm1'Spec; destruct perm1'Spec as [tmp1 [tmp1Spec perm1'Spec]].
- injection perm1'Spec; simpl; intros; subst; clear perm1'Spec.
- rewrite bind_Some in perm2'Spec; destruct perm2'Spec as [perm2 [perm2Spec perm2'Spec]].
- rewrite bind_Some in perm2'Spec; destruct perm2'Spec as [tmp2 [tmp2Spec perm2'Spec]].
- injection perm2'Spec; simpl; intros; subst; clear perm2'Spec.
- simpl in *.
- (* We can finally start the big case analysis at the level of the state machine *)
- destruct (most_init _), perm1, perm2; try congruence.
- all: injection tmp1Spec; intros; subst; clear tmp1Spec.
- all: injection tmp2Spec; intros; subst; clear tmp2Spec.
- all: destruct kind, (rel_dec _ _ _) eqn:relation, confl1; simpl in *; try discriminate.
- all: destruct confl2; simpl in *; try discriminate.
- all: try (injection perm1Spec; intros; subst); clear perm1Spec.
- all: try (injection perm2Spec; intros; subst); clear perm2Spec.
- all: try constructor; auto.
- all: try constructor.
- (* Now they are all ResActivable and we need to show that the cousin is still a witness.
- See the above lemma for exactly that. *)
- all: eapply access_preserves_pseudo_conflicted_activable; eassumption.
- - (* The permissions are formerly pseudo-conflicted, but the difference should no longer matter now. *)
- rewrite SameRel SameTg in ItAcc1.
- rewrite bind_Some in ItAcc1; destruct ItAcc1 as [perms1' [perms1'Spec it1'Spec]].
- rewrite bind_Some in ItAcc2; destruct ItAcc2 as [perms2' [perms2'Spec it2'Spec]].
- injection it1'Spec; intros; subst; clear it1'Spec.
- injection it2'Spec; intros; subst; clear it2'Spec.
- rewrite /item_lookup /=.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms1'Spec) as perm1'Spec; clear perms1'Spec.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms2'Spec) as perm2'Spec; clear perms2'Spec.
- (* Now we do the case analysis of the access that occured *)
- (* First off, if we're out of range then we can take the exact same witness. *)
- destruct (decide (range'_contains range l)).
- 2: {
- rewrite perm1'Spec.
- rewrite perm2'Spec.
- rewrite /item_lookup in itLookup1, itLookup2.
- rewrite -itLookup1 -itLookup2.
- econstructor 3.
- assumption.
- }
- (* Now we're within range *)
- destruct perm1'Spec as [perm1' [perm1'Lookup perm1'Spec]].
- destruct perm2'Spec as [perm2' [perm2'Lookup perm2'Spec]].
- rewrite perm1'Lookup perm2'Lookup; clear perm1'Lookup perm2'Lookup.
- simpl.
- rewrite bool_decide_eq_false_2 in perm1'Spec; [|assumption].
- rewrite bool_decide_eq_false_2 in perm2'Spec; [|rewrite -SameProt; assumption].
- rewrite /item_lookup in itLookup1, itLookup2.
- rewrite -itLookup1 in perm1'Spec; clear itLookup1.
- rewrite -itLookup2 in perm2'Spec; clear itLookup2.
- destruct (maybe_non_children_only_effect_or_nop b (apply_access_perm kind) (rel_dec tr2 acc_tg (itag it2))) as [Heff|Heff].
- all: rewrite !Heff /= in perm1'Spec,perm2'Spec.
- 2: { simplify_eq. econstructor; first done. all: by eapply access_preserves_pseudo_conflicted. }
- (* Next we need to unwrap the apply_access_perm to get to apply_access_perm_inner *)
- rewrite bind_Some in perm1'Spec; destruct perm1'Spec as [perm1 [perm1Spec perm1'Spec]].
- rewrite bind_Some in perm1'Spec; destruct perm1'Spec as [tmp1 [tmp1Spec perm1'Spec]].
- injection perm1'Spec; simpl; intros; subst; clear perm1'Spec.
- rewrite bind_Some in perm2'Spec; destruct perm2'Spec as [perm2 [perm2Spec perm2'Spec]].
- rewrite bind_Some in perm2'Spec; destruct perm2'Spec as [tmp2 [tmp2Spec perm2'Spec]].
- injection perm2'Spec; simpl; intros; subst; clear perm2'Spec.
- simpl in *.
- (* We can finally start the big case analysis at the level of the state machine *)
- edestruct (most_init ini _), perm1, perm2; try congruence.
- all: injection tmp1Spec; intros; subst; clear tmp1Spec.
- all: injection tmp2Spec; intros; subst; clear tmp2Spec.
- all: destruct kind, (rel_dec _ _ _) eqn:relation, confl1; simpl in *; try discriminate.
- all: destruct confl2; simpl in *; try discriminate.
- all: try (injection perm1Spec; intros; subst); clear perm1Spec.
- all: try (injection perm2Spec; intros; subst); clear perm2Spec.
- all: try by econstructor 1.
- all: try by econstructor 3.
- (* pseudo-disabled *)
- - rewrite SameRel SameTg in ItAcc1.
- rewrite bind_Some in ItAcc1; destruct ItAcc1 as [perms1' [perms1'Spec it1'Spec]].
- rewrite bind_Some in ItAcc2; destruct ItAcc2 as [perms2' [perms2'Spec it2'Spec]].
- injection it1'Spec; intros; subst; clear it1'Spec.
- injection it2'Spec; intros; subst; clear it2'Spec.
- rewrite /item_lookup /=.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms1'Spec) as perm1'Spec; clear perms1'Spec.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms2'Spec) as perm2'Spec; clear perms2'Spec.
- (* Now we do the case analysis of the access that occured *)
- (* First off, if we're out of range then we can take the exact same witness. *)
- destruct (decide (range'_contains range l)).
- 2: {
- rewrite perm1'Spec.
- rewrite perm2'Spec.
- rewrite /item_lookup in itLookup1, itLookup2.
- rewrite -itLookup1 -itLookup2.
- econstructor 4.
- all: eapply access_preserves_pseudo_disabled; first done.
- all: done.
- }
- (* Now we're within range *)
- destruct perm1'Spec as [perm1' [perm1'Lookup perm1'Spec]].
- destruct perm2'Spec as [perm2' [perm2'Lookup perm2'Spec]].
- rewrite perm1'Lookup perm2'Lookup; clear perm1'Lookup perm2'Lookup.
- simpl.
- rewrite /item_lookup in itLookup1, itLookup2.
- rewrite -itLookup1 in perm1'Spec; clear itLookup1.
- rewrite -itLookup2 in perm2'Spec; clear itLookup2.
- edestruct (maybe_non_children_only_effect_or_nop b (apply_access_perm kind) (rel_dec tr2 acc_tg (itag it2))) as [Heff|Heff].
- all: rewrite !Heff /= in perm1'Spec,perm2'Spec. all: clear Heff.
- 2: { injection perm1'Spec as <-. injection perm2'Spec as <-.
- econstructor 4.
- all: eapply access_preserves_pseudo_disabled; first done.
- all: done. }
- (* Next we need to unwrap the apply_access_perm to get to apply_access_perm_inner *)
- rewrite bind_Some in perm1'Spec; destruct perm1'Spec as [perm1 [perm1Spec perm1'Spec]].
- rewrite bind_Some in perm2'Spec; destruct perm2'Spec as [perm2 [perm2Spec perm2'Spec]].
- assert (¬ ParentChildIn (itag it2) acc_tg tr2) as HnPC.
- { intros HnPC. clear perm1'Spec perm1Spec.
- inversion Confl2 as [|tg_cs it_cs X1 X2 H1 H2 H3 H4 H5]; simplify_eq.
- 1: { rewrite /apply_access_perm_inner /= in perm2Spec.
- rewrite /rel_dec decide_True // in perm2Spec. by destruct kind. }
- destruct (apply_access_spec_per_node (proj1 H2) (proj2 H2) Acc2)
- as (cous' & cous'_spec & cous'_ex & cous'_det).
- symmetry in cous'_spec.
- rewrite bind_Some in cous'_spec.
- destruct cous'_spec as (perms' & perms'_spec & cous'_build).
- injection cous'_build; intros; subst; clear cous'_build.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms'_spec) as effect_at_l.
- rewrite decide_True // in effect_at_l.
- destruct effect_at_l as (perm' & perm'_lookup & perm'_spec).
- rewrite /item_lookup in H4. rewrite H4 in perm'_spec.
- rewrite bool_decide_true in perm'_spec. 2: done.
- assert (tg_cs = itag it_cs) as -> by (symmetry; by eapply tree_lookup_correct_tag).
- assert (tg = itag it2) as -> by (symmetry; by eapply tree_lookup_correct_tag).
- rewrite /rel_dec decide_False in perm'_spec.
- 2: { intros Hx. eapply cousins_have_disjoint_children. 4: eassumption. 4-5: done.
- all: eapply Hunq. 1: done. 1: eapply Lookup2. 1: eapply H2. }
- rewrite decide_False in perm'_spec.
- 2: { intros Hx. rewrite /rel_dec in H1.
- destruct decide as [|HH1] in H1; first done.
- destruct decide as [|HH2] in H1; first done.
- eapply HH2. eapply ParentChild_transitive. 2: exact Hx. 1: done. }
- rewrite maybe_non_children_only_no_effect in perm'_spec. 2: done.
- destruct kind in perm'_spec; cbv in perm'_spec; done. }
- rewrite /rel_dec decide_False // /= in perm2'Spec. injection perm2'Spec as <-.
- rewrite /rel_dec decide_False // /= in perm1'Spec. injection perm1'Spec as <-.
- rewrite /rel_dec decide_False // /= in perm2Spec.
- rewrite /rel_dec decide_False // /= in perm1Spec.
- econstructor 4; eapply access_preserves_pseudo_disabled. 2,4: done.
- + inversion Confl1 as [|X1 X2 X3 X4 X5 X6 X7 X8 H]; simplify_eq.
- 1: destruct kind, bool_decide in perm1Spec; cbv in perm1Spec; injection perm1Spec as <-; econstructor 1.
- econstructor 2. 1-4: done.
- intros ->.
- destruct (bool_decide (protector_is_active (iprot it1) C)), kind, p1 as [[]| | | |]; try discriminate perm1Spec.
- all: done.
- + inversion Confl2 as [|X1 X2 X3 X4 X5 X6 X7 X8 H]; simplify_eq.
- 1: destruct kind, bool_decide in perm1Spec; cbv in perm2Spec; injection perm2Spec as <-; econstructor 1.
- econstructor 2. 1-4: done.
- intros ->.
- destruct (bool_decide (protector_is_active (iprot it2) C)), kind, p2 as [[]| | | |]; try discriminate perm2Spec.
- all: done.
- - econstructor.
- + eapply disabled_in_practice_tree_apply_access_irreversible; last eassumption. 2-3: done.
- eassumption.
- + eapply disabled_in_practice_tree_apply_access_irreversible; last eassumption. 2-3: done.
- eassumption.
- + rewrite (item_apply_access_effect_on_initialized ItAcc1).
- rewrite (item_apply_access_effect_on_initialized ItAcc2).
- rewrite SameInit.
- case_match; last reflexivity.
- f_equal. f_equal. rewrite SameTg. apply SameRel.
- - (* Proof idea:
- each item is Reserved. Therefore it can:
- - get a child read: nothing happens
- - get a child write: it's UB, since the parent is frozen
- - get a foreign read: the conflictedness might change but that's OK, this case is precisely for that
- - get a foreign write: it's either UB or we remain, depending on interior mutability.
- + however, since such a write must disable our parent, it should not matter that IM is the same here.
- But reasoning about this is complicated (because of maybe_nonchildren_only) so let's just not. *)
- (* We're frozen in practice *)
- pose trd := (match d with Forwards => tr1 | Backwards => tr2 end). fold trd in Hfrz.
- pose trd' := (match d with Forwards => tr2 | Backwards => tr1 end).
- eapply trees_equal_transfer_frozen_in_practice_many in Hfrz as [(Hfrz&Hfrzo)|(tdis&Htdis&Htdiso)].
- 3-5: by destruct d.
- 2: { econstructor.
- + eapply disabled_in_practice_tree_apply_access_irreversible; last eassumption. 2-3: done.
- destruct d; try done. eapply Htdiso, tree_equal_sym, HeqTree.
- + eapply disabled_in_practice_tree_apply_access_irreversible; last eassumption. 2-3: done.
- destruct d; try done. eapply Htdiso, HeqTree.
- + rewrite (item_apply_access_effect_on_initialized ItAcc1).
- rewrite (item_apply_access_effect_on_initialized ItAcc2).
- rewrite -itLookup1 -itLookup2 /=.
- case_match; last reflexivity.
- f_equal. f_equal. rewrite SameTg. apply SameRel. }
- destruct (Hfrzo Forwards trd') as (p'&Hfrzalmost&Hfrz').
- 1: destruct d; first done. 1: eapply tree_equal_sym in HeqTree; exact HeqTree.
- rewrite SameRel SameTg in ItAcc1.
- rewrite bind_Some in ItAcc1; destruct ItAcc1 as [perms1' [perms1'Spec it1'Spec]].
- rewrite bind_Some in ItAcc2; destruct ItAcc2 as [perms2' [perms2'Spec it2'Spec]].
- injection it1'Spec; intros; subst; clear it1'Spec.
- injection it2'Spec; intros; subst; clear it2'Spec.
- rewrite /item_lookup /=.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms1'Spec) as perm1'Spec; clear perms1'Spec.
- pose proof (mem_apply_range'_spec _ _ l _ _ perms2'Spec) as perm2'Spec; clear perms2'Spec.
- (* Now we do the case analysis of the access that occured *)
- (* First off, if we're out of range then we can take the exact same witness. *)
- destruct (decide (range'_contains range l)) eqn:Hrangedec.
- 2: {
- rewrite perm1'Spec.
- rewrite perm2'Spec.
- rewrite /item_lookup in itLookup1, itLookup2.
- rewrite -itLookup1 -itLookup2.
- econstructor 6; destruct d.
- - eapply frozen_in_practice_tree_apply_access_irreversible in Hfrz. 4: exact Acc1. 2-3: done.
- destruct Hfrz as [(Hf&HX)|(Hf&HX)]; first done.
- rewrite /becomes_disabled Hrangedec in HX. done.
- - eapply frozen_in_practice_tree_apply_access_irreversible in Hfrz. 4: exact Acc2. 2-3: done.
- destruct Hfrz as [(Hf&HX)|(Hf&HX)]; first done.
- rewrite /becomes_disabled Hrangedec in HX. done.
- }
- (* Now we're within range *)
- destruct perm1'Spec as [perm1' [perm1'Lookup perm1'Spec]].
- destruct perm2'Spec as [perm2' [perm2'Lookup perm2'Spec]].
- rewrite perm1'Lookup perm2'Lookup; clear perm1'Lookup perm2'Lookup.
- simpl.
- rewrite /item_lookup in itLookup1, itLookup2.
- rewrite -itLookup1 in perm1'Spec; clear itLookup1.
- rewrite -itLookup2 in perm2'Spec; clear itLookup2.
- assert (∃ p, parent_has_perm p (match d with Backwards => tr1 | _ => tr2 end) tg witness_tg l ∧ (p = Frozen ∨ p = Active)) as (pt&Htrans&Hptrans).
- { destruct Hfrz' as [ -> |(->&_)]; eexists; (split; first done). all: tauto. }
- eapply @frozen_in_practice_tree_apply_access_irreversible with (tr' := match d with Forwards => _ | _ => _ end) in Hfrz; last (destruct d; [exact Acc1|exact Acc2]). 2-3: by destruct d.
- destruct Hfrz as [(H1&HX)|(H1&HX)].
- all: edestruct (maybe_non_children_only_effect_or_nop b (apply_access_perm kind) (rel_dec tr2 acc_tg (itag it2))) as [Heff|Heff].
- all: rewrite !Heff /= in perm1'Spec,perm2'Spec; clear Heff.
- 2: { simplify_eq. econstructor 6; eassumption. }
- 3: { eapply @parent_has_perm_similarly_disabled with (tr' := match d with Forwards => tr2' | _ => tr1' end) in Htrans.
- 4: by destruct d. 4: by destruct d. 3: destruct d; done.
- 3: { rewrite /becomes_disabled in HX|-*. destruct d.
- 1: rewrite -SameRel //. rewrite SameRel //. }
- 2: destruct Hptrans; by simplify_eq.
- econstructor 5. 3: by simplify_eq.
- all: eapply parent_has_disabled_perm_is_pseudo_disabled; by destruct d. }
- (* Next we need to unwrap the apply_access_perm to get to apply_access_perm_inner *)
- all: rewrite bind_Some in perm1'Spec; destruct perm1'Spec as [perm1 [perm1Spec perm1'Spec]].
- all: rewrite bind_Some in perm1'Spec; destruct perm1'Spec as [tmp1 [tmp1Spec perm1'Spec]].
- all: injection perm1'Spec; simpl; intros; subst; clear perm1'Spec.
- all: rewrite bind_Some in perm2'Spec; destruct perm2'Spec as [perm2 [perm2Spec perm2'Spec]].
- all: rewrite bind_Some in perm2'Spec; destruct perm2'Spec as [tmp2 [tmp2Spec perm2'Spec]].
- all: injection perm2'Spec; simpl; intros; subst; clear perm2'Spec.
- 2: { eapply @parent_has_perm_similarly_disabled with (tr' := match d with Forwards => tr2' | _ => tr1' end) in Htrans.
- 4: by destruct d. 4: by destruct d. 3: destruct d; done.
- 3: { rewrite /becomes_disabled in HX|-*. destruct d.
- 1: rewrite -SameRel //. rewrite SameRel //. }
- 2: destruct Hptrans; by simplify_eq.
- econstructor 5. 3: by simplify_eq.
- all: eapply parent_has_disabled_perm_is_pseudo_disabled; by destruct d. }
- simpl in *. rewrite -SameProt in tmp2Spec,perm2Spec.
- (* We can finally start the big case analysis at the level of the state machine *)
- edestruct (most_init ini _), perm1, perm2, (bool_decide (protector_is_active (iprot it1) C)); try congruence.
- all: injection tmp1Spec; intros; subst; clear tmp1Spec.
- all: injection tmp2Spec; intros; subst; clear tmp2Spec.
- all: destruct kind, (rel_dec _ _ _) eqn:relation, confl1; simpl in *; try discriminate.
- all: destruct confl2; simpl in *; try discriminate.
- all: try (injection perm1Spec; intros; subst); clear perm1Spec.
- all: try (injection perm2Spec; intros; subst); clear perm2Spec.
- all: try by econstructor 1.
- all: try by econstructor 6.
- - (* asymmetric *)
- rewrite bind_Some in ItAcc1; destruct ItAcc1 as [perms1' [PermsAcc1 it1'Spec]].
- injection it1'Spec; intros; subst; clear it1'Spec.
- rewrite bind_Some in ItAcc2; destruct ItAcc2 as [perms2' [PermsAcc2 it2'Spec]].
- injection it2'Spec; intros; subst; clear it2'Spec.
- simpl.
- pose proof (mem_apply_range'_spec _ _ l _ _ PermsAcc1) as Perms1'Spec.
- pose proof (mem_apply_range'_spec _ _ l _ _ PermsAcc2) as Perms2'Spec.
- rewrite /item_lookup /= in itLookup1,itLookup2.
- destruct (decide _); last first.
- { rewrite /item_lookup /= Perms1'Spec Perms2'Spec -itLookup1 -itLookup2.
- econstructor 7. done. }
- destruct Perms1'Spec as [p1' [LookupSome1' PermAcc1]].
- destruct Perms2'Spec as [p2' [LookupSome2' PermAcc2]].
- rewrite -itLookup1 in PermAcc1.
- rewrite -itLookup2 in PermAcc2.
- rewrite -SameProt -SameTg -SameRel in PermAcc2.
- edestruct maybe_non_children_only_effect_or_nop as [Heq|Heq]; erewrite Heq in PermAcc1, PermAcc2; clear Heq.
- 2: { injection PermAcc1 as <-; injection PermAcc2 as <-.
- rewrite /item_lookup /= LookupSome1' LookupSome2' /=. by econstructor 7. }
- destruct ini, d, kind, (rel_dec tr1 acc_tg (itag it1)); simpl in *.
- all: inversion H1 as [P|P]; subst P p1 p2; [
- rewrite bool_decide_eq_false_2 // in PermAcc1,PermAcc2
- | rewrite bool_decide_eq_true_2 // in PermAcc1,PermAcc2].
- all: rewrite /apply_access_perm /apply_access_perm_inner /= in PermAcc1,PermAcc2;
- try discriminate PermAcc1; try discriminate PermAcc2;
- injection PermAcc1 as <-; injection PermAcc2 as <-.
- all: rewrite /item_lookup /= LookupSome1' LookupSome2' /=.
- all: try econstructor 1.
- all: econstructor 7; simpl; econstructor; done.
- Qed.
-
- Lemma item_eq_up_to_C_preserved_by_access (b : bool)
- {d tr1 tr1' tr2 tr2' it1 it1' it2 it2' tg acc_tg kind range} (Hunq1 : wf_tree tr1) (Hunq2 : wf_tree tr2)
- (SameTg : itag it1 = itag it2)
- (SameRel : forall tg tg', rel_dec tr1 tg tg' = rel_dec tr2 tg tg')
- :
- parents_more_active tr1 →
- no_active_cousins C tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- tree_equal d tr1 tr2 →
- item_eq_up_to_C tr1 tr2 tg d it1 it2 ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1 = Some tr1' ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr2 = Some tr2' ->
- tree_lookup tr1 tg it1 ->
- tree_lookup tr1' tg it1' ->
- tree_lookup tr2 tg it2 ->
- tree_lookup tr2' tg it2' ->
- tree_contains acc_tg tr1 ->
- tree_contains acc_tg tr2 ->
- item_apply_access (maybe_non_children_only b (apply_access_perm kind)) C (rel_dec tr1 acc_tg (itag it1)) range it1 = Some it1' ->
- item_apply_access (maybe_non_children_only b (apply_access_perm kind)) C (rel_dec tr2 acc_tg (itag it2)) range it2 = Some it2' ->
- item_eq_up_to_C tr1' tr2' tg d it1' it2'.
- Proof.
- intros ????? EqC Acc1 Acc2 Lookup1 Lookup1' Lookup2 Lookup2' AccTg1 AccTg2 ItAcc1 ItAcc2.
- econstructor.
- - rewrite <- (proj1 (proj2 (item_apply_access_preserves_metadata _ _ ItAcc1))).
- rewrite <- (proj1 (proj2 (item_apply_access_preserves_metadata _ _ ItAcc2))).
- apply EqC. assumption.
- - eapply perm_eq_up_to_C_preserved_by_access.
- + done.
- + apply EqC. assumption.
- + apply SameTg.
- + apply SameRel.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + apply EqC.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- + eassumption.
- Qed.
-
- Lemma tree_equal_preserved_by_access_maybe_nonchildren_only (b : bool)
- {d tr1 tr2 tr1' tr2' kind acc_tg range}
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- :
- parents_more_active tr1 →
- no_active_cousins C tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- tree_equal d tr1 tr2 ->
- tree_contains acc_tg tr1 ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr1 = Some tr1' ->
- tree_apply_access (maybe_non_children_only b (apply_access_perm kind)) C acc_tg range tr2 = Some tr2' ->
- tree_equal d tr1' tr2'.
- Proof.
- intros ???? Heq. pose proof Heq as [SameTg [SameRel EqC]]. intros ExAcc Acc1 Acc2.
- split; [|split].
- - intros tg.
- rewrite <- (access_preserves_tags Acc1).
- rewrite <- (access_preserves_tags Acc2).
- apply SameTg.
- - intros tg tg'.
- rewrite <- (access_same_rel_dec Acc1).
- rewrite <- (access_same_rel_dec Acc2).
- apply SameRel.
- - intros tg Ex1'.
- pose proof (proj2 (access_preserves_tags Acc1) Ex1') as Ex1.
- pose proof (proj1 (SameTg _) Ex1) as Ex2.
- pose proof (proj1 (access_preserves_tags Acc2) Ex2) as Ex2'.
- destruct (EqC tg Ex1) as [it1 [it2 [Lookup1 [Lookup2 EqC12]]]].
- destruct (apply_access_spec_per_node Ex1 (proj2 Lookup1) Acc1) as [it1' [it1'Spec [_ Lookup1']]].
- destruct (apply_access_spec_per_node Ex2 (proj2 Lookup2) Acc2) as [it2' [it2'Spec [_ Lookup2']]].
- exists it1'. exists it2'.
- split; [|split].
- + split; assumption.
- + split; assumption.
- + eapply item_eq_up_to_C_preserved_by_access.
- * exact GloballyUnique1.
- * exact GloballyUnique2.
- * erewrite tree_lookup_correct_tag; [|exact Lookup1].
- erewrite tree_lookup_correct_tag; [|exact Lookup2].
- reflexivity.
- * eassumption.
- * eassumption.
- * eassumption.
- * eassumption.
- * eassumption.
- * eassumption.
- * eassumption.
- * eassumption.
- * eassumption.
- * eassumption.
- * split; eassumption.
- * eassumption.
- * split; eassumption.
- * eassumption.
- * by eapply SameTg.
- * symmetry; assumption.
- * symmetry; assumption.
- Qed.
-
- Lemma tree_equal_preserved_by_memory_access
- {d tr1 tr2 tr1' tr2' kind acc_tg range}
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- :
- parents_more_active tr1 →
- no_active_cousins C tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- tree_equal d tr1 tr2 ->
- tree_contains acc_tg tr1 ->
- memory_access kind C acc_tg range tr1 = Some tr1' ->
- memory_access kind C acc_tg range tr2 = Some tr2' ->
- tree_equal d tr1' tr2'.
- Proof.
- by eapply (tree_equal_preserved_by_access_maybe_nonchildren_only false).
- Qed.
-
- Lemma tree_equal_preserved_by_memory_access_nonchildren_only
- {d tr1 tr2 tr1' tr2' kind acc_tg range}
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- :
- parents_more_active tr1 →
- no_active_cousins C tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- tree_equal d tr1 tr2 ->
- tree_contains acc_tg tr1 ->
- memory_access_nonchildren_only kind C acc_tg range tr1 = Some tr1' ->
- memory_access_nonchildren_only kind C acc_tg range tr2 = Some tr2' ->
- tree_equal d tr1' tr2'.
- Proof.
- by eapply (tree_equal_preserved_by_access_maybe_nonchildren_only true).
- Qed.
-
- Lemma tree_equal_memory_deallocate
- {d tr1 tr2 tr1' tr2' acc_tg range}
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- :
- parents_more_active tr1 →
- no_active_cousins C tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- tree_equal d tr1 tr2 ->
- tree_contains acc_tg tr1 ->
- memory_deallocate C acc_tg range tr1 = Some tr1' ->
- memory_deallocate C acc_tg range tr2 = Some tr2' ->
- tree_equal d tr1' tr2'.
- Proof.
- intros ???? Heq Hcontains (pw1&Hacc1&<-%join_map_id_is_Some_identical)%bind_Some
- (pw2&Hacc2&<-%join_map_id_is_Some_identical)%bind_Some.
- by eapply (@tree_equal_preserved_by_memory_access d tr1 tr2).
- Qed.
-
- Lemma is_Some_if {A} (P : bool) (s:A) : is_Some (if P then Some s else None) → P.
- Proof.
- destruct P; first done.
- intros (x&[=]).
- Qed.
-
- Lemma is_Some_if_neg {A} (P : bool) (s:A) : is_Some (if P then None else Some s) → P = false.
- Proof.
- destruct P; last done.
- intros (x&[=]).
- Qed.
-
- Lemma tree_equal_allows_more_deallocation
- {tr1 tr2 acc_tg range}
- (GloballyUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (GloballyUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- (ProtParentsNonDis : protected_parents_not_disabled C tr2)
- (PMI : parents_more_init tr2) :
- parents_more_active tr1 →
- no_active_cousins C tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- tree_equal Forwards tr1 tr2 ->
- tree_unique acc_tg tr1 ->
- is_Some (memory_deallocate C acc_tg range tr1) ->
- is_Some (memory_deallocate C acc_tg range tr2).
- Proof.
- intros ???? Heq Hunq (tr1'&(pw1&Hpw1&Htrr%mk_is_Some)%bind_Some).
- pose proof Hpw1 as HH.
- eapply mk_is_Some, tree_equal_allows_more_access in HH as (pw2&Hpw2). 2-8: done.
- opose proof (tree_equal_preserved_by_memory_access _ _ _ _ _ _ _ _ Hpw1 Hpw2) as Heqpw.
- 1-3: done. 1-4: done. 1: by eapply unique_exists.
- rewrite /memory_deallocate Hpw2 /option_bind //.
- eapply join_success_condition, every_node_map, every_node_eqv_universal.
- intros itm2 Hitm2%exists_node_to_tree_lookup.
- 2: { intros ttg Hcont.
- eapply access_preserves_tags, GloballyUnique2 in Hcont.
- 2: apply Hpw2. setoid_rewrite <- tree_apply_access_preserve_unique; last apply Hpw2.
- done. }
- assert (tree_contains (itag itm2) pw2) as Hcont by apply Hitm2.
- destruct Heqpw as (Hsame&_&Hacc). setoid_rewrite <- Hsame in Hcont.
- apply Hacc in Hcont as (itm1&itm2'&Hlu1&Hlu2&Hiteq).
- assert (itm2' = itm2) as ->.
- 1: eapply tree_determined_unify. 1,3: eapply Hitm2. 1: eapply Hlu2.
- assert (itag itm1 = itag itm2) as Htageq.
- 1: eapply tree_lookup_correct_tag, Hlu1.
- eapply join_success_condition in Htrr.
- setoid_rewrite every_node_map in Htrr.
- eapply every_node_eqv_universal in Htrr.
- 2: { eapply tree_lookup_to_exists_node. rewrite -Htageq in Hlu1. done. }
- simpl in Htrr. eapply is_Some_if_neg in Htrr.
- destruct (Hiteq 0) as (Hloceq&_). simpl.
- rewrite -!Hloceq Htrr. done.
- Qed.
-
- Lemma trees_equal_insert d tr1 tr2 ttr1 ttr2 blk :
- trees_equal d tr1 tr2 →
- tree_equal d ttr1 ttr2 →
- trees_equal d (<[blk := ttr1]> tr1) (<[blk := ttr2]> tr2).
- Proof.
- intros Htr Httr blk'.
- destruct (decide (blk = blk')) as [Heq|Hne].
- - rewrite -!Heq !lookup_insert. by econstructor.
- - rewrite !lookup_insert_ne //.
- Qed.
-
- Lemma apply_within_trees_equal d fn blk tr1 tr1' tr2 :
- (∀ ttr1 ttr1' ttr2, fn ttr1 = Some ttr1' → tree_equal d ttr1 ttr2 →
- tr1 !! blk = Some ttr1 → tr1' !! blk = Some ttr1' → tr2 !! blk = Some ttr2 →
- ∃ ttr2', fn ttr2 = Some ttr2' ∧ tree_equal d ttr1' ttr2') →
- apply_within_trees fn blk tr1 = Some tr1' →
- trees_equal d tr1 tr2 →
- ∃ tr2', apply_within_trees fn blk tr2 = Some tr2' ∧
- trees_equal d tr1' tr2'.
- Proof.
- intros Hfn Happly Heq.
- rewrite /apply_within_trees in Happly|-*.
- specialize (Heq blk) as Heqblk.
- inversion Heqblk as [ttr1 ttr2 Hteq Htr1 Htr2|HN1 HN2]; last rewrite -HN1 // in Happly.
- rewrite -Htr1 -?Htr2 /= in Happly|-*.
- destruct (fn ttr1) as [ttr1'|] eqn:Hfnttr1; last done.
- rewrite /= in Happly. injection Happly as <-.
- destruct (Hfn ttr1 ttr1' ttr2) as (ttr2' & Hfnttr2 & Heq'); try done.
- 1: by rewrite lookup_insert.
- rewrite Hfnttr2 /=. eexists; split; first done.
- by apply trees_equal_insert.
- Qed.
-
- Lemma trees_equal_delete d tr1 tr2 blk :
- trees_equal d tr1 tr2 →
- trees_equal d (delete blk tr1) (delete blk tr2).
- Proof.
- intros Htr blk'.
- destruct (decide (blk = blk')) as [Heq|Hne].
- - rewrite -!Heq !lookup_delete. by econstructor.
- - rewrite !lookup_delete_ne //.
- Qed.
-
- Lemma trees_equal_init_trees d ts tt tg bl off sz :
- trees_equal d ts tt →
- trees_equal d (extend_trees tg bl off sz ts) (extend_trees tg bl off sz tt).
- Proof.
- intros Htrs. apply trees_equal_insert; first done.
- eapply tree_equal_reflexive.
- eapply wf_tree_tree_item_determined.
- eapply wf_init_tree.
- Qed.
-
- Lemma tree_all_protected_initialized_elem_of cid tr tg lst
- (AllUnique : forall tg, tree_contains tg tr -> tree_unique tg tr) :
- (tg, lst) ∈ tree_get_all_protected_tags_initialized_locs cid tr ↔
- ∃ it, tree_lookup tr tg it ∧ protector_is_for_call cid it.(iprot) ∧
- ∀ z v, lst !! z = Some v ↔ initialized (item_lookup it z) = PermInit ∧ (v = AccessWrite ↔ perm (item_lookup it z) = Active).
- Proof.
- setoid_rewrite tree_all_protected_initialized_exists_node.
- split.
- - intros (it&Hexit%exists_node_to_tree_lookup&Htg&Hprot&Hinit)%exists_node_eqv_existential. 2: done.
- rewrite Htg in Hexit. by eexists.
- - intros (it&Hit&Hprops). assert (itag it = tg) as <- by by eapply tree_lookup_correct_tag.
- eapply exists_node_eqv_existential. eexists; split; last done.
- by eapply tree_lookup_to_exists_node.
- Qed.
-
- Lemma parents_not_disabled_child_not_prot_init tr tg1 tg2 it1 it2 off
- (Hwf : wf_tree tr)
- (HH : protected_parents_not_disabled C tr) :
- tree_lookup tr tg1 it1 →
- tree_lookup tr tg2 it2 →
- ParentChildIn tg1 tg2 tr →
- perm (item_lookup it1 off) = Disabled →
- initialized (item_lookup it2 off) = PermInit →
- protector_is_active (iprot it2) C →
- False.
- Proof.
- intros Hl1 Hl2 HPC Hp1 Hp2 Hp3.
- specialize (HH tg1). eapply every_child_ParentChildIn in HH.
- 2: done. 2, 4: eapply Hwf. 2,4: eapply Hl1. 2: eapply Hl2. 2: done.
- assert (tg1 = itag it1) as -> by by eapply tree_lookup_correct_tag in Hl1.
- assert (tg2 = itag it2) as -> by by eapply tree_lookup_correct_tag in Hl2.
- eapply every_node_eqv_universal in HH.
- 2: eapply tree_lookup_to_exists_node, Hl2.
- ospecialize (HH _ _ Hp2 Hp3). 1: done. congruence.
- Qed.
-
- Lemma disabled_in_practice_not_prot_init tr tg1 tg2 it off
- (Hwf : wf_tree tr)
- (HNC : no_active_cousins C tr)
- (HH : protected_parents_not_disabled C tr) :
- tree_lookup tr tg2 it →
- initialized (item_lookup it off) = PermInit →
- protector_is_active (iprot it) C →
- disabled_in_practice tr tg2 tg1 off →
- False.
- Proof.
- intros Hl1 Hini Hperm [it_witness incl H1 H2 H3].
- destruct (decide (perm (item_lookup it_witness off) = Disabled)) as [Hdis|Hnondis].
- + eapply parents_not_disabled_child_not_prot_init. 1: exact Hwf. 1: done. 4: exact Hdis. 4: exact Hini. 4: exact Hperm.
- 1-2: done.
- rewrite /rel_dec in H1. destruct decide; done.
- + inversion H3 as [X1 X2 X3|lp X HH1 HH2 X2]; simplify_eq.
- { rewrite -X2 in Hnondis. done. }
- inversion HH1 as [|tgcs itcs X1 X2 H1' H2' H3' H4 H5 X3 X4]; simplify_eq.
- { rewrite -HH2 in Hnondis. done. }
- eapply HNC. 1: exact Hl1. 1: exact H2'. 3: by erewrite H4.
- 2: right; split. 2: done. 2: done.
- rewrite rel_dec_flip2 /=.
- rewrite /rel_dec in H1|-*.
- destruct decide as [HPC1|] in H1; last done. clear H1.
- rewrite decide_False; last first.
- { intros HPC2. rewrite /rel_dec in H1'.
- destruct decide in H1'; try done.
- rewrite decide_True // in H1'.
- eapply ParentChild_transitive. 1: exact HPC1. done. }
- rewrite decide_False //.
- intros HPC2.
- eapply cousins_have_disjoint_children. 4: exact H1'. 4: exact HPC1. 4: done.
- all: eapply Hwf. 1: eapply Hl1. 1: eapply H2. 1: eapply H2'.
- Qed.
-
- Lemma item_wf_item_lookup_active it ev1 ev2 off :
- item_wf it ev1 ev2 →
- perm (item_lookup it off) = Active →
- initialized (item_lookup it off) = PermInit.
- Proof.
- intros Hwf.
- rewrite /item_lookup. destruct (iperm it !! off) as [p|] eqn:Heq.
- - rewrite /=. eapply map_Forall_lookup_1 in Heq. 2: by eapply item_perms_valid. apply Heq.
- - simpl. intros HH. exfalso; by eapply item_default_perm_valid.
- Qed.
-
-
- Lemma perm_eq_up_to_C_same_protected_active d tr1 tr2 tg off prot it1 it2 ev1 ev2
- (Hwf1 : wf_tree tr1)
- (Hwf2 : wf_tree tr2)
- (ProtParentsNonDis1 : protected_parents_not_disabled C tr1)
- (ProtParentsNonDis2 : protected_parents_not_disabled C tr2)
- (HCS1 : no_active_cousins C tr1)
- (HCS2 : no_active_cousins C tr2)
- (Hiwf1 : item_wf it1 ev1 ev2)
- (Hiwf2 : item_wf it2 ev1 ev2) :
- tree_lookup tr1 tg it1 →
- tree_lookup tr2 tg it2 →
- prot = iprot it1 → prot = iprot it2 →
- protector_is_active prot C →
- perm_eq_up_to_C tr1 tr2 tg off prot d (item_lookup it1 off) (item_lookup it2 off) →
- perm (item_lookup it1 off) = Active ↔ perm (item_lookup it2 off) = Active.
- Proof.
- intros Hl1 Hl2 Hiprot1 Hiprot2 Hprot H. inversion H as [| | |p1 p2 HX1 HX2 HX3 HX4|X1 X2 X3 X4 X5 X6 X7| |p1 p2 ini Hr]; try done; simplify_eq.
- - simpl; split; intros Hact; exfalso.
- + rewrite /item_lookup in HX3.
- destruct lookup eqn:Heq in HX3.
- 2: { simpl in HX3. injection HX3 as ->.
- eapply item_default_perm_valid in Hact; done. }
- rewrite /= in HX3. subst.
- eapply item_perms_valid in Heq. 2: done.
- simpl in Heq. by ospecialize (Heq _).
- + rewrite /item_lookup in HX4.
- destruct lookup eqn:Heq in HX4.
- 2: { simpl in HX3. injection HX4 as ->.
- eapply item_default_perm_valid in Hact; done. }
- rewrite /= in HX4. subst.
- eapply item_perms_valid in Heq. 2: done.
- simpl in Heq. by ospecialize (Heq _).
- - split; intros XX; eapply item_wf_item_lookup_active in XX; try done.
- all: exfalso; destruct d;
- (eapply disabled_in_practice_not_prot_init in X4; [done..| |by congruence]).
- all: congruence.
- - destruct d; simpl in Hr; inversion Hr; simplify_eq; simpl.
- 2,4: done. all: exfalso; done.
- Qed.
-
- Lemma tree_equals_protected_initialized d tr1 tr2 cid ev1 ev2
- (AllUnique1 : forall tg, tree_contains tg tr1 -> tree_unique tg tr1)
- (AllUnique2 : forall tg, tree_contains tg tr2 -> tree_unique tg tr2)
- (PND1 : protected_parents_not_disabled C tr1)
- (PND2 : protected_parents_not_disabled C tr2)
- (HCS1 : no_active_cousins C tr1)
- (HCS2 : no_active_cousins C tr2)
- (Hiwf1 : tree_items_compat_nexts tr1 ev1 ev2)
- (Hiwf2 : tree_items_compat_nexts tr2 ev1 ev2) :
- cid ∈ C →
- tree_equal d tr1 tr2 →
- tree_get_all_protected_tags_initialized_locs cid tr1 =
- tree_get_all_protected_tags_initialized_locs cid tr2.
- Proof.
- intros Hcid Heq. eapply gset_leibniz. intros (tg&lst).
- split; intros (it&Hlu&Hprot&Hinit)%tree_all_protected_initialized_elem_of; try done.
- all: eapply tree_all_protected_initialized_elem_of; first done.
- - edestruct (tree_equal_transfer_lookup_1 Heq Hlu) as (it'&Hit'&Heqit').
- exists it'. split; first done.
- split; first by erewrite <- item_eq_up_to_C_same_iprot.
- intros z. specialize (Hinit z). destruct (Heqit' z) as (Hproteq&Heqlu).
- erewrite <- perm_eq_up_to_C_same_init. 2: done.
- setoid_rewrite <- perm_eq_up_to_C_same_protected_active. 15: eassumption. 2-7: try done.
- 1,4,5,6,7: done.
- + eapply every_node_eqv_universal in Hiwf1. 2: eapply tree_lookup_to_exists_node, Hlu.
- exact Hiwf1.
- + eapply every_node_eqv_universal in Hiwf2. 2: eapply tree_lookup_to_exists_node, Hit'.
- exact Hiwf2.
- + by eexists cid.
- - edestruct (tree_equal_transfer_lookup_2 Heq Hlu) as (it'&Hit'&Heqit').
- exists it'. split; first done.
- split; first by erewrite item_eq_up_to_C_same_iprot.
- intros z. specialize (Hinit z). destruct (Heqit' z) as (Hproteq&Heqlu).
- erewrite perm_eq_up_to_C_same_init. 2: done.
- setoid_rewrite perm_eq_up_to_C_same_protected_active. 15: eassumption. 2-7: done.
- 1,4,5,6,7: done.
- + eapply every_node_eqv_universal in Hiwf1. 2: eapply tree_lookup_to_exists_node, Hit'.
- exact Hiwf1.
- + eapply every_node_eqv_universal in Hiwf2. 2: eapply tree_lookup_to_exists_node, Hlu.
- exact Hiwf2.
- + rewrite Hproteq. by eexists cid.
- Qed.
-
-
- Lemma tree_equals_access_many_helper_2 tg (L : gmap Z _) tr1 tr1' tr2
- (Hwf1 : wf_tree tr1)
- (Hwf2 : wf_tree tr2)
- (PMI : parents_more_init tr2)
- (ProtParentsNonDis2 : protected_parents_not_disabled C tr2) :
- parents_more_active tr1 → parents_more_active tr2 →
- no_active_cousins C tr1 → no_active_cousins C tr2 →
- tree_equal Forwards tr1 tr2 →
- tree_unique tg tr1 →
- let fn := (λ tr, map_fold (λ l acc tr2, tr2 ≫= memory_access_nonchildren_only acc C tg (l, 1%nat)) (Some tr) L) in
- fn tr1 = Some tr1' →
- ∃ tr2', fn tr2 = Some tr2' ∧ tree_equal Forwards tr1' tr2'.
- Proof.
- intros X1 X2 X3 X4 Heq Hunq''. simpl.
- map_fold_weak_ind L as off acc E Hnone Hfoo IH in tr1' Hunq''.
- { simpl. intros [= ->]; by eexists. }
- simpl. intros (tr1'''&H1&H2)%bind_Some.
- specialize (IH _ Hunq'' H1) as (tr2'''&Htr2&HHtr2p). rewrite Hfoo Htr2 /=.
- assert (tree_unique tg tr1''') as Hunq'''.
- { rewrite /tree_unique. erewrite <- tree_access_many_helper_2. 1: exact Hunq''. exact H1. }
- assert (wf_tree tr1''') as Hwf1'''.
- { eapply preserve_tag_count_wf. 1: eapply tree_access_many_helper_2. 1: exact Hwf1. 1: apply H1. }
- assert (wf_tree tr2''') as Hwf2'''.
- { eapply preserve_tag_count_wf. 1: eapply tree_access_many_helper_2. 1: exact Hwf2. 1: apply Htr2. }
- opose proof (tree_equal_allows_more_access_nonchildren_only _ _ _ _ _ HHtr2p Hunq''' _) as (trr&Htrr).
- 1, 2: by apply wf_tree_tree_unique. 3: done.
- 1: { eapply tree_access_many_protected_not_disabled_helper_2. 5: exact Htr2. 1,3,4: done. destruct Heq as (Hx&_). by eapply Hx, unique_exists. }
- 1: { eapply tree_access_many_more_init_helper_2. 4: exact Htr2. 1,3: done. destruct Heq as (Hx&_). by eapply Hx, unique_exists. }
- 1: by eapply mk_is_Some.
- exists trr; split; first done.
- eapply tree_equal_preserved_by_memory_access_nonchildren_only.
- 9-10: done. 7: done. 7: by eapply unique_exists.
- 1-2: by eapply wf_tree_tree_unique.
- 1,3: eapply tree_access_many_more_active_helper_2; last done; first done; last done.
- 2: eapply Heq. 1-2: by eapply unique_exists.
- all: eapply tree_access_many_no_cousins_helper_2; last done; first done; last done.
- 2: eapply Heq. 1-2: by eapply unique_exists.
- Qed.
-
- Lemma tree_equals_access_many_helper_1 (E : list (tag * gmap Z _)) tr1 tr1' tr2
- (Hwf1 : wf_tree tr1)
- (Hwf2 : wf_tree tr2)
- (PMI2 : parents_more_init tr2)
- (ProtParentsNonDis : protected_parents_not_disabled C tr2) :
- parents_more_active tr1 → parents_more_active tr2 →
- no_active_cousins C tr1 → no_active_cousins C tr2 →
- tree_equal Forwards tr1 tr2 →
- (∀ tg L, (tg, L) ∈ E → tree_unique tg tr1)→
- let fn := (λ tr, foldr (λ '(tg, L) tr, tr ≫= λ tr1, map_fold (λ l acc tr2, tr2 ≫= memory_access_nonchildren_only acc C tg (l, 1%nat)) (Some tr1) L) (Some tr) E) in
- fn tr1 = Some tr1' →
- ∃ tr2', fn tr2 = Some tr2' ∧ tree_equal Forwards tr1' tr2'.
- Proof.
- intros X1 X2 X3 X4 Heq Hunq.
- induction E as [|(tg&init_locs) S IH] in tr1',Hunq|-*.
- { simpl. intros [= ->]; by eexists. }
- simpl. intros (tr1''&H1&H2)%bind_Some.
- opose proof (IH _ _ H1) as (tr2''&Htr2&HHtr2); clear IH.
- { intros ???. eapply Hunq. by right. }
- rewrite Htr2 /=. pose proof Hunq as Hunq2.
- ospecialize (Hunq tg init_locs _). 1: by left. revert H2.
- eapply tree_equals_access_many_helper_2.
- { eapply preserve_tag_count_wf. 1: eapply tree_access_many_helper_1. 1: exact Hwf1. 1: apply H1. }
- { eapply preserve_tag_count_wf. 1: eapply tree_access_many_helper_1. 1: exact Hwf2. 1: exact Htr2. }
- { eapply tree_access_many_more_init_helper_1. 4: exact Htr2. 1,3: done. intros ???. destruct Heq as (HH&_); eapply HH, unique_exists, Hunq2. by right. }
- { eapply tree_access_many_protected_not_disabled_helper_1. 5: exact Htr2. 1,3,4: done. intros ???. destruct Heq as (HH&_); eapply HH, unique_exists, Hunq2. by right. }
- 1,2: eapply tree_access_many_more_active_helper_1; last done; first done; last done; intros ???.
- 2: eapply Heq. 1-2: eapply unique_exists, Hunq2; by right.
- 1,2: eapply tree_access_many_no_cousins_helper_1; last done; first done; last done; intros ???.
- 2: eapply Heq. 1-2: eapply unique_exists, Hunq2; by right.
- { done. }
- { rewrite /tree_unique. erewrite <- tree_access_many_helper_1. 1: exact Hunq. exact H1. }
- Qed.
-
- Lemma tree_equals_access_all_protected_initialized' tr1 tr1' tr2 cid ev1 ev2
- (Hwf1 : wf_tree tr1)
- (Hwf2 : wf_tree tr2)
- (PMI : parents_more_init tr2)
- (PMA1 : parents_more_active tr1)
- (PMA2 : parents_more_active tr2)
- (ProtParentsNonDis1 : protected_parents_not_disabled C tr1)
- (ProtParentsNonDis2 : protected_parents_not_disabled C tr2)
- (NA1 : no_active_cousins C tr1)
- (NA2 : no_active_cousins C tr2)
- (CC1 : tree_items_compat_nexts tr1 ev1 ev2)
- (CC2 : tree_items_compat_nexts tr2 ev1 ev2) :
- cid ∈ C →
- tree_equal Forwards tr1 tr2 →
- tree_access_all_protected_initialized C cid tr1 = Some tr1' →
- ∃ tr2', tree_access_all_protected_initialized C cid tr2 = Some tr2' ∧
- tree_equal Forwards tr1' tr2'.
- Proof.
- intros Hc Heq.
- rewrite /tree_access_all_protected_initialized.
- erewrite <- (tree_equals_protected_initialized Forwards tr1 tr2); last done.
- 2-3: by eapply wf_tree_tree_unique. 2-8: done.
- eapply tree_equals_access_many_helper_1. 1-9: done.
- {intros tg E. setoid_rewrite elem_of_elements.
- intros (it&Hit&_)%tree_all_protected_initialized_elem_of. all: eapply wf_tree_tree_unique; try apply Hwf1.
- by eapply lookup_implies_contains. }
- Qed.
-
- Lemma apply_within_trees_lift d trs fn blk trs' :
- wf_trees trs →
- apply_within_trees fn blk trs = Some trs' →
- (∀ tr tr', trs !! blk = Some tr → trs' !! blk = Some tr' → fn tr = Some tr' → tree_equal d tr tr') →
- trees_equal d trs trs'.
- Proof.
- intros Hwf (tr&Htr&(tr'&Htr'&[= <-])%bind_Some)%bind_Some Heq.
- intros bb. destruct (decide (bb = blk)) as [<-|Hne].
- - rewrite lookup_insert Htr. econstructor. eapply Heq. 1,3: done. by rewrite lookup_insert.
- - rewrite lookup_insert_ne //. destruct (trs !! bb) eqn:HHeq. all: rewrite !HHeq. all: econstructor.
- eapply tree_equal_reflexive. eapply wf_tree_tree_item_determined, Hwf, HHeq.
- Qed.
-
- Lemma trees_equal_access_all_protected_initialized trs1 trs1' trs2 cid ev1 ev2
- (Hwf1 : wf_trees trs1)
- (Hwf2 : wf_trees trs2)
- (PMI : each_tree_parents_more_init trs2)
- (PMA1 : each_tree_parents_more_active trs1)
- (PMA2 : each_tree_parents_more_active trs2)
- (ProtParentsNonDis1 : each_tree_protected_parents_not_disabled C trs1)
- (ProtParentsNonDis2 : each_tree_protected_parents_not_disabled C trs2)
- (NA1 : each_tree_no_active_cousins C trs1)
- (NA2 : each_tree_no_active_cousins C trs2)
- (CC1 : trees_compat_nexts trs1 ev1 ev2)
- (CC2 : trees_compat_nexts trs2 ev1 ev2) :
- cid ∈ C →
- trees_equal Forwards trs1 trs2 →
- trees_access_all_protected_initialized C cid trs1 = Some trs1' →
- ∃ trs2', trees_access_all_protected_initialized C cid trs2 = Some trs2' ∧
- trees_equal Forwards trs1' trs2'.
- Proof.
- intros Hc Heq Htrapi.
- epose proof (trees_access_all_protected_initialized_pointwise_1 _ _ _ _ Htrapi) as Htrapi1.
- odestruct (trees_access_all_protected_initialized_pointwise_2 _ trs2) as (trs2'&Htrs2').
- { intros k. destruct (Htrapi1 k) as (HH'&_). intros tr2 Htr2.
- specialize (Heq k). rewrite Htr2 in Heq. inversion Heq as [tr1 x1 Heqtr Htr1 e|]. subst x1.
- destruct (HH' tr1) as (tr1'&Htr1'&HHtr1'); first done.
- edestruct tree_equals_access_all_protected_initialized' as (tr2'&Htr2'&Heq').
- 13: exact Heqtr. 13: exact HHtr1'. 1: by eapply Hwf1. 1: by eapply Hwf2.
- 11: by eexists. 1: by eapply PMI. 1: by eapply PMA1. 1: by eapply PMA2. 1: by eapply ProtParentsNonDis1. 1: by eapply ProtParentsNonDis2.
- 1: by eapply NA1. 1: by eapply NA2. 1: by eapply CC1. 1: by eapply CC2. done. }
- eexists; split; first done.
- intros k. specialize (Heq k).
- epose proof (trees_access_all_protected_initialized_pointwise_1 _ _ _ _ Htrs2' k) as (Htrapi2A&Htrapi2B).
- specialize (Htrapi1 k) as (Htrapi1A&Htrapi1B).
- inversion Heq as [tr1 tr2 Heqtr Htr1 Htr2|HNone1 HNone2]; last first.
- - rewrite Htrapi1B // Htrapi2B //. econstructor.
- - symmetry in Htr1,Htr2.
- destruct (Htrapi1A _ Htr1) as (tr1'&Htr1'&Hrapi1'). destruct (Htrapi2A _ Htr2) as (tr2'&Htr2'&Hrapi2').
- rewrite Htr1' Htr2'. econstructor.
- edestruct tree_equals_access_all_protected_initialized' as (tr2''&Htr2'u&Htr2'eq).
- 14: exact Hrapi1'. 13: exact Heqtr. 1: by eapply Hwf1. 1: by eapply Hwf2. 1: by eapply PMI. 1: by eapply PMA1. 1: by eapply PMA2. 1: by eapply ProtParentsNonDis1. 1: by eapply ProtParentsNonDis2.
- 1: by eapply NA1. 1: by eapply NA2. 1: by eapply CC1. 1: by eapply CC2. 1: done.
- rewrite Hrapi2' in Htr2'u. injection Htr2'u as <-. done.
- Qed.
-
- (* A bunch of extra conditions on the structure.
- They are put in the same clause to simplify this theorem, but we will want
- a higher-level lemma that derives these assumptions from their actual justification. *)
- Definition tree_equal_asymmetric_read_pre_protected tr range it acc_tg (mode:bool) :=
- (∀ off, range'_contains range off →
- let pp_acc := item_lookup it off in
- pp_acc.(initialized) = PermInit ∧ pp_acc.(perm) ≠Disabled ∧
- ∀ tg' it', tree_lookup tr tg' it' →
- let pp := item_lookup it' off in
- let rd := rel_dec tr tg' acc_tg in (* flipped here so that it's correcty lined up with logical_state *)
- match rd with
- Foreign (Parent _) => pp.(initialized) = PermInit ∧ pp.(perm) ≠Disabled
- | Foreign Cousin => pp.(perm) ≠Active | _ => True end ∧
- if mode then (rd = Child (Strict Immediate) → pp.(perm) = Disabled) else
- (pp_acc.(perm) = Frozen ∧ (∀ i, rd = Child (Strict i) → pp.(perm) ≠Active))).
-
- (* Remember that the entire reason we have [trees_equal] in the first place
- is to enable spurious reads. This is the lemma that verifies that after we
- do a spurious read we get a [tree_equal]. A companion lemma (stating
- that under certain circumstances the spurious read will succeed) will be proved
- separately.
-
- The hypotheses are guided by the optimizations that we want to prove.
- We can't (and don't plan to) do spurious reads anywhere, only on protected
- tags. For now we require that the tag also doesn't have any Active
- children. Both of these can be relaxed slightly, but a more general version
- of this lemma will come only if actually required.
-
- Because we have nice properties of transitivity and reflexivity of [tree_equal]
- already, the proof can be simplified by only considering the case where
- before the asymmetric read the trees are identical. In other words we're going
- to check that a tree is [tree_equal] to itself after a read. *)
- Lemma tree_equal_asymmetric_read_protected
- {d tr tr' acc_tg range it} (mode:bool)
- (GloballyUnique : forall tg, tree_contains tg tr -> tree_unique tg tr)
- :
- (* Accessed tag must be in the tree and protected*)
- tree_lookup tr acc_tg it ->
- protector_is_active it.(iprot) C ->
- tree_equal_asymmetric_read_pre_protected tr range it acc_tg mode ->
- (* Under the above conditions if we do a spurious read and it succeeds
- we get a [tree_equal] on the outcome. *)
- memory_access AccessRead C acc_tg range tr = Some tr' ->
- tree_equal d tr tr'.
- Proof.
- intros Lkup Protected TreeShapeProper Acc.
- split; last split.
- { intro tg. eapply access_preserves_tags. eassumption. }
- { intros tg1 tg2. eapply access_same_rel_dec. eassumption. }
- (* That was the easy part, helped by the fact that our initial configuration
- is reflexivity instead of a more general instance of [tree_equal].
- Soon it will get more interesting. *)
- intros tg0 Ex.
- destruct (unique_implies_lookup (GloballyUnique _ Ex)) as [it0 Lookup0].
- exists it0.
- assert (tree_unique tg0 tr') as Unq0'. {
- erewrite <- tree_apply_access_preserve_unique; last eassumption.
- apply GloballyUnique. assumption.
- }
- destruct (apply_access_spec_per_node (proj1 Lookup0) (proj2 Lookup0) Acc) as
- (it0' & it0'Spec & Ex0' & Det0').
- symmetry in it0'Spec.
- exists it0'.
- split; first assumption.
- split; first (split; assumption).
- (* Now down to per-item reasoning *)
- intro loc.
- split; first (eapply item_apply_access_preserves_metadata; eassumption).
- rewrite bind_Some in it0'Spec; destruct it0'Spec as (perms' & perms'Spec & [= <-]).
- pose proof (mem_apply_range'_spec _ _ loc _ _ perms'Spec) as PerLoc.
- clear perms'Spec.
- assert (itag it0 = tg0) by (eapply tree_determined_specifies_tag; eapply Lookup0).
- assert (itag it = acc_tg) by (eapply tree_determined_specifies_tag; eapply Lkup).
- subst.
- (* Finally the reasoning is per-location *)
- destruct (decide _) as [HinRange|?]; last first.
- { rewrite /item_lookup /= PerLoc.
- constructor. }
- destruct (TreeShapeProper _ HinRange) as (Htginit&Htgnondis&Hothers).
- (* Keep digging until [apply_access_perm_inner] *)
- destruct PerLoc as (perm' & perm'Lookup & perm'Spec).
- pose proof Hothers as Hothers_pure.
- ospecialize (Hothers _ _ Lookup0).
- change (default _ _) with (item_lookup it0 loc) in perm'Spec.
- rewrite {2}/item_lookup perm'Lookup /=.
- rewrite bind_Some in perm'Spec; destruct perm'Spec as (tmperm & Inner & perm'Spec).
- rewrite bind_Some in perm'Spec; destruct perm'Spec as (validated & MoreInit & EqPerm).
- injection EqPerm; clear EqPerm; intros; subst.
- rewrite rel_dec_flip2 in Hothers.
- destruct Hothers as (Hothers&Hspecials).
- destruct (rel_dec tr (itag it) (itag it0)) as [[]|[]] eqn:Hreldec.
- - destruct mode.
- + assert (∃ tg, tree_contains tg tr ∧ rel_dec tr tg (itag it) = Child (Strict Immediate) ∧ ParentChildIn tg (itag it0) tr) as (tgsw & Hin & Hswdec&Hpar).
- { rewrite /rel_dec in Hreldec. destruct decide as [HP|HnP]; try done. destruct decide as [HP|?]; try done.
- destruct HP as [Heq|HSP]. 1: exfalso; eapply HnP; by left.
- eapply immediate_sandwich in HSP as HSP2. 2, 3: eapply GloballyUnique. 2: eapply Lkup.
- destruct HSP2 as (tsw&Htsw&HPC). exists tsw.
- assert (tree_contains tsw tr) as Hcont.
- { eapply contains_child. 1: right; by eapply Immediate_is_StrictParentChild.
- eapply Lkup. }
- split_and!. 1: done. 2: done.
- rewrite /rel_dec decide_True.
- 2: right; by eapply Immediate_is_StrictParentChild.
- rewrite decide_False. 1: by rewrite decide_True.
- intros HH. eapply immediate_parent_not_child. 4: exact HH. 3: done.
- all: eapply GloballyUnique. 1: eapply Lkup. done. }
- assert (∃ itsw, tree_lookup tr tgsw itsw) as (itsw&Hitsw).
- 1: eapply unique_implies_lookup, GloballyUnique, Hin.
- specialize (Hothers_pure _ _ Hitsw).
- destruct (apply_access_spec_per_node (proj1 Hitsw) (proj2 Hitsw) Acc) as
- (itsw' & itsw'Spec & Hitsw').
- destruct Hothers_pure as (_&HH). ospecialize (HH _). 1: done.
- eapply (perm_eq_up_to_C_disabled_parent _ _ _ _ _ _ tgsw). 3: rewrite /= most_init_comm //=.
- * econstructor. 2: done. 1: rewrite /rel_dec decide_True //.
- destruct (item_lookup itsw loc) as [[] pp] eqn:HHH; simpl in *; subst pp.
- 1: econstructor 1. econstructor 2. econstructor 1.
- * econstructor. 1: erewrite <- access_same_rel_dec. 2: eassumption. 1: rewrite /rel_dec decide_True //.
- 1: exact Hitsw'. symmetry in itsw'Spec.
- eapply bind_Some in itsw'Spec as (psw&Hsw&[= Hitsweq]).
- pose proof (mem_apply_range'_spec _ _ loc _ _ Hsw) as PerLocSW.
- rewrite decide_True // in PerLocSW. destruct PerLocSW as (p & HPP & Hacc).
- rewrite /= /apply_access_perm /apply_access_perm_inner /= in Hacc.
- change (default _ _) with (item_lookup itsw loc) in Hacc.
- assert (itag itsw = tgsw) as <- by by eapply tree_lookup_correct_tag.
- rewrite rel_dec_flip2 Hswdec /= HH /= most_init_comm /= in Hacc.
- rewrite /item_lookup /= -Hitsweq HPP /=.
- destruct (item_lookup itsw loc) as [ini prm] eqn:Heq; simpl in *; subst prm.
- edestruct (bool_decide (protector_is_active (iprot itsw) C)), ini in Hacc; simpl in Hacc; try discriminate Hacc; injection Hacc as <-.
- all: try econstructor 1. all: econstructor 2; econstructor 1.
- + rewrite /apply_access_perm_inner /= in Inner. rewrite /= most_init_comm /=.
- destruct Hspecials as (Hfrz&Hnact).
- destruct (item_lookup it0 loc) as [ini [cfl| | | |]] eqn:Hperm.
- 2,4,5: by (destruct ini, (bool_decide (protector_is_active (iprot it0) C)); simpl in *; simplify_eq; econstructor 1).
- 2: exfalso; by eapply Hnact.
- simpl in *. assert (∃ cfl', validated = Reserved cfl') as (cfl'&->).
- { destruct ini, cfl, (bool_decide (protector_is_active (iprot it0) C)); simpl in *; eexists; simplify_eq; done. }
- destruct (apply_access_spec_per_node (proj1 Lkup) (proj2 Lkup) Acc) as
- (it' & it'Spec & Hit'). symmetry in it'Spec.
- eapply bind_Some in it'Spec as (pit&Hpit&[= Hiteq]).
- pose proof (mem_apply_range'_spec _ _ loc _ _ Hpit) as PerLoc.
- rewrite decide_True // in PerLoc. destruct PerLoc as (p & HPP & Hacc).
- rewrite /= /apply_access_perm /apply_access_perm_inner /= in Hacc.
- change (default _ _) with (item_lookup it loc) in Hacc.
- assert (itag it' = itag it) as Hit by by eapply tree_lookup_correct_tag.
- rewrite rel_dec_refl Hfrz /= most_init_comm /= in Hacc.
- rewrite Tauto.if_same /= in Hacc. injection Hacc as <-.
- eapply perm_eq_up_to_C_frozen_parent with (witness_tg := itag it). destruct d.
- * econstructor. 1: rewrite rel_dec_flip2 Hreldec //. 1: exact Lkup. 1: done. 1: done.
- * econstructor.
- { erewrite <- access_same_rel_dec. 2: done. rewrite rel_dec_flip2 Hreldec //. }
- { eapply Hit'. }
- all: rewrite /item_lookup -Hiteq /= HPP /= //.
- - rewrite /= most_init_comm /=.
- rewrite /apply_access_perm_inner /= in Inner.
- destruct (item_lookup it0 loc) as [[] [[]| | | |]] eqn:Hperm, (bool_decide (protector_is_active (iprot it0) C)) eqn:Hprot; simpl in *.
- all: try by (simplify_eq; econstructor 1).
- 1-2: simplify_eq; econstructor 2;
- [by eapply bool_decide_eq_true_1| |econstructor 1].
- 1-2: eapply (pseudo_conflicted_cousin_init _ _ _ (itag it) it);
- [rewrite rel_dec_flip2 Hreldec //|done..].
- - destruct Hothers as (Hinit&Hndis).
- rewrite /apply_access_perm_inner /= in Inner.
- destruct (item_lookup it0 loc) as [[] pp] eqn:Hperm. 2: done.
- assert (pp = tmperm) as ->.
- { simpl in *. destruct pp; simplify_eq; done. }
- rewrite /= in MoreInit|-*.
- destruct tmperm, (bool_decide (protector_is_active (iprot it0) C)); simpl in MoreInit.
- all: try done. all: simplify_eq; econstructor 1.
- - simpl in *. assert (itag it = itag it0) as Htageq.
- { rewrite /rel_dec in Hreldec. do 2 (destruct decide; try done).
- eapply mutual_parent_child_implies_equal. 1: done. 1: eapply Lkup. all: done. }
- assert (it = it0) as ->.
- { eapply tree_determined_unify. 1, 2: eapply Lkup. rewrite Htageq. eapply Lookup0. }
- rewrite Htginit in MoreInit|-*.
- rewrite bool_decide_true // /= in MoreInit.
- destruct (item_lookup it0 loc) as [[] pp] eqn:Hperm. 2: done.
- destruct pp; try done. all: repeat (simpl in *; simplify_eq); by econstructor 1.
- Qed.
-
- (* We can also do symmetric writes, provided we have sufficiently strong preconditions,
- which include being protected. *)
- Definition tree_equal_asymmetric_write_pre_protected tr range it acc_tg :=
- (∀ off, range'_contains range off →
- let pp_acc := item_lookup it off in
- pp_acc.(initialized) = PermInit ∧ pp_acc.(perm) = Active ∧
- ∀ tg' it', tree_lookup tr tg' it' →
- let pp := item_lookup it' off in
- let rd := rel_dec tr tg' acc_tg in (* flipped here so that it's correcty lined up with logical_state *)
- match rd with
- | Child (Strict Immediate) => pp.(perm) = Disabled
- | Child _ => True
- | Foreign (Parent _) => pp.(initialized) = PermInit ∧ pp.(perm) = Active (* this follows from state_wf *)
- | Foreign Cousin => match pp.(perm) with Disabled => True | ReservedIM => ¬ protector_is_active it'.(iprot) C (* never occurs *) | _ => pp.(initialized) = PermLazy end end).
-
- Lemma disabled_is_disabled x1 x2 x3 x4 pp : perm pp = Disabled → is_disabled x1 x2 x3 pp x4.
- Proof.
- destruct pp as [[] pp]; simpl; intros ->.
- 1: econstructor 1.
- econstructor 2. econstructor 1.
- Qed.
-
- Lemma tree_equal_asymmetric_write_protected
- {d tr tr' acc_tg range it}
- (GloballyUnique : forall tg, tree_contains tg tr -> tree_unique tg tr)
- :
- (* Accessed tag must be in the tree and protected*)
- tree_lookup tr acc_tg it ->
- protector_is_active it.(iprot) C ->
- tree_equal_asymmetric_write_pre_protected tr range it acc_tg ->
- (* Under the above conditions if we do a spurious read and it succeeds
- we get a [tree_equal] on the outcome. *)
- memory_access AccessWrite C acc_tg range tr = Some tr' ->
- tree_equal d tr tr'.
- Proof.
- intros Lkup Protected TreeShapeProper Acc.
- split; last split.
- { intro tg. eapply access_preserves_tags. eassumption. }
- { intros tg1 tg2. eapply access_same_rel_dec. eassumption. }
- (* That was the easy part, helped by the fact that our initial configuration
- is reflexivity instead of a more general instance of [tree_equal].
- Soon it will get more interesting. *)
- intros tg0 Ex.
- destruct (unique_implies_lookup (GloballyUnique _ Ex)) as [it0 Lookup0].
- exists it0.
- assert (tree_unique tg0 tr') as Unq0'. {
- erewrite <- tree_apply_access_preserve_unique; last eassumption.
- apply GloballyUnique. assumption.
- }
- destruct (apply_access_spec_per_node (proj1 Lookup0) (proj2 Lookup0) Acc) as
- (it0' & it0'Spec & Ex0' & Det0').
- symmetry in it0'Spec.
- exists it0'.
- split; first assumption.
- split; first (split; assumption).
- (* Now down to per-item reasoning *)
- intro loc.
- split; first (eapply item_apply_access_preserves_metadata; eassumption).
- rewrite bind_Some in it0'Spec; destruct it0'Spec as (perms' & perms'Spec & [= <-]).
- pose proof (mem_apply_range'_spec _ _ loc _ _ perms'Spec) as PerLoc.
- clear perms'Spec.
- assert (itag it0 = tg0) by (eapply tree_determined_specifies_tag; eapply Lookup0).
- assert (itag it = acc_tg) by (eapply tree_determined_specifies_tag; eapply Lkup).
- subst.
- (* Finally the reasoning is per-location *)
- destruct (decide _) as [HinRange|?]; last first.
- { rewrite /item_lookup /= PerLoc.
- constructor. }
- destruct (TreeShapeProper _ HinRange) as (Htginit&Htgactive&Hothers).
- (* Keep digging until [apply_access_perm_inner] *)
- destruct PerLoc as (perm' & perm'Lookup & perm'Spec).
- pose proof Hothers as Hothers_pure.
- ospecialize (Hothers _ _ Lookup0).
- change (default _ _) with (item_lookup it0 loc) in perm'Spec.
- rewrite {2}/item_lookup perm'Lookup /=.
- rewrite bind_Some in perm'Spec; destruct perm'Spec as (tmperm & Inner & perm'Spec).
- rewrite bind_Some in perm'Spec; destruct perm'Spec as (validated & MoreInit & EqPerm).
- injection EqPerm; clear EqPerm; intros; subst.
- rewrite rel_dec_flip2 /= in Hothers.
- destruct (rel_dec tr (itag it) (itag it0)) as [[]|[]] eqn:Hreldec; simpl in Hothers.
- - assert (∃ tg, tree_contains tg tr ∧ rel_dec tr tg (itag it) = Child (Strict Immediate) ∧ ParentChildIn tg (itag it0) tr) as (tgsw & Hin & Hswdec&Hpar).
- { rewrite /rel_dec in Hreldec. destruct decide as [HP|HnP]; try done. destruct decide as [HP|?]; try done.
- destruct HP as [Heq|HSP]. 1: exfalso; eapply HnP; by left.
- eapply immediate_sandwich in HSP as HSP2. 2, 3: eapply GloballyUnique. 2: eapply Lkup.
- destruct HSP2 as (tsw&Htsw&HPC). exists tsw.
- assert (tree_contains tsw tr) as Hcont.
- { eapply contains_child. 1: right; by eapply Immediate_is_StrictParentChild.
- eapply Lkup. }
- split_and!. 1: done. 2: done.
- rewrite /rel_dec decide_True.
- 2: right; by eapply Immediate_is_StrictParentChild.
- rewrite decide_False. 1: by rewrite decide_True.
- intros HH. eapply immediate_parent_not_child. 4: exact HH. 3: done.
- all: eapply GloballyUnique. 1: eapply Lkup. done. }
- assert (∃ itsw, tree_lookup tr tgsw itsw) as (itsw&Hitsw).
- 1: eapply unique_implies_lookup, GloballyUnique, Hin.
- specialize (Hothers_pure _ _ Hitsw).
- destruct (apply_access_spec_per_node (proj1 Hitsw) (proj2 Hitsw) Acc) as
- (itsw' & itsw'Spec & Hitsw'). rewrite Hswdec /= in Hothers_pure.
- eapply (perm_eq_up_to_C_disabled_parent _ _ _ _ _ _ tgsw). 3: rewrite /= most_init_comm //=.
- * econstructor. 2: done. 1: rewrite /rel_dec decide_True //. eapply disabled_is_disabled, Hothers_pure.
- * econstructor. 1: erewrite <- access_same_rel_dec. 2: eassumption. 1: rewrite /rel_dec decide_True //.
- 1: exact Hitsw'. symmetry in itsw'Spec.
- eapply bind_Some in itsw'Spec as (psw&Hsw&[= Hitsweq]).
- pose proof (mem_apply_range'_spec _ _ loc _ _ Hsw) as PerLocSW.
- rewrite decide_True // in PerLocSW. destruct PerLocSW as (p & HPP & Hacc).
- rewrite /= /apply_access_perm /apply_access_perm_inner /= in Hacc.
- change (default _ _) with (item_lookup itsw loc) in Hacc.
- assert (itag itsw = tgsw) as <- by by eapply tree_lookup_correct_tag.
- rewrite rel_dec_flip2 Hswdec /= Hothers_pure /= in Hacc.
- rewrite /item_lookup /= -Hitsweq HPP /=.
- repeat (case_match; simpl in *; try done; simplify_eq).
- all: by eapply disabled_is_disabled.
- - rewrite /= most_init_comm /=.
- rewrite /apply_access_perm_inner /= in Inner.
- eapply rel_dec_flip in Hreldec.
- destruct (item_lookup it0 loc) as [[] [[]| | | |]] eqn:Hperm, (bool_decide (protector_is_active (iprot it0) C)) eqn:Hprot; simpl in *.
- all: try by (simplify_eq; first [done | econstructor 1]).
- all: try by eapply bool_decide_eq_true_1 in Hprot.
- all: injection Inner as <-; injection MoreInit as <-.
- all: econstructor 4; last econstructor 1.
- all: econstructor 2; [exact Hreldec|exact Lkup|done|destruct (item_lookup it loc); simpl in *; congruence| ].
- all: intros [=]. all: by eapply bool_decide_eq_true_1.
- - destruct Hothers as (Hini&Hact).
- rewrite /apply_access_perm_inner /= in Inner.
- destruct (item_lookup it0 loc) as [ini pp] eqn:Hperm.
- simpl in Hini, Hact. subst ini pp. simpl in Inner. simplify_eq. simpl in MoreInit.
- destruct (bool_decide (protector_is_active (iprot it0) C)); simpl in MoreInit|-*; simplify_eq.
- all: econstructor 1.
- - simpl in *. assert (itag it = itag it0) as Htageq.
- { rewrite /rel_dec in Hreldec. do 2 (destruct decide; try done).
- eapply mutual_parent_child_implies_equal. 1: done. 1: eapply Lkup. all: done. }
- assert (it = it0) as ->.
- { eapply tree_determined_unify. 1, 2: eapply Lkup. rewrite Htageq. eapply Lookup0. }
- rewrite Htginit in MoreInit|-*. rewrite Htgactive in Inner. simplify_eq.
- rewrite bool_decide_true // /= in MoreInit. simplify_eq.
- destruct (item_lookup it0 loc) as [ii pp]. simpl in *; subst ii pp. econstructor 1.
- Qed.
-
- Lemma rel_dec_equal_ParentChildIn_equiv tr1 tr2 :
- (∀ tg, tree_contains tg tr1 ↔ tree_contains tg tr2) →
- (∀ tg1 tg2, rel_dec tr1 tg1 tg2 = rel_dec tr2 tg1 tg2) →
- ∀ tg1 tg2, (ParentChildIn tg1 tg2 tr1 ↔ ParentChildIn tg1 tg2 tr2) ∧ (ImmediateParentChildIn tg1 tg2 tr1 ↔ ImmediateParentChildIn tg1 tg2 tr2).
- Proof.
- intros Hcont H tg1 tg2.
- specialize (H tg2 tg1).
- rewrite /rel_dec in H. destruct (decide (ParentChildIn tg1 tg2 tr1)) as [H1|H1]; last first.
- all: destruct (decide (ParentChildIn tg1 tg2 tr2)) as [H2|H2]; try done.
- all: split; first tauto.
- - split; intros H3%Immediate_is_StrictParentChild; exfalso. 1: eapply H1. 2: eapply H2. all: by right.
- - destruct (decide (tree_contains tg1 tr1)) as [Hin|Hnin]; last first.
- { split; intros _; eapply ImmediateParentChildIn_parent_not_in; last done.
- by setoid_rewrite <- Hcont. }
- destruct (decide (tg1 = tg2)) as [->|Hne].
- { split; intros H3%Immediate_is_StrictParentChild; exfalso; (eapply strict_parent_self_impossible; last done).
- 2: rewrite <- Hcont. all: done. }
- destruct H1 as [?|H1]; first done.
- destruct H2 as [?|H2]; first done.
- rewrite decide_False in H. 2: { intros [?|H3]; first done. eapply strict_parent_self_impossible; first done. by eapply StrictParentChild_transitive. }
- rewrite (decide_False This) in H. 2: { intros [?|H3]; first done. setoid_rewrite Hcont in Hin. eapply strict_parent_self_impossible; first done. by eapply StrictParentChild_transitive. }
- destruct (decide (ImmediateParentChildIn tg1 tg2 tr1)), (decide (ImmediateParentChildIn tg1 tg2 tr2)); done.
- Qed.
-
- Lemma rel_dec_equal_ParentChildIn_equiv_lift tr1 tr2 :
- (∀ tg, tree_contains tg tr1 ↔ tree_contains tg tr2) →
- (∀ tg1 tg2, rel_dec tr1 tg1 tg2 = rel_dec tr2 tg1 tg2) →
- (∀ tg1 tg2, ParentChildIn tg1 tg2 tr1 ↔ ParentChildIn tg1 tg2 tr2) ∧
- (∀ tg1 tg2, StrictParentChildIn tg1 tg2 tr1 ↔ StrictParentChildIn tg1 tg2 tr2) ∧
- (∀ tg1 tg2, ImmediateParentChildIn tg1 tg2 tr1 ↔ ImmediateParentChildIn tg1 tg2 tr2).
- Proof.
- intros H1 H2.
- epose proof (rel_dec_equal_ParentChildIn_equiv _ _ H1 H2) as H. split_and!.
- 1, 3: eapply H.
- intros tg1 tg2.
- destruct (decide (tree_contains tg1 tr1)) as [H3|H3]; last first.
- all: epose proof H3 as H3'; setoid_rewrite H1 in H3'.
- { split; intros _; rewrite /StrictParentChildIn; eapply every_subtree_eqv_universal.
- all: intros br Hex Htg; exfalso. 1: eapply H3'. 2: eapply H3.
- all: eapply exists_node_iff_exists_root.
- all: eapply exists_subtree_eqv_existential; eexists.
- all: split; first done; done.
- all: split; first eapply exists_node_iff_exists_root. }
- destruct (decide (tg1 = tg2)) as [->|Hne].
- { split; intros []%strict_parent_self_impossible; done. }
- destruct (H tg1 tg2) as ((HH1&HH2)&_).
- split; intros Hc.
- - destruct HH1 as [?|HH1]; try done. by right.
- - destruct HH2 as [?|HH2]; try done. by right.
- Qed.
-
- Lemma tree_equal_create_child d tr1 tr2 tr1' tg_new tg_old pk im rk cid ev2 :
- wf_tree tr1 → wf_tree tr2 →
- tree_items_compat_nexts tr1 tg_new ev2 → tree_items_compat_nexts tr2 tg_new ev2 →
- (cid < ev2)%nat →
- tree_contains tg_old tr1 →
- ¬ tree_contains tg_new tr1 →
- tree_equal d tr1 tr2 →
- create_child C tg_old tg_new pk im rk cid tr1 = Some tr1' →
- ∃ tr2', create_child C tg_old tg_new pk im rk cid tr2 = Some tr2' ∧
- tree_equal d tr1' tr2'.
- Proof.
- intros Hwf1 Hwf2 Hiwf1 Hiwf2 Hcidwf.
- intros Hcontains1 Hnotcont1 (H1&H2&H3) (it_new&Hit_new&[= <-])%bind_Some.
- assert (itag it_new = tg_new) as Htgnew by by eapply new_item_has_tag.
- assert (tg_old ≠tg_new) as Htgsne by (intros ->; firstorder).
- pose proof Hcontains1 as Hcontains2. setoid_rewrite H1 in Hcontains2.
- pose proof Hnotcont1 as Hnotcont2. setoid_rewrite H1 in Hnotcont2.
- epose proof create_new_item_wf _ _ _ _ _ _ _ Hcidwf Hit_new as Hitemwf.
- opose proof (insert_child_wf C _ _ _ _ _ _ _ _ _ _ Hitemwf Hit_new _ Hiwf1 Hwf1) as (_&Hwf1').
- 1: rewrite /create_child Hit_new //.
- opose proof (insert_child_wf C _ _ _ _ _ _ _ _ _ _ Hitemwf Hit_new _ Hiwf2 Hwf2) as (_&Hwf2').
- 1: rewrite /create_child Hit_new //.
- eexists. split.
- 1: rewrite /create_child Hit_new //.
- pose proof (rel_dec_equal_ParentChildIn_equiv_lift _ _ H1 H2) as (H2A&H2B&H2C).
- split_and!.
- - intros tg. destruct (decide (tg = tg_new)) as [->|Hne].
- + split; (intros _; eapply insert_true_produces_exists; [done|]); assumption.
- + split; (intros H%insert_false_infer_exists; last congruence); eapply insert_preserves_exists, H1, H.
- - eapply same_parent_childs_agree; intros tg tg'.
- + destruct (decide (tg = tg_new)) as [->|Hne], (decide (tg' = tg_new)) as [->|Hne'].
- * split; intros _; by left.
- * subst tg_new. split; (intros [|Hc]; first done); exfalso; (eapply inserted_not_strict_parent; [| |exact Hc]; done).
- * subst tg_new. destruct (decide (tg = tg_old)) as [->|Hneold].
- 1: split; intros _; eapply insert_produces_ParentChild; done.
- split; (intros [|Hc]; first done).
- all: eapply insert_produces_minimal_ParentChild in Hc; [|done..].
- all: eapply ParentChild_transitive; last by eapply insert_produces_ParentChild.
- all: right; setoid_rewrite <- insert_eqv_strict_rel; [|done..].
- 1: by setoid_rewrite <- H2B. 1: by setoid_rewrite H2B.
- * subst tg_new. split; (intros [->|Hc]; [by left|right]).
- all: setoid_rewrite <- insert_eqv_strict_rel; [|done..].
- all: eapply H2B.
- all: setoid_rewrite -> insert_eqv_strict_rel; first done; done.
- + destruct (decide (tg = tg_new)) as [->|Hne], (decide (tg' = tg_new)) as [->|Hne'].
- * subst tg_new. split; intros H; exfalso; (eapply immediate_parent_child_not_equal; [..|done|done]).
- 1-2: eapply Hwf1'. 3-4: eapply Hwf2'.
- all: eapply insert_true_produces_exists; first done; done.
- * subst tg_new. split; (intros Hc%Immediate_is_StrictParentChild); exfalso; (eapply inserted_not_strict_parent; [| |exact Hc]; done).
- * subst tg_new. destruct (decide (tg = tg_old)) as [->|Hneold].
- 1: split; intros _; eapply insert_produces_ImmediateParentChild; done.
- destruct (decide (tree_contains tg tr1)) as [Htgin|Htgnin]; last first.
- { split; intros _; eapply ImmediateParentChildIn_parent_not_in.
- all: intros Hc%remove_false_preserves_exists; last done.
- all: eapply Htgnin. 1: eapply H1. all: eapply Hc. }
- split; intros Hc; exfalso.
- all: eapply ImmediateParentChild_of_insert_is_parent in Hc; [done|done|..|done].
- 1: done. by eapply H1.
- * subst tg_new. setoid_rewrite <- insert_eqv_imm_rel. 1: apply H2C.
- all: done.
- - intros tg Hcont. subst tg_new.
- destruct (decide (tg = itag it_new)) as [->|Hne].
- { exists it_new, it_new. split_and!.
- 1-2: split; first by eapply insert_true_produces_exists.
- 1-2: by eapply inserted_determined.
- eapply item_eq_up_to_C_reflexive. }
- eapply remove_false_preserves_exists in Hcont. 2: done.
- destruct (H3 tg Hcont) as (it1&it2&Hlu1&Hlu2&Hequptoc).
- exists it1, it2. split_and!.
- 1-2: destruct Hlu1, Hlu2.
- 1-2: split; first by eapply insert_preserves_exists.
- 1-2: setoid_rewrite <- insert_true_preserves_every; done.
- intros l. specialize (Hequptoc l) as (Heq1&Heq2).
- split; first done.
- inversion Heq2 as [|pi c1 c2 Hi1 Hi2 Hi3 Hi4 Hi5| |p1 p2 Hi2 Hi3 Hi4 Hi5|witness_tg ? ? Dis1 Dis2|??? witness_tg Frz1|p1 p2 ini Hd]; simplify_eq.
- + by econstructor 1.
- + destruct Hlu1 as (Hlu1A&Hlu1B), Hlu2 as (Hlu2A&Hlu2B).
- pose proof Hcont as Hcont2. setoid_rewrite H1 in Hcont2. econstructor 2. 1: done.
- * inversion Hi2 as [|tg_cs it_cs Hii1 Hii2 Hii3 Hii4 Hii5 Hii6]; simplify_eq; first by econstructor 1.
- destruct Hii2 as [HA HB].
- econstructor 2. 3-5: done.
- 2: { split. 1: by eapply insert_preserves_exists.
- setoid_rewrite <- insert_true_preserves_every; first done.
- intros <-. done. }
- rewrite /rel_dec in Hii1|-*.
- destruct (decide (ParentChildIn tg_cs tg tr1)) as [|HnPC]; first done.
- destruct (decide (ParentChildIn tg tg_cs tr1)) as [|HnPC2]; first done.
- rewrite decide_False; first rewrite decide_False //; last first.
- -- intros [|Hc]; eapply HnPC; first by left. right.
- eapply insert_eqv_strict_rel; last exact Hc.
- 1-2: by intros <-.
- -- intros [|Hc]; eapply HnPC2; first by left. right.
- eapply insert_eqv_strict_rel; last exact Hc.
- 1-2: by intros <-.
- * inversion Hi3 as [|tg_cs it_cs Hii1 Hii2 Hii3 Hii4 Hii5 Hii6]; simplify_eq; first by econstructor 1.
- destruct Hii2 as [HA HB].
- econstructor 2. 3-5: done.
- 2: { split. 1: by eapply insert_preserves_exists.
- setoid_rewrite <- insert_true_preserves_every; first done.
- intros <-. done. }
- rewrite /rel_dec in Hii1|-*.
- destruct (decide (ParentChildIn tg_cs tg tr2)) as [|HnPC]; first done.
- destruct (decide (ParentChildIn tg tg_cs tr2)) as [|HnPC2]; first done.
- rewrite decide_False; first rewrite decide_False //; last first.
- -- intros [|Hc]; eapply HnPC; first by left. right.
- eapply insert_eqv_strict_rel; last exact Hc.
- 1-2: by intros <-.
- -- intros [|Hc]; eapply HnPC2; first by left. right.
- eapply insert_eqv_strict_rel; last exact Hc.
- 1-2: by intros <-.
- + by econstructor 3.
- + destruct Hlu1 as (Hlu1A&Hlu1B), Hlu2 as (Hlu2A&Hlu2B).
- pose proof Hcont as Hcont2. setoid_rewrite H1 in Hcont2. econstructor 4.
- * inversion Hi2 as [|tg_cs it_cs X1 X2 Hii1 Hii2 Hii3 Hii4]; simplify_eq; first by econstructor 1.
- destruct Hii2 as [HA HB].
- econstructor 2. 3-5: done.
- 2: { split. 1: by eapply insert_preserves_exists.
- setoid_rewrite <- insert_true_preserves_every; first done.
- intros <-. done. }
- rewrite /rel_dec in Hii1|-*.
- destruct (decide (ParentChildIn tg_cs tg tr1)) as [|HnPC]; first done.
- destruct (decide (ParentChildIn tg tg_cs tr1)) as [|HnPC2]; first done.
- rewrite decide_False; first rewrite decide_False //; last first.
- -- intros [|Hc]; eapply HnPC; first by left. right.
- eapply insert_eqv_strict_rel; last exact Hc.
- 1-2: by intros <-.
- -- intros [|Hc]; eapply HnPC2; first by left. right.
- eapply insert_eqv_strict_rel; last exact Hc.
- 1-2: by intros <-.
- * inversion Hi3 as [|tg_cs it_cs X1 X2 Hii1 Hii2 Hii3 Hii4]; simplify_eq; first by econstructor 1.
- destruct Hii2 as [HA HB].
- econstructor 2. 3-5: done.
- 2: { split. 1: by eapply insert_preserves_exists.
- setoid_rewrite <- insert_true_preserves_every; first done.
- intros <-. done. }
- rewrite /rel_dec in Hii1|-*.
- destruct (decide (ParentChildIn tg_cs tg tr2)) as [|HnPC]; first done.
- destruct (decide (ParentChildIn tg tg_cs tr2)) as [|HnPC2]; first done.
- rewrite decide_False; first rewrite decide_False //; last first.
- -- intros [|Hc]; eapply HnPC; first by left. right.
- eapply insert_eqv_strict_rel; last exact Hc.
- 1-2: by intros <-.
- -- intros [|Hc]; eapply HnPC2; first by left. right.
- eapply insert_eqv_strict_rel; last exact Hc.
- 1-2: by intros <-.
- + econstructor 5.
- * eapply disabled_in_practice_create_child_irreversible.
- 5: rewrite /create_child; erewrite Hit_new; done.
- -- lia.
- -- inversion Dis1 as [it_witness ?? LuWitness].
- pose proof (tree_determined_specifies_tag _ _ _ (proj1 LuWitness) (proj2 LuWitness)) as itag_witness_spec.
- pose proof ((proj1 (every_node_iff_every_lookup (wf_tree_tree_item_determined _ Hwf1)) Hiwf1 witness_tg it_witness ltac:(assumption)).(item_tag_valid _ _ _) witness_tg itag_witness_spec).
- enough (itag it_new ≠witness_tg) by eassumption.
- lia.
- -- eassumption.
- -- eassumption.
- * eapply disabled_in_practice_create_child_irreversible.
- 5: rewrite /create_child; erewrite Hit_new; done.
- -- lia.
- -- inversion Dis1 as [it_witness ?? LuWitness].
- pose proof (tree_determined_specifies_tag _ _ _ (proj1 LuWitness) (proj2 LuWitness)) as itag_witness_spec.
- pose proof ((proj1 (every_node_iff_every_lookup (wf_tree_tree_item_determined _ Hwf1)) Hiwf1 witness_tg it_witness ltac:(assumption)).(item_tag_valid _ _ _) witness_tg itag_witness_spec).
- enough (itag it_new ≠witness_tg) by eassumption.
- lia.
- -- eassumption.
- -- eassumption.
- * auto.
- + econstructor 6; destruct d.
- * eapply frozen_in_practice_create_child_irreversible.
- 4: rewrite /create_child; erewrite Hit_new; done.
- -- lia.
- -- inversion Frz1 as [it_witness ?? LuWitness].
- pose proof (tree_determined_specifies_tag _ _ _ (proj1 LuWitness) (proj2 LuWitness)) as itag_witness_spec.
- pose proof ((proj1 (every_node_iff_every_lookup (wf_tree_tree_item_determined _ Hwf1)) Hiwf1 witness_tg it_witness ltac:(assumption)).(item_tag_valid _ _ _) witness_tg itag_witness_spec).
- enough (itag it_new ≠witness_tg) by eassumption.
- lia.
- -- eassumption.
- * eapply frozen_in_practice_create_child_irreversible.
- 4: rewrite /create_child; erewrite Hit_new; done.
- -- lia.
- -- inversion Frz1 as [it_witness ?? LuWitness].
- pose proof (tree_determined_specifies_tag _ _ _ (proj1 LuWitness) (proj2 LuWitness)) as itag_witness_spec.
- pose proof ((proj1 (every_node_iff_every_lookup (wf_tree_tree_item_determined _ Hwf2)) Hiwf2 witness_tg it_witness ltac:(assumption)).(item_tag_valid _ _ _) witness_tg itag_witness_spec).
- enough (itag it_new ≠witness_tg) by eassumption.
- lia.
- -- eassumption.
- + econstructor 7. done.
- Qed.
-
- Lemma trees_equal_create_child d trs1 trs2 trs1' blk tg_new tg_old pk im rk cid nxtc :
- wf_trees trs1 → wf_trees trs2 →
- trees_compat_nexts trs1 tg_new nxtc → trees_compat_nexts trs2 tg_new nxtc →
- (cid < nxtc)%nat →
- trees_contain tg_old trs1 blk →
- ¬ trees_contain tg_new trs1 blk →
- trees_equal d trs1 trs2 →
- apply_within_trees (create_child C tg_old tg_new pk im rk cid) blk trs1 = Some trs1' →
- ∃ trs2', apply_within_trees (create_child C tg_old tg_new pk im rk cid) blk trs2 = Some trs2' ∧
- trees_equal d trs1' trs2'.
- Proof.
- intros Hwf1 Hwf2 Hiwf1 Hiwf2 Hcidwf Hcont Hncont Heq.
- intros (tr1&Htr1&(tr1'&Htr1'&[= <-])%bind_Some)%bind_Some.
- eapply bind_Some in Htr1' as HH. destruct HH as (it&Hit&[= Htrit]).
- epose proof (Heq blk) as HeqblkI.
- inversion HeqblkI as [t1x tr2 Heqblk Heq1x Htr2|]; simplify_eq; last congruence.
- symmetry in Htr2. assert (t1x = tr1) as -> by congruence. clear Heq1x.
- eapply tree_equal_create_child in Htr1' as (tr2'&Htr2'&Heqtr).
- - eexists. rewrite /apply_within_trees /= Htr2 /=.
- split; first by rewrite /create_child Hit.
- intros blk'. destruct (decide (blk = blk')) as [->|Hne].
- + rewrite !lookup_insert. econstructor.
- eapply bind_Some in Htr2' as HH. destruct HH as (it2&Hit2&[= <-]).
- enough (it = it2) as -> by by eapply Heqtr.
- congruence.
- + rewrite !lookup_insert_ne //.
- - by eapply Hwf1.
- - by eapply Hwf2.
- - by eapply Hiwf1.
- - by eapply Hiwf2.
- - done.
- - by rewrite /trees_contain /trees_at_block Htr1 in Hcont.
- - by rewrite /trees_contain /trees_at_block Htr1 in Hncont.
- - done.
- Qed.
-
- Lemma perm_eq_up_to_C_trans {tr1 tr2 tr3 tg l cid perm1 perm2 perm3} :
- protected_parents_not_disabled C tr2 →
- (∀ tg, tree_contains tg tr2 → tree_unique tg tr2) →
- (∀ tg, tree_contains tg tr1 → tree_unique tg tr1) →
- parents_more_active tr2 →
- no_active_cousins C tr2 →
- parents_more_active tr1 →
- no_active_cousins C tr1 →
- tree_equal Forwards tr1 tr2 →
- tree_equal Forwards tr2 tr3 →
- perm_eq_up_to_C tr1 tr2 tg l cid Forwards perm1 perm2 →
- perm_eq_up_to_C tr2 tr3 tg l cid Forwards perm2 perm3 →
- perm_eq_up_to_C tr1 tr3 tg l cid Forwards perm1 perm3.
- Proof.
- intros Hpnd Hunq1 Hunq2 Hpma1 Hnac1 Hpma2 Hnac2 Heq12 Heq23 EqC1 EqC2.
- inversion EqC1 as [pp1|ini1 confl1 confl2 Hprot HP1 HP2|ini1 confl1 confl2 HnoProt|p1 p2 HP1 HP2|wit_tg lp1 lp2 Hdip1 Hdip2 Hini|ini1 confl1 confl2 wit_tg HF|p1 p2 ini Hd]; simplify_eq;
- inversion EqC2 as [pp1'|ini1' confl1' confl2' Hprot' HP1' HP2'|ini1' confl1' confl2' HnoProt'|p1' p2' HP1' HP2'|wit_tg' lp1 lp2 Hdip1' Hdip2' Hini'|ini1' confl1' confl2' wit_tg' HF'|p1' p2' ini' Hd']; simplify_eq.
- (* easy case: perm1 = perm2 *)
- + econstructor 1.
- + econstructor 2. 1: done. 2: done.
- eapply tree_equal_transfer_pseudo_conflicted. 1: done. 1: done. 1: done.
- 1: by eapply tree_equal_sym. done.
- + by econstructor 3.
- + econstructor 4. 2: done.
- eapply tree_equal_transfer_pseudo_disabled. 5: done. all: done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. congruence.
- + eapply trees_equal_transfer_frozen_in_practice_many in HF' as [(Hfip&Hfip2)|(tr&Hdi9p&Hdip2)]. 3-5: eassumption.
- * econstructor 6. all: edestruct Hfip2 as (px&Hpx&Hrz). 1: by eapply tree_equal_sym.
- enough (px = Frozen) as -> by done. destruct Hrz as [->|(->&[=])]; tauto.
- * econstructor 5; last done. all: eapply Hdip2. 2: done. 1: by eapply tree_equal_sym.
- + econstructor 7. apply Hd'.
- (* case 2: perm1 and perm2 are pseudo_conflicted Reserved *)
- + econstructor 2. 1: done. 1: done.
- eapply tree_equal_transfer_pseudo_conflicted. 5: exact HP2. all: done.
- + econstructor 2; done.
- + exfalso. done.
- + econstructor 4. 2: done.
- eapply conflicted_transfer_pseudo_disabled.
- eapply tree_equal_transfer_pseudo_disabled. 4: done. all: done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor 5. 1: exact Hw1. 1: exact Hw3. simpl in *. eapply Hini'.
- + eapply trees_equal_transfer_frozen_in_practice_many in HF' as [(Hfip&Hfip2)|(tr&Hdi9p&Hdip2)]. 3-5: eassumption.
- * econstructor 6. all: edestruct Hfip2 as (px&Hpx&Hrz). 1: by eapply tree_equal_sym.
- enough (px = Frozen) as -> by done. destruct Hrz as [->|(->&[=])]; tauto.
- * econstructor 5; last done. all: eapply Hdip2. 2: done. 1: by eapply tree_equal_sym.
- + inversion Hd'; simplify_eq. destruct confl1; last econstructor 1.
- econstructor 7; econstructor; done.
- (* case 3: perm1 and perm2 are unprotected reserved *)
- + by econstructor 3.
- + exfalso. done.
- + by econstructor 3.
- + econstructor 4. 2: done.
- eapply conflicted_transfer_pseudo_disabled.
- eapply tree_equal_transfer_pseudo_disabled. 4: done. all: done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + by econstructor 3.
- + inversion Hd'; simplify_eq; done.
- (* case 4: perm1 and perm2 are pseudo-disabled *)
- + econstructor 4. 1: done.
- eapply tree_equal_transfer_pseudo_disabled. 5: by eapply tree_equal_sym. all: done.
- + econstructor 4. 1: done.
- eapply conflicted_transfer_pseudo_disabled.
- eapply tree_equal_transfer_pseudo_disabled. 5: by eapply tree_equal_sym. all: done.
- + econstructor 4. 1: done.
- eapply conflicted_transfer_pseudo_disabled.
- eapply tree_equal_transfer_pseudo_disabled. 5: by eapply tree_equal_sym. all: done.
- + econstructor 4. all: done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + econstructor 4. 1: done.
- eapply conflicted_transfer_pseudo_disabled.
- eapply tree_equal_transfer_pseudo_disabled. 5: by eapply tree_equal_sym. all: done.
- + econstructor 4. 1: done.
- eapply transfer_pseudo_disabled_notimm.
- 1: eapply tree_equal_transfer_pseudo_disabled. 5: by eapply tree_equal_sym. 1-4: done.
- all: inversion Hd'; done.
- (* case 5: perm1 and perm2 are disabled in practice *)
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. congruence.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- (* case 6: perm1 and perm2 are frozen in practice. *)
- + by econstructor 6.
- + by econstructor 6.
- + by econstructor 6.
- + econstructor 4. 2: done.
- eapply transfer_pseudo_disabled_notimm.
- 1: eapply tree_equal_transfer_pseudo_disabled. 5: done. 1-4: done.
- all: done.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + by econstructor 6.
- + inversion Hd'; try done.
- simplify_eq. destruct confl1. 2: econstructor 1.
- econstructor 7. econstructor. done.
- (* case 7: the asymmetric case *)
- + by econstructor 7.
- + inversion Hd; simplify_eq. econstructor 2; try done. econstructor 1.
- + inversion Hd; simplify_eq. done.
- + econstructor 4. 2: done.
- eapply transfer_pseudo_disabled_notimm.
- 1: eapply tree_equal_transfer_pseudo_disabled. 5: done. 1-4: done.
- all: by inversion Hd.
- + odestruct (trees_equal_transfer_disabled_in_practice_twice Hunq1 Hpma1 Hnac1 Heq12 Heq23) as (ww&Hw1&Hw2&Hw3).
- 1: done. econstructor. 1: exact Hw1. 1: exact Hw3. simpl in *. done.
- + eapply trees_equal_transfer_frozen_in_practice_many in HF' as [(Hfip&Hfip2)|(tr&Hdi9p&Hdip2)]. 3-5: eassumption.
- * inversion Hd; simplify_eq. econstructor 6.
- all: edestruct Hfip2 as (px&Hpx&Hrz). 1: by eapply tree_equal_sym.
- enough (px = Frozen) as -> by done. destruct Hrz as [->|(->&[=])]; tauto.
- * econstructor 5; last done. all: eapply Hdip2. 2: done. 1: by eapply tree_equal_sym.
- + inversion Hd; inversion Hd'; by simplify_eq.
- Qed.
-
- Lemma item_eq_up_to_C_trans {tr1 tr2 tr3 tg it1 it2 it3} :
- protected_parents_not_disabled C tr2 →
- (∀ tg, tree_contains tg tr1 → tree_unique tg tr1) →
- (∀ tg, tree_contains tg tr2 → tree_unique tg tr2) →
- parents_more_active tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr1 →
- no_active_cousins C tr2 →
- tree_equal Forwards tr1 tr2 →
- tree_equal Forwards tr2 tr3 →
- item_eq_up_to_C tr1 tr2 tg Forwards it1 it2 →
- item_eq_up_to_C tr2 tr3 tg Forwards it2 it3 →
- item_eq_up_to_C tr1 tr3 tg Forwards it1 it3.
- Proof.
- intros Hnd ?????? He1 He2 H1 H2 l.
- destruct (H1 l) as (H1l&H1r), (H2 l) as (H2l&H2r).
- split; first congruence.
- eapply perm_eq_up_to_C_trans. 1-9: done.
- 1: exact H1r. rewrite H1l. 1: exact H2r.
- Qed.
-
-
- Lemma tree_equal_trans tr1 tr2 tr3 :
- protected_parents_not_disabled C tr2 →
- (∀ tg, tree_contains tg tr1 → tree_unique tg tr1) →
- (∀ tg, tree_contains tg tr2 → tree_unique tg tr2) →
- parents_more_active tr1 →
- parents_more_active tr2 →
- no_active_cousins C tr1 →
- no_active_cousins C tr2 →
- tree_equal Forwards tr1 tr2 →
- tree_equal Forwards tr2 tr3 →
- tree_equal Forwards tr1 tr3.
- Proof.
- rewrite /tree_equal.
- intros ??????? [SameTg1 [SameRel1 EqC1]] [SameTg2 [SameRel2 EqC2]].
- split; [|split].
- + intro tg. rewrite SameTg1 SameTg2 //.
- + intros tg tg'. rewrite SameRel1 SameRel2 //.
- + intros tg Ex.
- destruct (EqC1 _ Ex) as (it1M&it2M&Hlu1M&Hlu2M&Hiteq).
- destruct (EqC2 tg) as (it1R&it2R&Hlu1R&Hlu2R&Hiteq2).
- 1: by eapply Hlu2M.
- assert (it2M = it1R) as -> by by eapply tree_lookup_unique.
- exists it1M, it2R. split_and!; [done..|].
- eapply item_eq_up_to_C_trans; done.
- Qed.
-
- Lemma trees_equal_trans trs1 trs2 trs3 :
- each_tree_protected_parents_not_disabled C trs2 →
- wf_trees trs1 →
- wf_trees trs2 →
- each_tree_parents_more_active trs1 →
- each_tree_parents_more_active trs2 →
- each_tree_no_active_cousins C trs1 →
- each_tree_no_active_cousins C trs2 →
- trees_equal Forwards trs1 trs2 →
- trees_equal Forwards trs2 trs3 →
- trees_equal Forwards trs1 trs3.
- Proof.
- rewrite /trees_equal.
- intros Hu1 Hu2 Hu3 Hu4 Hu5 Hu6 Hu7 Equals1 Equals2 blk.
- specialize (Equals1 blk). specialize (Equals2 blk).
- destruct (trs1 !! blk) as [tr1|] eqn:Heq1;
- destruct (trs2 !! blk) as [tr2|] eqn:Heq2;
- destruct (trs3 !! blk) as [tr3|] eqn:Heq3.
- all: inversion Equals1; inversion Equals2; simplify_eq; first [exfalso; congruence | econstructor].
- eapply tree_equal_trans. 8-9: eassumption.
- 2: by eapply Hu2. 1: by eapply Hu1. 1: by eapply Hu3. 1: by eapply Hu4. 1: by eapply Hu5. 1: by eapply Hu6. 1: by eapply Hu7.
- Qed.
-
-End utils.
-
-Section call_set.
-
- Lemma call_is_active_mono C1 C2 cid :
- C1 ⊆ C2 →
- call_is_active cid C1 →
- call_is_active cid C2.
- Proof.
- rewrite /call_is_active. set_solver.
- Qed.
-
- Lemma protector_is_active_mono C1 C2 prot :
- C1 ⊆ C2 →
- protector_is_active prot C1 →
- protector_is_active prot C2.
- Proof.
- intros Hss (c&Hc1&Hc2). eexists; split; by eauto using call_is_active_mono.
- Qed.
-
- Lemma pseudo_conflicted_mono C1 C2 tr tg off rc :
- C1 ⊆ C2 →
- pseudo_conflicted C1 tr tg off rc →
- pseudo_conflicted C2 tr tg off rc.
- Proof.
- induction 2.
- + econstructor 1.
- + econstructor 2; by eauto using protector_is_active_mono.
- Qed.
-
- Lemma protector_not_active_extend
- {p c C}
- (Hwf : ∀ c' : nat, protector_is_for_call c' p → (c' < c)%nat)
- (NoProt : ¬ protector_is_active p C)
- : ¬ protector_is_active p (C ∪ {[ c ]}).
- Proof.
- intros (cc&Hcc&[Hact|<-%elem_of_singleton]%elem_of_union).
- 1: eapply NoProt; by eexists.
- apply Hwf in Hcc. lia.
- Qed.
-
- Lemma pseudo_disabled_mono C1 nxtc tr1 tg l p1 cid :
- pseudo_disabled C1 tr1 tg l p1 cid →
- pseudo_disabled (C1 ∪ {[ nxtc ]}) tr1 tg l p1 cid.
- Proof.
- induction 1 as [|???????? HH]. 1: by econstructor 1.
- econstructor 2. 1,2,4: done.
- 1: eapply protector_is_active_mono; last done; set_solver.
- done.
- Qed.
-
- Lemma is_disabled_mono C1 nxtc tr1 tg l p1 cid :
- is_disabled C1 tr1 tg l p1 cid →
- is_disabled (C1 ∪ {[ nxtc ]}) tr1 tg l p1 cid.
- Proof.
- induction 1 as [|]. 1: by econstructor 1.
- econstructor 2. eapply pseudo_disabled_mono. done.
- Qed.
-
- Lemma disabled_in_practice_mono C1 nxtc tr1 tg tg2 l:
- disabled_in_practice C1 tr1 tg tg2 l →
- disabled_in_practice (C1 ∪ {[ nxtc ]}) tr1 tg tg2 l.
- Proof.
- induction 1. econstructor. 1-2: done.
- eapply is_disabled_mono. done.
- Qed.
-
- Lemma perm_eq_up_to_C_mono (C1 : gset nat) (nxtc : nat)
- tr1 tr2 tg l cid lp1 lp2 {d nxtp} :
- (∀ cc, protector_is_for_call cc cid → (cc < nxtc)%nat) →
- tree_items_compat_nexts tr1 nxtp nxtc →
- tree_items_compat_nexts tr2 nxtp nxtc →
- wf_tree tr1 →
- wf_tree tr2 →
- perm_eq_up_to_C C1 tr1 tr2 tg l cid d lp1 lp2 →
- perm_eq_up_to_C (C1 ∪ {[ nxtc ]}) tr1 tr2 tg l cid d lp1 lp2.
- Proof.
- intros Hwf Hwf_all1 Hwf_all2 Hwf_tr1 Hwf_tr2.
- induction 1 as [| |??? H|?? H1 H2|??? H1 H2 ?| |p1 p2 ini Hd].
- 1: by econstructor.
- 1: econstructor; try done. 1: eapply protector_is_active_mono; last done; set_solver.
- 1-2: eapply pseudo_conflicted_mono; last done; set_solver.
- - econstructor 3; try done.
- apply protector_not_active_extend; assumption.
- - econstructor 4. all: eapply pseudo_disabled_mono; last done; done.
- - econstructor 5; try done.
- all: eapply disabled_in_practice_mono; last done.
- - econstructor 6; done.
- - econstructor 7. destruct d; inversion Hd as [x1 Hp|]; simplify_eq.
- all: econstructor.
- 2,4: eapply protector_is_active_mono; last done; set_solver.
- all: eapply protector_not_active_extend; done.
- Qed.
-
- Lemma loc_eq_up_to_C_mono C1 d tr1 tr2 tg it1 it2 nxtc nxtp l :
- item_wf it1 nxtp nxtc →
- tree_items_compat_nexts tr1 nxtp nxtc →
- tree_items_compat_nexts tr2 nxtp nxtc →
- wf_tree tr1 →
- wf_tree tr2 →
- loc_eq_up_to_C C1 tr1 tr2 tg d it1 it2 l →
- loc_eq_up_to_C (C1 ∪ {[ nxtc ]}) tr1 tr2 tg d it1 it2 l.
- Proof.
- intros Hwf1 Hwf_all1 Hwf_all2 Hwf_tr1 Hwf_tr2.
- induction 1; econstructor; try done.
- eapply perm_eq_up_to_C_mono; last done.
- 1: apply Hwf1.
- all: eassumption.
- Qed.
-
- Lemma item_eq_up_to_C_mono C1 d tr1 tr2 tg it1 it2 nxtc nxtp :
- item_wf it1 nxtp nxtc →
- tree_items_compat_nexts tr1 nxtp nxtc →
- tree_items_compat_nexts tr2 nxtp nxtc →
- wf_tree tr1 →
- wf_tree tr2 →
- item_eq_up_to_C C1 tr1 tr2 tg d it1 it2 →
- item_eq_up_to_C (C1 ∪ {[ nxtc ]}) tr1 tr2 tg d it1 it2.
- Proof.
- intros Hss Hwf_all1 Hwf_all2 Hwf_tr1 Hwf_tr2 H1 l.
- specialize (H1 l). by eapply loc_eq_up_to_C_mono.
- Qed.
-
- Lemma tree_equal_mono C1 d tr1 tr2 nxtc nxtp :
- tree_items_compat_nexts tr1 nxtp nxtc →
- tree_items_compat_nexts tr2 nxtp nxtc →
- wf_tree tr1 →
- wf_tree tr2 →
- tree_equal C1 d tr1 tr2 →
- tree_equal (C1 ∪ {[ nxtc ]}) d tr1 tr2.
- Proof.
- intros Hss Hss2 Hwf_tr1 Hwf_tr2 (H1&H2&H3). do 2 (split; first done).
- intros tg (it1&it2&H4&H5&H6)%H3.
- exists it1, it2. split_and!; try done.
- eapply item_eq_up_to_C_mono; try done.
- setoid_rewrite every_node_eqv_universal in Hss.
- apply Hss. eapply tree_lookup_to_exists_node.
- erewrite <-tree_lookup_correct_tag in H4; done.
- Qed.
-
- Lemma trees_equal_mono C1 d trs1 trs2 nxtc nxtp :
- trees_compat_nexts trs1 nxtp nxtc →
- trees_compat_nexts trs2 nxtp nxtc →
- wf_trees trs1 →
- wf_trees trs2 ->
- trees_equal C1 d trs1 trs2 →
- trees_equal (C1 ∪ {[ nxtc ]}) d trs1 trs2.
- Proof.
- intros Hss Hss2 Hwf_trs1 Hwf_trs2 Heq blk. specialize (Heq blk). inversion Heq; simplify_eq.
- all: econstructor; try done.
- eapply tree_equal_mono; try done.
- + eapply Hss. done.
- + eapply Hss2. done.
- + eapply Hwf_trs1. done.
- + eapply Hwf_trs2. done.
- Qed.
-
-End call_set.
-
-
diff --git a/theories/tree_borrows/trees_equal/trees_equal_asymmetric_prot.v b/theories/tree_borrows/trees_equal/trees_equal_asymmetric_prot.v
index 5bf54797952e7fc155966aeeca2f4609ba542644..4c081cee9ea29cae84d8ad35909e3f13d5f2c98b 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_asymmetric_prot.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_asymmetric_prot.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -12,7 +11,6 @@ From simuliris.tree_borrows Require Import steps_progress.
From simuliris.tree_borrows.trees_equal Require Import trees_equal_base random_lemmas.
From iris.prelude Require Import options.
-(* TODO cleanup *)
Section utils.
Context (C : call_id_set).
@@ -304,4 +302,4 @@ Context (C : call_id_set).
destruct (item_lookup it0 loc) as [ii pp]. simpl in *; subst ii pp. econstructor 1.
Qed.
-End utils.
\ No newline at end of file
+End utils.
diff --git a/theories/tree_borrows/trees_equal/trees_equal_base.v b/theories/tree_borrows/trees_equal/trees_equal_base.v
index 508e3a311bec21acd8c8d9131c60e2b603941b81..8c0500b124be830ac4cdacea099a18cd0f9b5ee2 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_base.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_base.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -12,8 +11,6 @@ From simuliris.tree_borrows Require Import steps_progress.
From simuliris.tree_borrows Require Export trees_equal.disabled_in_practice.
From iris.prelude Require Import options.
-
-(* TODO cleanup *)
Section utils.
Definition tag_valid (upper : tag) (n : tag) : Prop := (n < upper)%nat.
@@ -151,7 +148,6 @@ Section utils.
(* and define all the same relationships between those tags *)
/\ (forall tg tg', rel_dec tr1 tg tg' = rel_dec tr2 tg tg')
(* and have their permissions be equal up to C on all locations *)
- (* FIXME: maybe think about reformulating ∧ (∀ t it1 it2, tree_lookup t it1 tr1 -> tree_lookup t it2 tr2 -> it_rel it1 it2) *)
/\ (forall tg, tree_contains tg tr1 ->
exists it1 it2,
tree_lookup tr1 tg it1
diff --git a/theories/tree_borrows/trees_equal/trees_equal_create_child.v b/theories/tree_borrows/trees_equal/trees_equal_create_child.v
index cd1d22fdcfe7eb410ebd5ec77ff01730b06b5db3..e9b0cb19f1bc003a73078ae1cd4fdca4bdffb7d2 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_create_child.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_create_child.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -12,7 +11,6 @@ From simuliris.tree_borrows Require Import steps_progress.
From simuliris.tree_borrows.trees_equal Require Import trees_equal_base random_lemmas.
From iris.prelude Require Import options.
-(* TODO cleanup *)
Section utils.
Context (C : call_id_set).
@@ -387,4 +385,4 @@ Context (C : call_id_set).
Qed.
-End utils.
\ No newline at end of file
+End utils.
diff --git a/theories/tree_borrows/trees_equal/trees_equal_initcall.v b/theories/tree_borrows/trees_equal/trees_equal_initcall.v
index 10c03dc2a07980a59bfd05ace6a18233c74f27e0..dbb1a8883e64b0edec994a08f1d8ac561a6bf9f8 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_initcall.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_initcall.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
diff --git a/theories/tree_borrows/trees_equal/trees_equal_more_access.v b/theories/tree_borrows/trees_equal/trees_equal_more_access.v
index 747c550bee3bd50e8defb09e93a8feadcb78be63..c6382850a64bdd89baf2278335d4c907b355eff6 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_more_access.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_more_access.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -12,7 +11,6 @@ From simuliris.tree_borrows Require Import steps_progress.
From simuliris.tree_borrows.trees_equal Require Import trees_equal_base random_lemmas.
From iris.prelude Require Import options.
-(* TODO cleanup *)
Section utils.
Context (C : call_id_set).
@@ -79,11 +77,6 @@ Section utils.
We now need to prove that actually there is also UB in the source,
just not _here_, instead it occured at the cousin that creates the conflict. *)
all: exfalso.
- (* FIXME: here we need a lemma that shows
- 1. a Child/This access for tg is Foreign for tg_cous who is Cousin of tg
- 2. a Foreign access for such tg_cous is UB globally.
- We can indeed check that in all of the following cases we have
- rel = This or rel = Child and kind = AccessWrite. *)
all: eapply cousin_write_for_initialized_protected_nondisabled_is_ub.
all: try exact GlobalSuccess.
all: try eassumption.
diff --git a/theories/tree_borrows/trees_equal/trees_equal_preserved_by_access.v b/theories/tree_borrows/trees_equal/trees_equal_preserved_by_access.v
index 0fd6ff7f10f7ddc03139a1983b49d977bb59a813..17f81ed1504a5cdc633a37573a81fa16d6881295 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_preserved_by_access.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_preserved_by_access.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -13,7 +12,6 @@ From simuliris.tree_borrows.trees_equal Require Import trees_equal_base random_l
From simuliris.tree_borrows.trees_equal Require Export trees_equal_preserved_by_access_base.
From iris.prelude Require Import options.
-(* TODO cleanup *)
Section utils.
Context (C : call_id_set).
diff --git a/theories/tree_borrows/trees_equal/trees_equal_preserved_by_access_base.v b/theories/tree_borrows/trees_equal/trees_equal_preserved_by_access_base.v
index b40e646e177a081118228a1b02e905343af7158e..b0e6444ac195c68aa5e2388e026fb0e21db827f4 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_preserved_by_access_base.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_preserved_by_access_base.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -12,7 +11,6 @@ From simuliris.tree_borrows Require Import steps_progress.
From simuliris.tree_borrows.trees_equal Require Import trees_equal_base random_lemmas.
From iris.prelude Require Import options.
-(* TODO cleanup *)
Section utils.
Context (C : call_id_set).
diff --git a/theories/tree_borrows/trees_equal/trees_equal_source_read.v b/theories/tree_borrows/trees_equal/trees_equal_source_read.v
index 0f0b65b17690aaf3b7c7900ffe1a3cc59ec97b91..902f3963a39d6c7d82c09ac2b1c1742a1f2ff956 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_source_read.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_source_read.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -12,7 +11,6 @@ From simuliris.tree_borrows Require Import steps_progress.
From simuliris.tree_borrows.trees_equal Require Import trees_equal_base random_lemmas.
From iris.prelude Require Import options.
-(* TODO cleanup *)
Section utils.
Context (C : call_id_set).
@@ -132,4 +130,4 @@ Context (C : call_id_set).
destruct pp; try done. all: repeat (simpl in *; simplify_eq); by econstructor 1.
Qed.
-End utils.
\ No newline at end of file
+End utils.
diff --git a/theories/tree_borrows/trees_equal/trees_equal_transitivity.v b/theories/tree_borrows/trees_equal/trees_equal_transitivity.v
index 4906727bc23d759a663d21fafd4e80ad5665118c..9ebf91f1563912994ba5254b1856bdab590e27cc 100644
--- a/theories/tree_borrows/trees_equal/trees_equal_transitivity.v
+++ b/theories/tree_borrows/trees_equal/trees_equal_transitivity.v
@@ -1,4 +1,3 @@
-(** This file provides the basic heap and ghost state support for the BorIngLang program logic. *)
From iris.proofmode Require Export proofmode.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import ghost_map.
@@ -12,7 +11,6 @@ From simuliris.tree_borrows Require Import steps_progress.
From simuliris.tree_borrows.trees_equal Require Import trees_equal_base random_lemmas.
From iris.prelude Require Import options.
-(* TODO cleanup *)
Section utils.
Context (C : call_id_set).
@@ -617,4 +615,4 @@ Context (C : call_id_set).
Qed.
-End utils.
\ No newline at end of file
+End utils.
diff --git a/theories/tree_borrows/wf.v b/theories/tree_borrows/wf.v
index f8e145f6d4c7bd13ca519b8c8ae51eb36b504ffd..2926d2d79985102823d08544bd9ae4588e029311 100755
--- a/theories/tree_borrows/wf.v
+++ b/theories/tree_borrows/wf.v
@@ -25,7 +25,7 @@ Section expr_wf.
Fixpoint gen_expr_wf (e : expr) : Prop :=
expr_head_wf (expr_split_head e).1 ∧
match e with
- (** [value_wf v] should be part of [expr_head_wf (Val v)] because
+ (** NOTE: [value_wf v] could be part of [expr_head_wf (Val v)] because
[log_rel_structural] only provides [expr_head_wf]. *)
| Val v => True
| Var x => True
@@ -44,7 +44,7 @@ Section expr_wf.
| Case e branches => gen_expr_wf e ∧ Forall id (fmap gen_expr_wf branches)
| While e1 e2 => gen_expr_wf e1 ∧ gen_expr_wf e2
| Fork e => gen_expr_wf e
- (* These should have been handled by [expr_head_wf]. *)
+ (* NOTE: These could also have been handled by [expr_head_wf]. *)
| EndCall e => gen_expr_wf e
| InitCall => True (* administrative *)
| Place _ _ _ => True (* literal pointers *)
diff --git a/theories/tree_borrows/wishlist.v b/theories/tree_borrows/wishlist.v
index e5ea6c2b6ddbf7fb540c3a917016c08e659466b3..2e59c69552f03b3cc7d2ae15ea0704331da9b7dc 100644
--- a/theories/tree_borrows/wishlist.v
+++ b/theories/tree_borrows/wishlist.v
@@ -1,14 +1,10 @@
+(** Reexports that are so universal that not including them here would make the
+ size of every other Require Import list explode. *)
From iris.proofmode Require Export proofmode.
From simuliris.tree_borrows Require Export tree_access_laws tag_protected_laws loc_controlled_laws.
-From iris.base_logic.lib Require Import ghost_map.
From simuliris.base_logic Require Export gen_sim_prog.
From simuliris.simulation Require Export slsls.
-From simuliris.simulation Require Import lifting.
-From simuliris.tree_borrows Require Import tkmap_view.
From simuliris.tree_borrows Require Export defs class_instances.
-From simuliris.tree_borrows Require Import steps_progress steps_inv.
-From simuliris.tree_borrows Require Import logical_state inv_accessors.
-From simuliris.tree_borrows.trees_equal Require Import trees_equal_base random_lemmas.
From iris.prelude Require Import options.