From edf82ba06775ee1f8a06f33e4791ffa08faa7c28 Mon Sep 17 00:00:00 2001 From: June Rousseau Date: Thu, 16 Jan 2025 18:32:01 +0100 Subject: [PATCH] WIP import griotte --- _CoqProject | 8 +- theories/examples/macros/macros.v | 3 +- theories/exercises/cerise_modularity.v | 255 ---- .../exercises/cerise_modularity_solutions.v | 380 ----- theories/exercises/cerise_tutorial.v | 406 ------ .../exercises/cerise_tutorial_solutions.v | 197 --- theories/exercises/increment.v | 724 ---------- theories/exercises/restrict_buffer.v | 568 -------- theories/exercises/subseg_buffer.v | 503 ------- theories/exercises/subseg_buffer_call.v | 1175 ---------------- theories/exercises/subseg_buffer_closure.v | 447 ------ theories/exercises/subseg_buffer_malloc.v | 389 ------ theories/ftlr/AddSubLt.v | 116 +- theories/ftlr/Get.v | 50 +- theories/ftlr/GetWType.v | 57 - theories/ftlr/Load.v | 441 +++--- theories/ftlr/Mov.v | 141 +- theories/ftlr/Seal.v | 101 +- theories/ftlr/Store.v | 533 ++++--- theories/ftlr/UnSeal.v | 180 ++- theories/ftlr/ftlr_base.v | 84 +- theories/ftlr/interp_weakening.v | 565 +++++++- theories/logrel.v | 921 +++++++----- theories/monotone.v | 1137 +++++++++++---- theories/monotone_resource.v | 315 +++++ theories/proofmode/map_simpl_test.v | 2 +- theories/proofmode/region.v | 421 ++++++ theories/region_invariants.v | 1229 +++++++++++++++++ theories/region_invariants_transitions.v | 238 ++++ theories/rules_binary.v | 9 - theories/sts.v | 1107 +++++++++++++++ 31 files changed, 6178 insertions(+), 6524 deletions(-) delete mode 100644 theories/exercises/cerise_modularity.v delete mode 100644 theories/exercises/cerise_modularity_solutions.v delete mode 100644 theories/exercises/cerise_tutorial.v delete mode 100644 theories/exercises/cerise_tutorial_solutions.v delete mode 100644 theories/exercises/increment.v delete mode 100644 theories/exercises/restrict_buffer.v delete mode 100644 theories/exercises/subseg_buffer.v delete mode 100644 theories/exercises/subseg_buffer_call.v delete mode 100644 theories/exercises/subseg_buffer_closure.v delete mode 100644 theories/exercises/subseg_buffer_malloc.v delete mode 100644 theories/ftlr/GetWType.v create mode 100644 theories/monotone_resource.v create mode 100644 theories/region_invariants.v create mode 100644 theories/region_invariants_transitions.v delete mode 100644 theories/rules_binary.v create mode 100644 theories/sts.v diff --git a/_CoqProject b/_CoqProject index 796aaee7..c1d835c0 100644 --- a/_CoqProject +++ b/_CoqProject @@ -61,6 +61,13 @@ theories/proofmode/proofmode_instr_rules.v theories/proofmode/proofmode.v theories/proofmode/register_tactics.v +# MCerise +theories/sts.v +theories/region_invariants.v +theories/region_invariants_transitions.v +theories/monotone.v + + # Unary Logical Relation theories/seal_store.v theories/logrel.v @@ -81,7 +88,6 @@ theories/ftlr/UnSeal.v theories/fundamental.v # Misc for examples -theories/monotone.v theories/examples/addr_reg_sample.v theories/proofmode/disjoint_regions_tactics.v theories/proofmode/mkregion_helpers.v diff --git a/theories/examples/macros/macros.v b/theories/examples/macros/macros.v index dd0c628f..da7ebc35 100644 --- a/theories/examples/macros/macros.v +++ b/theories/examples/macros/macros.v @@ -3,7 +3,8 @@ From iris.proofmode Require Import proofmode. Require Import Eqdep_dec List. From cap_machine Require Import rules logrel. From cap_machine.proofmode Require Import tactics_helpers map_simpl solve_pure. -From cap_machine Require Export iris_extra addr_reg_sample contiguous malloc assert. +From cap_machine Require Export iris_extra addr_reg_sample contiguous. +From cap_machine Require Export malloc assert. Section macros. Context {Σ:gFunctors} {ceriseg:ceriseG Σ} diff --git a/theories/exercises/cerise_modularity.v b/theories/exercises/cerise_modularity.v deleted file mode 100644 index fa33495e..00000000 --- a/theories/exercises/cerise_modularity.v +++ /dev/null @@ -1,255 +0,0 @@ -(** This file is a tutorial to learn how to use the Cerise Program Logic within Coq. - We will use the modularity of the program logic to use the specification of - a macro in a program, and show how the macro can be linked via a linking table. - - Prerequisites: - We assume the user has already followed the first part of the tutorial - "cerise_tutorial.v" and is able to prove the specification of a program - with known code using the Cerise Proof Mode. *) - -From iris.proofmode Require Import tactics. -From cap_machine Require Import rules macros_new. -From cap_machine.proofmode Require Import - proofmode tactics_helpers register_tactics. -Open Scope Z_scope. - -Section increment_macro. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - (** The increment macro is a macro that takes a register r (r ≠ r_env), which - contains a capability C with a permission p ≤ RW, that points to - an integer n. The macro increments the value of the integer. - The macro uses the register r_env to perform the arithmetic, and clear - the result of the register. - *) - Definition incr_instrs r r_env : list Word := - encodeInstrsW [ - Load r_env r; - Add r_env r_env 1; - Store r r_env; - Mov r_env 0 - ]. - - (** Specification of the macro. The proof is an optional exercise. *) - Lemma incr_macro_spec - p_pc b_pc e_pc a_prog (* pc *) - r r_env (* registers of the macro *) - p (e b a : Addr) n (* capability *) - w_env - φ : - - let e_prog := (a_prog ^+ length (incr_instrs r r_env))%a in - r <> r_env → - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog e_prog → - - b ≤ a < e → (* a is in the bounds of the capability *) - writeAllowed p = true → (* p can Read/Write *) - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog*) - ∗ codefrag a_prog (incr_instrs r r_env) (* the prog instruction start at a_prog *) - ∗ r ↦ᵣ WCap p b e a (* r contains the capability *) - ∗ r_env ↦ᵣ w_env (* ownership of r_env *) - ∗ a ↦ₐ WInt n (* content of a, which is an integer *) - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r ↦ᵣ WCap p b e a - ∗ r_env ↦ᵣ WInt 0 (* cleared register *) - ∗ a ↦ₐ WInt (n + 1) (* incremented value *) - ∗ codefrag a_prog (incr_instrs r r_env) - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - (* FILL IN HERE *) - Admitted. - - (** The increment macro is just a list of instructions. In particular, - it can be used as a part of a bigger list of instructions. - The specification assumes that the PCC points to the first address of the - macro, and the list of instructions is _included_ into the bounds of the - PCC: thus, the specification can be used in the proof of the specification - of a bigger program. - - The macros are a way to define the program modularly. - For such short macro, the modularity is a bit "too much", but dealing - with larger and complex macros (e.g. involving a loop), this modularity - is necessary. *) - - (** The following is a very simple example of program that uses the macro. The - program assumes that R0 contains a writing capability pointing to the - memory. It initializes the value of this memory address at 0, calls the - increment macro to increment the value, and finally loads the - incremented value in the register R1. - - The reader may notice 3 blocks of instructions, separated by the `++` - operator. The proof will leverage this block separation using new - `focus_block` tactics, detailled in `proofmode.md`, section `Focusing a - sub-block`. They allow us to focus on a block, prove its specification - locally, and then continue the proof of the global program. - *) - Definition prog_instrs: list Word := - encodeInstrsW [ Store r_t0 0 ] ++ - incr_instrs r_t0 r_t1 ++ - encodeInstrsW [ Load r_t1 r_t0 ]. - - - Lemma prog_spec - p_pc b_pc e_pc a_prog (* pc *) - p (e b a : Addr) w (* capability *) - w_env - φ : - - let e_prog := (a_prog ^+ length prog_instrs)%a in - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog e_prog → - - b ≤ a < e → (* a is in the bounds of the capability *) - writeAllowed p = true → (* p can Read/Write *) - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog *) - ∗ codefrag a_prog prog_instrs (* the prog instruction start at a_prog *) - ∗ r_t0 ↦ᵣ WCap p b e a (* r_t0 contains the capability *) - ∗ r_t1 ↦ᵣ w_env (* ownership of r_t1 *) - ∗ a ↦ₐ w (* content of a *) - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_t0 ↦ᵣ WCap p b e a (* r_t0 contains the capability *) - ∗ r_t1 ↦ᵣ WInt 1 (* ownership of r_t1 *) - ∗ a ↦ₐ WInt 1 (* incremented value *) - ∗ codefrag a_prog prog_instrs - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hpc_perm Hpc_bounds Ha_bounds Hperm. - iIntros "(HPC & Hprog & Hr & Hrenv & Ha & Hcont)". - - (* 1 - prepare the assertions for the proof *) - subst e_prog; simpl. - simpl in *. - - (* We use the new tactic to focus on the first block. *) - (* Initialisation block *) - focus_block_0 "Hprog" as "Hintro" "Hnext". - iInstr "Hintro"; [ by rewrite withinBounds_true_iff |]. - unfocus_block "Hintro" "Hnext" as "Hprog". - - (* Increment macro *) - focus_block 1%nat "Hprog" as a_incr Ha_incr "Hincr" "Hnext". - - (* We use the specification of the macro. *) - iApply (incr_macro_spec with "[- $HPC $Hincr $Hr $Hrenv $Ha]"); eauto. - iIntros "!> (HPC & Hr & Hrenv & Ha & Hincr)". - - unfocus_block "Hincr" "Hnext" as "Hprog". - - focus_block 2%nat "Hprog" as a_end Ha_end "Hend" "Hnext". - iGo "Hend". - { split. - - by apply writeA_implies_readA. - - by rewrite withinBounds_true_iff. } - unfocus_block "Hend" "Hnext" as "Hprog". - - (* 3 - continuation *) - iApply "Hcont". - simpl in *. - replace (a_end ^+ 1)%a with (a_prog ^+ 6%nat)%a by solve_addr. - iFrame. - Qed. -End increment_macro. - -Section rclear_macro. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - (** In this section, we will use a pre-defined macro in Cerise, `rclear`. - `rclear` is a macro that clears (puts 0) the list of registers given as - argument. *) - - (** The following program assumes that the register r0 contains a capability - that points to a buffer with at least 2 integers. - It performs the addition of the 2 integers of the buffer and stores the - result at the address of the second integer. - Then, it clears all the used registers (to remove every trace of - the computations) and halts the machine. *) - Definition secret_add_instrs: list Word := - encodeInstrsW [ - Load r_t1 r_t0; - Lea r_t0 1; - Load r_t2 r_t0; - Add r_t1 r_t1 r_t2; - Store r_t0 r_t1 - ] ++ rclear_instrs [r_t0; r_t1; r_t2] ++ encodeInstrsW [Halt]. - - (** **** Exercise 3 --- Secret addition - Define the lemma `secret_add_spec` that specifies the program - `secret_add_instrs` and prove it. - - Use the tactics to focus and unfocus the block. - The specification of the `rclear` macro is `rclear_spec`, - defined in the file `theories/examples/macros_new.v`. - - Hint (specification): TODO ??? - Hint (proof): The specification of `rclear` requires the use of - the `big_sepM` resource. The `big_sepM` resource [...] use a map. - We urge the reader to search lemmas about `big_sepM` and - `gmap`. - - Hint (proof): useful lemmas - - big_sepM_insert - - big_sepM_insert_delete - - delete_insert_ne - - delete_empty - *) - -End rclear_macro. - -Section linking_table. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - (* Demo with incr_macro for the setup *) - - (* Exercices using malloc and assert *) - -End linking_table. - - - (** Outline - 2 steps: - 1. use the macro in the middle of the code (as a real macro) - 2. capture the macro into a sentry-capability (as a function), and use a linking table - - 1.1) Demo - Define a program that use this specification that do the following: - - takes a capability input - - store 0 into it - - use the increment macro - - 1.2) Exercise - Exercise with the rclear macro: specify and prove - - 2.1) Demo - Same program as 1.1, but the increment macro is reachable via - the linking table (instead of inlined). - It requires some boilerplate about the linking table and shows - how to set it up. - - 2.2) Exercise - At last exercise, the reader should be able to use the Cerise macros, - so why not a program that does the following: - - dyn alloc a region of memory with malloc - - stores 42 in the last adresse - - assert it is 42 - - Finally, list the macros available in Cerise *) - - - (** Now that you are familiar with the Cerise Proofmode, - we recommand to try defining a program by yourself, as - well as its specification. - We also recommand to continue the tutorial with - TODO (next file) to learn how to define the specification, - how to use the logical relation to reason with unknown code, - and how to deal with local encapsulation, using the call macro. - *) diff --git a/theories/exercises/cerise_modularity_solutions.v b/theories/exercises/cerise_modularity_solutions.v deleted file mode 100644 index c0d01db1..00000000 --- a/theories/exercises/cerise_modularity_solutions.v +++ /dev/null @@ -1,380 +0,0 @@ -(** This file is a tutorial to learn how to use the Cerise Program Logic within Coq. - We will use the modularity of the program logic to use the specification of - a macro in a program, and show how the macro can be linked via a linking table. - - Prerequisites: - We assume the user has already followed the first part of the tutorial - "cerise_tutorial.v" and is able to prove the specification of a program - with known code using the Cerise Proof Mode. *) - -From iris.proofmode Require Import tactics. -From cap_machine Require Import rules macros_new. -From cap_machine.proofmode Require Import proofmode tactics_helpers register_tactics. -Open Scope Z_scope. - -Section increment_macro. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - (** The increment macro is a macro that takes a register r (r ≠ r_env), which - contains a capability C with a permission p ≤ RW, that points to - an integer n. The macro increments the value of the integer. - The macro uses the register r_env to perform the arithmetic, and clear - the result of the register. - *) - Definition incr_instrs r r_env : list Word := - encodeInstrsW [ - Load r_env r; - Add r_env r_env 1; - Store r r_env; - Mov r_env 0 - ]. - - (** Specification of the macro. The proof is an optional exercise. *) - Lemma incr_macro_spec - p_pc b_pc e_pc a_prog (* pc *) - r r_env (* registers of the macro *) - p (e b a : Addr) n (* capability *) - w_env - φ : - - let e_prog := (a_prog ^+ length (incr_instrs r r_env))%a in - r <> r_env → - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog e_prog → - - b ≤ a < e → (* a is in the bounds of the capability *) - writeAllowed p = true → (* p can Read/Write *) - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog*) - ∗ codefrag a_prog (incr_instrs r r_env) (* the prog instruction start at a_prog *) - ∗ r ↦ᵣ WCap p b e a (* r contains the capability *) - ∗ r_env ↦ᵣ w_env (* ownership of r_env *) - ∗ a ↦ₐ WInt n (* content of a, which is an integer *) - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r ↦ᵣ WCap p b e a - ∗ r_env ↦ᵣ WInt 0 (* cleared register *) - ∗ a ↦ₐ WInt (n + 1) (* incremented value *) - ∗ codefrag a_prog (incr_instrs r r_env) - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hregs Hpc_perm Hpc_bounds Ha_bounds Hperm. - iIntros "(HPC & Hprog & Hr & Hrenv & Ha & Hcont)". - - (* 1 - prepare the assertions for the proof *) - subst e_prog; simpl. - codefrag_facts "Hprog". - simpl in *. - - (* 2 - wp rules for each instructions *) - (* Perform Load r_env r *) - iInstr "Hprog". - { split. - - by apply writeA_implies_readA. - - by rewrite withinBounds_true_iff. } - - (* Perform Add r_env r_env 1 *) - (* Perform Store r r_env *) - iGo "Hprog". - { by rewrite withinBounds_true_iff. } - - (* Perform Mov r_env 0 *) - iInstr "Hprog". - - (* 3 - Verify post condition *) - iApply "Hcont"; iFrame. - Qed. - - (** The increment macro is just a list of instructions. In particular, - it can be used as a part of a bigger list of instructions. - The specification assumes that the PCC points to the first address of the - macro, and the list of instructions is _included_ into the bounds of the - PCC: thus, the specification can be used in the proof of the specification - of a bigger program. - - The macros are a way to define the program modularly. - For such short macro, the modularity is a bit "too much", but dealing - with larger and complex macros (e.g. involving a loop), this modularity - is necessary. - *) - - (** The following is a very simple example of program that uses the macro. The - program assumes that R0 contains a writing capability pointing to the - memory. It initializes the value of this memory address at 0, calls the - increment macro to increment the value, and finally loads the - incremented value in the register R1. - - The reader may notice 3 blocks of instructions, separated by the `++` - operator. The proof will leverage this block separation using new - `focus_block` tactics, detailled in `proofmode.md`, section `Focusing a - sub-block`. They allow us to focus on a block, prove its specification - locally, and then continue the proof of the global program. - *) - Definition prog_instrs: list Word := - encodeInstrsW [ Store r_t0 0 ] ++ - incr_instrs r_t0 r_t1 ++ - encodeInstrsW [ Load r_t1 r_t0 ]. - - - Lemma prog_spec - p_pc b_pc e_pc a_prog (* pc *) - p (e b a : Addr) w (* capability *) - w_env - φ : - - let e_prog := (a_prog ^+ length prog_instrs)%a in - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog e_prog → - - b ≤ a < e → (* a is in the bounds of the capability *) - writeAllowed p = true → (* p can Read/Write *) - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog *) - ∗ codefrag a_prog prog_instrs (* the prog instruction start at a_prog *) - ∗ r_t0 ↦ᵣ WCap p b e a (* r_t0 contains the capability *) - ∗ r_t1 ↦ᵣ w_env (* ownership of r_t1 *) - ∗ a ↦ₐ w (* content of a *) - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_t0 ↦ᵣ WCap p b e a (* r_t0 contains the capability *) - ∗ r_t1 ↦ᵣ WInt 1 (* ownership of r_t1 *) - ∗ a ↦ₐ WInt 1 (* incremented value *) - ∗ codefrag a_prog prog_instrs - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hpc_perm Hpc_bounds Ha_bounds Hperm. - iIntros "(HPC & Hprog & Hr & Hrenv & Ha & Hcont)". - - (* 1 - prepare the assertions for the proof *) - subst e_prog; simpl. - simpl in *. - - (* We use the new tactic to focus on the first block. *) - (* Initialisation block *) - focus_block_0 "Hprog" as "Hintro" "Hnext". - iInstr "Hintro"; [ by rewrite withinBounds_true_iff |]. - unfocus_block "Hintro" "Hnext" as "Hprog". - - (* Increment macro *) - focus_block 1%nat "Hprog" as a_incr Ha_incr "Hincr" "Hnext". - - (* We use the specification of the macro. *) - iApply (incr_macro_spec with "[- $HPC $Hincr $Hr $Hrenv $Ha]"); eauto. - iIntros "!> (HPC & Hr & Hrenv & Ha & Hincr)". - - unfocus_block "Hincr" "Hnext" as "Hprog". - - focus_block 2%nat "Hprog" as a_end Ha_end "Hend" "Hnext". - iGo "Hend". - { split. - - by apply writeA_implies_readA. - - by rewrite withinBounds_true_iff. } - unfocus_block "Hend" "Hnext" as "Hprog". - - (* 3 - continuation *) - iApply "Hcont". - simpl in *. - replace (a_end ^+ 1)%a with (a_prog ^+ 6%nat)%a by solve_addr. - iFrame. - Qed. - -End increment_macro. - -Section rclear_macro. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - (** In this section, we will use a pre-defined macro in Cerise, `rclear`. - `rclear` is a macro that clears (puts 0) the list of registers given as - argument. *) - - (** The following program assumes that the register r0 contains a capability - that points to a buffer with at least 2 integers. - It performs the addition of the 2 integers of the buffer and stores the - result at the address of the second integer. - Then, it clears all the used registers (to remove every trace of - the computations) and halts the machine. *) - Definition secret_add_instrs: list Word := - encodeInstrsW [ - Load r_t1 r_t0; - Lea r_t0 1; - Load r_t2 r_t0; - Add r_t1 r_t1 r_t2; - Store r_t0 r_t1 - ] ++ rclear_instrs [r_t0; r_t1; r_t2] ++ encodeInstrsW [Halt]. - - (** **** Exercise 3 --- Secret addition - Define the lemma `secret_add_spec` that specifies the program - `secret_add_instrs` and prove it. - - Use the tactics to focus and unfocus the block. - The specification of the `rclear` macro is `rclear_spec`, - defined in the file `theories/examples/macros_new.v`. - - Hint (specification): TODO ??? - Hint (proof): The specification of `rclear` requires the use of - the `big_sepM` resource. The `big_sepM` resource [...] use a map. - We urge the reader to search lemmas about `big_sepM` and - `gmap`. - - Hint (proof): useful lemmas - - big_sepM_insert - - big_sepM_insert_delete - - delete_insert_ne - - delete_empty - *) - Lemma secret_add_spec - p_pc b_pc e_pc a_prog (* pc *) - p (e b a : Addr) (* capability *) - w1 w2 n1 n2 - φ : - - let e_prog := (a_prog ^+ length secret_add_instrs)%a in - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog e_prog → - - b + 2 < e → (* a is in the bounds of the capability *) - writeAllowed p = true → (* p can Read/Write *) - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog *) - ∗ codefrag a_prog secret_add_instrs (* the prog instruction start at a_prog *) - ∗ r_t0 ↦ᵣ WCap p b e b (* r_t0 contains the capability *) - ∗ r_t1 ↦ᵣ w1 (* ownership of r_t1 *) - ∗ r_t2 ↦ᵣ w2 (* ownership of r_t2 *) - ∗ b ↦ₐ WInt n1 (* content of a *) - ∗ (b ^+ 1)%a ↦ₐ WInt n2 (* content of a *) - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc (a_prog ^+ (length secret_add_instrs - 1))%a - ∗ r_t0 ↦ᵣ WInt 0 (* ownership of r_t0 *) - ∗ r_t1 ↦ᵣ WInt 0 (* ownership of r_t1 *) - ∗ r_t2 ↦ᵣ WInt 0 (* ownership of r_t2 *) - ∗ b ↦ₐ WInt n1 (* content of a *) - ∗ (b ^+ 1)%a ↦ₐ WInt (n1 + n2) (* content of a *) - ∗ codefrag a_prog secret_add_instrs (* the prog instruction start at a_prog *) - -∗ WP Instr Halted {{ v, φ v }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hpc_perm Hpc_bounds Ha_bounds Hperm. - iIntros "(HPC & Hprog & Hr0 & Hr1 & Hr2 & Hb0 & Hb1 & Hcont)". - - (* 1 - prepare the assertions for the proof *) - subst e_prog; simpl in *. - - (* We use the new tactic to focus on the first block. *) - (* Initialisation block *) - focus_block_0 "Hprog" as "Hintro" "Hnext". - - iInstr "Hintro". - { split; - [ by apply writeA_implies_readA - | rewrite withinBounds_true_iff; solve_addr +Ha_bounds ]. } - - iInstr "Hintro". - { transitivity (Some (b ^+ 1)%a); solve_addr +Ha_bounds. } - { destruct p; auto. } - - iInstr "Hintro". - { split; - [ by apply writeA_implies_readA - | rewrite withinBounds_true_iff; solve_addr +Ha_bounds]. } - - iInstr "Hintro". - iInstr "Hintro". - { rewrite withinBounds_true_iff; solve_addr +Ha_bounds. } - - unfocus_block "Hintro" "Hnext" as "Hprog". - - (* rclear macro block *) - focus_block 1%nat "Hprog" as a_clear Ha_clear "Hclear" "Hnext". - - (* We use the specification of the macro. The macro requires a mapping of - the register to their current value. We already instantiate the mapping. *) - set rmap: gmap RegName Word := {[ - r_t0 := WCap p b e (b ^+ 1)%a; - r_t1 := WInt (n1 + n2); - r_t2 := WInt n2 - ]}. - - iApply (rclear_spec _ rmap with "[- $Hclear $HPC]"); - eauto; - [ set_solver .. | ]. - - iSplitL "Hr0 Hr1 Hr2"; iNext. - { (* We need to transform the different resources of registers into a - single resource, the big_sepM resource. *) - by repeat (iApply big_sepM_insert; [auto | iFrame]). } - - iIntros "(HPC & Hrmap & Hclear)". - - unfocus_block "Hclear" "Hnext" as "Hprog". - - (* Final block, which is just the halting instruction. *) - focus_block 2%nat "Hprog" as a_end Ha_end "Hend" "Hnext". - iGo "Hend". - unfocus_block "Hend" "Hnext" as "Hprog". - - (* 3 - continuation *) - iApply "Hcont". - simpl in *. - replace ((a_prog ^+ (9%nat - 1))%a) with a_end by solve_addr. - iFrame. - - (* It only remains to extract the registers from the mapping. *) - iExtractList "Hrmap" [ r_t0; r_t1; r_t2 ] as [ "Hr0"; "Hr1"; "Hr2" ]. - iFrame. - Qed. - -End rclear_macro. - -Section linking_table. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - (* Demo with incr_macro for the setup *) - - (* Exercices using malloc and assert *) - - End linking_table. - - - (** Outline - 2 steps: - 1. use the macro in the middle of the code (as a real macro) - 2. capture the macro into a sentry-capability (as a function), and use a linking table - - 1.1) Demo - Define a program that use this specification that do the following: - - takes a capability input - - store 0 into it - - use the increment macro - - 1.2) Exercise - Exercise with the rclear macro: specify and prove - - 2.1) Demo - Same program as 1.1, but the increment macro is reachable via - the linking table (instead of inlined). - It requires some boilerplate about the linking table and shows - how to set it up. - - 2.2) Exercise - At last exercise, the reader should be able to use the Cerise macros, - so why not a program that does the following: - - dyn alloc a region of memory with malloc - - stores 42 in the last adresse - - assert it is 42 - - Finally, list the macros available in Cerise *) - - - (** Now that you are familiar with the Cerise Proofmode, - we recommand to try defining a program by yourself, as - well as its specification. - We also recommand to continue the tutorial with - TODO (next file) to learn how to define the specification, - how to use the logical relation to reason with unknown code, - and how to deal with local encapsulation, using the call macro. - *) diff --git a/theories/exercises/cerise_tutorial.v b/theories/exercises/cerise_tutorial.v deleted file mode 100644 index e770d2f0..00000000 --- a/theories/exercises/cerise_tutorial.v +++ /dev/null @@ -1,406 +0,0 @@ -(** This file is a tutorial to learn how to use the Cerise Program Logic within Coq. - We will specify a simple program and explain how to use the tactics of the - Cerise Proofmode to prove the specification. - - Prerequisites: - We assume the user already knows how to use Iris and the Iris Proofmode, - for instance with Heaplang. Learning material for Iris is available - at this URL: https://iris-project.org/ *) - -From iris.proofmode Require Import tactics. -From cap_machine Require Import rules. -From cap_machine.proofmode Require Import tactics_helpers proofmode contiguous. -Open Scope Z_scope. - -(** The imports correspond to the following: - - the Iris tactics and the Iris proofmode - - the WP rules of the Cerise program logic - - the automated tactics of the Cerise proofmode - - some additional tactics for the Cerise proofmode - - We recommand to check the documentation of the proofmode of Cerise: - https://github.com/logsem/cerise/blob/main/proofmode.md *) - -Section base_program. - (** Iris requires the ressources in the context. The resources of our machine - are the registers and the memory. Moreover, we need the machine parameters - in the context, which abstract the encoding and the decoding function - (for instance, to encode the instructions). *) - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - (** The program is a list of instructions. As the machine has a Von Neumann - architecture, the instructions are encoded data. The function - `encodeInstrsW` transforms a list of instructions into integers. - The encoding does not matter, as we always manipulate the encoded - instructions with the decoding function. *) - - (** The program we will study in this file moves a pointer in a buffer and - stores a value at this new location. More precisely, we assumes that the - register `r1` of the machine contains a capability pointing to a memory - buffer of size >= 1. The program derives a capability to the next address, - and stores the value of the register `r2` at this address. *) - - Definition prog_instrs : list Word := - encodeInstrsW [ - Lea r_t1 1; (* load effective address 1 into `r1` *) - Store r_t1 r_t2 (* store value from `r2` at address specified by `r1` *) - ]. - - (** We use the program logic to specify the program. In the program logic, - there is 2 types of ressources: - - the register /reg/ maps to the word /w/, reg ↦ᵣ w - - the address /a/ maps to the word /w/, a ↦ₐ w. - The notation [[a1, a2]] ↦ₐ [[lw]] maps the list of String.words /lw/ to the - contiguous fragment of memory between the adresses /a1/ and /a2/. - - To write the specification, we need to have the separation logic - assertion that describe all the resources required throughout the - execution. In this case, we need the ownership of: - - the fragment of the memory with the instructions of the program, - stored between the adresses `a_prog` and `a_prog + len(prog)` - - the memory buffer on which the program stores the new value, - between the addresses `b_mem` and `b_mem + 2` - - the PC contains a capability pointing to the first addresse of the - program `a_prog`, with all the required permissions - (i.e. validity range and executable) - - the registers `r1` and `r2`, where `r1` contains the capability to the - buffer and `r2` contains the new data (in our case, 42) - - The usual way to specify a program in Cerise in Coq is to use the - weakest-precondition (WP) with a Continuation Passing Style, instead of - the Hoare Triples. - The CPS style is defined as follows: - - {P} e {Q} ≡ ∀ ϕ, (P ∗ ▷(Q -∗ WP e { ϕ })) -∗ WP e { ϕ } - - It is important to notice that, for a such low-level programming language, - there is no notion of expression. The semantic only describes how the - state of the machine changes at each execution step, as soon as the machine - is in a Running state. - However, the WP property requires an expression. In this way, an - expression in the Cerise program logic encodes only the execution state of - the machine (Running, Halted or Failed) (1). - Thus, the WP rules only describes how the resources of the machine evolve - at each execution step. - - - (1) For technical purpose, an expression in actually either a (non-atomic) - Sequence of instructions, or an (atomic) Instruction. *) - - (** The following lemma `prog_spec_instr` is a specification of the program - previously defined. - - The SL assertion for the fragment of code is `codefrag a_prog prog_instr`. - - The PCC (PC Capability) has the permission `pc_p`, which has, at least, - the execution permission: `ExecPCPerm p_pc`. - The validity range of the PCC, between the addresses `pc_b` and `pc_e`, - is larger than the actual range of the code fragment. Indeed, for - modular purposes, the program we are specifying may be a part of a larger - program. Thus, we need to ensure the fragment of the code is included in - the PCC range, i.e. `SubBounds b_pc e_pc a_prog e_prog`. - - Because we work with addresses, which are actually finite integers, - we need to assume the addresses are always valid when we do addresses - arithmetic operations (for instance, there is no overflow of the memory). - In particular, the memory buffer is a contiguous region of memory where - all the addresses are in the bounds of the memory. - - For simplicity, we assume the buffer is filled with 0. - - When the whole program is a list of instructions, it is required to - manually get some helping facts before reasoning on the instructions, - using the tactic `codefrag_facts "Hprog"`. This tactic has to be used - when the `codefrag` assertion is used. It allows to get some additionnal - facts about the memory addresses containing the code. It is a boilerplate. - - To prove the specification, the idea is to manipulate the resources, such - that we have all the required assertion that fit with the corresponding - WP rule. Once all the resource are ready, the tactic `iInstr "Hprog"` - steps through one instruction, automatically finds the appropriate rule, - and tries to discharge as much goal as possible (e.g. side-condition - about the PC). It only remains some side-condition to prove manually, - such as address arithmetic. - We can use the tactic `solve_addr` to solve automatically the address - arithmetic goals. It sometimes requires to transform the goal or - hypotheses a bit to work. - - We advice to read carefully the following specification and to try to - understand each statement in the lemma. - Then, we urge to execute the proof step by step, and to understand - each time what happens to the proof state and why we are doing it. *) - - Lemma prog_spec_instr - p_pc b_pc e_pc a_prog (* pc *) - b_mem (* mem *) - φ : - - let e_mem := (b_mem ^+ 2)%a in (* end of memory buffer at b_mem + 2 *) - let e_prog := (a_prog ^+ length prog_instrs)%a in (* end of program at a_prog + length of instructions *) - - ExecPCPerm p_pc → (* p_pc has at least the executable permission*) - SubBounds b_pc e_pc a_prog e_prog → (* [b_pc : e_pc) contains [a_prog : e_prog) *) - ContiguousRegion b_mem 2 → (* addresses in [b_mem : b_mem + 2) are valid *) - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog *) - ∗ codefrag a_prog prog_instrs (* the prog instruction start at a_prog *) - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem b_mem (* r1 points to the allocated memory *) - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 0] ]] (* memory buffer, filled with 0 *) - ∗ r_t2 ↦ᵣ WInt 42 (* new value 42 *) - ∗ ▷ ( (* everything under the later `▷` and before the wand `-*` is our postcondition *) - PC ↦ᵣ WCap p_pc b_pc e_pc e_prog (* PC has reached the end of the program *) - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem (b_mem ^+ 1)%a (* r1 points to b_mem + 1*) - ∗ r_t2 ↦ᵣ WInt 42 (* unchanged *) - ∗ codefrag a_prog prog_instrs (* unchanged *) - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 42] ]] (* our memory buffer now contains 42 *) - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hpc_perm Hpc_bounds Hmem_bounds. - unfold ContiguousRegion in Hmem_bounds. - - iIntros "(HPC & Hprog & Hr1 & Hmem & Hr2 & Hcont)". - - (* 1 - prepare the assertions for the proof *) - subst e_mem e_prog. (* replace e_mem and e_prog with their known values *) - codefrag_facts "Hprog". (* Derives the facts from the codefrag *) - simpl in *. - - (* 2 - wp rules for each instructions *) - (* Lea *) - iInstr "Hprog". - - (* Store requires the resource (b_mem ^+ 1), we need to destruct the region_pointsto. - This essentially the same as destructing a list into (first element)::(rest of list). *) - iDestruct (region_pointsto_cons with "Hmem") as "(Hmem0 & Hmem1)". - { (* We simplify the subgoal first *) - transitivity (Some (b_mem ^+ 1)%a). - 2: reflexivity. - - (* This inequality holds if the address (b_mem + 1) is in memory *) - (* The hypothesis `Hmem_bounds` ensures that (b_mem + 2) is in memory, so (b_mem + 1) too *) - solve_addr +Hmem_bounds. (* `solve_addr` is invoked with the "required" environment + `Hmem_bounds` *) - } - { solve_addr +. (* `solve_addr` is invoked with only the "required" environment *) } - - (* We do it twice since we need the second element (b_mem ^+ 1). *) - iDestruct (region_pointsto_cons with "Hmem1") as "(Hmem1 & _)". - { transitivity (Some (b_mem ^+ (1 + 1))%a); [ solve_addr +Hmem_bounds | reflexivity ]. } - { solve_addr +. } - - (* Store *) - iInstr "Hprog". - - (* 3 - Continuation *) - iApply "Hcont". - - iFrame. - iApply region_pointsto_cons. - { transitivity (Some (b_mem ^+ 1)%a); solve_addr +Hmem_bounds. } - { solve_addr +. } - - iFrame. - iApply region_pointsto_cons. - { transitivity (Some (b_mem ^+ (1 + 1))%a); solve_addr +Hmem_bounds. } - { solve_addr +. } - - iFrame. - replace (b_mem ^+ (1 + 1))%a with (b_mem ^+ 2)%a by solve_addr +. - - unfold region_pointsto. - rewrite finz_seq_between_empty. - { simpl; iPureIntro. exact I. } - { solve_addr +. } - Qed. - - - (** The tactic `iGo "Hprog"` steps through multiple instructions, - until a side-condition needs to be prove manually. *) - - (** **** Exercise 1 --- More automation with iGo - Prove the specification of the previous example using the automated - tactic `iGo`. In order to leverage the strengh of the tactic, the memory - resources should be ready before the execution of the tactic, in - particular, the memory buffer should be split at the beginning of the - proof: it will allows the tactic `iGo` to step through multiple - instructions at once. - - Tips: take inspiration on the proof of the previous exercise, but we - recommend to try to manipulate the SL resources and the address - arithmetic by yourself. - Indeed, address arithmetic is a very common side-condition, - and the lemmas often require you to manipulate the PL resources - in order to make them fit with the hypothesis. *) - - Lemma prog_spec_igo - p_pc b_pc e_pc a_prog (* pc *) - b_mem (* mem *) - φ : - - let e_mem := (b_mem ^+ 2)%a in - let e_prog := (a_prog ^+ length prog_instrs)%a in - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog e_prog → - ContiguousRegion b_mem 2 → - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ codefrag a_prog prog_instrs - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem b_mem - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 0] ]] - ∗ r_t2 ↦ᵣ WInt 42 - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem (b_mem ^+ 1)%a - ∗ r_t2 ↦ᵣ WInt 42 - ∗ codefrag a_prog prog_instrs - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 42] ]] - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hpc_perm Hpc_bounds Hmem_bounds. - unfold ContiguousRegion in Hmem_bounds. - - iIntros "(HPC & Hprog & Hr1 & Hmem & Hr2 & Hcont)". - subst e_mem e_prog. - codefrag_facts "Hprog"; simpl in *. - - (* Prepare the memory resource for the Store *) - iDestruct (region_pointsto_cons with "Hmem") as "(Hmem0 & Hmem1)". - { transitivity (Some (b_mem ^+ 1)%a); solve_addr +Hmem_bounds. } - { solve_addr +. } - - iDestruct (region_pointsto_single with "Hmem1") as "Hmem1". - { transitivity (Some (b_mem ^+ (1 + 1))%a); solve_addr +Hmem_bounds. } - - iDestruct "Hmem1" as (v) "(Hmem1 & %Hr)". - injection Hr as <-. (* `Hmem1` is now pointing to `WInt 0` *) - - (* 2 - step through multiple instructions *) - (* FILL IN HERE *) - - (* 3 - Continuation *) - (* FILL IN HERE *) - Admitted. - - - (** The tactics `iInstr` and `iGo` automatically lookup the PC, find the - corresponding instruction in the `codefrag` instruction, find the - right WP rule to apply accordingly with the instruction, instantiate - the lemma and try to prove as much precondition as possible. - - However, in order to get a better understanding of the way to use the - WP rules in Cerise, we propose to prove the previous lemma using the - fully detailed tactics. - It is also useful if the assertion that embeds the code is not the - `codefrag` predicate, but for instance, the big conjonction separation - `[∗ list]` --- even though it is usually possible to rewrite the one - in term of the other. *) - - (** **** Exercise 2 --- Manual detailled proofs - For this exercise, we propose to re-do the proof of the previous - specification, using the manual WP rules. - We explain the different steps for the first instruction `Lea`. - Complete the proof. - *) - - Lemma prog_spec_detailed - p_pc b_pc e_pc (* pc *) - a_prog a - b_mem (* mem *) - φ : - - let e_mem := (b_mem ^+ 2)%a in - let e_prog := (a_prog ^+ length prog_instrs)%a in - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog e_prog → - contiguous_between a a_prog (e_prog) → - ContiguousRegion b_mem 2 → - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ ([∗ list] a_i;w ∈ a;prog_instrs, a_i ↦ₐ w)%I - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem b_mem - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 0] ]] - ∗ r_t2 ↦ᵣ WInt 42 - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem (b_mem ^+ 1)%a - ∗ r_t2 ↦ᵣ WInt 42 - ∗ ([∗ list] a_i;w ∈ a;prog_instrs, a_i ↦ₐ w)%I - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 42] ]] - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hpc_perm Hpc_bounds Hprog_addr Hmem_bounds. - iIntros "(HPC & Hprog & Hr1 & Hmem & Hr2 & Hcont)". - subst e_mem e_prog; simpl in *. - - (* In order to use the tactic `iCorrectPC` that solves the side-condition - about the PC, we need this assertion, equivalent to - `Hpc_perm /\ Hpc_bounds` *) - assert (Hpc_correct : isCorrectPC_range p_pc b_pc e_pc a_prog (a_prog ^+ 2)%a). - { unfold isCorrectPC_range. - intros. - apply isCorrectPC_ExecPCPerm_InBounds. - - assumption. - - solve_addr +H Hpc_bounds. - } - - (* 2 - step through instructions *) - - (* 2.1 - Lea *) - (* Prepare the resources: Destruct the list of addresses of the code fragment *) - iDestruct (big_sepL2_length with "Hprog") as %Hlength_prog. - destruct_list a. - pose proof (contiguous_between_cons_inv_first _ _ _ _ Hprog_addr) as ->. - - (* Focus to the atomic expression (regarding the operational semantic) *) - iDestruct "Hprog" as "[Hi Hprog]". - - (* Apply the WP rule corresponding to the instruction - and prove the preconditions of the rule *) - iApply (wp_bind (fill [SeqCtx])); iSimpl. - iApply (wp_lea_success_z with "[$HPC $Hi $Hr1]"). - { apply decode_encode_instrW_inv. } - { iCorrectPC a_prog (a_prog ^+ 2)%a. } - { iContiguous_next Hprog_addr 0%nat. } - { unfold ContiguousRegion in Hmem_bounds. - transitivity (Some (b_mem ^+ 1)%a); solve_addr +Hmem_bounds. } - { auto. } - - (* Introduce the postconditions of the rule and re-focus the expression. *) - iNext; iIntros "(HPC & Hdone & Hr1)"; iSimpl. - iApply wp_pure_step_later; [ exact I |]. - iIntros "!> _". - - (* 2.2 - Store *) - (* Destruct the list of addresses of the code fragment *) - pose proof (contiguous_between_last _ _ _ a Hprog_addr eq_refl) as Hlast. - - (* Prepare the memory resource for the Store *) - (* FILL IN HERE *) - - (* Focus to the atomic expression (regarding the operational semantic) *) - (* FILL IN HERE *) - - (* Apply the WP rule corresponding to the instruction - and prove the preconditions of the rule *) - (* FILL IN HERE *) - - (* Introduce the postconditions of the rule and re-focus the expression. *) - (* FILL IN HERE *) - - (* 3 - Continuation *) - (* FILL IN HERE *) - Admitted. - - - (** The next step to learn how to use the Cerise Proofmode is to leverage - the modularity of program logic to define macros and use their - specification inside bigger programs. - The next part of the tutorial "cerise_modularity.v" will learn you how - to define, specify and use user-defined macros, and present you the main - macros already defined in Cerise. - *) - -End base_program. diff --git a/theories/exercises/cerise_tutorial_solutions.v b/theories/exercises/cerise_tutorial_solutions.v deleted file mode 100644 index a5ef157f..00000000 --- a/theories/exercises/cerise_tutorial_solutions.v +++ /dev/null @@ -1,197 +0,0 @@ -(** This file is a tutorial to learn how to use the Cerise program logic in Coq. - We will specify a simple program and explain the tactic to use to prove the - specification. - We assume the user already knows how to use Iris, for instance with Heaplang. - *) - -From iris.proofmode Require Import tactics. -From cap_machine Require Import rules. -From cap_machine.proofmode Require Import proofmode tactics_helpers contiguous. -Open Scope Z_scope. - -Section base_program. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - Definition prog_instrs : list Word := - encodeInstrsW [ - Lea r_t1 1 ; - Store r_t1 r_t2 ]. - - (** **** Exercise 1 - More automation with iGo *) - - Lemma prog_spec_igo - p_pc b_pc e_pc a_prog (* pc *) - b_mem (* mem *) - φ : - - let e_mem := (b_mem ^+ 2)%a in - let e_prog := (a_prog ^+ length prog_instrs)%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc a_prog e_prog -> - ContiguousRegion b_mem 2 → - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ codefrag a_prog prog_instrs - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem b_mem - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 0] ]] - ∗ r_t2 ↦ᵣ WInt 42 - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem (b_mem ^+1)%a - ∗ r_t2 ↦ᵣ WInt 42 - ∗ codefrag a_prog prog_instrs - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 42] ]] - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hpc_perm Hpc_bounds Hmem_bounds. - unfold ContiguousRegion in Hmem_bounds. - iIntros "(HPC& Hprog& Hr1& Hmem& Hr2& Hcont)". - subst e_mem e_prog; simpl. - - (* Derives the facts from the codefrag *) - codefrag_facts "Hprog". - simpl in *. - - (* Prepare the memory resource for the Store *) - iDestruct (region_pointsto_cons with "Hmem") as "(Hmem0& Hmem1)". - { transitivity (Some (b_mem ^+1)%a) ; auto ; by solve_addr. } - { by solve_addr. } - iDestruct (region_pointsto_single with "Hmem1") as "Hmem1". - { transitivity (Some (b_mem ^+(1+1))%a) ; auto ; by solve_addr. } - iDestruct "Hmem1" as (v) "(Hmem1& %Hr)". - injection Hr ; intro Hr' ; subst ; clear Hr. - - (* 2 - step through multiple instructions *) - iGo "Hprog". - - (* 3 - Continuation *) - iApply "Hcont". - iFrame. - iApply region_pointsto_cons. - { transitivity (Some (b_mem ^+1)%a) ; auto ; by solve_addr. } - { by solve_addr. } - iFrame. - iApply region_pointsto_cons. - { transitivity (Some (b_mem ^+(1+1))%a) ; auto ; by solve_addr. } - { by solve_addr. } - iFrame. - replace (b_mem ^+ (1 + 1))%a with (b_mem ^+ 2)%a by solve_addr. - unfold region_pointsto. - rewrite finz_seq_between_empty ; last solve_addr. - done. - Qed. - - (** **** Exercise 2 --- Manual detailled proofs *) - - Lemma prog_spec_detailed - p_pc b_pc e_pc (* pc *) - a_prog a - b_mem (* mem *) - φ : - - let e_mem := (b_mem ^+ 2)%a in - let e_prog := (a_prog ^+ length prog_instrs)%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc a_prog e_prog -> - contiguous_between a a_prog (e_prog) → - ContiguousRegion b_mem 2 → - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ ([∗ list] a_i;w ∈ a;prog_instrs, a_i ↦ₐ w)%I - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem b_mem - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 0] ]] - ∗ r_t2 ↦ᵣ WInt 42 - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem (b_mem ^+1)%a - ∗ r_t2 ↦ᵣ WInt 42 - ∗ ([∗ list] a_i;w ∈ a;prog_instrs, a_i ↦ₐ w)%I - ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 42] ]] - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }}%I. - Proof. - intros * Hpc_perm Hpc_bounds Hprog_addr Hmem_bounds. - iIntros "(HPC& Hprog& Hr1& Hmem& Hr2& Hcont)". - subst e_mem e_prog; simpl in *. - (* In order to use the tactic `iCorrectPC` that solve the side-condition - about the PC, we need this assertion, equivalent to - `Hpc_perm /\ Hpc_bounds` *) - assert (Hpc_correct : isCorrectPC_range p_pc b_pc e_pc a_prog (a_prog ^+ 2)%a). - { unfold isCorrectPC_range. intros. - apply isCorrectPC_ExecPCPerm_InBounds ; auto ; solve_addr. - } - - - (* Lea *) - (* Prepare the resources - Destruct the list of addresses of the code fragment *) - iDestruct (big_sepL2_length with "Hprog") as %Hlength_prog. - destruct_list a. - pose proof (contiguous_between_cons_inv_first _ _ _ _ Hprog_addr) as ->. - (* Focus to the atomic expression (regarding the operational semantic) *) - iDestruct "Hprog" as "[Hi Hprog]". - iApply (wp_bind (fill [SeqCtx])). - (* Apply the WP rule corresponding to the instruction - and prove the preconditions of the rule *) - iApply (wp_lea_success_z with "[$HPC $Hi $Hr1]"). - { apply decode_encode_instrW_inv. } - { iCorrectPC a_prog (a_prog ^+ 2)%a. } - { iContiguous_next Hprog_addr 0%nat. } - { transitivity (Some (b_mem ^+ 1 )%a) ; auto ; solve_addr. } - { auto. } - (* Introduce the postconditions of the rule and re-focus the expression. *) - iNext; iIntros "(HPC& Hdone& Hr1)"; iSimpl. - iApply wp_pure_step_later;auto;iNext;iIntros "_". - - (* Lea *) - (* Destruct the list of addresses of the code fragment *) - pose proof (contiguous_between_last _ _ _ a Hprog_addr eq_refl) as Hlast. - - (* Prepare the memory resource for the Store *) - iDestruct (region_pointsto_cons with "Hmem") as "(Hmem0& Hmem1)". - { transitivity (Some (b_mem ^+1)%a) ; auto ; by solve_addr. } - { by solve_addr. } - iDestruct (region_pointsto_single with "Hmem1") as "Hmem1". - { transitivity (Some (b_mem ^+(1+1))%a) ; auto ; by solve_addr. } - iDestruct "Hmem1" as (v) "(Hmem1& %Hr)". - injection Hr ; intro Hr' ; subst ; clear Hr. - - (* Focus to the atomic expression (regarding the operational semantic) *) - iDestruct "Hprog" as "[Hi Hprog]". - iApply (wp_bind (fill [SeqCtx])). - - (* Apply the WP rule corresponding to the instruction - and prove the preconditions of the rule *) - iApply (wp_store_success_reg with "[$HPC $Hi $Hmem1 $Hr2 $Hr1]"). - { apply decode_encode_instrW_inv. } - { iCorrectPC a_prog (a_prog ^+ 2)%a. } - { eauto. } - { eauto. } - { apply le_addr_withinBounds; solve_addr. } - - (* Introduce the postconditions of the rule and re-focus the expression. *) - iNext; iIntros "(HPC& Hi& Hr2& Hr1& Hmem1 )"; iSimpl. - iCombine "Hdone Hi" as "Hdone". - iApply wp_pure_step_later;auto;iNext ;iIntros "_". - - (* 3 - Continuation *) - iApply "Hcont". - iDestruct "Hdone" as "[? ?]". - iFrame. - iApply region_pointsto_cons. - { transitivity (Some (b_mem ^+1)%a) ; auto ; by solve_addr. } - { by solve_addr. } - iFrame. - iApply region_pointsto_cons. - { transitivity (Some (b_mem ^+(1+1))%a) ; auto ; by solve_addr. } - { by solve_addr. } - iFrame. - replace (b_mem ^+ (1 + 1))%a with (b_mem ^+ 2)%a by solve_addr. - unfold region_pointsto. - rewrite finz_seq_between_empty ; last solve_addr. - done. - Qed. - -End base_program. diff --git a/theories/exercises/increment.v b/theories/exercises/increment.v deleted file mode 100644 index 2bbea52c..00000000 --- a/theories/exercises/increment.v +++ /dev/null @@ -1,724 +0,0 @@ -From iris.algebra Require Import frac. -From iris.proofmode Require Import tactics. -Require Import Eqdep_dec List. -From cap_machine Require Import malloc macros. -From cap_machine Require Import rules. -From cap_machine.proofmode Require Import tactics_helpers proofmode. -From cap_machine.examples Require Import template_adequacy. -From cap_machine.exercises Require Import subseg_buffer. -Open Scope Z_scope. - - -Ltac iHide0 irisH coqH := - let coqH := fresh coqH in - match goal with - | h: _ |- context [ environments.Esnoc _ (INamed irisH) ?prop ] => - set (coqH := prop) - end. - -Tactic Notation "iHide" constr(irisH) "as" ident(coqH) := - iHide0 irisH coqH. - - -Section program_call. - From cap_machine Require Import call callback. - - Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} - `{MP: MachineParameters}. - Context {nainv: logrel_na_invs Σ}. - - (* - r_t7 := r_cnt - - r_t8 := r_pc - - r_t9 := r_param *) - - Definition init_incr_instrs := - encodeInstrsW [ - Mov r_t7 0 ; - Mov r_t9 0 ; - Mov r_t8 PC ; - Lea r_t8 2 ]. - - Definition add_incr_instrs' : list Word := - restore_locals_instrs r_t2 (rev [r_t7 ; r_t8]) - ++ encodeInstrsW [ - Add r_t7 r_t7 1 ; - Mov r_t9 r_t7 ; - Jmp r_t8 ]. - - Definition add_incr_instrs r_adv f_m := - call_instrs f_m (offset_to_cont_call [r_t9]) r_adv [r_t7 ; r_t8] [r_t9] - ++ add_incr_instrs'. - - - Definition prog_incr_instrs r_adv f_m : list Word := - init_incr_instrs ++ add_incr_instrs r_adv f_m. - - Definition prog_incr_code addrs_prog r_adv f_m := - ([∗ list] a_i;w ∈ addrs_prog;(prog_incr_instrs r_adv f_m), a_i ↦ₐ w)%I. - - Lemma init_incr_spec - p_pc b_pc e_pc s_prog (* pc *) - w7 w8 w9 - φ : - - let e_prog := (s_prog ^+ length init_incr_instrs)%a in - - (* Validity pc *) - ExecPCPerm p_pc -> - SubBounds b_pc e_pc s_prog e_prog -> - - (* Specification *) - ⊢ (( PC ↦ᵣ WCap p_pc b_pc e_pc s_prog - ∗ r_t7 ↦ᵣ w7 - ∗ r_t8 ↦ᵣ w8 - ∗ r_t9 ↦ᵣ w9 - ∗ codefrag s_prog init_incr_instrs - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_t7 ↦ᵣ WInt 0 - ∗ r_t8 ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_t9 ↦ᵣ WInt 0 - ∗ codefrag s_prog init_incr_instrs - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intro e_prog ; subst e_prog. - iIntros (Hpc_perm Hpc_bounds) "(HPC & Hr7 & Hr8 & Hr9 & Hprog & Cont)". - codefrag_facts "Hprog". - iGo "Hprog". - iApply "Cont" ; iFrame. - Qed. - - Definition length_call := 89%nat. - Lemma length_call_instrs f_m : - length - (call_instrs f_m (offset_to_cont_call [r_t9]) r_t30 [r_t7; r_t8] [r_t9]) - = length_call. - Proof. - rewrite /call_instrs !length_app. - set (l_fetch := length (fetch_instrs f_m)). - set (l_clear := length (rclear_instrs (list_difference - all_registers ([PC; r_t30; r_t30] - ++ [r_t9])))). - simpl in l_fetch. - subst l_fetch l_clear. - rewrite rclear_length. - rewrite list_difference_length ; auto ; simpl. - apply all_registers_NoDup. - repeat (apply NoDup_cons_2 ; first set_solver); apply NoDup_nil_2. - apply all_registers_correct_sub. - repeat (apply NoDup_cons_2 ; first set_solver) - ; apply NoDup_nil_2. - Qed. - - Lemma length_add_incr f_m : - length (add_incr_instrs r_t30 f_m) = 96%nat. - Proof. - rewrite /add_incr_instrs. - rewrite length_app. - rewrite length_call_instrs. - done. - Qed. - - - - Lemma add_incr'_spec - p_pc b_pc e_pc s_prog (* pc *) - b_l e_l (* locals *) - n7 w9 a_call - φ : - - let e_prog := (s_prog ^+ length add_incr_instrs')%a in - let rmap := ( <[r_t7 := WInt n7]> {[r_t8 := WCap p_pc b_pc e_pc a_call]}) in - - (* Validity pc *) - ExecPCPerm p_pc -> - SubBounds b_pc e_pc s_prog e_prog -> - - (* Specification *) - ⊢ (( PC ↦ᵣ WCap p_pc b_pc e_pc s_prog - ∗ r_t2 ↦ᵣ WCap RWX b_l e_l e_l - ∗ r_t9 ↦ᵣ w9 - ∗ ([∗ map] r_i↦_ ∈ rmap , ∃ w_i, r_i ↦ᵣ w_i) - ∗ [[b_l,e_l]]↦ₐ[[ [WInt n7 ; (WCap p_pc b_pc e_pc a_call)] ]] - ∗ codefrag s_prog add_incr_instrs' - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_call - ∗ r_t7 ↦ᵣ WInt (n7+1) - ∗ r_t8 ↦ᵣ WCap p_pc b_pc e_pc a_call - ∗ r_t9 ↦ᵣ WInt (n7+1) - ∗ codefrag s_prog add_incr_instrs' - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intro e_prog ; subst e_prog; simpl. - iIntros (Hpc_perm Hpc_bounds) - "(HPC & Hr2 & Hr9 & Hrmap & Hlocals & Hprog & Post)". - iHide "Post" as Post. - - focus_block_0 "Hprog" as "Hprog" "Hcont". - rewrite {1}/codefrag {2}/region_pointsto. - iHide "Hcont" as Hcont. - rewrite -/(restore_locals _ _ _). - iDestruct (big_sepL2_length with "Hlocals") as %Hlength_locals - ; rewrite /= finz_seq_between_length in Hlength_locals. - iApply (restore_locals_spec _ _ _ _ _ _ _ _ _ _ - (s_prog ^+ length (restore_locals_instrs r_t2 [r_t7; r_t8]))%a - with "[- $HPC $Hr2 $Hrmap $Hprog $Hlocals]"). - { split ; auto. split ; solve_addr. } - { apply contiguous_between_region_addrs; solve_addr. } - { auto. } - { simpl ; lia. } - { reflexivity. } - { simpl. - rewrite map_to_list_insert ; last by simplify_map_eq. - rewrite map_to_list_singleton. - reflexivity. - } - { reflexivity. } - iNext ; iIntros "(HPC & Hr2 & Hrmap & Hlocals & Hprog)" ; simpl. - iAssert (codefrag s_prog (restore_locals_instrs r_t2 [r_t8; r_t7])) - with "Hprog" as "Hprog". - unfocus_block "Hprog" "Hcont" as "Hprog". - - focus_block 1%nat "Hprog" as a_mid Ha_mid "Hprog" "Hcont". - clear Post ; - iHide "Post" as Post; iHide "Hcont" as Hcont. - extract_register r_t7 with "Hrmap" as "[Hr7 Hrmap]". - extract_register r_t8 with "Hrmap" as "[Hr8 Hrmap]". - iClear "Hrmap". - iInstr "Hprog". - iInstr "Hprog". - iInstr "Hprog". - inversion Hpc_perm; subst. - all: unfocus_block "Hprog" "Hcont" as "Hprog". - all: iApply "Post" ; iFrame. - Qed. - - - Definition incrN : namespace := nroot .@ "incrN". - Definition incrN_link : namespace := incrN .@ "link". - Definition incrN_act : namespace := incrN .@ "act". - Definition incrN_locals : namespace := incrN .@ "locals". - Definition incrN_prog : namespace := incrN .@ "prog". - - - Definition locals_inv w7 w8 : iProp Σ := - ∃ b_local e_local, - ([[b_local,e_local]]↦ₐ[[ [w7; w8] ]])%I. - - Definition act_inv pc_p pc_b pc_e a_end : iProp Σ := - ∃ b_act e_act b_local e_local, - ([[b_act,e_act]]↦ₐ[[[WInt hw_1; - WInt hw_2; - WInt hw_3; - WInt hw_4; - WInt hw_5; - WCap RWX b_local e_local e_local; - WCap pc_p pc_b pc_e a_end] ]])%I. - - Definition link_inv table_addr b_link e_link a_link - malloc_entry b_m e_m : iProp Σ := - (table_addr ↦ₐ WCap RO b_link e_link a_link - ∗ malloc_entry ↦ₐ WCap E b_m e_m b_m)%I. - - - Ltac solve_addr' := - repeat - ( match goal with - | h: contiguous_between _ _ _ |- _ => - apply contiguous_between_bounds in h - end) - ; solve_addr. - - Lemma malloc_incrN mallocN : - (up_close (B:=coPset)mallocN ⊆ ⊤ ∖ ↑incrN) -> - (up_close (B:=coPset)mallocN ⊆ ⊤ ∖ ↑incrN_prog ∖ ↑incrN_link). - Proof. - intros. - assert (up_close (B:=coPset)incrN_prog ⊆ ↑incrN) by apply nclose_subseteq. - assert (up_close (B:=coPset)incrN_link ⊆ ↑incrN) by apply nclose_subseteq. - set_solver. - Qed. - - Lemma add_incr_spec - (* call *) n7 - (* remaining registers *) (rmap : gmap RegName Word) - (* pc *) a pc_p pc_b pc_e a_first a_last - (* malloc *) f_m b_m e_m mallocN - (* linking *) b_link a_link e_link malloc_entry : - - (* Validity pc *) - ExecPCPerm pc_p → - SubBounds pc_b pc_e a_first a_last -> - contiguous_between a a_first a_last → - (* LT *) - withinBounds b_link e_link malloc_entry = true → - (a_link + f_m)%a = Some malloc_entry → - (up_close (B:=coPset)mallocN ⊆ ⊤ ∖ ↑incrN) -> - - (* Specification *) - ⊢ (( PC ↦ᵣ WCap pc_p pc_b pc_e a_first - ∗ (∃ w0, r_t0 ↦ᵣ w0 ∗ interp w0) - ∗ r_t7 ↦ᵣ WInt n7 - ∗ r_t8 ↦ᵣ WCap pc_p pc_b pc_e a_first - ∗ r_t9 ↦ᵣ WInt n7 - ∗ (∃ wadv, r_t30 ↦ᵣ wadv ∗ interp wadv) - ∗ (([∗ map] r_i↦w_i ∈ rmap , r_i ↦ᵣ w_i) ∗ ⌜ dom (gset RegName) rmap = all_registers_s ∖ {[ PC; r_t0; r_t30 ; r_t7 ; r_t8 ; r_t9]} ⌝) - ∗ na_own logrel_nais ⊤ - ∗ na_inv logrel_nais mallocN (malloc_inv b_m e_m) - ∗ na_inv logrel_nais incrN_link - (link_inv pc_b b_link e_link a_link malloc_entry b_m e_m) - ∗ na_inv logrel_nais incrN_prog - ([∗ list] a_i;w ∈ a;(add_incr_instrs r_t30 f_m), a_i ↦ₐ w)%I - -∗ WP Seq (Instr Executable) {{λ v, - (⌜v = HaltedV⌝ → ∃ r : Reg, full_map r ∧ registers_pointsto r ∗ na_own logrel_nais ⊤)%I - ∨ ⌜v = FailedV⌝ }}))%I. - Proof with (try solve_addr'). - iIntros - (Hpc_perm Hpc_bounds Hcont Hwb Hlink Hnamespace) - "(HPC & Hr0 & Hr7 & Hr8 & Hr9 & Hr30 & Hrmap & Hna - & #Hmalloc_inv & #Hlink_inv & #Hprog_inv)". - iHide "Hprog_inv" as Hprog_inv. - - iLöb as "IH" forall ( n7 rmap ). - iHide "IH" as IH. - iDestruct "Hr0" as (w0) "[Hr0 #Hinterp_w0]" - ; iDestruct "Hr30" as (wadv) "[Hr30 #Hinterp_adv]" - ; iDestruct "Hrmap" as "[Hrmap %Hdom]". - - iDestruct (jmp_to_unknown with "Hinterp_adv") as "Cont". - iHide "Cont" as cont. - - - iMod (na_inv_acc with "Hprog_inv Hna") as "(>Hprog & Hna & Hcls)" ; auto. - iMod (na_inv_acc with "Hlink_inv Hna") as - "(>[Hpcb Hmalloc_entry] & Hna & Hcls') "; [auto|solve_ndisj|]. - iHide "Hcls" as Hcls; iHide "Hcls'" as Hcls'. - - (* 1 - prepare the ressources for the call specification *) - (* We split the program in 2 parts: the call and the callback *) - iDestruct (big_sepL2_length with "Hprog") as %Hlength_prog. - iDestruct (contiguous_between_program_split with "Hprog") as - (call_addrs add_incr_addrs a_add) "(Hcall_prog & Hadd_prog & #Hcont1)" - ;[apply Hcont|] - ;iDestruct "Hcont1" as %(Hcont_call & Hcont_prog & Heqapp1 & Ha_prog). - iDestruct (big_sepL2_length with "Hcall_prog") as %Hlength_call. - - iAssert ( call _ f_m r_t30 [r_t7 ; r_t8] [r_t9]) - with "Hcall_prog" - as "Hcall". - set (w7 := WInt n7). - set (w8 := WCap pc_p pc_b pc_e a_first). - set (rmap_call' := <[r_t7:=w7]> (<[r_t8 := w8 ]> rmap)). - set (mlocals := (@list_to_map _ _ (@gmap RegName reg_eq_dec reg_countable - Word) _ _ [ (r_t7, w7) ; (r_t8, w8) ])). - iApply (call_spec - r_t30 mlocals ({[r_t9 := w7]}) - wadv _ rmap_call' - _ _ _ _ _ a_add - with "[- $HPC $Hna $Hr30 $Hrmap $Hpcb $Hmalloc_entry $Hmalloc_inv]" - ) ; simpl ; eauto. - { split; auto... } - { rewrite map_to_list_insert ; last by simplify_map_eq. - simpl ; lia. } - 1,3: ( rewrite Hdom; set_solver+ ). - { - subst rmap_call'. - rewrite dom_singleton_L. - rewrite <- !difference_difference_l_L. - rewrite !dom_insert_L Hdom. - replace (all_registers_s ∖ {[PC; r_t0; r_t30; r_t7; r_t8; r_t9]}) - with (all_registers_s ∖ {[PC]} ∖ {[r_t0]} ∖ {[r_t30]} ∖ {[r_t9]} ∖ {[r_t8]} ∖ {[r_t7]}) - by (rewrite <- !difference_difference_l_L ; set_solver+). - replace - ( {[r_t7]} - ∪ ({[r_t8]} - ∪ (all_registers_s ∖ {[PC]} ∖ {[r_t0]} ∖ {[r_t30]} ∖ {[r_t9]} ∖ - {[r_t8]} ∖ {[r_t7]}))) - with (all_registers_s ∖ {[PC]} ∖ {[r_t0]} ∖ {[r_t30]} ∖ {[r_t9]}) - ; first reflexivity. - match goal with - |h: _ |- ?x = _ => set (rmaps := x) - end. - replace ({[r_t7]} ∪ ({[r_t8]} ∪ rmaps ∖ {[r_t8]} ∖ {[r_t7]})) - with - ({[r_t7 ; r_t8]} ∪ (rmaps ∖ {[r_t7 ; r_t8]})) by set_solver+. - rewrite -union_difference_L; set_solver+. - } - { apply malloc_incrN ; solve_ndisj. } - - iSplitL "Hcall". - { iNext. - rewrite !map_to_list_singleton /=. admit. - } - iSplitL "Hr9"; first (iApply big_sepM_singleton; iFrame). - iSplitL "Hr0"; first (iNext ; iExists _ ; iFrame). - iSplitL "Hr7 Hr8". - { iNext. iFrame. - iApply (big_sepM_insert with "[-]") ; first by simplify_map_eq. - simpl. iFrame. - (iApply big_sepM_singleton; iFrame). - } - iNext. - clear IH ; iHide "IH" as IH. - iIntros "H" ; iDestruct "H" as - (b_act e_act b_local e_local a_end_call) - "( %Hnext & HPC & Hrmap & Hr9 & Hpcb & Haentry & Hr30 & Hr0 & Hact & Hlocals & Hcall & Hna )". - - - (* Cleaning *) - iMod ("Hcls'" with "[$Hna $Haentry $Hpcb]") as "Hna". - iHide "Hact" as Hact. - clear cont ; iHide "Cont" as cont. - subst rmap_call'. - replace (map_to_list mlocals) - with [(r_t7,w7) ; (r_t8,w8)] ; [simpl|]. - 2:{ clear. admit. } - replace ((map_to_list {[r_t9 := w7]}).*1) - with [r_t9] by (by rewrite map_to_list_singleton /=). - iDestruct (big_sepM_singleton (fun r w => r ↦ᵣ w)%I r_t9 w7 with "Hr9") as - "Hr9". - - (* Re -insert the registers into the map *) - iDestruct (big_sepM_to_create_gmap_default _ _ (λ k i, k ↦ᵣ i)%I (WInt 0%Z) with "Hrmap") as "Hrmap";[apply Permutation_refl|reflexivity|]. - (* r0 *) - iDestruct (big_sepM_insert with "[$Hrmap $Hr0]") as "Hrmap". - { apply not_elem_of_dom. - rewrite create_gmap_default_dom list_to_set_map_to_list. - rewrite !dom_insert_L Hdom. - clear; set_solver. - } - (* r30 *) - iDestruct (big_sepM_insert with "[$Hrmap $Hr30]") as "Hrmap". - { apply not_elem_of_dom. - rewrite !dom_insert_L create_gmap_default_dom list_to_set_map_to_list. - rewrite !dom_insert_L Hdom. - clear; set_solver. } - (* r7 *) - iDestruct (big_sepM_insert with "[$Hrmap $Hr9]") as "Hrmap". - { apply not_elem_of_dom. - rewrite !dom_insert_L create_gmap_default_dom list_to_set_map_to_list. - rewrite !dom_insert_L Hdom. - clear; set_solver. } - set rmap2 := (<[r_t9:=w7]> _). - - (* we are now ready to call the unknown adversary *) - (* we first need to prepare the invariants needed *) - iMod (na_inv_alloc logrel_nais _ incrN_act with "Hact") as "#Hact_inv". - iMod (na_inv_alloc logrel_nais _ incrN_locals with "Hlocals") as "#Hlocals_inv". - iMod ("Hcls" with "[Hcall Hadd_prog $Hna]") as "Hna". - { iNext. - rewrite /call. - iDestruct (big_sepL2_app with "Hcall Hadd_prog") as "Hprog". - rewrite <- Heqapp1. - by rewrite /add_incr_instrs. } - - (* Apply the continuation - ie. jump to the adversary code using - the fact that it is safe to execute *) - iSpecialize ("Cont" $! rmap2). - iApply "Cont". - { iPureIntro. - subst rmap2. - rewrite !dom_insert_L create_gmap_default_dom list_to_set_map_to_list. - rewrite !dom_insert_L Hdom. - rewrite !singleton_union_difference_L. set_solver+. } - iFrame. - subst rmap2. - iApply big_sepM_sep. iFrame. - iApply big_sepM_insert_2 ; first (subst w7 ; iApply interp_int). - iApply big_sepM_insert_2 ; first iFrame "#". - iApply big_sepM_insert_2 ; cycle 1. - (* The remaining registers contains WInt*) - { iApply big_sepM_intuitionistically_forall. iIntros "!>" (r ?). - (set rmap' := <[r_t7:=w7]> _ ). - destruct ((create_gmap_default (map_to_list rmap').*1 (WInt 0%Z : Word)) !! r) eqn:Hsome. - apply create_gmap_default_lookup_is_Some in Hsome as [Hsome ->]. rewrite !fixpoint_interp1_eq. - iIntros (?); simplify_eq; done. iIntros (?); done. } - - (* The activation code is safe to share - ie. safe to execute *) - { cbn beta. rewrite !fixpoint_interp1_eq. - iIntros (r). iNext; iModIntro. - iIntros "([%Hrmap_full #Hrmap_safe] & Hrmap & Hna)". - iClear "Cont". - rewrite /interp_conf {1}/registers_pointsto. - - (* get the registers we need *) - extract_register PC with "Hrmap" as "[HPC Hrmap]". - some_register r_t1 with r as w1 Hw1 - ; extract_register r_t1 with "Hrmap" as "[Hr1 Hrmap]". - some_register r_t2 with r as w2 Hw2 - ; extract_register r_t2 with "Hrmap" as "[Hr2 Hrmap]". - some_register r_t7 with r as w7 Hw7 - ; extract_register r_t7 with "Hrmap" as "[Hr7 Hrmap]". - some_register r_t8 with r as w8 Hw8 - ; extract_register r_t8 with "Hrmap" as "[Hr8 Hrmap]". - some_register r_t9 with r as w9 Hw9 - ; extract_register r_t9 with "Hrmap" as "[Hr9 Hrmap]". - some_register r_t0 with r as w0 Hw0 - ; extract_register r_t0 with "Hrmap" as "[Hr0 Hrmap]". - some_register r_t30 with r as w30 Hw30 - ; extract_register r_t30 with "Hrmap" as "[Hr30 Hrmap]". - - (* 1 - step through the activation record *) - iMod (na_inv_acc with "Hprog_inv Hna") as "[>Hprog [Hna Hcls] ]" - ;[solve_ndisj|solve_ndisj|]. - clear Hcls ; iHide "Hcls" as Hcls. - iMod (na_inv_acc with "Hact_inv Hna") as "[Hact [Hna Hcls'] ]";[solve_ndisj|solve_ndisj|]. - iApply (scall_epilogue_spec with "[- $HPC $Hact $Hr1 $Hr2]") ;[|apply Hnext|]. - { split;auto. } - iNext; iIntros "(HPC & Hr1 & Hr2 & Hact)". - iMod ("Hcls'" with "[$Hact $Hna]") as "Hna". - iDestruct "Hr1" as (w1') "Hr1". - - (* 1 - prepare ressurces for restore locals *) - iDestruct (contiguous_between_program_split with "Hprog") as - (call_addrs' add_incr_addrs' a_add') "(Hcall_prog' & Hadd_prog' & #Hcont1)" - ;[apply Hcont|] - ;iDestruct "Hcont1" as %(Hcont_call' & Hcont_prog' & Heqapp1' & Ha_prog'). - iDestruct (big_sepL2_length with "Hcall_prog'") as %Hlength_call'. - assert (a_add = a_add') as -> ; [|clear Hlength_call']. - { rewrite Heqapp1 in Heqapp1'. - apply app_inj_1 in Heqapp1' as [ -> -> ]. - rewrite Ha_prog in Ha_prog'. - by injection Ha_prog'. - by rewrite <- Hlength_call in Hlength_call'. - } - - rewrite /add_incr_instrs'. - iMod (na_inv_acc with "Hlocals_inv Hna") as "[>Hlocals [Hna Hcls'] ]" - ;[solve_ndisj|solve_ndisj|]. - iHide "Hinterp_w0" as Hinterp_w0. - iHide "Hinterp_adv" as Hinterp_adv. - iHide "Hrmap_safe" as Hrmap_safe. - clear Hcls' ; iHide "Hcls'" as Hcls'. - - (* Extract instructions *) - iDestruct (contiguous_between_program_split with "Hadd_prog'") as - (restore_addrs incr_addrs' a_incr) "(Hrestore_prog & Hincr_prog & #Hcont)" - ;[apply Hcont_prog'|] - ;iDestruct "Hcont" as %(Hcont_restore & Hcont_incr & Heqapp2 & Ha_incr). - iDestruct (big_sepL2_length with "Hlocals") as %Hlength_locals - ; rewrite finz_seq_between_length /= in Hlength_locals. - - iApply (restore_locals_spec _ _ ( <[r_t7 := w7 ]> {[ r_t8 := w8]} ) - _ _ _ _ _ _ _ a_incr - with "[- $HPC $Hr2 $Hlocals $Hrestore_prog]"). - { split ; try eauto... } - { eassumption. } - { auto. } - { simpl ; lia. } - { auto. } - { rewrite /= map_to_list_insert ; last by simplify_map_eq. - by rewrite map_to_list_singleton. } - { simpl ; lia. } - iSplitL "Hr7 Hr8". - { iNext. - iApply (big_sepM_insert_2 with "[Hr7]"); first by iExists _. - iApply (big_sepM_insert_2 with "[Hr8]"); first by iExists _. - done. - } - iNext ; iIntros "(HPC & Hr2 & Hregs_locals & Hlocals & Hrestore_prog)". - extract_register r_t7 with "Hregs_locals" as "[Hr7 Hregs_locals]". - extract_register r_t8 with "Hregs_locals" as "[Hr8 _]". - iHide "Hrmap" as Hrmap. - iHide "Hcall_prog'" as Hcall_prog. - - iDestruct (big_sepL2_length with "Hincr_prog") as %Hlength_incr. - destruct incr_addrs';[inversion Hlength_incr|]. apply contiguous_between_cons_inv_first in Hcont_incr as Heq;subst f. - destruct incr_addrs' as [|a_incr2 incr_addrs'];[inversion Hlength_incr|]. - destruct incr_addrs' as [|a_incr3 incr_addrs'];[inversion Hlength_incr|]. - destruct incr_addrs' as [|? ?];inversion Hlength_incr. - - (* add rt7 1 *) - iDestruct "Hincr_prog" as "(Hincr_prog1 & Hincr_prog2 & Hincr_prog3 & _)". - wp_instr. - iApply (wp_add_sub_lt_success_dst_z with "[$HPC $Hincr_prog1 $Hr7]"); - [apply decode_encode_instrW_inv - |auto - |iContiguous_next Hcont_incr 0%nat - |..]. - { eapply isCorrectPC_contiguous_range ; eauto. split ; solve_addr. - cbn; solve [ repeat constructor ]. - } - iEpilogue "(HPC & Hincr_prog1 & Hr7)". - - (* mov rt9 rt7 *) - wp_instr. - iApply (wp_move_success_reg with "[$HPC $Hincr_prog2 $Hr9 $Hr7]"); - [apply decode_encode_instrW_inv - | auto - |iContiguous_next Hcont_incr 1%nat - |..]. - { eapply isCorrectPC_contiguous_range ; eauto. split ; solve_addr. - cbn; solve [ repeat constructor ]. - } - iEpilogue "(HPC & Hincr_prog2 & Hr9 & Hr7)". - - (* jmp r8 *) - wp_instr. - iApply (wp_jmp_success with "[$HPC $Hincr_prog3 $Hr8]"); - [apply decode_encode_instrW_inv - | auto - |..]. - { eapply isCorrectPC_contiguous_range ; eauto. split ; solve_addr. - cbn; solve [ repeat constructor ]. - } - iEpilogue "(HPC & Hincr_prog3 & Hr8)". - iCombine "Hincr_prog1" "Hincr_prog2" as "Hprog_done". - iCombine "Hprog_done" "Hincr_prog3" as "Hprog_done". - rewrite updatePcPerm_cap_non_E ; last by apply ExecPCPerm_not_E. - - subst Hrmap. - insert_register r_t1 with "[Hr1 $Hrmap]" as "Hrmap". - insert_register r_t2 with "[Hr2 $Hrmap]" as "Hrmap". - - (* We have jumped at the call instruction, we are at the same point - as the beginning - use the induction hypothesis *) - iApply (wp_wand with "[-]"). - iMod ("Hcls'" with "[$Hlocals $Hna]") as "Hna". - iMod ("Hcls" with "[Hcall_prog' Hrestore_prog Hprog_done $Hna]") as "Hna". - { iNext. - rewrite /add_incr_instrs Heqapp1'. - iApply (big_sepL2_app with "[$Hcall_prog']") ; simpl. - rewrite /add_incr_instrs' Heqapp2. - iApply (big_sepL2_app with "[$Hrestore_prog]") ; simpl. - iDestruct "Hprog_done" as "(?&?&?)" ; iFrame. } - - subst IH. - iApply ("IH" with - "[$HPC] [Hr0] [$Hr7] [$Hr8] [$Hr9] [Hr30] [Hrmap] [$Hna]"). - { iExists w5 ; iFrame. iApply "Hrmap_safe" ; eauto ; eauto. } - { iExists _ ; iFrame. iApply "Hrmap_safe" ; eauto ; eauto. } - { iClear "IH"; iFrame. iPureIntro. - apply regmap_full_dom in Hrmap_full. - rewrite !dom_delete_L !dom_insert_L dom_delete_L Hrmap_full. - set_solver+. } - { iIntros (v) "[H|->]" ; auto. iIntros "%contra" ; done. }. - (* TODO: it remains the technical stuff about the map_to_list *) - Admitted. - - Lemma prog_incr_code_spec - (* remaining registers *) (rmap : gmap RegName Word) - (* pc *) a pc_p pc_b pc_e a_first a_last - (* malloc *) f_m b_m e_m mallocN - (* linking *) b_link a_link e_link malloc_entry : - - (* Validity pc *) - ExecPCPerm pc_p → - SubBounds pc_b pc_e a_first a_last -> - contiguous_between a a_first a_last → - (* LT *) - withinBounds b_link e_link malloc_entry = true → - (a_link + f_m)%a = Some malloc_entry → - - (up_close (B:=coPset)mallocN ⊆ ⊤ ∖ ↑incrN) -> - - dom (gset RegName) rmap = all_registers_s ∖ {[ PC ]} -> - - (* Specification *) - ⊢ (( PC ↦ᵣ WCap pc_p pc_b pc_e a_first - ∗ ([∗ map] r_i↦w_i ∈ rmap , r_i ↦ᵣ w_i ∗ interp w_i) - ∗ prog_incr_code a r_t30 f_m - ∗ pc_b ↦ₐ WCap RO b_link e_link a_link - ∗ malloc_entry ↦ₐ WCap E b_m e_m b_m - ∗ na_own logrel_nais ⊤ - ∗ na_inv logrel_nais mallocN (malloc_inv b_m e_m) - -∗ WP Seq (Instr Executable) {{λ v, - (⌜v = HaltedV⌝ → ∃ r : Reg, full_map r ∧ registers_pointsto r ∗ na_own logrel_nais ⊤)%I - ∨ ⌜v = FailedV⌝ }}))%I. - Proof. - iIntros (Hpc_perm Hpc_bounds Hcont Hwb Hlink Hna Hdom) - "(HPC & Hrmap & Hprog & Hpcb & Hmalloc_entry & Hna & #Hinv_malloc)". - rewrite /prog_incr_code /prog_incr_instrs. - - (* Split the program to get each parts *) - iDestruct (big_sepL2_length with "Hprog") as %Hprog_length. - iDestruct (contiguous_between_program_split with "Hprog") as - (init_addrs add_addrs a_add) "(Hinit_prog & Hadd_prog & #Hcont)" - ;[apply Hcont|] - ;iDestruct "Hcont" as %(Hcont_init & Hcont_add & Heqapp1 & Ha_add). - iDestruct (big_sepL2_length with "Hinit_prog") as %Hlength_init. - - (* 1 - prepare the ressources for init_spec *) - (* 1.1 - extract the registers from the map (r7 r8 r9) *) - extract_register r_t7 with "Hrmap" as ( w7 Hw7 ) "[[Hr7 _] Hrmap]". - extract_register r_t8 with "Hrmap" as ( w8 Hw8 ) "[[Hr8 _] Hrmap]". - extract_register r_t9 with "Hrmap" as ( w9 Hw9 ) "[[Hr9 _] Hrmap]". - (* 1.2 - transform Hinit_prog into a codefrag predicate *) - iAssert (codefrag a_first init_incr_instrs) - with "[Hinit_prog]" - as "Hinit_prog". - {clear - Hcont_init Heqapp1 Hlength_init Ha_add. - rewrite /codefrag /region_pointsto /=. - replace init_addrs with (finz.seq_between a_first (a_first ^+ 4%nat)%a). - done. - apply region_addrs_of_contiguous_between in Hcont_init as ->. - replace a_add with (a_first ^+ 4%nat)%a by solve_addr. - done. - } - (* 1.3 - apply the spec *) - iApply (init_incr_spec with "[- $HPC $Hr7 $Hr8 $Hr9 $Hinit_prog]") - ; eauto - ;[solve_addr'|]. - iNext ; iIntros "(HPC & Hr7 & Hr8 & Hr9 & Hinit_prog)". - replace (a_first ^+ length init_incr_instrs)%a with a_add by solve_addr. - - (* 2 - prepare the ressources for add_incr_spec *) - (* 2.1 - extract registers *) - extract_register r_t30 with "Hrmap" as ( wadv Hwadv ) "[[Hr30 #Hinterp_adv] Hrmap]". - extract_register r_t0 with "Hrmap" as ( w0 Hw0 ) "[[Hr0 #Hinterp_w0] Hrmap]". - iDestruct (big_sepM_sep with "Hrmap") as "[Hrmap #Hrmap_interp]". - (* 2.2 - prepare the invariants *) - iCombine "Hpcb" "Hmalloc_entry" as "Hlink". - iMod (na_inv_alloc logrel_nais _ incrN_link with "Hlink") as "#Hinv_link". - iMod (na_inv_alloc logrel_nais _ incrN_prog with "Hadd_prog") as "#Hinv_prog". - (* 2.3 - apply the spec *) - iApply (add_incr_spec with "[- $HPC $Hr7 $Hr8 $Hr9 $Hrmap]") - ; eauto - ;[solve_addr'|]. - iSplitL "Hr0" ; first iExists _ ; iFrame ; iFrame "#". - iSplitL "Hr30" ; first iExists _ ; iFrame ; iFrame "#". - iPureIntro; rewrite !dom_delete_L Hdom ; set_solver+. - Qed. - - - - (* Lemma prog_incr_code_spec *) - (* (* remaining registers *) (rmap : gmap RegName Word) *) - (* (* pc *) a pc_p pc_b pc_e a_first a_last *) - (* (* malloc *) f_m b_m e_m mallocN *) - (* (* linking *) b_link a_link e_link malloc_entry : *) - - - - (* Lemma prog_incr_code_safe_to_share *) - (* pc_b pc_e a a_first a_last *) - (* f_m b_m e_m mallocN *) - (* b_link e_link a_link malloc_entry : *) - - (* (* Validity pc *) *) - (* SubBounds pc_b pc_e a_first a_last -> *) - (* contiguous_between a a_first a_last → *) - (* (* LT *) *) - (* withinBounds b_link e_link malloc_entry = true → *) - (* (a_link + f_m)%a = Some malloc_entry → *) - - (* (up_close (B:=coPset)mallocN ⊆ ⊤ ∖ ↑incrN) -> *) - - (* ⊢ na_inv logrel_nais incrN_prog (prog_incr_code a r_t30 f_m) *) - (* ∗ na_inv logrel_nais mallocN (malloc_inv b_m e_m) *) - (* ∗ na_inv logrel_nais incrN_link *) - (* (link_inv pc_b b_link e_link a_link malloc_entry b_m e_m) *) - (* -∗ interp (WCap E pc_b pc_e a_first). *) - (* Proof. *) - (* iIntros (Hpc_bounds Hcont Hwb HlinkE Hna) *) - (* "(#Hinv_prog& #Hinv_malloc& #Hinv_link)". *) - (* rewrite fixpoint_interp1_eq ; simpl. *) - (* iIntros (r). iNext; iModIntro. *) - (* iIntros "([%Hrmap_full #Hrmap_safe] & Hrmap & Hna)". *) - (* rewrite /interp_conf {1}/registers_pointsto. *) - - (* extract_register PC with "Hrmap" as "[HPC Hrmap]". *) - (* iApply (wp_wand with "[-]"). *) - (* - iApply (prog_incr_code_spec with "[- $HPC]") *) - (* ; try eauto *) - (* ; try apply ExecPCPerm_RX. *) diff --git a/theories/exercises/restrict_buffer.v b/theories/exercises/restrict_buffer.v deleted file mode 100644 index eb0e855b..00000000 --- a/theories/exercises/restrict_buffer.v +++ /dev/null @@ -1,568 +0,0 @@ -From iris.algebra Require Import frac. -From iris.proofmode Require Import tactics. -Require Import Eqdep_dec List. -From cap_machine Require Import malloc macros. -From cap_machine Require Import fundamental logrel rules. -From cap_machine.examples Require Import template_adequacy. -From cap_machine Require Import tactics_helpers proofmode register_tactics. -Open Scope Z_scope. - -(** Variant of the `subseg_buffer` where we don't restrict the range - of the buffer, but we restrict the permission *) -Section program_ro. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} {sealsg: sealStoreG Σ} - `{MP: MachineParameters}. - Context {nainv: logrel_na_invs Σ}. - - Definition prog_ro_code secret_off secret_val : list Word := - (* code: *) - encodeInstrsW [ - Lea r_t1 secret_off ; - Store r_t1 secret_val ; - Restrict r_t1 (encodePerm RO) ; - Jmp r_t30 - ]. - - Definition roN := nroot .@ "roN". - Definition prog_roN := roN .@ "prog". - Definition prog_ro_inv a_prog secret_off secret_val := - na_inv logrel_nais prog_roN (codefrag a_prog (prog_ro_code secret_off secret_val)). - - Definition inv_secret secret secret_val := - inv (logN.@secret%a) - (∃ w : leibnizO Word, secret ↦ₐ w ∗ (⌜w = WInt 0⌝ ∨ ⌜w = WInt secret_val⌝ ))%I. - - Definition inv_buffer addr_buffer := - inv (logN.@addr_buffer%a) - (∃ w : leibnizO Word, addr_buffer ↦ₐ w ∗ (⌜w = WInt 0⌝)). - - Lemma prog_ro_spec_base - p_pc b_pc e_pc a_prog (* pc *) - p_mem b_mem e_mem (* mem *) - w_adv - (secret_off secret_val : Z) - φ : - let secret := (b_mem^+secret_off)%a in - let len_p := (a_prog ^+ length (prog_ro_code secret_off secret_val))%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc a_prog len_p -> - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - - ⊢ (( inv_secret secret secret_val - ∗ PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ r_t30 ↦ᵣ w_adv - ∗ codefrag a_prog (prog_ro_code secret_off secret_val) - ∗ ▷ ( PC ↦ᵣ updatePcPerm w_adv - ∗ r_t1 ↦ᵣ WCap RO b_mem e_mem secret%a - ∗ r_t30 ↦ᵣ w_adv - ∗ codefrag a_prog (prog_ro_code secret_off secret_val) - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem. - iIntros "(#Hinv_secret& HPC& Hr1& Hr30& Hprog& Post)". - subst secret len_p. - - codefrag_facts "Hprog". - simpl in *. - rewrite /prog_ro_code. - assert (Hp_mem': ~ p_mem = E) - by (intros -> ; simpl in Hp_mem ; discriminate). - iGo "Hprog". - { transitivity (Some (b_mem ^+secret_off)%a) ; auto. solve_addr. } - - (* open the invariant inv_secret, execute the instruction, close the invariant *) - wp_instr. - iInv "Hinv_secret" as (w_secret) ">[Hsecret [->|->]]" "Hinv_close_secret". - - all: iInstr "Hprog" ; try solve_addr. - all: - iMod ("Hinv_close_secret" with "[Hsecret]") as "_" - ; try ( iNext ; iExists _ ; iFrame ; iRight ; done ) ; iModIntro. - all: wp_pure. - all: iInstr "Hprog"; - try (rewrite decode_encode_perm_inv; - rewrite /writeAllowed in Hp_mem; - destruct p_mem ; try discriminate; auto). - all: iInstr "Hprog". - - all: iApply "Post". - all: replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off +1))%a by solve_addr. - all: iFrame. - Qed. - - - Lemma prog_ro_spec - p_pc b_pc e_pc a_prog (* pc *) - p_mem b_mem e_mem (* mem *) - w_adv - (secret_off secret_val : Z) - EN φ : - let secret := (b_mem^+secret_off)%a in - let len_p := (a_prog ^+ length (prog_ro_code secret_off secret_val))%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc a_prog len_p -> - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - - ↑prog_roN ⊆ EN -> - - ⊢ (( prog_ro_inv a_prog secret_off secret_val - ∗ inv_secret secret secret_val - ∗ PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ r_t30 ↦ᵣ w_adv - ∗ na_own logrel_nais EN - ∗ ▷ ( PC ↦ᵣ updatePcPerm w_adv - ∗ r_t1 ↦ᵣ WCap RO b_mem e_mem secret%a - ∗ r_t30 ↦ᵣ w_adv - ∗ na_own logrel_nais EN - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem Hnainv_prog. - iIntros "(#Hinv_prog& #Hinv_secret& HPC& Hr1& Hr30& Hna& Post)". - subst secret len_p. - - iMod (na_inv_acc with "Hinv_prog Hna") as "(>Hprog& Hna& Hinv_close_prog)" - ; auto. - - iApply (prog_ro_spec_base with "[-]") ; iFrameAutoSolve ; iFrame "#". - iNext ; iIntros "(HPC & Hr1 & Hr30 & Hprog)". - iMod ("Hinv_close_prog" with "[$Hprog $Hna]") as "Hna". - iApply "Post". - iFrame. - Qed. - - (* TODO: ask if I can do diffently, I mean by defining on-the-fly - in the proof *) - Program Definition inv_secret_ne secret : leibnizO Word -n> iPropO Σ := - λne w, (⌜w = WInt 0⌝ ∨ ⌜w = WInt secret⌝)%I. - Program Definition inv_buffer_ne : leibnizO Word -n> iPropO Σ := - λne w, ⌜w = WInt 0⌝%I. - - Lemma prog_ro_spec_full - p_pc b_pc e_pc a_prog (* pc *) - p_mem b_mem e_mem (* mem *) - w_adv - (secret_off secret_val : Z) - rmap : - - let secret := (b_mem^+secret_off)%a in - let len_p := (a_prog ^+ length (prog_ro_code secret_off secret_val))%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc a_prog len_p -> - - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - (* the adversary code contains only instructions *) - dom rmap = all_registers_s ∖ {[ PC; r_t1; r_t30 ]} → - - ⊢ (( prog_ro_inv a_prog secret_off secret_val - ∗ inv_secret secret secret_val - ∗ ([∗ list] a ∈ (finz.seq_between b_mem secret), inv_buffer a ) - ∗ ([∗ list] a ∈ (finz.seq_between (secret ^+1)%a e_mem), inv_buffer a) - ∗ PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ r_t30 ↦ᵣ w_adv - ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ interp w) - ∗ na_own logrel_nais ⊤ - ∗ interp w_adv) - -∗ WP Seq (Instr Executable) - {{ v, ⌜v = HaltedV⌝ → ∃ r : Reg, full_map r ∧ registers_pointsto r ∗ na_own logrel_nais ⊤ }})%I. - Proof. - intros * Hpc_perm Hpc_bounds Hvsecret Hp_mem Hrmap_dom. - iIntros "(#Hinv_prog & #Hinv_secret & #Hinv_mem & #Hinv_mem' & HPC & Hr1 & Hr30 & Hrmap & Hna & #Hinterp_adv)". - - (* Prove that the capability pointing to the adversary code is safe to - execute using the FTLR. *) - - iDestruct (jmp_to_unknown with "Hinterp_adv") as "Cont". - - iApply (prog_ro_spec with "[-]") ; eauto. - iFrame ; iFrame "#". - iNext ; iIntros "(HPC & Hr1 & Hr30 & Hna)". - (* Show that the contents of r1 are safe *) - iAssert ( interp (WCap RO b_mem e_mem (b_mem ^+ secret_off)%a)) - as "#Hmem_safe". - { - rewrite /interp /=. - rewrite (fixpoint_interp1_eq (WCap RO b_mem e_mem _)) /=. - rewrite (finz_seq_between_split b_mem (b_mem ^+secret_off)%a e_mem) - ; [|subst secret ; solve_addr]. - rewrite (finz_seq_between_cons (b_mem ^+secret_off)%a e_mem) - ; [|subst secret ; auto]. - replace ((b_mem ^+ secret_off) ^+ 1)%a - with (b_mem ^+ (secret_off+1))%a - by (subst secret ; by solve_addr). - iApply big_sepL_app. - iSplitL ; cycle 1. - iApply big_sepL_cons. - iSplitL. - { - iClear "Cont Hinterp_adv Hinv_mem Hinv_prog". - rewrite /inv_secret; subst secret. - iExists (inv_secret_ne secret_val). rewrite /inv_secret_ne. - iFrame "#". - iNext ; iModIntro. - iIntros (w) "[->|->]" ; iApply interp_int. - } - 3: solve_addr. - all: subst secret; - replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off+1))%a by solve_addr. - 1: iApply (big_sepL_mono with "Hinv_mem'"). - 2: iApply (big_sepL_mono with "Hinv_mem"). - all: iIntros (???) "Hinv_buffer". - all: - iExists inv_buffer_ne - ; rewrite /inv_buffer /= - ; iSplitL ; try iApply "Hinv_buffer". - all: iNext ; iModIntro; iIntros (w) "->" ; iApply interp_int. - } - - (* TODO tactic to do that automatically ? *) - (* put the registers woth capability back into the register map *) - iDestruct (big_sepM_insert _ _ r_t30 with "[$Hrmap Hr30]") as "Hrmap". - { apply not_elem_of_dom. - rewrite Hrmap_dom. set_solver+. } - { by iFrame. } - iDestruct (big_sepM_insert _ _ r_t1 with "[$Hrmap Hr1]") as "Hrmap". - { rewrite !lookup_insert_ne //. apply not_elem_of_dom. - rewrite Hrmap_dom. set_solver+. } - { by iFrame ; iFrame "#". } - - iApply "Cont"; cycle 1. iFrame. iPureIntro. rewrite !dom_insert_L Hrmap_dom. - rewrite !singleton_union_difference_L. set_solver+. - Qed. - - (** As the subseg variant, we can't prove that this program is safe to share. - We have to create a closure around both buffer and program, or dynamically - allocate the memory. *) - -End program_ro. - - -Section program_closure_ro. - - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} {sealsg : sealStoreG Σ} - `{MP: MachineParameters}. - Context {nainv: logrel_na_invs Σ}. - Definition closure_roN : namespace := nroot .@ "closure_ro". - - (* TODO: the load section already exists in `subseg_buffer.v`, - I shouldn't rewrite it here *) - - (* we assume pc_b contains the capability pointing the allocated buffer - this code load the capability in R1 *) - Definition load_code := - encodeInstrsW [ - Mov r_t1 PC; (* r1 => (RWX, pc_b, pc_e, a_first) *) - GetB r_t2 r_t1; (* r2 => pc_b *) - GetA r_t3 r_t1; (* r3 => a_first *) - Sub r_t2 r_t2 r_t3; (* r2 => (pc_b - a_first) *) - Lea r_t1 r_t2; (* r1 => (RWX, pc_b, pc_e, pc_b) *) - Load r_t1 r_t1 (* r1 => (p_mem, b_mem, e_mem, b_mem) *) - ]. - - Definition closure_ro_code secret_off secret_val := - load_code ++ prog_ro_code secret_off secret_val. - - (** We define the invariants *) - (* cap_addr points to the capability for the buffer *) - Definition cap_memN := roN.@"cap_mem". - Definition cap_mem_inv p_mem b_mem e_mem cap_addr := - na_inv logrel_nais cap_memN - (cap_addr ↦ₐ WCap p_mem b_mem e_mem b_mem). - - (** Specifications *) - - (* We specify the closure program in a modular way, so we firstly specifie - the part of the code that load the capability *) - Lemma load_spec p_pc b_pc e_pc s_load (* pc *) - p_mem b_mem e_mem (* mem *) - w1 w2 w3 - EN φ : - - let e_load := (s_load ^+ length load_code)%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc s_load e_load -> - - writeAllowed p_mem = true -> - - ↑cap_memN ⊆ EN -> - - ⊢ ( cap_mem_inv p_mem b_mem e_mem b_pc - ∗ PC ↦ᵣ WCap p_pc b_pc e_pc s_load - ∗ r_t1 ↦ᵣ w1 - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - ∗ codefrag s_load load_code - ∗ na_own logrel_nais EN - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_load - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ (∃ n2, r_t2 ↦ᵣ WInt n2) - ∗ (∃ n3, r_t3 ↦ᵣ WInt n3) - ∗ codefrag s_load load_code - ∗ na_own logrel_nais EN - -∗ - WP Seq (Instr Executable) {{ φ }} - ) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intros end_load ; subst end_load. - iIntros (Hpc_perm Hpc_bounds Hp_mem Hnainv_cap) - "(#Hinv_cap & HPC & Hr1 & Hr2 & Hr3 & Hprog & Hna & Post)". - simpl in *. - codefrag_facts "Hprog". - iMod (na_inv_acc with "Hinv_cap Hna") as "(>Hcap& Hna& Hinv_close)" ; auto. - iGo "Hprog". - { transitivity (Some b_pc); eauto. solve_addr. } - iGo "Hprog". - iMod ("Hinv_close" with "[Hcap Hna]") as "Hna" ; iFrame. - iApply "Post". iFrame. - Qed. - - - Definition code_closure_roN := roN .@ "prog_closure". - Definition code_closure_ro_inv a_prog secret_off secret_val := - na_inv logrel_nais code_closure_roN (codefrag a_prog (closure_ro_code secret_off secret_val)). - - Lemma closure_ro_spec - pc_p pc_b pc_e s_closure_ro - p_mem b_mem e_mem - w1 w2 w3 w_adv - (secret_off secret_val : Z) - EN - φ : - - let secret := (b_mem^+secret_off)%a in - let e_closure_ro := (s_closure_ro ^+ length (closure_ro_code secret_off secret_val))%a in - - ExecPCPerm pc_p -> - SubBounds pc_b pc_e s_closure_ro e_closure_ro -> - - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - - ↑roN ⊆ EN -> - - ⊢ ( inv_secret secret secret_val - ∗ code_closure_ro_inv s_closure_ro secret_off secret_val - ∗ cap_mem_inv p_mem b_mem e_mem pc_b - ∗ PC ↦ᵣ WCap pc_p pc_b pc_e s_closure_ro - ∗ r_t1 ↦ᵣ w1 - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - ∗ r_t30 ↦ᵣ w_adv - ∗ na_own logrel_nais EN - ∗ ▷ ( PC ↦ᵣ updatePcPerm w_adv - ∗ r_t1 ↦ᵣ WCap RO b_mem e_mem secret%a - ∗ (∃ n2, r_t2 ↦ᵣ WInt n2) - ∗ (∃ n3, r_t3 ↦ᵣ WInt n3) - ∗ r_t30 ↦ᵣ w_adv - ∗ na_own logrel_nais EN - -∗ WP Seq (Instr Executable) {{ φ }}) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intros secret e_closure_ro ; subst secret e_closure_ro. - iIntros (Hpc_perm Hpc_bounds Hvsecret Hp_mem Hnainv) - "(#Hinv_secret & #Hinv_code & #Hinv_cap & HPC & Hr1 & Hr2 & Hr3 & Hr30 & Hna & Post)". - rewrite /code_closure_ro_inv. - - iMod (na_inv_acc with "Hinv_code Hna") - as "(>Hprog & Hna & Hprog_close)" - ; auto ; try solve_ndisj. - rewrite {2}/closure_ro_code. - - focus_block_0 "Hprog" as "Hload" "Hcont". - iApply (load_spec with "[-]") - ; try (iFrame ; iFrame "#") - ; eauto - ; try solve_ndisj. - iNext. - iIntros "(HPC & Hr1 & Hr2 & Hr3 & Hload & Hna)". - clear w2 w3. - iDestruct "Hr2" as (n2) "Hr2"; iDestruct "Hr3" as (n3) "Hr3". - unfocus_block "Hload" "Hcont" as "Hprog" . - - focus_block 1%nat "Hprog" as a_mid Ha_mid "Hprog" "Hcont". - iApply (prog_ro_spec_base with "[-]") - ; try (iFrame; iFrame "#") - ; eauto - ; try solve_ndisj. - iNext. - iIntros "(HPC & Hr1 & Hr30 &Hprog)". - unfocus_block "Hprog" "Hcont" as "Hprog" . - - iMod ("Hprog_close" with "[$Hprog $Hna]") as "Hna". - iApply "Post" ; iFrame ; iFrame "#". - Qed. - - Lemma closure_ro_spec_full - p_pc b_pc e_pc a_prog (* pc *) - p_mem b_mem e_mem (* mem *) - w_adv - (secret_off secret_val : Z) - rmap : - - let secret := (b_mem^+secret_off)%a in - let len_p := (a_prog ^+ length (closure_ro_code secret_off secret_val))%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc a_prog len_p -> - - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - dom rmap = all_registers_s ∖ {[ PC; r_t30 ]} → - - ⊢ (( inv_secret secret secret_val - ∗ code_closure_ro_inv a_prog secret_off secret_val - ∗ cap_mem_inv p_mem b_mem e_mem b_pc - ∗ ([∗ list] a ∈ (finz.seq_between b_mem secret), inv_buffer a ) - ∗ ([∗ list] a ∈ (finz.seq_between (secret ^+1)%a e_mem), inv_buffer a) - - ∗ PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ r_t30 ↦ᵣ w_adv - ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ interp w) - ∗ na_own logrel_nais ⊤ - ∗ interp w_adv) - -∗ WP Seq (Instr Executable) - {{ v, ⌜v = HaltedV⌝ → ∃ r : Reg, full_map r ∧ registers_pointsto r ∗ na_own logrel_nais ⊤ }})%I. - Proof. - intros * Hpc_perm Hpc_bounds Hvsecret Hp_mem Hrmap_dom. - iIntros - "(#Hinv_secret & #Hinv_prog & #HCap & #Hinv_mem & #Hinv_mem' & HPC & Hr30 & Hrmap & Hna & #Hinterp_adv)". - - (* FTLR on V(w_adv) *) - iDestruct (jmp_to_unknown with "Hinterp_adv") as "Cont". - - (* Preparation resources for `closure_ro_spec` *) - - iExtractList "Hrmap" [r_t1;r_t2;r_t3] as ["[Hr1 _]";"[Hr2 _]";"[Hr3 _]"]. - (* Extract the register r_t1 - r_t3 *) - - iApply (closure_ro_spec with "[-]") - ; try (iFrame "∗ #") ; eauto. - iNext - ; iIntros "(HPC & Hr1 & Hr2 & Hr3 & Hr30 & Hna)" - ; iDestruct "Hr2" as (n2) "Hr2" - ; iDestruct "Hr3" as (n3) "Hr3". - - (* In order to use the continuation, we have to re-insert the registers - r3, r2, r1 and r30 in the map, and thus to prove that they are safe to share. - For r3, r2 and r30 it's trivial, but there is some work to do for r1. *) - - (* r1 is safe to share *) - iAssert ( interp (WCap RO b_mem e_mem (b_mem ^+ secret_off)%a)) - as "#Hmem_safe". - { - rewrite /interp /=. - rewrite (fixpoint_interp1_eq (WCap RO b_mem e_mem (b_mem ^+ secret_off)%a)) /=. - rewrite (finz_seq_between_split b_mem (b_mem ^+secret_off)%a e_mem) - ; [|subst secret ; solve_addr]. - rewrite (finz_seq_between_cons (b_mem ^+secret_off)%a e_mem) - ; [|subst secret ; auto]. - replace ((b_mem ^+ secret_off) ^+ 1)%a - with (b_mem ^+ (secret_off+1))%a - by (subst secret;solve_addr). - iApply big_sepL_app. - iSplitL ; cycle 1. - iApply big_sepL_cons. - iSplitL. - { - iClear "Cont Hinterp_adv Hinv_mem Hinv_prog". - rewrite /inv_secret; subst secret. - iExists (inv_secret_ne secret_val). rewrite /inv_secret_ne. - iFrame "#". - iNext ; iModIntro. - iIntros (w) "[->|->]" ; iApply interp_int. - } - 3: solve_addr. - all: subst secret; - replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off+1))%a by solve_addr. - 1: iApply (big_sepL_mono with "Hinv_mem'"). - 2: iApply (big_sepL_mono with "Hinv_mem"). - all: iIntros (???) "Hinv_buffer". - all: - iExists inv_buffer_ne - ; rewrite /inv_buffer /= - ; iSplitL ; try iApply "Hinv_buffer". - all: iNext ; iModIntro; iIntros (w) "->" ; iApply interp_int. - } - - iCombine "Hr1 Hmem_safe" as "Hr1". - iPoseProof (interp_int n2)%I as "Hr2_safe"; iCombine "Hr2 Hr2_safe" as "Hr2". - iPoseProof (interp_int n3)%I as "Hr3_safe"; iCombine "Hr3 Hr3_safe" as "Hr3". - iCombine "Hr30 Hinterp_adv" as "Hr30". - iInsertList "Hrmap" [r_t1;r_t2;r_t3;r_t30]. - - (* Apply the continuation *) - iApply "Cont" ; [|iFrame]. - iPureIntro. - rewrite !dom_insert_L Hrmap_dom. - rewrite !singleton_union_difference_L. set_solver+. - Qed. - - Lemma closure_ro_safe_to_share - b_pc e_pc a_prog (* pc *) - p_mem b_mem e_mem (* mem *) - (secret_off secret_val : Z) : - - let secret := (b_mem^+secret_off)%a in - SubBounds b_pc e_pc a_prog (a_prog ^+ length (closure_ro_code secret_off secret_val))%a -> - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - - ⊢ ((inv_secret secret secret_val - ∗ code_closure_ro_inv a_prog secret_off secret_val - ∗ cap_mem_inv p_mem b_mem e_mem b_pc - ∗ ([∗ list] a ∈ (finz.seq_between b_mem secret), inv_buffer a ) - ∗ ([∗ list] a ∈ (finz.seq_between (secret ^+1)%a e_mem), inv_buffer a)) - -∗ interp (WCap E b_pc e_pc a_prog)). - Proof. - intro secret ; subst secret ; simpl. - iIntros (Hpc_bounds Hvsecret Hp_mem) - "(#Hinv_secret & #Hinv_code & #Hinv_cap & #Hinv_mem & #Hinv_mem')". - rewrite fixpoint_interp1_eq /= /interp_conf. - iIntros (regs) ; iNext ; iModIntro. - iIntros "([%Hrfull #Hrsafe] & Hregs & Hna)". - rewrite /registers_pointsto. - - (* Prepare the resources for closure_ro_spec_full *) - - iDestruct (big_sepM_insert_delete with "Hregs") as "[HPC Hregs]". - assert (is_Some (regs !! r_t30)) as [w30 Hw30] by apply Hrfull. - iDestruct (big_sepM_delete _ _ r_t30 with "Hregs") as "[Hr30 Hregs]". - { rewrite !lookup_delete_ne ; eauto. } - iAssert (interp w30) as "Hw30". - { iApply ("Hrsafe" $! r_t30 w30) ; eauto. } - - iApply (closure_ro_spec_full - RX b_pc e_pc a_prog - p_mem b_mem e_mem - w30 - secret_off secret_val - (delete r_t30 (delete PC regs)) - with "[-]") - ; eauto - ; try apply ExecPCPerm_RX - ; try (iFrame ; iFrame "#"). - - rewrite !dom_delete_L. - rewrite difference_difference_l_L. - apply regmap_full_dom in Hrfull; rewrite Hrfull. - set_solver. - - iDestruct (big_sepM_sep _ (λ k v, interp v)%I with "[Hregs]") as "Hregs". - { iSplitL. by iApply "Hregs". iApply big_sepM_intro. iModIntro. - iIntros (r' ? HH). repeat eapply lookup_delete_Some in HH as [? HH]. - iApply ("Hrsafe" $! r'); auto. } - simpl. - iFrame. -Qed. - -End program_closure_ro. diff --git a/theories/exercises/subseg_buffer.v b/theories/exercises/subseg_buffer.v deleted file mode 100644 index 19d95fdc..00000000 --- a/theories/exercises/subseg_buffer.v +++ /dev/null @@ -1,503 +0,0 @@ -From iris.algebra Require Import frac. -From iris.proofmode Require Import tactics. -Require Import Eqdep_dec List. -From cap_machine Require Import malloc macros. -From cap_machine Require Import fundamental logrel. -From cap_machine.proofmode Require Import tactics_helpers proofmode register_tactics. -From cap_machine.examples Require Import template_adequacy. -Open Scope Z_scope. - - -(** Exercise - the region is already allocated and the capability pointing to this - region is in R1. As a first step, the adversary code is known and just halts. *) -Section base_program. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} - `{MP: MachineParameters}. - - (** `r_mem` is the register that contains the capability pointing to - the allocated buffer: - - `secret_off` is the offset of the secret in the buffer - - `secret` is the value stored in the buffer - *) - Definition prog_base_instrs r_mem (secret_off secret : Z) : list Word := - encodeInstrsW [ - Lea r_mem secret_off; - Store r_mem secret; - GetB r_t2 r_mem; - GetE r_t3 r_mem; - Add r_t2 r_t2 (secret_off + 1); - Subseg r_mem r_t2 r_t3 - ]. - - (** Jump to the adversary in register `r30` at the end of the program *) - Definition prog_code secret_off secret_val: list Word := - prog_base_instrs r_t1 secret_off secret_val ++ encodeInstrsW [Jmp r_t30]. - - (** The adversary code is known --- it just halts *) - Definition adv_code : list Word := - encodeInstrsW [ Halt ]. - - (** Specification of : - - executes the first part - - jump to the adversary - - halts - *) - Lemma prog_spec (a_adv : Addr) - p_pc b_pc e_pc a_prog (* pc *) - p_mem (b_mem e_mem: Addr) (* mem *) - secret_off secret_val - w2 w3 : - let secret := (b_mem ^+ secret_off)%a in - let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog len_p → - - (b_mem ≤ secret < e_mem)%a → - writeAllowed p_mem = true → - - ⊢ ( (* PC points to `prog_code` *) - PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ codefrag a_prog (prog_code secret_off secret_val) - - (* r1 points to the allocated memory *) - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - (* which is filled by zeroes *) - ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]] - - (* r30 point to the adversary code *) - ∗ r_t30 ↦ᵣ WCap E a_adv (a_adv ^+ (length adv_code))%a a_adv - ∗ codefrag a_adv adv_code - - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - - -∗ WP Seq (Instr Executable) {{ - λ v, ⌜v = HaltedV⌝ -∗ (* The machine is halted after the adversary *) - r_t1 ↦ᵣ WCap p_mem (b_mem ^+ (secret_off + 1))%a e_mem secret%a - ∗ r_t2 ↦ᵣ WInt (b_mem + (secret_off + 1)) - ∗ r_t3 ↦ᵣ WInt e_mem - ∗ codefrag a_prog (prog_code secret_off secret_val) - ∗ codefrag a_adv adv_code - ∗ secret ↦ₐ WInt secret_val - ∗ [[b_mem, secret]] ↦ₐ [[ region_addrs_zeroes b_mem secret]] - ∗ [[(secret ^+ 1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (secret ^+ 1)%a e_mem ]] - }})%I. - - Proof. - intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem. - iIntros "(HPC & Hprog & Hr1 & Hmem & Hr30 & Hadv & Hr2 & Hr3)". - - (* 1 - prepare the assertions for the proof *) - subst secret len_p. - - (* Derives the facts from the codefrag *) - codefrag_facts "Hprog". - codefrag_facts "Hadv". - simpl in *. - rewrite /prog_code. - - (* This assertion will be helpful seeral times during the proof *) - assert (Hp_mem': p_mem ≠ E). { - intros ->. - simpl in Hp_mem. - discriminate. - } - - (* 2 - Use the WP rules for each instructions *) - (* Lea r_t1 3 *) - iInstr "Hprog". - { transitivity (Some (b_mem ^+ secret_off)%a); solve_addr +Hlen_mem. } - - (* Store r_t1 42, where r_t1 = (RWX, b, e, secret) *) - (* The store requires the resource `secret ↦ₐ w` for some w, - we thus extract the resource from the memory buffer *) - rewrite (region_addrs_zeroes_split b_mem (b_mem ^+ secret_off)%a e_mem); - [| solve_addr +Hlen_mem ]. - - iDestruct (region_pointsto_split - b_mem e_mem (b_mem ^+ secret_off)%a - (region_addrs_zeroes b_mem (b_mem ^+ secret_off)%a) - (region_addrs_zeroes (b_mem ^+ secret_off)%a e_mem) - with "Hmem") as "[Hmem Hmem']". - { solve_addr +Hlen_mem. } - { unfold region_addrs_zeroes. by rewrite length_replicate. } - - unfold region_addrs_zeroes at 2. - rewrite finz_dist_S; [| solve_addr +Hlen_mem ]. - rewrite replicate_S. - iDestruct (region_pointsto_cons - (b_mem ^+ secret_off)%a _ e_mem (WInt 0) - (region_addrs_zeroes _ e_mem) - with "Hmem'") as "[Hsecret Hmem']". - { transitivity (Some (b_mem ^+ (secret_off + 1))%a); solve_addr +Hlen_mem. } - { solve_addr +Hlen_mem. } - - (* Now that we have the secret address, we can continue *) - iInstr "Hprog". - { solve_addr +Hlen_mem. } - - (* getB, getE, add, subseg *) - iGo "Hprog". - { transitivity (Some (b_mem ^+ (secret_off + 1))%a); solve_addr +Hlen_mem. } - { solve_addr +Hlen_mem. } - - (* jmp *) - iInstr "Hprog". - - (* halts in the adversary code *) - rewrite /adv_code. - iInstr "Hadv". - - (* 3 - The machine is halted, prove that the post condition holds *) - wp_end. - - iIntros "_". - replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off + 1))%a by solve_addr. - iFrame. - Qed. - -End base_program. - -(** We use a CPS specification. We don't know the adversary code, - thus we stop the specification after the jump. We give only the necessary - resources. *) -Section base_program_CPS. - - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} {sealsg : sealStoreG Σ} - `{MP: MachineParameters}. - - (* For a clearer context, we will use these following notations *) - (* Note that the invocation of `solve_addr` will be done with the full Coq context *) - (* Therefore, these tactics will require more computation. *) - Local Tactic Notation "solve_addr'" := - repeat (lazymatch goal with x := _ |- _ => subst x end); solve_addr. - - Local Tactic Notation "iGo'" constr(H) := repeat (iGo H; try solve_addr'). - - (** Specification of the program before the jump to the adversary. - The specification and the proof are essentially the same as the - previous one. *) - Lemma prog_base_spec - r_mem secret_off secret (* instantiation prog_base *) - p_pc b_pc e_pc s_prog (* pc *) - p_mem (b_mem e_mem : Addr) (* mem *) - w2 w3 - φ : - - let e_prog := (s_prog ^+ length (prog_base_instrs r_mem secret_off secret))%a in - let a_secret := (b_mem ^+ secret_off)%a in - - (* Validity pc *) - ExecPCPerm p_pc → - SubBounds b_pc e_pc s_prog e_prog → - - (* Validity buffer *) - ( b_mem ≤ a_secret < e_mem)%a → - writeAllowed p_mem = true → - - (* Specification *) - ⊢ (( PC ↦ᵣ WCap p_pc b_pc e_pc s_prog - ∗ r_mem ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]] - ∗ codefrag s_prog (prog_base_instrs r_mem secret_off secret) - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_mem ↦ᵣ WCap p_mem (a_secret ^+ 1)%a e_mem a_secret - ∗ r_t2 ↦ᵣ WInt (b_mem + secret_off + 1) - ∗ r_t3 ↦ᵣ WInt e_mem - ∗ [[b_mem, a_secret]] ↦ₐ [[ region_addrs_zeroes b_mem a_secret ]] - ∗ a_secret ↦ₐ WInt secret - ∗ [[(a_secret ^+ 1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (a_secret ^+ 1)%a e_mem ]] - ∗ codefrag s_prog (prog_base_instrs r_mem secret_off secret) - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof with (try solve_addr'). - (* `Proof with` will replace each `...` by `try solve_addr'` *) - intros e_prog a_secret Hpc_perm Hpc_bounds Hsecret_bounds Hp_mem. - iIntros "(HPC & Hr_mem & Hr2 & Hr3 & Hmem & Hprog & Post)". - - rewrite /region_pointsto. - codefrag_facts "Hprog". - - iGo' "Hprog". - { transitivity (Some (b_mem ^+ secret_off)%a)... } - { intros ->; simpl in Hp_mem; discriminate. } - - rewrite (region_addrs_zeroes_split b_mem a_secret e_mem)... - iDestruct (region_pointsto_split - b_mem e_mem a_secret - (region_addrs_zeroes b_mem a_secret) - (region_addrs_zeroes a_secret e_mem) - with "Hmem") as "[Hmem Hmem']"... - { unfold region_addrs_zeroes. by rewrite length_replicate. } - - unfold region_addrs_zeroes at 4. - rewrite finz_dist_S... - rewrite replicate_S. - - iDestruct (region_pointsto_cons - a_secret (a_secret ^+ 1)%a e_mem (WInt 0) - (region_addrs_zeroes _ e_mem) - with "Hmem'") as "[Hsecret Hmem']"... - - (* getB getE add subseg *) - iGo' "Hprog". - { transitivity (Some (b_mem ^+ (secret_off + 1))%a)... } - { intros ->; simpl in Hp_mem; discriminate. } - { solve_addr'. } - - (* Post condition *) - iApply "Post". - - subst e_prog; simpl in *. - replace (b_mem ^+ (secret_off + 1))%a with (a_secret ^+ 1)%a by solve_addr'. - replace (b_mem + secret_off + 1) with (b_mem + (secret_off + 1)) by lia. - iFrame. - Qed. - - - (** Specification of the program until the jump to the unknown adversary code *) - Lemma prog_spec_CPS - wadv - p_pc b_pc e_pc a_prog (* pc *) - p_mem (b_mem e_mem : Addr) (* mem *) - w2 w3 - secret_off secret_val - φ : - let secret := (b_mem ^+ secret_off)%a in - let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in - - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog len_p → - - (b_mem ≤ secret < e_mem)%a → - writeAllowed p_mem = true → - - ⊢ ( (* PC points to prog_code*) - ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ codefrag a_prog (prog_code secret_off secret_val) - (* r1 points to the allocated memory*) - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - (* which is filled by zeroes *) - ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]] - (* r30 point to the adversary code *) - ∗ r_t30 ↦ᵣ wadv - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - ∗ ▷ ( PC ↦ᵣ updatePcPerm wadv (* The specification stops after the jump *) - ∗ r_t1 ↦ᵣ WCap p_mem (b_mem ^+ (secret_off + 1))%a e_mem secret%a - ∗ r_t2 ↦ᵣ WInt (b_mem + (secret_off + 1)) - ∗ r_t3 ↦ᵣ WInt e_mem - ∗ r_t30 ↦ᵣ wadv - ∗ codefrag a_prog (prog_code secret_off secret_val) - ∗ [[(secret ^+ 1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (secret ^+ 1)%a e_mem ]] - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem. - iIntros "(HPC & Hprog & Hr1 & Hmem & Hr30 & Hr2 & Hr3 & Post)". - - rewrite /prog_code. - codefrag_facts "Hprog". - - focus_block_0 "Hprog" as "Hprog" "Hcont". - - (* 1 - Specification from Lea to Subsug *) - iApply (prog_base_spec with "[-]"); - last iFrame; eauto; - first solve_addr'. - - iIntros "!> (HPC & Hr1 & Hr2 & Hr3 & Hmem & Hsecret & Hmem' & Hprog)". - - unfocus_block "Hprog" "Hcont" as "Hprog". - - (* 2 - Jump to the adversary *) - (* jmp *) - iInstr "Hprog". - - (* 3 - Post condition *) - iApply "Post". - - subst secret. - replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off + 1))%a by solve_addr. - replace (b_mem + secret_off + 1)%Z with (b_mem + (secret_off + 1))%Z by lia. - iFrame. - Qed. - - Context {nainv: logrel_na_invs Σ}. - - (** Assuming that the word of the adversary is safe to share, - the machine executes safely and completely. - The assumption makes sense, because we consider adversary programs containing - no capabilities. *) - Lemma prog_spec_CPS_full - p_pc b_pc e_pc a_prog (* pc *) - p_mem (b_mem e_mem : Addr) (* mem *) - w_adv - secret_off secret_val - rmap : - - let secret := (b_mem ^+ secret_off)%a in - let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in - - (* Validity PC*) - ExecPCPerm p_pc → - SubBounds b_pc e_pc a_prog len_p → - - (* Validity buffer *) - (b_mem ≤ secret < e_mem)%a → - writeAllowed p_mem = true → - - (* Register map for the big_sep of registers *) - dom rmap = all_registers_s ∖ {[ PC; r_t1; r_t30 ]} → - - ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ r_t30 ↦ᵣ w_adv - ∗ codefrag a_prog (prog_code secret_off secret_val) - ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]] - (* All the registers contains integers *) - ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ ⌜is_z w = true⌝) - (* The NA token is required for the post condition *) - ∗ na_own logrel_nais ⊤ - (* The adversary word is safe to share *) - ∗ interp w_adv - (* Post condition of the corollary of the FTLR *) - -∗ WP Seq (Instr Executable) - {{ v, ⌜v = HaltedV⌝ → (* if the machine halts *) - (* we own all the registers *) - ∃ r : Reg, full_map r ∧ registers_pointsto r - (* all the NA invariants are closed*) - ∗ na_own logrel_nais ⊤}})%I. - - Proof. - intros * Hpc_perm Hpc_bounds Hvsecret Hp_mem Hrmap_dom. - iIntros "(HPC & Hr1 & Hr30 & Hprog & Hregion & Hrmap & Hna & #Hadv)". - - (* Using the FLTR corollary, w_adv is safe to execute and we can specify - what happens after the jump: safe and complete execution *) - (* It is required to do it _before_ the specification, because it introduces a - later modality *) - iDestruct (jmp_to_unknown with "Hadv") as "Cont". - - (* 1 - Specification of the known program *) - (* Extract the register r_t2 and r_t3, required for `prog_spec_CPS` *) - iExtractList "Hrmap" [r_t2; r_t3] as ["[Hr2 _]"; "[Hr3 _]"]. - - iApply (prog_spec_CPS with "[-]"); [ eassumption .. |]. - iFrame "HPC Hr1 Hr30 Hregion Hr2 Hr3 Hprog". - iIntros "!> (HPC & Hr1 & Hr2 & Hr3 & Hr30 & Hprog & Hmem)". - - (* 2 - The continuation requires all the registers to be safe to share *) - (* Show that the contents of r1 are safe *) - replace ((b_mem ^+ secret_off) ^+ 1)%a - with (b_mem ^+ (secret_off + 1))%a by (subst secret; by solve_addr). - - rewrite /region_pointsto. - iDestruct (region_integers_alloc' _ _ _ (b_mem ^+ secret_off)%a _ p_mem with "Hmem") - as ">#Hmem_safe". - { rewrite /region_addrs_zeroes. apply Forall_replicate. auto. } - - (* put the other registers back into the register map *) - iAssert ( ⌜is_z (WInt (b_mem + (secret_off + 1))) = true ⌝)%I as "Hvr2"; first auto. - iCombine "Hr2 Hvr2" as "Hr2". - - iAssert ( ⌜is_z (WInt e_mem) = true ⌝)%I as "Hvr3"; first auto. - iCombine "Hr3 Hvr3" as "Hr3". - - iInsertList "Hrmap" [r_t3; r_t2]. iClear "Hvr2 Hvr3". - - (* Show that the contents of unused registers is safe *) - set (rmap' := <[r_t2 := WInt _]> (<[r_t3 := _]> rmap)). - - iAssert ([∗ map] r↦w ∈ rmap', r ↦ᵣ w ∗ interp w)%I with "[Hrmap]" as "Hrmap". - { subst rmap'. - iApply (big_sepM_mono with "Hrmap"). - iIntros (r w Hr') "[$ %Hw]". - destruct_word w; [| by inversion Hw .. ]. - rewrite fixpoint_interp1_eq //. } - - (* put the registers with capability back into the register map *) - iCombine "Hr1 Hmem_safe" as "Hr1". - iCombine "Hr30 Hadv" as "Hr30". - subst rmap'; iInsertList "Hrmap" [r_t1;r_t30]. - - (* 3 - Use the continuation *) - (* Prepare the resources *) - iApply "Cont"; [| iFrame ]. - iPureIntro. - rewrite !dom_insert_L Hrmap_dom. - rewrite !singleton_union_difference_L. - set_solver+. - Qed. - -(** The encapsulation of the program is safe-to-share - By unfolding the definition of V(E,-,-,-) , we can use only persistent - proposition. Thus, all the required resources of the memory have to be - encapsulated in invariants. *) - - Definition N : namespace := nroot .@ "secret". - Definition start_memN := (N.@"start_mem"). - Definition secretN := (N.@"secret"). - Definition end_memN := (N.@"end_mem"). - Definition codeN := (N.@"code"). - - (* The first part of the buffer, before the secret, is always zeroes *) - Definition start_mem_inv (b_mem e_mem : Addr) secret_off:= - let secret_addr := (b_mem ^+ secret_off)%a in - na_inv logrel_nais start_memN - ([[b_mem, secret_addr]] ↦ₐ [[ region_addrs_zeroes b_mem secret_addr ]]). - - (* The secret is either equal to 0 -- at the initialisation -- or equal to - 42 -- after the secret was stored *) - Definition secret_inv (b_mem : Addr) secret_off secret := - let secret_addr := (b_mem ^+ secret_off)%a in - na_inv logrel_nais secretN - ((secret_addr ↦ₐ WInt 0) ∨ (secret_addr ↦ₐ WInt secret)). - - (* The code instruction is stored in an invariant as well *) - Definition code_inv a_prog secret_off secret := - na_inv logrel_nais codeN (codefrag a_prog (prog_code secret_off secret)). - - Definition end_mem_inv b_mem e_mem secret_off := - let n_secret_addr := (b_mem ^+ (secret_off + 1))%a in - na_inv logrel_nais end_memN - ([∗ list] a ∈ finz.seq_between n_secret_addr e_mem, - ∃ P, inv (logN .@ a) (interp_ref_inv a P) ∗ read_cond P interp - ∗ write_cond P interp)%I. - - - (** Currently, we cannot prove the closure, because we need more information - about the buffer. Since the closure means "called in any context", - we cannot assume that the buffer is correctly set up in the context, - i.e. we cannot assume that the register r1 contains the capability - pointing to the buffer. - - In order to get the right context, we may change our code. Here is 2 - solutions: - - we assume that our program contains a capability pointing to our buffer, - we need to load the capability in R1 before our program. It corresponds - to a closure around the code and the buffer - - we dynamically allocate the buffer, by using the `malloc` macro. - It is different from the previous solution, because it allocates a new - buffer each time our program is called - - *) - Lemma prog_CPS_safe_to_share b_pc e_pc a_prog (b_mem e_mem: Addr) secret_off secret : - - (* The instructions of the code are in the memory closure of the PCC *) - SubBounds b_pc e_pc a_prog (a_prog ^+ length (prog_code secret_off secret))% a → - (* The secret offset fits in the memory buffer *) - (b_mem ≤ b_mem ^+ secret_off < e_mem)%a → - - ⊢ ( code_inv a_prog secret_off secret - ∗ start_mem_inv b_mem e_mem secret_off - ∗ end_mem_inv b_mem e_mem secret_off - ∗ secret_inv b_mem secret_off secret) - - -∗ interp (WCap E b_pc e_pc a_prog). - Abort. - -End base_program_CPS. diff --git a/theories/exercises/subseg_buffer_call.v b/theories/exercises/subseg_buffer_call.v deleted file mode 100644 index cf16e271..00000000 --- a/theories/exercises/subseg_buffer_call.v +++ /dev/null @@ -1,1175 +0,0 @@ -From iris.algebra Require Import frac. -From iris.proofmode Require Import tactics. -From cap_machine Require Import malloc macros. -From cap_machine Require Import fundamental logrel rules. -From cap_machine.proofmode Require Import tactics_helpers proofmode register_tactics. -From cap_machine.examples Require Import template_adequacy. -From cap_machine.exercises Require Import subseg_buffer. -From cap_machine.examples Require Import template_adequacy template_adequacy_ocpl. -From cap_machine Require Import call callback. -Open Scope Z_scope. - -(** Variant of the exercise where we use the call macro - to jump to the adversary *) - -(** The full program does the following: - - allocates a region - - stores a secret data in the newly allocated region - - derives 2 capabilities: - + Cs: from the beginning of the buffer to the secret address - + Cp: from the secret address (not included) to the end of the buffer - - calls the adversary (with the call macro) - + locally encapsulates Cs - + gives Cp in parameter for the adversary - - after the call, restores the locals and asserts the integrity of - the secret data - - halts *) - -Section program_call. - - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} {sealsg: sealStoreG Σ} - `{MP: MachineParameters}. - Context {nainv: logrel_na_invs Σ}. - - (** Definition useful tactics *) - (* Address arithmetic solver with substitution *) - Local Ltac solve_addr' := - repeat match goal with x := _ |- _ => subst x end - ; solve_addr. - - (* Set an Iris proposition as a variable: allows to hide it in Emacs - and clarify the goal buffer *) - Local Ltac iHide0 irisH coqH := - let coqH := fresh coqH in - match goal with - | h: _ |- context [ environments.Esnoc _ (INamed irisH) ?prop ] => - set (coqH := prop) - end. - - Tactic Notation "iHide" constr(irisH) "as" ident(coqH) := - iHide0 irisH coqH. - - (** Definition of the program *) - - (** P1) First part: store the secret data, derive Cp and derive Cs *) - (* - r_mem is the register that contains the capability pointing to - the allocated buffer - - secret_off is the offset of the secret in the buffer - - secret is the value stored in the buffer *) - Definition prog_secret_instrs - (r_mem r_mem' : RegName) (secret_off secret : Z) : list Word := - encodeInstrsW [Mov r_mem' r_mem ] - ++ prog_base_instrs r_mem secret_off secret (* store data + derive Cp*) - ++ encodeInstrsW [ (* derive Cs*) - GetB r_t2 r_mem' ; - GetB r_t3 r_mem' ; - Add r_t3 r_t3 (secret_off+1) ; - Subseg r_mem' r_t2 r_t3]. - - (** P) Full program, no assumptions on the registers *) - Definition prog_call_instrs f_m f_a (size : nat) secret_off secret_val : list Word := - malloc_instrs f_m size ++ - encodeInstrsW [ Mov r_t7 r_t1 ; Mov r_t1 0 ] ++ - (prog_secret_instrs r_t7 r_t8 secret_off secret_val) ++ - call_instrs f_m (offset_to_cont_call [r_t7]) r_t30 [r_t8] [r_t7] ++ - restore_locals_instrs r_t2 [r_t8] ++ - encodeInstrsW [ (* prepare the registers for the assert macro *) - Load r_t2 r_t2; (* r_t2 -> (RWX, b_mem, (b_mem ^+ (secret_off+1))%a, b_mem) *) - Lea r_t2 secret_off; (* r_t2 -> (RWX, b_mem, (b_mem ^+ (secret_off+1))%a, (b_mem ^+ secret_off)%a) *) - Load r_t4 r_t2; (* r_t4 -> secret_val *) - Mov r_t5 secret_val (* Prepare the assert *) - ] ++ assert_instrs f_a ++ encodeInstrsW [ Halt ]. - - Definition prog_call_code a_prog f_m f_a (size : nat) secret_off secret_val := - ([∗ list] a_i;w ∈ a_prog;(prog_call_instrs f_m f_a size secret_off secret_val), a_i ↦ₐ w)%I. - - - (** Definition of the invariants *) - Definition call_versionN : namespace := nroot .@ "call_version". - - (* Program invariant *) - Definition call_codeN := (call_versionN.@"code"). - Definition prog_call_inv a f_m f_a size secret_off secret_val := - na_inv logrel_nais call_codeN (prog_call_code a f_m f_a size secret_off secret_val ). - - Definition malloc_call_inv b_m e_m := - na_inv logrel_nais ocpl.mallocN (malloc_inv b_m e_m). - - (* Assert invariant *) - Definition assert_call_inv b_a e_a a_flag := - na_inv logrel_nais ocpl.assertN (assert_inv b_a a_flag e_a). - - Definition flag_call_inv a_flag flagN := - inv flagN (a_flag ↦ₐ WInt 0%Z) . - - Definition call_actN : namespace := call_versionN .@ "act". - Definition call_localsN : namespace := call_versionN .@ "locals". - - (** Specifications *) - (* Specification P1 *) - Lemma prog_secret_spec - r_mem r_mem' secret_off secret (* instantiation prog_base *) - p_pc b_pc e_pc s_prog (* pc *) - p_mem b_mem e_mem (* mem *) - w2 w3 - φ : - - let e_prog := (s_prog ^+ length (prog_secret_instrs r_mem r_mem' secret_off secret))%a in - let a_secret := (b_mem ^+ secret_off)%a in - - (* Validity pc *) - ExecPCPerm p_pc -> - SubBounds b_pc e_pc s_prog e_prog -> - - (* Validity buffer *) - ( b_mem <= a_secret < e_mem)%a -> - writeAllowed p_mem = true -> - - (* Specification *) - ⊢ (( PC ↦ᵣ WCap p_pc b_pc e_pc s_prog - ∗ r_mem ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ (∃ wm, r_mem' ↦ᵣ wm) - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - (* I'd like to generelize more this hypothesis, such that it can be - usefull even if I don't have a region of zeroes *) - ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]] - ∗ codefrag s_prog (prog_secret_instrs r_mem r_mem' secret_off secret) - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog - ∗ r_mem ↦ᵣ WCap p_mem (a_secret^+1)%a e_mem a_secret - ∗ r_mem' ↦ᵣ WCap p_mem b_mem (a_secret^+1)%a b_mem - ∗ r_t2 ↦ᵣ WInt b_mem - ∗ r_t3 ↦ᵣ WInt (b_mem + (secret_off+1)) - ∗ [[b_mem, a_secret]] ↦ₐ [[ region_addrs_zeroes b_mem a_secret ]] - ∗ a_secret ↦ₐ WInt secret - ∗ [[(a_secret ^+1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (a_secret^+1)%a e_mem ]] - ∗ codefrag s_prog (prog_secret_instrs r_mem r_mem' secret_off secret) - -∗ WP Seq (Instr Executable) {{ φ }})) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof with (try solve_addr'). - intros e_prog a_secret. - iIntros (Hpc_perm Hpc_bounds Hsecret_bounds Hp_mem) - "(HPC & Hr_mem & Hr_mem' & Hr2 & Hr3 & Hmem & Hprog & Post)" - ; iDestruct "Hr_mem'" as (wmem) "Hr_mem'". - - (* For more clarity, we split the fragments of the programs *) - rewrite /region_pointsto /prog_secret_instrs. - match goal with - | h:_ |- context [codefrag _ (?l1 ++ ?l2 ++ ?l3)] => - set (copy_instrs := l1) - ; set (prog_base_instrs := l2) - ; set (secret_instrs := l3) - end. - simpl in e_prog; subst e_prog. - - (* Fragment 1 - copy the buffer capability *) - codefrag_facts "Hprog". - focus_block_0 "Hprog" as "Hcopy" "Hcont". - iGo "Hcopy". - unfocus_block "Hcopy" "Hcont" as "Hprog". - - (* Fragment 2 - execute base program (cf. subseg_buffer) - restrict capability to public buffer *) - focus_block 1%nat "Hprog" as amid Hamid "Hprog_base" "Hcont". - iApply (prog_base_spec with "[- $HPC $Hr2 $Hr3 $Hmem $Hr_mem $Hprog_base]") - ; auto. - iNext - ; iIntros "(HPC & Hr_mem & Hr2 & Hr3 & Hmem & Hsecret & Hmem' & Hprog_base)". - unfocus_block "Hprog_base" "Hcont" as "Hprog". - - (* Fragment 3 - restrict capability to secret buffer *) - focus_block 2%nat "Hprog" as apc_secret Hapc_secret "Hprog_secret" "Hcont". - iGo "Hprog_secret". - { transitivity (Some (b_mem ^+ (secret_off+1))%a) ; auto ; solve_addr'. } - { intros -> ; simpl in Hp_mem ; discriminate. } - { solve_addr'. } - unfocus_block "Hprog_secret" "Hcont" as "Hprog". - - (* Post condition *) - iApply "Post". - replace (apc_secret ^+ 4)%a with (s_prog ^+ 11%nat)%a by solve_addr'. - subst a_secret. - replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off+1))%a by solve_addr'. - iFrame. - Qed. - - (* Specification for the preparation of the registers for the assert *) - Lemma prepa_assert_spec - prepa_addrs a_prepa - pc_p pc_b pc_e - (secret_off secret_val : Z) - b_local e_locals w4 w5 - (b_mem : Addr) EN - φ : - - let instrs_prepa := - [encodeInstrW (Load r_t2 r_t2); - encodeInstrW (Lea r_t2 secret_off); - encodeInstrW (Load r_t4 r_t2); - encodeInstrW (Mov r_t5 secret_val)] in - let e_prepa := (a_prepa ^+ (length instrs_prepa))%a in - - contiguous_between prepa_addrs a_prepa e_prepa -> - ExecPCPerm pc_p → - SubBounds pc_b pc_e a_prepa e_prepa -> - (b_local + 1)%a = Some (e_locals) -> - - b_mem ≤ (b_mem ^+secret_off)%a < (b_mem ^+ (secret_off + 1))%a -> - - ⊢ ( PC ↦ᵣ WCap pc_p pc_b pc_e a_prepa - ∗ r_t2 ↦ᵣ WCap RWX b_local e_locals b_local - ∗ r_t4 ↦ᵣ w4 ∗ r_t5 ↦ᵣ w5 - ∗ b_local ↦ₐ WCap RWX b_mem (b_mem ^+ (secret_off + 1))%a b_mem - ∗ (b_mem ^+ secret_off)%a ↦ₐ WInt secret_val - ∗ codefrag a_prepa instrs_prepa - ∗ ▷ ( PC ↦ᵣ WCap pc_p pc_b pc_e e_prepa - ∗ r_t2 ↦ᵣ WCap RWX b_mem (b_mem ^+ (secret_off + 1))%a (b_mem ^+ secret_off)%a - ∗ r_t4 ↦ᵣ WInt secret_val - ∗ r_t5 ↦ᵣ WInt secret_val - ∗ b_local ↦ₐ WCap RWX b_mem (b_mem ^+ (secret_off + 1))%a b_mem - ∗ (b_mem ^+ secret_off)%a ↦ₐ WInt secret_val - ∗ codefrag a_prepa instrs_prepa - -∗ WP Seq (Instr Executable) @ EN {{ φ }})%I - -∗ WP Seq (Instr Executable) @ EN {{ φ }})%I. - Proof. - intros instrs_prepa e_prepa - Hcont_prepa Hperm Hpc_valid Hlocals Hmem. - iIntros "(HPC & Hr2 & Hr4 & Hr5 & Hlocal & Hsecret & Hprog & Hcont)". - codefrag_facts "Hprog". - iInstr "Hprog". - (apply le_addr_withinBounds ; solve_addr). - iInstr "Hprog". - { transitivity (Some (b_mem ^+ secret_off)%a) ; solve_addr. } - iInstr "Hprog". - split ; eauto ; solve_addr. - iInstr "Hprog". - iApply "Hcont". iFrame. - Qed. - - - (* Full spec *) - Lemma prog_call_full_run_spec_aux - (* call *) wadv w0 - (* remaining registers *) (rmap : gmap RegName Word) - (* pc *) a pc_p pc_b pc_e a_first a_last - (* malloc *) f_m b_m e_m - (* assert *) f_a b_a e_a a_flag flagN - (* linking *) b_link a_link e_link malloc_entry assert_entry - (size : nat) secret_off secret_val : - - (* Validity PC *) - ExecPCPerm pc_p → - SubBounds pc_b pc_e a_first a_last -> - contiguous_between a a_first a_last → - (* Validity linking table *) - withinBounds b_link e_link malloc_entry = true → - withinBounds b_link e_link assert_entry = true → - (a_link + f_m)%a = Some malloc_entry → - (a_link + f_a)%a = Some assert_entry → - (* Validity secret*) - (0 <= secret_off < size %a) -> - - dom rmap = all_registers_s ∖ {[ PC; r_t30 ]} → - - ⊢ ( prog_call_code a f_m f_a size secret_off secret_val - ∗ malloc_call_inv b_m e_m - ∗ assert_call_inv b_a e_a a_flag - ∗ flag_call_inv a_flag flagN - ∗ PC ↦ᵣ WCap pc_p pc_b pc_e a_first - ∗ r_t30 ↦ᵣ wadv - ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i) - - (* Linking table *) - ∗ pc_b ↦ₐ WCap RO b_link e_link a_link - ∗ malloc_entry ↦ₐ WCap E b_m e_m b_m - ∗ assert_entry ↦ₐ WCap E b_a e_a b_a - - ∗ na_own logrel_nais ⊤ - ∗ interp w0 ∗ interp wadv - - -∗ WP Seq (Instr Executable) {{λ v, - (⌜v = HaltedV⌝ → ∃ r : Reg, full_map r ∧ registers_pointsto r ∗ na_own logrel_nais ⊤)%I - ∨ ⌜v = FailedV⌝ }})%I. - - Proof with (try solve_addr'). - iIntros - (Hpc_perm Hpc_bounds Hcont Hwb_malloc Hwb_assert Hlink_malloc Hlink_assert Hsize Hdom) - "(Hprog& #Hinv_malloc& #Hinv_assert& #Hinv_flag& HPC& Hr30& Hrmap& -Hlink& Hentry_malloc& Hentry_assert& Hna& #Hw0& #Hadv)". - - - (* FTLR on wadv - we do it now because of the later modality *) - iDestruct (jmp_to_unknown with "Hadv") as "Cont". - iHide "Cont" as cont. - - (* The program is composed of multiple part. Most of them already have their - own specification. - The main method is the following: - - split the code into the different parts of the program - - when splitting, generate hypothesis about addresses, required by solve_addr - - for each part, prepare the resources and use the specification *) - - (* Split the program between each parts *) - iDestruct (big_sepL2_length with "Hprog") as %Hlength_prog. - rewrite /prog_call_code /prog_call_instrs. - (* malloc *) - iDestruct (contiguous_between_program_split with "Hprog") as - (malloc_addrs rest1 a_clear) "(Hmalloc_prog & Hprog & #Hcont1)" - ;[apply Hcont|]. - iDestruct "Hcont1" as %(Hcont_malloc & Hcont_rest1 & Heqapp1 & Ha_clear). - iDestruct (big_sepL2_length with "Hmalloc_prog") as %Hlength_malloc. - match goal with - | h: _ |- context [ (big_sepL2 _ _ ?instrs) ] => - match instrs with - | (?l0 ++ ?l1 ++ ?l2 ++ ?l3 ++ ?l4 ++ ?l5 ++ ?l6 ) => - set (instrs_clear := l0) - ; set (instrs_prog := l1) - ; set (instrs_call := l2) - ; set (instrs_restore := l3) - ; set (instrs_prepa := l4) - ; set (instrs_assert := l5) - ; set (instrs_end := l6) - end - end. - (* clear end prepare registers *) - iDestruct (contiguous_between_program_split with "Hprog") - as (clear_addrs rest1_addrs a_prog) "(Hclear & Hrest2 & #Hcont2)" - ;[apply Hcont_rest1|]. - iDestruct "Hcont2" as %(Hcont_clear & Hcont_rest2 & Heqapp2 & Ha_prog). - iDestruct (big_sepL2_length with "Hclear") as %Hlength_clear. - iDestruct (big_sepL2_length with "Hrest2") as %Hlength_rest2. - (* prog_base *) - iDestruct (contiguous_between_program_split with "Hrest2") - as (prog_addrs rest_addrs a_call) "(Hprogi & Hrest3 & #Hcont3)" - ;[apply Hcont_rest2|]. - iDestruct "Hcont3" as %(Hcont_prog & Hcont_rest3 & Heqapp3 & Ha_call). - iDestruct (big_sepL2_length with "Hprogi") as %Hlength_progi. - iDestruct (big_sepL2_length with "Hrest3") as %Hlength_rest3. - (* call *) - iDestruct (contiguous_between_program_split with "Hrest3") - as (call_addrs rest2_addrs a_restore) "(Hcall & Hrest4 & #Hcont4)" - ;[apply Hcont_rest3|]. - iDestruct "Hcont4" as %(Hcont_call & Hcont_rest4 & Heqapp4 & Ha_restore). - iDestruct (big_sepL2_length with "Hcall") as %Hlength_call. - iDestruct (big_sepL2_length with "Hrest4") as %Hlength_rest4. - (* restore *) - iDestruct (contiguous_between_program_split with "Hrest4") - as (restore_addrs rest3_addrs a_prepa) "(Hrestore & Hrest5 & #Hcont5)" - ;[apply Hcont_rest4|]. - iDestruct "Hcont5" as %(Hcont_restore & Hcont_rest5 & Heqapp5 & Ha_prepa). - iDestruct (big_sepL2_length with "Hrestore") as %Hlength_restore. - iDestruct (big_sepL2_length with "Hrest5") as %Hlength_rest5. - (* prepa *) - iDestruct (contiguous_between_program_split with "Hrest5") - as (prepa_addrs rest4_addrs a_assert) "(Hprepa & Hrest6 & #Hcont6)" - ;[apply Hcont_rest5|]. - iDestruct "Hcont6" as %(Hcont_prepa & Hcont_rest6 & Heqapp6 & Ha_assert). - iDestruct (big_sepL2_length with "Hprepa") as %Hlength_prepa. - iDestruct (big_sepL2_length with "Hrest6") as %Hlength_rest6. - (* assert and end *) - iDestruct (contiguous_between_program_split with "Hrest6") - as (assert_addrs end_addrs a_end) "(Hassert & Hend & #Hcont7)" - ;[apply Hcont_rest6|]. - iDestruct "Hcont7" as %(Hcont_assert & Hcont_end & Heqapp7 & Ha_end). - iDestruct (big_sepL2_length with "Hassert") as %Hlength_assert. - iDestruct (big_sepL2_length with "Hend") as %Hlength_end. - - - (* Part 1 - Malloc *) - (* Prepare the resource for the malloc spec *) - iInsert "Hrmap" r_t30. - set (rmap' := <[r_t30:=wadv]> rmap). - assert (Hdom' : - dom rmap' = all_registers_s ∖ {[PC]}). - { subst rmap'. - rewrite dom_insert_L. - rewrite Hdom. - rewrite - difference_difference_l_L. - rewrite -union_difference_L; auto. - set_solver. - } - iExtract "Hrmap" r_t0 as "Hr0". - - (* malloc specification *) - rewrite -/(malloc _ _ _). - iApply (wp_wand_l _ _ _ (λ v, ((_ ∨ ⌜v = FailedV⌝) ∨ ⌜v = FailedV⌝)))%I. iSplitR. - { iIntros (v) "[H|H]";auto. } - - iApply (malloc_spec _ size with - "[- $Hmalloc_prog $Hinv_malloc $Hna $Hlink $Hentry_malloc $HPC $Hr0 $Hrmap]") - ; eauto ; try solve_ndisj ; try lia. - { rewrite /contiguous.isCorrectPC_range; intros. - apply isCorrectPC_ExecPCPerm_InBounds ; auto. - apply contiguous_between_bounds in Hcont_rest1. - solve_addr. - } - { subst rmap'. - rewrite !dom_delete_L !dom_insert_L Hdom. - clear. - replace ( all_registers_s ∖ {[PC; r_t0]} ) - with ( ( all_registers_s ∖ {[PC]} ∖ {[r_t0]} ) ) by set_solver+. - replace ( all_registers_s ∖ {[PC; r_t30]}) - with ( ( all_registers_s ∖ {[PC]} ∖ {[r_t30]} ) ) by set_solver+. - replace ( {[r_t30]} ∪ all_registers_s ∖ {[PC]} ∖ {[r_t30]}) - with (all_registers_s ∖ {[PC]}) ; auto. - } - iNext. - iIntros "(HPC & Hmalloc_prog & Hlink & Hentry_malloc & Hreg & Hr0 & Hna & Hrmap)" - ; iDestruct "Hreg" as (b_mem e_mem Hmem_size) "(Hr1 & Hmem)". - - - (* Part 2 - Clear register *) - (* Unlike the other part of the code, we prove this one instructions by instructions *) - iHide "Cont" as Cont. - iExtract "Hrmap" r_t7 as "Hr7". - - do 2 (destruct clear_addrs;[inversion Hlength_clear|]). - simpl in *. - apply - contiguous_between_cons_inv_first in Hcont_clear as Heq;subst f. - iPrologue "Hclear" ; iRename "Hprog" into "Hclear". - iApply (wp_move_success_reg with "[$HPC $Hr7 $Hr1 $Hi]") - ; [apply decode_encode_instrW_inv|..] - ; auto. - { apply isCorrectPC_ExecPCPerm_InBounds ; auto. - apply contiguous_between_bounds in Hcont_rest2. - solve_addr. - } - { transitivity (Some f0) ; auto. - replace (a_clear + 1)%a with (a_clear + 1%nat)%a by solve_addr. - eapply contiguous_between_incr_addr. - eassumption. - by simplify_map_eq. - } - iEpilogue "(HPC & Ha_clear & Hr7 & Hr1)". - - iPrologue "Hclear" ; iRename "Hprog" into "Hclear". - iApply (wp_move_success_z with "[$HPC $Hr1 $Hi]") - ; [apply decode_encode_instrW_inv|..] - ; auto. - { apply isCorrectPC_ExecPCPerm_InBounds ; auto. - assert (Hcont_clear' := Hcont_clear). - eapply (contiguous_between_incr_addr _ 1%nat _ f0 _) - in Hcont_clear'. - repeat ( - match goal with - | h: contiguous_between _ _ _ |- _ => - apply contiguous_between_bounds in h - end). - split ; auto... - by simplify_map_eq. - } - { transitivity (Some a_prog) ; auto. - rewrite Hlength_clear in Ha_prog. - rewrite <- Ha_prog. - replace (f0 + 1)%a with (f0 + 1%nat)%a by solve_addr. - eapply (contiguous_between_incr_addr _ 1%nat _ f0 _) - in Hcont_clear. - solve_addr. - by simplify_map_eq. - } - (* iNext ; iIntros "(HPC & Hi & Hr7 & Hr1)". *) - iEpilogue "(HPC & Ha_f0 & Hr1)". - iDestruct "Hend" as "[Hend _]". - - (* Part 3 - Prog_base *) - (* Prepare the resources for the prog_base_spec *) - iExtract "Hrmap" r_t8 as "Hr8". - - iAssert (codefrag a_prog (prog_secret_instrs r_t7 r_t8 secret_off secret_val)) - with "[Hprogi]" as "Hprogi". - { rewrite /codefrag. simpl. rewrite /region_pointsto. - simpl in *. - replace prog_addrs with (finz.seq_between a_prog (a_prog ^+ 11%nat)%a). - done. - symmetry. - apply region_addrs_of_contiguous_between. - replace (a_prog ^+ 11%nat)%a with a_call. done. - rewrite Hlength_progi in Ha_call... } - do 4 (rewrite delete_insert_ne ; eauto). - - (* 2 - extract r2 and r3 *) - iExtractList "Hrmap" [r_t2;r_t3] as ["Hr2";"Hr3"]. - - (* Apply the base_prog_spec *) - iApply (prog_secret_spec with "[- $HPC $Hr7 $Hr8 $Hprogi $Hr2 $Hr3]") - ; auto - ; try (iFrame ; iFrame "#") - ; eauto... - { simpl in *. - apply contiguous_between_length in Hcont_call, Hcont_end. - solve_addr'. - } - iNext - ; iIntros "(HPC & Hr7 & Hr8 & Hr2 & Hr3 & Hmem & Hsecret & Hmem' & Hprogi)" - ; iHide "Cont" as cont - ; iClear "Hmem". - replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off+1))%a by solve_addr. - replace ((b_mem + secret_off) + 1) with (b_mem + (secret_off+1)) by lia. - - (* Part 4 - Call *) - (* Prepare the ressource for the call_spec *) - iAssert ( call _ f_m r_t30 [r_t8] [r_t7]) - with "Hcall" - as "Hcall". - (* Re-insert r2 and r3 in the [* map] *) - iInsertList "Hrmap" [r_t3;r_t2;r_t1]. - (* Extract r30 - adv *) - subst rmap'. - iExtract "Hrmap" r_t30 as "Hr30". - - set (rmap_call' := delete r_t7 _). - set (w7 := (WCap RWX _ e_mem _ )). - set (w8 := (WCap RWX b_mem _ _ )). - (* Call_spec *) - iApply (call_spec - r_t30 ({[r_t8 := w8]}) ({[r_t7 := w7]}) - wadv _ rmap_call' - _ _ _ _ _ a_restore - with "[- $HPC $Hna $Hr30 $Hrmap $Hlink $Hentry_malloc]") ; cycle -1 - ; simpl - ; eauto. - 1: iFrame "#". - shelve. - { repeat - ( match goal with - | h: contiguous_between _ _ _ |- _ => - apply contiguous_between_bounds in h - end). - split ; auto... - } - { replace (a_prog ^+ 11%nat)%a with (a_call) by solve_addr. - eassumption. - } - - (* set_solver +. *) - all : subst rmap_call'. - 1,2: (solve_map_dom). - match goal with | |- _ ⊆ dom ?m => get_map_dom m as Hid; rewrite Hid end. - set_solver+. - Unshelve. - iSplitL "Hcall" ; first (iNext ; rewrite !map_to_list_singleton /= ; done). - iSplitL "Hr7"; first (iApply big_sepM_singleton; iFrame). - iSplitL "Hr0"; first (iNext ; iExists _ ; iFrame). - iSplitL "Hr8" ; first (iApply big_sepM_singleton; iFrame). - iNext. - iIntros "H" ; iDestruct "H" as - (b_act e_act b_local e_locals a_end_call) - "( %Hnext & HPC & Hrmap & Hr7 & Hpcb & Hentry_malloc & Hr30 & Hr0 & Hact & Hlocals & Hcall & Hna )". - rewrite map_to_list_singleton /=. - - (* ------------------ Jump to the adversary code ----------------- *) - (** In order to jump to the adversary code, we have to prove that the context is safe, - i.e. all the registers are safe to share. - We need to prove that all the registers contains safe-to-share String.words. - In particular the register that contains the activation code is a - sentry-capability, which relies on persistent proposition only. - Thus, we encapsulate the needed memory resources for the remaining code - into invariants. *) - - - (* Allocate the invariants necessary for the continuation *) - (* Activation record *) - iMod (na_inv_alloc logrel_nais _ call_actN with "Hact") as "#Hact". - (* Locals*) - iDestruct (big_sepL2_length with "Hlocals") as %Hlength_locals - ; rewrite finz_seq_between_length /= in Hlength_locals. - iMod (na_inv_alloc logrel_nais _ call_localsN with "Hlocals") as "#Hlocals". - (* Code after the call *) - iCombine "Hrestore" "Hprepa" as "Hcallback". - iCombine "Hcallback" "Hassert" as "Hcallback". - iCombine "Hcallback" "Hend" as "Hcallback". - iMod (na_inv_alloc logrel_nais _ call_codeN with "Hcallback") as - "#Hcallback". - (* Secret address *) - iMod (na_inv_alloc logrel_nais _ (call_versionN.@"secret") with "Hsecret") - as "#Hsecret". - (* Linking table *) - iCombine "Hentry_malloc" "Hentry_assert" as "Hlink_entries". - iCombine "Hpcb" "Hlink_entries" as "Hlink". - iMod (na_inv_alloc logrel_nais _ (call_versionN.@"link_table") with "Hlink") - as "#Hinv_link". - - (* Cleaning *) - iClear "Hclear Hmalloc_prog Ha_clear Ha_f0 Hprogi". - iHide "Hact" as Hact. - iHide "Hw0" as Hinterp_w0. - iHide "Hadv" as Hinterp_adv. - iHide "Hlocals" as Hlocals. - iHide "Hinv_link" as Hinv_link. - subst rmap_call'. - - (* Re-insert the registers into the map *) - (* r0 *) - iDestruct (big_sepM_to_create_gmap_default _ _ (λ k i, k ↦ᵣ i)%I (WInt 0%Z) with "Hrmap") as "Hrmap";[apply Permutation_refl|reflexivity|]. - iDestruct (big_sepM_insert with "[$Hrmap $Hr0]") as "Hrmap". - { apply not_elem_of_dom. - rewrite create_gmap_default_dom list_to_set_map_to_list. - rewrite !dom_delete_L - ; rewrite !dom_insert_L - ; rewrite !dom_delete_L - ; rewrite Hdom. - clear. set_solver. - } - (* r30 *) - iDestruct (big_sepM_insert with "[$Hrmap $Hr30]") as "Hrmap". - { apply not_elem_of_dom. - rewrite !dom_insert_L create_gmap_default_dom list_to_set_map_to_list. - rewrite !dom_delete_L - ; rewrite !dom_insert_L - ; rewrite !dom_delete_L - ; rewrite Hdom. - clear. set_solver. } - (* r7 *) - iDestruct (big_sepM_singleton (fun k a => k ↦ᵣ a)%I r_t7 _ with "Hr7") as "Hr7". - iDestruct (big_sepM_insert with "[$Hrmap $Hr7]") as "Hrmap". - { apply not_elem_of_dom. - rewrite !dom_insert_L create_gmap_default_dom list_to_set_map_to_list. - rewrite !dom_delete_L - ; rewrite !dom_insert_L - ; rewrite !dom_delete_L - ; rewrite Hdom. - clear. set_solver. } - set rmap2 := (<[r_t7:=w7]> _). - - (* We prove that the shared buffer is indeed safe to share - (because it is given in param) *) - rewrite /region_pointsto. - iDestruct (region_integers_alloc' with "Hmem'") as ">#Hinterp_buffer". - { by apply Forall_replicate. } - - (* Apply the continuation *) - iSpecialize ("Cont" $! rmap2). - iApply "Cont" ; auto ; iFrame. - { iPureIntro. - rewrite !dom_insert_L create_gmap_default_dom list_to_set_map_to_list. - rewrite !dom_delete_L ; rewrite !dom_insert_L ; rewrite !dom_delete_L ; rewrite Hdom. - rewrite !singleton_union_difference_L. - set_solver+. } - - (* -- It remains to prove that all the registers are safe to share -- *) - iApply big_sepM_sep. iFrame. - iApply big_sepM_insert_2 ; first iFrame "#". - iApply big_sepM_insert_2 ; first iFrame "#". - iApply big_sepM_insert_2 ; cycle 1. - (* The remaining registers contains WInt*) - { iApply big_sepM_intro. iIntros "!>" (r ?). - (set rmap' := delete r_t7 _ ). - destruct ((create_gmap_default (map_to_list rmap').*1 (WInt 0%Z : Word)) !! r) eqn:Hsome. - apply create_gmap_default_lookup_is_Some in Hsome as [Hsome ->]. rewrite !fixpoint_interp1_eq. - iIntros (?). simplify_eq. done. iIntros (?). done. } - - (* The activation code is safe to share - ie. safe to execute *) - { cbn beta. rewrite !fixpoint_interp1_eq. - iIntros (r). iNext; iModIntro. - iIntros "([% #Hrmap_safe] & Hrmap & Hna)". - iHide "Hinterp_buffer" as Hinterp_buffer. - iHide "Hrmap_safe" as Hrmap_safe. - iClear "Cont". - rewrite /interp_conf /registers_pointsto. - apply regmap_full_dom in H as H'. - - (* get all the registers we need for the remaining code *) - iExtractList "Hrmap" [PC;r_t0;r_t1;r_t2;r_t3;r_t4;r_t5;r_t8] as ["HPC";"Hr0";"Hr1";"Hr2";"Hr3";"Hr4";"Hr5";"Hr8"]. - - (* 1 - step through the activation record *) - iMod (na_inv_acc with "Hact Hna") as "[Hact' [Hna Hcls'] ]";[solve_ndisj|solve_ndisj|]. - iApply (scall_epilogue_spec with "[- $HPC $Hact' $Hr1 $Hr2]") ;[|apply Hnext|]. - { split;auto. } - iNext; iIntros "(HPC & Hr1 & Hr2 & Hact')". - iMod ("Hcls'" with "[$Hact' $Hna]") as "Hna". - iDestruct "Hr1" as (w1') "Hr1". - - (* Code after the return of the call *) - iMod (na_inv_acc with "Hcallback Hna") as - "[>[[[Hrestore Hprepa] Hassert] Hend] [Hna Hcls] ]" - ;[solve_ndisj|solve_ndisj|]. - - (* 2 - restore locals *) - iMod (na_inv_acc with "Hlocals Hna") as "[>Hlocal [Hna Hcls'] ]" - ;[solve_ndisj|solve_ndisj|]. - - iAssert (restore_locals restore_addrs r_t2 [r_t8]) with "Hrestore" as "Hrestore". - iApply (restore_locals_spec _ r_t2 {[ r_t8 := w8]} [r_t8] [w8] - restore_addrs pc_p pc_b pc_e a_restore _ RWX b_local e_locals - with "[- $HPC $Hr2 $Hlocal $Hrestore]") - ; try eauto. - { split ; try eauto. - split ; try solve_addr. - apply contiguous_between_bounds in Hcont_end. - solve_addr. } - { simpl. by rewrite map_to_list_singleton. } - iSplitL "Hr8"; iNext. - iApply big_sepM_singleton ; iExists _ ; iAssumption. - iIntros "(HPC & Hr2 & Hr8 & Hlocal & Hrestore)". - simpl. - iAssert (r_t8 ↦ᵣ w8)%I with "[Hr8]" as "Hr8". - { iApply (big_sepM_singleton (fun k a => k ↦ᵣ a)%I r_t8 w8). - done. } - iInsert "Hrmap" r_t8. - - - (* 3 - Preparation of the assert *) - iDestruct (big_sepL2_length with "Hlocal") as %Hlength_local. - assert ( (b_local + 1)%a = Some e_locals ) as Hsize_locals. - { rewrite finz_seq_between_length /= /finz.dist in Hlength_local. - clear -Hlength_local. solve_addr. } - iDestruct (region_pointsto_single with "Hlocal") as "Hlocal" ; auto. - iDestruct "Hlocal" as (?) "[Hlocal %Hv]". - inversion Hv as [Hv'] ; clear Hv Hv' v. - subst w8. - (* The specification requires the codefrag assertions *) - iAssert (codefrag a_prepa instrs_prepa) with "[Hprepa]" as "Hprepa". - { rewrite /codefrag /region_pointsto. - rewrite <- (region_addrs_of_contiguous_between prepa_addrs). - done. - replace (a_prepa ^+ length instrs_prepa)%a with a_assert by solve_addr. - done. } - - iMod (na_inv_acc with "Hsecret Hna") as "[>Ha_secret [Hna Hcls_secret] ]" - ;[solve_ndisj|solve_ndisj|]. - - iApply (prepa_assert_spec - with "[- $HPC $Hr2 $Hr4 $Hr5 $Hlocal $Ha_secret $Hprepa]") - ; auto. - { Unshelve. 2: exact prepa_addrs. cbn. - replace (a_prepa ^+ 4%nat)%a with a_assert by solve_addr. - done. - } - cbn. - split ; try solve_addr. - split ; try solve_addr. - repeat ( - match goal with - | h:contiguous_between _ _ _ |- _ => apply contiguous_between_bounds in h - end) ; solve_addr. - solve_addr. - iNext ; iIntros "(HPC & Hr2 & Hr4 & Hr5 & Hlocal & Ha_secret & Hprepa)". - simpl. - replace (a_prepa ^+ 4%nat)%a with a_assert by solve_addr. - - (* + Cleaning + *) - iAssert ( ([∗ list] a_i;w_i ∈ prepa_addrs;instrs_prepa, a_i ↦ₐ w_i)%I ) - with "[Hprepa]" as "Hprepa". - { rewrite /codefrag /region_pointsto. simpl. - replace (a_prepa ^+ 4%nat)%a with a_assert by solve_addr. - rewrite <- (region_addrs_of_contiguous_between prepa_addrs) ; done. - } - iMod ("Hcls_secret" with "[$Ha_secret $Hna]") as "Hna". - iMod ("Hcls'" with "[Hlocal $Hna]") as "Hna". - { iNext. rewrite /region_pointsto. - rewrite finz_seq_between_singleton ; auto. - by iFrame. } - - (* 4 - Assert *) - iMod (na_inv_acc with "Hinv_link Hna") as "[>[Hlink [Hentry_malloc Hentry_assert]] [Hna Hcls'] ]" - ;[solve_ndisj|solve_ndisj|]. - iApply (assert_success with - "[- $HPC $Hna $Hinv_assert $Hr0 $Hr1 $Hr2 $Hr3 $Hr4 $Hr5 $Hlink $Hentry_assert]") ; eauto. - repeat ( - match goal with - | h:contiguous_between _ _ _ |- _ => apply contiguous_between_bounds in h - end). - split ; auto ; solve_addr. - solve_ndisj. - iSplitL "Hassert" ; first (iNext ; auto). - iNext - ; iIntros - "(Hr0 & Hr1 & Hr2 & Hr3 & Hr4 & Hr5 & HPC & Hassert & Hna & Hlink & Hentry_assert)". - iMod ("Hcls'" with "[$Hentry_assert $Hentry_malloc $Hlink $Hna]") as "Hna". - - (* 5 - End - halts *) - assert (Hcont_end' := Hcont_end). - apply contiguous_between_cons_inv_first in Hcont_end as ->. - wp_instr. - iApply (wp_halt with "[$HPC $Hend]") - ; [apply decode_encode_instrW_inv|..]. - { apply isCorrectPC_ExecPCPerm_InBounds ; auto. - subst. - assert ( Hcont_end:= Hcont_end'). - apply region_addrs_of_contiguous_between in Hcont_end'. - eapply (InBounds_sub _ _ _ _ _ a_end) in Hpc_bounds. - split ; auto... - split ; auto... - assert ((a_end +1)%a = Some a_last). - { inversion Hcont_end ; subst. - match goal with | h: contiguous_between [] _ _ |- _ => (inversion h ; subst) end. - solve_addr. } - solve_addr. - } - iNext ; iIntros "[HPC Hi]". - - (* close invariants, reassemble registers, and finish *) - iMod ("Hcls" with "[$Hna $Hrestore $Hi $Hprepa $Hassert]") as "Hna". - iInsertList "Hrmap" [r_t0;r_t1;r_t2;r_t3;r_t4;r_t5;PC]. - wp_pure; wp_end. - iIntros "_". - iExists _. iFrame. - iPureIntro. - intros r';simpl. - consider_next_reg r' PC. - consider_next_reg r' r_t5. - consider_next_reg r' r_t4. - consider_next_reg r' r_t3. - consider_next_reg r' r_t2. - consider_next_reg r' r_t1. - consider_next_reg r' r_t0. - consider_next_reg r' r_t8. } - Qed. - - (* The post-condition actually does not matter *) - Lemma prog_call_full_run_spec - (* call *) wadv w0 - (* remaining registers *) (rmap : gmap RegName Word) - (* pc *) a pc_p pc_b pc_e a_first a_last - (* malloc *) f_m b_m e_m - (* assert *) f_a b_a e_a a_flag flagN - (* linking *) b_link a_link e_link malloc_entry assert_entry - (size : nat) secret_off secret_val : - - (* Validity PC *) - ExecPCPerm pc_p → - SubBounds pc_b pc_e a_first a_last -> - contiguous_between a a_first a_last → - (* Validity linking table *) - withinBounds b_link e_link malloc_entry = true → - withinBounds b_link e_link assert_entry = true → - (a_link + f_m)%a = Some malloc_entry → - (a_link + f_a)%a = Some assert_entry → - (* Validity secret*) - (0 <= secret_off < size %a) -> - - dom rmap = all_registers_s ∖ {[ PC; r_t30 ]} → - - ⊢ ( prog_call_code a f_m f_a size secret_off secret_val - ∗ malloc_call_inv b_m e_m - ∗ assert_call_inv b_a e_a a_flag - ∗ flag_call_inv a_flag flagN - ∗ PC ↦ᵣ WCap pc_p pc_b pc_e a_first - ∗ r_t30 ↦ᵣ wadv - ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i) - - (* Linking table *) - ∗ pc_b ↦ₐ WCap RO b_link e_link a_link - ∗ malloc_entry ↦ₐ WCap E b_m e_m b_m - ∗ assert_entry ↦ₐ WCap E b_a e_a b_a - - ∗ na_own logrel_nais ⊤ - ∗ interp w0 ∗ interp wadv - -∗ WP Seq (Instr Executable) {{λ v, True}})%I. - Proof. - - intros. - iIntros "(?&?&?&?&?&Hr30&?&?&?&assert_entry&?&?&Hadv)". - iApply (wp_wand with "[-]"). - { iApply (prog_call_full_run_spec_aux - wadv w0 _ _ _ _ _ _ _ f_m b_m e_m f_a) - ; cycle -1 - ; [iFrame|..] ; eauto. } - iIntros (?) "?" ; done. - Qed. -End program_call. - - -(** Adequacy theorem *) -Section program_call_adequacy. - -(** Defininition of the memory layout *) - -Instance DisjointList_list_Addr : DisjointList (list Addr). -Proof. exact (@disjoint_list_default _ _ app []). Defined. - -Import ocpl. - -Context `{ secret_off : Z , secret_val : Z, size : nat }. -Context `{ HVsize : 0 <= secret_off < size }. - - -Class memory_layout `{MachineParameters} := { - (* Code of f *) - f_region_start : Addr; - f_start : Addr; - f_end : Addr; - f_size: (f_start + (length (prog_call_instrs 0 1 size secret_off secret_val)) = Some f_end)%a; - f_region_start_offset: (f_region_start + 1)%a = Some f_start; - - (* adversary code *) - adv_region_start : Addr; - adv_start : Addr; - adv_end : Addr; - adv_instrs : list Word; - adv_size : (adv_start + (length adv_instrs) = Some adv_end)%a ; - adv_region_start_offset: (adv_region_start + 1)%a = Some adv_start; - - (* malloc routine *) - l_malloc_start : Addr; - l_malloc_memptr : Addr; - l_malloc_mem_start : Addr; - l_malloc_end : Addr; - - l_malloc_code_size : - (l_malloc_start + length malloc_subroutine_instrs)%a - = Some l_malloc_memptr; - - l_malloc_memptr_size : - (l_malloc_memptr + 1)%a = Some l_malloc_mem_start; - - l_malloc_mem_size : - (l_malloc_mem_start <= l_malloc_end)%a; - - (* fail routine *) - l_assert_start : Addr; - l_assert_cap : Addr; - l_assert_flag : Addr; - l_assert_end : Addr; - - l_assert_code_size : - (l_assert_start + length assert_subroutine_instrs)%a = Some l_assert_cap; - l_assert_cap_size : - (l_assert_cap + 1)%a = Some l_assert_flag; - l_assert_flag_size : - (l_assert_flag + 1)%a = Some l_assert_end; - - (* link table *) - link_table_start : Addr; - link_table_end : Addr; - - link_table_size : - (link_table_start + 2)%a = Some link_table_end; - - (* adversary link table *) - adv_link_table_start : Addr; - adv_link_table_end : Addr; - adv_link_table_size : - (adv_link_table_start + 1)%a = Some adv_link_table_end; - - (* disjointness of all the regions above *) - regions_disjoint : - ## [ - finz.seq_between adv_region_start adv_end; - finz.seq_between f_region_start f_end; - finz.seq_between link_table_start link_table_end; - finz.seq_between adv_link_table_start adv_link_table_end; - finz.seq_between l_assert_start l_assert_end; - finz.seq_between l_malloc_mem_start l_malloc_end; - [l_malloc_memptr]; - finz.seq_between l_malloc_start l_malloc_memptr - ] -}. - -Definition call_prog `{memory_layout} : prog := - {| prog_start := f_start ; - prog_end := f_end ; - prog_instrs := (prog_call_instrs 0 1 size secret_off secret_val) ; - prog_size := f_size |}. - -Definition adv_prog `{memory_layout} : prog := - {| prog_start := adv_start ; - prog_end := adv_end ; - prog_instrs := adv_instrs ; - prog_size := adv_size |}. - -Program Definition layout `{memory_layout} : ocpl_library := - {| (* malloc library *) - malloc_start := l_malloc_start; - malloc_memptr := l_malloc_memptr; - malloc_mem_start := l_malloc_mem_start; - malloc_end := l_malloc_end; - - malloc_code_size := l_malloc_code_size; - - malloc_memptr_size := l_malloc_memptr_size; - - malloc_mem_size := l_malloc_mem_size; - - (* assertion fail library *) - assert_start := l_assert_start; - assert_cap := l_assert_cap; - assert_flag := l_assert_flag; - assert_end := l_assert_end; - - assert_code_size := l_assert_code_size; - assert_cap_size := l_assert_cap_size; - assert_flag_size := l_assert_flag_size; - - (* disjointness of the two libraries *) - libs_disjoint := _ - |}. -Next Obligation. - intros. - pose proof (regions_disjoint) as Hdisjoint. - rewrite !disjoint_list_cons in Hdisjoint |- *. - set_solver. -Qed. -Definition OCPLLibrary `{memory_layout} := library layout. - -Program Definition call_table `{memory_layout} : @tbl_priv call_prog OCPLLibrary := - {| prog_lower_bound := f_region_start ; - tbl_start := link_table_start ; - tbl_end := link_table_end ; - tbl_size := link_table_size ; - tbl_prog_link := f_region_start_offset ; - tbl_disj := _ - |}. -Next Obligation. - intros. simpl. - pose proof (regions_disjoint) as Hdisjoint. - rewrite !disjoint_list_cons in Hdisjoint |- *. - disjoint_map_to_list. set_solver. -Qed. - -Program Definition adv_table `{memory_layout} : @tbl_pub adv_prog OCPLLibrary := - {| prog_lower_bound := adv_region_start ; - tbl_start := adv_link_table_start ; - tbl_end := adv_link_table_end ; - tbl_size := adv_link_table_size ; - tbl_prog_link := adv_region_start_offset ; - tbl_disj := _ - |}. -Next Obligation. - intros. simpl. - pose proof (regions_disjoint) as Hdisjoint. - rewrite !disjoint_list_cons in Hdisjoint |- *. - disjoint_map_to_list. set_solver. -Qed. - -Section prog_call_correct. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} {sealsg : sealStoreG Σ} - {nainv: logrel_na_invs Σ} - `{memlayout: memory_layout}. - - Lemma prog_call_correct : - Forall (λ w, is_z w = true \/ in_region w adv_start adv_end) adv_instrs → - let filtered_map := λ (m : gmap Addr Word), filter (fun '(a, _) => a ∉ minv_dom (flag_inv layout)) m in - (∀ rmap, - dom rmap = all_registers_s ∖ {[ PC; r_t30 ]} → - ⊢ inv invN (minv_sep (flag_inv layout)) - ∗ na_inv logrel_nais mallocN (mallocInv layout) - ∗ na_inv logrel_nais assertN (assertInv layout) - ∗ na_own logrel_nais ⊤ - ∗ PC ↦ᵣ WCap RWX (prog_lower_bound call_table) (prog_end call_prog) (prog_start call_prog) - ∗ r_t30 ↦ᵣ WCap RWX (prog_lower_bound adv_table) (prog_end adv_prog) (prog_start adv_prog) - ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ ⌜is_z w = true⌝) - (* P program and table *) - ∗ (prog_lower_bound call_table) ↦ₐ (WCap RO (tbl_start call_table) (tbl_end call_table) (tbl_start call_table)) - ∗ ([∗ map] a↦w ∈ (tbl_region call_table), a ↦ₐ w) - ∗ ([∗ map] a↦w ∈ (prog_region call_prog), a ↦ₐ w) - (* Adv program and table *) - ∗ (prog_lower_bound adv_table) ↦ₐ (WCap RO (tbl_start adv_table) (tbl_end adv_table) (tbl_start adv_table)) - ∗ ([∗ map] a↦w ∈ (tbl_region adv_table), a ↦ₐ w) - ∗ ([∗ map] a↦w ∈ (prog_region adv_prog), a ↦ₐ w) - - -∗ WP Seq (Instr Executable) {{ λ _, True }}). - Proof. - iIntros (Hints Hfilter rmap Hdom) "(#Hinv & #Hmalloc & #Hassert & Hown & HPC & Hr_adv & Hrmap & Hcall_link & Hcall_table & Hcall - & Hadv_link & Hadv_table & Hadv)". - - iDestruct (big_sepM_sep with "Hrmap") as "[Hrmap #Hrmapvalid]". - simpl. - - (* setting up read only example program *) - iAssert (prog_call_code (finz.seq_between f_start f_end) 0 1 size secret_off - secret_val) with "[Hcall] "as "Hprog". - { rewrite /prog_call_code /prog_region /= /mkregion. - iApply big_sepM_to_big_sepL2. apply finz_seq_between_NoDup. - pose proof f_size as Hsize. - rewrite finz_seq_between_length /finz.dist. solve_addr +Hsize. - iFrame. } - - (* cleaning up the environment tables *) - rewrite /tbl_region /mkregion /=. - pose proof link_table_size as Hsize. - assert (is_Some (link_table_start + 1)%a) as [link_table_mid Hmid]. solve_addr+Hsize. - rewrite finz_seq_between_cons;[|solve_addr +Hsize]. - rewrite (addr_incr_eq Hmid) /= finz_seq_between_singleton /=;[|solve_addr +Hmid Hsize]. - pose proof adv_link_table_size as Hsize_adv. - rewrite finz_seq_between_singleton /=;[|solve_addr +Hsize_adv]. - iDestruct (big_sepM_insert with "Hcall_table") as "[Hlink_table_start Hcall_table]". - { rewrite lookup_insert_ne//. solve_addr +Hmid. } - iDestruct (big_sepM_insert with "Hcall_table") as "[Hlink_table_mid _]";auto. - iDestruct (big_sepM_insert with "Hadv_table") as "[Hadv_link_table_start _]";auto. - - (* determine malloc validity *) - iDestruct (simple_malloc_subroutine_valid with "[$Hmalloc]") as "#Hmalloc_val". - - (* allocate adversary table *) - iMod (inv_alloc (logN .@ adv_link_table_start) ⊤ (interp_ref_inv adv_link_table_start interp) - with "[Hadv_link_table_start]") as "#Hadv_table_valid". - { iNext. iExists _. iFrame. auto. } - - (* allocate validity of adversary *) - pose proof adv_size as Hadv_size'. - pose proof adv_region_start_offset as Hadv_region_offset. - iDestruct (big_sepM_to_big_sepL2 with "Hadv") as "Hadv /=". apply finz_seq_between_NoDup. - rewrite finz_seq_between_length /finz.dist /=. solve_addr+Hadv_size'. - - iAssert (|={⊤}=> interp (WCap RWX adv_start adv_end adv_start))%I with "[Hadv]" as ">#Hadv". - { iApply (region_valid_in_region _ _ _ _ adv_instrs);auto. apply Forall_forall. intros. set_solver+. } - - iAssert (|={⊤}=> interp (WCap RWX adv_region_start adv_end adv_start))%I with "[Hadv_link]" as ">#Hadv_valid". - { iApply fixpoint_interp1_eq. iSimpl. - rewrite (finz_seq_between_cons adv_region_start); - [rewrite (addr_incr_eq Hadv_region_offset) /=|solve_addr +Hadv_region_offset Hadv_size']. - iSplitL. - - iExists interp. iSplitL;[|iModIntro;auto]. - iApply inv_alloc. iNext. iExists _. iFrame. - iApply fixpoint_interp1_eq;simpl. - rewrite finz_seq_between_singleton// /=. - iSplit;auto. iExists interp. iFrame "#". - iNext. iModIntro. auto. - - rewrite !fixpoint_interp1_eq /=. iFrame "#". done. - } - - iApply (prog_call_full_run_spec - with "[- $HPC $Hown $Hr_adv $Hrmap $Hprog - $Hlink_table_start $Hlink_table_mid $Hcall_link - $Hadv_valid]");auto ; cycle -1. - { rewrite /malloc_call_inv /mallocInv. - rewrite /assert_call_inv /assertInv. - rewrite /flag_call_inv. - iFrame "#". - iApply (inv_iff with "Hinv []"). iNext. iModIntro. - iSplit. - - rewrite /minv_sep /=. iIntros "HH". iDestruct "HH" as (m) "(Hm & %Heq & %HOK)". - assert (is_Some (m !! l_assert_flag)) as [? Hlook]. - { apply elem_of_dom. rewrite Heq. apply elem_of_singleton. auto. } - iDestruct (big_sepM_lookup _ _ l_assert_flag with "Hm") as "Hflag";eauto. - apply HOK in Hlook as ->. iFrame. - - iIntros "HH". iExists {[ l_assert_flag := WInt 0%Z ]}. - rewrite big_sepM_singleton. iFrame. - rewrite dom_singleton_L /minv_dom /=. iSplit;auto. - rewrite /OK_invariant. iPureIntro. intros w Hw. simplify_map_eq. done. - } - {apply ExecPCPerm_RWX. } - instantiate (1:=f_end). - { pose proof (f_region_start_offset) as HH. - pose proof (f_size) as HH'. - solve_addr. } - { apply contiguous_between_of_region_addrs;auto. pose proof (f_size) as HH. solve_addr+HH. } - { apply le_addr_withinBounds'. solve_addr+Hsize Hmid. } - { apply le_addr_withinBounds'. solve_addr+Hsize Hmid. } - { solve_addr. } - Qed. -End prog_call_correct. - -Theorem prog_call_adequacy `{memory_layout} - (m m': Mem) (reg reg': Reg) (es: list cap_lang.expr): - is_initial_memory call_prog adv_prog OCPLLibrary call_table adv_table m → - is_initial_registers call_prog adv_prog OCPLLibrary call_table adv_table reg r_t30 → - Forall (λ w, is_z w = true \/ in_region w adv_start adv_end) (prog_instrs adv_prog) → - - rtc erased_step ([Seq (Instr Executable)], (reg, m)) (es, (reg', m')) → - (∀ w, m' !! l_assert_flag = Some w → w = WInt 0%Z). -Proof. - intros ? ? Hints ?. - set (Σ' := #[]). - pose proof (ocpl_template_adequacy Σ' layout call_prog adv_prog call_table adv_table) as Hadequacy. - eapply Hadequacy;eauto. - - intros Σ ? ? ? ? ?. - cbn. - apply prog_call_correct. - apply Hints. -Qed. - -End program_call_adequacy. diff --git a/theories/exercises/subseg_buffer_closure.v b/theories/exercises/subseg_buffer_closure.v deleted file mode 100644 index 6840f8f6..00000000 --- a/theories/exercises/subseg_buffer_closure.v +++ /dev/null @@ -1,447 +0,0 @@ -From iris.algebra Require Import frac. -From iris.proofmode Require Import tactics. -Require Import Eqdep_dec List. -From cap_machine Require Import malloc macros register_tactics. -From cap_machine Require Import fundamental logrel rules. -From cap_machine.proofmode Require Import tactics_helpers proofmode. -From cap_machine.examples Require Import template_adequacy. -From cap_machine.exercises Require Import subseg_buffer. -Open Scope Z_scope. - -(** Firtly, we create a closure around our code and buffer. The capability - pointing to the allocated buffer is stored in memory. We thus have to load - it in the register. This part of code sets up the context, allowing to use - the previous specification. - *) -Section closure_program. - - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} {sealsg: sealStoreG Σ} - `{MP: MachineParameters}. - Context {nainv: logrel_na_invs Σ}. - Definition Nclosure : namespace := nroot .@ "closure". - - (* we assume pc_b contains the capability pointing the allocated buffer - this code load the capability in R1 *) - Definition load_code := - encodeInstrsW [ - Mov r_t1 PC; (* r1 => (RWX, pc_b, pc_e, a_first) *) - GetB r_t2 r_t1; (* r2 => pc_b *) - GetA r_t3 r_t1; (* r3 => a_first *) - Sub r_t2 r_t2 r_t3; (* r2 => (pc_b - a_first) *) - Lea r_t1 r_t2; (* r1 => (RWX, pc_b, pc_e, pc_b) *) - Load r_t1 r_t1 (* r1 => (p_mem, b_mem, e_mem, b_mem) *) - ]. - - Definition closure_code secret_off secret_val:= - load_code ++ (prog_code secret_off secret_val). - - (** As we will prove that the encapsulation of the program - in a sentry capability is safe-to-share, the memory - propositions have to be in invariant. *) - (** We define the invariants *) - (* cap_addr points to the capability for the buffer *) - Definition cap_memN := Nclosure.@"cap_mem". - Definition cap_mem_inv p_mem b_mem e_mem cap_addr := - na_inv logrel_nais cap_memN - (cap_addr ↦ₐ WCap p_mem b_mem e_mem b_mem). - - (* The first part of the buffer, before the secret, is always zeroes *) - Definition start_memN := (Nclosure.@"start_mem"). - Definition start_mem_inv b_mem secret_off := - let secret_addr := (b_mem ^+ secret_off)%a in - na_inv logrel_nais start_memN - ([[b_mem, secret_addr]] ↦ₐ [[ region_addrs_zeroes b_mem secret_addr ]]). - - (* The secret is either equal to 0 -- at the initialisation -- or equal to - 42 -- after the secret was stored *) - Definition secretN := (Nclosure.@"secret"). - Definition secret_inv (b_mem : Addr) secret_off secret_val := - let secret_addr := (b_mem ^+ secret_off)%a in - na_inv logrel_nais secretN - ((secret_addr ↦ₐ WInt 0) ∨ (secret_addr ↦ₐ WInt secret_val)). - - (* The code instruction is stored in an invariant as well *) - Definition codeN := (Nclosure.@"code"). - Definition code_closure_inv a_prog secret_off secret_val := - na_inv logrel_nais codeN (codefrag a_prog (closure_code secret_off secret_val)). - - (** Specifications *) - - (* We specifie the closure program in a modular way, so we firstly specifie - the part of the code that load the capability *) - Lemma load_spec p_pc b_pc e_pc s_load (* pc *) - p_mem b_mem e_mem (* mem *) - w1 w2 w3 - EN φ : - - let e_load := (s_load ^+ length load_code)%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc s_load e_load -> - - writeAllowed p_mem = true -> - - ↑ cap_memN ⊆ EN -> - - ⊢ ( cap_mem_inv p_mem b_mem e_mem b_pc - ∗ PC ↦ᵣ WCap p_pc b_pc e_pc s_load - ∗ r_t1 ↦ᵣ w1 - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - ∗ codefrag s_load load_code - ∗ na_own logrel_nais EN - ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_load - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ (∃ w2, r_t2 ↦ᵣ w2) - ∗ (∃ w3, r_t3 ↦ᵣ w3) - ∗ codefrag s_load load_code - ∗ na_own logrel_nais EN - -∗ - WP Seq (Instr Executable) {{ φ }} - ) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intros end_load ; subst end_load. - iIntros (Hpc_perm Hpc_bounds Hp_mem Hnainv_cap) - "(#Hinv_cap & HPC & Hr1 & Hr2 & Hr3 & Hprog & Hna & Post)". - simpl in *. - codefrag_facts "Hprog". - iMod (na_inv_acc with "Hinv_cap Hna") as "(>Hcap& Hna& Hinv_close)" ; auto. - iGo "Hprog". - { transitivity (Some b_pc); eauto. solve_addr. } - iGo "Hprog". - iMod ("Hinv_close" with "[Hcap Hna]") as "Hna" ; iFrame. - iApply "Post". iFrame. - Qed. - - - (* We specifie the part of the program that store the secret, using the - invariant. *) - Lemma prog_closure_spec - wadv - p_pc b_pc e_pc a_prog (* pc *) - p_mem b_mem e_mem (* mem *) - w2 w3 - secret_off secret_val - EN - φ : - let secret := (b_mem^+secret_off)%a in - let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in - - ExecPCPerm p_pc -> - SubBounds b_pc e_pc a_prog len_p -> - - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - - ↑secretN ⊆ EN -> - - ⊢ ( (* PC points to prog_code*) - ( secret_inv b_mem secret_off secret_val - ∗ PC ↦ᵣ WCap p_pc b_pc e_pc a_prog - ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - ∗ r_t30 ↦ᵣ wadv - - ∗ codefrag a_prog (prog_code secret_off secret_val) - ∗ na_own logrel_nais EN - - ∗ ▷ ( PC ↦ᵣ updatePcPerm wadv - ∗ r_t1 ↦ᵣ WCap p_mem (b_mem^+(secret_off+1))%a e_mem secret%a - ∗ r_t2 ↦ᵣ WInt (b_mem+(secret_off +1)) - ∗ r_t3 ↦ᵣ WInt e_mem - ∗ r_t30 ↦ᵣ wadv - ∗ codefrag a_prog (prog_code secret_off secret_val) - ∗ na_own logrel_nais EN - -∗ WP Seq (Instr Executable) {{ φ }})%I - ) - - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem Hnainv. - iIntros "(#Hinv_secret & HPC& Hr1& Hr2& Hr3& Hr30& Hprog& Hna & Post)". - subst secret len_p. - codefrag_facts "Hprog". - - iMod (na_inv_acc logrel_nais with "Hinv_secret Hna") as - "(>Hsecret & Hna & Hclose_secret)" ; auto. (* inclusion namespace *) - - simpl in *. - rewrite /prog_code. - assert (Hp_mem': ~ p_mem = E) - by (intros -> ; simpl in Hp_mem ; discriminate). - (* Lea r_t1 secret_off *) - iInstr "Hprog". - { transitivity (Some (b_mem ^+secret_off)%a) ; auto. solve_addr. } - (* Store r_t1 42 , where r_t1 = (RWX, b, e, secret) *) - (* Regarding the invariant, the secret can be either 0 or 42 *) - iDestruct "Hsecret" as "[Hsecret | Hsecret]". - all: iInstr "Hprog" ; [solve_addr|]. - (* getB getE add subseg *) - all: iGo "Hprog" - ; try transitivity (Some (b_mem ^+(secret_off+1))%a) ; auto - ; try solve_addr . - (* jmp *) - all: iInstr "Hprog". - (* halts in the adversary code *) - all: iMod ("Hclose_secret" with "[Hsecret $Hna]") as "Hna" - ; [iNext ; iRight ; iFrame |]. - all: iApply "Post". - all: iFrame ; iFrame "#". - Qed. - - (* Specification of the full program, stops after the jump to the adversary *) - Lemma closure_spec - pc_p pc_b pc_e s_closure - p_mem b_mem e_mem - w1 w2 w3 w_adv - secret_off secret_val - EN - φ : - - let secret := (b_mem^+secret_off)%a in - let e_closure := (s_closure ^+ length (closure_code secret_off secret_val))%a in - - ExecPCPerm pc_p -> - SubBounds pc_b pc_e s_closure e_closure -> - - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - - ↑secretN ⊆ EN -> - ↑codeN ⊆ EN -> - ↑cap_memN ⊆ EN -> - - ⊢ ( secret_inv b_mem secret_off secret_val - ∗ code_closure_inv s_closure secret_off secret_val - ∗ cap_mem_inv p_mem b_mem e_mem pc_b - ∗ PC ↦ᵣ WCap pc_p pc_b pc_e s_closure - ∗ r_t1 ↦ᵣ w1 - ∗ r_t2 ↦ᵣ w2 - ∗ r_t3 ↦ᵣ w3 - ∗ r_t30 ↦ᵣ w_adv - ∗ na_own logrel_nais EN - ∗ ▷ ( PC ↦ᵣ updatePcPerm w_adv - ∗ r_t1 ↦ᵣ WCap p_mem (b_mem^+(secret_off+1))%a e_mem secret%a - ∗ r_t2 ↦ᵣ WInt (b_mem+(secret_off +1)) - ∗ r_t3 ↦ᵣ WInt e_mem - ∗ r_t30 ↦ᵣ w_adv - ∗ na_own logrel_nais EN - -∗ WP Seq (Instr Executable) {{ φ }}) - -∗ WP Seq (Instr Executable) {{ φ }})%I. - Proof. - intros secret e_closure ; subst secret e_closure. - iIntros (Hpc_perm Hpc_bounds Hvsecret Hp_mem Hnainv_secret Hnainv_code Hnainv_cap) - "(#Hinv_secret & #Hinv_code & #Hinv_cap & HPC & Hr1 & Hr2 & Hr3 & Hr30 & Hna & Post)". - - rewrite /code_closure_inv. - iMod (na_inv_acc with "Hinv_code Hna") - as "(>Hprog & Hna & Hprog_close)" - ; auto. - rewrite /closure_code. - focus_block_0 "Hprog" as "Hload" "Hcont". - iApply (load_spec with "[-]") - ; try (iFrame ; iFrame "#") - ; eauto - ; try solve_ndisj. - iNext. - - iIntros "(HPC & Hr1 & Hr2 & Hr3 & Hload & Hna)". - clear w2 w3. - iDestruct "Hr2" as (w2) "Hr2"; iDestruct "Hr3" as (w3) "Hr3". - unfocus_block "Hload" "Hcont" as "Hprog" . - focus_block 1%nat "Hprog" as a_mid Ha_mid "Hprog" "Hcont". - iApply (prog_closure_spec with "[-]") - ; try (iFrame; iFrame "#") - ; eauto - ; try solve_ndisj. - iNext. - - iIntros "(HPC & Hr1 & Hr2 & Hr3 & Hr30 & Hprog &Hna)". - unfocus_block "Hprog" "Hcont" as "Hprog" . - iMod ("Hprog_close" with "[$Hprog $Hna]") as "Hna". - iApply "Post" ; iFrame ; iFrame "#". - Qed. - - (* Invariant on the shared part of the buffer *) - Definition end_memN := (Nclosure.@"end_mem"). - Definition end_mem_inv b_mem e_mem secret_off := - let n_secret_addr := (b_mem ^+ (secret_off + 1))%a in - na_inv logrel_nais end_memN - ([∗ list] a ∈ finz.seq_between n_secret_addr e_mem, - ∃ P, inv (logN .@ a) (interp_ref_inv a P) ∗ read_cond P interp - ∗ write_cond P interp)%I. - - (* Assuming that the word of the adversary is safe to share, - the machine executes safely and completely. *) - Lemma closure_full_run_spec - pc_p pc_b pc_e s_closure - p_mem b_mem e_mem - secret_off secret_val - w_adv - rmap : - - let secret := (b_mem^+secret_off)%a in - let e_closure := (s_closure ^+ length (closure_code secret_off secret_val))%a in - - ExecPCPerm pc_p -> - SubBounds pc_b pc_e s_closure e_closure -> - - (b_mem <= secret < e_mem)%a -> - writeAllowed p_mem = true -> - - dom rmap = all_registers_s ∖ {[ PC ; r_t30 ]} → - - ⊢ ( code_closure_inv s_closure secret_off secret_val - ∗ end_mem_inv b_mem e_mem secret_off - ∗ secret_inv b_mem secret_off secret_val - ∗ cap_mem_inv p_mem b_mem e_mem pc_b - - ∗ PC ↦ᵣ WCap pc_p pc_b pc_e s_closure - ∗ r_t30 ↦ᵣ w_adv - ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ interp w) - - ∗ na_own logrel_nais ⊤ - ∗ interp w_adv - - -∗ WP Seq (Instr Executable) - {{ v, ⌜v = HaltedV⌝ - → ∃ r : Reg, full_map r ∧ registers_pointsto r ∗ na_own logrel_nais ⊤ }})%I. - Proof. - intros secret e_closure ; subst secret e_closure. - iIntros (Hpc_perm Hpc_bounds Hvsecret Hp_mem Hrmap_dom) - "(#Hinv_prog & #Hinv_mem' & #Hinv_secret & #Hinv_cap & HPC & Hr30 & Hrmap & Hna & #Hvadv)". - - (* FTLR on V(w_adv) *) - iDestruct (jmp_to_unknown with "Hvadv") as "Cont". - - (* We open the invariant on the shared buffer, - needed to prove that r1 is safe to share *) - rewrite /end_mem_inv. - iMod (na_inv_acc with "Hinv_mem' Hna") - as "(Hmem'& Hna& Hnainv_close)" ; auto. - - (* Extract the register r_t1 - r_t3 *) - iExtractList "Hrmap" [r_t1;r_t2;r_t3] as ["[Hr1 _]"; "[Hr2 _]"; "[Hr3 _]"]. - - (* Apply the spec *) - iApply (closure_spec with "[-]") - ; try iFrame "HPC Hr1 Hr2 Hr3 Hr30 Hna" - ; try iFrame "#" - ; eauto - ; try solve_ndisj. - iNext. - iIntros "(HPC & Hr1 & Hr2 & Hr3 & Hr30 & Hna)". - - (* We also need to prove that Hr1 is safe to share *) - iAssert (interp (WCap p_mem (b_mem ^+(secret_off+1))%a e_mem (b_mem ^+ secret_off)%a)) - with "[Hmem']" - as "#Hinterp_r1". - { unfold interp. - destruct p_mem ; try discriminate. - all: simpl. - all: rewrite (fixpoint_interp1_eq - (WCap _ (b_mem ^+ (secret_off+1))%a e_mem (b_mem ^+ secret_off)%a)) . - all: simpl. - all: iFrame. - } - - rewrite /interp. - - (* Re-insert the registers *) - iCombine "Hr1 Hinterp_r1" as "Hr1". - iCombine "Hr30 Hvadv" as "Hr30". - iAssert (interp (WInt (b_mem + (secret_off + 1)))) as "Hr2i". iApply interp_int. - iCombine "Hr2 Hr2i" as "Hr2". - iAssert (interp (WInt e_mem)) as "Hr3i". iApply interp_int. - iCombine "Hr3 Hr3i" as "Hr3". - - (* iAssert (interp vr_t1) as "Hrt1". auto. *) - iInsertList "Hrmap" [r_t3;r_t2;r_t30;r_t1]. - - (* Close the invariant *) - iMod ("Hnainv_close" with "[$Hna]") as "Hna". - { iNext. - rewrite /interp /=. - destruct p_mem eqn:Heq; try discriminate. - all: rewrite (fixpoint_interp1_eq (WCap _ _ e_mem _)) . - all: simpl. - all: iFrame "#". - } - - (* Apply the continuation *) - iApply "Cont" ; [|iFrame]. - iPureIntro. - rewrite !dom_insert_L Hrmap_dom. - rewrite !singleton_union_difference_L. set_solver+. - Qed. - - (* The encapsulation of the program in a sentry-capability is safe to share *) - Lemma closure_prog_safe_to_share - b_pc e_pc a_prog - p_mem b_mem e_mem - secret_off secret_val : - - SubBounds b_pc e_pc a_prog (a_prog ^+ length (closure_code secret_off secret_val))%a -> - (b_mem <= b_mem ^+ secret_off < e_mem)%a -> - writeAllowed p_mem = true -> - - ⊢ (code_closure_inv a_prog secret_off secret_val - ∗ end_mem_inv b_mem e_mem secret_off - ∗ secret_inv b_mem secret_off secret_val - ∗ cap_mem_inv p_mem b_mem e_mem b_pc - ) - - -∗ interp (WCap E b_pc e_pc a_prog). - Proof. - iIntros (Hbounds Hb_mem Hp_mem) - "(#Hnainv_code & #Hinv_mem' & #Hinv_secret & #Hinv_cap)". - (* 1 - unfold the definitions *) - rewrite !fixpoint_interp1_eq /=. - iIntros (regs). - iNext; iModIntro. - iIntros "(Hrsafe& Hregs& Hna)". - iDestruct "Hrsafe" as "[%Hrfull #Hrsafe]". - rewrite /interp_conf. - rewrite {1}/registers_pointsto. - - (* 2 - prepare the registers for closure_full_run_spec *) - apply regmap_full_dom in Hrfull. - assert (is_Some (regs !! r_t30)) as [w30 Hw30];[rewrite -elem_of_dom Hrfull; set_solver|]. - iExtractList "Hregs" [PC;r_t30] as ["HPC"; "Hw30"]. - iAssert (interp w30) as "Hw30i". - { iApply ("Hrsafe" $! r_t30 w30) ; eauto. } - set (rmap:= delete r_t30 (delete PC regs)). - - (* 3 - use the full specification to show that the program executes safely and completely *) - iApply (closure_full_run_spec - RX b_pc e_pc a_prog - p_mem b_mem e_mem - secret_off secret_val - _ - rmap - with "[-]") - ; eauto - ; try apply ExecPCPerm_RX - ; try (iFrame ; iFrame "#"). - - subst rmap. solve_map_dom. - - subst rmap. - iDestruct (big_sepM_sep _ (λ k v, interp v)%I with "[Hregs]") as "Hregs". - { iSplitL. by iApply "Hregs". iApply big_sepM_intro. iModIntro. - iIntros (r' ? HH). repeat eapply lookup_delete_Some in HH as [? HH]. - iApply ("Hrsafe" $! r'); auto. } - simpl. - iFrame. - Qed. - - (** Adequacy theorem - the template of the adequacy theorem defined in Cerise - requires the memory invariant being in the memory of the program. - However, the memory buffer is not inside the memory closure of the program. - Therefore, we cannot apply the adequacy theorem on this instance. *) - - (** Remarks : We could apply the adequacy theorem on this instance, - but not using the template defined in Cerise. We could - use the adequacy theorem of Cerise, but it is out-of-scope - here *) -End closure_program. diff --git a/theories/exercises/subseg_buffer_malloc.v b/theories/exercises/subseg_buffer_malloc.v deleted file mode 100644 index 7b422bc7..00000000 --- a/theories/exercises/subseg_buffer_malloc.v +++ /dev/null @@ -1,389 +0,0 @@ -From iris.algebra Require Import frac. -From iris.proofmode Require Import tactics. -Require Import Eqdep_dec List. -From cap_machine Require Import malloc macros. -From cap_machine Require Import fundamental logrel rules. -From cap_machine.examples Require Import template_adequacy. -From cap_machine.proofmode Require Import tactics_helpers proofmode register_tactics. -From cap_machine.exercises Require Import subseg_buffer. -Open Scope Z_scope. - -(** Secondly, the other approach is to dynamically allocate the region with - the `malloc` macro. *) -Section malloc_program. - Context {Σ:gFunctors} {ceriseg:ceriseG Σ} {sealsg : sealStoreG Σ} - {nainv: logrel_na_invs Σ} - `{MP: MachineParameters}. - - Definition prog_malloc_instrs f_m (size : nat) secret_off secret_val : list Word := - (* code: *) - malloc_instrs f_m size ++ (prog_code secret_off secret_val). - - Definition prog_malloc_code a_prog f_m size secret_off secret_val := - ([∗ list] a_i;w ∈ a_prog;(prog_malloc_instrs f_m size secret_off secret_val), a_i ↦ₐ w)%I. - - (** We define the needed invariant *) - - Definition malloc_versionN : namespace := nroot .@ "malloc_version". - - (* Program invariant *) - Definition malloc_codeN := (malloc_versionN.@"code"). - Definition prog_malloc_inv a f_m size secret_off secret_val := - na_inv logrel_nais malloc_codeN (prog_malloc_code a f_m size secret_off secret_val ). - - (* Malloc invariant *) - Definition mallocN := (malloc_versionN.@"malloc"). - Definition malloc_nainv b_m e_m := - na_inv logrel_nais mallocN (malloc_inv b_m e_m). - - (* Linking table invariant *) - Definition link_tableN := (malloc_versionN.@"link_table"). - Definition link_table_inv - table_addr b_link e_link a_link - malloc_entry b_m e_m := - na_inv logrel_nais link_tableN - (table_addr ↦ₐ WCap RO b_link e_link a_link - ∗ malloc_entry ↦ₐ WCap E b_m e_m b_m)%I. - - - (* This spec re-uses the specification defined in the previous section *) - Lemma prog_malloc_spec - (a_prog : Addr) - wadv w0 - rmap (* resources *) - a p b e a_first a_last (* pc *) - f_m b_m e_m (* malloc *) - b_link a_link e_link a_entry (* linking *) - (size : nat) secret_off secret_val - EN - φ : - - let rmap_post := - (∃ b_l e_l, - ([∗ map] r_i↦w_i ∈ (<[r_t1:=WCap RWX (b_l ^+ (secret_off+1))%a e_l (b_l ^+ secret_off)%a]> - (<[r_t2:=WInt (b_l + (secret_off+1))]> - (<[r_t3:=WInt e_l]> - (<[r_t4:=WInt 0]> (<[r_t5:=WInt 0]> rmap))))), - r_i ↦ᵣ w_i) - ∗ [[(b_l ^+ (secret_off+1))%a,e_l]]↦ₐ[[region_addrs_zeroes (b_l ^+ (secret_off+1))%a e_l]] - )%I - in - - ExecPCPerm p → - SubBounds b e a_first a_last -> - contiguous_between a a_first a_last → - withinBounds b_link e_link a_entry = true → - (a_link + f_m)%a = Some a_entry → - (0 <= secret_off < size %a) -> - - - dom rmap = all_registers_s ∖ {[ PC; r_t0 ; r_t30 ]} → - ↑malloc_versionN ⊆ EN -> - - ⊢ (( prog_malloc_inv a f_m size secret_off secret_val - ∗ malloc_nainv b_m e_m - ∗ link_table_inv b b_link e_link a_link a_entry b_m e_m - ∗ PC ↦ᵣ WCap p b e a_first - ∗ r_t0 ↦ᵣ w0 - ∗ r_t30 ↦ᵣ wadv - ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i) - ∗ na_own logrel_nais EN - ∗ ▷ ( PC ↦ᵣ updatePcPerm wadv - ∗ r_t30 ↦ᵣ wadv - ∗ r_t0 ↦ᵣ w0 - ∗ rmap_post - ∗ na_own logrel_nais EN - -∗ WP Seq (Instr Executable) {{λ v, φ v ∨ ⌜v = FailedV⌝ }})) - -∗ WP Seq (Instr Executable) {{λ v, φ v ∨ ⌜v = FailedV⌝ }})%I. - Proof. - intros rmap_post ; subst rmap_post. - iIntros - (Hpc_perm Hpc_bounds Hcont Hwb Hlink Hsecret_size Hdom Hna_malloc) - "(#Hinv_prog & #Hinv_malloc & #Hinv_link & HPC& Hr0& Hr30& Hrmap& Hna& Post)". - simpl in *. - - (* Open the invariants *) - iMod (na_inv_acc with "Hinv_prog Hna") as "(>Hprog & Hna & Hinv_close_prog)" - ; auto ; try solve_ndisj. - rewrite {1}/prog_malloc_code {1}/prog_malloc_instrs. - iMod (na_inv_acc with "Hinv_link Hna") as "(>[Hb Ha_entry] & Hna & Hinv_close_link)" - ; auto ; try solve_ndisj. - - (* Prepare the ressources for the use of malloc_spec *) - (* Extract malloc from the program *) - iDestruct (contiguous_between_program_split with "Hprog") as - (malloc_prog rest1 link1) "(Hmalloc_prog & Hprog & #Hcont1)" - ;[apply Hcont|]. - iDestruct "Hcont1" as %(Hcont1 & Hcont2 & Heqapp1 & Hlink1). - - (* Insert r30 in rmap *) - assert (dom (<[r_t30:=wadv]> rmap) = - all_registers_s ∖ {[PC; r_t0]}) as Hdomeq. - { rewrite dom_insert_L. - rewrite Hdom. - rewrite - difference_difference_l_L. - rewrite -union_difference_L; auto. - set_solver. - } - iInsert "Hrmap" r_t30. - - (* Malloc spec *) - rewrite -/(malloc _ _ _). - iApply (wp_wand_l _ _ _ (λ v, ((φ v ∨ ⌜v = FailedV⌝) ∨ ⌜v = FailedV⌝)))%I. iSplitR. - { iIntros (v) "[H|H] /=";auto. } - iApply (malloc_spec _ size with - "[- $Hmalloc_prog $Hinv_malloc $Hna $Hb $Ha_entry $HPC $Hr0 $Hrmap]") - ; auto ; try solve_ndisj ; try lia. - { rewrite /contiguous.isCorrectPC_range; intros. - apply isCorrectPC_ExecPCPerm_InBounds ; auto. - apply contiguous_between_bounds in Hcont2. - solve_addr. - } - iNext. - iIntros "(HPC & Hmalloc & Hb & Ha_entry & Hregion & Hr0 & Hna & Hgen)" - ; iDestruct "Hregion" as (b_l e_l Hmem_size) "(Hr1 & Hmem)". - - (* Prepare ressources for the use of prof_spec_CPS *) - (* Extract some registers *) - iExtractList "Hgen" [r_t2;r_t3;r_t30] as ["Hr2";"Hr3";"Hadv"]. - - (* Convert the [* list] of instructions into a codefrag *) - set (prog_instrs := (encodeInstrsW - [Lea r_t1 secret_off; Store r_t1 secret_val; GetB r_t2 r_t1; GetE r_t3 r_t1; - Add r_t2 r_t2 (secret_off+1); Subseg r_t1 r_t2 r_t3; Jmp r_t30]) ). - iDestruct (big_sepL2_length with "Hprog") as %Hlength_prog. - iAssert (codefrag link1 prog_instrs) with "[Hprog]" as "Hprog". - { rewrite /codefrag. simpl. rewrite /region_pointsto. - simpl in *. - replace rest1 with (finz.seq_between link1 (link1 ^+ 7%nat)%a). - done. - symmetry. - apply region_addrs_of_contiguous_between. - replace (link1 ^+ 7%nat)%a with a_last. done. - apply contiguous_between_length in Hcont2. - rewrite Hlength_prog in Hcont2. - solve_addr. } - - (* Apply the prog_spec *) - iApply (prog_spec_CPS with "[- $HPC $Hprog $Hr1 $Hr2 $Hr3 $Hmem $Hadv]") - ; auto ; try solve_addr. - { simpl in *. - apply contiguous_between_length in Hcont2. - rewrite Hlength_prog /= in Hcont2. - solve_addr. - } - iNext. - iIntros "(HPC& Hr1& Hr2& Hr3& Hr30& Hprog& Hmem)". - - (* Close the invariants *) - iMod ("Hinv_close_link" with "[$Hb $Ha_entry $Hna]") as "Hna". - - iMod ("Hinv_close_prog" with "[Hprog Hmalloc $Hna]") as "Hna". - { - subst a. - rewrite /prog_code /codefrag /malloc. - iAssert (([∗ list] a_i;w ∈ (malloc_prog ++ rest1) - ;(malloc_instrs f_m size ++ prog_instrs), a_i ↦ₐ w)%I) - with "[Hprog Hmalloc]" - as "Hprog'" . - {iApply (big_sepL2_app with "[Hmalloc]") ; [done|]. - simpl. rewrite /region_pointsto. - simpl in *. - replace rest1 with (finz.seq_between link1 (link1 ^+ 7%nat)%a). - done. - symmetry. - apply region_addrs_of_contiguous_between. - replace (link1 ^+ 7%nat)%a with a_last. done. - apply contiguous_between_length in Hcont2. - rewrite Hlength_prog in Hcont2. - solve_addr. - } - iFrame. - } - - (* Apply the continuation *) - iApply "Post". iFrame. - replace ((b_l ^+ secret_off) ^+ 1)%a with (b_l ^+ (secret_off+1))%a by solve_addr. - - iExists _, _. - iFrame. - - iInsertList "Hgen" [r_t3;r_t2;r_t1]. - rewrite (delete_notin); [ | apply not_elem_of_dom_1; clear -Hdom; set_solver]. - iAssumption. - Qed. - - Lemma prog_malloc_full_run_spec - wadv w0 - rmap (* register map *) - a p b e a_first a_last (* pc *) - f_m b_m e_m (* malloc *) - b_link a_link e_link a_entry (* linking *) - (size : nat) secret_off secret_val : - - ExecPCPerm p → - SubBounds b e a_first a_last -> - contiguous_between a a_first a_last → - withinBounds b_link e_link a_entry = true → - (a_link + f_m)%a = Some a_entry → - (0 <= secret_off < size %a) -> - - dom rmap = all_registers_s ∖ {[ PC; r_t0 ; r_t30 ]} → - - ⊢ (( malloc_nainv b_m e_m - ∗ prog_malloc_inv a f_m size secret_off secret_val - ∗ link_table_inv b b_link e_link a_link a_entry b_m e_m - - ∗ PC ↦ᵣ WCap p b e a_first - ∗ r_t0 ↦ᵣ w0 - ∗ r_t30 ↦ᵣ wadv - ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i ∗ interp w_i ) - ∗ na_own logrel_nais ⊤ - - ∗ interp wadv - ∗ interp w0 - ) - -∗ WP Seq (Instr Executable) {{λ v, - (⌜v = HaltedV⌝ → ∃ r : Reg, full_map r ∧ registers_pointsto r ∗ na_own logrel_nais ⊤)%I - ∨ ⌜v = FailedV⌝ }})%I. - Proof. - intros *. - iIntros - (Hpc_perm Hpc_bounds Hcont Hwb Hlink Hsize_secret Hdom) - "(#Hinv_malloc& #Hinv_prog& #Hinv_link& HPC& Hr0 &Hr30& Hrmap& Hown& #Hadv & #Hw0)". - - (* First and foremost, we prove that wadv is safe to execute *) - iDestruct (jmp_to_unknown with "Hadv") as "Cont"; eauto. - - (* Apply the specification of the program *) - iDestruct (big_sepM_sep with "Hrmap") as "[Hrmap Hrmap_interp]". - iApply (prog_malloc_spec with "[-]") ; eauto. - iFrame ; iFrame "#". - iNext ; iIntros "(HPC & Hr30 & Hr0 & Hrmap & Hna)" - ; iDestruct "Hrmap" as (b_mem e_mem) "[Hrmap Hmem]". - - - (* After the specificatio, the PC points to the adversary code. - Since it is safe to share, we have a continuation that prove the full - safe execution. But we need to manipulate the resources in order to - use this continuation *) - set ( rmap' := (<[r_t1:=WCap RWX (b_mem ^+ (secret_off+1))%a e_mem (b_mem ^+ secret_off)%a]> - (<[r_t2:=WInt (b_mem + (secret_off+1))]> - (<[r_t3:=WInt e_mem]> - (<[r_t4:=WInt 0]> (<[r_t5:=WInt 0]> rmap))))) - ). - (* Insert the registers r0 and r30 in the register map *) - assert (dom (<[r_t0 := w0]> (<[r_t30:=wadv]> rmap')) - = all_registers_s ∖ {[PC]}). - { rewrite !dom_insert_L. rewrite Hdom. - replace (all_registers_s ∖ {[PC]}) - with - ({[r_t0; r_t30]} ∪ all_registers_s ∖ {[PC; r_t0; r_t30]}) - ; [set_solver|]. - rewrite - !difference_difference_l_L. - rewrite (difference_difference_l_L _ {[r_t0]}). - rewrite -union_difference_L; auto. - set_solver. - } - - (* r1 is safe to share *) - iDestruct (region_integers_alloc' _ _ _ (b_mem ^+ secret_off)%a _ RWX with "Hmem") as ">#Hmem" - ; [rewrite /region_addrs_zeroes; apply Forall_replicate; auto|]. - - iApply (wp_wand with "[-]"). - 2: {iIntros (v) "Hv" ; by iLeft. } - iApply ("Cont" with "[]") ; eauto ; iFrame. - subst rmap'. - - (* We need to prove that all the registers are r -> v and interp v. - But, the register maps is split, such that some of them are known a interp, - but the one that have been modified by the specification are not. - Thus, we have to extract all the new register from the map, - recombine the [* map] over rmap, and re-insert the new registers - into the rmap, proving both points_to and interp. - *) - (* First, extract the new registers *) - iApply (big_sepM_sep_2 with "[- Hrmap_interp]"). - - by iInsertList "Hrmap" [r_t30;r_t0]. - - iApply big_sepM_intro. iDestruct "Hrmap_interp" as "#Hmap_interp". - iIntros "!>" (r w). - consider_next_reg r r_t0; [iIntros (Hr0) ; by inversion Hr0 |]. - consider_next_reg r r_t30; [iIntros (Hr0) ; by inversion Hr0 |]. - consider_next_reg r r_t1; [iIntros (Hr0) ; by inversion Hr0 |]. - consider_next_reg r r_t2; [iIntros (Hr0) ; inversion Hr0; by rewrite !fixpoint_interp1_eq /= |]. - consider_next_reg r r_t3; [iIntros (Hr0) ; inversion Hr0; by rewrite !fixpoint_interp1_eq /= |]. - consider_next_reg r r_t4; [iIntros (Hr0) ; inversion Hr0; by rewrite !fixpoint_interp1_eq /= |]. - consider_next_reg r r_t5; [iIntros (Hr0) ; inversion Hr0; by rewrite !fixpoint_interp1_eq /= |]. - iIntros (Hr). - iDestruct (big_sepM_delete _ _ r with "Hmap_interp") as "[Hr_t7 Hregs]"; eauto. -Qed. - - Lemma prog_malloc_safe_to_share - pc_b pc_e - a a_first a_last f_m b_m e_m - b_link e_link a_link a_entry - (size : nat) secret_off secret_val : - - SubBounds pc_b pc_e a_first a_last -> - contiguous_between a a_first a_last → - withinBounds b_link e_link a_entry = true → - (a_link + f_m)%a = Some a_entry → - (0 <= secret_off < size %a) -> - - ⊢ prog_malloc_inv a f_m size secret_off secret_val - ∗ malloc_nainv b_m e_m - ∗ link_table_inv pc_b b_link e_link a_link a_entry b_m e_m - - -∗ interp (WCap E pc_b pc_e a_first). - Proof. - iIntros (Hpc_bounds Hcont HlinkB HlinkE Hsize) "(#Hinv_prog& #Hinv_malloc& #Hinv_link)". - simpl. - rewrite !fixpoint_interp1_eq /=. - iIntros (regs). - iNext. iModIntro. - iIntros "(Hrsafe& Hregs& Hna)". - iDestruct "Hrsafe" as "[%Hrfull #Hrsafe]". - rewrite /interp_conf. - rewrite {1}/registers_pointsto. - - (* Extract the registers from the map *) - apply regmap_full_dom in Hrfull as Hrfull'. - assert (is_Some (regs !! r_t0)) as [w0 Hw0];[set_solver|]. - assert (is_Some (regs !! r_t30)) as [w30 Hw30];[set_solver|]. - iExtractList "Hregs" [PC;r_t0;r_t30] as ["HPC";"Hr0";"Hr30"]. - - iAssert (interp w0) as "Hw0" ; first (iApply ("Hrsafe" $! r_t0 w0) ; eauto). - iAssert (interp w30) as "Hw30" ; first (iApply ("Hrsafe" $! r_t30 w30) ; eauto). - - iApply (wp_wand _ _ _ - (λ v0 : language.val cap_lang, - (⌜v0 = HaltedV⌝ → - ∃ r : Reg, full_map r - ∧ registers_pointsto r ∗ na_own logrel_nais ⊤) - ∨ ⌜v0 = FailedV⌝)%I - with "[-]"). - 2:{ iIntros (v) "Hv"; iDestruct "Hv" as "[Hv|->]" ; auto. - iIntros ; done. } - - (* Apply the full run spec *) - iApply (prog_malloc_full_run_spec _ _ - (delete r_t30 (delete r_t0 (delete PC regs))) - with "[-]") - ; try (iFrame ; iFrame "#") - ; try apply ExecPCPerm_RX - ; eauto. - - rewrite !dom_delete_L. - rewrite (difference_difference_l_L _ {[PC]}). - rewrite (difference_difference_l_L _ _ {[r_t30]}). - apply regmap_full_dom in Hrfull. - rewrite Hrfull. - set_solver. - - iDestruct (big_sepM_sep _ (λ k v, interp v)%I with "[Hregs]") as "Hregs". - { iSplitL. by iApply "Hregs". iApply big_sepM_intro. iModIntro. - iIntros (r' ? HH). repeat eapply lookup_delete_Some in HH as [? HH]. - iApply ("Hrsafe" $! r'); auto. } - simpl. - iFrame. -Qed. - -End malloc_program. diff --git a/theories/ftlr/AddSubLt.v b/theories/ftlr/AddSubLt.v index 24e3ed72..6ce597fb 100644 --- a/theories/ftlr/AddSubLt.v +++ b/theories/ftlr/AddSubLt.v @@ -3,61 +3,79 @@ From cap_machine.rules Require Export rules_AddSubLt. From iris.proofmode Require Import proofmode. From iris.program_logic Require Import weakestpre adequacy lifting. From stdpp Require Import base. -From cap_machine Require Import machine_base. From cap_machine.rules Require Import rules_base. +From cap_machine Require Import ftlr_base. +From cap_machine Require Import machine_base. Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). - - Lemma add_sub_lt_case (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (w : Word) (dst : RegName) (r1 r2: Z + RegName) (P : D): - p = RX ∨ p = RWX - → (∀ x : RegName, is_Some (r !! x)) - → isCorrectPC (WCap p b e a) + Lemma add_sub_lt_case (W : WORLD) (regs : leibnizO Reg) (p : Perm) + (g : Locality) (b e a : Addr) (w : Word) (ρ : region_type) (dst : RegName) + (r1 r2: Z + RegName) (P:D): + p = RX ∨ p = RWX ∨ (p = RWLX /\ g = Local) + → (∀ x : RegName, is_Some (regs !! x)) + → isCorrectPC (WCap p g b e a) → (b <= a)%a ∧ (a < e)%a + → (∀ Wv : WORLD * leibnizO Word, Persistent (P Wv.1 Wv.2)) + → (if pwl p then region_state_pwl W a else region_state_nwl W a g) + → std W !! a = Some ρ + → ρ ≠ Revoked + → (∀ g : Mem, ρ ≠ Monostatic g) → (decodeInstrW w = Add dst r1 r2 \/ decodeInstrW w = Sub dst r1 r2 \/ decodeInstrW w = Lt dst r1 r2) - -> □ ▷ (∀ a0 a1 a2 a3 a4, - full_map a0 - -∗ (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜a0 !! r1 = Some v⌝ → (fixpoint interp1) v) - -∗ registers_pointsto (<[PC:=WCap a1 a2 a3 a4]> a0) - -∗ na_own logrel_nais ⊤ - -∗ □ (fixpoint interp1) (WCap a1 a2 a3 a4) -∗ interp_conf) - -∗ (fixpoint interp1) (WCap p b e a) - -∗ inv (logN.@a) (∃ w0 : leibnizO Word, a ↦ₐ w0 ∗ P w0) - -∗ (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜r !! r1 = Some v⌝ → (fixpoint interp1) v) - -∗ ▷ □ (∀ w : Word, P w -∗ (fixpoint interp1) w) - ∗ (if decide (writeAllowed_in_r_a (<[PC:=WCap p b e a]> r) a) then ▷ □ (∀ w : Word, (fixpoint interp1) w -∗ P w) else emp) + -> ftlr_IH + -∗ region_conditions W p g b e + -∗ (∀ (r : RegName) v, ⌜r ≠ PC⌝ → ⌜regs !! r = Some v⌝ → fixpoint interp1 W v) + -∗ rel a (λ Wv, P Wv.1 Wv.2) + -∗ rcond P interp + -∗ □ (if decide (writeAllowed_in_r_a (<[PC:=(WCap p g b e a)]> regs) a) + then wcond P interp + else emp) + -∗ (▷ (if decide (ρ = Monotemporary) + then future_pub_a_mono a (λ Wv, P Wv.1 Wv.2) w + else future_priv_mono (λ Wv, P Wv.1 Wv.2) w)) + -∗ ▷ P W w + -∗ sts_full_world W -∗ na_own logrel_nais ⊤ + -∗ open_region a W + -∗ sts_state_std a ρ -∗ a ↦ₐ w - -∗ ▷ P w - -∗ (▷ (∃ w0 : leibnizO Word, a ↦ₐ w0 ∗ P w0) ={⊤ ∖ ↑logN.@a,⊤}=∗ emp) - -∗ PC ↦ᵣ WCap p b e a - -∗ ([∗ map] k↦y ∈ delete PC (<[PC:=WCap p b e a]> r), k ↦ᵣ y) - -∗ - WP Instr Executable - @ ⊤ ∖ ↑logN.@a {{ v, |={⊤ ∖ ↑logN.@a,⊤}=> WP Seq (of_val v) - {{ v0, ⌜v0 = HaltedV⌝ - → ∃ r1 : Reg, full_map r1 ∧ registers_pointsto r1 - ∗ na_own logrel_nais ⊤ }} }}. + -∗ PC ↦ᵣ WCap p g b e a + -∗ ([∗ map] k↦y ∈ delete PC (<[PC:=(WCap p g b e a)]> regs), k ↦ᵣ y) + -∗ WP Instr Executable + {{ v, WP Seq (cap_lang.of_val v) + {{ v0, ⌜v0 = HaltedV⌝ + → ∃ (regs' : Reg) (W' : WORLD), + full_map regs' ∧ registers_pointsto regs' + ∗ ⌜related_sts_priv_world W W'⌝ + ∗ na_own logrel_nais ⊤ + ∗ sts_full_world W' ∗ region W' }} }}. Proof. - intros Hp Hsome i Hbae Hi. - iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap". + intros Hp Hsome i Hbae Hpers Hpwl Hregion Hnotrevoked Hnotmonostatic Hi. + iIntros "#IH #Hinv #Hreg #Hinva #Hrcond #Hwcond Hmono Hw Hsts Hown". + iIntros "Hr Hstate Ha HPC Hmap". rewrite delete_insert_delete. iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. + iApply (wp_AddSubLt with "[$Ha $Hmap]"); eauto. { simplify_map_eq; auto. } { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _. @@ -65,24 +83,24 @@ Section fundamental. iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]". destruct HSpec; cycle 1. - { iApply wp_pure_step_later; auto. - iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. - iNext; iIntros "_". - iApply wp_value; auto. iIntros; discriminate. } - { incrementPC_inv; simplify_map_eq. - iApply wp_pure_step_later; auto. - iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. iNext;iIntros "_". - assert (dst <> PC) as HdstPC by (intros ->; simplify_map_eq). - simplify_map_eq. - iApply ("IH" $! (<[dst:=_]> (<[PC:=_]> r)) with "[%] [] [Hmap] [$Hown]"); + - iApply wp_pure_step_later; auto. iNext; iIntros "_". + iApply wp_value; auto. iIntros; discriminate. + - incrementPC_inv; simplify_map_eq. + iApply wp_pure_step_later; auto. iNext; iIntros "_". + assert (dst <> PC) as HdstPC by (intros ->; rewrite lookup_insert in H1; done). + rewrite lookup_insert_ne in H1; eauto; simplify_map_eq. + iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono Hw]") as "Hr"; eauto. + { destruct ρ;auto;[|specialize (Hnotmonostatic g)];contradiction. } + iApply ("IH" $! _ (<[dst:=_]> (<[PC:=_]> regs)) with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]"); try iClear "IH"; eauto. - { intro. cbn. by repeat (rewrite lookup_insert_is_Some'; right). } - iIntros (ri v Hri Hsv). rewrite insert_commute // lookup_insert_ne // in Hsv; []. - destruct (decide (ri = dst)); simplify_map_eq. - { repeat rewrite fixpoint_interp1_eq; auto. } - { by iApply "Hreg". } - { iModIntro. rewrite !fixpoint_interp1_eq /=. destruct Hp as [-> | ->];iFrame "Hinv". } - } + + intro. cbn. by repeat (rewrite lookup_insert_is_Some'; right). + + iIntros (ri wi Hri Hregs_ri). + destruct (decide (ri = dst)); simplify_map_eq. + { rewrite lookup_insert in Hregs_ri; simplify_eq. + repeat rewrite fixpoint_interp1_eq; auto. } + { rewrite lookup_insert_ne in Hregs_ri; eauto; simplify_eq. + rewrite lookup_insert_ne in Hregs_ri; eauto; simplify_eq. + by iApply "Hreg". } Qed. End fundamental. diff --git a/theories/ftlr/Get.v b/theories/ftlr/Get.v index 64a860e9..6fb700ad 100644 --- a/theories/ftlr/Get.v +++ b/theories/ftlr/Get.v @@ -9,48 +9,58 @@ Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). - Lemma get_case (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (w : Word) (dst r0 : RegName) (ins: instr) (P:D) : - is_Get ins dst r0 → - ftlr_instr r p b e a w ins P. + Lemma get_case (W : WORLD) (regs : leibnizO Reg) (p : Perm) + (g : Locality) (b e a : Addr) (w : Word) (ρ : region_type) (dst r : RegName) (ins: instr) (P:D) : + is_Get ins dst r → + ftlr_instr W regs p g b e a w ins ρ P. Proof. - intros Hinstr Hp Hsome i Hbae Hi. - iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap". + intros Hinstr Hp Hsome i Hbae Hpers Hpwl Hregion Hnotrevoked Hnotmonostatic Hi. + iIntros "#IH #Hinv #Hreg #Hinva #Hrcond #Hwcond Hmono Hw Hsts Hown". + iIntros "Hr Hstate Ha HPC Hmap". rewrite delete_insert_delete. rewrite <- Hi in Hinstr. clear Hi. iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. iApply (wp_Get with "[$Ha $Hmap]"); eauto. { simplify_map_eq; auto. } - { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _. + { rewrite /subseteq /map_subseteq. intros rr _. apply elem_of_dom. apply lookup_insert_is_Some'; eauto. } iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]". destruct HSpec; cycle 1. - { iApply wp_pure_step_later; auto. iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. iNext. - iIntros "_". - iApply wp_value; auto. iIntros; discriminate. } - { incrementPC_inv; simplify_map_eq. - iApply wp_pure_step_later; auto. iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. iNext. + - iApply wp_pure_step_later; auto. iNext; iIntros "_". + iApply wp_value; auto. iIntros; discriminate. + - incrementPC_inv; simplify_map_eq. + iApply wp_pure_step_later; auto. iNext; iIntros "_". + (* destruct c as ((((p1 & g1) & b1) & e1) & a1). *) assert (dst <> PC) as HdstPC by (intros ->; simplify_map_eq). - iIntros "_". simplify_map_eq. - iApply ("IH" $! (<[dst := _]> (<[PC := _]> r)) with "[%] [] [Hmap] [$Hown]"); + iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono Hw]") as "Hr"; eauto. + { destruct ρ;auto;[|specialize (Hnotmonostatic g)];contradiction. } + + iApply ("IH" $! _ (<[dst := _]> (<[PC := _]> regs)) + with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]"); try iClear "IH"; eauto. - { intro. cbn. by repeat (rewrite lookup_insert_is_Some'; right). } - iIntros (ri v Hri Hsv). rewrite insert_commute // lookup_insert_ne // in Hsv; []. - destruct (decide (ri = dst)); simplify_map_eq. + + intro. cbn. by repeat (rewrite lookup_insert_is_Some'; right). + + iIntros (ri wi Hri Hregs_ri). + destruct (decide (ri = dst)); simplify_map_eq. { repeat rewrite fixpoint_interp1_eq; auto. } - { by iApply "Hreg". } rewrite !fixpoint_interp1_eq /=. destruct Hp as [-> | ->];iFrame "Hinv". } + { by iApply "Hreg". } Qed. End fundamental. diff --git a/theories/ftlr/GetWType.v b/theories/ftlr/GetWType.v deleted file mode 100644 index 0e85fbfe..00000000 --- a/theories/ftlr/GetWType.v +++ /dev/null @@ -1,57 +0,0 @@ -From iris.proofmode Require Import proofmode. -From iris.program_logic Require Import weakestpre adequacy lifting. -From stdpp Require Import base. -From cap_machine Require Export logrel. -From cap_machine.ftlr Require Import ftlr_base. -From cap_machine.rules Require Import rules_GetWType. - -Section fundamental. - Context - {Σ : gFunctors} - {ceriseg: ceriseG Σ} - {sealsg: sealStoreG Σ} - {nainv: logrel_na_invs Σ} - {MP: MachineParameters} - . - - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). - Implicit Types w : (leibnizO Word). - Implicit Types interp : (D). - - Lemma getwtype_case (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (w : Word) (dst r0 : RegName) (P:D) : - ftlr_instr r p b e a w (GetWType dst r0) P. - Proof. - intros Hp Hsome i Hbae Hi. - iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap". - rewrite delete_insert_delete. - iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; - [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. - iApply (wp_GetWType with "[$Ha $Hmap]"); eauto. - { simplify_map_eq; auto. } - { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _. - apply elem_of_dom. apply lookup_insert_is_Some'; eauto. } - - iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]". - destruct HSpec; cycle 1. - { iApply wp_pure_step_later; auto. iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. - iNext; iIntros "_". - iApply wp_value; auto. iIntros; discriminate. } - { incrementPC_inv; simplify_map_eq. - iApply wp_pure_step_later; auto. iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. - iNext; iIntros "_". - assert (dst <> PC) as HdstPC. { intros ->. simplify_map_eq. } - simplify_map_eq. - iApply ("IH" $! (<[dst:= _]> _) with "[%] [] [Hmap] [$Hown]"); - try iClear "IH"; eauto. - { cbn; intro. repeat (rewrite lookup_insert_is_Some'; right); eauto. } - { iIntros (ri v Hri Hvs). - rewrite insert_commute // lookup_insert_ne // in Hvs. - destruct (decide (ri = dst)); simplify_map_eq. - * repeat rewrite fixpoint_interp1_eq; auto. - * by iApply "Hreg". } - rewrite !fixpoint_interp1_eq /=. destruct Hp as [-> | ->];iFrame "Hinv". } - Qed. - -End fundamental. diff --git a/theories/ftlr/Load.v b/theories/ftlr/Load.v index b7040794..80930685 100644 --- a/theories/ftlr/Load.v +++ b/theories/ftlr/Load.v @@ -10,223 +10,298 @@ Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). - (* The necessary resources to close the region again, except for the points to predicate, which we will store separately - The boolean bl can be used to keep track of whether or not we have applied a wp lemma *) - Definition region_open_resources (P : D) (w : Word) (a pc_a : Addr) (f:bool) : iProp Σ := - ((if f then ▷ P w else P w) ∗ read_cond P interp ∗ ((▷ ∃ w0, a ↦ₐ w0 ∗ P w0) ={⊤ ∖ ↑logN.@pc_a ∖ ↑logN.@a,⊤ ∖ ↑logN.@pc_a}=∗ emp))%I. - - Lemma load_inr_eq {regs r p0 b0 e0 a0 p1 b1 e1 a1}: - reg_allows_load regs r p0 b0 e0 a0 → - read_reg_inr regs r p1 b1 e1 a1 → - p0 = p1 ∧ b0 = b1 ∧ e0 = e1 ∧ a0 = a1. + (* The necessary resources to close the region again, + except for the points to predicate, which we will store separately + The boolean bl can be used to keep track of whether or not we have applied a wp lemma *) + Definition region_open_resources W l ls φ v (bl : bool): iProp Σ := + (∃ ρ, + sts_state_std l ρ + ∗ ⌜ρ ≠ Revoked ∧ (∀ g, ρ ≠ Monostatic g)⌝ + ∗ open_region_many (l :: ls) W + ∗ (if bl then monotonicity_guarantees_region ρ l v φ ∗ φ (W, v) + else ▷ monotonicity_guarantees_region ρ l v φ ∗ ▷ φ (W, v) ) + ∗ rel l φ)%I. + + + Lemma load_inr_eq {regs r p0 g0 b0 e0 a0 p1 g1 b1 e1 a1}: + reg_allows_load regs r p0 g0 b0 e0 a0 → + read_reg_inr regs r p1 g1 b1 e1 a1 → + p0 = p1 ∧ g0 = g1 ∧ b0 = b1 ∧ e0 = e1 ∧ a0 = a1. Proof. - intros Hrar H3. - pose (Hrar' := Hrar). - destruct Hrar' as (Hinr0 & _). rewrite /read_reg_inr Hinr0 in H3. by inversion H3. + intros Hrar H3. + pose (Hrar' := Hrar). + destruct Hrar' as (Hinr0 & _). rewrite /read_reg_inr Hinr0 in H3. by inversion H3. Qed. - - (* Description of what the resources are supposed to look like after opening the region if we need to, but before closing the region up again*) - Definition allow_load_res r (regs : Reg) pc_a a p b e (P : D) := - (⌜read_reg_inr regs r p b e a⌝ ∗ - if decide (reg_allows_load regs r p b e a ∧ a ≠ pc_a ) then - |={⊤ ∖ ↑logN.@pc_a,⊤ ∖ ↑logN.@pc_a ∖ ↑logN.@a}=> ∃ w, a ↦ₐ w ∗ region_open_resources P w a pc_a true ∗ ▷ interp w - else True)%I. - - - Definition allow_load_mem r (regs : Reg) (pc_a : Addr) (pc_w : Word) (mem : gmap Addr Word) (a : Addr) p b e (P:D) (f:bool) := - (⌜read_reg_inr regs r p b e a⌝ ∗ - if decide (reg_allows_load regs r p b e a ∧ a ≠ pc_a) then - ∃ (w : Word), ⌜mem = <[a:=w]> (<[pc_a:=pc_w]> ∅)⌝ ∗ - (region_open_resources P w a pc_a f) ∗ if f then ▷ interp w else interp w - else ⌜mem = <[pc_a:=pc_w]> ∅⌝)%I. + (* Description of what the resources are supposed to look like + after opening the region if we need to, + but before closing the region up again*) + Definition allow_load_res W r (regs : Reg) pc_a:= + (∃ p g b e a, ⌜read_reg_inr regs r p g b e a⌝ ∗ + if decide (reg_allows_load regs r p g b e a ∧ a ≠ pc_a ) then + ∃ w (P:D), ⌜(∀ Wv, Persistent (P Wv.1 Wv.2))⌝ ∗ + a ↦ₐ w ∗ (region_open_resources W a [pc_a] (λ Wv, P Wv.1 Wv.2) w false) + ∗ rcond P interp + else open_region pc_a W)%I. + + Definition allow_load_mem W r (regs : Reg) pc_a pc_w (mem : Mem) (bl: bool):= + (∃ p g b e a, ⌜read_reg_inr regs r p g b e a⌝ ∗ + if decide (reg_allows_load regs r p g b e a ∧ a ≠ pc_a) then + ∃ w (P:D), ⌜(∀ Wv, Persistent (P Wv.1 Wv.2))⌝ ∗ ⌜mem = <[a:=w]> (<[pc_a:=pc_w]> ∅)⌝ + ∗ (region_open_resources W a [pc_a] (λ Wv, P Wv.1 Wv.2) w bl) + ∗ (if bl then □ (∀ W (w : Word), P W w -∗ interp W w) else rcond P interp) + else ⌜mem = <[pc_a:=pc_w]> ∅⌝ ∗ open_region pc_a W)%I. Lemma create_load_res: - ∀ (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (src : RegName) (p0 : Perm) - (b0 e0 a0 : Addr), - read_reg_inr (<[PC:=WCap p b e a]> r) src p0 b0 e0 a0 - → (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜r !! r1 = Some v⌝ → (fixpoint interp1) v) - -∗ ∃ P, allow_load_res src (<[PC:=WCap p b e a]> r) a a0 p0 b0 e0 P. + ∀ (W : WORLD) (regs : leibnizO Reg) + (p : Perm) (g : Locality) (b e a : Addr) + (src : RegName) (p0 : Perm) (g0 : Locality) (b0 e0 a0 : Addr), + read_reg_inr (<[PC:=WCap p g b e a]> regs) src p0 g0 b0 e0 a0 + → (∀ (r : RegName) (v : Word), ⌜r ≠ PC⌝ → ⌜regs !! r = Some v⌝ → ((fixpoint interp1) W) v) + -∗ open_region a W + -∗ sts_full_world W + -∗ allow_load_res W src (<[PC:= WCap p g b e a]> regs) a + ∗ sts_full_world W. Proof. - intros r p b e a src p0 b0 e0 a0 HVsrc. - iIntros "#Hreg". rewrite /allow_load_res. - (* do 5 (iApply sep_exist_r; iExists _). *) (* do 3 (iExists _). *) iFrame "%". + intros W regs p g b e a src p0 g0 b0 e0 a0 HVsrc. + iIntros "#Hreg Hr Hsts". + do 5 (iApply sep_exist_r; iExists _). iFrame "%". case_decide as Hdec. 1: destruct Hdec as [Hallows Haeq]. - destruct Hallows as [Hrinr [Hra Hwb] ]. apply andb_prop in Hwb as [Hle Hge]. - (* Unlike in the old proof, we now go the other way around, and prove that the source register could not have been the PC, since both addresses differ. This saves us some cases.*) - assert (src ≠ PC) as n. refine (addr_ne_reg_ne Hrinr _ Haeq). by rewrite lookup_insert. + (* Unlike in the old proof, we now go the other way around, + and prove that the source register could not have been the PC, + since both addresses differ. This saves us some cases.*) + assert (src ≠ PC) as n. + { refine (addr_ne_reg_ne Hrinr _ Haeq). by rewrite lookup_insert. } + simplify_map_eq. - rewrite lookup_insert_ne in Hrinr; last by congruence. - iDestruct ("Hreg" $! src _ n Hrinr) as "Hvsrc". - iDestruct (read_allowed_inv _ a0 with "Hvsrc") as (P) "[Hinv [Hconds _] ]"; auto; + iDestruct ("Hreg" $! src _ n Hrinr) as "Hvsrc"; eauto. + iDestruct (read_allowed_inv _ a0 with "Hvsrc") as "Hconds"; auto; first (split; [by apply Z.leb_le | by apply Z.ltb_lt]). - iExists P. - iMod (inv_acc (⊤ ∖ ↑logN.@a) with "Hinv") as "[Hrefinv Hcls]";[solve_ndisj|]. - rewrite /interp_ref_inv /=. iDestruct "Hrefinv" as (w) "[>Ha HP]". - iExists w. - iAssert (▷ interp w)%I as "#Hw". - { iNext. iApply "Hconds". iFrame. } - iFrame "∗ #". iModIntro. rewrite /region_open_resources. done. - - iExists (λne _, True%I). done. + rewrite /read_write_cond. + iDestruct "Hconds" as "Hrel'". + + iDestruct (region_open_prepare with "Hr") as "Hr". + iDestruct (readAllowed_valid_cap_implies with "Hvsrc") as %HH; eauto. + { rewrite /withinBounds Hle Hge. auto. } + destruct HH as [ρ' [Hstd [Hnotrevoked' Hnotstatic' ] ] ]. + (* We can finally frame off Hsts here, + since it is no longer needed after opening the region*) + destruct (writeAllowed p0). + + iDestruct (region_open_next _ _ _ a0 ρ' with "[$Hrel' $Hr $Hsts]") as (w0) "($ & Hstate' & Hr & Ha0 & Hfuture & Hval)"; eauto. + { intros [g1 Hcontr]. specialize (Hnotstatic' g1); contradiction. } + { apply not_elem_of_cons. split; auto. apply not_elem_of_nil. } + iExists w0,interp. iFrame. iSplitR;[iPureIntro;apply _|]. + rewrite /rcond. iSplit;auto. iSplit;auto. + iNext; iModIntro. iIntros (W1 W2 z) "_"; iClear "#"; rewrite fixpoint_interp1_eq;done. + + iDestruct "Hrel'" as (P Hpers) "[Hcond Hrel']". + iDestruct (region_open_next _ _ _ a0 ρ' with "[$Hrel' $Hr $Hsts]") as (w0) "($ & Hstate' & Hr & Ha0 & Hfuture & Hval)"; eauto. + { intros [g1 Hcontr]. specialize (Hnotstatic' g1); contradiction. } + { apply not_elem_of_cons. split; auto. apply not_elem_of_nil. } + iExists w0,P. iFrame. iSplitR;[iPureIntro;apply _|]. + rewrite /rcond. iSplit;auto. + - iFrame. Qed. - (* Definition allow_load_mask (a a0 : Addr) : namespace := *) - (* if decide (a = a0) then ⊤ ∖ ↑logN.@a else ⊤ ∖ ↑logN.@a ∖ ↑logN.@a0. *) - Lemma load_res_implies_mem_map: - ∀ (r : leibnizO Reg) - (a a0 : Addr) (w : Word) (src : RegName) p1 b1 e1 (P:D), - allow_load_res src r a a0 p1 b1 e1 P - -∗ a ↦ₐ w - ={⊤ ∖ ↑logN.@a,if decide (reg_allows_load r src p1 b1 e1 a0 ∧ a0 ≠ a) then ⊤ ∖ ↑logN.@a ∖ ↑logN.@a0 else ⊤ ∖ ↑logN.@a}=∗ ∃ mem0 : gmap Addr Word, - allow_load_mem src r a w mem0 a0 p1 b1 e1 P true - ∗ ▷ ([∗ map] a0↦w ∈ mem0, a0 ↦ₐ w). + ∀ (W : WORLD) (regs : leibnizO Reg) + (a : Addr) (w : Word) (src : RegName), + allow_load_res W src regs a + -∗ a ↦ₐ w + -∗ ∃ mem0 : Mem, + allow_load_mem W src regs a w mem0 false + ∗ ▷ ([∗ map] a0↦w ∈ mem0, a0 ↦ₐ w). Proof. - intros r a a0 w src p1 b1 e1 P. + intros W regs a w src. iIntros "HLoadRes Ha". - iDestruct "HLoadRes" as "[% HLoadRes]". + iDestruct "HLoadRes" as (p1 g1 b1 e1 a1) "[% HLoadRes]". case_decide as Hdec. 1: destruct Hdec as [ Hallows Haeq ]. - pose(Hallows' := Hallows). destruct Hallows' as [Hrinr [Hra Hwb] ]. - iMod "HLoadRes" as (w0) "[Ha0 [HLoadRest #Hval] ]". + iDestruct "HLoadRes" as (w0 P Hpers) "[HLoadCh [HLoadRest #Hrcond] ]". iExists _. iSplitL "HLoadRest". - + iSplitR; first auto. - - case_decide as Hdec1. - 2: apply not_and_r in Hdec1 as [|]; by exfalso. - iExists w0. iSplitR; auto. - + iModIntro. iNext. - rewrite memMap_resource_2ne; auto; iFrame. - - rewrite /read_reg_inr in H. - iExists _. + + iExists p1,g1,b1,e1,a1. iSplitR; first auto. + case_decide as Hdec1. 2: apply not_and_r in Hdec1 as [|]; by exfalso. + iExists w0. iExists _. iSplitR; auto. + + iNext. + iApply memMap_resource_2ne; auto; iFrame. + - iExists _. iSplitL "HLoadRes". - + iModIntro. rewrite /allow_load_mem. iSplitR; auto. + + iExists p1,g1,b1,e1,a1. iSplitR; auto. case_decide; first by exfalso. auto. - + iModIntro. iNext. by iApply memMap_resource_1. + + iNext. by iApply memMap_resource_1. Qed. Lemma mem_map_implies_pure_conds: - ∀ (r : leibnizO Reg) - (a a0 : Addr) (w : Word) (src : RegName) - (mem0 : gmap Addr Word) p b e P f, - allow_load_mem src r a w mem0 a0 p b e P f - -∗ ⌜mem0 !! a = Some w⌝ - ∗ ⌜allow_load_map_or_true src r mem0⌝. + ∀ (W : WORLD) (regs : leibnizO Reg) + (a : Addr) (w : Word) (src : RegName) + (mem0 : Mem), + allow_load_mem W src regs a w mem0 false + -∗ ⌜mem0 !! a = Some w⌝ ∗ ⌜allow_load_map_or_true src regs mem0⌝. Proof. - iIntros (r a a0 w src mem0 p b e P f) "HLoadMem". - iDestruct "HLoadMem" as "[% HLoadRes]". + iIntros (W regs a w src mem0) "HLoadMem". + iDestruct "HLoadMem" as (p1 g1 b1 e1 a1) "[% HLoadRes]". case_decide as Hdec. 1: destruct Hdec as [ Hallows Haeq ]. - pose(Hallows' := Hallows). destruct Hallows' as [Hrinr [Hra Hwb] ]. (* case_decide as Haeq. *) - iDestruct "HLoadRes" as (w0) "[% _]". - iSplitR. rewrite H0 lookup_insert_ne; auto. by rewrite lookup_insert. - iExists p,b,e,a0. iSplitR; auto. + iDestruct "HLoadRes" as (w0 P Hpers) "[-> _]". + iSplitR. rewrite lookup_insert_ne; auto. by rewrite lookup_insert. + iExists p1,g1,b1,e1,a1. iSplitR; auto. case_decide; last by exfalso. - iExists w0. rewrite H0. - by rewrite lookup_insert. - - iDestruct "HLoadRes" as "->". + iExists w0. + by rewrite lookup_insert. + - iDestruct "HLoadRes" as "[-> HLoadRes ]". iSplitR. by rewrite lookup_insert. - iExists p,b,e,a0. iSplitR; auto. + iExists p1,g1,b1,e1,a1. iSplitR; auto. case_decide as Hdec1; last by done. apply not_and_r in Hdec as [| <-%dec_stable]; first by exfalso. iExists w. by rewrite lookup_insert. Qed. Lemma allow_load_mem_later: - ∀ (r : leibnizO Reg) (p : Perm) - (b e a a0 : Addr) (w : Word) (src : RegName) - (mem0 : gmap Addr Word) p0 b0 e0 P, - allow_load_mem src r a w mem0 a0 p0 b0 e0 P true - -∗ ▷ allow_load_mem src r a w mem0 a0 p0 b0 e0 P false. + ∀ (W : WORLD) (regs : leibnizO Reg) + (p : Perm) (g : Locality) (b e a : Addr) + (w : Word) (src : RegName) (mem0 : Mem), + allow_load_mem W src regs a w mem0 false + -∗ ▷ allow_load_mem W src regs a w mem0 true. Proof. - iIntros (r p b e a a0 w src mem0 p0 b0 e0 P) "HLoadMem". - iDestruct "HLoadMem" as "[% HLoadMem]". - rewrite !/allow_load_mem /=. iSplit;[auto|]. - destruct (decide (reg_allows_load r src p0 b0 e0 a0 ∧ a0 ≠ a)). - - iApply later_exist_2. iDestruct "HLoadMem" as (w0) "(?&HP&?)". - iExists w0. iNext. iDestruct "HP" as "(?&?&?)". iFrame. - - iNext. iFrame. + iIntros (W regs p g b e a w src mem0) "HLoadMem". + iDestruct "HLoadMem" as (p0 g0 b0 e0 a0) "[% HLoadMem]". + do 5 (iApply later_exist_2; iExists _). iApply later_sep_2; iSplitR; auto. + case_decide. + * iDestruct "HLoadMem" as (w0 P Hpers) "[-> [HLoadMem #[Hrcond _]] ]". + do 2 (iApply later_exist_2; iExists _). + do 2 (iApply later_sep_2; iSplitR; auto). + * iFrame. Qed. - Instance if_Persistent p b e a r src p0 b0 e0 a0 loadv : Persistent (if decide (reg_allows_load (<[PC:=WCap p b e a]> r) src p0 b0 e0 a0 ∧ a0 ≠ a) then interp loadv else emp)%I. - Proof. intros. destruct (decide (reg_allows_load (<[PC:=WCap p b e a]> r) src p0 b0 e0 a0 ∧ a0 ≠ a));apply _. Qed. - Lemma mem_map_recover_res: - ∀ (r : leibnizO Reg) - (a : Addr) (w : Word) (src : RegName) p0 - (b0 e0 a0 : Addr) (mem0 : gmap Addr Word) loadv P, - mem0 !! a0 = Some loadv - -> reg_allows_load r src p0 b0 e0 a0 - → allow_load_mem src r a w mem0 a0 p0 b0 e0 P false - -∗ ([∗ map] a0↦w ∈ mem0, a0 ↦ₐ w) - ={if decide (reg_allows_load r src p0 b0 e0 a0 ∧ a0 ≠ a) then ⊤ ∖ ↑logN.@a ∖ ↑logN.@a0 else ⊤ ∖ ↑logN.@a,⊤ ∖ ↑logN.@a}=∗ a ↦ₐ w - ∗ if decide (reg_allows_load r src p0 b0 e0 a0 ∧ a0 ≠ a) then interp loadv else emp. + ∀ (W : WORLD) (regs : leibnizO Reg) + (a : Addr) (w : Word) (src : RegName) + (p0 : Perm) (g0 : Locality) (b0 e0 a0 : Addr) + (mem0 : Mem) (loadv : Word), + reg_allows_load regs src p0 g0 b0 e0 a0 + → mem0 !! a0 = Some loadv + → allow_load_mem W src regs a w mem0 true + -∗ ((fixpoint interp1) W) w + -∗ ([∗ map] a0↦w ∈ mem0, a0 ↦ₐ w) + -∗ open_region a W ∗ a ↦ₐ w ∗ ((fixpoint interp1) W) loadv. Proof. - intros r a w src p0 b0 e0 a0 mem0 loadv P Hloadv Hrar. - iIntros "HLoadMem Hmem". - iDestruct "HLoadMem" as "[% HLoadRes]". - (* destruct (load_inr_eq Hrar H0) as (<- & <- &<- &<- &<-). *) + intros W regs a w src p0 g0 b0 e0 a0 mem0 loadv Hrar Ha0. + iIntros "HLoadMem #Hw Hmem". + iDestruct "HLoadMem" as (p1 g1 b1 e1 a1) "[%Hread HLoadRes]". + destruct (load_inr_eq Hrar Hread) as (<- & <- & <- & <- & <-). case_decide as Hdec. destruct Hdec as [Hallows Heq]. - destruct Hallows as [Hrinr [Hra Hwb] ]. - iDestruct "HLoadRes" as (w0) "[-> [ [HP [#Hcond Hcls] ] Hinterp] ]". - simplify_map_eq. + iDestruct "HLoadRes" as (w0 P Hpers) "[-> [HLoadRes #Hrcond] ]". + iDestruct "HLoadRes" as (ρ1) "(Hstate' & #Hrev & Hr & (Hfuture & #HV) & Hrel')". + iDestruct "Hrev" as %[Hnotrevoked Hnotstatic ]. rewrite memMap_resource_2ne; last auto. iDestruct "Hmem" as "[Ha1 $]". - iMod ("Hcls" with "[Ha1 HP]") as "_";[iNext;iExists loadv;iFrame|]. iModIntro. done. + iDestruct (region_close_next with "[$Hr $Ha1 $Hrel' $Hstate' $Hfuture]") as "Hr"; eauto. + { intros [g Hg]; specialize (Hnotstatic g); contradiction. } + { apply not_elem_of_cons; split; [auto|apply not_elem_of_nil]. } + iDestruct (region_open_prepare with "Hr") as "$". + simplify_map_eq. + iApply "Hrcond". simpl. iFrame "#". - apply not_and_r in Hdec as [| <-%dec_stable]. * by exfalso. - * iDestruct "HLoadRes" as "->". - rewrite -memMap_resource_1. by iFrame. + * iDestruct "HLoadRes" as "[-> $ ]". + rewrite -memMap_resource_1. + rewrite lookup_insert in Ha0. inversion Ha0. by iFrame. Qed. - Lemma load_case (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (w : Word) (dst src : RegName) (P : D): - ftlr_instr r p b e a w (Load dst src) P. + (* Instance if_Persistent p b e a r src p0 b0 e0 a0 loadv : Persistent (if decide (reg_allows_load (<[PC:=WCap p b e a]> r) src p0 b0 e0 a0 ∧ a0 ≠ a) then interp loadv else emp)%I. *) + (* Proof. intros. destruct (decide (reg_allows_load (<[PC:=WCap p b e a]> r) src p0 b0 e0 a0 ∧ a0 ≠ a));apply _. Qed. *) + + (* Lemma mem_map_recover_res: *) + (* ∀ (r : leibnizO Reg) *) + (* (a : Addr) (w : Word) (src : RegName) p0 *) + (* (b0 e0 a0 : Addr) (mem0 : gmap Addr Word) loadv P, *) + (* mem0 !! a0 = Some loadv *) + (* -> reg_allows_load r src p0 b0 e0 a0 *) + (* → allow_load_mem src r a w mem0 a0 p0 b0 e0 P false *) + (* -∗ ([∗ map] a0↦w ∈ mem0, a0 ↦ₐ w) *) + (* ={if decide (reg_allows_load r src p0 b0 e0 a0 ∧ a0 ≠ a) then ⊤ ∖ ↑logN.@a ∖ ↑logN.@a0 else ⊤ ∖ ↑logN.@a,⊤ ∖ ↑logN.@a}=∗ a ↦ₐ w *) + (* ∗ if decide (reg_allows_load r src p0 b0 e0 a0 ∧ a0 ≠ a) then interp loadv else emp. *) + (* Proof. *) + (* intros r a w src p0 b0 e0 a0 mem0 loadv P Hloadv Hrar. *) + (* iIntros "HLoadMem Hmem". *) + (* iDestruct "HLoadMem" as "[% HLoadRes]". *) + (* (* destruct (load_inr_eq Hrar H0) as (<- & <- &<- &<- &<-). *) *) + (* case_decide as Hdec. destruct Hdec as [Hallows Heq]. *) + (* - destruct Hallows as [Hrinr [Hra Hwb] ]. *) + (* iDestruct "HLoadRes" as (w0) "[-> [ [HP [#Hcond Hcls] ] Hinterp] ]". *) + (* simplify_map_eq. *) + (* rewrite memMap_resource_2ne; last auto. iDestruct "Hmem" as "[Ha1 $]". *) + (* iMod ("Hcls" with "[Ha1 HP]") as "_";[iNext;iExists loadv;iFrame|]. iModIntro. done. *) + (* - apply not_and_r in Hdec as [| <-%dec_stable]. *) + (* * by exfalso. *) + (* * iDestruct "HLoadRes" as "->". *) + (* rewrite -memMap_resource_1. by iFrame. *) + (* Qed. *) + + + Lemma load_case (W : WORLD) (regs : leibnizO Reg) (p : Perm) + (g : Locality) (b e a : Addr) (w : Word) (ρ : region_type) (dst src : RegName) (P:D) : + ftlr_instr W regs p g b e a w (Load dst src) ρ P. Proof. - intros Hp Hsome i Hbae Hi. - iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap". + intros Hp Hsome i Hbae Hpers Hpwl Hregion Hnotrevoked Hnotmonostatic Hi. + iIntros "#IH #Hinv #Hreg #Hinva #[Hrcond _] #Hwcond Hmono Hw Hsts Hown". + iIntros "Hr Hstate Ha HPC Hmap". + assert (Persistent (▷ P W w)). + { apply later_persistent. specialize (Hpers (W,w)). auto. } + iDestruct "Hw" as "#Hw". rewrite delete_insert_delete. iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. (* To read out PC's name later, and needed when calling wp_load *) - assert(∀ x : RegName, is_Some (<[PC:=WCap p b e a]> r !! x)) as Hsome'. + assert(∀ x : RegName, is_Some (<[PC:=WCap p g b e a]> regs !! x)) as Hsome'. { intros. destruct (decide (x = PC)). rewrite e0 lookup_insert; unfold is_Some. by eexists. by rewrite lookup_insert_ne. } - (* Initializing the names for the values of Hsrc now, to instantiate the existentials in step 1 *) - assert (∃ p0 b0 e0 a0, read_reg_inr (<[PC:=WCap p b e a]> r) src p0 b0 e0 a0) as [p0 [b0 [e0 [a0 HVsrc] ] ] ]. + (* Initializing the names for the values of Hsrc now, + to instantiate the existentials in step 1 *) + assert (∃ p0 g0 b0 e0 a0, read_reg_inr (<[PC:=WCap p g b e a]> regs) src p0 g0 b0 e0 a0) + as [p0 [g0 [b0 [e0 [a0 HVsrc] ] ] ] ]. { specialize Hsome' with src as Hsrc. destruct Hsrc as [wsrc Hsomesrc]. unfold read_reg_inr. rewrite Hsomesrc. - destruct wsrc as [|[ p0 b0 e0 a0|] | ]; try done. + destruct wsrc as [|[ p0 g0 b0 e0 a0|] | ]; try done. by repeat eexists. } - (* Step 1: open the region, if necessary, and store all the resources obtained from the region in allow_load_res *) - iDestruct (create_load_res with "Hreg") as (P') "HLoadRes"; eauto. + iDestruct (create_load_res with "Hreg Hr Hsts") as "[HLoadRes Hsts]"; eauto. + (* Clear helper values; they exist in the existential now *) + clear HVsrc p0 g0 b0 e0 a0. (* Step2: derive the concrete map of memory we need, and any spatial predicates holding over it *) - iMod (load_res_implies_mem_map with "HLoadRes Ha") as (mem0) "[HLoadMem HLoadRest]". + iDestruct (load_res_implies_mem_map W with "HLoadRes Ha") as (mem) "[HLoadMem HMemRes]". (* Step 3: derive the non-spatial conditions over the memory map*) iDestruct (mem_map_implies_pure_conds with "HLoadMem") as %(HReadPC & HLoadAP); auto. @@ -234,94 +309,70 @@ Section fundamental. (* Step 4: move the later outside, so that we can remove it after applying wp_load *) iDestruct (allow_load_mem_later with "HLoadMem") as "HLoadMem"; auto. - iApply (wp_load with "[Hmap HLoadRest]");eauto. + iApply (wp_load with "[Hmap HMemRes]"); eauto. { by rewrite lookup_insert. } - { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _. + { rewrite /subseteq /map_subseteq. intros rr _. apply elem_of_dom. rewrite lookup_insert_is_Some'; eauto. } { iSplitR "Hmap"; auto. } iNext. iIntros (regs' retv). iDestruct 1 as (HSpec) "[Hmem Hmap]". - (* Infer that if P holds at w, then w must be valid (read condition) *) - iDestruct ("Hread" with "HP") as "#Hw". - destruct HSpec as [* ? ? Hincr|]. { apply incrementPC_Some_inv in Hincr. - destruct Hincr as (?&?&?&?&?&?&?&?). - iApply wp_pure_step_later; auto. - specialize (load_inr_eq H HVsrc) as (-> & -> & -> & ->). - rewrite /allow_load_res. + destruct Hincr as (?&?&?&?&?&?&?&?&XX). + iApply wp_pure_step_later; auto. iNext; iIntros "_". + (* Step 5: return all the resources we had in order to close the second location in the region, in the cases where we need to *) - iMod (mem_map_recover_res with "HLoadMem Hmem") as "[Ha #Hinterp]";[eauto|auto|iModIntro]. - iMod ("Hcls" with "[Ha HP]");[iExists w;iFrame|iModIntro]. + iDestruct (mem_map_recover_res with "HLoadMem [] Hmem") as "[Hr [Ha #HLVInterp ] ]"; eauto. + { iApply "Hrcond". iFrame "Hw". } - (* Exceptional success case: we do not apply the induction hypothesis in case we have a faulty PC *) - destruct (decide (x = RX ∨ x = RWX)). + (* Exceptional success case: we do not apply the induction hypothesis in case we have a faulty PC*) + destruct (decide (x = RX ∨ x = RWX ∨ x = RWLX)). 2 : { - assert (x ≠ RX ∧ x ≠ RWX). split; by auto. + assert (x ≠ RX ∧ x ≠ RWX ∧ x ≠ RWLX). split; last split; by auto. iDestruct ((big_sepM_delete _ _ PC) with "Hmap") as "[HPC Hmap]". { subst. by rewrite lookup_insert. } - iNext; iIntros "_". iApply (wp_bind (fill [SeqCtx])). iApply (wp_notCorrectPC_perm with "[HPC]"); eauto. iIntros "!> _". - iApply wp_pure_step_later; auto. - iNext; iIntros "_". - iApply wp_value. + iApply wp_pure_step_later; auto. iNext; iIntros "_". iApply wp_value. iIntros (a1); inversion a1. } - iNext; iIntros "_". - iApply ("IH" $! regs' with "[%] [Hinterp] [Hmap] [$Hown]"). + iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono]") as "Hr"; eauto. + { destruct ρ;auto;[|specialize (Hnotmonostatic g1)];contradiction. } + iApply ("IH" $! _ regs' with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]"). { cbn. intros. subst regs'. rewrite lookup_insert_is_Some. - destruct (decide (PC = x4)); [ auto | right; split; auto]. + destruct (decide (PC = x5)); [ auto | right; split; auto]. rewrite lookup_insert_is_Some. - destruct (decide (dst = x4)); [ auto | right; split; auto]. } - (* Prove in the general case that the value relation holds for the register that was loaded to - unless it was the PC.*) - { iIntros (ri v Hri Hvs). + destruct (decide (dst = x5)); [ auto | right; split; auto]. } + (* Prove in the general case that the value relation holds for the register + that was loaded to - unless it was the PC.*) + { iIntros (ri wi Hri Hregs_ri). subst regs'. - rewrite lookup_insert_ne in Hvs; auto. destruct (decide (ri = dst)). - { subst ri. - rewrite lookup_insert in Hvs; auto. inversion Hvs. - destruct (decide (a = a0)). - - simplify_eq. iFrame "Hw". - - iClear "HLoadRes Hwrite". rewrite decide_True. iFrame "#". auto. - } - { repeat (rewrite lookup_insert_ne in Hvs); auto. - iApply "Hreg"; auto. } + { by simplify_map_eq. } + { simplify_map_eq; iApply "Hreg"; auto. } } { subst regs'. rewrite insert_insert. iApply "Hmap". } + { destruct (decide (PC = dst)); simplify_eq. + - destruct o as [HRX | [HRWX | HRWLX] ]; auto. + subst; simplify_map_eq. + iDestruct (writeLocalAllowed_implies_local _ RWLX with "[HLVInterp]") as "%"; auto. + destruct x0; unfold isLocal in *. all: inversion H3. + iPureIntro; do 2 right; auto; simplify_map_eq. + naive_solver. + - simplify_map_eq; iPureIntro; naive_solver. + } { iModIntro. destruct (decide (PC = dst)); simplify_eq. - - simplify_map_eq. rewrite (fixpoint_interp1_eq). - destruct (decide (a = a0)). - + simplify_map_eq. - + iClear "HLoadRes Hwrite". rewrite decide_True;auto. - rewrite !fixpoint_interp1_eq. - destruct o as [-> | ->]; iFrame "Hinterp". - - (* iExists p'. *) simplify_map_eq. - iClear "Hw Hinterp Hwrite". - rewrite !fixpoint_interp1_eq /=. - destruct o as [-> | ->]; iFrame "Hinv". + - simplify_map_eq. + iApply readAllowed_implies_region_conditions; auto. naive_solver. + - simplify_map_eq. auto. } } - { rewrite /allow_load_res /allow_load_mem. - destruct (decide (reg_allows_load (<[PC:=WCap p b e a]> r) src p0 b0 e0 a0 ∧ a0 ≠ a)). - - iDestruct "HLoadMem" as "(_&H)". - iDestruct "H" as (w') "(->&Hres&Hinterp)". rewrite /region_open_resources. - destruct a1. rewrite memMap_resource_2ne; last auto. - iDestruct "Hmem" as "[Ha0 Ha]". iDestruct "Hres" as "(HP' & Hread' & Hcls')". - iMod ("Hcls'" with "[HP' Ha0]");[iExists w';iFrame|iModIntro]. - iMod ("Hcls" with "[Ha HP]");[iExists w;iFrame|iModIntro]. - iApply wp_pure_step_later; auto. - iNext; iIntros "_". - iApply wp_value; auto. iIntros; discriminate. - - iModIntro. iDestruct "HLoadMem" as "(_&->)". rewrite -memMap_resource_1. - iMod ("Hcls" with "[Hmem HP]");[iExists w;iFrame|iModIntro]. - iApply wp_pure_step_later; auto. - iNext; iIntros "_". - iApply wp_value; auto. iIntros; discriminate. - } + { iApply wp_pure_step_later; auto. + iNext; iIntros "_". + iApply wp_value; auto. iIntros; discriminate. } Unshelve. all: auto. Qed. diff --git a/theories/ftlr/Mov.v b/theories/ftlr/Mov.v index b0fca7c4..8757909f 100644 --- a/theories/ftlr/Mov.v +++ b/theories/ftlr/Mov.v @@ -4,96 +4,115 @@ From iris.program_logic Require Import weakestpre adequacy lifting. From stdpp Require Import base. From cap_machine.ftlr Require Import ftlr_base. From cap_machine.rules Require Import rules_base rules_Mov. +From cap_machine.proofmode Require Import map_simpl. +From cap_machine Require Import stdpp_extra. Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). - Lemma mov_case (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (w : Word) (dst : RegName) (src : Z + RegName) (P : D): - ftlr_instr r p b e a w (Mov dst src) P. + Lemma mov_case (W : WORLD) (regs : leibnizO Reg) (p : Perm) + (g : Locality) (b e a : Addr) (w : Word) (ρ : region_type) (dst : RegName) (src : Z + RegName) (P:D): + ftlr_instr W regs p g b e a w (Mov dst src) ρ P. Proof. - intros Hp Hsome i Hbae Hi. - iIntros "#IH #Hinv #Hinva #Hreg #Hread Hown Ha HP Hcls HPC Hmap". + intros Hp Hsome i Hbae Hpers Hpwl Hregion Hnotrevoked Hnotmonostatic Hi. + iIntros "#IH #Hinv #Hreg #Hinva #Hrcond #Hwcond Hmono Hw Hsts Hown". + iIntros "Hr Hstate Ha HPC Hmap". rewrite delete_insert_delete. iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. iApply (wp_Mov with "[$Ha $Hmap]"); eauto. { simplify_map_eq; auto. } - { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _. + { rewrite /subseteq /map_subseteq. intros rr _. apply elem_of_dom. apply lookup_insert_is_Some'; eauto. } iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]". destruct HSpec; cycle 1. - { iApply wp_pure_step_later; auto. - iMod ("Hcls" with "[Ha HP]"); [iExists w; iFrame|iModIntro]. iNext. - iIntros "_". - iApply wp_value; auto. iIntros; discriminate. } - { incrementPC_inv as (p''&b''&e''&a''& ? & HPC & Z & Hregs'); simplify_map_eq. - iApply wp_pure_step_later; auto. - iMod ("Hcls" with "[Ha HP]"); [iExists w; iFrame|iModIntro]. - iNext. - destruct (reg_eq_dec dst PC). - { subst dst. - simplify_map_eq. - repeat rewrite insert_insert. + - iApply wp_pure_step_later; auto. iNext; iIntros "_". + iApply wp_value; auto. iIntros; discriminate. + - incrementPC_inv; simplify_map_eq. + rename x into p' + ; rename x0 into g' + ; rename x1 into b' + ; rename x2 into e' + ; rename x3 into a' + ; rename x4 into a''. + iApply wp_pure_step_later; auto; iNext; iIntros "_". + + destruct (decide (dst = PC)) as [HdstPC|HdstPC]; simplify_map_eq. + { map_simpl "Hmap". destruct src; simpl in *; try discriminate. - destruct (reg_eq_dec PC r0). - { subst r0. simplify_map_eq. - iIntros "_". - iApply ("IH" $! r with "[%] [] [Hmap] [$Hown]"); try iClear "IH"; eauto. - iModIntro. rewrite !fixpoint_interp1_eq /=. destruct Hp as [-> | ->]; iFrame "Hinv". } - { simplify_map_eq. - iDestruct ("Hreg" $! r0 _ _ H) as "Hr0". - destruct (PermFlowsTo RX p'') eqn:Hpft; iIntros "_". - - iApply ("IH" $! r with "[%] [] [Hmap] [$Hown]"); try iClear "IH"; eauto. - + iModIntro. - destruct p''; simpl in Hpft; try discriminate; repeat (rewrite fixpoint_interp1_eq); simpl; auto. - - iApply (wp_bind (fill [SeqCtx])). - iDestruct ((big_sepM_delete _ _ PC) with "Hmap") as "[HPC Hmap]"; [apply lookup_insert|]. - iApply (wp_notCorrectPC with "HPC"); [eapply not_isCorrectPC_perm; destruct p''; simpl in Hpft; try discriminate; eauto|]. - iNext. iIntros "HPC /=". - iApply wp_pure_step_later; auto. - iNext; iIntros "_". - iApply wp_value. - iIntros. discriminate. } } - { simplify_map_eq. - iIntros "_". - iApply ("IH" $! (<[dst:=w0]> _) with "[%] [] [Hmap] [$Hown]"); eauto. + iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono Hw]") as "Hr"; eauto. + { destruct ρ;auto;[|specialize (Hnotmonostatic g0)];contradiction. } + destruct (decide (r = PC)). + + simplify_map_eq. + iApply ("IH" $! _ regs with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]"); try iClear "IH"; eauto. + + simplify_map_eq. + iDestruct ("Hreg" $! r (WCap p' g' b' e' a') n H ) as "Hr0". + destruct (PermFlowsTo RX p') eqn:Hpft. + - iApply ("IH" $! _ regs with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]"); try iClear "IH"; eauto. + { destruct p'; simpl in Hpft; auto. + repeat rewrite fixpoint_interp1_eq; simpl. + destruct g'; auto. + } + { iModIntro. rewrite /region_conditions. + destruct p'; simpl in Hpft; try discriminate; repeat (rewrite fixpoint_interp1_eq); simpl; auto. + + iApply (big_sepL_mono with "Hr0"). + intros. iIntros "H". iDestruct "H" as (P') "(?&?&?)". + iApply bi.and_exist_r. iExists _. iFrame. + + destruct g'; auto. + iApply (big_sepL_mono with "Hr0"). + intros. iIntros "H". iDestruct "H" as (P') "(?&?&?)". + iFrame. + } + - iApply (wp_bind (fill [SeqCtx])). + iDestruct ((big_sepM_delete _ _ PC) with "Hmap") as "[HPC Hmap]"; [apply lookup_insert|]. + iApply (wp_notCorrectPC with "HPC"); [eapply not_isCorrectPC_perm; destruct p'; simpl in Hpft; try discriminate; eauto|]. + iNext. iIntros "HPC /=". + iApply wp_pure_step_later; auto;iNext; iIntros "_". + iApply wp_value. + iIntros. discriminate. } + { map_simpl "Hmap". + iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono Hw]") as "Hr"; eauto. + { destruct ρ;auto;[|specialize (Hnotmonostatic g)];contradiction. } + iApply ("IH" $! _ (<[dst:=w0]> _) with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]"); eauto. - intros; simpl. rewrite lookup_insert_is_Some. - destruct (reg_eq_dec dst x0); auto; right; split; auto. - rewrite lookup_insert_is_Some. - destruct (reg_eq_dec PC x0); auto; right; split; auto. - - iIntros (ri v Hri Hvs). - destruct (reg_eq_dec ri dst). - + subst ri. rewrite lookup_insert in Hvs. + destruct (decide (dst = x)); auto; right; split; auto. + - iIntros (ri wi Hri Hregs_ri). + destruct (decide (ri = dst)); simplify_map_eq. + { (* ri = dst *) destruct src; simplify_map_eq. * repeat rewrite fixpoint_interp1_eq; auto. - * destruct (reg_eq_dec PC r0). - { subst r0. - - simplify_map_eq. - rewrite !fixpoint_interp1_eq /=. - destruct Hp as [Hp | Hp]; subst p''; try subst g''; - (iFrame "Hinv Hexec"). } - simplify_map_eq. - iDestruct ("Hreg" $! r0 _ _ H) as "Hr0". auto. - + repeat rewrite lookup_insert_ne in Hvs; auto. - iApply "Hreg"; auto. - - iModIntro. rewrite !fixpoint_interp1_eq /=. destruct Hp as [-> | ->]; iFrame "Hinv". + * destruct (decide (PC = r)); simplify_map_eq. + ** rewrite (fixpoint_interp1_eq _ (WCap p' g' b' e' a')) /=. + destruct Hp as [Hp | [Hp | [Hp Hg] ] ]; subst p'; try subst g'; + try (iFrame "Hexec"); try (iFrame "Hinv"). + all: iApply (big_sepL_mono with "Hinv"). + all: intros; iIntros "(H & ?)". + all: simpl; try (iDestruct "H" as (P') "(?&?&?)"). + iExists _; iFrame. + iExists RWLX; iFrame; iPureIntro ; done. + ** iApply ("Hreg" $! r) ; auto. + } + { iApply ("Hreg" $! ri) ; auto. } } - } - Unshelve. all: auto. Qed. End fundamental. diff --git a/theories/ftlr/Seal.v b/theories/ftlr/Seal.v index e09a24d5..7ff069a2 100644 --- a/theories/ftlr/Seal.v +++ b/theories/ftlr/Seal.v @@ -9,41 +9,48 @@ Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). (* Proving the meaning of sealing in the LR sane *) - Lemma sealing_preserves_interp sb p0 b0 e0 a0: + Lemma sealing_preserves_interp W sb p0 g0 b0 e0 a0: permit_seal p0 = true → withinBounds b0 e0 a0 = true → - fixpoint interp1 (WSealable sb) -∗ - fixpoint interp1 (WSealRange p0 b0 e0 a0) -∗ - fixpoint interp1 (WSealed a0 sb). + fixpoint interp1 W (WSealable sb) -∗ + fixpoint interp1 W (WSealRange p0 g0 b0 e0 a0) -∗ + fixpoint interp1 W (WSealed a0 sb). Proof. iIntros (Hpseal Hwb) "#HVsb #HVsr". - rewrite (fixpoint_interp1_eq (WSealRange _ _ _ _)) (fixpoint_interp1_eq (WSealed _ _)) /= Hpseal /interp_sb. + rewrite (fixpoint_interp1_eq W (WSealRange _ _ _ _ _)) (fixpoint_interp1_eq W (WSealed _ _)) /= Hpseal /interp_sb. iDestruct "HVsr" as "[Hss _]". apply seq_between_dist_Some in Hwb. iDestruct (big_sepL_delete with "Hss") as "[HSa0 _]"; eauto. iDestruct "HSa0" as (P) "[% [HsealP HWcond]]". - iExists P. + iExists (P W). repeat iSplitR; auto. by iApply "HWcond". Qed. - Lemma seal_case (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (w : Word) (dst r1 r2 : RegName) (P:D): - ftlr_instr r p b e a w (Seal dst r1 r2) P. + Lemma seal_case (W : WORLD) (regs : leibnizO Reg) (p : Perm) + (g : Locality) (b e a : Addr) (w : Word) (ρ : region_type) (dst r1 r2 : RegName) (P:D): + ftlr_instr W regs p g b e a w (Seal dst r1 r2) ρ P. Proof. - intros Hp Hsome i Hbae Hi. - iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap". + intros Hp Hsome i Hbae Hpers Hpwl Hregion Hnotrevoked Hnotmonostatic Hi. + iIntros "#IH #Hinv #Hreg #Hinva #Hrcond #Hwcond Hmono Hw Hsts Hown". + iIntros "Hr Hstate Ha HPC Hmap". rewrite delete_insert_delete. iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. @@ -53,46 +60,48 @@ Section fundamental. apply elem_of_dom. apply lookup_insert_is_Some'; eauto. } iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]". - destruct HSpec as [ * Hr1 Hr2 Hseal Hwb HincrPC | ]. - { apply incrementPC_Some_inv in HincrPC as (p''&b''&e''&a''& ? & HPC & Z & Hregs') . + destruct HSpec as [ * Hr1 Hr2 Hseal Hwb HincrPC | ]; cycle 1. + { + iApply wp_pure_step_later; auto. iNext; iIntros "_". + iApply wp_value; auto. iIntros; discriminate. + } - assert (p'' = p ∧ a'' = a ∧ b'' = b ∧ e'' = e) as (-> & -> & -> & ->). + - apply incrementPC_Some_inv in HincrPC as (p''&g''&b''&e''&a''& ? & HPC & Z & Hregs') . + assert (p'' = p ∧ g'' = g ∧ a'' = a ∧ b'' = b ∧ e'' = e) as (-> & -> & -> & -> & ->). { destruct (decide (PC = dst)); simplify_map_eq; auto. } assert (r1 ≠ PC) as Hne. { destruct (decide (PC = r1)); last auto. simplify_map_eq; auto. } rewrite lookup_insert_ne in Hr1; auto. - iAssert (fixpoint interp1 (WSealable sb)) as "HVsb". { - destruct (decide (r2 = PC)) eqn:Heq. - - subst r2. simplify_map_eq; auto. - - simplify_map_eq. unshelve iSpecialize ("Hreg" $! r2 _ _ Hr2); eauto. + iAssert (fixpoint interp1 W (WSealable sb)) as "#HVsb". { + destruct (decide (r2 = PC)) as [Heq|Heq]; simplify_map_eq. + - rewrite (fixpoint_interp1_eq _ (WCap p g b e a)) /=. + destruct Hp as [Hp | [Hp | [Hp Hg] ] ]; subst p; try subst g; + try (iFrame "Hexec"); try (iFrame "Hinv"). + all: iApply (big_sepL_mono with "Hinv"). + all: intros; iIntros "(H & ?)". + all: simpl; try (iDestruct "H" as (P') "(?&?&?)"). + iExists _; iFrame. + iExists RWLX; iFrame; iPureIntro ; done. + - unshelve iSpecialize ("Hreg" $! r2 _ _ Hr2); eauto. } - iApply wp_pure_step_later; auto. - iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. - iNext; iIntros "_". - iApply ("IH" $! regs' with "[%] [] [Hmap] [$Hown]"). - { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). } - { iIntros (ri v Hri Hvs). - subst regs'. - rewrite lookup_insert_ne in Hvs; auto. - destruct (decide (ri = dst)). - { subst ri. - rewrite lookup_insert in Hvs; inversion Hvs. simplify_eq. - (* Sealrange is valid -> validity implies P *) - unshelve iDestruct ("Hreg" $! r1 _ _ Hr1) as "HVsr"; eauto. - iApply (sealing_preserves_interp with "HVsb HVsr"); auto. } - { repeat (rewrite lookup_insert_ne in Hvs); auto. - iApply "Hreg"; auto. } } - { subst regs'. rewrite insert_insert. iApply "Hmap". } - iModIntro. - iApply (interp_weakening with "IH Hinv"); auto; try solve_addr. - { destruct Hp; by subst p. } - { by rewrite PermFlowsToReflexive. } - } - { iApply wp_pure_step_later; auto. - iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. - iNext; iIntros "_". - iApply wp_value; auto. iIntros; discriminate. } + iApply wp_pure_step_later; auto; iNext; iIntros "_". + + assert (dst <> PC) as HdstPC by (intros ->; simplify_map_eq). + simplify_map_eq. + iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono Hw]") as "Hr"; eauto. + { destruct ρ;auto;[|ospecialize (Hnotmonostatic _)];contradiction. } + + iApply ("IH" $! _ (<[dst := _]> (<[PC := _]> regs)) + with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]"); + try iClear "IH"; eauto. + + intro. cbn. by repeat (rewrite lookup_insert_is_Some'; right). + + iIntros (ri wi Hri Hregs_ri). + destruct (decide (ri = dst)); simplify_map_eq. + { unshelve iDestruct ("Hreg" $! r1 _ _ Hr1) as "HVsr"; eauto. + iApply (sealing_preserves_interp with "[HVsb HVsr]"); eauto. + } + { by iApply "Hreg". } Qed. End fundamental. diff --git a/theories/ftlr/Store.v b/theories/ftlr/Store.v index c7cdf669..9de94dd1 100644 --- a/theories/ftlr/Store.v +++ b/theories/ftlr/Store.v @@ -1,7 +1,7 @@ From iris.proofmode Require Import proofmode. From iris.program_logic Require Import weakestpre adequacy lifting. From stdpp Require Import base. -From cap_machine Require Export logrel. +From cap_machine Require Export logrel monotone. From cap_machine.ftlr Require Import ftlr_base. From cap_machine.rules Require Import rules_Store. Import uPred. @@ -11,175 +11,338 @@ Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). - - (* The necessary resources to close the region again, except for the points to predicate, which we will store separately *) - (* Since we will store a new word into a, we do not need to remember its validity *) - Definition region_open_resources (a pc_a : Addr) pc_w : iProp Σ := - (▷ interp pc_w ∗ ((▷ ∃ w0, a ↦ₐ w0 ∗ interp w0) ={⊤ ∖ ↑logN.@pc_a ∖ ↑logN.@a,⊤ ∖ ↑logN.@pc_a}=∗ emp))%I. - - Lemma store_inr_eq {regs r p0 b0 e0 a0 p1 b1 e1 a1}: - reg_allows_store regs r p0 b0 e0 a0 → - read_reg_inr regs r p1 b1 e1 a1 → - p0 = p1 ∧ b0 = b1 ∧ e0 = e1 ∧ a0 = a1. + (* The necessary resources to close the region again, + except for the points to predicate, which we will store separately *) + Definition region_open_resources W l ls φ (v : Word): iProp Σ := + (∃ ρ, + sts_state_std l ρ + ∗ ⌜std W !! l = Some ρ⌝ + ∗ ⌜ρ ≠ Revoked⌝ + ∗ ⌜(∀ g, ρ ≠ Monostatic g)⌝ + ∗ open_region_many (l :: ls) W + ∗ rel l φ)%I. + + Lemma store_inr_eq {regs r p0 g0 b0 e0 a0 p1 g1 b1 e1 a1 storev}: + reg_allows_store regs r p0 g0 b0 e0 a0 storev → + read_reg_inr regs r p1 g1 b1 e1 a1 → + p0 = p1 ∧ g0 = g1 ∧ b0 = b1 ∧ e0 = e1 ∧ a0 = a1. Proof. - intros Hrar H3. - pose (Hrar' := Hrar). - destruct Hrar' as (Hinr0 & _). rewrite /read_reg_inr Hinr0 in H3. - by inversion H3. + intros Hrar H3. + pose (Hrar' := Hrar). + destruct Hrar' as (Hinr0 & _). rewrite /read_reg_inr Hinr0 in H3. + by inversion H3. Qed. - (* Description of what the resources are supposed to look like after opening the region if we need to, but before closing the region up again*) - Definition allow_store_res r1 (regs : Reg) pc_a a p b e := - (⌜read_reg_inr regs r1 p b e a⌝ ∗ - if decide (reg_allows_store regs r1 p b e a ∧ a ≠ pc_a) then - |={⊤ ∖ ↑logN.@pc_a,⊤ ∖ ↑logN.@pc_a ∖ ↑logN.@a}=> ∃ w, a ↦ₐ w ∗ region_open_resources a pc_a w - else True)%I. - - Definition allow_store_mem r1 (regs : Reg) pc_a pc_w (mem : gmap Addr Word) p b e a := - (⌜read_reg_inr regs r1 p b e a⌝ ∗ - if decide (reg_allows_store regs r1 p b e a ∧ a ≠ pc_a) then - ∃ w, ⌜mem = <[a:=w]> (<[pc_a:=pc_w]> ∅)⌝ ∗ region_open_resources a pc_a w - else ⌜mem = <[pc_a:=pc_w]> ∅⌝)%I. - + (* Description of what the resources are supposed to look like + after opening the region if we need to, + but before closing the region up again*) + Definition allow_store_res W r1 r2 (regs : Reg) pc_a := + (∃ p g b e a storev, ⌜read_reg_inr regs r1 p g b e a⌝ + ∗ ⌜word_of_argument regs r2 = Some storev⌝ + ∗ if decide (reg_allows_store regs r1 p g b e a storev ) + then (if decide (a ≠ pc_a) + then ∃ w, a ↦ₐ w ∗ (region_open_resources W a [pc_a] interpC w) + else open_region pc_a W ) + else open_region pc_a W)%I. + + Definition allow_store_mem W r1 r2 (regs : Reg) pc_a pc_w (mem : Mem):= + (∃ p g b e a storev, ⌜read_reg_inr regs r1 p g b e a⌝ + ∗ ⌜word_of_argument regs r2 = Some storev⌝ + ∗ if decide (reg_allows_store regs r1 p g b e a storev) + then (if decide (a ≠ pc_a) + then ∃ w, ⌜mem = <[a:=w]> (<[pc_a:=pc_w]> ∅)⌝ + ∗ (region_open_resources W a [pc_a] interpC w) + else ⌜mem = <[pc_a:=pc_w]> ∅⌝ ∗ open_region pc_a W) + else ⌜mem = <[pc_a:=pc_w]> ∅⌝ ∗ open_region pc_a W)%I. Lemma create_store_res: - ∀ (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (r1 : RegName) (p0 : Perm) - (b0 e0 a0 : Addr), - read_reg_inr (<[PC:=WCap p b e a]> r) r1 p0 b0 e0 a0 - → (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜r !! r1 = Some v⌝ → (fixpoint interp1) v) - -∗ allow_store_res r1 (<[PC:=WCap p b e a]> r) a a0 p0 b0 e0. + ∀ (W : WORLD) (regs : leibnizO Reg) (p : Perm) + (g : Locality) (b e a : Addr) (r1 : RegName) (r2 : Z + RegName) + (p0 : Perm) (g0 : Locality) (b0 e0 a0 : Addr) (storev : Word) (P:D), + read_reg_inr (<[PC:= WCap p g b e a]> regs) r1 p0 g0 b0 e0 a0 + → word_of_argument (<[PC:=WCap p g b e a]> regs) r2 = Some storev + → (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜regs !! r1 = Some v⌝ → ((fixpoint interp1) W) v) + -∗ rel a (λ Wv : STS_std_states Addr region_type * (STS_states * STS_rels) * Word, P Wv.1 Wv.2) + -∗ open_region a W + -∗ sts_full_world W + -∗ allow_store_res W r1 r2 (<[PC:=WCap p g b e a]> regs) a ∗ sts_full_world W. Proof. - intros r p b e a r1 p0 b0 e0 a0 HVr1. - iIntros "#Hreg". - iFrame "%". + intros W regs p g b e a r1 r2 p0 g0 b0 e0 a0 storev P HVr1 Hwoa. + iIntros "#Hreg #Hinva Hr Hsts". + do 6 (iApply sep_exist_r; iExists _). iFrame "%". case_decide as Hallows. - - destruct Hallows as ((Hrinr & Hra & Hwb) & Haeq). - apply andb_prop in Hwb as [Hle Hge]. - revert Hle Hge. rewrite !Z.leb_le Z.ltb_lt =>Hle Hge. - assert (r1 ≠ PC) as n. refine (addr_ne_reg_ne Hrinr _ Haeq). by rewrite lookup_insert. - rewrite lookup_insert_ne in Hrinr; last by congruence. - iDestruct ("Hreg" $! r1 _ n Hrinr) as "Hvsrc". - iAssert (inv (logN.@a0) ((interp_ref_inv a0) interp))%I as "#Hinva". - { iApply (write_allowed_inv with "Hvsrc"); auto. } - iMod (inv_acc with "Hinva") as "[Hinv Hcls']";[solve_ndisj|]. - iDestruct "Hinv" as (w) "[>Ha0 #Hinv]". - iFrame. done. - - done. + - case_decide as Haeq. + * destruct Hallows as (Hrinr & Hra & Hwb & HLoc). + apply andb_prop in Hwb as [Hle Hge]. + assert (r1 ≠ PC) as n. + { refine (addr_ne_reg_ne Hrinr _ Haeq). by rewrite lookup_insert. } + + simplify_map_eq. + iDestruct ("Hreg" $! r1 _ n Hrinr) as "Hvsrc"; eauto. + iDestruct (read_allowed_inv _ a0 with "Hvsrc") as "Hrel'". + { split; [apply Zle_is_le_bool | apply Zlt_is_lt_bool]; auto. } + { by apply writeA_implies_readA in Hra as ->. } + rewrite /read_write_cond. + + iDestruct (region_open_prepare with "Hr") as "Hr". + iDestruct (readAllowed_valid_cap_implies with "Hvsrc") as %HH; eauto. + { by apply writeA_implies_readA. } + { rewrite /withinBounds Hge; solve_addr. } + destruct HH as [ρ' [Hstd' [Hnotrevoked' Hnotmonostatic'] ] ]. + (* We can finally frame off Hsts here, since it is no longer needed after opening the region*) + rewrite Hra. + iDestruct (region_open_next _ _ _ a0 ρ' with "[$Hrel' $Hr $Hsts]") as (w0) "($ & Hstate' & Hr & Ha0 & Hfuture & #Hval)"; eauto. + { intros [g1 Hcontr]. specialize (Hnotmonostatic' g1); contradiction. } + { apply not_elem_of_cons. split; auto. apply not_elem_of_nil. } + iExists w0. iSplitL "Ha0"; auto. unfold region_open_resources. + iExists ρ'. iFrame "%". iFrame. by iFrame "#". + * subst a0. iFrame. + - iFrame. Qed. - Lemma store_res_implies_mem_map: - ∀ (r : leibnizO Reg) - (a a0 : Addr) (w : Word) (r1 : RegName) p1 b1 e1, - allow_store_res r1 r a a0 p1 b1 e1 - -∗ a ↦ₐ w - ={⊤ ∖ ↑logN.@a, if decide (reg_allows_store r r1 p1 b1 e1 a0 ∧ a0 ≠ a) then ⊤ ∖ ↑logN.@a ∖ ↑logN.@a0 - else ⊤ ∖ ↑logN.@a}=∗ ∃ mem0 : gmap Addr Word, - allow_store_mem r1 r a w mem0 p1 b1 e1 a0 - ∗ ▷ ([∗ map] a0↦w ∈ mem0, a0 ↦ₐ w). + ∀ (W : WORLD) (regs : leibnizO Reg) + (a : Addr) (w : Word) (r1 : RegName) (r2 : Z + RegName), + allow_store_res W r1 r2 regs a + -∗ a ↦ₐ w + -∗ ∃ mem0 : Mem, + allow_store_mem W r1 r2 regs a w mem0 ∗ ▷ ([∗ map] a0↦w0 ∈ mem0, a0 ↦ₐ w0). Proof. - intros r a a0 w r1 p1 b1 e1. + intros W regs a w r1 r2. iIntros "HStoreRes Ha". - iDestruct "HStoreRes" as "(% & HStoreRes)". - + iDestruct "HStoreRes" as (p1 g1 b1 e1 a1 storev) "(% & % & HStoreRes)". case_decide as Hallows. - - iMod "HStoreRes" as (w0) "[Ha0 HStoreRest]". - iExists _. - iSplitL "HStoreRest". - * iFrame "%". - case_decide; last by exfalso. + - case_decide as Haeq. + ++ pose(Hallows' := Hallows). destruct Hallows as (Hrinr & Hra & Hwb & HLoc). + iDestruct "HStoreRes" as (w0) "[HStoreCh HStoreRest]". + iExists _. + iSplitL "HStoreRest". + + iExists p1,g1,b1,e1,a1,storev. iFrame "%". + case_decide; last by exfalso. case_decide; last by exfalso. iExists w0. iSplitR; auto. - * iModIntro. iNext. - destruct Hallows as ((Hrinr & Hra & Hwb) & Hne). + + iNext. iApply memMap_resource_2ne; auto; iFrame. + ++ iExists _. + iSplitL "HStoreRes". + + iExists p1,g1,b1,e1,a1,storev. iFrame "%". + case_decide; last by exfalso. case_decide; first by exfalso. + iFrame. auto. + + iNext. by iApply memMap_resource_1. - iExists _. - iSplitR "Ha". - + iFrame "%". - case_decide; first by exfalso. auto. - + iModIntro. iNext. by iApply memMap_resource_1. + iSplitL "HStoreRes". + + iExists p1,g1,b1,e1,a1,storev. iFrame "%". + case_decide; first by exfalso. iFrame. auto. + + iNext. by iApply memMap_resource_1. Qed. - Lemma mem_map_implies_pure_conds: - ∀ (r : leibnizO Reg) - (a a0 : Addr) (w : Word) (r1 : RegName) - (mem0 : gmap Addr Word) p b e, - allow_store_mem r1 r a w mem0 p b e a0 - -∗ ⌜mem0 !! a = Some w⌝ - ∗ ⌜allow_store_map_or_true r1 r mem0⌝. + ∀ (W : WORLD) (regs : leibnizO Reg) + (p : Perm) (g : Locality) (b e a : Addr) + (w : Word) (r1 : RegName) (r2 : Z + RegName) + (mem0 : Mem), + allow_store_mem W r1 r2 regs a w mem0 + -∗ ⌜mem0 !! a = Some w⌝ + ∗ ⌜allow_store_map_or_true r1 r2 regs mem0⌝. Proof. - iIntros (r a a0 w r1 mem0 p b e) "HStoreMem". - iDestruct "HStoreMem" as "(% & HStoreRes)". + iIntros (W regs p g b e a w r1 r2 mem0) "HStoreMem". + iDestruct "HStoreMem" as (p1 g1 b1 e1 a1 storev) "(% & % & HStoreRes)". case_decide as Hallows. - - pose(Hallows' := Hallows). - destruct Hallows' as ((Hrinr & Hra & Hwb) & Hne). - iDestruct "HStoreRes" as (w0 ->) "HStoreRest". - iSplitR. rewrite lookup_insert_ne; auto. by rewrite lookup_insert. - iExists p,b,e,a0. iSplit;auto. - iPureIntro. case_decide;auto. - exists w0. by simplify_map_eq. - - iDestruct "HStoreRes" as "->". + - case_decide as Haeq. + + pose(Hallows' := Hallows). destruct Hallows' as (Hrinr & Hra & Hwb & HLoc). + (* case_decide as Haeq. *) + iDestruct "HStoreRes" as (w0) "[% _]". + iSplitR. subst. rewrite lookup_insert_ne; auto. by rewrite lookup_insert. + iExists p1,g1,b1,e1,a1,storev. + iPureIntro. repeat split; auto. + case_decide; last by exfalso. + exists w0. by simplify_map_eq. + + subst a. iDestruct "HStoreRes" as "[-> HStoreRes]". + iSplitR. by rewrite lookup_insert. + iExists p1,g1,b1,e1,a1,storev. repeat iSplitR; auto. + case_decide as Hdec1; last by done. + iExists w. by rewrite lookup_insert. + - iDestruct "HStoreRes" as "[-> HStoreRes ]". iSplitR. by rewrite lookup_insert. - iExists p,b,e,a0. repeat iSplitR; auto. - case_decide as Hdec1; last by done. - apply not_and_l in Hallows as [Hallows | Hallows]; try contradiction. - assert (a0 = a) as ->. - { apply finz_to_z_eq, Z.eq_dne. intros Hcontr. apply Hallows. by intros ->. } - simplify_map_eq. eauto. + iExists p1,g1,b1,e1,a1,storev. repeat iSplitR; auto. + case_decide as Hdec1; last by done. by exfalso. Qed. - Lemma mem_map_recover_res: - ∀ (r : leibnizO Reg) - (a : Addr) (w : Word) (src : RegName) p0 - (b0 e0 a0 : Addr) (mem0 : gmap Addr Word) storev loadv, - reg_allows_store r src p0 b0 e0 a0 - → mem0 !! a0 = Some loadv - → allow_store_mem src r a w mem0 p0 b0 e0 a0 - -∗ ([∗ map] a1↦w ∈ (<[a0:=storev]> mem0), a1 ↦ₐ w) - -∗ interp storev - ={if decide (reg_allows_store r src p0 b0 e0 a0 ∧ a0 ≠ a) then ⊤ ∖ ↑logN.@a ∖ ↑logN.@a0 else ⊤ ∖ ↑logN.@a,⊤ ∖ ↑logN.@a}=∗ - if decide (reg_allows_store r src p0 b0 e0 a0 ∧ a0 = a) then a ↦ₐ storev else a ↦ₐ w. + (* TODO move in monotone.v *) + Lemma interp_monotone_generalSd (W : WORLD) (ρ : region_type) + (p0 : Perm) (l : Locality) (a2 a1 a0 : Addr) + (ot : OType) (sb : Sealable) : + std W !! a0 = Some ρ → + withinBounds a2 a1 a0 = true → + ((fixpoint interp1) W) (WCap p0 l a2 a1 a0) -∗ + monotonicity_guarantees_region ρ a0 (WSealed ot sb) (λne Wv : WORLD * (leibnizO Word), (interp Wv.1) Wv.2). Proof. - intros r a w src p0 b0 e0 a0 mem0 storev loadv Hrar Hloadv. - iIntros "HLoadMem Hmem Hvalid". - iDestruct "HLoadMem" as "[% HLoadRes]". - (* destruct (load_inr_eq Hrar H0) as (<- & <- &<- &<- &<-). *) - case_decide as Hdec. destruct Hdec as [Hallows Heq]. - - destruct Hallows as [Hrinr [Hra Hwb] ]. - iDestruct "HLoadRes" as (w0) "[-> [Hval Hcls] ]". - simplify_map_eq. rewrite insert_insert. - rewrite memMap_resource_2ne; last auto. iDestruct "Hmem" as "[Ha1 Haw]". - iMod ("Hcls" with "[Ha1 Hvalid]") as "_";[iNext;iExists storev;iFrame|]. iModIntro. - rewrite decide_False; [done|]. apply not_and_r. right. auto. - - apply not_and_r in Hdec as [| <-%dec_stable]. - * by exfalso. - * iDestruct "HLoadRes" as "->". - rewrite insert_insert. - rewrite -memMap_resource_1. simplify_map_eq. by iFrame. + unfold monotonicity_guarantees_region. + iIntros (Hstd Hwb) "#Hvdst". + destruct ρ;auto. + - iModIntro; simpl. + all: iIntros (W0 W1) "% HIW0". + all: rewrite !fixpoint_interp1_eq;done. + - iModIntro; simpl. + all: iIntros (W0 W1) "% HIW0". + all: rewrite !fixpoint_interp1_eq;done. Qed. - Lemma store_case (r : leibnizO Reg) (p : Perm) (b e a : Addr) (w : Word) (dst : RegName) (src : Z + RegName) P : - ftlr_instr r p b e a w (Store dst src) P. + Lemma interp_monotone_generalSr (W : WORLD) (ρ : region_type) + (p0 : Perm) (l : Locality) (a2 a1 a0 : Addr) + (p : SealPerms) (g : Locality) (b e a : OType) : + std W !! a0 = Some ρ → + withinBounds a2 a1 a0 = true → + ((fixpoint interp1) W) (WCap p0 l a2 a1 a0) -∗ + monotonicity_guarantees_region ρ a0 (WSealRange p g b e a) (λne Wv : WORLD * (leibnizO Word), (interp Wv.1) Wv.2). Proof. - intros Hp Hsome i Hbae Hi. - iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap". - rewrite delete_insert_delete. - iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; - [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. + unfold monotonicity_guarantees_region. + iIntros (Hstd Hwb) "#Hvdst". + destruct ρ;auto. + - iModIntro; simpl. + all: iIntros (W0 W1) "% HIW0". + all: rewrite !fixpoint_interp1_eq;done. + - iModIntro; simpl. + all: iIntros (W0 W1) "% HIW0". + all: rewrite !fixpoint_interp1_eq;done. + Qed. + + Lemma storev_interp_mono W (r : Reg) (r1 : RegName) (r2 : Z + RegName) p g b e a ρ storev: + word_of_argument r r2 = Some storev + → reg_allows_store r r1 p g b e a storev + → std W !! a = Some ρ + → ((fixpoint interp1) W) (WCap p g b e a) + -∗ monotonicity_guarantees_region ρ a storev interpC. + Proof. + iIntros (Hwoa Hras Hststd) "HInt". + destruct Hras as (Hrir & Hwa & Hwb & Hloc). + destruct storev as [z | sb | ot sb ]. + - iApply (interp_monotone_generalZ with "[HInt]" ); eauto. + - destruct sb ; + [ iApply (interp_monotone_generalW with "[HInt]" ) + | iApply (interp_monotone_generalSr with "[HInt]" )] + ; eauto. + - iApply (interp_monotone_generalSd with "[HInt]" ); eauto. + Qed. + + Definition wcond' (P : D) p g b e a r : iProp Σ := (if decide (writeAllowed_in_r_a (<[PC:= WCap p g b e a]> r) a) then □ (∀ W0 (w : Word), interp W0 w -∗ P W0 w) else emp)%I. + Instance wcond'_pers P p g b e a r: Persistent (wcond' P p g b e a r). + Proof. intros. rewrite /wcond'. case_decide;apply _. Qed. + + (* Note that we turn in all information that we might have on the monotonicity of the current PC value, so that in the proof of the ftlr case itself, we do not have to worry about whether the PC was written to or not when we close the last location pc_a in the region *) + Lemma mem_map_recover_res: + ∀ (W : WORLD) (regs : Reg) + (pc_w : Word) (r1 : RegName) (r2 : Z + RegName) (p0 pc_p : Perm) + (g0 pc_g : Locality) (b0 e0 a0 pc_b pc_e pc_a : Addr) + (mem0 : Mem) (oldv storev : Word) (ρ : region_type) (P:D), + word_of_argument (<[PC:= WCap pc_p pc_g pc_b pc_e pc_a]> regs) r2 = Some storev + → reg_allows_store (<[PC:= WCap pc_p pc_g pc_b pc_e pc_a]> regs) r1 p0 g0 b0 e0 a0 storev + → std W !! pc_a = Some ρ + → mem0 !! a0 = Some oldv (*?*) + → allow_store_mem W r1 r2 (<[PC:=WCap pc_p pc_g pc_b pc_e pc_a]> regs) pc_a pc_w mem0 + -∗ (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜regs !! r1 = Some v⌝ → ((fixpoint interp1) W) v) + -∗ ((fixpoint interp1) W) (WCap pc_p pc_g pc_b pc_e pc_a) + -∗ P W pc_w + -∗ □ (∀ W0 (w : Word), P W0 w -∗ interp W0 w) + -∗ wcond' P pc_p pc_g pc_b pc_e pc_a regs + -∗ monotonicity_guarantees_region ρ pc_a pc_w (λ Wv : WORLD * Word, P Wv.1 Wv.2) + -∗ ([∗ map] a0↦w0 ∈ <[a0 := storev]> mem0, a0 ↦ₐ w0) + -∗ ∃ v, open_region pc_a W ∗ pc_a ↦ₐ v ∗ P W v ∗ monotonicity_guarantees_region ρ pc_a v (λ Wv : WORLD * Word, P Wv.1 Wv.2). + Proof. + intros W regs pc_w r1 r2 p0 pc_p g0 pc_g b0 e0 a0 pc_b pc_e pc_a mem0 oldv storev ρ P Hwoa Hras Hstdst Ha0. + iIntros "HStoreMem #Hreg #HVPCr Hpc_w #Hrcond #Hwcond Hpcmono Hmem". + iDestruct "HStoreMem" as (p1 g1 b1 e1 a1 storev1) "[% [% HStoreRes] ]". + destruct (store_inr_eq Hras H) as (<- & <- &<- &<- &<-). + inversion H0; simplify_eq. + case_decide as Hallows. + - iAssert (((fixpoint interp1) W) (WCap p0 g0 b0 e0 a0))%I with "[HVPCr Hreg]" as "#HVr1". + { destruct Hras as [Hreg _]. destruct (decide (r1 = PC)). + - subst r1. rewrite lookup_insert in Hreg; by inversion Hreg. + - simplify_map_eq. + by iSpecialize ("Hreg" $! r1 _ n Hreg). + } + iAssert (((fixpoint interp1) W) storev)%I with "[HVPCr Hreg]" as "#HVstorev1". + { destruct storev. + - repeat rewrite fixpoint_interp1_eq. by cbn. + - destruct r2. cbn in Hwoa; inversion Hwoa; by exfalso. + cbn in Hwoa. + destruct (decide (r = PC)). + + subst r. simplify_map_eq. done. + + simplify_map_eq. + iSpecialize ("Hreg" $! r _ n Hwoa). + done. + - destruct r2. cbn in Hwoa; inversion Hwoa; by exfalso. + cbn in Hwoa. + destruct (decide (r = PC)). + + subst r. simplify_map_eq. + + simplify_map_eq. + iSpecialize ("Hreg" $! r _ n Hwoa). + done. + } + case_decide as Haeq. + + iExists pc_w. + destruct Hallows as [Hrinr [Hwa [Hwb Hloc] ] ]. + iDestruct "HStoreRes" as (w') "[-> HLoadRes]". + rewrite lookup_insert in Ha0; inversion Ha0; clear Ha0; subst. + iDestruct "HLoadRes" as (ρ1) "(Hstate' & % & % & % & Hr & Hrel')". + rewrite insert_insert memMap_resource_2ne; last auto. iDestruct "Hmem" as "[Ha1 $]". + iDestruct (storev_interp_mono with "HVr1") as "Hr1Mono"; eauto. + iDestruct (region_close_next with "[$Hr $Ha1 $Hrel' $Hstate' $HVstorev1 $Hr1Mono]") as "Hr"; eauto. + { intros [g Hcontr]. specialize (H2 g). done. } + { apply not_elem_of_cons; split; [auto|apply not_elem_of_nil]. } + iDestruct (region_open_prepare with "Hr") as "$". iFrame. + + subst a0. iDestruct "HStoreRes" as "[-> HStoreRes]". + rewrite insert_insert -memMap_resource_1. + rewrite lookup_insert in Ha0; inversion Ha0; simplify_eq. + iExists storev. iFrame. rewrite /wcond'. + rewrite decide_True. + iSplitR;[iApply "Hwcond";iFrame "#"|]. + iDestruct (storev_interp_mono with "HVr1") as "Hr1Mono"; eauto. + rewrite /monotonicity_guarantees_region. + destruct ρ;auto. + { iModIntro. iIntros (W1 W2 Hrelated) "H". iApply "Hwcond". iApply "Hr1Mono". eauto. iApply "Hrcond". iFrame. } + { iModIntro. iIntros (W1 W2 Hrelated) "H". iApply "Hwcond". iApply "Hr1Mono". eauto. iApply "Hrcond". iFrame. } + rewrite /writeAllowed_in_r_a. eexists r1, _. inversion Hras. + split. eassumption. + destruct H1. destruct H2. + split;auto. + split;auto. + apply withinBounds_le_addr in H2; auto. + - by exfalso. + Qed. + + Lemma if_later {C} {eqdec: Decision C} (P:D) interp (Q Q' : iProp Σ) : (if (decide C) then ▷ Q else Q') -∗ ▷ (if (decide C) then Q else Q'). + Proof. iIntros "H". destruct (decide C);auto. Qed. + + Lemma store_case (W : WORLD) (regs : leibnizO Reg) + (p : Perm) (g : Locality) (b e a : Addr) (w : Word) + (ρ : region_type) (dst : RegName) (src : Z + RegName) (P : D) : + ftlr_instr W regs p g b e a w (Store dst src) ρ P. + Proof. + intros Hp Hsome i Hbae Hpers Hpwl Hregion Hnotrevoked Hnotmonostatic Hi. + iIntros "#IH #Hinv #Hreg #Hinva #[Hrcond Hrcondints] #Hwcond Hmono Hw Hsts Hown". + iIntros "Hr Hstate Ha HPC Hmap". + rewrite delete_insert_delete. + iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; + [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. (* To read out PC's name later, and needed when calling wp_load *) - assert(∀ x : RegName, is_Some (<[PC:=WCap p b e a]> r !! x)) as Hsome'. + assert(∀ x : RegName, is_Some (<[PC:=WCap p g b e a]> regs !! x)) as Hsome'. { intros. destruct (decide (x = PC)). rewrite e0 lookup_insert; unfold is_Some. by eexists. @@ -187,101 +350,73 @@ Section fundamental. } (* Initializing the names for the values of Hsrc now, to instantiate the existentials in step 1 *) - assert (∃ p0 b0 e0 a0 , read_reg_inr (<[PC:=WCap p b e a]> r) dst p0 b0 e0 a0) as [p0 [b0 [e0 [a0 HVdst] ] ] ]. + assert (∃ p0 g0 b0 e0 a0 , read_reg_inr (<[PC:=WCap p g b e a]> regs) dst p0 g0 b0 e0 a0) + as [ p0 [g0 [b0 [e0 [a0 HVdst] ] ] ] ]. { specialize Hsome' with dst as Hdst. destruct Hdst as [wdst Hsomedst]. unfold read_reg_inr. rewrite Hsomedst. - destruct wdst as [|[ p0 b0 e0 a0|] | ]; try done. + destruct wdst as [|[ p0 g0 b0 e0 a0|] | ]; try done. by repeat eexists. } - assert (∃ storev, word_of_argument (<[PC:=WCap p b e a]> r) src = Some storev) as [storev Hwoa]. + assert (∃ storev, word_of_argument (<[PC:= WCap p g b e a]> regs) src = Some storev) + as [storev Hwoa]. { destruct src; cbn. - by exists (WInt z). - - specialize Hsome' with r0 as Hr0. - destruct Hr0 as [wsrc Hsomer0]. - exists wsrc. by rewrite Hsomer0. + - specialize Hsome' with r as Hr. + destruct Hr as [wsrc Hsomer]. + exists wsrc. by rewrite Hsomer. } - (* Step 1: open the region, if necessary, and store all the resources obtained from the region in allow_load_res *) - iDestruct (create_store_res with "Hreg") as "HStoreRes"; eauto. - + (* Step 1: open the region, if necessary, + and store all the resources obtained from the region in allow_load_res *) + iDestruct (create_store_res with "Hreg Hinva Hr Hsts") as "[HStoreRes Hsts]"; eauto. + (* Clear helper values; they exist in the existential now *) + clear HVdst p0 g0 b0 e0 a0 Hwoa storev. - (* Step2: derive the concrete map of memory we need, and any spatial predicates holding over it *) - iMod (store_res_implies_mem_map with "HStoreRes Ha") as (mem) "[HStoreMem >HMemRes]". + (* Step2: derive the concrete map of memory we need, + and any spatial predicates holding over it *) + iDestruct (store_res_implies_mem_map W with "HStoreRes Ha") as (mem) "[HStoreMem HMemRes]". (* Step 3: derive the non-spatial conditions over the memory map*) iDestruct (mem_map_implies_pure_conds with "HStoreMem") as %(HReadPC & HStoreAP); auto. iApply (wp_store with "[Hmap HMemRes]"); eauto. { by rewrite lookup_insert. } - { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _. + { rewrite /subseteq /map_subseteq. intros rr _. apply elem_of_dom. rewrite lookup_insert_is_Some'; eauto. } { iSplitR "Hmap"; auto. } + rewrite /wcond. + iDestruct (if_later with "Hwcond") as "Hwcond'";auto. iNext. iIntros (regs' mem' retv). iDestruct 1 as (HSpec) "[Hmem Hmap]". - destruct HSpec as [* ? ? ? -> Hincr|* -> Hincr]. + destruct HSpec as [* ? ? ? -> Hincr|]. { apply incrementPC_Some_inv in Hincr. - destruct Hincr as (?&?&?&?&?&?&?&?). - iApply wp_pure_step_later; auto. - specialize (store_inr_eq H0 HVdst) as (-> & -> & -> & ->). - - (* The stored value is valid *) - iAssert (interp storev0) as "#Hvalidstore". - { destruct src; inversion H. rewrite !fixpoint_interp1_eq. done. - simplify_map_eq. destruct (<[PC:=WCap x x0 x1 x2]> r !! r0) eqn:Hsomer0;simplify_map_eq. - 2 : { rewrite Hsomer0 in Hwoa. done. } - destruct (decide (r0 = PC)). - - subst. simplify_map_eq. iFrame "Hinv". - - simplify_map_eq. iSpecialize ("Hreg" $! _ _ n Hsomer0). - iFrame "Hreg". - } + destruct Hincr as (?&?&?&?&?&?&?&?&?). + iApply wp_pure_step_later; auto. iNext; iIntros "_". - (* Step 4: return all the resources we had in order to close the second location in the region, in the cases where we need to *) - iMod (mem_map_recover_res with "HStoreMem Hmem Hvalidstore") as "Ha";[eauto|eauto|iModIntro]. - - iMod ("Hcls" with "[HP Ha]"). - { simplify_map_eq. - case_decide as Hwrite. - - case_decide. - + iNext. iExists storev. - iDestruct ("Hwrite" with "Hvalidstore") as "HPstore". - iFrame "∗ #". - + iNext. iExists w. iFrame. - - rewrite decide_False. iNext. iExists w. iFrame. - intros [Hcontr ->]. - apply Hwrite. exists dst. - destruct Hcontr as (Hlookup & Hwa & Hwb). simplify_map_eq. - apply andb_prop in Hwb. - revert Hwb. rewrite Z.leb_le Z.ltb_lt. intros. eexists _. - split_and!; done. - } + (* From this, derive value relation for the current PC*) + iDestruct (execcPC_implies_interp _ _ _ _ _ a with "Hinv") as "HVPC"; eauto. + + iDestruct (switch_monotonicity_formulation with "Hmono") as "Hmono"; [eauto..|]. + + (* assert that the PC *) + (* Step 4: return all the resources we had in order to close the second location + in the region, in the cases where we need to *) + iDestruct (mem_map_recover_res with "HStoreMem Hreg HVPC Hw Hrcond [Hwcond] Hmono Hmem") as (w') "(Hr & Ha & HSVInterp & Hmono)";eauto. + + iDestruct (switch_monotonicity_formulation with "Hmono") as "Hmono"; auto. + + iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono $HSVInterp]") as "Hr"; eauto. + { destruct ρ;auto;[|specialize (Hnotmonostatic g1)];contradiction. } simplify_map_eq. - rewrite insert_insert. - iModIntro; iNext; iIntros "_". - iApply ("IH" with "[%] [] Hmap [$Hown]");auto. - { rewrite !fixpoint_interp1_eq /=. destruct Hp as [-> | ->]; by iFrame "#". } - } - { rewrite /allow_store_res /allow_store_mem. - destruct (decide (reg_allows_store (<[PC:=WCap p b e a]> r) dst p0 b0 e0 a0 ∧ a0 ≠ a)). - - iDestruct "HStoreMem" as "(%&H)". - iDestruct "H" as (w') "(->&[Hres Hcls'])". rewrite /region_open_resources. - destruct a1. simplify_map_eq. rewrite memMap_resource_2ne; last auto. - iDestruct "Hmem" as "[Ha0 Ha]". - iMod ("Hcls'" with "[Ha0 Hres]");[iExists w';iFrame|iModIntro]. - iMod ("Hcls" with "[Ha HP]");[iExists w;iFrame|iModIntro]. - iApply wp_pure_step_later; auto. - iNext; iIntros "_". - iApply wp_value; auto. iIntros; discriminate. - - iModIntro. iDestruct "HStoreMem" as "(_&->)". rewrite -memMap_resource_1. - iMod ("Hcls" with "[Hmem HP]");[iExists w;iFrame|iModIntro]. - iApply wp_pure_step_later; auto. - iNext ; iIntros "_". - iApply wp_value; auto. iIntros; discriminate. + iApply ("IH" with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]"); auto. + { rewrite insert_insert. iApply "Hmap". } } + { iApply wp_pure_step_later; auto. iNext; iIntros "_". iApply wp_value; auto. iIntros; discriminate. } Unshelve. all: auto. Qed. diff --git a/theories/ftlr/UnSeal.v b/theories/ftlr/UnSeal.v index 5a12df70..fa7f351c 100644 --- a/theories/ftlr/UnSeal.v +++ b/theories/ftlr/UnSeal.v @@ -4,47 +4,58 @@ From iris.program_logic Require Import weakestpre adequacy lifting. From stdpp Require Import base. From cap_machine.ftlr Require Import ftlr_base interp_weakening. From cap_machine.rules Require Import rules_base rules_UnSeal. +From cap_machine.proofmode Require Import map_simpl. Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). (* Proving the meaning of unsealing in the LR sane. Note the use of the later in the result. *) - Lemma unsealing_preserves_interp sb p0 b0 e0 a0: + Lemma unsealing_preserves_interp W sb p0 g0 b0 e0 a0: permit_unseal p0 = true → withinBounds b0 e0 a0 = true → - fixpoint interp1 (WSealed a0 sb) -∗ - fixpoint interp1 (WSealRange p0 b0 e0 a0) -∗ - ▷ fixpoint interp1 (WSealable sb). + fixpoint interp1 W (WSealed a0 sb) -∗ + fixpoint interp1 W (WSealRange p0 g0 b0 e0 a0) -∗ + ▷ fixpoint interp1 W (WSealable sb). Proof. iIntros (Hpseal Hwb) "#HVsd #HVsr". - rewrite (fixpoint_interp1_eq (WSealRange _ _ _ _)) (fixpoint_interp1_eq (WSealed _ _)) /= Hpseal /interp_sb. + rewrite + (fixpoint_interp1_eq W (WSealRange _ _ _ _ _)) + (fixpoint_interp1_eq W (WSealed _ _)) /= Hpseal /interp_sb. iDestruct "HVsr" as "[_ Hss]". apply seq_between_dist_Some in Hwb. iDestruct (big_sepL_delete with "Hss") as "[HSa0 _]"; eauto. - iDestruct "HSa0" as (P) "[HsealP HWcond]". + iDestruct "HSa0" as (P) "[HsealP [ HWcond _ ]]". iDestruct "HVsd" as (P') "[% [HsealP' HP']]". - iDestruct (seal_pred_agree with "HsealP HsealP'") as "Hequiv". iSpecialize ("Hequiv" $! (WSealable sb)). - iAssert (▷ P (WSealable sb))%I as "HP". { iNext. by iRewrite "Hequiv". } + iDestruct (seal_pred_agree with "HsealP HsealP'") as "Hequiv". + Unshelve. 2: exact W. + iSpecialize ("Hequiv" $! (WSealable sb)). + iAssert (▷ P W (WSealable sb))%I as "HP". { iNext; by iRewrite "Hequiv". } by iApply "HWcond". Qed. - Lemma unseal_case (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (w : Word) (dst r1 r2 : RegName) (P:D): - ftlr_instr r p b e a w (UnSeal dst r1 r2) P. + Lemma unseal_case (W : WORLD) (regs : leibnizO Reg) (p : Perm) + (g : Locality) (b e a : Addr) (w : Word) (ρ : region_type) (dst r1 r2 : RegName) (P:D): + ftlr_instr W regs p g b e a w (UnSeal dst r1 r2) ρ P. Proof. - intros Hp Hsome i Hbae Hi. - iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap". + intros Hp Hsome i Hbae Hpers Hpwl Hregion Hnotrevoked Hnotmonostatic Hi. + iIntros "#IH #Hinv #Hreg #Hinva #Hrcond #Hwcond Hmono Hw Hsts Hown". + iIntros "Hr Hstate Ha HPC Hmap". rewrite delete_insert_delete. iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /="; [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl. @@ -54,64 +65,103 @@ Section fundamental. apply elem_of_dom. apply lookup_insert_is_Some'; eauto. } iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]". - destruct HSpec as [ * Hr1 Hr2 Hunseal Hwb HincrPC | ]. - { apply incrementPC_Some_inv in HincrPC as (p''&b''&e''&a''& ? & HPC & Z & Hregs') . + destruct HSpec as [ * Hr1 Hr2 Hunseal Hwb HincrPC | ]; cycle 1. + { + iApply wp_pure_step_later; auto. iNext; iIntros "_". + iApply wp_value; auto. iIntros; discriminate. + } + + apply incrementPC_Some_inv in HincrPC as (p''&g''&b''&e''&a''& ? & HPC & Z & Hregs') . + + assert (r1 ≠ PC) as Hne1. + { destruct (decide (PC = r1)); last auto. simplify_map_eq; auto. } + rewrite lookup_insert_ne in Hr1; auto. + assert (r2 ≠ PC) as Hne2. + { destruct (decide (PC = r2)); last auto. simplify_map_eq; auto. } + rewrite lookup_insert_ne in Hr2; auto. - assert (r1 ≠ PC) as Hne1. - { destruct (decide (PC = r1)); last auto. simplify_map_eq; auto. } - rewrite lookup_insert_ne in Hr1; auto. - assert (r2 ≠ PC) as Hne2. - { destruct (decide (PC = r2)); last auto. simplify_map_eq; auto. } - rewrite lookup_insert_ne in Hr2; auto. + unshelve iDestruct ("Hreg" $! r1 _ _ Hr1) as "HVsr"; eauto. + unshelve iDestruct ("Hreg" $! r2 _ _ Hr2) as "HVsd"; eauto. + (* Generate interp instance before step, so we get rid of the later *) + iDestruct (unsealing_preserves_interp with "HVsd HVsr") as "HVsb"; auto. - unshelve iDestruct ("Hreg" $! r1 _ _ Hr1) as "HVsr"; eauto. - unshelve iDestruct ("Hreg" $! r2 _ _ Hr2) as "HVsd"; eauto. - (* Generate interp instance before step, so we get rid of the later *) - iDestruct (unsealing_preserves_interp with "HVsd HVsr") as "HVsb"; auto. + iApply wp_pure_step_later; auto; iNext; iIntros "_". + (* assert (dst <> PC) as HdstPC by (intros ->; simplify_map_eq). *) + (* simplify_map_eq. *) + iDestruct (region_close with "[$Hstate $Hr $Ha $Hmono Hw]") as "Hr"; eauto. + { destruct ρ;auto;[|ospecialize (Hnotmonostatic _)];contradiction. } + (* If PC=dst and perm of unsealed cap = E -> error! *) + destruct (decide (PC = dst ∧ p'' = E)) as [ [Herr1 Herr2] | HNoError]. + { (* Error case *) + simplify_map_eq. + iDestruct ((big_sepM_delete _ _ PC) with "Hmap") as "[HPC Hmap]". + { subst. by rewrite lookup_insert. } + iApply (wp_bind (fill [SeqCtx])). + iApply (wp_notCorrectPC_perm with "[HPC]"); eauto. split; auto. + iIntros "!> _". iApply wp_pure_step_later; auto. - iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. iNext; iIntros "_". + iApply wp_value. + iIntros (a1); inversion a1. + } + + destruct (decide (PC = dst)) as [Heq | Hne]; cycle 1. + { (* PC ≠ dst *) + simplify_map_eq. + map_simpl "Hmap". + iApply ("IH" $! _ (<[PC:=WCap p'' g'' b'' e'' x]> (<[dst:=WSealable sb]> regs)) + with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]") + ; try (iClear "IH") ; eauto. + { cbn. intros. + by repeat (rewrite lookup_insert_is_Some'; right). + } + { iIntros (ri v Hri Hvs). + rewrite lookup_insert_ne in Hvs; auto. + destruct (decide (ri = dst)). + { subst ri. + rewrite lookup_insert in Hvs; inversion Hvs. auto. } + { repeat (rewrite lookup_insert_ne in Hvs); auto. + iApply "Hreg"; auto. } + } + { rewrite insert_insert. iApply "Hmap". } + } + { (* PC = dst *) + simplify_map_eq; map_simpl "Hmap". + destruct (decide (p'' = RX ∨ p'' = RWX ∨ p'' = RWLX ∧ g'' = Local)) as [Hpft|Hpft]. + - iApply ("IH" $! _ (<[PC:=WCap p'' g'' b'' e'' x]> regs) + with "[%] [] [Hmap] [$Hr] [$Hsts] [$Hown]") + ; try (iClear "IH") ; eauto. + { cbn. intros. + by repeat (rewrite lookup_insert_is_Some'; right). + } + { iIntros (ri v Hri Hvs). + rewrite lookup_insert_ne in Hvs; auto. + iApply "Hreg"; auto. } + { rewrite insert_insert. iApply "Hmap". } + { iApply (readAllowed_implies_region_conditions with "HVsb"). + rewrite /readAllowed. + destruct p'' ; repeat (destruct Hpft as [?|Hpft]) ; try congruence. + all: destruct Hpft; congruence. + } + - (* not eq RX/RWX/RWLX-Local *) + destruct (decide (p'' = RX)); simplify_eq. + { destruct (Hpft); by left. } + destruct (decide (p'' = RWX)); simplify_eq. + { destruct (Hpft); by right; left. } + destruct (decide (p'' = RWLX )); simplify_eq. + destruct g'' ; simplify_eq; cycle 1. + { destruct (Hpft); by right; right. } + { iEval (rewrite fixpoint_interp1_eq //=) in "HVsb"; done. } - (* If PC=dst and perm of unsealed cap = E -> error! *) - destruct (decide (PC = dst ∧ p'' = E)) as [ [Herr1 Herr2] | HNoError]. - { (* Error case *) - simplify_map_eq. - iDestruct ((big_sepM_delete _ _ PC) with "Hmap") as "[HPC Hmap]". - { subst. by rewrite lookup_insert. } iApply (wp_bind (fill [SeqCtx])). - iApply (wp_notCorrectPC_perm with "[HPC]"); eauto. split; auto. - iIntros "!> _". - iApply wp_pure_step_later; auto. - iNext; iIntros "_". + iDestruct ((big_sepM_delete _ _ PC) with "Hmap") as "[HPC Hmap]"; [apply lookup_insert|]. + iApply (wp_notCorrectPC with "HPC") + ; [eapply not_isCorrectPC_perm; simpl in Hp; try discriminate; eauto|]. + iNext. iIntros "HPC /=". + iApply wp_pure_step_later; auto;iNext; iIntros "_". iApply wp_value. - iIntros (a1); inversion a1. - } - (* Otherwise, we will be able to derive validity of the PC below*) - - iApply ("IH" $! regs' with "[%] [] [Hmap] [$Hown]"). - { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). } - { iIntros (ri v Hri Hvs). - subst regs'. - rewrite lookup_insert_ne in Hvs; auto. - destruct (decide (ri = dst)). - { subst ri. - rewrite lookup_insert in Hvs; inversion Hvs. auto. } - { repeat (rewrite lookup_insert_ne in Hvs); auto. - iApply "Hreg"; auto. } } - { subst regs'. rewrite insert_insert. iApply "Hmap". } - iModIntro. - destruct (reg_eq_dec PC dst) as [Heq | Hne]; simplify_map_eq. - - iApply (interp_weakening with "IH HVsb"); auto; try solve_addr. (* HNoError used here *) - { by rewrite PermFlowsToReflexive. } - - iApply (interp_weakening with "IH Hinv"); auto; try solve_addr. - { destruct Hp; by subst p''. } - { by rewrite PermFlowsToReflexive. } - } - { iApply wp_pure_step_later; auto. - iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. - iNext ; iIntros "_". - iApply wp_value; auto. iIntros; discriminate. } + iIntros. discriminate. } Qed. End fundamental. diff --git a/theories/ftlr/ftlr_base.v b/theories/ftlr/ftlr_base.v index 4d0e2349..31c3685a 100644 --- a/theories/ftlr/ftlr_base.v +++ b/theories/ftlr/ftlr_base.v @@ -7,49 +7,75 @@ Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). + Definition ftlr_IH: iProp Σ := + (□ ▷ (∀ (W_ih : WORLD) (r_ih : leibnizO Reg) + (p_ih : Perm) (g_ih : Locality) (b_ih e_ih a_ih : Addr), + full_map r_ih + -∗ (∀ (r : RegName) v, ⌜r ≠ PC⌝ → ⌜r_ih !! r = Some v⌝ → fixpoint interp1 W_ih v) + -∗ registers_pointsto (<[PC:= WCap p_ih g_ih b_ih e_ih a_ih]> r_ih) + -∗ region W_ih + -∗ sts_full_world W_ih + -∗ na_own logrel_nais ⊤ + -∗ ⌜p_ih = RX ∨ p_ih = RWX ∨ p_ih = RWLX ∧ g_ih = Local⌝ + → □ region_conditions W_ih p_ih g_ih b_ih e_ih -∗ interp_conf W_ih))%I. - (* NOTE: I think having PC:= wsrc in the IH in below definition, rather than restricting induction to capabilities only, would allow us to more generally apply the induction hypothesis in multiple cases. Now we do the `wp_notCorrectPC`-related reasoning in multiple places, not just in the top-level ftlr. *) - Definition ftlr_instr (r : leibnizO Reg) (p : Perm) - (b e a : Addr) (w : Word) (i: instr) (P : D) := - p = RX ∨ p = RWX - → (∀ x : RegName, is_Some (r !! x)) - → isCorrectPC (WCap p b e a) + Definition ftlr_instr (W : WORLD) (regs : leibnizO Reg) + (p : Perm) (g : Locality) (b e a : Addr) + (w : Word) (i: instr) (ρ : region_type) (P : D) : Prop := + p = RX ∨ p = RWX ∨ (p = RWLX /\ g = Local) + → (∀ x : RegName, is_Some (regs !! x)) + → isCorrectPC (WCap p g b e a) → (b <= a)%a ∧ (a < e)%a + → (∀ Wv : WORLD * leibnizO Word, Persistent (P Wv.1 Wv.2)) + → (if pwl p then region_state_pwl W a else region_state_nwl W a g) + → std W !! a = Some ρ + → ρ ≠ Revoked + → (∀ g : Mem, ρ ≠ Monostatic g) → decodeInstrW w = i - -> □ ▷ (∀ a0 a1 a2 a3 a4, - full_map a0 - -∗ (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜a0 !! r1 = Some v⌝ → (fixpoint interp1) v) - -∗ registers_pointsto (<[PC:=WCap a1 a2 a3 a4]> a0) - -∗ na_own logrel_nais ⊤ - -∗ □ (fixpoint interp1) (WCap a1 a2 a3 a4) -∗ interp_conf) - -∗ (fixpoint interp1) (WCap p b e a) - -∗ inv (logN.@a) (∃ w0 : leibnizO Word, a ↦ₐ w0 ∗ P w0) - -∗ (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜r !! r1 = Some v⌝ → (fixpoint interp1) v) - -∗ ▷ □ (∀ w : Word, P w -∗ (fixpoint interp1) w) - ∗ (if decide (writeAllowed_in_r_a (<[PC:=WCap p b e a]> r) a) then ▷ □ (∀ w : Word, (fixpoint interp1) w -∗ P w) else emp) + -> ftlr_IH + -∗ region_conditions W p g b e + -∗ (∀ (r : RegName) v, ⌜r ≠ PC⌝ → ⌜regs !! r = Some v⌝ → fixpoint interp1 W v) + -∗ rel a (λ Wv, P Wv.1 Wv.2) + -∗ rcond P interp + -∗ □ (if decide (writeAllowed_in_r_a (<[PC:=(WCap p g b e a)]> regs) a) + then wcond P interp + else emp) + -∗ (▷ (if decide (ρ = Monotemporary) + then future_pub_a_mono a (λ Wv, P Wv.1 Wv.2) w + else future_priv_mono (λ Wv, P Wv.1 Wv.2) w)) + -∗ ▷ P W w + -∗ sts_full_world W -∗ na_own logrel_nais ⊤ + -∗ open_region a W + -∗ sts_state_std a ρ -∗ a ↦ₐ w - -∗ ▷ P w - -∗ (▷ (∃ w0 : leibnizO Word, a ↦ₐ w0 ∗ P w0) ={⊤ ∖ ↑logN.@a,⊤}=∗ emp) - -∗ PC ↦ᵣ WCap p b e a - -∗ ([∗ map] k↦y ∈ delete PC (<[PC:=WCap p b e a]> r), k ↦ᵣ y) - -∗ - WP Instr Executable - @ ⊤ ∖ ↑logN.@a {{ v, |={⊤ ∖ ↑logN.@a,⊤}=> WP Seq (of_val v) - {{ v0, ⌜v0 = HaltedV⌝ - → ∃ r1 : Reg, full_map r1 ∧ registers_pointsto r1 - ∗ na_own logrel_nais ⊤ }} }}. + -∗ PC ↦ᵣ (WCap p g b e a) + -∗ ([∗ map] k↦y ∈ delete PC (<[PC:=(WCap p g b e a)]> regs), k ↦ᵣ y) + -∗ WP Instr Executable + {{ v, WP Seq (cap_lang.of_val v) + {{ v0, ⌜v0 = HaltedV⌝ + → ∃ (regs' : Reg) (W' : WORLD), + full_map regs' ∧ registers_pointsto regs' + ∗ ⌜related_sts_priv_world W W'⌝ + ∗ na_own logrel_nais ⊤ + ∗ sts_full_world W' ∗ region W' }} }}. End fundamental. diff --git a/theories/ftlr/interp_weakening.v b/theories/ftlr/interp_weakening.v index 98773a83..e0bf090b 100644 --- a/theories/ftlr/interp_weakening.v +++ b/theories/ftlr/interp_weakening.v @@ -9,80 +9,524 @@ Section fundamental. Context {Σ : gFunctors} {ceriseg: ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {sealsg: sealStoreG Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). - Definition IH: iProp Σ := - (□ ▷ (∀ a0 a1 a2 a3 a4, - full_map a0 - -∗ (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜a0 !! r1 = Some v⌝ → (fixpoint interp1) v) - -∗ registers_pointsto (<[PC:=WCap a1 a2 a3 a4]> a0) - -∗ na_own logrel_nais ⊤ - -∗ □ (fixpoint interp1) (WCap a1 a2 a3 a4) -∗ interp_conf))%I. - Instance if_persistent (PROP: bi) (b: bool) (φ1 φ2: PROP) (H1: Persistent φ1) (H2: Persistent φ2): + (* TODO move somewhere *) + Global Instance if_persistent (PROP: bi) (b: bool) (φ1 φ2: PROP) (H1: Persistent φ1) (H2: Persistent φ2): Persistent (if b then φ1 else φ2). Proof. destruct b; auto. Qed. - Lemma interp_weakening p p' b b' e e' a a': + (* TODO FIX *) + Lemma interp_weakeningEO W p p' g g' b b' e e' a a' : + p <> E -> + p ≠ O → + p' ≠ E → + p' ≠ O → + (b <= b')%a -> + (e' <= e)%a -> + PermFlowsTo p' p -> + LocalityFlowsTo g' g -> + (fixpoint interp1) W (WCap p g b e a) -∗ + (fixpoint interp1) W (WCap p' g' b' e' a'). + Proof. + (* intros HpnotE HpnotO HpnotE' HpnotO' Hb He Hp Hl. iIntros "HA". *) + (* rewrite !fixpoint_interp1_eq !interp1_eq. *) + (* destruct (perm_eq_dec p O);try congruence. *) + (* destruct (perm_eq_dec p E);try congruence. *) + (* destruct (perm_eq_dec p' O);try congruence. *) + (* destruct (perm_eq_dec p' E);try congruence. *) + (* iDestruct "HA" as "[#A [% #C]]". *) + (* iSplit. *) + (* { destruct (isU p') eqn:HisU'. *) + (* { destruct (isU p) eqn:HisU. *) + (* - destruct l; destruct l'; simpl. *) + (* + destruct (Addr_le_dec b' e'). *) + (* { rewrite (isWithin_region_addrs_decomposition b' e' b e); try solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* case_eq (pwlU p'); intros. *) + (* + assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;auto;inversion HP. } *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';auto;inversion H2. } *) + (* iFrame "X". *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* + assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;auto;inversion HP. } *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';auto;inversion H2. } *) + (* iFrame "X". *) + (* iAssert (future_world Global e' W W) as "Hfut". *) + (* { iApply futureworld_refl. } *) + (* iApply (region_state_nwl_future W W Global Global); eauto. *) + (* assert (x ∈ region_addrs b' e') as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto;destruct l;inversion H0;auto. } *) + (* { rewrite (region_addrs_empty b' e'); auto. solve_addr. } *) + (* + destruct (Addr_le_dec b' (min a' e')). *) + (* { rewrite (isWithin_region_addrs_decomposition b' (min a' e') b e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';auto;inversion HisU'. } *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p';auto;inversion HisU';destruct p;inversion Hp;auto. } *) + (* repeat iSplit; auto. *) + (* case_eq (pwlU p'); intros. *) + (* * assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* * iApply (region_state_nwl_future W W Global Local _ _ (min a' e')); eauto. *) + (* assert (x ∈ region_addrs b' (min a' e')) as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);inversion H0;auto. *) + (* simpl. iPureIntro. eapply related_sts_priv_refl_world. } *) + (* { rewrite (region_addrs_empty b' (min a' e')); auto. solve_addr. } *) + (* + destruct (Addr_le_dec b' (min a' e')). *) + (* { rewrite (isWithin_region_addrs_decomposition b' (min a' e') b e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';auto;inversion HisU'. } *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p';auto;inversion HisU';destruct p;inversion Hp;auto. } *) + (* repeat iSplit; auto. *) + (* case_eq (pwlU p'); intros. *) + (* * assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* * iApply (region_state_nwl_future W W Global Directed _ _ (min a' e')); eauto. *) + (* assert (x ∈ region_addrs b' (min a' e')) as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);inversion H0;auto. *) + (* simpl. iPureIntro. eapply related_sts_a_refl_world. } *) + (* { rewrite (region_addrs_empty b' (min a' e')); auto. solve_addr. } *) + (* + inversion Hl. *) + (* + destruct (Addr_le_dec b' (min a' e')). *) + (* { rewrite (isWithin_region_addrs_decomposition b' (min a' e') b (min a e)). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;inversion HisU;auto. } *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';inversion HisU';auto. } *) + (* repeat iSplit; auto. *) + (* case_eq (pwlU p'); intros. *) + (* * assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* * iApply (region_state_nwl_future W W Local Local _ _ (min a' e')); eauto. *) + (* assert (x ∈ region_addrs b' (min a' e')) as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);inversion H0;auto. *) + (* iApply futureworld_refl. } *) + (* { rewrite (region_addrs_empty b' (min a' e')); auto. solve_addr. } *) + (* + destruct (Addr_le_dec b' (min a' e')). *) + (* { rewrite (isWithin_region_addrs_decomposition b' (min a' e') b (min a e)). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;inversion HisU;auto. } *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';inversion HisU';auto. } *) + (* repeat iSplit; auto. *) + (* case_eq (pwlU p'); intros. *) + (* * assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* * iApply (region_state_nwl_future W W Local Directed _ _ (min a' e')); eauto. *) + (* assert (x ∈ region_addrs b' (min a' e')) as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);inversion H0;auto. *) + (* iApply futureworld_refl. } *) + (* { rewrite (region_addrs_empty b' (min a' e')); auto. solve_addr. } *) + (* + inversion Hl. *) + (* + inversion Hl. *) + (* + destruct (Addr_le_dec b' (min a' e')). *) + (* { rewrite (isWithin_region_addrs_decomposition b' (min a' e') b (min a e)). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;inversion HisU;auto. } *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';inversion HisU';auto. } *) + (* repeat iSplit; auto. *) + (* case_eq (pwlU p'); intros. *) + (* * assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* * iApply (region_state_nwl_future W W Directed Directed _ _ (min a' e')); eauto. *) + (* assert (x ∈ region_addrs b' (min a' e')) as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);inversion H0;auto. *) + (* iApply futureworld_refl. } *) + (* { rewrite (region_addrs_empty b' (min a' e')); auto. solve_addr. } *) + (* - simpl. destruct l'; simpl. *) + (* { destruct (Addr_le_dec b' e'). *) + (* + rewrite (isWithin_region_addrs_decomposition b' e' b e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';inversion HisU';auto. } *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p';inversion HisU';destruct p;inversion Hp;auto. } *) + (* repeat iSplit; auto. *) + (* case_eq (pwlU p'); intros. *) + (* * assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* * iApply (region_state_nwl_future W W l Global _ _ e'); eauto. *) + (* assert (x ∈ region_addrs b' e') as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto. destruct l;auto;inversion H0. *) + (* iApply futureworld_refl. *) + (* + rewrite (region_addrs_empty b' e'); auto. solve_addr. } *) + (* { destruct (Addr_le_dec b' (min a' e')). *) + (* + rewrite (isWithin_region_addrs_decomposition b' (min a' e') b e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';inversion HisU';auto. } *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p';inversion HisU';destruct p;inversion Hp;auto. } *) + (* repeat iSplit; auto. *) + (* case_eq (pwlU p'); intros. *) + (* * assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* * iApply (region_state_nwl_future W W l Local _ _ (min a' e')); eauto. *) + (* assert (x ∈ region_addrs b' (min a' e')) as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto. destruct l;auto;inversion H0. *) + (* iApply futureworld_refl. *) + (* + rewrite (region_addrs_empty b' (min a' e')); auto. solve_addr. } *) + (* { destruct (Addr_le_dec b' (min a' e')). *) + (* + rewrite (isWithin_region_addrs_decomposition b' (min a' e') b e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p' || readAllowedU p' = true) as ->. *) + (* { destruct p';inversion HisU';auto. } *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p';inversion HisU';destruct p;inversion Hp;auto. } *) + (* repeat iSplit; auto. *) + (* case_eq (pwlU p'); intros. *) + (* * assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* * iApply (region_state_nwl_future W W l Directed _ _ (min a' e')); eauto. *) + (* assert (x ∈ region_addrs b' (min a' e')) as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto. destruct l;auto;inversion H0. *) + (* iApply futureworld_refl. *) + (* + rewrite (region_addrs_empty b' (min a' e')); auto. solve_addr. } *) + (* } *) + (* assert (HisU: isU p = false). *) + (* { destruct p', p; simpl in *; try tauto; try congruence. } *) + (* rewrite !HisU. simpl. *) + (* destruct (Addr_le_dec b' e'). *) + (* - rewrite (isWithin_region_addrs_decomposition b' e' b e); try solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (readAllowedU p = false) as ->. *) + (* { destruct p;auto;inversion HisU. } *) + (* assert (readAllowedU p' = false) as ->. *) + (* { destruct p';auto;inversion HisU'. } *) + (* rewrite !orb_false_r. *) + (* destruct (writeAllowed p') eqn:Hpw. *) + (* { assert (writeAllowed p = true) as ->. *) + (* { destruct p',p;inversion Hp;auto. } *) + (* iSplitR; auto. *) + (* case_eq (pwlU p'); intros. *) + (* + assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* + iApply (region_state_nwl_future _ _ _ _ _ x e'); eauto. *) + (* assert (x ∈ region_addrs b' e') as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto. destruct l;auto;inversion H0. *) + (* iApply futureworld_refl. } *) + (* { destruct (writeAllowed p). *) + (* - rewrite bi.and_exist_r. iExists interp. rewrite /read_cond. iFrame "X". *) + (* iSplit;[iSplit;[iPureIntro;apply _|iApply rcond_interp]|]. *) + (* case_eq (pwlU p'); intros. *) + (* + assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* + iApply (region_state_nwl_future _ _ _ _ _ x e'); eauto. *) + (* assert (x ∈ region_addrs b' e') as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto. destruct l;auto;inversion H0. *) + (* iApply futureworld_refl. *) + (* - rewrite bi.and_exist_r. iDestruct "X" as (P) "(?&?&?)". *) + (* iExists P. iFrame "#". *) + (* case_eq (pwlU p'); intros. *) + (* + assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H1. iPureIntro. auto. *) + (* + iApply (region_state_nwl_future _ _ _ _ _ x e'); eauto. *) + (* assert (x ∈ region_addrs b' e') as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto. destruct l;auto;inversion H0. *) + (* iApply futureworld_refl. } *) + (* - rewrite (region_addrs_empty b' e'); auto. solve_addr. } *) + (* iSplit. *) + (* { case_eq (pwlU p'); intros; auto. *) + (* assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H0. destruct l;inversion H0. destruct l'; simpl in Hl; try tauto. auto. } *) + (* { case_eq (pwlU p'); intros; auto. *) + (* - assert (pwlU p = true) as HP by (destruct p, p'; naive_solver). *) + (* rewrite HP in H0; destruct l;inversion H0. destruct l'; simpl in Hl; try tauto. *) + (* destruct (isU p') eqn:HisU'; auto. simpl. *) + (* destruct (isU p) eqn:HisU; simpl. *) + (* + destruct (Addr_le_dec (max b' a') e'). *) + (* * rewrite HP. destruct (Addr_lt_dec (max b' a') (max b a)). *) + (* { destruct (Addr_le_dec (max b a) e'). *) + (* - rewrite (isWithin_region_addrs_decomposition (max b a) e' (max b a) e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "C" as "[C1 [C2 C3]]". *) + (* rewrite (isWithin_region_addrs_decomposition (max b a) e' (max b' a') e'). 2: solve_addr. *) + (* rewrite !big_sepL_app. rewrite (region_addrs_empty e' e'); [simpl; iFrame "#"|solve_addr]. *) + (* assert (Heq: min a e = max b a) by solve_addr. rewrite Heq. *) + (* rewrite (isWithin_region_addrs_decomposition (max b' a') (max b a) b (max b a)). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". iFrame "#". *) + (* iApply (big_sepL_impl with "A2"); auto. *) + (* iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;inversion HP;auto. } iFrame "X". *) + (* iPureIntro. left; auto. *) + (* - rewrite (isWithin_region_addrs_decomposition (max b' a') e' b (min a e)). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. *) + (* iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;inversion HP;auto. } iFrame "X". *) + (* iPureIntro. left; auto. } *) + (* { rewrite (isWithin_region_addrs_decomposition (max b' a') e' (max b a) e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "C" as "[C1 [C2 C3]]". *) + (* iApply (big_sepL_impl with "C2"); auto. } *) + (* * rewrite (region_addrs_empty (max b' a') e'); auto. solve_addr. *) + (* + destruct (Addr_le_dec (max b' a') e'). *) + (* * rewrite HP. rewrite (isWithin_region_addrs_decomposition (max b' a') e' b e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. *) + (* iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;inversion HP;auto. } iFrame "X". *) + (* iPureIntro. left; auto. *) + (* * rewrite (region_addrs_empty (max b' a') e'); auto. solve_addr. *) + (* - destruct (isU p') eqn:HisU'; simpl; auto. *) + (* destruct (isLocal l') eqn:Hl'; auto. *) + (* destruct (isU p && isLocal l) eqn:X. *) + (* + destruct (Addr_le_dec (max b' a') e'). *) + (* * destruct (Addr_lt_dec (max b' a') (max b a)). *) + (* { destruct (Addr_le_dec (max b a) e'). *) + (* - rewrite (isWithin_region_addrs_decomposition (max b a) e' (max b a) e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "C" as "[C1 [C2 C3]]". *) + (* rewrite (isWithin_region_addrs_decomposition (max b a) e' (max b' a') e'). 2: solve_addr. *) + (* rewrite !big_sepL_app. rewrite (region_addrs_empty e' e'); [simpl; iFrame "#"|solve_addr]. *) + (* assert (Heq: min a e = max b a) by solve_addr. rewrite Heq. *) + (* rewrite (isWithin_region_addrs_decomposition (max b' a') (max b a) b (max b a)). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iSplitR. *) + (* + iApply (big_sepL_impl with "A2"); auto. *) + (* iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;inversion H1;auto. } iFrame "X". *) + (* iPureIntro. destruct (pwlU p). *) + (* { destruct l';inversion Hl';destruct l;inversion H0;inversion Hl. left; auto. } *) + (* { destruct l; simpl in H1; auto. *) + (* - destruct l';auto. right; left; auto. *) + (* - destruct l';inversion Hl;auto. right;left;auto. *) + (* - destruct l';inversion Hl. destruct H2;[left;auto|right;left;auto]. } *) + (* + iSplitL; auto. iApply (big_sepL_impl with "C2"); auto. *) + (* iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* iFrame "X". *) + (* iPureIntro. *) + (* destruct (pwlU p). *) + (* { destruct l';inversion Hl';destruct l;inversion H0;inversion Hl. *) + (* destruct H2;[left;auto|right;right;auto]. } *) + (* { destruct l; simpl in H1; auto. *) + (* - destruct l';auto. right; left; auto. *) + (* - destruct l';inversion Hl;auto. right;left;auto. *) + (* - destruct l';inversion Hl. destruct H2;[left;auto|]. *) + (* destruct H2;[right;left;auto|right;right;auto]. } *) + (* - rewrite (isWithin_region_addrs_decomposition (max b' a') e' b (min a e)). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. *) + (* iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { apply andb_true_iff in X as [HisU Hlocal]. destruct p;inversion HisU;auto. } *) + (* iFrame "#". iPureIntro. destruct (pwlU p). *) + (* + destruct l,l'; inversion H0;inversion Hl. left; auto. *) + (* + destruct l; simpl in H1; auto. *) + (* * destruct l';inversion Hl';[auto|right; left; auto]. *) + (* * destruct l';inversion Hl;auto. right;left;auto. *) + (* * destruct l';inversion Hl. destruct H2;[left;auto|right;left;auto]. } *) + (* { rewrite (isWithin_region_addrs_decomposition (max b' a') e' (max b a) e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "C" as "[C1 [C2 C3]]". auto. *) + (* iApply (big_sepL_impl with "C2"); auto. *) + (* iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* iFrame "X". *) + (* iPureIntro. *) + (* destruct (pwlU p);auto. *) + (* + destruct l;inversion H0. destruct l';inversion Hl. *) + (* destruct H2;[left;auto|right;right;auto]. *) + (* + apply andb_true_iff in X as [HisU Hll]. *) + (* destruct l',l;inversion Hll;inversion Hl'; inversion Hl;auto. *) + (* right;left;auto. } *) + (* * rewrite (region_addrs_empty (max b' a') e'); auto. solve_addr. *) + (* + destruct (Addr_le_dec (max b' a') e'). *) + (* * rewrite (isWithin_region_addrs_decomposition (max b' a') e' b e). 2: solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. *) + (* iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* assert (writeAllowed p || readAllowedU p = true) as ->. *) + (* { destruct p;auto;destruct p';inversion HisU';inversion Hp. } *) + (* iFrame "#". iPureIntro. destruct (pwlU p). *) + (* { destruct l;inversion H0. destruct l';inversion Hl. left; auto. } *) + (* { destruct l; simpl in H2; auto. *) + (* - destruct l'; try (right; left; auto);auto. *) + (* - destruct l';inversion Hl;auto. *) + (* right;left. auto. *) + (* - destruct l';inversion Hl. *) + (* destruct H2; [left|right;left]; auto. } *) + (* * rewrite (region_addrs_empty (max b' a') e'); auto. solve_addr. } *) + Admitted. + + + + (* TODO FIX *) + Lemma interp_weakening W p p' g g' b b' e e' a a' : p <> E -> (b <= b')%a -> (e' <= e)%a -> PermFlowsTo p' p -> - IH -∗ - (fixpoint interp1) (WCap p b e a) -∗ - (fixpoint interp1) (WCap p' b' e' a'). + LocalityFlowsTo g' g -> + ftlr_IH -∗ + (fixpoint interp1) W (WCap p g b e a) -∗ + (fixpoint interp1) W (WCap p' g' b' e' a'). Proof. - intros HpnotE Hb He Hp. iIntros "#IH #HA". - destruct (decide (b' <= e')%a). - 2: { rewrite !fixpoint_interp1_eq. destruct p'; try done; try (by iClear "HA"; rewrite /= !finz_seq_between_empty;[|solve_addr]). - iIntros (r). iNext. iModIntro. iIntros "([Hfull Hreg] & Hregs & Hna)". - iApply ("IH" with "Hfull Hreg Hregs Hna"); auto. iModIntro. - iClear "HA". by rewrite !fixpoint_interp1_eq /= !finz_seq_between_empty;[|solve_addr]. - } - destruct p'. - - rewrite !fixpoint_interp1_eq. done. - - rewrite !fixpoint_interp1_eq. - destruct p;inversion Hp; - (rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]); - rewrite !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]";iFrame "#". - + iApply (big_sepL_mono with "A2"). - iIntros (k y Hsome) "H". iDestruct "H" as (P) "(H1 & H2 & H3)". iExists P. iFrame. - + iApply (big_sepL_mono with "A2"). - iIntros (k y Hsome) "H". iDestruct "H" as (P) "(H1 & H2 & H3)". iExists P. iFrame. - - rewrite !fixpoint_interp1_eq. - destruct p;inversion Hp; - (rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]); - rewrite !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]";iFrame "#". - - rewrite !fixpoint_interp1_eq. - destruct p;inversion Hp; - (rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]); - rewrite !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]";iFrame "#". - iApply (big_sepL_mono with "A2"). - iIntros (k y Hsome) "H". iDestruct "H" as (P) "(H1 & H2 & H3)". iExists P. iFrame. - - rewrite !fixpoint_interp1_eq. iIntros (r). iNext. iModIntro. iIntros "([Hfull Hreg] & Hregs & Hna)". - iApply ("IH" with "Hfull Hreg Hregs Hna"); auto. iModIntro. - destruct p; inversion Hp; try contradiction. - + rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]. - rewrite !fixpoint_interp1_eq !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]"; iFrame "#". - + rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]. - rewrite !fixpoint_interp1_eq !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]". - iApply (big_sepL_mono with "A2"). - iIntros (k y Hsome) "H". iDestruct "H" as (P) "(H1 & H2 & H3)". iExists P. iFrame. - - rewrite !fixpoint_interp1_eq. - destruct p;inversion Hp; - (rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]); - rewrite !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]";iFrame "#". - Qed. + (* intros HpnotE Hb He Hp Hl. iIntros "#IH HA". *) + (* destruct (perm_eq_dec p E); try congruence. *) + (* destruct (perm_eq_dec p' O). *) + (* { subst. *) + (* rewrite !fixpoint_interp1_eq !interp1_eq. auto. } *) + (* destruct (perm_eq_dec p O). *) + (* { subst p; destruct p'; simpl in Hp; try tauto. } *) + (* destruct (perm_eq_dec p' E). *) + (* { rewrite !fixpoint_interp1_eq !interp1_eq. *) + (* destruct (perm_eq_dec p' O);try congruence. *) + (* destruct (perm_eq_dec p' E);try congruence. *) + (* destruct (perm_eq_dec p O);try congruence. *) + (* destruct (perm_eq_dec p E);try congruence. *) + (* iDestruct "HA" as "[#A [% #C]]". *) + (* (* p' = E *) subst p'. iModIntro. *) + (* assert (HisU: isU p = false). *) + (* { destruct p; simpl in Hp; simpl; auto; tauto. } *) + (* rewrite !HisU /enter_cond /interp_expr /=. *) + (* iIntros (r W') "#Hfuture". iNext. *) + (* iIntros "[[Hfull Hmap] [Hreg [Hregion [Hsts Hown]]]]". *) + (* iSplitR; auto. rewrite /interp_conf. *) + (* iApply ("IH" with "Hfull Hmap Hreg Hregion Hsts Hown"); eauto. *) + (* iModIntro. simpl. destruct (Addr_le_dec b' e'). *) + (* - rewrite (isWithin_region_addrs_decomposition b' e' b e); try solve_addr. *) + (* rewrite !big_sepL_app. iDestruct "A" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_impl with "A2"); auto. iModIntro; iIntros (k x Hx) "Hw". *) + (* iDestruct "Hw" as "[#X %]". *) + (* simpl. *) + (* destruct (writeAllowed p || readAllowedU p). *) + (* { rewrite bi.and_exist_r. iExists interp. *) + (* iFrame "#". iSplit;[iSplit;[iPureIntro;apply _|iApply rcond_interp]|]. *) + (* iApply (region_state_nwl_future with "Hfuture"); eauto. *) + (* assert (x ∈ region_addrs b' e') as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto;destruct l;inversion H0;auto. } *) + (* { rewrite bi.and_exist_r. iDestruct "X" as (P) "(? & ?)". *) + (* iExists P;iFrame "#". *) + (* iApply (region_state_nwl_future with "Hfuture"); eauto. *) + (* assert (x ∈ region_addrs b' e') as [_ Hin]%elem_of_region_addrs; *) + (* [apply elem_of_list_lookup;eauto|];auto. *) + (* destruct (pwlU p);auto;destruct l;inversion H0;auto. } *) + (* - rewrite /region_conditions (region_addrs_empty b' e'); auto. solve_addr. *) + (* } *) + (* iApply interp_weakeningEO;eauto. *) + Admitted. + + (* from cerise *) + (* Lemma interp_weakening p p' b b' e e' a a': *) + (* p <> E -> *) + (* (b <= b')%a -> *) + (* (e' <= e)%a -> *) + (* PermFlowsTo p' p -> *) + (* IH -∗ *) + (* (fixpoint interp1) (WCap p b e a) -∗ *) + (* (fixpoint interp1) (WCap p' b' e' a'). *) + (* Proof. *) + (* intros HpnotE Hb He Hp. iIntros "#IH #HA". *) + (* destruct (decide (b' <= e')%a). *) + (* 2: { rewrite !fixpoint_interp1_eq. destruct p'; try done; try (by iClear "HA"; rewrite /= !finz_seq_between_empty;[|solve_addr]). *) + (* iIntros (r). iNext. iModIntro. iIntros "([Hfull Hreg] & Hregs & Hna)". *) + (* iApply ("IH" with "Hfull Hreg Hregs Hna"); auto. iModIntro. *) + (* iClear "HA". by rewrite !fixpoint_interp1_eq /= !finz_seq_between_empty;[|solve_addr]. *) + (* } *) + (* destruct p'. *) + (* - rewrite !fixpoint_interp1_eq. done. *) + (* - rewrite !fixpoint_interp1_eq. *) + (* destruct p;inversion Hp; *) + (* (rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]); *) + (* rewrite !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]";iFrame "#". *) + (* + iApply (big_sepL_mono with "A2"). *) + (* iIntros (k y Hsome) "H". iDestruct "H" as (P) "(H1 & H2 & H3)". iExists P. iFrame. *) + (* + iApply (big_sepL_mono with "A2"). *) + (* iIntros (k y Hsome) "H". iDestruct "H" as (P) "(H1 & H2 & H3)". iExists P. iFrame. *) + (* - rewrite !fixpoint_interp1_eq. *) + (* destruct p;inversion Hp; *) + (* (rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]); *) + (* rewrite !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]";iFrame "#". *) + (* - rewrite !fixpoint_interp1_eq. *) + (* destruct p;inversion Hp; *) + (* (rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]); *) + (* rewrite !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]";iFrame "#". *) + (* iApply (big_sepL_mono with "A2"). *) + (* iIntros (k y Hsome) "H". iDestruct "H" as (P) "(H1 & H2 & H3)". iExists P. iFrame. *) + (* - rewrite !fixpoint_interp1_eq. iIntros (r). iNext. iModIntro. iIntros "([Hfull Hreg] & Hregs & Hna)". *) + (* iApply ("IH" with "Hfull Hreg Hregs Hna"); auto. iModIntro. *) + (* destruct p; inversion Hp; try contradiction. *) + (* + rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]. *) + (* rewrite !fixpoint_interp1_eq !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]"; iFrame "#". *) + (* + rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]. *) + (* rewrite !fixpoint_interp1_eq !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]". *) + (* iApply (big_sepL_mono with "A2"). *) + (* iIntros (k y Hsome) "H". iDestruct "H" as (P) "(H1 & H2 & H3)". iExists P. iFrame. *) + (* - rewrite !fixpoint_interp1_eq. *) + (* destruct p;inversion Hp; *) + (* (rewrite /= (isWithin_finz_seq_between_decomposition b' e' b e); [|solve_addr]); *) + (* rewrite !big_sepL_app; iDestruct "HA" as "[A1 [A2 A3]]";iFrame "#". *) + (* Qed. *) Lemma safe_to_unseal_weakening b e b' e': (b <= b')%ot -> @@ -112,6 +556,7 @@ Section fundamental. - iClear "HA"; rewrite !finz_seq_between_empty;[done |solve_addr]. Qed. + (* TODO move cap_machine/machine_base *) Ltac destruct_sealperm p := let b := fresh "b" in let b1 := fresh "b1" in @@ -123,14 +568,15 @@ Section fundamental. SealPermFlowsTo p' p = true -> permit_unseal p' = true → permit_unseal p = true. Proof. destruct_sealperm p; destruct_sealperm p'; done. Qed. - Lemma interp_weakening_ot p p' b b' e e' a a': + Lemma interp_weakening_ot W p p' g g' b b' e e' a a': (b <= b')%ot -> (e' <= e)%ot -> SealPermFlowsTo p' p = true -> - (fixpoint interp1) (WSealRange p b e a) -∗ - (fixpoint interp1) (WSealRange p' b' e' a'). + LocalityFlowsTo g' g = true -> + (fixpoint interp1) W (WSealRange p g b e a) -∗ + (fixpoint interp1) W (WSealRange p' g' b' e' a'). Proof. - intros Hb He Hp. iIntros "#HA". + intros Hb He Hp Hg. iIntros "#HA". rewrite !fixpoint_interp1_eq. cbn. destruct (permit_seal p') eqn:Hseal; [eapply (permit_seal_flowsto _ p) in Hseal as ->; auto | ]. all: destruct (permit_unseal p') eqn:Hunseal; [eapply (permit_unseal_flowsto _ p) in Hunseal as ->; auto | ]; iDestruct "HA" as "[Hs Hus]". @@ -138,5 +584,4 @@ Section fundamental. [try iApply (safe_to_seal_weakening with "Hs") | try iApply (safe_to_unseal_weakening with "Hus")]; auto. Qed. - End fundamental. diff --git a/theories/logrel.v b/theories/logrel.v index f3fa8250..affe50c9 100644 --- a/theories/logrel.v +++ b/theories/logrel.v @@ -1,7 +1,7 @@ From iris.proofmode Require Import proofmode. From iris.program_logic Require Export weakestpre. (* From cap_machine.rules Require Export rules. *) -From cap_machine Require Export cap_lang region seal_store. +From cap_machine Require Export cap_lang region seal_store region_invariants. From iris.algebra Require Import gmap agree auth. From iris.base_logic Require Export invariants na_invariants saved_prop. From cap_machine.rules Require Import rules_base. @@ -33,14 +33,19 @@ Class logrel_na_invs Σ := Section logrel. Context {Σ : gFunctors} - {ceriseg: ceriseG Σ} - {sealsg: sealStoreG Σ} + {ceriseg: ceriseG Σ} {sealsg: sealStoreG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} {nainv: logrel_na_invs Σ} {MP: MachineParameters} . - Notation D := ((leibnizO Word) -n> iPropO Σ). - Notation R := ((leibnizO Reg) -n> iPropO Σ). + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Notation D := (WORLD -n> (leibnizO Word) -n> iPropO Σ). + Notation R := (WORLD -n> (leibnizO Reg) -n> iPropO Σ). Implicit Types w : (leibnizO Word). Implicit Types interp : (D). @@ -52,97 +57,239 @@ Section logrel. Definition full_map (reg : Reg) : iProp Σ := (∀ (r : RegName), ⌜is_Some (reg !! r)⌝)%I. Program Definition interp_reg (interp : D) : R := - λne (reg : leibnizO Reg), (full_map reg ∧ - ∀ (r : RegName) (v : Word), (⌜r ≠ PC⌝ → ⌜reg !! r = Some v⌝ → interp v))%I. - - Definition interp_conf : iProp Σ := - (WP Seq (Instr Executable) {{ v, ⌜v = HaltedV⌝ → ∃ r, full_map r ∧ registers_pointsto r ∗ na_own logrel_nais ⊤ }})%I. - - Program Definition interp_expr (interp : D) r : D := - (λne w, (interp_reg interp r ∗ registers_pointsto (<[PC:=w]> r) ∗ na_own logrel_nais ⊤ -∗ - interp_conf))%I. + λne (W : WORLD) (reg : leibnizO Reg), + (full_map reg ∧ + ∀ (r : RegName) (v : Word), (⌜r ≠ PC⌝ → ⌜reg !! r = Some v⌝ → interp W v))%I. Solve All Obligations with solve_proper. + Definition interp_conf W : iProp Σ := + (WP Seq (Instr Executable) {{ v, ⌜v = HaltedV⌝ → + ∃ r W', full_map r ∧ registers_pointsto r + ∗ ⌜related_sts_priv_world W W'⌝ + ∗ na_own logrel_nais ⊤ + ∗ sts_full_world W' + ∗ region W' }})%I. + +Program Definition interp_expr (interp : D) r : D := + (λne W w, (interp_reg interp W r ∗ registers_pointsto (<[PC:=w]> r) + ∗ region W + ∗ sts_full_world W + ∗ na_own logrel_nais ⊤ -∗ + ⌜match w with WCap _ _ _ _ _ => True | _ => False end⌝ ∧ interp_conf W))%I. + Solve All Obligations with solve_proper. (* condition definitions *) - Program Definition read_cond (P : D) : D -n> iPropO Σ := - λne interp, (▷ □ ∀ (w : Word), P w -∗ interp w)%I. - Solve Obligations with solve_proper. - Global Instance read_cond_ne n : - Proper (dist n ==> dist n ==> dist n) read_cond. + Program Definition read_write_cond l (interp : D) : iProp Σ := + rel l (λne Wv, interp Wv.1 Wv.2). + Next Obligation. Proof. solve_proper. Qed. + Global Instance read_write_cond_ne n : + Proper ((=) ==> dist n ==> dist n) read_write_cond. + Proof. + rewrite /read_write_cond rel_eq /rel. solve_proper_prepare. + f_equiv =>γ. f_equiv. + apply saved_anything_ne. + solve_proper. + Qed. - Program Definition write_cond (P : D) : D -n> iPropO Σ := - λne interp, (▷ □ ∀ (w : Word), interp w -∗ P w)%I. - Solve Obligations with solve_proper. - Global Instance write_cond_ne n : - Proper (dist n ==> dist n ==> dist n) write_cond. + Definition rcond (P interp : D) : iProp Σ := + (▷ □ ∀ (W: WORLD) (w : Word), P W w -∗ interp W w) + ∗ (▷ □ ∀ (W1 W2: WORLD) (z : Z), P W1 (WInt z) -∗ P W2 (WInt z)). + Program Definition read_cond l (P : D) (interp : D) : iProp Σ := + rcond P interp ∗ rel l (λne Wv, P Wv.1 Wv.2). + Next Obligation. Proof. solve_proper. Qed. + Global Instance read_cond_ne n : + Proper ((=) ==> dist n ==> dist n ==> dist n) read_cond. + Proof. + rewrite /read_cond /rcond rel_eq /rel. solve_proper_prepare. + apply sep_ne. + - repeat f_equiv;auto. + - solve_proper_prepare. + f_equiv =>γ. f_equiv. + apply saved_anything_ne. + solve_proper. + Qed. - Program Definition enter_cond b e a : D -n> iPropO Σ := - λne interp, (∀ r, ▷ □ interp_expr interp r (WCap RX b e a))%I. - Solve Obligations with solve_proper. + Definition wcond (P interp : D) : iProp Σ := + (▷ □ ∀ (W: WORLD) (w : Word), interp W w -∗ P W w). + Global Instance wcond_ne n : + Proper ((=) ==> dist n ==> dist n) wcond. + Proof. solve_proper_prepare. repeat f_equiv;auto. Qed. + + (* TODO fix *) + Definition future_world g W W' : iProp Σ := + (match g with + (* | Local => ⌜related_sts_pub_plus_world W W'⌝ *) + | Local | Global => ⌜related_sts_priv_world W W'⌝ + end)%I. + + Lemma localityflowsto_futureworld g g' W W' a a': + LocalityFlowsTo g' g -> + (a' <= a)%a → + (@future_world g' W W' -∗ + @future_world g W W'). + Proof. + intros; destruct g, g'; auto. + Qed. + + Lemma futureworld_refl g W : + ⊢ @future_world g W W. + Proof. + rewrite /future_world. + destruct g. + all: iPureIntro; apply related_sts_priv_refl_world. + Qed. + + Global Instance future_world_persistent g W W': Persistent (future_world g W W'). + Proof. + unfold future_world. destruct g; apply bi.pure_persistent. + Qed. + + Definition exec_cond W b e g p (interp : D) : iProp Σ := + (∀ a r W', ⌜a ∈ₐ [[ b , e ]]⌝ → future_world g W W' → + ▷ interp_expr interp r W' (WCap p g b e a))%I. + Global Instance exec_cond_ne n : + Proper ((=) ==> (=) ==> (=) ==> (=) ==> (=) ==> dist n ==> dist n) exec_cond. + Proof. unfold exec_cond. solve_proper. Qed. + + Definition enter_cond W g b e a (interp : D) : iProp Σ := + (∀ r W', future_world g W W' → + ▷ interp_expr interp r W' (WCap RX g b e a))%I. Global Instance enter_cond_ne n : - Proper ((=) ==> (=) ==> (=) ==> dist n ==> dist n) enter_cond. - Proof. solve_proper. Qed. + Proper ((=) ==> (=) ==> (=) ==> (=) ==> (=) ==> dist n ==> dist n) enter_cond. + Proof. unfold enter_cond. solve_proper. Qed. (* interp definitions *) - Program Definition interp_ref_inv (a : Addr) : D -n> iPropO Σ := λne P, (∃ w, a ↦ₐ w ∗ P w)%I. - Solve Obligations with solve_proper. - Definition logN : namespace := nroot .@ "logN". - Definition interp_z : D := λne w, ⌜match w with WInt z => True | _ => False end⌝%I. + (* TODO update the table *) + (* + ------------------------------------------------------------- + | | nwl | pwl | + | | - < a | a ≤ - | - < a | a ≤ - | + ------------------------------------------------------------- + | Directed | {M,P} | {M,P,U} | {M} | {M,U} | + |-----------------------------------------------------------| + | Local | {P} | N/A | + |-----------------------------------------------------------| + | Global | {P} | N/A | + ------------------------------------------------------------- + + *) + + Definition region_state_pwl W (a : Addr) : Prop := + (std W) !! a = Some Monotemporary. + + Definition region_state_nwl W (a : Addr) (l : Locality) : Prop := + match l with + | Local => (std W) !! a = Some Permanent + (* TODO ∨ (std W) !! a = Some Monotemporary *) + | Global => (std W) !! a = Some Permanent + end. + + (* Definition region_state_U W (a : Addr) : Prop := *) + (* (std W) !! a = Some Permanent. *) + + (* Definition region_state_U_mono W (a : Addr) : Prop := *) + (* (std W) !! a = Some Monotemporary *) + (* \/ (std W) !! a = Some Permanent *) + (* ∨ (exists w, (std W) !! a = Some (Uninitialized w)). *) + + (* Definition region_state_U_pwl_mono W (a : Addr) : Prop := *) + (* (std W) !! a = Some Monotemporary *) + (* ∨ (exists w, (std W) !! a = Some (Uninitialized w)). *) + + (* For simplicity we might want to have the following statement in valididy of caps. + However, it is strictly not necessary since it can be derived form full_sts_world *) + (* Definition region_std W (a : Addr) : Prop := rel_is_std_i W (countable.encode a). *) - Definition interp_cap_O : D := λne _, True%I. + Definition interp_z : D := λne _ w, ⌜match w with WInt z => True | _ => False end⌝%I. + Definition interp_cap_O : D := λne _ _, True%I. + + (* TODO reverse [∗ list] a ∈ (region_addrs b e) if necessary *) Program Definition interp_cap_RO (interp : D) : D := - λne w, (match w with - | WCap RO b e a => - [∗ list] a ∈ (finz.seq_between b e), ∃ P, inv (logN .@ a) (interp_ref_inv a P) ∗ read_cond P interp + λne W w, (match w with + | WCap RO g b e a => + [∗ list] a ∈ (finz.seq_between b e), + ∃ (P:D), ⌜(∀ Wv, Persistent (P Wv.1 Wv.2))⌝ + ∧ (read_cond a P interp) + ∧ ⌜region_state_nwl W a g⌝ | _ => False end)%I. Solve All Obligations with solve_proper. Program Definition interp_cap_RW (interp : D) : D := - λne w, (match w with - | WCap RW b e a => - [∗ list] a ∈ (finz.seq_between b e), ∃ P, inv (logN .@ a) (interp_ref_inv a P) ∗ read_cond P interp - ∗ write_cond P interp + λne W w, (match w with + | WCap RW g b e a => + [∗ list] a ∈ (finz.seq_between b e), + (read_write_cond a interp) (* TODO should be wcond and rcond *) + ∧ ⌜region_state_nwl W a g⌝ | _ => False end)%I. Solve All Obligations with solve_proper. Program Definition interp_cap_RX (interp : D) : D := - λne w, (match w with WCap RX b e a => - [∗ list] a ∈ (finz.seq_between b e), ∃ P, inv (logN .@ a) (interp_ref_inv a P) ∗ read_cond P interp + λne W w, (match w with + | WCap RX g b e a => + ([∗ list] a ∈ (finz.seq_between b e), + ∃ (P:D), ⌜(∀ Wv, Persistent (P Wv.1 Wv.2))⌝ + ∧ (read_cond a P interp) + ∧ ⌜region_state_nwl W a g⌝) | _ => False end)%I. Solve All Obligations with solve_proper. Program Definition interp_cap_E (interp : D) : D := - λne w, (match w with - | WCap E b e a => enter_cond b e a interp + λne W w, (match w with + | WCap E g b e a => □ enter_cond W g b e a interp | _ => False end)%I. Solve All Obligations with solve_proper. Program Definition interp_cap_RWX (interp : D) : D := - λne w, (match w with WCap RWX b e a => - [∗ list] a ∈ (finz.seq_between b e), ∃ P, inv (logN .@ a) (interp_ref_inv a P) ∗ read_cond P interp - ∗ write_cond P interp - | _ => False end)%I. + λne W w, (match w with + | WCap RWX g b e a => + ([∗ list] a ∈ (finz.seq_between b e), + (read_write_cond a interp) + ∧ ⌜region_state_nwl W a g⌝) + | _ => False end)%I. + Solve All Obligations with solve_proper. + + (* Interp with WL *) + Program Definition interp_cap_RWL (interp : D) : D := + λne W w, (match w with + | WCap RWL Local b e a => + [∗ list] a ∈ (finz.seq_between b e), + ∃ p, ⌜PermFlows RWL p⌝ ∗ + (read_write_cond a interp) + ∧ ⌜region_state_pwl W a⌝ + | _ => False + end)%I. + Solve All Obligations with solve_proper;auto. + + Program Definition interp_cap_RWLX (interp : D) : D := + λne W w, (match w with + | WCap RWLX Local b e a => + [∗ list] a ∈ (finz.seq_between b e), + ∃ p, ⌜PermFlows RWLX p⌝ ∗ + (read_write_cond a interp) + ∧ ⌜region_state_pwl W a⌝ + | _ => False end)%I. Solve All Obligations with solve_proper. (* (un)seal permission definitions *) (* Note the asymmetry: to seal values, we need to know that we are using a persistent predicate to create a value, whereas we do not need this information when unsealing values (it is provided by the `interp_sb` case). *) Definition safe_to_seal (interp : D) (b e : OType) : iPropO Σ := - ([∗ list] a ∈ (finz.seq_between b e), ∃ P : D, ⌜∀ w, Persistent (P w)⌝ ∗ seal_pred a P ∗ write_cond P interp)%I. + ([∗ list] a ∈ (finz.seq_between b e), + ∃ P : D, ⌜∀ w W, Persistent (P W w)⌝ ∗ (∀ W, seal_pred a (P W)) ∗ wcond P interp)%I. Definition safe_to_unseal (interp : D) (b e : OType) : iPropO Σ := - ([∗ list] a ∈ (finz.seq_between b e), ∃ P : D, seal_pred a P ∗ read_cond P interp)%I. + ([∗ list] a ∈ (finz.seq_between b e), ∃ P : D, (∀ W, seal_pred a (P W)) ∗ rcond P interp)%I. Program Definition interp_sr (interp : D) : D := - λne w, (match w with - | WSealRange p b e a => - (if permit_seal p then safe_to_seal interp b e else True) ∗ (if permit_unseal p then safe_to_unseal interp b e else True) + λne W w, (match w with + | WSealRange p g b e a => + (if permit_seal p then safe_to_seal interp b e else True) + ∗ (if permit_unseal p then safe_to_unseal interp b e else True) | _ => False end ) %I. Solve All Obligations with solve_proper. @@ -150,22 +297,54 @@ Section logrel. (∃ P : Word → iPropI Σ, ⌜∀ w, Persistent (P w)⌝ ∗ seal_pred o P ∗ ▷ P w)%I. Program Definition interp1 (interp : D) : D := - (λne w, + (λne W w, match w return _ with - | WInt _ => interp_z w - | WCap O b e a => interp_cap_O w - | WCap RO b e a => interp_cap_RO interp w - | WCap RW b e a => interp_cap_RW interp w - | WCap RX b e a => interp_cap_RX interp w - | WCap E b e a => interp_cap_E interp w - | WCap RWX b e a => interp_cap_RWX interp w - | WSealRange p b e a => interp_sr interp w + | WInt _ => interp_z W w + | WCap O g b e a => interp_cap_O W w + | WCap RO g b e a => interp_cap_RO interp W w + | WCap RW g b e a => interp_cap_RW interp W w + | WCap RX g b e a => interp_cap_RX interp W w + | WCap E g b e a => interp_cap_E interp W w + | WCap RWX g b e a => interp_cap_RWX interp W w + | WCap RWL g b e a => interp_cap_RWL interp W w + | WCap RWLX g b e a => interp_cap_RWLX interp W w + | WSealRange p g b e a => interp_sr interp W w | WSealed o sb => interp_sb o (WSealable sb) end)%I. + Solve All Obligations with solve_proper. + + Global Instance rcond_contractive P : + Contractive (λ interp, rcond P interp). + Proof. solve_contractive. Qed. + + Global Instance wcond_contractive P : + Contractive (λ interp, wcond P interp). + Proof. solve_contractive. Qed. - Global Instance read_cond_contractive : - Contractive (read_cond). + Global Instance read_cond_contractive a P : + Contractive (λ interp, read_cond a P interp). Proof. solve_contractive. Qed. + + Global Instance read_write_cond_contractive a : + Contractive (λ interp, read_write_cond a interp). + Proof. + solve_proper_prepare. + rewrite /read_write_cond rel_eq /rel_def /saved_pred_own. + apply exist_ne =>γ. apply sep_ne; auto. + f_equiv. solve_contractive. + Qed. + + Global Instance exec_cond_contractive W b e g p : + Contractive (λ interp, exec_cond W b e g p interp). + Proof. + solve_contractive. + Qed. + Global Instance enter_cond_contractive W b e a g : + Contractive (λ interp, enter_cond W b e a g interp). + Proof. + solve_contractive. + Qed. + Global Instance interp_cap_O_contractive : Contractive (interp_cap_O). Proof. solve_contractive. Qed. @@ -173,47 +352,63 @@ Section logrel. Contractive (interp_cap_RO). Proof. solve_proper_prepare. - destruct_word x0; auto. destruct c; auto. + destruct_word x1; auto. destruct c; auto. solve_contractive. Qed. + Global Instance interp_cap_RW_contractive : Contractive (interp_cap_RW). Proof. solve_proper_prepare. - destruct_word x0; auto. destruct c; auto. + destruct_word x1; auto. destruct c; auto. solve_contractive. Qed. - Global Instance enter_cond_contractive b e a : - Contractive (λ interp, enter_cond b e a interp). + + Global Instance interp_cap_RWL_contractive : + Contractive (interp_cap_RWL). Proof. + solve_proper_prepare. + destruct_word x1; auto. destruct c, g; auto. solve_contractive. Qed. + Global Instance interp_cap_RX_contractive : Contractive (interp_cap_RX). Proof. solve_proper_prepare. - destruct_word x0; auto. destruct c; auto. + destruct_word x1; auto. destruct c; auto. solve_contractive. Qed. + Global Instance interp_cap_E_contractive : Contractive (interp_cap_E). Proof. solve_proper_prepare. - destruct_word x0; auto. destruct c; auto. + destruct_word x1; auto. destruct c; auto. solve_contractive. Qed. + Global Instance interp_cap_RWX_contractive : Contractive (interp_cap_RWX). Proof. solve_proper_prepare. - destruct_word x0; auto. destruct c; auto. - solve_contractive. + destruct_word x1; auto. destruct c,g; auto. + all: solve_contractive. Qed. + + Global Instance interp_cap_RWLX_contractive : + Contractive (interp_cap_RWLX). + Proof. + solve_proper_prepare. + destruct_word x1; auto. destruct c,g; auto. + all: solve_contractive. + Qed. + Global Instance interp_sr_contractive : Contractive (interp_sr). Proof. solve_proper_prepare. - destruct_word x0; auto. + destruct_word x1; auto. destruct (permit_seal sr), (permit_unseal sr); rewrite /safe_to_seal /safe_to_unseal; solve_contractive. @@ -222,91 +417,205 @@ Section logrel. Global Instance interp1_contractive : Contractive (interp1). Proof. - intros n x y Hdistn w. + intros n x y Hdistn W w. rewrite /interp1. destruct_word w; [auto|..]. + destruct c; first auto. - by apply interp_cap_RO_contractive. - by apply interp_cap_RW_contractive. + - by apply interp_cap_RWL_contractive. - by apply interp_cap_RX_contractive. - by apply interp_cap_E_contractive. - by apply interp_cap_RWX_contractive. + - by apply interp_cap_RWLX_contractive. + by apply interp_sr_contractive. + rewrite /interp_sb. solve_contractive. Qed. - Lemma fixpoint_interp1_eq (x : leibnizO Word) : - fixpoint (interp1) x ≡ interp1 (fixpoint (interp1)) x. - Proof. exact: (fixpoint_unfold (interp1) x). Qed. + Lemma fixpoint_interp1_eq (W : WORLD) (x : leibnizO Word) : + fixpoint (interp1) W x ≡ interp1 (fixpoint (interp1)) W x. + Proof. exact: (fixpoint_unfold (interp1) W x). Qed. - Definition interp : D := λne w, (fixpoint (interp1)) w. + Program Definition interp : D := λne W w, (fixpoint (interp1)) W w. + Solve All Obligations with solve_proper. Definition interp_expression r : D := interp_expr interp r. Definition interp_registers : R := interp_reg interp. - Global Instance interp_persistent w : Persistent (interp w). + Global Instance interp_persistent W w : Persistent (interp W w). Proof. intros. destruct_word w; simpl; rewrite fixpoint_interp1_eq; simpl. - apply _. - - destruct c; repeat (apply exist_persistent; intros); try apply _. + - destruct c,g; repeat (apply exist_persistent; intros); try apply _. - destruct (permit_seal sr), (permit_unseal sr); rewrite /safe_to_seal /safe_to_unseal; apply _ . - apply exist_persistent; intros P. - unfold Persistent. iIntros "(Hpers & #Hs & HP)". iDestruct "Hpers" as %Hpers. + unfold Persistent. iIntros "(Hpers & #Hs & HP)". + iDestruct "Hpers" as %Hpers. (* use knowledge about persistence *) - iAssert ( ▷ P (WSealable s))%I with "[ HP ]" as "HP". + iAssert ( ▷ P (WSealable sb))%I with "[ HP ]" as "HP". { iApply later_persistently_1. by iApply Hpers. } iApply persistently_sep_2; iSplitR; auto. iApply persistently_sep_2; auto. Qed. - Lemma interp_int n : ⊢ interp (WInt n). + Global Instance ne_interpC : NonExpansive + (λ Wv : (WORLD * (leibnizO Word)), (interp Wv.1) Wv.2). + Proof. intros. solve_proper. Qed. + + (* Non-curried version of interp *) + Definition interpC := + (λne Wv : WORLD * (leibnizO Word), (interp Wv.1) Wv.2). + + Lemma interp_int W n : ⊢ interp W (WInt n). Proof. iIntros. rewrite /interp fixpoint_interp1_eq //. Qed. - Lemma read_allowed_inv (a' a b e: Addr) p : + Lemma read_allowed_inv W (a' a b e: Addr) p g : (b ≤ a' ∧ a' < e)%Z → readAllowed p → - ⊢ (interp (WCap p b e a) → - (∃ P, inv (logN .@ a') (interp_ref_inv a' P) ∗ read_cond P interp ∗ if writeAllowed p then write_cond P interp else emp))%I. + ⊢ (interp W (WCap p g b e a)) → + if writeAllowed p + then read_write_cond a' interp + else (∃ (P:D), ⌜(∀ Wv, Persistent (P Wv.1 Wv.2))⌝ ∧ read_cond a' P interp). Proof. iIntros (Hin Ra) "Hinterp". rewrite /interp. cbn. rewrite fixpoint_interp1_eq /=; cbn. - destruct p; try contradiction; - try (iDestruct "Hinterp" as "[Hinterp Hinterpe]"); - try (iDestruct (extract_from_region_inv with "Hinterp") as (P) "[Hinv Hiff]"; [eauto|iExists P;iSplit;eauto]). + destruct p,g; try contradiction;simpl. + all: try (iDestruct (extract_from_region_inv with "Hinterp") as (P Hpers) "[Hinv _]";eauto). + all: try (iDestruct (extract_from_region_inv with "Hinterp") as "[Hinv _]";eauto). + all: done. Qed. - Lemma write_allowed_inv (a' a b e: Addr) p : - (b ≤ a' ∧ a' < e)%Z → - writeAllowed p → - ⊢ (interp (WCap p b e a) → - inv (logN .@ a') (interp_ref_inv a' interp))%I. + (* Lemma write_allowed_inv (a' a b e: Addr) p : *) + (* (b ≤ a' ∧ a' < e)%Z → *) + (* writeAllowed p → *) + (* ⊢ (interp (WCap p b e a) → *) + (* inv (logN .@ a') (interp_ref_inv a' interp))%I. *) + (* Proof. *) + (* iIntros (Hin Wa) "Hinterp". *) + (* rewrite /interp. cbn. rewrite fixpoint_interp1_eq /=; cbn. *) + (* destruct p; try contradiction. *) + (* - iDestruct (extract_from_region_inv with "Hinterp") as (P) "[Hinv #[Hread Hwrite] ]";[eauto|]. *) + (* iApply (inv_iff with "Hinv"). *) + (* iNext. iModIntro. iSplit. *) + (* + iIntros "HP". iDestruct "HP" as (w) "[Ha' HP]". *) + (* iExists w. iFrame. iApply "Hread". iFrame. *) + (* + iIntros "HP". iDestruct "HP" as (w) "[Ha' HP]". *) + (* iExists w. iFrame. iApply "Hwrite". iFrame. *) + (* - iDestruct (extract_from_region_inv with "Hinterp") as (P) "[Hinv #[Hread Hwrite] ]";[eauto|]. *) + (* iApply (inv_iff with "Hinv"). *) + (* iNext. iModIntro. iSplit. *) + (* + iIntros "HP". iDestruct "HP" as (w) "[Ha' HP]". *) + (* iExists w. iFrame. iApply "Hread". iFrame. *) + (* + iIntros "HP". iDestruct "HP" as (w) "[Ha' HP]". *) + (* iExists w. iFrame. iApply "Hwrite". iFrame. *) + (* Qed. *) + + + Lemma writeLocalAllowed_implies_local W p g b e a: + pwl p = true -> + interp W (WCap p g b e a) -∗ ⌜ isLocal g = true ⌝. Proof. - iIntros (Hin Wa) "Hinterp". - rewrite /interp. cbn. rewrite fixpoint_interp1_eq /=; cbn. - destruct p; try contradiction. - - iDestruct (extract_from_region_inv with "Hinterp") as (P) "[Hinv #[Hread Hwrite] ]";[eauto|]. - iApply (inv_iff with "Hinv"). - iNext. iModIntro. iSplit. - + iIntros "HP". iDestruct "HP" as (w) "[Ha' HP]". - iExists w. iFrame. iApply "Hread". iFrame. - + iIntros "HP". iDestruct "HP" as (w) "[Ha' HP]". - iExists w. iFrame. iApply "Hwrite". iFrame. - - iDestruct (extract_from_region_inv with "Hinterp") as (P) "[Hinv #[Hread Hwrite] ]";[eauto|]. - iApply (inv_iff with "Hinv"). - iNext. iModIntro. iSplit. - + iIntros "HP". iDestruct "HP" as (w) "[Ha' HP]". - iExists w. iFrame. iApply "Hread". iFrame. - + iIntros "HP". iDestruct "HP" as (w) "[Ha' HP]". - iExists w. iFrame. iApply "Hwrite". iFrame. + intros. iIntros "Hvalid". + unfold interp; rewrite fixpoint_interp1_eq /=. + destruct p; simpl in H; try congruence; destruct g; auto. + Qed. + + Lemma readAllowed_valid_cap_implies W p g b e a: + readAllowed p = true -> + withinBounds b e a = true -> + interp W (WCap p g b e a) -∗ + ⌜∃ ρ, std W !! a = Some ρ ∧ ρ <> Revoked ∧ (∀ m, ρ ≠ Monostatic m)⌝. + Proof. + intros Hp Hb. iIntros "H". + eapply withinBounds_le_addr in Hb. + unfold interp; rewrite fixpoint_interp1_eq /=. + destruct p; simpl in Hp; try congruence. + - iDestruct (extract_from_region_inv with "H") as (P Hpers) "[_ H]"; eauto. + iDestruct "H" as %HH. iPureIntro. destruct g; eauto;simpl in HH. + - iDestruct (extract_from_region_inv with "H") as "[_ H]"; eauto. + iDestruct "H" as %HH. iPureIntro. destruct g; eauto; simpl in HH. + - destruct g; auto. + iDestruct (extract_from_region_inv with "H") as (p Hpers) "[_ H]"; eauto. + iDestruct "H" as %HH. iPureIntro. eauto. + - iDestruct (extract_from_region_inv with "H") as (p Hpers) "[_ H]"; eauto. + iDestruct "H" as %HH. iPureIntro. destruct g; eauto. + - iDestruct (extract_from_region_inv with "H") as "[_ H]"; eauto. + iDestruct "H" as %HH. iPureIntro. destruct g; eauto. + - destruct g; auto. + iDestruct (extract_from_region_inv with "H") as (p Hpers) "[_ H]"; eauto. + iDestruct "H" as %HH. iPureIntro. eauto. + Qed. + + Definition region_conditions W p g b e:= + ([∗ list] a ∈ (finz.seq_between b e), + (if writeAllowed p + then read_write_cond a interp + else (∃ (P:D), ⌜(∀ Wv, Persistent (P Wv.1 Wv.2))⌝ + ∧ read_cond a P interp)) + ∧ ⌜if pwl p then region_state_pwl W a else region_state_nwl W a g⌝)%I. + + Global Instance region_conditions_persistent W p g b e : Persistent (region_conditions W p g b e). + Proof. + intros. rewrite /region_conditions. apply big_sepL_persistent. intros. + destruct (writeAllowed p),(pwl p);apply _. Qed. + Lemma readAllowed_implies_region_conditions W p g b e a: + readAllowed p = true -> + interp W (WCap p g b e a) -∗ region_conditions W p g b e. + Proof. + intros. iIntros "Hvalid". + unfold interp; rewrite fixpoint_interp1_eq /=. + unfold region_conditions. + destruct p; simpl in *; try congruence; destruct g; simpl; eauto. + all:iApply (big_sepL_mono with "Hvalid");iIntros (k y Hin) "H". + all: try (iApply and_exist_r; iDestruct "H" as (P) "(?&?&?)"; iExists _; iFrame). + all: iDestruct "H" as (p _) "H". + all: iDestruct "H" as "[H %]" ; iFrame "H%". + Qed. + + Lemma read_write_cond_implies_read_cond a : + read_write_cond a interp -∗ ∃ P, read_cond a P interp. + Proof. + iIntros "Hread". iExists interp. iFrame. rewrite /rcond. iSplit; auto. + iNext. iModIntro. iIntros (W1 W2 z) "_". rewrite fixpoint_interp1_eq. done. + Qed. + + Lemma rcond_interp : ⊢ rcond interp interp. + Proof. + iSplit;[auto|]. + iNext. iModIntro. iIntros (W1 W2 Hrelated) "_". + rewrite fixpoint_interp1_eq. done. + Qed. + + Lemma wcond_interp : ⊢ wcond interp interp. + Proof. + by iNext; iModIntro; iIntros (W1 w) "?". + Qed. + + Lemma execcPC_implies_interp W p g b e a0: + p = RX ∨ p = RWX ∨ p = RWLX ∧ g = Local → + region_conditions W p g b e -∗ ((fixpoint interp1) W) (WCap p g b e a0). + Proof. + iIntros (Hp) "#HR". + rewrite (fixpoint_interp1_eq _ (WCap _ _ _ _ _)). + (do 2 try destruct Hp as [ | Hp]); [| |destruct Hp];subst; auto. + all: rewrite /region_conditions /=. + all: iApply (big_sepL_mono with "HR"). + all: intros;iIntros "H". + iDestruct (and_exist_r with "H") as (P) "((?&?)&?)"; eauto. + iExists RWLX;iFrame;done. + Qed. + + + (* TODO Move? *) Definition writeAllowedWord (w : Word) : Prop := match w with - | WCap p _ _ _ => writeAllowed p = true + | WCap p _ _ _ _ => writeAllowed p = true | _ => False end. Definition hasValidAddress (w : Word) (a : Addr) : Prop := match w with - | WCap p b e a' => (b ≤ a' ∧ a' < e)%Z ∧ a = a' + | WCap _ _ b e a' => (b ≤ a' ∧ a' < e)%Z ∧ a = a' | _ => False end. @@ -328,281 +637,128 @@ Section logrel. all : (right; intros [w1 (Heq & ? & ?)]; inversion Heq; try congruence ). Qed. - Global Instance writeAllowed_in_r_a_Persistent P r a: Persistent (if decide (writeAllowed_in_r_a r a) then write_cond P interp else emp)%I. + Global Instance writeAllowed_in_r_a_Persistent P r a: + Persistent (if decide (writeAllowed_in_r_a r a) then wcond P interp else emp)%I. Proof. intros. case_decide; apply _. Qed. - Lemma read_allowed_inv_regs (a' a b e: Addr) p r : + Lemma read_allowed_inv_regs (a' a b e: Addr) p g W r : (b ≤ a' ∧ a' < e)%Z → readAllowed p → - ⊢ (interp_registers r -∗ - interp (WCap p b e a) -∗ - (∃ P, inv (logN .@ a') (interp_ref_inv a' P) ∗ read_cond P interp ∗ if decide (writeAllowed_in_r_a (<[PC:=WCap p b e a]> r) a') then write_cond P interp else emp))%I. + ⊢ (interp_registers W r -∗ + interp W (WCap p g b e a) -∗ + (∃ (P : D), ⌜(∀ Wv, Persistent (P Wv.1 Wv.2))⌝ + ∗ rel a' (λ Wv, P Wv.1 Wv.2) + ∗ rcond P interp + ∗ if decide (writeAllowed_in_r_a (<[PC:=(WCap p g b e a)]> r) a') + then wcond P interp + else emp))%I. Proof. iIntros (Hin Ra) "#Hregs #Hinterp". rewrite /interp_registers /interp_reg /=. iDestruct "Hregs" as "[Hfull Hregvalid]". case_decide as Hinra. - - destruct Hinra as (reg & w & (Hw & Hwa & Ha) ). + - destruct Hinra as [reg (wa & Hra & Hwa & Ha) ]. destruct (decide (reg = PC)). + simplify_map_eq. rewrite /interp. cbn. rewrite fixpoint_interp1_eq /=; cbn. - destruct p; try contradiction; inversion Hwa; - try (iDestruct (extract_from_region_inv with "Hinterp") as (P) "[Hinv Hiff]"; [eauto|iExists P;iSplit;eauto]). + destruct p,g + ; try contradiction ; try done + ; inversion Hwa; try done + ; try (iDestruct (extract_from_region_inv with "Hinterp") as "[Hinv Hiff]"; eauto) + ; try (iDestruct (extract_from_region_inv with "Hinterp") as (p) "[% [Hinv Hiff]]"; eauto). + all: iExists interp;try iFrame "Hinv". + all: iSplitR;[iPureIntro;apply _|]. + all: rewrite /rcond /wcond /=;auto. + all: try (iSplit;[iSplit;auto|]). + all: try (iNext;iModIntro;try (iIntros (W1 W2 z) "_";rewrite fixpoint_interp1_eq;auto)). + all: auto. + simplify_map_eq. - destruct (r !! reg) eqn:Hsome; rewrite Hsome in Hw; inversion Hw. - destruct_word w; try by inversion Ha. destruct Ha as [Hwba ->]. - iSpecialize ("Hregvalid" $! _ _ n Hsome). simplify_eq. iClear "Hinterp". + destruct wa; try inv Ha. + destruct sb; try inv Ha. + iSpecialize ("Hregvalid" $! _ _ n Hra). + iClear "Hinterp". rewrite /interp. cbn. rewrite fixpoint_interp1_eq /=; cbn. - destruct c; try contradiction; inversion Hwa; - try (iDestruct (extract_from_region_inv with "Hregvalid") as (P) "[Hinv Hiff]"; [eauto|iExists P;iSplit;eauto]). + destruct p0,g0; try contradiction; inversion Hwa; try done ; subst. + all: try (iDestruct (extract_from_region_inv _ _ a0 with "Hregvalid") as "[Hinv Hiff]";[solve_addr|];iExists interp;iFrame "Hinv";rewrite /rcond /wcond /=;auto). + all: try (iDestruct (extract_from_region_inv _ _ a0 with "Hregvalid") as (p0) "[% [Hinv Hiff]]";[solve_addr|];iExists interp;iFrame "Hinv";rewrite /rcond /wcond /=;auto). + all: try (iSplitR;[iPureIntro;apply _|auto]). + all: try (iSplit;[iSplit|];auto;iNext;iModIntro;iIntros (W1 W2 z) "_";rewrite fixpoint_interp1_eq;auto). - rewrite /interp. cbn. rewrite fixpoint_interp1_eq /=; cbn. - destruct p; try contradiction; - try (iDestruct (extract_from_region_inv with "Hinterp") as (P) "[Hinv [Hiff _] ]"; [eauto|iExists P;iSplit;eauto]); - try (iDestruct (extract_from_region_inv with "Hinterp") as (P) "[Hinv Hiff]"; [eauto|iExists P;iSplit;eauto]). + destruct p,g; try contradiction; try done. + all: try (iDestruct (extract_from_region_inv with "Hinterp") as (P Hpers) "[ [Hrcond Hinv] Hiff]"; eauto). + all: try (iDestruct (extract_from_region_inv with "Hinterp") as "[Hinv Hiff]";eauto;iExists interp;iFrame "Hinv";rewrite /rcond /wcond /=). + all: try (iDestruct (extract_from_region_inv with "Hinterp") as (p) "[ % [Hinv Hiff] ]"; eauto). + all: try (iExists (fixpoint interp1);iFrame "Hinv"). + all: try (iSplitR;[iPureIntro;apply _|auto]). + all: try (iSplit;[iSplit|];auto;iNext;iModIntro;iIntros (W1 W2 z) "_" + ;rewrite fixpoint_interp1_eq;auto). Qed. - (* Lemma for allocating invariants in a region *) - Lemma region_inv_alloc E l1 l2 : - ([∗ list] k;v ∈ l1;l2, k ↦ₐ v ∗ interp v) ={E}=∗ - ([∗ list] k;_ ∈ l1;l2, inv (logN .@ k) (interp_ref_inv k interp)). - Proof. - revert l2. induction l1. - - iIntros (l2) "Hl". - iDestruct (big_sepL2_length with "Hl") as %Hlen. - destruct l2;[|inversion Hlen]. - simpl. done. - - iIntros (l2) "Hl". - iDestruct (big_sepL2_length with "Hl") as %Hlen. - destruct l2;[inversion Hlen|]. - iDestruct "Hl" as "[Ha Hl]". - simpl. iMod (IHl1 with "Hl") as "Hl". - iFrame. iApply inv_alloc. iNext. iExists w. iFrame. - Qed. - - (* Get the validity of a region containing only integers *) - Lemma region_integers_alloc E (b e a: Addr) l p : - Forall (λ w, is_z w = true) l → - PermFlowsTo RO p → - ([∗ list] a;w ∈ finz.seq_between b e;l, a ↦ₐ w) ={E}=∗ - interp (WCap p b e a). - Proof. - iIntros (Hl Hp) "H". - iMod (region_inv_alloc with "[H]") as "H". - { iApply (big_sepL2_mono with "H"). - intros k v1 v2 ? Hlk. cbn. iIntros. iFrame. - pose proof (Forall_lookup_1 _ _ _ _ Hl Hlk) as HH. - cbn in HH. destruct_word v2; try by inversion HH. - rewrite fixpoint_interp1_eq //. } - iDestruct (big_sepL2_length with "H") as %?. - iDestruct (big_sepL2_to_big_sepL_l with "H") as "H"; auto. - - iModIntro. rewrite fixpoint_interp1_eq //. - destruct p; cbn; eauto; try by inversion Hp. - all: iApply (big_sepL_mono with "H"). - all: iIntros (k a' Hk) "H"; cbn. - all: iExists (fixpoint interp1); iFrame. - all: try iSplit; iNext; iModIntro; eauto. - Qed. - - (* Get the validity of a region containing only valid String.words *) - Lemma region_valid_alloc E (b e a: Addr) l p : - PermFlowsTo RO p → - ([∗ list] w ∈ l, interp w) -∗ - ([∗ list] a;w ∈ finz.seq_between b e;l, a ↦ₐ w) ={E}=∗ - interp (WCap p b e a). - Proof. - iIntros (Hp) "#Hl H". - iMod (region_inv_alloc with "[H]") as "H". - { iDestruct (big_sepL2_length with "H") as %Hlen. - iDestruct (big_sepL2_to_big_sepL_r with "Hl") as "Hl'";[apply Hlen|]. - iDestruct (big_sepL2_sep with "[H]") as "H";[iSplitL;[iFrame "H"|iFrame "Hl'"]|]. - iApply (big_sepL2_mono with "H"). - intros k v1 v2 ? Hlk. cbn. iIntros. iFrame. } - iDestruct (big_sepL2_length with "H") as %?. - iDestruct (big_sepL2_to_big_sepL_l with "H") as "H"; auto. - - iModIntro. rewrite fixpoint_interp1_eq //. - destruct p; cbn; eauto; try by inversion Hp. - all: iApply (big_sepL_mono with "H"). - all: iIntros (k a' Hk) "H"; cbn. - all: iExists (fixpoint interp1); iFrame. - all: try iSplit; iNext; iModIntro; eauto. - Qed. - - Definition compute_mask (E : coPset) (ls : gset Addr) := - set_fold (λ l E, E ∖ ↑logN .@ l) E ls. - - Lemma compute_mask_mono E ls : - compute_mask E ls ⊆ E. + Lemma extract_from_region_inv_regs a (a' b e : Addr) p g W r : + (b ≤ a' ∧ a' < e)%Z → + readAllowed p → + ⊢ (interp_registers W r -∗ + region_conditions W p g b e -∗ + (∃ (P : D), ⌜(∀ Wv, Persistent (P Wv.1 Wv.2))⌝ + ∗ rel a' (λ Wv, P Wv.1 Wv.2) + ∗ rcond P interp + ∗ if decide (writeAllowed_in_r_a (<[PC:=WCap p g b e a]> r) a') + then wcond P interp + else emp))%I. Proof. - rewrite /compute_mask. revert E. - induction ls using set_ind_L; intros E. - { by rewrite set_fold_empty. } - rewrite set_fold_disj_union_strong; [|set_solver..]. - rewrite set_fold_singleton. - etransitivity; [apply IHls|]. - set_solver. + iIntros (Hin Ra) "#Hregs #Hinterp". + rewrite /interp_registers /interp_reg /=. + iDestruct "Hregs" as "[Hfull Hregvalid]". + case_decide as Hinra. + - destruct Hinra as [reg (wa & Hra & Hwa & Ha) ]. + destruct (decide (reg = PC)). + + simplify_map_eq. + rewrite /interp. cbn. + destruct p,g; try contradiction; inversion Hwa; try done; + try (iDestruct (extract_from_region_inv with "Hinterp") as "[Hinv Hiff]"; eauto). + all: iExists interp;iFrame "Hinv". + all: rewrite /rcond /wcond /=. + all: iSplitR;[iPureIntro;apply _|]. + all: try (iSplit;[iSplit|];auto;iNext;iModIntro;iIntros (W1 W2 z) "_";rewrite fixpoint_interp1_eq;auto). + + simplify_map_eq. + destruct wa; try inv Ha. + destruct sb; try inv Ha. + iSpecialize ("Hregvalid" $! _ _ n Hra). + iClear "Hinterp". + rewrite /interp. cbn. rewrite fixpoint_interp1_eq /=; cbn. + destruct p0,g0; try contradiction; inversion Hwa; try done ; subst. + all: try (iDestruct (extract_from_region_inv with "Hregvalid") as "[Hinv Hiff]";eauto;iExists interp;iFrame "Hinv";rewrite /rcond /wcond /=). + all: try (iSplitR;[iPureIntro;apply _|]). + all: try (iSplit;[iSplit|];auto;iNext;iModIntro;iIntros (W1 W2 z) "_";rewrite fixpoint_interp1_eq;auto). + all: iDestruct (extract_from_region_inv with "Hregvalid") as (p' Hp') "[Hinv Hiff]"; eauto + ;iExists interp;iFrame "Hinv";rewrite /rcond /wcond /=. + all: try (iSplitR;[iPureIntro;apply _|]). + all: try (iSplit;[iSplit|];auto;iNext;iModIntro;iIntros (W1 W2 z) "_";rewrite fixpoint_interp1_eq;auto). + - rewrite /interp. cbn. + destruct p,g; try contradiction; try done. all: rewrite /region_conditions /=. + all: try (iDestruct (extract_from_region_inv with "Hinterp") as "[Ha _]"; eauto; iDestruct "Ha" as (P Hpers) "[Ha Hcond]";iExists P;iFrame "Ha Hcond"). + all: try (iDestruct (extract_from_region_inv with "Hinterp") as "[Hinv Hiff]";eauto;iExists interp;iFrame "Hinv";rewrite /rcond /wcond /=). + all: iSplitR;[iPureIntro;apply _|]. + all: try (iSplit;[iSplit|];auto;iNext;iModIntro;iIntros (W1 W2 z) "_";rewrite fixpoint_interp1_eq;auto). Qed. - Lemma compute_mask_subseteq E (ls1 ls2 : gset Addr) : - ls2 ⊆ ls1 → compute_mask E ls1 ⊆ compute_mask E ls2. - Proof. - rewrite /compute_mask. - revert E ls1. - induction ls2 using set_ind_L. - { intros E ls1 Hle. rewrite set_fold_empty. apply compute_mask_mono. } - intros E ls1 Hle. - rewrite set_fold_disj_union_strong; [|set_solver..]. - rewrite set_fold_singleton. - assert (∃ Y, ls1 = {[x]} ∪ Y ∧ {[x]} ## Y) as [Y [-> Hdisj] ]. - { apply subseteq_disjoint_union_L. set_solver. } - rewrite set_fold_disj_union_strong; [|set_solver..]. - rewrite set_fold_singleton. - apply IHls2. set_solver. - Qed. - - Lemma compute_mask_elem_of E l ls : - ↑(logN .@ l) ⊆ E → l ∉ ls → ↑logN.@l ⊆ compute_mask E ls. + Lemma writeLocalAllowed_valid_cap_implies W p g b e a: + pwl p = true -> + withinBounds b e a = true -> + interp W (WCap p g b e a) -∗ + ⌜std W !! a = Some Monotemporary⌝. Proof. - rewrite /compute_mask. - revert E. - induction ls using set_ind_L. - { set_solver. } - intros E HE Hnin. - rewrite set_fold_disj_union_strong; [|set_solver..]. - rewrite set_fold_singleton. - rewrite not_elem_of_union in Hnin. destruct Hnin as [Hnin1 Hnin2]. - apply IHls; [|done]. - assert (logN.@l ## logN.@x). - { apply ndot_ne_disjoint. set_solver. } - set_solver. - Qed. - - Lemma compute_mask_id E : - compute_mask E ∅ = E. - Proof. auto. Qed. - - Definition in_region (w : Word) (b e : Addr) := - match w with - | WCap p b' e' a => PermFlows RO p /\ (b <= b')%a /\ (e' <= e)%a - | _ => False - end. - - Definition in_region_list (w : Word) (ls: list Addr) := - match w with - | WCap p b' e' a => PermFlows RO p /\ (forall x, b' <= x < e' -> x ∈ ls)%a - | _ => False - end. + intros Hp Hb. iIntros "Hvalid". + eapply withinBounds_le_addr in Hb. + unfold interp; rewrite fixpoint_interp1_eq /=. + destruct p; simpl in Hp; try congruence; destruct g;try done. + - iDestruct (extract_from_region_inv with "Hvalid") as (p' Hp') "[_ %]"; eauto. + - iDestruct (extract_from_region_inv with "Hvalid") as (p' Hp') "[_ %]"; eauto. + Qed. - Lemma region_valid_in_region_ind E (l1 l2 : list Addr) : - Forall (λ a, ↑logN.@a ⊆ E) (l1 ++ l2) -> - NoDup l1 -> NoDup l2 -> - l2 ## l1 -> - ([∗ list] a ∈ l1, inv (logN .@ a) (interp_ref_inv a interp)) -∗ - ([∗ list] a ∈ l2, ∃ w, a ↦ₐ w ∗ ⌜is_z w = true \/ in_region_list w (l1 ++ l2)⌝) -∗ - |={compute_mask E (list_to_set l1)}=> ([∗ list] a ∈ l1 ++ l2, inv (logN .@ a) (interp_ref_inv a interp)). - Proof. - iIntros (Hforall Hdup1 Hdup2 Hdisj) "Hval Hl2". - iInduction l2 as [|] "IH" - forall (l1 Hdup2 Hforall Hdup1 Hdisj);iDestruct "Hval" as "#Hval". - { simpl. rewrite app_nil_r. iFrame "#". iModIntro. done. } - iDestruct "Hl2" as "[Hl Hl2]". - iDestruct "Hl" as (w) "[Hl %Hcond]". - apply NoDup_cons in Hdup2 as [Hni Hdup2]. - apply disjoint_cons in Hdisj as Hni'. - apply disjoint_swap in Hdisj;auto. - destruct Hcond as [Hint | Hin]. - - destruct w;try done. - iMod (inv_alloc (logN .@ a) _ (interp_ref_inv a interp) with "[Hl]") as "#Hlval". - { iNext. iExists _. iFrame. iApply fixpoint_interp1_eq. eauto. } - iMod (fupd_mask_subseteq (compute_mask E (list_to_set (a :: l1)))) as "Hclose"; - [apply compute_mask_subseteq; set_solver|]. - iMod ("IH" $! (a :: l1) with "[] [] [] [] [] [Hl2]") as "HH";auto. - { iPureIntro. simpl. rewrite Permutation_middle. auto. } - { iPureIntro. apply NoDup_cons;auto. } - { iSimpl. iFrame "#". } - { iApply (big_sepL_mono with "Hl2"). iIntros (k x Hx) "Hc". - iDestruct "Hc" as (w) "[Hx [Hw|%Hw]]";iExists _;iFrame;[iLeft;auto|]. - iRight. iPureIntro. destruct w;try done. destruct sb;try done. - destruct Hw as [Hro Hb]. split;auto. - intros y Hy. simpl. rewrite Permutation_middle. apply Hb;auto. } - iDestruct (big_sepL_app with "HH") as "[#Hl1 #Hl2]". - iFrame "∗ #". iMod ("Hclose"). auto. - - destruct w;try done. destruct sb;try done. destruct Hin as [Hro Hin]. - iApply big_sepL_app. iFrame "#". - iMod (inv_alloc_open (logN .@ a) _ (interp_ref_inv a interp)) as "[#Ha Hcls]". - { apply compute_mask_elem_of. - { revert Hforall; rewrite Forall_forall =>Hforall. apply Hforall. - apply elem_of_app;right;apply elem_of_cons;auto. } - apply not_elem_of_list_to_set. auto. } - iFrame "#". - iMod (fupd_mask_subseteq (compute_mask E (list_to_set (a :: l1)))) as "Hclose". - { rewrite /compute_mask. - rewrite list_to_set_cons union_comm_L. - rewrite (set_fold_disj_union_strong _ _ _ (list_to_set l1) {[a]}). - - rewrite set_fold_singleton. done. - - set_solver. - - set_solver. } - iMod ("IH" $! (a :: l1) with "[] [] [] [] [] [Hl2]") as "HH";auto. - { iPureIntro. simpl. rewrite Permutation_middle. auto. } - { iPureIntro. apply NoDup_cons;auto. } - { iSimpl. iFrame "#". } - { iApply (big_sepL_mono with "Hl2"). iIntros (k x Hx) "Hc". - iDestruct "Hc" as (w) "[Hx [Hw|%Hw]]";iExists _;iFrame;[iLeft;auto|]. - iRight. iPureIntro. destruct w;try done. destruct sb;try done. - destruct Hw as [Hro' Hb]. split;auto. - intros y Hy. simpl. rewrite Permutation_middle. apply Hb;auto. } - iMod "Hclose". - iSimpl in "HH";iDestruct "HH" as "[#Hav HH]". - iDestruct (big_sepL_app with "HH") as "[#Hl1v #Hl2v]". - iMod ("Hcls" with "[Hl]");[|by iFrame "#"]. - iNext. iExists _. iFrame. - iApply fixpoint_interp1_eq. destruct p;try done. - all: iApply big_sepL_forall; iIntros (k x Hlook); iExists interp. - all: iSplit;[|(try iSplitR);iIntros (?);iNext;iModIntro;auto]. - all: apply elem_of_list_lookup_2,elem_of_finz_seq_between,Hin,elem_of_app in Hlook. - all: destruct Hlook as [Hl1 | [->|Hl2]%elem_of_cons]; - [iDestruct (big_sepL_elem_of with "Hl1v") as "$";auto|iFrame "#"| - iDestruct (big_sepL_elem_of with "Hl2v") as "$";auto]. - Unshelve. all: apply _. - Qed. - - Lemma region_valid_in_region E (b e a: Addr) l p : - Forall (λ a0 : Addr, ↑logN.@a0 ⊆ E) (finz.seq_between b e) -> - PermFlowsTo RO p → - Forall (λ w, is_z w = true \/ in_region w b e) l -> - ([∗ list] a;w ∈ finz.seq_between b e;l, a ↦ₐ w) ={E}=∗ - interp (WCap p b e a). - Proof. - iIntros (Hsub Hperm Hl) "Hl". - iDestruct (region_valid_in_region_ind E [] (finz.seq_between b e) with "[] [Hl]") as "HH". - { rewrite app_nil_l. auto. } - { apply NoDup_nil. auto. } - { apply finz_seq_between_NoDup. } - { eapply disjoint_nil_r. exact 0%a. } - { auto. } - { rewrite app_nil_l. - iDestruct (big_sepL2_length with "Hl") as %Hlen. - iApply big_sepL2_to_big_sepL_l;[apply Hlen|]. - iApply (big_sepL2_mono with "Hl"). - iIntros (k y1 y2 Hy1 Hy2) "Hl". - iExists _; iFrame. iPureIntro. - rewrite Forall_lookup in Hl. - apply Hl in Hy2 as [Hy2|Hy2];auto. - right. destruct y2;try done. destruct sb;try done. - destruct Hy2 as [Hro Hin]. - split;auto. intros x Hx. apply elem_of_finz_seq_between. - solve_addr. } - { rewrite list_to_set_nil compute_mask_id app_nil_l. iMod "HH". - iModIntro. - iApply fixpoint_interp1_eq. destruct p;try done. - all: iApply (big_sepL_mono with "HH");iIntros (k y Hy) "Hl"; - try iExists _;iFrame;try iSplit;iIntros (?);auto. } - Qed. - - Lemma region_seal_pred_interp E (b e a: OType) b1 b2 : - ([∗ list] o ∈ finz.seq_between b e, seal_pred o interp) ={E}=∗ - interp (WSealRange (b1,b2) b e a). + Lemma region_seal_pred_interp E W (b e a: OType) b1 b2 g : + ([∗ list] o ∈ finz.seq_between b e, (∀ W, seal_pred o (interp W))) ={E}=∗ + interp W (WSealRange (b1,b2) g b e a). Proof. remember (finz.seq_between b e) as l eqn:Hgen. rewrite Hgen; revert Hgen. generalize b e. clear b e. @@ -625,21 +781,26 @@ Section logrel. all: iApply (big_sepL_mono with "Hfirst"). all: iIntros (k a' Hk) "H"; cbn. all: iExists _; iFrame; auto. - iSplit; auto. iPureIntro; apply _. + all: iSplit; auto. + all: try (iPureIntro; apply _). + rewrite /wcond;auto. + iNext ; iModIntro; iIntros (? ? ?) "?"; rewrite !fixpoint_interp1_eq //=. Qed. - (* Get the validity of sealing capabilities if we can allocate an arbitrary predicate, and can hence choose interp itself as the sealing predicate *) - Lemma region_can_alloc_interp E (b e a: OType) b1 b2: - ([∗ list] o ∈ finz.seq_between b e, can_alloc_pred o) ={E}=∗ - interp (WSealRange (b1,b2) b e a). - Proof. - iIntros "Hca". - iDestruct (big_sepL_mono with "Hca") as "Hca". - iIntros (k a' Hk) "H". iDestruct (seal_store_update_alloc _ interp with "H") as "H". iExact "H". - iDestruct (big_sepL_bupd with "Hca") as "Hca". - iMod "Hca". - by iApply region_seal_pred_interp. - Qed. + (* Get the validity of sealing capabilities if we can allocate an arbitrary predicate, + and can hence choose interp itself as the sealing predicate *) + (* Lemma region_can_alloc_interp E W (b e a: OType) b1 b2 g: *) + (* ([∗ list] o ∈ finz.seq_between b e, can_alloc_pred o) ={E}=∗ *) + (* interp W (WSealRange (b1,b2) g b e a). *) + (* Proof. *) + (* iIntros "Hca". *) + (* iDestruct (big_sepL_mono with "Hca") as "Hca". *) + (* iIntros (k a' Hk) "H". iDestruct (seal_store_update_alloc _ (interp W) with "H") as "H". iExact "H". *) + + (* iDestruct (big_sepL_bupd with "Hca") as "Hca". *) + (* iMod "Hca". *) + (* by iApply region_seal_pred_interp. *) + (* Qed. *) End logrel. diff --git a/theories/monotone.v b/theories/monotone.v index 295227a6..2e8a3b1c 100644 --- a/theories/monotone.v +++ b/theories/monotone.v @@ -1,315 +1,838 @@ -(** Author: Amin Timany *) - -From iris.algebra Require Export cmra auth. -From iris.base_logic Require Import base_logic. -Local Arguments validN _ _ _ !_ /. -Local Arguments valid _ _ !_ /. -Local Arguments op _ _ _ !_ /. -Local Arguments pcore _ _ !_ /. -Local Arguments ofe_dist !_ /. -Local Arguments ofe_equiv ! _ /. - -Definition monotone {A : Type} (R : relation A) : Type := list A. - -Definition principal {A : Type} (R : relation A) (a : A) : - monotone R := [a]. +From iris.proofmode Require Import proofmode. +From iris.program_logic Require Export weakestpre. +From cap_machine Require Export logrel region_invariants_transitions. +From iris.base_logic Require Export invariants na_invariants saved_prop. +Import uPred. Section monotone. -Local Set Default Proof Using "Type". -Context {A : ofe} {R : relation A}. -Implicit Types a b : A. -Implicit Types x y : monotone R. - -Definition Below (a : A) (x : monotone R) := ∃ b, b ∈ x ∧ R a b. - -Lemma Below_app a x y : Below a (x ++ y) ↔ Below a x ∨ Below a y. -Proof. - split. - - intros (b & [|]%elem_of_app & ?); [left|right]; exists b; eauto. - - intros [(b & Hb1 & Hb2)|(b & Hb1 & Hb2)]; exists b; rewrite elem_of_app; eauto. -Qed. - -Lemma Below_principal a b : Below a (principal R b) ↔ R a b. -Proof. - split. - - intros (c & ->%elem_of_list_singleton & ?); done. - - intros Hab; exists b; split; first apply elem_of_list_singleton; done. -Qed. - -(* OFE *) -Instance monotone_dist : Dist (monotone R) := - λ n x y, ∀ a, Below a x ↔ Below a y. - -Instance monotone_equiv : Equiv (monotone R) := λ x y, ∀ n, x ≡{n}≡ y. - -Definition monotone_ofe_mixin : OfeMixin (monotone R). -Proof. - split. - - rewrite /equiv /monotone_equiv /dist /monotone_dist; intuition auto using O. - - intros n; split. - + rewrite /dist /monotone_dist /equiv /monotone_equiv; intuition. - + rewrite /dist /monotone_dist /equiv /monotone_equiv; intros ? ? Heq a. - split; apply Heq. - + rewrite /dist /monotone_dist /equiv /monotone_equiv; - intros ? ? ? Heq Heq' a. - split; intros Hxy. - * apply Heq'; apply Heq; auto. - * apply Heq; apply Heq'; auto. - - intros n x y; rewrite /dist /monotone_dist; auto. -Qed. -Canonical Structure monotoneC := Ofe (monotone R) monotone_ofe_mixin. - -(* CMRA *) -Instance monotone_validN : ValidN (monotone R) := λ n x, True. -Instance monotone_valid : Valid (monotone R) := λ x, True. - -Program Instance monotone_op : Op (monotone R) := λ x y, x ++ y. -Instance monotone_pcore : PCore (monotone R) := Some. - -Instance monotone_comm : Comm (≡) (@op (monotone R) _). -Proof. - intros x y n a; rewrite /Below. - setoid_rewrite elem_of_app; split=> Ha; firstorder. -Qed. -Instance monotone_assoc : Assoc (≡) (@op (monotone R) _). -Proof. - intros x y z n a; rewrite /Below /=. - repeat setoid_rewrite elem_of_app; split=> Ha; firstorder. -Qed. -Lemma monotone_idemp (x : monotone R) : x ⋅ x ≡ x. -Proof. - intros n a; rewrite /Below. - setoid_rewrite elem_of_app; split=> Ha; firstorder. -Qed. - -Instance monotone_validN_ne n : - Proper (dist n ==> impl) (@validN (monotone R) _ n). -Proof. intros x y ?; rewrite /impl; auto. Qed. -Instance monotone_validN_proper n : Proper (equiv ==> iff) (@validN (monotone R) _ n). -Proof. move=> x y /equiv_dist H; auto. Qed. - -Instance monotone_op_ne' x : NonExpansive (op x). -Proof. - intros n y1 y2; rewrite /dist /monotone_dist /equiv /monotone_equiv /Below. - rewrite /=; setoid_rewrite elem_of_app => Heq a. - specialize (Heq a); destruct Heq as [Heq1 Heq2]. - split; intros [b [[Hb|Hb] HRb]]; eauto. - - destruct Heq1 as [? [? ?]]; eauto. - - destruct Heq2 as [? [? ?]]; eauto. -Qed. -Instance monotone_op_ne : NonExpansive2 (@op (monotone R) _). -Proof. by intros n x1 x2 Hx y1 y2 Hy; rewrite Hy !(comm _ _ y2) Hx. Qed. -Instance monotone_op_proper : Proper ((≡) ==> (≡) ==> (≡)) (@op (monotone R) _) := ne_proper_2 _. - -Lemma monotone_included (x y : monotone R) : x ≼ y ↔ y ≡ x ⋅ y. -Proof. - split; [|by intros ?; exists y]. - by intros [z Hz]; rewrite Hz assoc monotone_idemp. -Qed. - -Definition monotone_cmra_mixin : CmraMixin (monotone R). -Proof. - apply cmra_total_mixin; try apply _ || by eauto. - - intros ?; apply monotone_idemp. - - rewrite /equiv /monotone_equiv /dist /monotone_dist; eauto. -Qed. -Canonical Structure monotoneR : cmra := Cmra (monotone R) monotone_cmra_mixin. - -Global Instance monotone_cmra_total : CmraTotal monotoneR. -Proof. rewrite /CmraTotal; eauto. Qed. -Global Instance monotone_core_id (x : monotone R) : CoreId x. -Proof. by constructor. Qed. - -Global Instance monotone_cmra_discrete : CmraDiscrete monotoneR. -Proof. - split; auto. - intros ? ?. - rewrite /dist /equiv /= /cmra_dist /cmra_equiv /= - /monotone_dist /monotone_equiv /dist /monotone_dist; eauto. -Qed. - -Instance monotone_empty : Unit (monotone R) := @nil A. -Lemma auth_ucmra_mixin : UcmraMixin (monotone R). -Proof. split; done. Qed. - -Canonical Structure monotoneUR := Ucmra (monotone R) auth_ucmra_mixin. - -Global Instance principal_ne - `{HRne : !∀ n, Proper ((dist n) ==> (dist n) ==> iff) R} : - NonExpansive (principal R). -Proof. intros n a1 a2 Ha; split; rewrite /= !Below_principal !Ha; done. Qed. - -Global Instance principal_proper - {HRne : ∀ n, Proper ((dist n) ==> (dist n) ==> iff) R} : - Proper ((≡) ==> (≡)) (principal R) := ne_proper _. - -Global Instance principal_discrete a : Discrete (principal R a). -Proof. - intros y; rewrite /dist /ofe_dist /= /equiv /ofe_equiv /= /monotone_equiv; - eauto. -Qed. - -Lemma principal_injN_general n a b : - principal R a ≡{n}≡ principal R b → R a a → R a b. -Proof. - rewrite /principal /dist /monotone_dist => Hab Haa. - - destruct (Hab a) as [Ha _]; edestruct Ha as [? [?%elem_of_list_singleton ?]]; - subst; eauto. - eexists _; split; first apply elem_of_list_singleton; eauto. -Qed. - -Lemma principal_inj_general a b : - principal R a ≡ principal R b → R a a → R a b. -Proof. intros Hab; apply (principal_injN_general 0); eauto. Qed. - -Global Instance principal_injN_general' `{!Reflexive R} n : - Inj (λ a b, R a b ∧ R b a) (dist n) (principal R). -Proof. - intros x y Hxy; split; eapply (principal_injN_general n); eauto. -Qed. - -Global Instance principal_inj_general' `{!Reflexive R} : - Inj (λ a b, R a b ∧ R b a) (≡) (principal R). -Proof. - intros x y Hxy; specialize (Hxy 0); eapply principal_injN_general'; eauto. -Qed. - -Global Instance principal_injN `{!Reflexive R} {Has : AntiSymm (≡) R} n : - Inj (dist n) (dist n) (principal R). -Proof. - intros x y [Hxy Hyx]%principal_injN_general'. - erewrite (@anti_symm _ _ _ Has); eauto. -Qed. -Global Instance principal_inj `{!Reflexive R} `{!AntiSymm (≡) R} : - Inj (≡) (≡) (principal R). -Proof. intros ???. apply equiv_dist=>n. by apply principal_injN, equiv_dist. Qed. - -Lemma principal_R_opN_base `{!Transitive R} n x y : - (∀ b, b ∈ y → ∃ c, c ∈ x ∧ R b c) → y ⋅ x ≡{n}≡ x. -Proof. - intros HR; split; rewrite /op /monotone_op Below_app; [|by firstorder]. - intros [(c & (d & Hd1 & Hd2)%HR & Hc2)|]; [|done]. - exists d; split; [|transitivity c]; done. -Qed. - -Lemma principal_R_opN `{!Transitive R} n a b : - R a b → principal R a ⋅ principal R b ≡{n}≡ principal R b. -Proof. - intros; apply principal_R_opN_base; intros c; rewrite /principal. - setoid_rewrite elem_of_list_singleton => ->; eauto. -Qed. - -Lemma principal_R_op `{!Transitive R} a b : - R a b → principal R a ⋅ principal R b ≡ principal R b. -Proof. by intros ? ?; apply principal_R_opN. Qed. - -Lemma principal_op_RN n a b x : - R a a → principal R a ⋅ x ≡{n}≡ principal R b → R a b. + Context {Σ:gFunctors} + {ceriseg: ceriseG Σ} {sealsg: sealStoreG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} + {nainv: logrel_na_invs Σ} + `{MP:MachineParameters}. + + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Lemma region_state_nwl_monotone W W' a l : + related_sts_pub_world W W' → + region_state_nwl W a l -> region_state_nwl W' a l. + Proof. + rewrite /region_state_nwl /std. + intros Hrelated Hstate. + destruct l. + - destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. } + specialize (Hrelated a Permanent y Hstate Hy). + apply std_rel_pub_rtc_Permanent in Hrelated; subst; auto. + - destruct Hrelated as [ [Hdom_sta Hrelated] _]. simpl in *. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom. + eauto. } + specialize (Hrelated _ Permanent y Hstate Hy). + apply std_rel_pub_rtc_Permanent in Hrelated; subst; auto. + Qed. + + Lemma region_state_nwl_monotone_a W W' (a a' : Addr) l : + (a < a')%a → + related_sts_a_world W W' a' → + region_state_nwl W a l -> region_state_nwl W' a l. + Proof. + rewrite /region_state_nwl /std. + intros Hlt Hrelated Hstate. + destruct l. + - destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. } + specialize (Hrelated a Permanent y Hstate Hy). + eapply rtc_implies in Hrelated. + apply std_rel_pub_plus_rtc_Permanent in Hrelated; subst; auto. + intros r q. destruct (decide (a' <= a)%a);auto. + - destruct Hrelated as [ [Hdom_sta Hrelated] _]. simpl in *. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom. + eauto. } + specialize (Hrelated _ Permanent y Hstate Hy). + eapply rtc_implies in Hrelated. + apply std_rel_pub_plus_rtc_Permanent in Hrelated; subst; auto. + intros r q. destruct (decide (a' <= a)%a);auto. + Qed. + + Lemma region_state_nwl_monotone_nm W W' a : + related_sts_priv_world W W' → + region_state_nwl W a Local -> region_state_nwl W' a Local. + Proof. + rewrite /region_state_nwl /std. + intros Hrelated Hstate. + destruct Hrelated as [ [Hdom_sta Hrelated ] _]. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. } + specialize (Hrelated _ Permanent y Hstate Hy). + apply std_rel_rtc_Permanent in Hrelated; subst; auto. + Qed. + + Lemma region_state_nwl_monotone_nm_nl W W' a : + related_sts_priv_world W W' → + region_state_nwl W a Global -> region_state_nwl W' a Global. + Proof. + rewrite /region_state_nwl /std. + intros Hrelated Hstate. + destruct Hrelated as [ [Hdom_sta Hrelated ] _]. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. } + specialize (Hrelated _ Permanent y Hstate Hy). + apply std_rel_rtc_Permanent in Hrelated; subst; auto. + Qed. + + Lemma region_state_pwl_monotone_mono W W' a : + related_sts_pub_world W W' → + region_state_pwl W a -> region_state_pwl W' a. + Proof. + rewrite /region_state_pwl /std. + intros Hrelated Hstate. + destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. } + specialize (Hrelated _ Monotemporary y Hstate Hy). + apply std_rel_pub_rtc_Monotemporary in Hrelated; subst; auto. + Qed. + + Lemma region_state_pwl_monotone_a W W' a a' : + (a < a')%a → + related_sts_a_world W W' a' → + region_state_pwl W a -> region_state_pwl W' a. + Proof. + rewrite /region_state_pwl /std. + intros Hle Hrelated Hstate. + destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. } + specialize (Hrelated _ Monotemporary y Hstate Hy). + eapply rtc_implies in Hrelated. + apply std_rel_pub_rtc_Monotemporary in Hrelated; subst; auto. + intros r q. rewrite decide_False;auto. solve_addr. + Qed. + + (* Lemma region_state_nwl_future W W' l l' p a a': *) + (* (a < a')%a → *) + (* LocalityFlowsTo l' l -> *) + (* (if pwlU p then l = Directed else True) -> *) + (* (@future_world Σ l' a' W W') -∗ *) + (* ⌜if pwlU p then region_state_pwl_mono W a else region_state_nwl W a l⌝ -∗ *) + (* ⌜region_state_nwl W' a l'⌝. *) + (* Proof. *) + (* intros Hlt Hlflows Hloc. iIntros "Hfuture %". *) + (* destruct l'; simpl; iDestruct "Hfuture" as %Hf; iPureIntro. *) + (* - assert (l = Global) as -> by (destruct l; simpl in Hlflows; tauto). *) + (* destruct (pwlU p) eqn:HpwlU; try congruence. *) + (* eapply region_state_nwl_monotone_nm_nl; eauto. *) + (* - destruct (pwlU p). *) + (* + subst l. inversion Hlflows. *) + (* + eapply region_state_nwl_monotone_nm_nl; eauto. *) + (* destruct l;inversion Hlflows;auto. *) + (* - destruct (pwlU p). *) + (* + subst l. simpl in *. *) + (* left. eapply region_state_pwl_monotone_a;eauto. *) + (* + destruct l. *) + (* * right. eapply region_state_nwl_monotone_nm_nl;eauto. *) + (* apply related_sts_pub_plus_priv_world. *) + (* eapply related_sts_a_pub_plus_world;eauto. *) + (* * right. eapply region_state_nwl_monotone_nm_nl;eauto. *) + (* apply related_sts_pub_plus_priv_world. *) + (* eapply related_sts_a_pub_plus_world;eauto. *) + (* * destruct H0 as [a0 | a0]. *) + (* left. eapply region_state_pwl_monotone_a;eauto. *) + (* right. eapply region_state_nwl_monotone_nm_nl;eauto. *) + (* apply related_sts_pub_plus_priv_world. *) + (* eapply related_sts_a_pub_plus_world;eauto. *) + (* Qed. *) + + (* Lemma region_state_U_monotone W W' a : *) + (* related_sts_priv_world W W' → *) + (* region_state_U W a -> region_state_U W' a. *) + (* Proof. *) + (* rewrite /region_state_U /std. *) + (* intros Hrelated Hstate. *) + (* destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. *) + (* assert (is_Some (W'.1 !! a)) as [y Hy]. *) + (* { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. } *) + (* specialize (Hrelated _ Permanent y Hstate Hy). *) + (* apply std_rel_rtc_Permanent in Hrelated; auto. subst y; auto. *) + (* Qed. *) + + (* Lemma region_state_U_monotone_mono W W' a : *) + (* related_sts_pub_plus_world W W' → *) + (* region_state_U_mono W a -> region_state_U_mono W' a. *) + (* Proof. *) + (* rewrite /region_state_U_mono /std. *) + (* intros Hrelated Hstate. *) + (* destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. *) + (* assert (is_Some (W'.1 !! a)) as [y Hy]. *) + (* { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. *) + (* destruct Hstate as [Hstate | [Hstate | [w Hstate] ] ];eauto. } *) + (* destruct Hstate as [Hstate | [Hstate | [w Hstate] ] ]. *) + (* - specialize (Hrelated _ _ y Hstate Hy). *) + (* apply std_rel_pub_plus_rtc_Monotemporary in Hrelated;eauto. *) + (* destruct Hrelated as [-> | [? ->] ];subst;rewrite Hy;eauto. *) + (* - specialize (Hrelated _ Permanent y Hstate Hy). *) + (* apply std_rel_pub_plus_rtc_Permanent in Hrelated; auto. subst y; auto. *) + (* - specialize (Hrelated _ _ y Hstate Hy). *) + (* eapply std_rel_pub_plus_rtc_Uninitialized in Hrelated; eauto. *) + (* destruct Hrelated as [-> | [? ->] ]; eauto. *) + (* Qed. *) + + (* Lemma region_state_U_pwl_monotone_mono W W' a : *) + (* related_sts_pub_world W W' → *) + (* region_state_U_pwl_mono W a -> region_state_U_pwl_mono W' a. *) + (* Proof. *) + (* rewrite /region_state_U /std. *) + (* intros Hrelated Hstate. *) + (* destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. *) + (* assert (is_Some (W'.1 !! a)) as [y Hy]. *) + (* { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. *) + (* destruct Hstate as [? | [? ?] ]; eauto. } *) + (* destruct Hstate as [Hstate|[? Hstate] ]. *) + (* - specialize (Hrelated _ Monotemporary y Hstate Hy). *) + (* destruct (decide (y = Monotemporary)); subst; left; auto. *) + (* apply std_rel_pub_rtc_Monotemporary in Hrelated; auto. contradiction. *) + (* - specialize (Hrelated _ (Uninitialized x) y Hstate Hy). *) + (* eapply std_rel_pub_rtc_Uninitialized in Hrelated; eauto. destruct Hrelated;subst y; [left | right]; eauto. *) + (* Qed. *) + + (* Lemma region_state_U_pwl_monotone_mono_a W W' a a' : *) + (* related_sts_a_world W W' a' → *) + (* region_state_U_pwl_mono W a -> region_state_U_pwl_mono W' a. *) + (* Proof. *) + (* rewrite /region_state_U /std. *) + (* intros Hrelated Hstate. *) + (* destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. *) + (* assert (is_Some (W'.1 !! a)) as [y Hy]. *) + (* { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom;eauto. *) + (* destruct Hstate as [? | [? ?] ]; eauto. } *) + (* destruct Hstate as [Hstate|[? Hstate] ]. *) + (* - specialize (Hrelated _ Monotemporary y Hstate Hy). *) + (* destruct (decide (y = Monotemporary)); subst; auto. left;auto. *) + (* destruct (decide (a' <= a)%a). *) + (* + apply std_rel_pub_plus_rtc_Monotemporary in Hrelated; subst;auto. *) + (* destruct Hrelated as [-> | [? ->] ]; *) + (* rewrite /region_state_U_pwl_mono;eauto. *) + (* + apply std_rel_pub_rtc_Monotemporary in Hrelated; subst;auto. contradiction. *) + (* - specialize (Hrelated _ (Uninitialized x) y Hstate Hy). *) + (* destruct (decide (a' <= a)%a). *) + (* + eapply std_rel_pub_plus_rtc_Uninitialized in Hrelated; eauto. *) + (* destruct Hrelated as [Hy' | [w' Hy'] ]; subst y; [left | right]; eauto. *) + (* + eapply std_rel_pub_rtc_Uninitialized in Hrelated; eauto. *) + (* destruct Hrelated; subst y; [left | right]; eauto. *) + (* Qed. *) + + (* The following lemma is not required for monotonicity, but is interesting for use in examples *) + Lemma region_state_U_pwl_monotone_same W W' g a : + related_sts_pub_world W W' → + (std W) !! a = Some (Monostatic g) -> (std W') !! a = Some (Monostatic g). + Proof. + rewrite /std. + intros Hrelated Hstate. + destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom ;eauto. } + specialize (Hrelated _ (Monostatic g) y Hstate Hy). + eapply std_rel_pub_rtc_Monostatic in Hrelated; eauto. subst. auto. + Qed. + + Lemma region_state_Revoked_monotone (W W' : WORLD) (a : Addr) : + related_sts_pub_world W W' → + (std W) !! a = Some Revoked -> + (std W') !! a = Some Revoked ∨ + (std W') !! a = Some Monotemporary ∨ + (std W') !! a = Some Permanent. + Proof. + rewrite /region_state_pwl /std. + intros Hrelated Hstate. + destruct Hrelated as [ [Hdom_sta Hrelated ] _]. simpl in *. + assert (is_Some (W'.1 !! a)) as [y Hy]. + { rewrite -elem_of_dom. apply elem_of_subseteq in Hdom_sta. apply Hdom_sta. rewrite elem_of_dom ;eauto. } + specialize (Hrelated _ Revoked y Hstate Hy). + apply std_rel_pub_rtc_Revoked in Hrelated; auto. + destruct Hrelated as [Hperm | [Hmono | Hrev] ]; subst; auto. + Qed. + + Lemma interp_monotone W W' w : + ⌜related_sts_pub_world W W'⌝ -∗ + interp W w -∗ interp W' w. + Proof. + iIntros (Hrelated) "#Hw". + rewrite /interp /= fixpoint_interp1_eq /=. + destruct w; rewrite fixpoint_interp1_eq /=; auto. + destruct sb,p; auto. + - iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as (P Hpers) "#[Hrw Hrel]". + iExists _. iSplit;eauto. iFrame "#". + iDestruct "Hrel" as %Hrel. + iPureIntro. apply region_state_nwl_monotone with W;auto. + - iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as "#[Hrw Hrel]". + iSplit;eauto. iFrame "#". + iDestruct "Hrel" as %Hrel. + iPureIntro. apply region_state_nwl_monotone with W;auto. + - destruct g; auto. + iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as (p) "(%Hflow & Hrw & %Hrel)". + eapply region_state_pwl_monotone_mono in Hrel;auto. + - iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as (P Hpers) "#[Hrw Hrel]". + iExists _. iSplit;eauto. iFrame "#". + iDestruct "Hrel" as %Hrel. + iPureIntro. apply region_state_nwl_monotone with W;auto. + - iModIntro. iIntros (r W''). + destruct g; simpl. + + iIntros (Hrelated'). + iAssert (future_world Global W W'')%I as "Hrelated". + { iPureIntro. apply related_sts_pub_priv_trans_world with W'; auto. } + iSpecialize ("Hw" $! r W'' with "Hrelated"). + iApply "Hw". + + iIntros (Hrelated'). + iAssert (future_world Local W W'')%I as "Hrelated". + { iPureIntro. apply related_sts_pub_priv_trans_world with W'; auto. } + iSpecialize ("Hw" $! r W'' with "Hrelated"). + iApply "Hw". + - iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as "#[Hrw Hrel]". + iSplit;eauto. iFrame "#". + iDestruct "Hrel" as %Hrel. + iPureIntro. apply region_state_nwl_monotone with W;auto. + - destruct g; auto. + iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as (p) "(%Hflow & Hrw & %Hrel)". + eapply region_state_pwl_monotone_mono in Hrel;auto. + Qed. + + (* Definition aOf (w : Word) : Addr := *) + (* match w with *) + (* | inl _ => addr_reg.top *) + (* | inr (p,_,_,e,a) => if isU p then a else e *) + (* end. *) + + (* TODO move region.v *) + Lemma region_addrs_lookup_le b e a n : + region_addrs b e !! n = Some a → + (a < e)%a. + Proof. + intros Hlookup. + assert (a ∈ (region_addrs b e)) as Hin. + { apply elem_of_list_lookup. eauto. } + apply elem_of_region_addrs in Hin as [? ?]. + solve_addr. + Qed. + + (* Lemma interp_monotone_a W W' w : *) + (* ⌜related_sts_a_world W W' (aOf w)⌝ -∗ *) + (* interp W w -∗ interp W' w. *) + (* Proof. *) + (* iIntros (Hrelated) "#Hw". *) + (* rewrite /interp /= fixpoint_interp1_eq /=. *) + (* destruct w; rewrite fixpoint_interp1_eq /=; auto. *) + (* destruct c,p,p,p,p; auto; simpl in Hrelated. *) + (* - iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as (P Hpers) "#[Hrw Hrel]". *) + (* iExists _. iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_nwl_monotone_a with W a0;auto. *) + (* eapply region_addrs_lookup_le;eauto. *) + (* - iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_nwl_monotone_a with W a0;auto. eapply region_addrs_lookup_le;eauto. *) + (* - destruct l; auto. *) + (* iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. *) + (* apply region_state_pwl_monotone_a with W a0;auto. eapply region_addrs_lookup_le;eauto. *) + (* - iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as (P Hpers) "#[Hrw Hrel]". *) + (* iExists _. iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_nwl_monotone_a with W a0;auto. eapply region_addrs_lookup_le;eauto. *) + (* - iModIntro. iIntros (r W''). *) + (* destruct l; simpl. *) + (* + iIntros (Hrelated'). *) + (* iAssert (future_world Global a W W'')%I as "Hrelated". *) + (* { iPureIntro. apply related_sts_a_priv_trans_world with W' a0; auto. } *) + (* iSpecialize ("Hw" $! r W'' with "Hrelated"). *) + (* iApply "Hw". *) + (* + iIntros (Hrelated'). *) + (* iAssert (future_world Local a W W'')%I as "Hrelated". *) + (* { iPureIntro. apply related_sts_a_priv_trans_world with W' a0; auto. } *) + (* iSpecialize ("Hw" $! r W'' with "Hrelated"). *) + (* iApply "Hw". *) + (* + iIntros (Hrelated'). *) + (* iAssert (future_world Directed a0 W W'')%I as "Hrelated". *) + (* { iPureIntro. apply related_sts_a_trans_world with W';auto. } *) + (* iSpecialize ("Hw" $! r W'' with "Hrelated"). *) + (* iApply "Hw". *) + (* - iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_nwl_monotone_a with W a0;auto. eapply region_addrs_lookup_le;eauto. *) + (* - destruct l; auto. *) + (* iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_pwl_monotone_a with W a0;auto. eapply region_addrs_lookup_le;eauto. *) + (* - destruct l; simpl. *) + (* + iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. apply region_state_nwl_monotone_nm_nl with W;auto. *) + (* apply related_sts_pub_plus_priv_world, related_sts_a_pub_plus_world with a;auto. *) + (* + iDestruct "Hw" as "[Hw1 Hw2]". *) + (* iSplitL "Hw1". *) + (* * iApply (big_sepL_mono with "Hw1"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hstd. *) + (* iPureIntro. eapply (region_state_nwl_monotone_a W W' _ (addr_reg.min a a0) Local); auto. *) + (* eapply region_addrs_lookup_le;eauto. apply related_sts_a_weak_world with a;auto. solve_addr. *) + (* * iApply (big_sepL_mono with "Hw2"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. *) + (* eapply region_state_U_monotone; eauto. *) + (* apply related_sts_pub_plus_priv_world. apply related_sts_a_pub_plus_world with a;auto. *) + (* + iDestruct "Hw" as "[Hw1 Hw2]". *) + (* iSplitL "Hw1". *) + (* * iApply (big_sepL_mono with "Hw1"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hstd. *) + (* iPureIntro. eapply (region_state_nwl_monotone_a W W' _ (addr_reg.min a a0) Directed); auto. *) + (* eapply region_addrs_lookup_le;eauto. apply related_sts_a_weak_world with a;auto. solve_addr. *) + (* * iApply (big_sepL_mono with "Hw2"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. *) + (* eapply region_state_U_monotone_mono; eauto. *) + (* apply related_sts_a_pub_plus_world with a;auto. *) + (* - destruct l; auto. *) + (* iDestruct "Hw" as "[Hbe Hexec]". *) + (* iSplit. *) + (* { iApply (big_sepL_mono with "Hbe"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_pwl_monotone_a with W (addr_reg.min a a0);auto. *) + (* eapply region_addrs_lookup_le;eauto. apply related_sts_a_weak_world with a;auto. solve_addr. *) + (* } *) + (* { iApply (big_sepL_mono with "Hexec"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_U_pwl_monotone_mono_a with W (addr_reg.min a a0);auto. *) + (* apply related_sts_a_weak_world with a;auto. solve_addr. } *) + (* - destruct l; simpl. *) + (* + iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. apply region_state_nwl_monotone_nm_nl with W;auto. *) + (* apply related_sts_pub_plus_priv_world, related_sts_a_pub_plus_world with a;auto. *) + (* + iDestruct "Hw" as "[Hw1 Hw2]". *) + (* iSplitL "Hw1". *) + (* * iApply (big_sepL_mono with "Hw1"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hstd. *) + (* iPureIntro. eapply (region_state_nwl_monotone_a W W' _ (addr_reg.min a a0) Local); auto. *) + (* eapply region_addrs_lookup_le;eauto. apply related_sts_a_weak_world with a;auto. solve_addr. *) + (* * iApply (big_sepL_mono with "Hw2"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. *) + (* eapply region_state_U_monotone; eauto. *) + (* apply related_sts_pub_plus_priv_world. *) + (* apply related_sts_a_pub_plus_world with a;auto. *) + (* + iDestruct "Hw" as "[Hw1 Hw2]". *) + (* iSplitL "Hw1". *) + (* * iApply (big_sepL_mono with "Hw1"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hstd. *) + (* iPureIntro. eapply (region_state_nwl_monotone_a W W' _ (addr_reg.min a a0) Directed); auto. *) + (* eapply region_addrs_lookup_le;eauto. apply related_sts_a_weak_world with a;auto. solve_addr. *) + (* * iApply (big_sepL_mono with "Hw2"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. *) + (* eapply region_state_U_monotone_mono; eauto. *) + (* apply related_sts_a_pub_plus_world with a;auto. *) + (* - destruct l; auto. *) + (* iDestruct "Hw" as "[Hbe Hexec]". *) + (* iSplit. *) + (* { iApply (big_sepL_mono with "Hbe"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_pwl_monotone_a with W (addr_reg.min a a0);auto. *) + (* eapply region_addrs_lookup_le;eauto. apply related_sts_a_weak_world with a;auto. solve_addr. *) + (* } *) + (* { iApply (big_sepL_mono with "Hexec"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. apply region_state_U_pwl_monotone_mono_a with W a;auto. } *) + (* Qed. *) + + (* Definition isDirectedWord (w : Word) := *) + (* match w with *) + (* | inl _ => false *) + (* | inr (_,l,_,_,_) => isDirected l *) + (* end. *) + + (* Lemma interp_monotone_nm W W' w : *) + (* ⌜related_sts_priv_world W W'⌝ -∗ *) + (* interp W w -∗ interp W' w. *) + (* Proof. *) + (* iIntros (Hrelated) "#Hw". *) + (* rewrite /interp /= fixpoint_interp1_eq /=. *) + (* destruct w; rewrite fixpoint_interp1_eq /=; auto. *) + (* destruct c,p,p,p,p; auto. *) + (* - iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as (p Hpers) "#[Hrw Hrel ]". *) + (* iExists _. iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. destruct l; try discriminate. *) + (* apply region_state_nwl_monotone_nm_nl with W;auto. *) + (* apply region_state_nwl_monotone_nm with W;auto. *) + (* - iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. destruct l; try discriminate. *) + (* apply region_state_nwl_monotone_nm_nl with W;auto. *) + (* apply region_state_nwl_monotone_nm with W;auto. *) + (* - admit. *) + (* (* - destruct l eqn:Hl; auto. *) *) + (* (* discriminate. *) *) + (* - iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as (p Hpers) "#[Hrw Hrel ]". *) + (* iExists _. iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. *) + (* destruct l; try discriminate. *) + (* apply region_state_nwl_monotone_nm_nl with W;auto. *) + (* apply region_state_nwl_monotone_nm with W;auto. *) + (* - iModIntro. iIntros (r W''). *) + (* destruct l; simpl; try discriminate. *) + (* + iIntros (Hrelated'). *) + (* iAssert (future_world Global W W'')%I as "Hrelated". *) + (* { iPureIntro. apply related_sts_priv_trans_world with W'; auto. } *) + (* iSpecialize ("Hw" $! r W'' with "Hrelated"). *) + (* iApply "Hw". *) + (* + iIntros (Hrelated'). *) + (* iAssert (future_world Local W W'')%I as "Hrelated". *) + (* { iPureIntro. apply related_sts_priv_trans_world with W'; auto. } *) + (* iSpecialize ("Hw" $! r W'' with "Hrelated"). *) + (* iApply "Hw". *) + (* - iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hrel ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hrel" as %Hrel. *) + (* iPureIntro. destruct l; try discriminate. *) + (* apply region_state_nwl_monotone_nm_nl with W;auto. *) + (* apply region_state_nwl_monotone_nm with W;auto. *) + (* (* - destruct l; try discriminate. done. done. *) *) + (* - destruct l; try done. *) + (* + iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as (p) "(%Hp & #Hrw & # Hst)". *) + (* iExists p. *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. *) + (* admit. *) + (* (* apply region_state_nwl_monotone_nm_nl with W;auto. *) *) + (* (* + iDestruct "Hw" as "[Hw1 Hw2]". *) *) + (* (* iSplit. *) *) + (* (* { iApply (big_sepL_mono with "Hw1"). *) *) + (* (* iIntros (n y Hsome) "Hw". *) *) + (* (* iDestruct "Hw" as "#[Hrw Hst ]". *) *) + (* (* iSplit;eauto. iFrame "#". *) *) + (* (* iDestruct "Hst" as %Hst. *) *) + (* (* iPureIntro. *) *) + (* (* apply region_state_nwl_monotone_nm with W;auto. } *) *) + (* (* { iApply (big_sepL_mono with "Hw2"). *) *) + (* (* iIntros (n y Hsome) "Hw". *) *) + (* (* iDestruct "Hw" as "#[Hrw Hst ]". *) *) + (* (* iSplit;eauto. iFrame "#". *) *) + (* (* iDestruct "Hst" as %Hst. *) *) + (* (* iPureIntro. *) *) + (* (* apply region_state_U_monotone with W;auto. } *) *) + (* - destruct l; auto. discriminate. *) + (* - destruct l; simpl in Hnl; try discriminate. *) + (* + iApply (big_sepL_mono with "Hw"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. *) + (* apply region_state_nwl_monotone_nm_nl with W; auto. *) + (* + iDestruct "Hw" as "[Hw1 Hw2]". *) + (* iSplit. *) + (* { iApply (big_sepL_mono with "Hw1"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. *) + (* apply region_state_nwl_monotone_nm with W;auto. } *) + (* { iApply (big_sepL_mono with "Hw2"). *) + (* iIntros (n y Hsome) "Hw". *) + (* iDestruct "Hw" as "#[Hrw Hst ]". *) + (* iSplit;eauto. iFrame "#". *) + (* iDestruct "Hst" as %Hst. *) + (* iPureIntro. *) + (* apply region_state_U_monotone with W;auto. } *) + (* - destruct l; try discriminate. done. done. *) + (* Qed. *) + + Lemma interp_monotone_nm_nl W W' w : + ⌜related_sts_priv_world W W'⌝ -∗ ⌜isLocalWord w = false⌝ -∗ + interp W w -∗ interp W' w. + Proof. + iIntros (Hrelated Hnl) "#Hw". + rewrite /interp /= fixpoint_interp1_eq /=. + destruct w; rewrite fixpoint_interp1_eq /=; auto. + destruct sb,p; auto. + - iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as (p Hfl) "#[Hrw Hrel ]". + iExists _. iSplit;eauto. iFrame "#". + iDestruct "Hrel" as %Hrel. + iPureIntro. destruct g; try discriminate. + apply region_state_nwl_monotone_nm_nl with W;auto. + - iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as "#[Hrw Hrel ]". + (* iDestruct "Hw" as (p Hfl) "#[Hrw Hrel ]". *) + iSplit;eauto. iFrame "#". + iDestruct "Hrel" as %Hrel. + iPureIntro. destruct g; try discriminate. + apply region_state_nwl_monotone_nm_nl with W;auto. + - destruct g; auto. discriminate. + - iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as (p Hfl) "#[Hrw Hrel ]". + iExists _. iSplit;eauto. iFrame "#". + iDestruct "Hrel" as %Hrel. + iPureIntro. destruct g; try discriminate. + apply region_state_nwl_monotone_nm_nl with W;auto. + - iModIntro. iIntros (r W''). + destruct g; simpl; try discriminate. + iIntros (Hrelated'). + iAssert (future_world Global W W'')%I as "Hrelated". + { iPureIntro. apply related_sts_priv_trans_world with W'; auto. } + iSpecialize ("Hw" $! r W'' with "Hrelated"). + iApply "Hw". + - iApply (big_sepL_mono with "Hw"). + iIntros (n y Hsome) "Hw". + iDestruct "Hw" as "#[Hrw Hrel ]". + iSplit;eauto. iFrame "#". + iDestruct "Hrel" as %Hrel. + iPureIntro. destruct g; try discriminate. + apply region_state_nwl_monotone_nm_nl with W;auto. + - destruct g; try discriminate. done. + Qed. + + (*Lemma that allows switching between the two different formulations of monotonicity, to alleviate the effects of inconsistencies*) + Lemma switch_monotonicity_formulation ρ l w φ: + ρ ≠ Revoked → (∀ m, ρ ≠ Monostatic m) -> + monotonicity_guarantees_region ρ l w φ ≡ monotonicity_guarantees_decide (Σ := Σ) ρ l w φ. + Proof. + intros Hrev Hmono. + unfold monotonicity_guarantees_region, monotonicity_guarantees_decide. + iSplit; iIntros "HH". + - destruct ρ;simpl;auto;try done. + * specialize (Hmono g). done. + - intros. destruct ρ;simpl;auto. + Qed. + + (* The validity of regions are monotone wrt private/public future worlds *) + Lemma adv_monotone W W' b e : + related_sts_priv_world W W' → + ([∗ list] a ∈ region_addrs b e, read_write_cond a interp + ∧ ⌜std W !! a = Some Permanent⌝) + -∗ ([∗ list] a ∈ region_addrs b e, read_write_cond a interp + ∧ ⌜std W' !! a = Some Permanent⌝). + Proof. + iIntros (Hrelated) "Hr". + iApply (big_sepL_mono with "Hr"). + iIntros (k y Hsome) "(Hy & Hperm)". + iFrame. + iDestruct "Hperm" as %Hperm. + iPureIntro. + apply (region_state_nwl_monotone_nm_nl _ W') in Hperm; auto. + Qed. + + Lemma adv_stack_monotone W W' b e : + related_sts_pub_world W W' -> + ([∗ list] a ∈ region_addrs b e, read_write_cond a interp + ∧ ⌜region_state_pwl W a⌝) + -∗ ([∗ list] a ∈ region_addrs b e, read_write_cond a interp + ∧ ⌜region_state_pwl W' a⌝). + Proof. + iIntros (Hrelated) "Hstack_adv". + iApply (big_sepL_mono with "Hstack_adv"). + iIntros (k y Hsome) "(Hr & Htemp)". + iDestruct "Htemp" as %Htemp. + iFrame. iPureIntro. + apply (region_state_pwl_monotone_mono _ W') in Htemp; auto. + Qed. + + Global Instance interp_ne n : + Proper (dist n ==> dist n) (λ Wv : WORLD * (leibnizO Word), (interp Wv.1) Wv.2). + Proof. + solve_proper. + Qed. + + (* The general monotonicity statement that interp gives you when writing a word into a + pointer (p0, l, a2, a1, a0) ; simply a bundling of all individual monotonicity statements *) +Lemma interp_monotone_generalW (W : WORLD) (ρ : region_type) (p p0 : Perm) (l g : Locality)(b e a a2 a1 a0 : Addr): + std W !! a0 = Some ρ → + withinBounds a2 a1 a0 = true → + canStore p0 (WCap p g b e a) = true → + ((fixpoint interp1) W) (WCap p0 l a2 a1 a0) -∗ + monotonicity_guarantees_region ρ a0 (WCap p g b e a) (λne Wv : WORLD * (leibnizO Word), (interp Wv.1) Wv.2). Proof. - intros Ha HR. - destruct (HR a) as [[z [HR1%elem_of_list_singleton HR2]] _]; - last by subst; eauto. - rewrite /op /monotone_op /principal Below_app Below_principal; auto. -Qed. - -Lemma principal_op_R a b x : - R a a → principal R a ⋅ x ≡ principal R b → R a b. -Proof. intros ? ?; eapply (principal_op_RN 0); eauto. Qed. - -Lemma principal_op_R' `{!Reflexive R} a b x : - principal R a ⋅ x ≡ principal R b → R a b. -Proof. intros; eapply principal_op_R; eauto. Qed. - -Lemma principal_includedN `{!PreOrder R} n a b : - principal R a ≼{n} principal R b ↔ R a b. -Proof. - split. - - intros [z Hz]; eapply principal_op_RN; last by rewrite Hz; eauto. - reflexivity. - - intros ?; exists (principal R b); rewrite principal_R_opN; eauto. -Qed. - -Lemma principal_included `{!PreOrder R} a b : - principal R a ≼ principal R b ↔ R a b. -Proof. - split. - - intros [z Hz]; eapply principal_op_R; last by rewrite Hz; eauto. - reflexivity. - - intros ?; exists (principal R b); rewrite principal_R_op; eauto. -Qed. - -(** Internalized properties *) -Lemma monotone_equivI `{!(∀ n : nat, Proper (dist n ==> dist n ==> iff) R)} - `{!Reflexive R} `{!AntiSymm (≡) R} {M} a b : - principal R a ≡ principal R b ⊣⊢ (a ≡ b : uPred M). -Proof. - uPred.unseal. do 2 split. - - intros Hx. exact: principal_injN. - - intros Hx. exact: principal_ne. -Qed. - -Lemma monotone_local_update_grow `{!Transitive R} a q na: - R a na → - (principal R a, q) ~l~> (principal R na, principal R na). + unfold monotonicity_guarantees_region. + iIntros (Hstd Hwb Hconds) "#Hvdst". + destruct ρ;auto. + - iModIntro; simpl;auto. + iIntros (W0 W1) "%Hrel HIW0". + destruct g. + * iApply (interp_monotone_nm_nl with "[] [] HIW0");auto. + iPureIntro. + apply related_sts_a_pub_plus_world in Hrel. + apply related_sts_pub_plus_priv_world;auto. + * admit. + (* * iApply (interp_monotone_nm_nl with "[] [] HIW0");auto. *) + (* iPureIntro. apply related_sts_pub_plus_priv_world. apply related_sts_a_pub_plus_world with a0;auto. *) + (* * destruct (decide (p = O)). *) + (* { subst. rewrite !fixpoint_interp1_eq. done. } *) + (* iApply (interp_monotone_a with "[] HIW0");auto. *) + (* apply andb_prop in Hconds as [Hp0 Hleb]. *) + (* simpl. destruct (isU p) eqn:Hu. *) + (* ** assert (a <= a0)%a as Hle. *) + (* { destruct p; inversion Hu;simpl in Hleb;apply Z.leb_le in Hleb;solve_addr. } *) + (* iPureIntro. apply related_sts_a_weak_world with a0;auto. *) + (* ** assert (e <= a0)%a as Hle. *) + (* { destruct p; inversion Hu;simpl in Hleb;apply Z.leb_le in Hleb; try solve_addr. } *) + (* iPureIntro. apply related_sts_a_weak_world with a0;auto. *) + - iModIntro. simpl. iIntros (W0 W1) "% HIW0". + destruct g. + + by iApply interp_monotone_nm_nl. + + (*Trick here: value relation leads to a contradiction if p0 is WL, since then its region cannot be permanent*) + iDestruct ( writeLocalAllowed_valid_cap_implies with "Hvdst" ) as %Ha; eauto. + rewrite Hstd in Ha. inversion Ha. +Admitted. + +(* Lemma interp_monotone_generalUW (W : WORLD) (ρ : region_type) (p p0 : Perm) (l g : Locality)(b e a a2 a1 a0 : Addr): *) +(* std W !! a0 = Some ρ → *) +(* withinBounds (p0, l, a2, a1, a0) = true → *) +(* canStoreU p0 a0 (inr (p,g,b,e,a)) = true → *) +(* ((fixpoint interp1) W) (inr (p0, l, a2, a1, a0)) -∗ *) +(* monotonicity_guarantees_region ρ a0 (inr (p, g, b, e, a)) (λne Wv : WORLD * (leibnizO Word), (interp Wv.1) Wv.2). *) +(* Proof. *) +(* unfold monotonicity_guarantees_region. *) +(* iIntros (Hstd Hwb Hconds) "#Hvdst". *) +(* destruct ρ;auto. *) +(* - iModIntro; simpl;auto. *) +(* iIntros (W0 W1) "% HIW0". *) +(* destruct g. *) +(* * iApply (interp_monotone_nm with "[] [] HIW0");auto. *) +(* iPureIntro. apply related_sts_a_pub_plus_world in H0. apply related_sts_pub_plus_priv_world;auto. *) +(* * iApply (interp_monotone_nm with "[] [] HIW0");auto. *) +(* iPureIntro. apply related_sts_pub_plus_priv_world. apply related_sts_a_pub_plus_world with a0;auto. *) +(* * destruct (decide (p = O)). *) +(* { subst. rewrite !fixpoint_interp1_eq. done. } *) +(* iApply (interp_monotone_a with "[] HIW0");auto. *) +(* apply andb_prop in Hconds as [Hp0 Hleb]. *) +(* simpl. destruct (isU p) eqn:Hu. *) +(* ** assert (a <= a0)%a as Hle. *) +(* { destruct p; inversion Hu;simpl in Hleb;apply Z.leb_le in Hleb;solve_addr. } *) +(* iPureIntro. apply related_sts_a_weak_world with a0;auto. *) +(* ** assert (e <= a0)%a as Hle. *) +(* { destruct p; inversion Hu;simpl in Hleb;apply Z.leb_le in Hleb; try solve_addr. } *) +(* iPureIntro. apply related_sts_a_weak_world with a0;auto. *) +(* - iModIntro. simpl. iIntros (W0 W1) "% HIW0". *) +(* destruct g. *) +(* + by iApply interp_monotone_nm. *) +(* + (*Trick here: value relation leads to a contradiction if p0 is WL, since then its region cannot be permanent*) *) +(* iDestruct ( writeLocalAllowedU_valid_cap_implies with "Hvdst" ) as %Ha; eauto. *) +(* destruct Ha as [Ha | [? Ha] ]; rewrite Hstd in Ha; inversion Ha. *) +(* + apply andb_prop in Hconds as [Hp0 Hleb]. *) +(* iDestruct ( writeLocalAllowedU_valid_cap_implies with "Hvdst" ) as %Ha; eauto. *) +(* destruct Ha as [Ha | [? Ha] ]; rewrite Hstd in Ha; inversion Ha. *) +(* Qed. *) + +(* Analogous, but now we have the general monotonicity statement in case an integer z is written *) +Lemma interp_monotone_generalZ (W : WORLD) (ρ : region_type) (p0 : Perm) (l : Locality)(a2 a1 a0 : Addr) z: + std W !! a0 = Some ρ → + withinBounds a2 a1 a0 = true → + ((fixpoint interp1) W) (WCap p0 l a2 a1 a0) -∗ + monotonicity_guarantees_region ρ a0 (WInt z) (λne Wv : WORLD * (leibnizO Word), (interp Wv.1) Wv.2). Proof. - intros Hana Hanb. - apply local_update_unital_discrete. - intros z _ Habz. - split; first done. - intros n; specialize (Habz n). - intros x; split. - - intros (y & ->%elem_of_list_singleton & Hy2). - by exists na; split; first constructor. - - intros (y & [->|Hy1]%elem_of_cons & Hy2). - + by exists na; split; first constructor. - + exists na; split; first constructor. - specialize (Habz x) as [_ [c [->%elem_of_list_singleton Hc2]]]. - { exists y; split; first (by apply elem_of_app; right); eauto. } - etrans; eauto. -Qed. - -Lemma monotone_local_update_get_frag `{!PreOrder R} a na: - R na a → - (principal R a, ε) ~l~> (principal R a, principal R na). -Proof. - intros Hana. - apply local_update_unital_discrete. - intros z _. - rewrite left_id. - intros <-. - split; first done. - apply monotone_included. - by apply principal_included. -Qed. - -Lemma monotone_update `{!PreOrder R} a b c: - R a b → - R c b → - ● principal R a ~~> ● principal R b ⋅ ◯ principal R c. -Proof. - intros Hab Hcb. - etrans. - { apply auth_update_alloc; apply (monotone_local_update_grow _ _ b); done. } - etrans; first apply cmra_update_op_l. - apply auth_update_alloc. - apply monotone_local_update_get_frag; done. + unfold monotonicity_guarantees_region. + iIntros (Hstd Hwb) "#Hvdst". + destruct ρ;auto. + - iModIntro; simpl. + all: iIntros (W0 W1) "% HIW0". + all: rewrite !fixpoint_interp1_eq;done. + - iModIntro; simpl. + all: iIntros (W0 W1) "% HIW0". + all: rewrite !fixpoint_interp1_eq;done. Qed. End monotone. - -Arguments monotoneC {_} _. -Arguments monotoneR {_} _. -Arguments monotoneUR {_} _. - - -(** Having an instance of this class for a relation R allows almost -all lemmas provided in this module to be used. See type classes -required by some of preceding the lemmas and instances in the to see -how this works. -The only lemma that requires extra conditions on R is the injectivity -of principal which requires antisymmetry. *) -Class ProperPreOrder {A : Type} `{Dist A} (R : relation A) := { - ProperPreOrder_preorder :: PreOrder R; - ProperPreOrder_ne :: ∀ n, Proper ((dist n) ==> (dist n) ==> iff) R -}. diff --git a/theories/monotone_resource.v b/theories/monotone_resource.v new file mode 100644 index 00000000..295227a6 --- /dev/null +++ b/theories/monotone_resource.v @@ -0,0 +1,315 @@ +(** Author: Amin Timany *) + +From iris.algebra Require Export cmra auth. +From iris.base_logic Require Import base_logic. +Local Arguments validN _ _ _ !_ /. +Local Arguments valid _ _ !_ /. +Local Arguments op _ _ _ !_ /. +Local Arguments pcore _ _ !_ /. +Local Arguments ofe_dist !_ /. +Local Arguments ofe_equiv ! _ /. + +Definition monotone {A : Type} (R : relation A) : Type := list A. + +Definition principal {A : Type} (R : relation A) (a : A) : + monotone R := [a]. + +Section monotone. +Local Set Default Proof Using "Type". +Context {A : ofe} {R : relation A}. +Implicit Types a b : A. +Implicit Types x y : monotone R. + +Definition Below (a : A) (x : monotone R) := ∃ b, b ∈ x ∧ R a b. + +Lemma Below_app a x y : Below a (x ++ y) ↔ Below a x ∨ Below a y. +Proof. + split. + - intros (b & [|]%elem_of_app & ?); [left|right]; exists b; eauto. + - intros [(b & Hb1 & Hb2)|(b & Hb1 & Hb2)]; exists b; rewrite elem_of_app; eauto. +Qed. + +Lemma Below_principal a b : Below a (principal R b) ↔ R a b. +Proof. + split. + - intros (c & ->%elem_of_list_singleton & ?); done. + - intros Hab; exists b; split; first apply elem_of_list_singleton; done. +Qed. + +(* OFE *) +Instance monotone_dist : Dist (monotone R) := + λ n x y, ∀ a, Below a x ↔ Below a y. + +Instance monotone_equiv : Equiv (monotone R) := λ x y, ∀ n, x ≡{n}≡ y. + +Definition monotone_ofe_mixin : OfeMixin (monotone R). +Proof. + split. + - rewrite /equiv /monotone_equiv /dist /monotone_dist; intuition auto using O. + - intros n; split. + + rewrite /dist /monotone_dist /equiv /monotone_equiv; intuition. + + rewrite /dist /monotone_dist /equiv /monotone_equiv; intros ? ? Heq a. + split; apply Heq. + + rewrite /dist /monotone_dist /equiv /monotone_equiv; + intros ? ? ? Heq Heq' a. + split; intros Hxy. + * apply Heq'; apply Heq; auto. + * apply Heq; apply Heq'; auto. + - intros n x y; rewrite /dist /monotone_dist; auto. +Qed. +Canonical Structure monotoneC := Ofe (monotone R) monotone_ofe_mixin. + +(* CMRA *) +Instance monotone_validN : ValidN (monotone R) := λ n x, True. +Instance monotone_valid : Valid (monotone R) := λ x, True. + +Program Instance monotone_op : Op (monotone R) := λ x y, x ++ y. +Instance monotone_pcore : PCore (monotone R) := Some. + +Instance monotone_comm : Comm (≡) (@op (monotone R) _). +Proof. + intros x y n a; rewrite /Below. + setoid_rewrite elem_of_app; split=> Ha; firstorder. +Qed. +Instance monotone_assoc : Assoc (≡) (@op (monotone R) _). +Proof. + intros x y z n a; rewrite /Below /=. + repeat setoid_rewrite elem_of_app; split=> Ha; firstorder. +Qed. +Lemma monotone_idemp (x : monotone R) : x ⋅ x ≡ x. +Proof. + intros n a; rewrite /Below. + setoid_rewrite elem_of_app; split=> Ha; firstorder. +Qed. + +Instance monotone_validN_ne n : + Proper (dist n ==> impl) (@validN (monotone R) _ n). +Proof. intros x y ?; rewrite /impl; auto. Qed. +Instance monotone_validN_proper n : Proper (equiv ==> iff) (@validN (monotone R) _ n). +Proof. move=> x y /equiv_dist H; auto. Qed. + +Instance monotone_op_ne' x : NonExpansive (op x). +Proof. + intros n y1 y2; rewrite /dist /monotone_dist /equiv /monotone_equiv /Below. + rewrite /=; setoid_rewrite elem_of_app => Heq a. + specialize (Heq a); destruct Heq as [Heq1 Heq2]. + split; intros [b [[Hb|Hb] HRb]]; eauto. + - destruct Heq1 as [? [? ?]]; eauto. + - destruct Heq2 as [? [? ?]]; eauto. +Qed. +Instance monotone_op_ne : NonExpansive2 (@op (monotone R) _). +Proof. by intros n x1 x2 Hx y1 y2 Hy; rewrite Hy !(comm _ _ y2) Hx. Qed. +Instance monotone_op_proper : Proper ((≡) ==> (≡) ==> (≡)) (@op (monotone R) _) := ne_proper_2 _. + +Lemma monotone_included (x y : monotone R) : x ≼ y ↔ y ≡ x ⋅ y. +Proof. + split; [|by intros ?; exists y]. + by intros [z Hz]; rewrite Hz assoc monotone_idemp. +Qed. + +Definition monotone_cmra_mixin : CmraMixin (monotone R). +Proof. + apply cmra_total_mixin; try apply _ || by eauto. + - intros ?; apply monotone_idemp. + - rewrite /equiv /monotone_equiv /dist /monotone_dist; eauto. +Qed. +Canonical Structure monotoneR : cmra := Cmra (monotone R) monotone_cmra_mixin. + +Global Instance monotone_cmra_total : CmraTotal monotoneR. +Proof. rewrite /CmraTotal; eauto. Qed. +Global Instance monotone_core_id (x : monotone R) : CoreId x. +Proof. by constructor. Qed. + +Global Instance monotone_cmra_discrete : CmraDiscrete monotoneR. +Proof. + split; auto. + intros ? ?. + rewrite /dist /equiv /= /cmra_dist /cmra_equiv /= + /monotone_dist /monotone_equiv /dist /monotone_dist; eauto. +Qed. + +Instance monotone_empty : Unit (monotone R) := @nil A. +Lemma auth_ucmra_mixin : UcmraMixin (monotone R). +Proof. split; done. Qed. + +Canonical Structure monotoneUR := Ucmra (monotone R) auth_ucmra_mixin. + +Global Instance principal_ne + `{HRne : !∀ n, Proper ((dist n) ==> (dist n) ==> iff) R} : + NonExpansive (principal R). +Proof. intros n a1 a2 Ha; split; rewrite /= !Below_principal !Ha; done. Qed. + +Global Instance principal_proper + {HRne : ∀ n, Proper ((dist n) ==> (dist n) ==> iff) R} : + Proper ((≡) ==> (≡)) (principal R) := ne_proper _. + +Global Instance principal_discrete a : Discrete (principal R a). +Proof. + intros y; rewrite /dist /ofe_dist /= /equiv /ofe_equiv /= /monotone_equiv; + eauto. +Qed. + +Lemma principal_injN_general n a b : + principal R a ≡{n}≡ principal R b → R a a → R a b. +Proof. + rewrite /principal /dist /monotone_dist => Hab Haa. + - destruct (Hab a) as [Ha _]; edestruct Ha as [? [?%elem_of_list_singleton ?]]; + subst; eauto. + eexists _; split; first apply elem_of_list_singleton; eauto. +Qed. + +Lemma principal_inj_general a b : + principal R a ≡ principal R b → R a a → R a b. +Proof. intros Hab; apply (principal_injN_general 0); eauto. Qed. + +Global Instance principal_injN_general' `{!Reflexive R} n : + Inj (λ a b, R a b ∧ R b a) (dist n) (principal R). +Proof. + intros x y Hxy; split; eapply (principal_injN_general n); eauto. +Qed. + +Global Instance principal_inj_general' `{!Reflexive R} : + Inj (λ a b, R a b ∧ R b a) (≡) (principal R). +Proof. + intros x y Hxy; specialize (Hxy 0); eapply principal_injN_general'; eauto. +Qed. + +Global Instance principal_injN `{!Reflexive R} {Has : AntiSymm (≡) R} n : + Inj (dist n) (dist n) (principal R). +Proof. + intros x y [Hxy Hyx]%principal_injN_general'. + erewrite (@anti_symm _ _ _ Has); eauto. +Qed. +Global Instance principal_inj `{!Reflexive R} `{!AntiSymm (≡) R} : + Inj (≡) (≡) (principal R). +Proof. intros ???. apply equiv_dist=>n. by apply principal_injN, equiv_dist. Qed. + +Lemma principal_R_opN_base `{!Transitive R} n x y : + (∀ b, b ∈ y → ∃ c, c ∈ x ∧ R b c) → y ⋅ x ≡{n}≡ x. +Proof. + intros HR; split; rewrite /op /monotone_op Below_app; [|by firstorder]. + intros [(c & (d & Hd1 & Hd2)%HR & Hc2)|]; [|done]. + exists d; split; [|transitivity c]; done. +Qed. + +Lemma principal_R_opN `{!Transitive R} n a b : + R a b → principal R a ⋅ principal R b ≡{n}≡ principal R b. +Proof. + intros; apply principal_R_opN_base; intros c; rewrite /principal. + setoid_rewrite elem_of_list_singleton => ->; eauto. +Qed. + +Lemma principal_R_op `{!Transitive R} a b : + R a b → principal R a ⋅ principal R b ≡ principal R b. +Proof. by intros ? ?; apply principal_R_opN. Qed. + +Lemma principal_op_RN n a b x : + R a a → principal R a ⋅ x ≡{n}≡ principal R b → R a b. +Proof. + intros Ha HR. + destruct (HR a) as [[z [HR1%elem_of_list_singleton HR2]] _]; + last by subst; eauto. + rewrite /op /monotone_op /principal Below_app Below_principal; auto. +Qed. + +Lemma principal_op_R a b x : + R a a → principal R a ⋅ x ≡ principal R b → R a b. +Proof. intros ? ?; eapply (principal_op_RN 0); eauto. Qed. + +Lemma principal_op_R' `{!Reflexive R} a b x : + principal R a ⋅ x ≡ principal R b → R a b. +Proof. intros; eapply principal_op_R; eauto. Qed. + +Lemma principal_includedN `{!PreOrder R} n a b : + principal R a ≼{n} principal R b ↔ R a b. +Proof. + split. + - intros [z Hz]; eapply principal_op_RN; last by rewrite Hz; eauto. + reflexivity. + - intros ?; exists (principal R b); rewrite principal_R_opN; eauto. +Qed. + +Lemma principal_included `{!PreOrder R} a b : + principal R a ≼ principal R b ↔ R a b. +Proof. + split. + - intros [z Hz]; eapply principal_op_R; last by rewrite Hz; eauto. + reflexivity. + - intros ?; exists (principal R b); rewrite principal_R_op; eauto. +Qed. + +(** Internalized properties *) +Lemma monotone_equivI `{!(∀ n : nat, Proper (dist n ==> dist n ==> iff) R)} + `{!Reflexive R} `{!AntiSymm (≡) R} {M} a b : + principal R a ≡ principal R b ⊣⊢ (a ≡ b : uPred M). +Proof. + uPred.unseal. do 2 split. + - intros Hx. exact: principal_injN. + - intros Hx. exact: principal_ne. +Qed. + +Lemma monotone_local_update_grow `{!Transitive R} a q na: + R a na → + (principal R a, q) ~l~> (principal R na, principal R na). +Proof. + intros Hana Hanb. + apply local_update_unital_discrete. + intros z _ Habz. + split; first done. + intros n; specialize (Habz n). + intros x; split. + - intros (y & ->%elem_of_list_singleton & Hy2). + by exists na; split; first constructor. + - intros (y & [->|Hy1]%elem_of_cons & Hy2). + + by exists na; split; first constructor. + + exists na; split; first constructor. + specialize (Habz x) as [_ [c [->%elem_of_list_singleton Hc2]]]. + { exists y; split; first (by apply elem_of_app; right); eauto. } + etrans; eauto. +Qed. + +Lemma monotone_local_update_get_frag `{!PreOrder R} a na: + R na a → + (principal R a, ε) ~l~> (principal R a, principal R na). +Proof. + intros Hana. + apply local_update_unital_discrete. + intros z _. + rewrite left_id. + intros <-. + split; first done. + apply monotone_included. + by apply principal_included. +Qed. + +Lemma monotone_update `{!PreOrder R} a b c: + R a b → + R c b → + ● principal R a ~~> ● principal R b ⋅ ◯ principal R c. +Proof. + intros Hab Hcb. + etrans. + { apply auth_update_alloc; apply (monotone_local_update_grow _ _ b); done. } + etrans; first apply cmra_update_op_l. + apply auth_update_alloc. + apply monotone_local_update_get_frag; done. +Qed. + + +End monotone. + +Arguments monotoneC {_} _. +Arguments monotoneR {_} _. +Arguments monotoneUR {_} _. + + +(** Having an instance of this class for a relation R allows almost +all lemmas provided in this module to be used. See type classes +required by some of preceding the lemmas and instances in the to see +how this works. +The only lemma that requires extra conditions on R is the injectivity +of principal which requires antisymmetry. *) +Class ProperPreOrder {A : Type} `{Dist A} (R : relation A) := { + ProperPreOrder_preorder :: PreOrder R; + ProperPreOrder_ne :: ∀ n, Proper ((dist n) ==> (dist n) ==> iff) R +}. diff --git a/theories/proofmode/map_simpl_test.v b/theories/proofmode/map_simpl_test.v index 9d7fc25f..cec4ca80 100644 --- a/theories/proofmode/map_simpl_test.v +++ b/theories/proofmode/map_simpl_test.v @@ -2,7 +2,7 @@ From iris.proofmode Require Import proofmode. From cap_machine Require Import rules_base addr_reg_sample map_simpl. Section test. - Context `{memG Σ, regG Σ}. + Context `{ceriseG Σ}. Lemma foo rmap: ([∗ map] k↦y ∈ <[r_t3:=WInt 0%Z]> diff --git a/theories/proofmode/region.v b/theories/proofmode/region.v index 2cccce6e..d0834c89 100644 --- a/theories/proofmode/region.v +++ b/theories/proofmode/region.v @@ -226,3 +226,424 @@ Section codefrag. Qed. End codefrag. + +(* TODO I think that the this part can be replaced by finz.seq_between *) +Section region. + Context `{MP: MachineParameters, CeriseG: ceriseG Σ}. + + (*------------------------- region_size ------------------------------------*) + Definition region_size : Addr → Addr → nat := + λ b e, Z.to_nat (e - b). + + Lemma region_size_S a b : + (a < b)%a -> + region_size a b = S (region_size ((a^+1))%a b). + Proof. rewrite /region_size. solve_addr. Qed. + + Lemma region_size_0 a b : + (b <= a)%a -> + region_size a b = 0. + Proof. rewrite /region_size. solve_addr. Qed. + + Lemma region_size_split (a b e : Addr) : + (b ≤ a ≤ e)%Z → + region_size b e = region_size b a + region_size a e. + Proof. intros [? ?]. rewrite /region_size. solve_addr. Qed. + + Lemma get_addr_from_option_addr_region_size (a b : Addr) : + (b ≤ a)%Z → + ((b ^+ region_size b a) = a)%a. + Proof. intros Hle. rewrite /region_size. solve_addr. Qed. + + Lemma incr_addr_region_size (a b : Addr) : + (b <= a)%a → + (b + region_size b a)%a = Some a. + Proof. intros. unfold region_size. solve_addr. Qed. + + Lemma incr_addr_region_size_iff (a b : Addr) (i : nat) : + (a + i)%a = Some b ↔ (a <= b)%a ∧ region_size a b = i. + Proof. + rewrite /region_size. split; [ intros | intros [? ?] ]; solve_addr. + Qed. + + (*-------------------------- region_addrs_aux ------------------------------*) + + Fixpoint region_addrs_aux (b: Addr) (n: nat): list Addr := + match n with + | 0 => nil + | S n => b :: (region_addrs_aux ((b ^+ 1)%a) n) + end. + + Lemma region_addrs_aux_length: + forall n b, + length (region_addrs_aux b n) = n. + Proof. induction n; intros; simpl; auto. Qed. + + Definition region_addrs_aux_singleton (a : Addr) : + [a] = region_addrs_aux a 1. Proof. done. Qed. + + Lemma region_addrs_aux_decomposition n b k : + (k <= n)%nat -> + region_addrs_aux b n = region_addrs_aux b k ++ (region_addrs_aux ((b ^+ k)%a) (n - k)). + Proof. + revert b k. induction n. + - intros. assert ((k = 0)%nat) by lia; subst k. reflexivity. + - intros * HH. inv HH. + + rewrite Nat.sub_diag. simpl. rewrite app_nil_r //. + + simpl. destruct k; simpl. + by replace (b ^+ 0%nat)%a with b by solve_addr. + rewrite (IHn ((b^+1))%a k); [|lia]. do 3 f_equal. solve_addr. + Qed. + + Lemma region_addrs_aux_spec n b k : + (k < n)%nat -> + nth_error (region_addrs_aux b n) k = Some ((b ^+ k)%a). + Proof. + revert b k. induction n; intros. + - lia. + - assert (X: k = n \/ k < n) by lia; destruct X as [X | X]. + + subst k. destruct n; simpl. + * f_equal. solve_addr. + * rewrite IHn; [| lia]. f_equal. solve_addr. + + rewrite <- IHn; auto. + rewrite (region_addrs_aux_decomposition (S n) b n); [| lia]. + rewrite nth_error_app1; auto. + rewrite region_addrs_aux_length. auto. + Qed. + + Lemma not_elem_of_region_addrs_aux a n (i : Z) : + (i > 0)%Z → + a ≠ addr_reg.top → + a ∉ region_addrs_aux ((a ^+ i)%a) n. + Proof. + intros Hi Hne. + revert i Hi; induction n; intros i Hi. + - apply not_elem_of_nil. + - simpl. apply not_elem_of_cons; split. + + intro. apply Hne. solve_addr. + + rewrite get_addrs_from_option_addr_comm. + apply IHn; lia. lia. lia. + Qed. + + Lemma region_addrs_not_elem_of a n : + forall a', (a < a')%a -> a ∉ (region_addrs_aux a' n). + Proof. + induction n. + - intros a' Ha'. apply not_elem_of_nil. + - intros a' Ha'. apply not_elem_of_cons. + split. + + solve_addr. + + apply IHn; solve_addr. + Qed. + + Lemma region_addrs_aux_next_head a (a0 a1 : Addr) n : + ((region_addrs_aux (a)%a n) !! 0) = Some a0 → + ((region_addrs_aux (a)%a n) !! (1)) = Some a1 → + ((a0 ^+ 1)%a = a1). + Proof. + intros Ha0 Ha1. + destruct n as [| n]; cbn in *; [ by inversion Ha0 |]. + destruct n as [| n]; cbn in *; [ by inversion Ha1 |]. + solve_addr. + Qed. + + Lemma region_addrs_aux_next a n i ai aj : + ((region_addrs_aux a n) !! i) = Some ai → ((region_addrs_aux a n) !! (i + 1)) = Some aj → + (ai ^+ 1)%a = aj. + Proof. + intros Hai Haj. + assert (i + 1 < n). + { rewrite -(region_addrs_aux_length n a). + apply lookup_lt_is_Some_1. eauto. } + assert (i < n). + { rewrite -(region_addrs_aux_length n a). + apply lookup_lt_is_Some_1. eauto. } + rewrite (region_addrs_aux_decomposition n a i) in Hai; last lia. + rewrite lookup_app_r region_addrs_aux_length in Hai |- *; last lia. + rewrite (region_addrs_aux_decomposition n a i) in Haj; last lia. + rewrite lookup_app_r region_addrs_aux_length in Haj |- *; last lia. + rewrite Nat.sub_diag in Hai. + replace (i + 1 - i) with 1 in Haj by lia. + eapply region_addrs_aux_next_head; eauto. + Qed. + + (* Lemma region_addrs_lt_top (a: Addr) n i ai : *) + (* (a + (Z.of_nat i) < MemNum)%Z → *) + (* (region_addrs_aux a n) !! i = Some ai → ai ≠ addr_reg.top. *) + (* Proof. *) + (* intros Ha Hai. *) + (* assert (length (region_addrs_aux a n) = n) as Hlen. *) + (* { apply region_addrs_aux_length. } *) + (* assert (length (region_addrs_aux a i) = i) as Hleni. *) + (* { apply region_addrs_aux_length. } *) + (* assert (i < n) as Hi. *) + (* { rewrite -Hlen. by apply lookup_lt_Some with ai. } *) + (* rewrite (region_addrs_aux_decomposition n a i) in Hai; last lia. *) + (* rewrite lookup_app_r in Hai; last lia. *) + (* rewrite Hleni Nat.sub_diag in Hai. *) + (* destruct (n - i) eqn:Hni; cbn in Hai; [ congruence |]. *) + (* inversion Hai; subst ai. intro. solve_addr. *) + (* Qed. *) + + Lemma region_addrs_aux_NoDup (a: Addr) (n: nat) : + is_Some (a + n)%a → + NoDup (region_addrs_aux a n). + Proof. + generalize a. clear a. induction n; intros a Hsome. + - apply NoDup_nil; auto. + - cbn. apply NoDup_cons; split. + + eapply not_elem_of_region_addrs_aux; first lia. + destruct Hsome as [? ?]. intros ->. solve_addr. + + eapply IHn. destruct Hsome as [? ?]. unfold is_Some. + zify_addr; first [ by eauto | lia ]. + Qed. + + (*---------------------------- region_addrs --------------------------------*) + + Definition region_addrs (b e: Addr): list Addr := + region_addrs_aux b (region_size b e). + + Lemma region_addrs_length: + forall b e, + length (region_addrs b e) = region_size b e. + Proof. + intros; unfold region_addrs. by rewrite region_addrs_aux_length. + Qed. + + Lemma region_addrs_spec: + forall b e k, + (b <= e)%a -> + (k < region_size b e)%nat -> + nth_error (region_addrs b e) k = Some ((b ^+ k)%a). + Proof. + intros; unfold region_addrs. + destruct (Z.le_dec b e). + - apply region_addrs_aux_spec; auto. + - elim n. solve_addr. + Qed. + + Lemma region_addrs_empty b e: + (e <= b)%a -> + region_addrs b e = nil. + Proof. + intros. rewrite /region_addrs /region_size /=. + replace (Z.to_nat (e - b)) with 0 by solve_addr. + reflexivity. + Qed. + + Lemma region_addrs_decomposition b a e : + (b <= a /\ a < e)%a -> + region_addrs b e = region_addrs b a ++ (a :: region_addrs (a^+1)%a e). + Proof with try (unfold region_size; solve_addr). + intros [? ?]. unfold region_addrs at 1. + rewrite (region_addrs_aux_decomposition _ _ (region_size b a))... + rewrite (_ : region_size b e - region_size b a = region_size a e)... + rewrite -/(region_addrs b a). f_equal. + rewrite (_ : region_size a e = S (region_size (a^+1)%a e))... + cbn. f_equal... rewrite /region_addrs. f_equal... + Qed. + + Lemma region_addrs_split b a e : + (b <= a ∧ a <= e)%a → + region_addrs b e = region_addrs b a ++ region_addrs a e. + Proof with try (unfold region_size; solve_addr). + intros [? ?]. unfold region_addrs at 1. + rewrite (region_addrs_aux_decomposition _ _ (region_size b a))... + rewrite (_: region_size b e - region_size b a = region_size a e)... + rewrite (_: (b ^+ region_size b a)%a = a)... + rewrite -/(region_addrs _ _) //. + Qed. + + Lemma region_addrs_split2 b e a: + region_addrs b e = region_addrs b (finz.min a e) ++ region_addrs (finz.max b a) e. + Proof. + destruct (decide ((finz.min a e) = (finz.max b a))). + - rewrite e0 -region_addrs_split; auto. + split; solve_addr. + - destruct (decide ((finz.min a e) < b)%a). + + rewrite (region_addrs_empty b (finz.min a e)); auto. + destruct (decide (a < b)%a). + * replace (finz.max b a) with b by solve_addr. auto. + * replace (finz.max b a) with a in n by solve_addr. + assert (e <= b)%a by solve_addr. + rewrite (region_addrs_empty b e); auto. + rewrite region_addrs_empty; auto. solve_addr. + * solve_addr. + + replace (finz.max b a) with a by solve_addr. + destruct (decide (e < a)%a). + * rewrite (region_addrs_empty a e); try solve_addr. + replace (finz.min a e) with e by solve_addr; auto. + rewrite app_nil_r. auto. + * replace (finz.min a e) with a by solve_addr. + rewrite -region_addrs_split; auto. solve_addr. + Qed. + + Lemma region_addrs_split3 b e n: + region_size b e > n -> + exists a, region_addrs b e = region_addrs b a ++ region_addrs a e /\ region_size b a = n. + Proof. + intros Hsize. rewrite /region_size in Hsize. + assert (exists a, (b + n)%a = Some a) as [a Ha]. + { exists (b ^+ n)%a. solve_addr. } + exists a. split; [|rewrite /region_size; solve_addr]. + eapply region_addrs_split. split; solve_addr. + Qed. + + Lemma isWithin_region_addrs_decomposition a0 a1 b e: + (b <= a0 /\ a1 <= e /\ a0 <= a1)%a -> + region_addrs b e = region_addrs b a0 ++ + region_addrs a0 a1 ++ + region_addrs a1 e. + Proof with try (unfold region_size; solve_addr). + intros (Hba0 & Ha1e & Ha0a1). + rewrite (region_addrs_split b a0 e)... f_equal. + rewrite (region_addrs_split a0 a1 e)... + Qed. + + Lemma region_addrs_first a b : + (a < b)%a -> + (region_addrs a b) !! 0 = Some a. + Proof. + intros Hle. + rewrite /region_addrs. + rewrite (_: region_size a b = S (region_size a b - 1)). + 2: by (unfold region_size; solve_addr). done. + Qed. + + Lemma region_addrs_NoDup a b : + NoDup (region_addrs a b). + Proof. + rewrite /region_addrs. destruct (Z.le_dec a b). + - apply region_addrs_aux_NoDup. + rewrite incr_addr_region_size; eauto. + - rewrite /region_size Z2Nat.nonpos; [| lia]. by apply NoDup_nil. + Qed. + + Lemma region_addrs_cons a e : + (a < e)%a → + region_addrs a e = a :: region_addrs ((a^+1))%a e. + Proof. + intros. rewrite (region_addrs_decomposition a a). 2: solve_addr. + rewrite /region_addrs region_size_0 //. solve_addr. + Qed. + + Lemma region_addrs_weak n a b e : + a ∈ region_addrs_aux b (S n) -> + (b + n)%a = Some e -> + a ≠ e -> + a ∈ region_addrs_aux b n. + Proof. + revert b. induction n;intros b Hin Hb Hne. + - simpl in Hin. apply elem_of_list_singleton in Hin. subst. + rewrite addr_add_0 in Hb. inversion Hb. contradiction. + - simpl. destruct (decide (a = b)). + + subst. apply elem_of_cons. by left. + + apply elem_of_cons. right. + simpl in Hin. apply elem_of_cons in Hin. + destruct Hin as [Hcontr | Hin];[contradiction|]. + apply IHn;auto. solve_addr. + Qed. + + Lemma region_addrs_elem_of_lt (a b e : Addr) n : + a ∈ region_addrs_aux b n -> (b + n)%a = Some e -> (a < e)%a. + Proof. + rewrite /region_addrs. intros Hin. + revert e. induction n; intros e. + - inversion Hin. + - intros He. + assert (exists e', (b + n)%a = Some e') as [e' He']. + { rewrite Nat2Z.inj_succ in He. + assert (Z.succ n = n + 1)%Z as Heq;[lia|]. rewrite Heq in He. + destruct (b + n)%a eqn:Hsome. + { eauto. } + exfalso. solve_addr. + } + destruct n. + + rewrite addr_add_0 in He'. inversion He'. subst. + simpl in Hin. apply elem_of_list_singleton in Hin. subst. + solve_addr. + + destruct (decide (a = e'));[subst;solve_addr|]. + trans e';[|solve_addr]. + apply IHn;auto. apply region_addrs_weak with (e:=e');auto. + Qed. + + Lemma region_addrs_elem_of_ge (a b : Addr) n : + a ∈ region_addrs_aux b n -> (b <= a)%a. + Proof. + rewrite /region_addrs. + revert b. induction n;intros b Hin. + - inversion Hin. + - simpl in Hin. + apply elem_of_cons in Hin as [Heq | Hin]. + + subst. solve_addr. + + trans (b ^+ 1)%a;[solve_addr|]. + apply IHn;auto. + Qed. + + Lemma elem_of_region_addrs (a b e: Addr): + a ∈ region_addrs b e ↔ (b <= a)%a ∧ (a < e)%a. + Proof. + rewrite /region_addrs /region_size. + set n := Z.to_nat (e - b). have: (n = Z.to_nat (e - b)) by reflexivity. + clearbody n. revert n a b e. induction n. + { intros. cbn. rewrite elem_of_nil. solve_addr. } + { intros. cbn. rewrite elem_of_cons (IHn a _ e). 2: solve_addr. + split. intros [ -> | ]; solve_addr. intros [Hba ?]. + apply Zle_lt_or_eq in Hba. destruct Hba; [| subst]. solve_addr. + assert (b = a) by solve_addr. subst. solve_addr. } + Qed. + + Lemma not_elem_of_region_addrs (a b e: Addr): + a ∉ region_addrs b e ↔ (a < b)%a ∨ (e <= a)%a. + Proof. + destruct (decide ((a < b)%a ∨ (e <= a)%a)) as [X1|X1]; + destruct (decide (a ∈ region_addrs b e)) as [X2|X2]. + - rewrite -> elem_of_region_addrs in *. solve_addr. + - split; auto. + - rewrite -> elem_of_region_addrs in *. solve_addr. + - split; auto. intros _. exfalso. apply X2, elem_of_region_addrs. solve_addr. + Qed. + + Lemma region_addrs_not_elem_of_le a (n : nat) b a' : + (b + n)%a = Some a -> (a <= a')%a -> a' ∉ (region_addrs_aux b n). + Proof. + revert b a'. induction n. + - intros * Ha' Hle. apply not_elem_of_nil. + - intros * Ha' Hle. apply not_elem_of_cons. + split. + + intros Hcontr;subst. solve_addr. + + apply IHn; solve_addr. + Qed. + + Lemma region_addrs_xor_elem_of (a b c e : Addr) : + (b <= c < e)%Z -> + a ∈ region_addrs b e -> + (a ∈ region_addrs b c ∧ a ∉ region_addrs c e) ∨ (a ∉ region_addrs b c ∧ a ∈ region_addrs c e). + Proof. + intros Hbounds Ha. + rewrite (region_addrs_split _ c) in Ha;auto. 2: solve_addr. + apply elem_of_app in Ha. rewrite ->!elem_of_region_addrs in *. solve_addr. + Qed. + + Lemma region_addrs_single b e: + (b+1)%a = Some e → + region_addrs b e = [b]. + Proof. + intros. rewrite /region_addrs. + rewrite (_: region_size b e = 1) //= /region_size. + solve_addr. + Qed. + + Lemma region_addrs_submseteq b b' e e': + (b' <= b)%a -> + (e <= e')%a -> + region_addrs b e ⊆+ region_addrs b' e'. + Proof. + intros. destruct (decide (b < e)%a). + - rewrite (region_addrs_split b' b e'); [|solve_addr]. + rewrite (region_addrs_split b e e'); [|solve_addr]. + eapply submseteq_middle. + - rewrite region_addrs_empty; [|solve_addr]. + eapply submseteq_nil_l. + Qed. +End region. diff --git a/theories/region_invariants.v b/theories/region_invariants.v new file mode 100644 index 00000000..45737bfb --- /dev/null +++ b/theories/region_invariants.v @@ -0,0 +1,1229 @@ +From iris.algebra Require Import gmap agree auth. +From iris.proofmode Require Import proofmode. +From iris.base_logic Require Export invariants na_invariants saved_prop. +From cap_machine Require Export stdpp_extra cap_lang sts rules_base. +(* import [stdpp.countable] before [griotte.lang]; this way [encode] and + [decode] refer to [countable.encode] and [countable.decode], instead of + [cap_lang.encode]/[cap_lang.decode]. *) +From stdpp Require Import countable. +Import uPred. + +(** CMRA for heap and its predicates. Contains: *) +(* CMRA for relatedness between locations and saved prop names *) +(* CMRA for saved predicates *) +Definition relUR : ucmra := gmapUR Addr (agreeR (leibnizO (gname))). +Definition relT := gmap Addr (leibnizO (gname)). + +(* We will first define the standard STS for the shared part of the heap *) +Inductive region_type := +| Monotemporary +| Permanent +| Revoked +| Monostatic of gmap Addr Word. + +Inductive std_rel_pub : region_type -> region_type -> Prop := +| Std_pub_Revoked_Monotemporary : std_rel_pub Revoked Monotemporary +| Std_pub_Revoked_Permanent : std_rel_pub Revoked Permanent. + +Inductive std_rel_priv : region_type -> region_type -> Prop := +| Std_priv_Monotemporary_Monostatic m : std_rel_priv Monotemporary (Monostatic m) +| Std_priv_Monotemporary_Revoked : std_rel_priv Monotemporary Revoked +| Std_priv_Monotemporary_Temporary : std_rel_priv Monotemporary Permanent. + +Inductive std_rel_pub_plus : region_type → region_type → Prop := +| Std_pub_plus_Monostatic_Monotemporary m : std_rel_pub_plus (Monostatic m) Monotemporary. + +Global Instance sts_std : STS_STD region_type := + {| Rpub := std_rel_pub; Rpubp := std_rel_pub_plus; Rpriv := std_rel_priv |}. + +(* Global Instance finz_le_dec : RelDecision (@finz.le finz_bound). *) +(* Proof. *) +(* intros x y. destruct x as [x], y as [y]. *) +(* destruct (Z.le_dec x y); [by left|by right]. *) +(* Defined. *) + +(* Global Instance le_addr_dec (a1 a2 : Addr) : Decision (Z.le a1 a2). *) +(* Proof. apply _. Qed. *) + +(* TODO move in machine_utils_extra.v *) +Global Instance finz_le_preorder `{finz_bound : Z} : PreOrder (@finz.le finz_bound). +Proof. + apply Build_PreOrder. + - rewrite /Reflexive. solve_addr. + - rewrite /Transitive. solve_addr. +Qed. + +Global Instance finz_le_ord : Ord Addr := + {| le_a := finz.le; + le_a_decision := finz_le_dec; + le_a_preorder := finz_le_preorder |}. + +Class heapGpreS Σ := HeapGpreS { + heapPreG_invPreG : invGpreS Σ; + heapPreG_saved_pred :: savedPredG Σ (((STS_std_states Addr region_type) * (STS_states * STS_rels)) * Word); + heapPreG_rel :: inG Σ (authR relUR); +}. + +Class heapGS Σ := HeapGS { + heapG_invG : invGS Σ; + heapG_saved_pred :: savedPredG Σ (((STS_std_states Addr region_type) * (STS_states * STS_rels)) * Word); + heapG_rel :: inG Σ (authR relUR); + γrel : gname +}. + +Definition heapPreΣ := + #[ GFunctor (authR relUR) ]. + +Instance subG_heapPreΣ {Σ}: + subG heapPreΣ Σ → + invGpreS Σ → + subG (savedPredΣ (((STS_std_states Addr region_type) * (STS_states * STS_rels)) * Word)) Σ → + heapGpreS Σ. +Proof. solve_inG. Qed. + +Section REL_defs. + Context {Σ:gFunctors} {heapg : heapGS Σ}. + + Definition REL_def l γ : iProp Σ := own γrel (◯ {[ l := to_agree γ ]}). + Definition REL_aux : { x | x = @REL_def }. by eexists. Qed. + Definition REL := proj1_sig REL_aux. + Definition REL_eq : @REL = @REL_def := proj2_sig REL_aux. + + Definition RELS_def (M : relT) : iProp Σ := own γrel (● (to_agree <$> M : relUR)). + Definition RELS_aux : { x | x = @RELS_def }. by eexists. Qed. + Definition RELS := proj1_sig RELS_aux. + Definition RELS_eq : @RELS = @RELS_def := proj2_sig RELS_aux. + + Definition rel_def (l : Addr) (φ : ((STS_std_states Addr region_type * (STS_states * STS_rels)) * Word) -> iProp Σ) : iProp Σ := + (∃ (γpred : gnameO), REL l γpred + ∗ saved_pred_own γpred DfracDiscarded φ)%I. + Definition rel_aux : { x | x = @rel_def }. by eexists. Qed. + Definition rel := proj1_sig rel_aux. + Definition rel_eq : @rel = @rel_def := proj2_sig rel_aux. +End REL_defs. + +Section heapPre. + (* TODO wsat_alloc had been changed in Iris 4.0. + Fixed using Hc + *) + Context {Σ:gFunctors} {heappreg : heapGpreS Σ} {Hc : lcGS Σ}. + + Lemma heap_init : + ⊢ |==> ∃ (heapg: heapGS Σ), RELS (∅ : relT). + Proof. + iMod (own_alloc (A:= (authR relUR)) (● (to_agree <$> (∅: relT) : relUR))) as (γ) "H". + { rewrite fmap_empty. by apply auth_auth_valid. } + iMod (@wsat.wsat_alloc _ (@invGpreS_wsat _ (@heapPreG_invPreG _ heappreg))) as (Hw) "[Hw HE]". + iModIntro. iExists (HeapGS _ (InvG HasLc _ Hw _) _ _ γ). rewrite RELS_eq /RELS_def. done. + Qed. + +End heapPre. + +Section heap. + Context {Σ:gFunctors} {ceriseg:ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} + `{MP: MachineParameters}. + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Global Instance region_type_EqDecision : EqDecision region_type := + (fun x y => match x, y with + | Permanent, Permanent + | Revoked, Revoked + | Monotemporary, Monotemporary => left eq_refl + | Monostatic m1, Monostatic m2 => ltac:(solve_decision) + | _, _ => ltac:(right; auto) + end). + + Lemma i_div i n m : + i ≠ 0 -> + (i | (i * n + m))%Z → (i | m)%Z. + Proof. + intros Hne [m' Hdiv]. + assert (((i * n + m) `div` i)%Z = ((m' * i) `div` i)%Z) as Hr. + { rewrite Hdiv. auto. } + rewrite Z.div_mul in Hr;[|lia]. + assert ((i * n + m) `div` i = ((i * n) `div` i) + (m `div` i))%Z as Heq. + { rewrite Z.add_comm Z.mul_comm Z.div_add;[|lia]. + rewrite Z.div_mul;[|lia]. rewrite Z.add_comm. auto. } + rewrite Heq in Hr. rewrite Z.mul_comm Z.div_mul in Hr;[|lia]. + assert (m `div` i = m' - n)%Z. + { rewrite -Hr. lia. } + exists (m' - n)%Z. lia. + Qed. + + Lemma two_div_odd n m : + (2 | (2 * n + m))%Z → (2 | m)%Z. + Proof. + intros Hdiv. apply (i_div 2 n);auto. + Qed. + + Lemma i_mod i n m k : + (i > 0 -> + (m + i * n) `mod` i = k → m `mod` i = k)%Z. + Proof. + intros Hlt Hmod. + rewrite Z.mul_comm Z_mod_plus in Hmod;auto. + Qed. + + Lemma three_mod n m k : + ((m + 3 * n) `mod` 3 = k → m `mod` 3 = k)%Z. + Proof. + apply i_mod. lia. + Qed. + + Lemma two_mod n m k : + ((m + 2 * n) `mod` 2 = k → m `mod` 2 = k)%Z. + Proof. + apply i_mod. lia. + Qed. + + Lemma four_mod_two : + (4 `mod` 2 = 0)%Z. + Proof. auto. Qed. + Lemma five_mod_two : + (5 `mod` 2 = 1)%Z. + Proof. auto. Qed. + + Global Instance divide_dec : forall p1 p2, Decision (Pos.divide p1 p2). + Proof. + intros p1 p2. + destruct (Znumtheory.Zdivide_dec (Z.pos p1) (Z.pos p2)). + - left. by apply Pos2Z.inj_divide. + - right. intros Hcontr. apply Pos2Z.inj_divide in Hcontr. done. + Qed. + + Global Instance region_type_countable : Countable region_type. + Proof. + set encode := fun ty => match ty with + | Monotemporary => 1 + | Permanent => 2 + | Revoked => 3 + | Monostatic m => 4 + 2 * (encode m) + end%positive. + set decode := (fun n => + if decide (n = 1) then Some Monotemporary + else if decide (n = 2) then Some Permanent + else if decide (n = 3) then Some Revoked + else if decide (Zpos n `mod` 2 = 0)%Z then + match (decode (Z.to_pos (((Zpos n)-4) / 2)%Z)) with + | Some m => Some (Monostatic m) + | None => None + end + else None)%positive. + eapply (Build_Countable _ _ encode decode). + intro ty. destruct ty; try reflexivity; + unfold encode, decode; + repeat (match goal with |- context [ decide ?x ] => + destruct (decide x); [ try (exfalso; lia) | ] end). + - rewrite Pos2Z.inj_add Z.add_comm Z.add_simpl_r Pos2Z.inj_mul. + rewrite Z.mul_comm Z.div_mul;[|lia]. rewrite Pos2Z.id decode_encode//. + - exfalso. apply n2. rewrite Pos2Z.inj_add Pos2Z.inj_mul Z.mul_comm Z_mod_plus;auto. lia. + Qed. + + + Global Instance rel_persistent l (φ : (WORLD * Word) -> iProp Σ) : + Persistent (rel l φ). + Proof. rewrite rel_eq /rel_def REL_eq /REL_def. + apply _. + Qed. + + Definition future_pub_mono (φ : (WORLD * Word) -> iProp Σ) (v : Word) : iProp Σ := + (□ ∀ W W', ⌜related_sts_pub_world W W'⌝ → φ (W,v) -∗ φ (W',v))%I. + + Definition future_pub_plus_mono (φ : (WORLD * Word) -> iProp Σ) (v : Word) : iProp Σ := + (□ ∀ W W', ⌜related_sts_pub_plus_world W W'⌝ → φ (W,v) -∗ φ (W',v))%I. + + Definition future_pub_a_mono (a : Addr) (φ : (WORLD * Word) -> iProp Σ) (v : Word) : iProp Σ := + (□ ∀ W W', ⌜related_sts_a_world W W' a⌝ → φ (W,v) -∗ φ (W',v))%I. + + Definition future_priv_mono (φ : (WORLD * Word) -> iProp Σ) v : iProp Σ := + (□ ∀ W W', ⌜related_sts_priv_world W W'⌝ → φ (W,v) -∗ φ (W',v))%I. + + (* Some practical shorthands for projections *) + Definition std W := W.1. + Definition loc W := W.2. + + (* Asserting that a location is in a specific state in a given World *) + + Definition permanent (W : WORLD) (l : Addr) := + match W.1 !! l with + | Some ρ => ρ = Permanent + | _ => False + end. + Definition revoked (W : WORLD) (l : Addr) := + match W.1 !! l with + | Some ρ => ρ = Revoked + | _ => False + end. + Definition monostatic (W : WORLD) (m: gmap Addr Word) (l : Addr) := + match W.1 !! l with + | Some ρ => ρ = (Monostatic m) + | _ => False + end. + Definition monotemporary (W : WORLD) (l : Addr) := + match W.1 !! l with + | Some ρ => ρ = Monotemporary + | _ => False + end. + + (* ----------------------------------------------------------------------------------------------- *) + (* ------------------------------------------- REGION_MAP ---------------------------------------- *) + (* ----------------------------------------------------------------------------------------------- *) + + Definition region_map_def M (Mρ: gmap Addr region_type) W := + ([∗ map] a↦γpred ∈ M, ∃ ρ, ⌜Mρ !! a = Some ρ⌝ ∗ + sts_state_std a ρ ∗ + ∃ φ, ⌜∀ Wv, Persistent (φ Wv)⌝ ∗ saved_pred_own γpred DfracDiscarded φ ∗ + match ρ with + | Monotemporary => ∃ (v : Word), + a ↦ₐ v + ∗ future_pub_a_mono a φ v + ∗ ▷ φ (W,v) + | Permanent => ∃ (v : Word), + a ↦ₐ v + ∗ future_priv_mono φ v + ∗ ▷ φ (W,v) + | Monostatic m => ∃ v, ⌜m !! a = Some v⌝ + ∗ a ↦ₐ v + ∗ ⌜∀ a', a' ∈ dom m → + Mρ !! a' = Some (Monostatic m)⌝ + | Revoked => emp + end)%I. + + Definition region_def W : iProp Σ := + (∃ (M : relT) Mρ, RELS M ∗ ⌜dom W.1 = dom M⌝ + ∗ ⌜dom Mρ = dom M⌝ + ∗ region_map_def M Mρ W)%I. + Definition region_aux : { x | x = @region_def }. by eexists. Qed. + Definition region := proj1_sig region_aux. + Definition region_eq : @region = @region_def := proj2_sig region_aux. + + Lemma reg_in γ (R : relT) (n : Addr) (r : leibnizO (gname)) : + own γ (● (to_agree <$> R : relUR)) ∗ own γ (◯ {[n := to_agree r]}) -∗ + ⌜R = <[n := r]>(delete n R)⌝. + Proof. + iIntros "[H1 H2]". + iDestruct (own_valid_2 with "H1 H2") as %Hv. + iPureIntro. + apply auth_both_valid_discrete in Hv; destruct Hv as [Hv1 Hv2]. + specialize (Hv2 n). + apply singleton_included_l in Hv1. + destruct Hv1 as (y & Heq & Hi). + revert Hv2; rewrite Heq => Hv2. + revert Hi; rewrite Some_included_total => Hi. + apply to_agree_uninj in Hv2 as [y' Hy]. + revert Hi Heq; rewrite -Hy => Hi Heq. + apply to_agree_included in Hi; subst. + revert Heq; rewrite -Hi => Heq. + rewrite insert_delete_insert insert_id /leibniz_equiv_iff => //; auto. + revert Heq. rewrite lookup_fmap fmap_Some_equiv =>Hx. + destruct Hx as [x [-> Hrx] ]. + apply to_agree_inj, leibniz_equiv_iff in Hrx as ->. + done. + Qed. + + Lemma rels_agree a γ1 γ2 : + REL a γ1 ∗ REL a γ2 -∗ ⌜γ1 = γ2⌝. + Proof. + rewrite REL_eq /REL_def. + iIntros "[Hγ1 Hγ2]". + iDestruct (own_valid_2 with "Hγ1 Hγ2") as %Hval. + iPureIntro. + rewrite -auth_frag_op singleton_op in Hval. + apply (to_agree_op_inv_L (A:=leibnizO _)). + eapply singleton_valid, auth_frag_valid, Hval. + Qed. + + Lemma rel_agree a φ1 φ2 : + rel a φ1 ∗ rel a φ2 -∗ (∀ x, ▷ (φ1 x ≡ φ2 x)). + Proof. + iIntros "[Hr1 Hr2]". + rewrite rel_eq /rel_def. + iDestruct "Hr1" as (γ1) "[Hrel1 Hpred1]". + iDestruct "Hr2" as (γ2) "[Hrel2 Hpred2]". + iDestruct (rels_agree with "[$Hrel1 $Hrel2]") as %->. + iIntros (x). iApply (saved_pred_agree with "Hpred1 Hpred2"). + Qed. + + + (* Definition and notation for updating a standard or local state in the STS collection *) + Definition std_update (W : WORLD) (l : Addr) (a : region_type) : WORLD := + (<[ l := a]>W.1, W.2). + Definition loc_update (W : WORLD) (l : Addr) (a : region_type) (r1 r2 r3 : region_type → region_type -> Prop) : WORLD := + (W.1,(<[encode l := encode a]>W.2.1, + <[encode l := (convert_rel r1,convert_rel r2,convert_rel r3)]>W.2.2)). + + Notation " W" := (std_update W a ρ) (at level 10, format " W"). + Notation " W" := (loc_update W a ρ r.1 r.2.1 r.2.2) (at level 10, format " W"). + + (* ------------------------------------------------------------------- *) + (* region_map is monotone with regards to public future world relation *) + + Lemma region_map_monotone W W' M Mρ : + related_sts_pub_world W W' → + region_map_def M Mρ W -∗ region_map_def M Mρ W'. + Proof. + iIntros (Hrelated) "Hr". + iApply big_sepM_mono; iFrame. + iIntros (a γ Hsome) "Hm". + iDestruct "Hm" as (ρ Hρ) "[Hstate Hm]". + iExists ρ. iFrame. iSplitR;[auto|]. + destruct ρ. + - iDestruct "Hm" as (φ Hpers) "(#Hsavedφ & Hl)". + iDestruct "Hl" as (v) "(Hl & #Hmono & Hφ)". + iExists _. do 2 (iSplitR;[eauto|]). + iFrame "#". + iFrame "∗ #". + iApply "Hmono"; iFrame; auto. + iPureIntro. by apply related_sts_pub_a_world. + - iDestruct "Hm" as (φ Hpers) "(#Hsavedφ & Hl)". + iDestruct "Hl" as (v) "(Hl & #Hmono & Hφ)". + iExists _. do 2 (iSplitR;[eauto|]). + iFrame "∗ #". + iApply "Hmono"; iFrame "∗ #"; auto. + iPureIntro. + by apply related_sts_pub_priv_world. + - done. + - done. + Qed. + + Lemma region_monotone W W' : + dom W.1 = dom W'.1 → + related_sts_pub_world W W' → region W -∗ region W'. + Proof. + iIntros (Hdomeq Hrelated) "HW". rewrite region_eq. + iDestruct "HW" as (M Mρ) "(HM & % & % & Hmap)". + iExists M, Mρ. iFrame. + iSplitR; [iPureIntro;congruence|]. + iSplitR;[auto|]. + iApply region_map_monotone; eauto. + Qed. + + Lemma uninitialized_mono_related_sts_pub_plus_world l W w : + (std W) !! l = Some (Monostatic {[l:=w]}) -> + related_sts_pub_plus_world W ( W). + Proof. + intros. split;[|apply related_sts_pub_plus_refl]. + split. + - rewrite dom_insert_L. set_solver. + - intros i x y Hx Hy. + destruct (decide (i = l)). + + subst. rewrite /std in H. + simplify_map_eq. rewrite H in Hx. + inv Hx. + (* rewrite lookup_insert in Hy. inv Hy. *) + right with Monotemporary;[|left]. + right. constructor. + + simplify_map_eq; auto. + rewrite Hx in Hy. + simplify_eq. left. + Qed. + + (* Lemma uninitialized_w_mono_related_sts_pub_world l W w : *) + (* (std W) !! l = Some (Uninitialized w) -> *) + (* related_sts_pub_world W ( W). *) + (* Proof. *) + (* intros. split;[|apply related_sts_pub_refl]. *) + (* split. *) + (* - rewrite dom_insert_L. set_solver. *) + (* - intros i x y Hx Hy. *) + (* destruct (decide (i = l)). *) + (* + subst. simplify_map_eq. *) + (* rewrite lookup_insert in Hy. inv Hy. *) + (* right with Monotemporary;[|left]. *) + (* constructor. *) + (* + simplify_map_eq. rewrite lookup_insert_ne in Hy; auto. *) + (* simplify_map_eq. left. *) + (* Qed. *) + + (* ----------------------------------------------------------------------------------------------- *) + (* ------------------------------------------- OPEN_REGION --------------------------------------- *) + + Definition open_region_def (a : Addr) (W : WORLD) : iProp Σ := + (∃ (M : relT) Mρ, RELS M ∗ ⌜dom W.1 = dom M⌝ + ∗ ⌜dom Mρ = dom M⌝ + ∗ region_map_def (delete a M) (delete a Mρ) W)%I. + Definition open_region_aux : { x | x = @open_region_def }. by eexists. Qed. + Definition open_region := proj1_sig open_region_aux. + Definition open_region_eq : @open_region = @open_region_def := proj2_sig open_region_aux. + + (* open_region is monotone wrt public future worlds *) + Lemma open_region_monotone l W W': + dom W.1 = dom W'.1 → + related_sts_pub_world W W' → + open_region l W -∗ open_region l W'. + Proof. + iIntros (Hdomeq Hrelated) "HW". rewrite open_region_eq /open_region_def. + iDestruct "HW" as (M Mρ) "(Hm & % & % & Hmap)". iExists M, Mρ. iFrame. + iSplitR;[iPureIntro;congruence|]. + iSplitR; auto. + iApply region_map_monotone; eauto. + Qed. + + (* ----------------------------------------------------------------------------------------------- *) + (* ------------------------- LEMMAS FOR OPENING THE REGION MAP ----------------------------------- *) + + Lemma region_map_delete_nonstatic M Mρ W l : + (forall m, Mρ !! l ≠ Some (Monostatic m)) → + region_map_def (delete l M) Mρ W -∗ + region_map_def (delete l M) (delete l Mρ) W. + Proof. + iIntros (Hl) "Hr". iApply (big_sepM_mono with "Hr"). + iIntros (a γr Ha) "HH". iDestruct "HH" as (ρ Hρ) "(Hsts & HH)". + iExists ρ. + iSplitR; eauto. + { iPureIntro. destruct (decide (a = l)); simplify_map_eq/=. congruence. } + iFrame. destruct ρ; try by iFrame. + iDestruct "HH" as (φ Hpers) "(#Hsavedφ & Hl)". + iDestruct "Hl" as (v) "(#Hmono & Hφ & Hothers)". + iExists _. do 2 (iSplitR;[eauto|]). + iDestruct "Hothers" as %Hothers. iFrame "#∗". + iPureIntro. + intros a' Ha'. destruct (decide (a' = l)). + { subst. exfalso. apply Hothers in Ha'. destruct Hl with g. congruence. } + { by simplify_map_eq. } + Qed. + + Lemma region_map_delete_monosingleton M Mρ W l : + (∃ w, Mρ !! l = Some (Monostatic {[l:=w]})) -> + region_map_def (delete l M) Mρ W -∗ + region_map_def (delete l M) (delete l Mρ) W. + Proof. + iIntros (Hl) "Hr". iApply (big_sepM_mono with "Hr"). + iIntros (a γr Ha) "HH". iDestruct "HH" as (ρ Hρ) "(Hsts & HH)". + iExists ρ. + iSplitR; eauto. + { iPureIntro. destruct (decide (a = l)); simplify_map_eq/=. congruence. } + iFrame. destruct ρ; try by iFrame. + iDestruct "HH" as (φ Hpers) "(#Hsavedφ & Hl)". + iDestruct "Hl" as (v) "(% & Hφ & Hothers)". + iExists _. do 2 (iSplitR;[eauto|]). + iDestruct "Hothers" as %Hothers. iFrame "#". + iExists _. iSplitR; eauto. iFrame. iPureIntro. + intros a' Ha'. destruct (decide (a' = l)). + { subst. destruct Hl as [w Hl]. + exfalso. assert (l ≠ a) as Hne;[intros Hcontr;subst;rewrite lookup_delete in Ha;inversion Ha|]. + apply Hothers in Ha'. rewrite Hl in Ha'. inversion Ha'. subst. simplify_map_eq. } + { by simplify_map_eq. } + Qed. + + Lemma region_open_monotemp W l φ : + (std W) !! l = Some Monotemporary → + rel l φ ∗ region W ∗ sts_full_world W -∗ + ∃ v, open_region l W + ∗ sts_full_world W + ∗ sts_state_std l Monotemporary + ∗ l ↦ₐ v + ∗ ▷ future_pub_a_mono l φ v + ∗ ▷ φ (W,v). + Proof. + iIntros (Htemp) "(Hrel & Hreg & Hfull)". + rewrite rel_eq region_eq /rel_def /region_def REL_eq RELS_eq /REL_def /RELS_def /region_map_def. + iDestruct "Hrel" as (γpred) "#(Hγpred & Hφ)". + iDestruct "Hreg" as (M Mρ) "(HM & % & % & Hpreds)". + (* assert that γrel = γrel' *) + iDestruct (reg_in γrel (M) with "[$HM $Hγpred]") as %HMeq. + rewrite HMeq big_sepM_insert; [|by rewrite lookup_delete]. + iDestruct "Hpreds" as "[Hl Hpreds]". + iDestruct "Hl" as (ρ Hρ) "[Hstate Hl]". + iDestruct (sts_full_state_std with "Hfull Hstate") as %Hst. + rewrite Htemp in Hst. (destruct ρ; try by simplify_eq); []. + iDestruct "Hl" as (φ' Hpers) "(#Hφ' & Hl)". + iDestruct "Hl" as (v) "(Hl & #Hmono & Hφv)". + iDestruct (saved_pred_agree _ _ _ _ _ (W,v) with "Hφ Hφ'") as "#Hφeq". + iExists v. iFrame. + iSplitR "Hφv". + - rewrite open_region_eq /open_region_def. + iExists _. rewrite RELS_eq /RELS_def -HMeq. iFrame "∗ #". + iExists Mρ. do 2 (iSplitR; eauto). + iApply region_map_delete_nonstatic; auto. rewrite Hρ; auto. + - iSplitR. + + rewrite /future_pub_mono. + iApply later_intuitionistically_2. iModIntro. + repeat (iApply later_forall_2; iIntros (?)). + iDestruct (saved_pred_agree _ _ _ _ _ (a,v) with "Hφ Hφ'") as "#Hφeq'". + iDestruct (saved_pred_agree _ _ _ _ _ (a0,v) with "Hφ Hφ'") as "#Hφeq''". + iNext. iIntros (Hrel) "Hφw". + iRewrite ("Hφeq''"). + iApply "Hmono"; eauto. + iRewrite -("Hφeq'"). iFrame. + + iNext. iRewrite "Hφeq". iFrame "∗ #". + Qed. + + Lemma region_open_perm W l φ : + (std W) !! l = Some Permanent → + rel l φ ∗ region W ∗ sts_full_world W -∗ + ∃ v, open_region l W + ∗ sts_full_world W + ∗ sts_state_std l Permanent + ∗ l ↦ₐ v + ∗ ▷ future_priv_mono φ v + ∗ ▷ φ (W,v). + Proof. + iIntros (Htemp) "(Hrel & Hreg & Hfull)". + rewrite rel_eq region_eq /rel_def /region_def REL_eq RELS_eq /REL_def /RELS_def /region_map_def. + iDestruct "Hrel" as (γpred) "#[Hγpred Hφ]". + iDestruct "Hreg" as (M Mρ) "(HM & % & % & Hpreds)". + (* assert that γrel = γrel' *) + iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. + rewrite HMeq big_sepM_insert; [|by rewrite lookup_delete]. + iDestruct "Hpreds" as "[Hl Hpreds]". + iDestruct "Hl" as (ρ Hρ) "[Hstate Hl]". + iDestruct (sts_full_state_std with "Hfull Hstate") as %Hst. + rewrite Htemp in Hst. (destruct ρ; try by simplify_eq); []. + iDestruct "Hl" as (φ' Hpers) "(#Hφ' & Hl)". + iDestruct "Hl" as (v) "(Hl & #Hmono & Hφv)". + iDestruct (saved_pred_agree _ _ _ _ _ (W,v) with "Hφ Hφ'") as "#Hφeq". + iExists v. iFrame. + iSplitR "Hφv". + - rewrite open_region_eq /open_region_def. + iExists _. rewrite RELS_eq /RELS_def -HMeq. iFrame "∗ #". + iExists _. do 2 (iSplitR; eauto). + iApply region_map_delete_nonstatic; auto. rewrite Hρ;auto. + - iSplitR. + + rewrite /future_priv_mono. + iApply later_intuitionistically_2. iModIntro. + repeat (iApply later_forall_2; iIntros (?)). + iDestruct (saved_pred_agree _ _ _ _ _ (a0,v) with "Hφ Hφ'") as "#Hφeq'". + iDestruct (saved_pred_agree _ _ _ _ _ (a,v) with "Hφ Hφ'") as "#Hφeq''". + iNext. iIntros (Hrel) "Hφw". + iRewrite ("Hφeq'"). + iApply "Hmono"; eauto. + iRewrite -("Hφeq''"). iFrame. + + iNext. iRewrite "Hφeq". iFrame "∗ #". + Qed. + + (* Lemma region_open_uninitialized W l v φ : *) + (* (std W) !! l = Some (Uninitialized v) → *) + (* rel l φ ∗ region W ∗ sts_full_world W -∗ *) + (* open_region l W *) + (* ∗ sts_full_world W *) + (* ∗ sts_state_std l (Uninitialized v) *) + (* ∗ l ↦ₐ v. *) + (* Proof. *) + (* iIntros (Htemp) "(Hrel & Hreg & Hfull)". *) + (* rewrite region_eq /region_def /region_map_def rel_eq /rel_def REL_eq /REL_def. *) + (* iDestruct "Hreg" as (M Mρ) "(HM & HMW & % & Hpreds)". iDestruct "HMW" as %HMW. *) + (* iDestruct "Hrel" as (γpred) "#[Hγpred Hφ]". *) + (* rewrite RELS_eq /RELS_def. *) + (* iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. *) + (* assert (is_Some(M !! l)) as [γp HX]. *) + (* { apply elem_of_dom. rewrite -HMW. apply (elem_of_dom W.1 l). eauto. } *) + (* iDestruct (big_sepM_delete with "Hpreds") as "[Hl Hpreds]"; eauto. *) + (* iDestruct "Hl" as (ρ) "[ % [Hstate Hl] ]". destruct ρ. *) + (* 1,2,3,4,5: iDestruct (sts_full_state_std with "Hfull Hstate") as %Hcontr. *) + (* 1,2,3,4,5: rewrite Htemp in Hcontr; try by inversion Hcontr. *) + (* iDestruct "Hl" as (φ') "(#Hpers & #Hsaved & Hl)". inversion Hcontr. *) + (* subst. *) + (* rewrite open_region_eq /open_region_def RELS_eq /RELS_def. iFrame. *) + (* iExists Mρ. iFrame. *) + (* repeat iSplit;auto. iApply region_map_delete_nonstatic; eauto. *) + (* rewrite H1. eauto. *) + (* Qed. *) + + Lemma region_open W l φ (ρ : region_type) : + ρ = Permanent ∨ ρ = Monotemporary → + (std W) !! l = Some ρ → + rel l φ ∗ region W ∗ sts_full_world W -∗ + ∃ v, open_region l W + ∗ sts_full_world W + ∗ sts_state_std l ρ + ∗ l ↦ₐ v + ∗ (▷ if (decide (ρ = Monotemporary)) + then future_pub_a_mono l φ v + else future_priv_mono φ v) + ∗ ▷ φ (W,v). + Proof. + iIntros (Hne Htemp) "(Hrel & Hreg & Hfull)". + destruct ρ; destruct Hne as [Hne | Hne]; try (exfalso; congruence). + - iDestruct (region_open_monotemp with "[$Hrel $Hreg $Hfull]") as (v) "(Hr & Hfull & Hstate & Hl & Hmono & φ)"; auto. + iExists _; iFrame. + - iDestruct (region_open_perm with "[$Hrel $Hreg $Hfull]") as (v) "(Hr & Hfull & Hstate & Hl & Hmono & φ)"; auto. + iExists _; iFrame. + Qed. + + (* It is important here that we have (delete l Mρ) and not simply Mρ. + Otherwise, [Mρ !! l] could in principle map to a static region (although + it's not the case in practice), that it would be incorrect to overwrite + with a non-static state. *) + Lemma region_map_undelete_nonmonostatic M Mρ W l : + (forall m, Mρ !! l ≠ Some (Monostatic m)) → + region_map_def (delete l M) (delete l Mρ) W -∗ + region_map_def (delete l M) Mρ W. + Proof. + iIntros (Hl) "Hr". iApply (big_sepM_mono with "Hr"). + iIntros (a γr Ha) "HH". iDestruct "HH" as (ρ Hρ) "(Hsts & HH)". + iExists ρ. + iSplitR; eauto. + { iPureIntro. destruct (decide (a = l)); simplify_map_eq/=. congruence. } + iFrame. destruct ρ; try by iFrame. + iDestruct "HH" as (φ' Hpers) "(#Hφ' & Hl)". + iDestruct "Hl" as (v HH2) "(Hl & Hothers)". + iDestruct "Hothers" as %Hothers. + iExists _. iSplitR; eauto. iFrame "∗ #". + repeat iSplit;auto. iPureIntro. + intros a' Ha'. apply Hothers in Ha'. + destruct (decide (a' = l)); by simplify_map_eq. + Qed. + + Lemma region_map_insert_nonmonostatic ρ M Mρ W l : + (forall m, ρ ≠ Monostatic m) → + region_map_def (delete l M) (delete l Mρ) W -∗ + region_map_def (delete l M) (<[ l := ρ ]> Mρ) W. + Proof. + iIntros (?) "HH". + rewrite {1}(_: delete l Mρ = delete l (<[ l := ρ ]> Mρ)). 2: by rewrite delete_insert_delete//. + iDestruct (region_map_undelete_nonmonostatic with "HH") as "HH". + { intro. simplify_map_eq. congruence. } + auto. + Qed. + + (* We can apply the same reasoning to singleton static regions (i.e. uninitialised regions) *) + Lemma region_map_undelete_monosingleton M Mρ W l : + (∃ w, Mρ !! l = Some (Monostatic {[l:=w]})) → + region_map_def (delete l M) (delete l Mρ) W -∗ + region_map_def (delete l M) Mρ W. + Proof. + iIntros (Hl) "Hr". iApply (big_sepM_mono with "Hr"). + iIntros (a γr Ha) "HH". iDestruct "HH" as (ρ Hρ) "(Hsts & HH)". + iExists ρ. + iSplitR; eauto. + { iPureIntro. destruct (decide (a = l)); simplify_map_eq/=. congruence. } + iFrame. destruct ρ; try by iFrame. + iDestruct "HH" as (φ' Hpers) "(#Hφ' & Hl)". + iDestruct "Hl" as (v HH2) "(Hl & Hothers)". + iDestruct "Hothers" as %Hothers. + iExists _. iSplitR; eauto. iFrame "∗ #". + repeat iSplit;auto. iPureIntro. + intros a' Ha'. apply Hothers in Ha'. + destruct (decide (a' = l)); by simplify_map_eq. + Qed. + + Lemma region_map_insert_monosingleton ρ M Mρ W l : + (∃ w, ρ = Monostatic {[l:=w]}) → + region_map_def (delete l M) (delete l Mρ) W -∗ + region_map_def (delete l M) (<[ l := ρ ]> Mρ) W. + Proof. + iIntros (?) "HH". + rewrite {1}(_: delete l Mρ = delete l (<[ l := ρ ]> Mρ)). 2: by rewrite delete_insert_delete//. + iDestruct (region_map_undelete_monosingleton with "HH") as "HH". + { simplify_map_eq. naive_solver. } + auto. + Qed. + + + Lemma full_sts_Mρ_agree W M Mρ (ρ: region_type) : + (* NB: only the forward direction of dom_equal (std_sta W) M is actually needed *) + dom (std W) = dom M → + (* NB: only one direction of this assumption is needed, and only for the reverse *) + (* direction of the lemma *) + dom Mρ = dom M → + sts_full_world W -∗ + region_map_def M Mρ W -∗ + ⌜∀ a:Addr, (std W) !! a = Some ρ ↔ Mρ !! a = Some ρ⌝. + Proof. + iIntros (HWM HMMρ) "Hfull Hr". + iAssert (∀ a:Addr, ⌜ std W !! a = Some ρ ⌝ → ⌜ Mρ !! a = Some ρ ⌝)%I as %?. + { iIntros (a Haρ). + assert (is_Some (M !! a)) as [γp Hγp]. + { apply elem_of_dom. + rewrite -HWM. apply (elem_of_dom (std W)) . eauto. } + iDestruct (big_sepM_lookup with "Hr") as (ρ' Hρ') "(Hst & _)"; eauto; []. + iDestruct (sts_full_state_std with "Hfull Hst") as %Haρ'. + enough (ρ = ρ') by (subst; eauto). apply encode_inj. + rewrite Haρ in Haρ'. congruence. } + iAssert (∀ a:Addr, ⌜ Mρ !! a = Some ρ ⌝ → ⌜ std W !! a = Some ρ ⌝)%I as %?. + { iIntros (a HMρa). + assert (is_Some (M !! a)) as [γp Hγp]. + { rewrite -elem_of_dom -HMMρ elem_of_dom; eauto. } + iDestruct (big_sepM_lookup with "Hr") as (ρ' Hρ') "(Hst & _)"; eauto; []. + iDestruct (sts_full_state_std with "Hfull Hst") as %Haρ'. + enough (ρ = ρ') by (subst; eauto). rewrite HMρa in Hρ'. congruence. } + iPureIntro. intros. split; eauto. + Qed. + + Lemma full_sts_monostatic_all W m (l : Addr) : + (std W) !! l = Some (Monostatic m) → + sts_full_world W -∗ + region W -∗ + ⌜forall a, a ∈ dom m -> monostatic W m a⌝. + Proof. + iIntros (Hstatic) "Hsts Hr". + rewrite region_eq /region_def. + iDestruct "Hr" as (M Mρ) "(HM & #Hdom1 & #Hdom2 & Hr)". + iDestruct "Hdom1" as %Hdom1. iDestruct "Hdom2" as %Hdom2. + iIntros (a Hdom). + iDestruct (full_sts_Mρ_agree _ _ _ (Monostatic m) with "Hsts Hr") as "%Hag'"; eauto. + destruct (Hag' l) as [Hag _]. clear Hag'. + pose proof (Hag Hstatic) as Hl. + assert (is_Some (M !! l)) as [γp Hsome]. + { apply elem_of_dom. rewrite -Hdom1. rewrite elem_of_dom . eauto. } + rewrite /region_map_def. + iDestruct (big_sepM_delete _ _ l with "Hr") as "[Hl Hr]";[eauto|]. + iDestruct "Hl" as (ρ Hρ) "(Hstate & Hρ)". + rewrite Hag in Hρ; auto. inversion Hρ. + iDestruct "Hρ" as (φ Hpers) "(#Hsaved & Hl)". + iDestruct "Hl" as (v Hpv') "[Hl #Hall]". iDestruct "Hall" as %Hall. + iDestruct (big_sepM_delete _ _ l with "[$Hr Hl Hstate]") as "Hr";[eauto|..]. + { iExists ρ. iSplitR;subst;auto. iFrame. iExists _. repeat iSplit;eauto. } + iDestruct (full_sts_Mρ_agree _ _ _ (Monostatic m) with "Hsts Hr") as "%Hag'"; auto. + iPureIntro. + rewrite /monostatic. + destruct (Hag' a) as [_ Hag2]. + pose proof (Hall _ Hdom) as Ha. + rewrite /std in Hag2. + by pose proof (Hag2 Ha) as ->. + Qed. + + (* Closing the region without updating the sts collection *) + Lemma region_close_monotemp W l φ v `{forall Wv, Persistent (φ Wv)} : + ⊢ sts_state_std l Monotemporary + ∗ open_region l W ∗ l ↦ₐ v ∗ future_pub_a_mono l φ v ∗ ▷ φ (W,v) ∗ rel l φ + -∗ region W. + Proof. + rewrite open_region_eq rel_eq region_eq /open_region_def /rel_def /region_def + REL_eq RELS_eq /RELS_def /REL_def. + iIntros "(Hstate & Hreg_open & Hl & #Hmono & Hφ & #Hrel)". + iDestruct "Hrel" as (γpred) "#[Hγpred Hφ_saved]". + iDestruct "Hreg_open" as (M Mρ) "(HM & % & Hdomρ & Hpreds)". iDestruct "Hdomρ" as %Hdomρ. + iDestruct (region_map_insert_nonmonostatic Monotemporary with "Hpreds") as "Hpreds". by congruence. + iDestruct (big_sepM_insert _ (delete l M) l with "[-HM]") as "test"; + first by rewrite lookup_delete. + { iFrame. iSplitR; [by simplify_map_eq|]. + iExists _. iFrame "∗ #". repeat (iSplitR;[eauto|]). iFrame. auto. } + iFrame. iFrame "∗ #". + iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. + rewrite -HMeq. iFrame. iSplitR; eauto. iPureIntro. + rewrite HMeq !insert_delete_insert !dom_insert_L Hdomρ. set_solver. + Qed. + + (* Lemma region_close_mono_uninit_w E W l φ w v `{forall Wv, Persistent (φ Wv)} : *) + (* sts_state_std l (Uninitialized w) *) + (* ∗ open_region l W *) + (* ∗ l ↦ₐ v *) + (* ∗ future_pub_a_mono l φ v *) + (* ∗ ▷ φ (W,v) (* Maybe φ ( W, v) *) *) + (* ∗ rel l φ *) + (* ∗ sts_full_world W *) + (* ={E}=∗ region ( W) ∗ sts_full_world ( W). *) + (* Proof. *) + (* rewrite open_region_eq rel_eq region_eq /open_region_def /rel_def /region_def *) + (* REL_eq RELS_eq /RELS_def /REL_def. *) + (* iIntros "(Hstate & Hreg_open & Hl & #Hmono & #Hφ & #Hrel & Hfull)". *) + (* iDestruct "Hrel" as (γpred) "#[Hγpred Hφ_saved]". *) + (* iDestruct "Hreg_open" as (M Mρ) "(HM & HMW & HMρ & Hpreds)". *) + (* iDestruct "HMW" as %HMW. iDestruct "HMρ" as %HMρ. *) + (* iDestruct (sts_full_state_std with "Hfull Hstate") as "%". *) + (* iDestruct (sts_update_std with "Hfull Hstate") as ">[Hfull Hstate]". *) + (* iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. *) + (* iModIntro. iFrame "Hfull". *) + (* iDestruct (region_map_insert_nonmonostatic Monotemporary with "Hpreds") as "Hpreds";[intros;auto|]. *) + (* iDestruct (big_sepM_insert _ (delete l M) l with "[-HM]") as "test"; *) + (* first by rewrite lookup_delete. *) + (* { iFrame. iFrame. *) + (* iSplit;[iPureIntro;apply lookup_insert|]. *) + (* iExists _. iFrame "∗ #". repeat iSplitR; auto. } *) + (* assert (Hpub: related_sts_pub_world W (W)). *) + (* { eapply (uninitialized_w_mono_related_sts_pub_world l W); eauto. } *) + (* iDestruct (region_map_monotone _ _ _ _ Hpub with "test") as "HMdef"; eauto. *) + (* rewrite -HMeq. iExists M,_; iFrame. iPureIntro. *) + (* repeat rewrite dom_insert_L. assert (l ∈ dom W.1) as Hin;[rewrite elem_of_dom;eauto|]. *) + (* split;[rewrite -HMW| rewrite HMρ -HMW];set_solver. *) + (* Qed. *) + + Lemma region_close_perm W l φ v `{forall Wv, Persistent (φ Wv)}: + ⊢ sts_state_std l Permanent + ∗ open_region l W ∗ l ↦ₐ v ∗ future_priv_mono φ v ∗ ▷ φ (W,v) ∗ rel l φ + -∗ region W. + Proof. + rewrite open_region_eq rel_eq region_eq /open_region_def /rel_def /region_def + REL_eq RELS_eq /RELS_def /REL_def. + iIntros "(Hstate & Hreg_open & Hl & #Hmono & Hφ & #Hrel)". + iDestruct "Hrel" as (γpred) "#[Hγpred Hφ_saved]". + iDestruct "Hreg_open" as (M Mρ) "(HM & % & Hdomρ & Hpreds)". iDestruct "Hdomρ" as %Hdomρ. + + iDestruct (region_map_insert_nonmonostatic Permanent with "Hpreds") as "Hpreds". by congruence. + iDestruct (big_sepM_insert _ (delete l M) l with "[-HM]") as "test"; + first by rewrite lookup_delete. + { iFrame. iFrame. iSplitR; [by simplify_map_eq|]. + iFrame "∗ #". repeat (iSplitR;[eauto|]). iFrame. auto. } + iExists _,_. iFrame "∗ #". + iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. + rewrite -HMeq. iFrame. iSplitR; eauto. iPureIntro. + rewrite HMeq !insert_delete_insert !dom_insert_L Hdomρ. set_solver. + Qed. + + Lemma region_close W l φ v (ρ : region_type) `{forall Wv, Persistent (φ Wv)} : + ρ = Permanent ∨ ρ = Monotemporary→ + sts_state_std l ρ + ∗ open_region l W ∗ l ↦ₐ v ∗ + (if (decide (ρ = Monotemporary)) + then future_pub_a_mono l φ v + else future_priv_mono φ v) ∗ ▷ φ (W,v) ∗ rel l φ + -∗ region W. + Proof. + iIntros (Htp) "(Hstate & Hreg_open & Hl & Hmono & Hφ & Hrel)". + destruct ρ; try (destruct Htp as [Htp | Htp ]; exfalso; congruence). + - iApply region_close_monotemp; eauto. iFrame. + - iApply region_close_perm; eauto. iFrame. + Qed. + + (* ---------------------------------------------------------------------------------------- *) + (* ----------------------- OPENING MULTIPLE LOCATIONS IN REGION --------------------------- *) + + Definition open_region_many_def (l : list Addr) (W : WORLD) : iProp Σ := + (∃ M Mρ, RELS M ∗ ⌜dom (std W) = dom M⌝ + ∗ ⌜dom Mρ = dom M⌝ + ∗ region_map_def (delete_list l M) (delete_list l Mρ) W)%I. + Definition open_region_many_aux : { x | x = @open_region_many_def }. by eexists. Qed. + Definition open_region_many := proj1_sig open_region_many_aux. + Definition open_region_many_eq : @open_region_many = @open_region_many_def := proj2_sig open_region_many_aux. + + Lemma open_region_many_monotone l W W': + dom (std W) = dom (std W') → + related_sts_pub_world W W' → + open_region_many l W -∗ open_region_many l W'. + Proof. + iIntros (Hdomeq Hrelated) "HW". rewrite open_region_many_eq /open_region_many_def. + iDestruct "HW" as (M Mρ) "(Hm & % & % & Hmap)". iExists M, Mρ. iFrame. + iSplitR;[iPureIntro;congruence|]. + iSplitR; auto. + iApply region_map_monotone; eauto. + Qed. + + Lemma open_region_many_permutation l1 l2 W: + l1 ≡ₚ l2 → open_region_many l1 W -∗ open_region_many l2 W. + Proof. + intros Hperm. + rewrite open_region_many_eq /open_region_many_def. + iIntros "H". iDestruct "H" as (? ?) "(? & % & % & ?)". + rewrite !(delete_list_permutation l1 l2) //. iExists _,_. iFrame. eauto. + Qed. + + Lemma region_open_prepare l W : + open_region l W ⊣⊢ open_region_many [l] W. + Proof. + iSplit; iIntros "Hopen"; + rewrite open_region_eq open_region_many_eq /=; + iFrame. + Qed. + + Lemma region_open_nil W : + region W ⊣⊢ open_region_many [] W. + Proof. + iSplit; iIntros "H"; + rewrite region_eq open_region_many_eq /=; + iFrame. + Qed. + + Lemma region_open_next_monotemp W φ ls l : + l ∉ ls → + (std W) !! l = Some Monotemporary -> + open_region_many ls W ∗ rel l φ ∗ sts_full_world W -∗ + ∃ v, open_region_many (l :: ls) W + ∗ sts_full_world W + ∗ sts_state_std l Monotemporary + ∗ l ↦ₐ v + ∗ ▷ future_pub_a_mono l φ v + ∗ ▷ φ (W,v). + Proof. + rewrite open_region_many_eq . + iIntros (Hnin Htemp) "(Hopen & #Hrel & Hfull)". + rewrite /open_region_many_def /region_map_def /=. + rewrite rel_eq /rel_def /rel_def /region_def REL_eq RELS_eq /rel /region /REL /RELS. + iDestruct "Hrel" as (γpred) "#[Hγpred Hφ]". + iDestruct "Hopen" as (M Mρ) "(HM & % & % & Hpreds)". + iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. + rewrite HMeq delete_list_insert; auto. + rewrite delete_list_delete; auto. + rewrite HMeq big_sepM_insert; [|by rewrite lookup_delete]. + iDestruct "Hpreds" as "[Hl Hpreds]". + iDestruct "Hl" as (ρ Hρ) "[Hstate Hl]". + iDestruct (sts_full_state_std with "Hfull Hstate") as %Hst. + rewrite Htemp in Hst. (destruct ρ; try by simplify_eq); []. + iDestruct "Hl" as (φ' Hpers) "(#Hφ' & Hl)". + iDestruct "Hl" as (v) "(Hl & #Hmono & Hφv)". + iDestruct (saved_pred_agree _ _ _ _ _ (W,v) with "Hφ Hφ'") as "#Hφeq". + iExists _. iFrame. + iSplitR "Hφv". + - iExists _. repeat (rewrite -HMeq). iFrame "∗ #". + do 2 (iSplitR; eauto). + iApply region_map_delete_nonstatic; auto. rewrite Hρ;auto. + - iSplitR;[auto|]. + + rewrite /future_pub_mono. + iApply later_intuitionistically_2. iModIntro. + repeat (iApply later_forall_2; iIntros (?)). + iDestruct (saved_pred_agree _ _ _ _ _ (a,v) with "Hφ Hφ'") as "#Hφeq'". + iDestruct (saved_pred_agree _ _ _ _ _ (a0,v) with "Hφ Hφ'") as "#Hφeq''". + iNext. iIntros (Hrel) "Hφw". + iRewrite ("Hφeq''"). + iApply "Hmono"; eauto. + iRewrite -("Hφeq'"). iFrame. + + iNext. + iRewrite "Hφeq". iFrame. + Qed. + + Lemma region_open_next_perm W φ ls l : + l ∉ ls → (std W) !! l = Some Permanent -> + open_region_many ls W ∗ rel l φ ∗ sts_full_world W -∗ + ∃ v, sts_full_world W + ∗ sts_state_std l Permanent + ∗ open_region_many (l :: ls) W + ∗ l ↦ₐ v + ∗ ▷ future_priv_mono φ v + ∗ ▷ φ (W,v). + Proof. + rewrite open_region_many_eq . + iIntros (Hnin Htemp) "(Hopen & #Hrel & Hfull)". + rewrite /open_region_many_def /= /region_map_def. + rewrite rel_eq /rel_def /rel_def /region_def REL_eq RELS_eq /rel /region /REL /RELS. + iDestruct "Hrel" as (γpred) "#[Hγpred Hφ]". + iDestruct "Hopen" as (M Mρ) "(HM & % & % & Hpreds)". + iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. + rewrite HMeq delete_list_insert; auto. + rewrite delete_list_delete; auto. + rewrite HMeq big_sepM_insert; [|by rewrite lookup_delete]. + iDestruct "Hpreds" as "[Hl Hpreds]". + iDestruct "Hl" as (ρ Hρ) "[Hstate Hl]". + iDestruct (sts_full_state_std with "Hfull Hstate") as %Hst. + rewrite Htemp in Hst. (destruct ρ; try by simplify_eq); []. + iDestruct "Hl" as (φ' Hpers) "(#Hφ' & Hl)". + iDestruct "Hl" as (v) "(Hl & #Hmono & Hφv)". + iDestruct (saved_pred_agree _ _ _ _ _ (W,v) with "Hφ Hφ'") as "#Hφeq". + iExists _. iFrame. + iSplitR "Hφv". + - rewrite /open_region. + iExists _. repeat (rewrite -HMeq). iFrame "∗ #". do 2 (iSplitR; eauto). + iApply region_map_delete_nonstatic; auto. rewrite Hρ;auto. + - iSplitR;[auto|]. + + iApply later_intuitionistically_2. iModIntro. + repeat (iApply later_forall_2; iIntros (?)). + iDestruct (saved_pred_agree _ _ _ _ _ (a0,v) with "Hφ Hφ'") as "#Hφeq'". + iDestruct (saved_pred_agree _ _ _ _ _ (a,v) with "Hφ Hφ'") as "#Hφeq''". + iNext. iIntros (Hrel) "Hφw". + iRewrite ("Hφeq'"). + iApply "Hmono"; eauto. + iRewrite -("Hφeq''"). iFrame. + + iNext. + iRewrite "Hφeq". iFrame. + Qed. + + Lemma region_open_next_monouninit W w ls l φ : + l ∉ ls → + (std W) !! l = Some (Monostatic {[l:=w]}) → + rel l φ ∗ open_region_many ls W ∗ sts_full_world W -∗ + open_region_many (l :: ls) W + ∗ sts_full_world W + ∗ sts_state_std l (Monostatic {[l:=w]}) + ∗ l ↦ₐ w. + Proof. + iIntros (Hnin Htemp) "(Hrel & Hreg & Hfull)". + rewrite open_region_many_eq /open_region_many_def /= /region_map_def rel_eq /rel_def REL_eq /REL_def. + iDestruct "Hreg" as (M Mρ) "(HM & HMW & % & Hpreds)". iDestruct "HMW" as %HMW. + rewrite RELS_eq /RELS_def. + iDestruct "Hrel" as (γpred) "#[Hγpred Hφ]". + iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. + assert (is_Some (M !! l)) as [γp HX]. + { apply elem_of_dom. rewrite -HMW. rewrite elem_of_dom. eauto. } + iDestruct (big_sepM_delete with "Hpreds") as "[Hl Hpreds]"; eauto. + { rewrite lookup_delete_list_notin; eauto. } + iDestruct "Hl" as (ρ) "[% [Hstate Hl] ]". destruct ρ. + 1,2,3,4: iDestruct (sts_full_state_std with "Hfull Hstate") as %Hcontr. + 1,2,3,4: rewrite Htemp in Hcontr; try by inversion Hcontr. + iDestruct "Hl" as (φ' Hpers) "[#Hsaved Hl]". + iDestruct "Hl" as (v Hlookup) "[Hl _]". + inversion Hcontr; subst g. + rewrite lookup_insert in Hlookup;inversion Hlookup. iFrame. + iExists Mρ. iFrame "∗ #". + iDestruct (region_map_delete_monosingleton with "Hpreds") as "Hpreds"; eauto. + Qed. + + (* Lemma region_open_next_monouninit_w W w ls l φ : *) + (* l ∉ ls → *) + (* (std W) !! l = Some (Uninitialized w) → *) + (* rel l φ ∗ open_region_many ls W ∗ sts_full_world W -∗ *) + (* open_region_many (l :: ls) W *) + (* ∗ sts_full_world W *) + (* ∗ sts_state_std l (Uninitialized w) *) + (* ∗ l ↦ₐ w. *) + (* Proof. *) + (* iIntros (Hnin Htemp) "(Hrel & Hreg & Hfull)". *) + (* rewrite open_region_many_eq /open_region_many_def /= /region_map_def rel_eq /rel_def REL_eq /REL_def. *) + (* iDestruct "Hreg" as (M Mρ) "(HM & HMW & % & Hpreds)". iDestruct "HMW" as %HMW. *) + (* rewrite RELS_eq /RELS_def. *) + (* iDestruct "Hrel" as (γpred) "#[Hγpred Hφ]". *) + (* iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. *) + (* assert (is_Some (M !! l)) as [γp HX]. *) + (* { apply elem_of_dom. rewrite -HMW. rewrite elem_of_dom. eauto. } *) + (* iDestruct (big_sepM_delete with "Hpreds") as "[Hl Hpreds]"; eauto. *) + (* { rewrite lookup_delete_list_notin; eauto. } *) + (* iDestruct "Hl" as (ρ) "[% [Hstate Hl] ]". destruct ρ. *) + (* 1,2,3,4,5: iDestruct (sts_full_state_std with "Hfull Hstate") as %Hcontr. *) + (* 1,2,3,4,5: rewrite Htemp in Hcontr; try by inversion Hcontr. *) + (* iDestruct "Hl" as (φ' Hpers) "[#Hsaved Hl]". *) + (* inversion Hcontr; subst w. *) + (* iFrame. *) + (* iExists Mρ. iFrame "∗ #". *) + (* iDestruct (region_map_delete_nonstatic with "Hpreds") as "Hpreds"; eauto. *) + (* rewrite H1. eauto. *) + (* Qed. *) + + Lemma region_close_next_monotemp W φ ls l v `{forall Wv, Persistent (φ Wv)} : + l ∉ ls -> + ⊢ sts_state_std l Monotemporary ∗ + open_region_many (l::ls) W ∗ l ↦ₐ v ∗ future_pub_a_mono l φ v ∗ ▷ φ (W,v) ∗ rel l φ + -∗ open_region_many ls W. + Proof. + rewrite open_region_many_eq /open_region_many_def. + iIntros (Hnin) "(Hstate & Hreg_open & Hl & #Hmono & Hφ & #Hrel)". + rewrite rel_eq /rel_def REL_eq RELS_eq /rel /region /RELS /REL. + iDestruct "Hrel" as (γpred) "#[Hγpred Hφ_saved]". + iDestruct "Hreg_open" as (M Mρ) "(HM & % & Hdomρ & Hpreds)". iDestruct "Hdomρ" as %Hdomρ. + iDestruct (region_map_insert_nonmonostatic Monotemporary with "Hpreds") as "Hpreds". congruence. + rewrite -!/delete_list. + iDestruct (big_sepM_insert _ (delete l (delete_list ls M)) l with "[-HM]") as "test"; + first by rewrite lookup_delete. + { iFrame. iSplitR; [by simplify_map_eq|]. + iFrame "∗ #". repeat (iSplitR;[eauto|]). iFrame. auto. } + rewrite -(delete_list_delete _ M) //. + rewrite -(delete_list_insert _ (delete l M)) //. + rewrite -(delete_list_insert _ Mρ) //. + iExists (<[l:=γpred ]> (delete l M)), (<[l:=Monotemporary]> Mρ). iFrame. + iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. + rewrite -HMeq. iFrame. iSplitR; eauto. iPureIntro. + rewrite HMeq !insert_delete_insert !dom_insert_L Hdomρ. set_solver. + Qed. + + (* Lemma region_close_next_mono_uninit_w E W ls l φ w v `{forall Wv, Persistent (φ Wv)} : *) + (* l ∉ ls -> *) + (* sts_state_std l (Uninitialized w) *) + (* ∗ open_region_many (l::ls) W *) + (* ∗ l ↦ₐ v *) + (* ∗ future_pub_a_mono l φ v *) + (* ∗ ▷ φ (W,v) (* Maybe φ ( W, v) *) *) + (* ∗ rel l φ *) + (* ∗ sts_full_world W *) + (* ={E}=∗ open_region_many ls ( W) ∗ sts_full_world ( W). *) + (* Proof. *) + (* rewrite open_region_many_eq rel_eq /open_region_many_def /rel_def /region_def *) + (* REL_eq RELS_eq /RELS_def /REL_def. *) + (* iIntros (Hnin) "(Hstate & Hreg_open & Hl & #Hmono & Hφ & #Hrel & Hfull)". *) + (* iDestruct "Hrel" as (γpred) "#[Hγpred Hφ_saved]". *) + (* iDestruct "Hreg_open" as (M Mρ) "(HM & HMW & HMρ & Hpreds)". *) + (* iDestruct "HMW" as %HMW. iDestruct "HMρ" as %HMρ. *) + (* iDestruct (sts_full_state_std with "Hfull Hstate") as "%". *) + (* iDestruct (sts_update_std with "Hfull Hstate") as ">[Hfull Hstate]". *) + (* iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. *) + (* iModIntro. iSplitR "Hfull". *) + (* { iDestruct (big_sepM_insert _ (delete l (delete_list ls M)) l with "[-HM]") as "Hmap_def"; *) + (* first by rewrite lookup_delete. *) + (* { simpl. iDestruct (region_map_insert_nonmonostatic Monotemporary with "Hpreds") as "Hpreds". by congruence. *) + (* iFrame. *) + (* iSplit;[iPureIntro;apply lookup_insert|]. *) + (* iExists _. iFrame "∗ #". repeat iSplitR; auto. } *) + (* assert (Hpub: related_sts_pub_world W (W)). *) + (* { eapply (uninitialized_w_mono_related_sts_pub_world l W); eauto. } *) + (* iDestruct (region_map_monotone _ _ _ _ Hpub with "Hmap_def") as "HMdef"; eauto. *) + (* iExists M,(<[l:=Monotemporary]>Mρ); iFrame. rewrite HMeq. *) + (* repeat rewrite dom_insert_L. rewrite dom_delete_L. *) + (* assert (l ∈ dom W.1) as Hin;[rewrite elem_of_dom;eauto|]. *) + (* assert ({[l]} ∪ dom (std W) ∖ {[l]} = dom (std W)) as Heq. *) + (* { rewrite union_comm_L difference_union_L. set_solver. } *) + (* repeat iSplit. *) + (* - iPureIntro. rewrite -HMW. set_solver. *) + (* - iPureIntro. rewrite HMρ -HMW. *) + (* set_solver. *) + (* - repeat rewrite insert_delete_insert. rewrite delete_list_insert; auto. *) + (* rewrite insert_insert. rewrite delete_list_insert; auto. } *) + (* iFrame. *) + (* Qed. *) + + Lemma region_close_next_perm W φ ls l v `{forall Wv, Persistent (φ Wv)} : + l ∉ ls -> + ⊢ sts_state_std l Permanent ∗ + open_region_many (l::ls) W ∗ l ↦ₐ v ∗ future_priv_mono φ v ∗ ▷ φ (W,v) ∗ rel l φ + -∗ open_region_many ls W. + Proof. + rewrite open_region_many_eq /open_region_many_def. + iIntros (Hnin) "(Hstate & Hreg_open & Hl & #Hmono & Hφ & #Hrel)". + rewrite rel_eq /rel_def REL_eq RELS_eq /rel /region /RELS /REL. + iDestruct "Hrel" as (γpred) "#[Hγpred Hφ_saved]". + iDestruct "Hreg_open" as (M Mρ) "(HM & % & Hdomρ & Hpreds)". iDestruct "Hdomρ" as %Hdomρ. + iDestruct (region_map_insert_nonmonostatic Permanent with "Hpreds") as "Hpreds". congruence. + iDestruct (big_sepM_insert _ (delete l (delete_list ls M)) l with "[-HM]") as "test"; + first by rewrite lookup_delete. + { iFrame. iSplitR; [by simplify_map_eq|]. + iFrame "∗ #". repeat (iSplitR;[eauto|]). iFrame. auto. } + rewrite -(delete_list_delete _ M) // -(delete_list_insert _ (delete _ M)) //. + rewrite -(delete_list_insert _ Mρ) //. + iExists _, _. iFrame. + iDestruct (reg_in γrel M with "[$HM $Hγpred]") as %HMeq. + rewrite -HMeq. iFrame. iSplitR; auto. iPureIntro. + rewrite HMeq !insert_delete_insert !dom_insert_L Hdomρ. set_solver. + Qed. + + Definition monotonicity_guarantees_region ρ l w φ := + (match ρ with + | Monotemporary => future_pub_a_mono l + | Permanent => future_priv_mono + | Revoked | Monostatic _ => λ (_ : WORLD * Word → iProp Σ) (_ : Word), True + end φ w)%I. + + Definition monotonicity_guarantees_decide ρ l w φ:= + (if decide (ρ = Monotemporary) + then future_pub_a_mono l φ w + else future_priv_mono φ w)%I. + + Lemma region_open_next + (W : WORLD) + (φ : WORLD * Word → iProp Σ) + (ls : list Addr) (l : Addr) (ρ : region_type) + (Hρnotrevoked : ρ <> Revoked) + (Hρnotmonostatic : ¬ exists g, ρ = Monostatic g): + l ∉ ls → + std W !! l = Some ρ → + ⊢ open_region_many ls W ∗ rel l φ ∗ sts_full_world W + -∗ ∃ v : Word, + sts_full_world W + ∗ sts_state_std l ρ + ∗ open_region_many (l :: ls) W + ∗ l ↦ₐ v ∗ ▷ monotonicity_guarantees_region ρ l v φ ∗ + ▷ φ (W, v). + Proof. + unfold monotonicity_guarantees_region. + intros. iIntros "H". + destruct ρ; try congruence. + - iDestruct (region_open_next_monotemp with "H") as (v) "[A [B [C [D [E F]]]]]"; eauto. + iExists v. iFrame. + - iApply (region_open_next_perm with "H"); eauto. + - exfalso. apply Hρnotmonostatic. eauto. + Qed. + + Lemma region_close_next + (W : WORLD) + (φ : WORLD * Word → iProp Σ) + `{forall Wv, Persistent (φ Wv)} + (ls : list Addr) (l : Addr) (v : Word) (ρ : region_type) + (Hρnotrevoked : ρ <> Revoked) + (Hρnotmonostatic : ¬ exists g, ρ = Monostatic g): + l ∉ ls + → sts_state_std l ρ + ∗ open_region_many (l :: ls) W + ∗ l ↦ₐ v ∗ monotonicity_guarantees_region ρ l v φ ∗ ▷ φ (W, v) ∗ rel l φ -∗ + open_region_many ls W. + Proof. + unfold monotonicity_guarantees_region. + intros. iIntros "[A [B [C [D [E F]]]]]". + destruct ρ; try congruence. + - iApply (region_close_next_monotemp with "[A B C D E F]"); eauto; iFrame. + - iApply (region_close_next_perm with "[A B C D E F]"); eauto; iFrame. + - exfalso. apply Hρnotmonostatic. eauto. + Qed. + +End heap. + +Notation " W" := (std_update W a ρ) (at level 10, format " W"). +Notation " W" := (loc_update W a ρ r.1 r.2.1 r.2.2) (at level 10, format " W"). diff --git a/theories/region_invariants_transitions.v b/theories/region_invariants_transitions.v new file mode 100644 index 00000000..adce46c6 --- /dev/null +++ b/theories/region_invariants_transitions.v @@ -0,0 +1,238 @@ +From iris.proofmode Require Import proofmode. +From iris.program_logic Require Export weakestpre. +From cap_machine Require Export region_invariants. +From iris.base_logic Require Export invariants na_invariants saved_prop. +Import uPred. + + +Section transitions. + Context {Σ:gFunctors} + {ceriseg:ceriseG Σ} + {stsg : STSG Addr region_type Σ} {heapg : heapGS Σ} + `{MP: MachineParameters}. + + Implicit Types fsd gsd hsd : STS_std_states Addr region_type. + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states Addr region_type)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + (* --------------------------------------------------------------------------------- *) + (* ------------------------- LEMMAS ABOUT STD TRANSITIONS -------------------------- *) + + Lemma std_rel_pub_Permanent x : + std_rel_pub Permanent x → x = Permanent. + Proof. + intros Hrel. + inversion Hrel. + Qed. + + Lemma std_rel_pub_rtc_Permanent x y : + x = Permanent → + rtc std_rel_pub x y → y = Permanent. + Proof. + intros Hx Hrtc. + induction Hrtc;auto. + subst. apply IHHrtc. apply std_rel_pub_Permanent; auto. + Qed. + + Lemma std_rel_pub_plus_Permanent x : + std_rel_pub_plus Permanent x → x = Permanent. + Proof. + intros Hrel. + inversion Hrel. + Qed. + + Lemma std_rel_pub_plus_rtc_Permanent x y : + x = Permanent → + rtc (λ x y : region_type, std_rel_pub x y ∨ std_rel_pub_plus x y) x y → + y = Permanent. + Proof. + intros Hx Hrtc. + induction Hrtc as [|x y z Hrel];auto. + subst. destruct Hrel as [Hpub | Hpubp]. + - apply std_rel_pub_Permanent in Hpub. auto. + - apply std_rel_pub_plus_Permanent in Hpubp. auto. + Qed. + + Lemma std_rel_priv_Permanent x : + std_rel_priv Permanent x → x = Permanent. + Proof. + intros Hrel. + inversion Hrel; done. + Qed. + + Lemma std_rel_priv_rtc_Permanent x y : + x = Permanent → + rtc std_rel_priv x y → y = Permanent. + Proof. + intros Hx Hrtc. + induction Hrtc;auto. + subst. apply IHHrtc. apply std_rel_priv_Permanent; auto. + Qed. + + Lemma std_rel_priv_Revoked x : + std_rel_priv Revoked x → x = Revoked. + Proof. + intros Hrel. + inversion Hrel; done. + Qed. + + Lemma std_rel_priv_rtc_Revoked x y : + x = Revoked → + rtc std_rel_priv x y → y = Revoked. + Proof. + intros Hx Hrtc. + induction Hrtc;auto. + subst. apply IHHrtc. apply std_rel_priv_Revoked; auto. + Qed. + + Lemma std_rel_priv_Monostatic x g : + std_rel_priv (Monostatic g) x → x = Monostatic g. + Proof. + intros Hrel. + inversion Hrel; done. + Qed. + + Lemma std_rel_priv_rtc_Monostatic x y g : + x = Monostatic g → + rtc std_rel_priv x y → y = Monostatic g. + Proof. + intros Hx Hrtc. + induction Hrtc;auto. + subst. apply IHHrtc. apply std_rel_priv_Monostatic; auto. + Qed. + + Lemma std_rel_rtc_Permanent x y : + x = Permanent → + rtc (λ x0 y0 : region_type, std_rel_pub x0 y0 ∨ std_rel_pub_plus x0 y0 ∨ std_rel_priv x0 y0) x y → + y = Permanent. + Proof. + intros Hx Hrtc. + induction Hrtc as [|x y z Hrel];auto. + subst. destruct Hrel as [Hrel | [Hrel | Hrel] ]. + - apply std_rel_pub_Permanent in Hrel. auto. + - apply std_rel_pub_plus_Permanent in Hrel. auto. + - apply std_rel_priv_Permanent in Hrel. auto. + Qed. + + Lemma std_rel_pub_Monotemporary x : + std_rel_pub Monotemporary x → x = Monotemporary. + Proof. + intros Hrel. + inversion Hrel. + Qed. + + Lemma std_rel_pub_rtc_Monotemporary x y : + x = Monotemporary → + rtc std_rel_pub x y → y = Monotemporary. + Proof. + intros Hx Hrtc. + induction Hrtc ;auto. + subst. apply IHHrtc. apply std_rel_pub_Monotemporary; auto. + Qed. + + Lemma std_rel_pub_Revoked x : + std_rel_pub Revoked x → x = Permanent ∨ x = Monotemporary. + Proof. + intros Hrel. + inversion Hrel; auto. + Qed. + + Lemma std_rel_pub_rtc_Revoked x y : + x = Revoked → + rtc std_rel_pub x y → y = Permanent ∨ y = Monotemporary ∨ y = Revoked. + Proof. + intros Hx Hrtc. + inversion Hrtc; subst; auto. + apply std_rel_pub_Revoked in H as [-> | ->];auto. + - left. eapply std_rel_pub_rtc_Permanent;eauto. + - right. left. eapply std_rel_pub_rtc_Monotemporary;eauto. + Qed. + + Lemma std_rel_pub_Monostatic x g : + std_rel_pub (Monostatic g) x → x = Monostatic g. + Proof. + intros Hrel. + inversion Hrel. + Qed. + + (* Lemma std_rel_pub_Uninitialized x w : *) + (* std_rel_pub (Uninitialized w) x → x = Monotemporary. *) + (* Proof. *) + (* intros Hrel. *) + (* inversion Hrel. auto. *) + (* Qed. *) + + (* Lemma std_rel_pub_rtc_Uninitialized x y w : *) + (* x = (Uninitialized w) → *) + (* rtc std_rel_pub x y → y = Monotemporary ∨ y = (Uninitialized w). *) + (* Proof. *) + (* intros Hx Hrtc. *) + (* inversion Hrtc; subst; auto. left. *) + (* apply std_rel_pub_Uninitialized in H0. *) + (* eapply std_rel_pub_rtc_Monotemporary;eauto. *) + (* Qed. *) + + Lemma std_rel_pub_rtc_Monostatic x y g : + x = (Monostatic g) → + rtc std_rel_pub x y → y = (Monostatic g). + Proof. + intros Hx Hrtc. + induction Hrtc; subst; auto. + apply std_rel_pub_Monostatic in H as ->. + auto. + Qed. + + Lemma std_rel_pub_plus_Monostatic x g : + std_rel_pub_plus (Monostatic g) x → x = Monotemporary. + Proof. + intros Hrel; inversion Hrel. auto. Qed. + + (* Lemma std_rel_pub_plus_Uninitialized x w : *) + (* std_rel_pub_plus (Uninitialized w) x → x = (Uninitialized w). *) + (* Proof. *) + (* intros Hrel; inversion Hrel. Qed. *) + + (* Lemma std_rel_pub_plus_Monotemporary x : *) + (* std_rel_pub_plus Monotemporary x → ∃ w, x = Uninitialized w. *) + (* Proof. *) + (* intros Hrel. inversion Hrel. eauto. Qed. *) + + (* Lemma std_rel_pub_plus_rtc_Monotemporary_or_Uninitialized x y : *) + (* x = Monotemporary ∨ (∃ w, x = Uninitialized w) → *) + (* rtc (λ x0 y0, std_rel_pub x0 y0 ∨ std_rel_pub_plus x0 y0) x y → *) + (* y = Monotemporary ∨ ∃ w, y = Uninitialized w. *) + (* Proof. *) + (* intros Hx Hrtc. *) + (* induction Hrtc ;[destruct Hx;eauto|]. *) + (* destruct Hx as [-> | [g ->] ]. *) + (* - destruct H0 as [Hpub | Hpubp]. *) + (* + apply std_rel_pub_Monotemporary in Hpub. auto. *) + (* + apply std_rel_pub_plus_Monotemporary in Hpubp as [g' ->]. *) + (* apply IHHrtc. eauto. *) + (* - destruct H0 as [Hpub | Hpubp]. *) + (* + apply std_rel_pub_Uninitialized in Hpub. auto. *) + (* + apply std_rel_pub_plus_Uninitialized in Hpubp as ->. *) + (* apply IHHrtc. eauto. *) + (* Qed. *) + + (* Lemma std_rel_pub_plus_rtc_Uninitialized x y w : *) + (* x = Uninitialized w → *) + (* rtc (λ x0 y0, std_rel_pub x0 y0 ∨ std_rel_pub_plus x0 y0) x y → *) + (* y = Monotemporary ∨ (∃ w', y = Uninitialized w'). *) + (* Proof. *) + (* intros Hx Hrtc. *) + (* eapply std_rel_pub_plus_rtc_Monotemporary_or_Uninitialized;eauto. *) + (* Qed. *) + + (* Lemma std_rel_pub_plus_rtc_Monotemporary x y : *) + (* x = Monotemporary → *) + (* rtc (λ x0 y0, std_rel_pub x0 y0 ∨ std_rel_pub_plus x0 y0) x y → *) + (* y = Monotemporary ∨ ∃ w, y = Uninitialized w. *) + (* Proof. *) + (* intros Hx Hrtc. subst. *) + (* apply (std_rel_pub_plus_rtc_Monotemporary_or_Uninitialized Monotemporary);eauto. *) + (* Qed. *) + +End transitions. diff --git a/theories/rules_binary.v b/theories/rules_binary.v deleted file mode 100644 index 83721708..00000000 --- a/theories/rules_binary.v +++ /dev/null @@ -1,9 +0,0 @@ -From cap_machine.rules_binary Require Export - rules_binary_base rules_binary_Restrict - rules_binary_Get rules_binary_Load - rules_binary_Store rules_binary_AddSubLt - rules_binary_Lea rules_binary_Mov - rules_binary_Jmp rules_binary_Jnz - rules_binary_Subseg. -From iris.base_logic Require Export invariants gen_heap. -From iris.program_logic Require Export weakestpre ectx_lifting. diff --git a/theories/sts.v b/theories/sts.v new file mode 100644 index 00000000..58b94111 --- /dev/null +++ b/theories/sts.v @@ -0,0 +1,1107 @@ +From iris.algebra Require Import auth agree gmap excl. +From iris.base_logic Require Export invariants. +From iris.proofmode Require Import proofmode. +From cap_machine Require Import stdpp_extra. +Import uPred. + +(** The CMRA for the heap of STS. + We distinguish between the standard and owned sts. *) + +(** For shared resources, we register the state. *) + +Definition sts_std_stateUR (A B : Type) {eqD: EqDecision A} {count: Countable A} := authUR (gmapUR A (exclR (leibnizO B))). +Definition STS_std_states (A B : Type) {eqD: EqDecision A} {count: Countable A} : Type := gmap A B. + + +(** For owned resources, we register the state and the transition relation. *) + +Definition sts_stateUR := authUR (gmapUR positive (exclR (leibnizO positive))). +Definition sts_relUR := + authUR (gmapUR positive (agreeR (leibnizO ((positive → positive → Prop) * (positive → positive → Prop) * (positive → positive → Prop))))). + +Notation STS_states := (gmap positive positive). +Notation STS_rels := (gmap positive ((positive → positive → Prop) * (positive → positive → Prop) * (positive → positive → Prop ))). + +(** A typeclass for comparable *) +Class Ord A `{EqDecision A} : Type := + { le_a : relation A; + le_a_decision : ∀ a1 a2, Decision (le_a a1 a2); + le_a_preorder : PreOrder le_a }. + +(** Standard STS. *) +(** The Standard STS is made up of three relations *) +Class STS_STD (B : Type) := + { Rpub : relation B; + Rpriv : relation B; + Rpubp : relation B; }. + +(** The CMRA for the sts collection. *) +Class STS_preG A B Σ `{EqDecision A, Countable A} := + { sts_pre_state_inG :: inG Σ sts_stateUR; + sts_pre_std_state_inG :: inG Σ (sts_std_stateUR A B); + sts_pre_rel_inG :: inG Σ sts_relUR; }. + +Class STSG A B Σ `{EqDecision A, Countable A} := + { sts_state_inG :: inG Σ sts_stateUR; + sts_std_state_inG :: inG Σ (sts_std_stateUR A B); + sts_rel_inG :: inG Σ sts_relUR; + γs_std : gname; + γs_loc : gname; + γr_loc : gname;}. + +Definition STS_preΣ A B `{EqDecision A, Countable A} := + #[ GFunctor sts_stateUR; + GFunctor (sts_std_stateUR A B); + GFunctor sts_relUR ]. + +Instance subG_STS_preΣ A B `{EqDecision A, Countable A} {Σ} : + subG (STS_preΣ A B) Σ → STS_preG A B Σ. +Proof. + (* hack: solve_inG does not currently unfold [subG X _] where X has more than + 4 parameters. We have 5. *) + set f := STS_preΣ A B. unfold STS_preΣ in f. + solve_inG. +Qed. + +Section definitionsS. + + (* A now needs to be comparable, so we can distinquish between higher and lower a's *) + Context {A B C D: Type} {Σ : gFunctors} {eqa: EqDecision A} {a_compare : Ord A} + {count: Countable A} + {sts_std: STS_STD B} {eqc : EqDecision C} {countC: Countable C} + {eqd : EqDecision D} {countD: Countable D} {stsg : STSG A B Σ}. + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states A B)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + Program Definition sts_state_std (i : A) (x : B) : iProp Σ + := own (γs_std (A:=A)) (◯ {[ i := Excl x ]}). + + Definition sts_state_loc (i : positive) (y : D) : iProp Σ + := own (γs_loc (A:=A)) (◯ {[ i := Excl (encode y) ]}). + + Definition convert_rel {D : Type} `{Countable D} (R : D → D → Prop) : positive → positive → Prop := + λ x y, ∃ a b, x = encode a ∧ y = encode b ∧ R a b. + + Definition sts_rel_loc (i : positive) (R : D → D → Prop) (P : D → D → Prop) (Q : D → D → Prop) : iProp Σ := + own (γr_loc (A:=A)) (◯ {[ i := to_agree ((convert_rel R,convert_rel P,convert_rel Q)) ]}). + + Program Definition sts_full γs γr (fs : STS_states) (fr : STS_rels) : iProp Σ + := (own (A := sts_stateUR) γs (● (Excl <$> fs)) + ∗ own (A := sts_relUR) γr (● (to_agree <$> fr)))%I. + Program Definition sts_full_std γs (fs : STS_std_states A B) : iProp Σ + := own (A := sts_std_stateUR A B) γs (● (Excl <$> fs))%I. + Program Definition sts_full_world W : iProp Σ := + ((sts_full_std (γs_std (A:=A)) W.1) ∗ (sts_full (γs_loc (A:=A)) (γr_loc (A:=A)) W.2.1 W.2.2))%I. + + (* We will have three kinds of future world relation (here in subset order) : + - public + - public + + - private + + Additionally, we define a special public future world relation that allows + public + transitions above an address a, but only public transitions below + a + *) + + Definition related_sts_std_pub (fs gs : STS_std_states A B) : Prop := + dom fs ⊆ dom gs ∧ + ∀ i x y, fs !! i = Some x → gs !! i = Some y → rtc (Rpub) x y. + + Definition related_sts_std_pub_plus (fs gs : STS_std_states A B) : Prop := + dom fs ⊆ dom gs ∧ + ∀ i x y, fs !! i = Some x → gs !! i = Some y → rtc (λ x y, (Rpub x y ∨ Rpubp x y)) x y. + + Definition related_sts_std_priv (fs gs : STS_std_states A B) : Prop := + dom fs ⊆ dom gs ∧ + ∀ i x y, fs !! i = Some x → gs !! i = Some y → rtc (λ x y, (Rpub x y ∨ Rpubp x y ∨ Rpriv x y)) x y. + + Program Definition related_sts_a (fs gs : STS_std_states A B) (a : A) : Prop := + dom fs ⊆ dom gs ∧ + ∀ (i : A) (x y : B), fs !! i = Some x → gs !! i = Some y → + rtc (λ x y, if (decide(Decision:=le_a_decision a i) (le_a a i)) + then (Rpub x y ∨ Rpubp x y) + else (Rpub x y)) x y. + + Definition related_sts_pub (fs gs : STS_states) (fr gr : STS_rels) : Prop := + dom fs ⊆ dom gs ∧ + dom fr ⊆ dom gr ∧ + ∀ i (r1 r2 r1' r2' r3 r3' : positive → positive → Prop), fr !! i = Some (r1,r2,r3) → gr !! i = Some (r1',r2',r3') → + r1 = r1' ∧ r2 = r2' ∧ r3 = r3' ∧ + (∀ x y, fs !! i = Some x → gs !! i = Some y → (rtc r1 x y)). + + + Definition related_sts_pub_plus (fs gs : STS_states) (fr gr : STS_rels) : Prop := + dom fs ⊆ dom gs ∧ + dom fr ⊆ dom gr ∧ + ∀ i (r1 r2 r1' r2' r3 r3' : positive → positive → Prop), fr !! i = Some (r1,r2,r3) → gr !! i = Some (r1',r2',r3') → + r1 = r1' ∧ r2 = r2' ∧ r3 = r3' ∧ + (∀ x y, fs !! i = Some x → gs !! i = Some y → (rtc (λ x y, r1 x y ∨ r2 x y) x y)). + + Definition related_sts_priv (fs gs : STS_states) (fr gr : STS_rels) : Prop := + dom fs ⊆ dom gs ∧ + dom fr ⊆ dom gr ∧ + ∀ i (r1 r2 r1' r2' r3 r3' : positive → positive → Prop), fr !! i = Some (r1,r2,r3) → gr !! i = Some (r1',r2',r3') → + r1 = r1' ∧ r2 = r2' ∧ r3 = r3' ∧ + (∀ x y, fs !! i = Some x → gs !! i = Some y → (rtc (λ x y, (r1 x y ∨ r2 x y ∨ r3 x y)) x y)). + + Definition related_sts_pub_world W W' := + related_sts_std_pub W.1 W'.1 ∧ + related_sts_pub W.2.1 W'.2.1 W.2.2 W'.2.2. + + Definition related_sts_pub_plus_world W W' := + related_sts_std_pub_plus W.1 W'.1 ∧ + related_sts_pub_plus W.2.1 W'.2.1 W.2.2 W'.2.2. + + Definition related_sts_priv_world W W' := + related_sts_std_priv W.1 W'.1 ∧ + related_sts_priv W.2.1 W'.2.1 W.2.2 W'.2.2. + + Definition related_sts_a_world W W' a := + related_sts_a W.1 W'.1 a ∧ + related_sts_pub_plus W.2.1 W'.2.1 W.2.2 W'.2.2. + + Global Instance sts_rel_loc_Persistent i R P Q : Persistent (sts_rel_loc i R P Q). + Proof. apply _. Qed. + + Global Instance sts_rel_loc_Timeless i R P Q : Timeless (sts_rel_loc i R P Q). + Proof. apply _. Qed. + + Global Instance sts_state_std_Timeless i x : Timeless (sts_state_std i x). + Proof. apply _. Qed. + Global Instance sts_state_loc_Timeless i x : Timeless (sts_state_loc i x). + Proof. apply _. Qed. + + Global Instance sts_full_Timeless γs γr fs fr : Timeless (sts_full γs γr fs fr). + Proof. apply _. Qed. + Global Instance sts_full_world_Timeless W : Timeless (sts_full_world W). + Proof. apply _. Qed. + +End definitionsS. + +Typeclasses Opaque sts_state_std sts_state_loc sts_rel_loc sts_full + related_sts_pub related_sts_priv. + +Lemma convert_rel_of_rel {A} `{EqDecision A, Countable A} (R: A -> A -> Prop) x y: + R x y → convert_rel R (encode x) (encode y). +Proof. rewrite /convert_rel. eauto. Qed. + +Lemma rel_of_convert_rel {A} `{EqDecision A, Countable A} (R: A -> A -> Prop) x y: + convert_rel R (encode x) (encode y) → R x y. +Proof. + rewrite /convert_rel. intros (?&?&HH1&HH2&?). + apply encode_inj in HH1. + apply encode_inj in HH2. subst; eauto. +Qed. + +Section pre_STS. + Context {A B C D: Type} {Σ : gFunctors} {eqa: EqDecision A} {compare_a: Ord A} + {count: Countable A} + {sts_std: STS_STD B} {eqc : EqDecision C} {countC: Countable C} + {eqd : EqDecision D} {countD: Countable D} {sts_preg: STS_preG A B Σ}. + + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states A B)). + Notation WORLD := (prodO STS_STD STS). + + Lemma gen_sts_init : + ⊢ |==> ∃ (stsg : STSG A B Σ), sts_full_world ((∅, (∅, ∅)) : WORLD). + Proof. + iMod (own_alloc (A:=sts_std_stateUR A B) (● ∅)) as (γsstd) "Hstd". by apply auth_auth_valid. + iMod (own_alloc (A:=sts_stateUR) (● ∅)) as (γs) "Hs". by apply auth_auth_valid. + iMod (own_alloc (A:=sts_relUR) (● ∅)) as (γr) "Hr". by apply auth_auth_valid. + iModIntro. iExists (Build_STSG _ _ _ _ _ _ _ _ _ γsstd γs γr). + rewrite /sts_full_world /sts_full_std /sts_full /=. + rewrite !fmap_empty. iFrame. + Qed. + +End pre_STS. + +Section STS. + Context {A B C D: Type} {Σ : gFunctors} {eqa: EqDecision A} {compare_a: Ord A} + {count: Countable A} + {sts_std: STS_STD B} {eqc : EqDecision C} {countC: Countable C} + {eqd : EqDecision D} {countD: Countable D} {stsg : STSG A B Σ}. + Implicit Types x y : positive. + Implicit Types a : A. + Implicit Types b : B. + Implicit Types c : C. + Implicit Types d : D. + Implicit Types fs gs : STS_states. + Implicit Types fsd gsd : STS_std_states A B. + Implicit Types fr_pub fr_priv gr_pub gr_priv : STS_rels. + Implicit Types R : C → C → Prop. + Implicit Types Q : D → D → Prop. + Implicit Types Rp : positive → positive → Prop. + + Notation STS := (leibnizO (STS_states * STS_rels)). + Notation STS_STD := (leibnizO (STS_std_states A B)). + Notation WORLD := (prodO STS_STD STS). + Implicit Types W : WORLD. + + (* --------------------- REFLEXIVITY --------------------- *) + + Lemma related_sts_pub_refl fs fr : related_sts_pub fs fs fr fr. + Proof. + split; [|split]; trivial. + intros; simplify_eq. + split; [|split]; [..|split]; trivial. + intros; simplify_eq; eauto using rtc_refl. + Qed. + + Lemma related_sts_pub_plus_refl fs fr : related_sts_pub_plus fs fs fr fr. + Proof. + split; [|split]; trivial. + intros; simplify_eq. + split; [|split]; [..|split]; trivial. + intros; simplify_eq; eauto using rtc_refl. + Qed. + + Lemma related_sts_priv_refl fs fr : related_sts_priv fs fs fr fr. + Proof. + split; [|split]; trivial. + intros; simplify_eq. + split; [|split]; [..|split]; trivial. + intros; simplify_eq; + eauto using rtc_refl. + Qed. + + Lemma related_sts_std_pub_refl fsd : related_sts_std_pub fsd fsd. + Proof. + split; trivial. + intros; simplify_eq. + eauto using rtc_refl. + Qed. + + Lemma related_sts_std_pub_plus_refl fsd : related_sts_std_pub_plus fsd fsd. + Proof. + split; trivial. + intros; simplify_eq. + eauto using rtc_refl. + Qed. + + Lemma related_sts_std_priv_refl fsd : related_sts_std_priv fsd fsd. + Proof. + split; trivial. + intros; simplify_eq. + eauto using rtc_refl. + Qed. + + Lemma related_sts_pub_refl_world W : related_sts_pub_world W W. + Proof. split;[apply related_sts_std_pub_refl|apply related_sts_pub_refl]. Qed. + Lemma related_sts_pub_plus_refl_world W : related_sts_pub_plus_world W W. + Proof. split;[apply related_sts_std_pub_plus_refl|apply related_sts_pub_plus_refl]. Qed. + Lemma related_sts_priv_refl_world W : related_sts_priv_world W W. + Proof. split;[apply related_sts_std_priv_refl|apply related_sts_priv_refl]. Qed. + + + (* --------------------- pub ⊆ pub+ ⊆ priv --------------------- *) + + Lemma related_sts_pub_pub_plus fs fr gs gr : + related_sts_pub fs gs fr gr → related_sts_pub_plus fs gs fr gr. + Proof. + rewrite /related_sts_pub /related_sts_priv. + intros [Hf1 [Hf2 Hf3]]. + do 2 (split; auto). intros. + specialize (Hf3 i r1 r2 r1' r2' r3 r3' H H0) as (Hr1 & Hr2 & Hr3 & Hrtc); auto. + subst. repeat (split;auto). intros. + specialize (Hrtc x y H1 H2). + inversion Hrtc. + - left. + - right with y0; auto. + apply rtc_or_intro. apply H4. + Qed. + + Lemma related_sts_pub_plus_priv fs fr gs gr : + related_sts_pub_plus fs gs fr gr → related_sts_priv fs gs fr gr. + Proof. + intros [Hf1 [Hf2 Hf3]]. + do 2 (split; auto). intros. + specialize (Hf3 i r1 r2 r1' r2' r3 r3' H H0) as (Hr1 & Hr2 & Hr3 & Hrtc); auto. + subst. repeat (split;auto). intros. + specialize (Hrtc x y H1 H2). + inversion Hrtc. + - left. + - inversion H3. + + right with y0; auto. + apply rtc_implies with (R:=(λ x1 y1, (r1' x1 y1 ∨ r2' x1 y1) ∨ r3' x1 y1)); + [intros ? ? [[?|?]|?];auto|]. + apply rtc_or_intro;auto. + + right with y0; auto. + apply rtc_implies with (R:=(λ x1 y1, (r1' x1 y1 ∨ r2' x1 y1) ∨ r3' x1 y1)); + [intros ? ? [[?|?]|?];auto|]. + apply rtc_or_intro;auto. + Qed. + + Lemma related_sts_pub_priv fs fr gs gr : + related_sts_pub fs gs fr gr → related_sts_priv fs gs fr gr. + Proof. + intros Hpub. + by apply related_sts_pub_plus_priv, related_sts_pub_pub_plus. + Qed. + + Lemma related_sts_std_pub_pub_plus fsd gsd : + related_sts_std_pub fsd gsd → related_sts_std_pub_plus fsd gsd. + Proof. + intros [Hf1 Hf2]. + split;auto. intros i x y Hx Hy. + specialize (Hf2 i x y Hx Hy). + apply rtc_or_intro. auto. + Qed. + + Lemma related_sts_std_pub_plus_priv fsd gsd : + related_sts_std_pub_plus fsd gsd → related_sts_std_priv fsd gsd. + Proof. + intros [Hf1 Hf2]. + split;auto. intros i x y Hx Hy. + specialize (Hf2 i x y Hx Hy). + eapply rtc_implies;[|eauto]. + intros r q [Hr | Hq];auto. + Qed. + + Lemma related_sts_std_pub_priv fsd gsd : + related_sts_std_pub fsd gsd → related_sts_std_priv fsd gsd. + Proof. + intros Hpub. by apply related_sts_std_pub_plus_priv, related_sts_std_pub_pub_plus. + Qed. + + Lemma related_sts_pub_pub_plus_world W W' : + related_sts_pub_world W W' → related_sts_pub_plus_world W W'. + Proof. + intros [Hrel Hrel']. + split;[apply related_sts_std_pub_pub_plus|apply related_sts_pub_pub_plus];auto. + Qed. + Lemma related_sts_pub_plus_priv_world W W' : + related_sts_pub_plus_world W W' → related_sts_priv_world W W'. + Proof. + intros [Hrel Hrel']. + split;[apply related_sts_std_pub_plus_priv|apply related_sts_pub_plus_priv];auto. + Qed. + Lemma related_sts_pub_priv_world W W' : + related_sts_pub_world W W' → related_sts_priv_world W W'. + Proof. + intros [Hrel Hrel']. + split;[apply related_sts_std_pub_priv|apply related_sts_pub_priv];auto. + Qed. + + (* --------------------- pub a lemmas --------------------- *) + + Lemma related_sts_a_weak fsd gsd a a' : + le_a a' a → + related_sts_a fsd gsd a → related_sts_a fsd gsd a'. + Proof. + intros Hleb [Hdom Ha]. + split;auto. intros i x y Hx Hy. + specialize (Ha i x y Hx Hy). + eapply rtc_implies;[|eauto]. + intros r q Hr. + destruct (decide (le_a a' i)). + - destruct (decide (le_a a i));auto. + - destruct (decide (le_a a i));auto. + exfalso. apply n. + assert (Transitive le_a) as Htrans;[eapply PreOrder_Transitive|trans a;auto]. + Unshelve. apply compare_a. + Qed. + + Lemma related_sts_a_weak_world W W' a a' : + le_a a' a → + related_sts_a_world W W' a → related_sts_a_world W W' a'. + Proof. + destruct W,W'. + intros Hle [Hrel Hrel']. split; simpl in *. + - by pose proof (related_sts_a_weak _ _ _ _ Hle Hrel). + - auto. + Qed. + + Lemma related_sts_a_pub_plus fsd gsd a : + related_sts_a fsd gsd a → related_sts_std_pub_plus fsd gsd. + Proof. + intros [Hdom Hrel]. split;auto. + intros i x y Hx Hy. + specialize (Hrel i x y Hx Hy). + destruct (decide (le_a a i)). + - auto. + - apply rtc_or_intro. auto. + Qed. + + Lemma related_sts_pub_a fsd gsd a : + related_sts_std_pub fsd gsd → related_sts_a fsd gsd a. + Proof. + intros [Hdom Hrel]. + split;auto. intros i x y Hx Hy. + specialize (Hrel i x y Hx Hy). + destruct (decide (le_a a i)). + - apply rtc_or_intro. auto. + - auto. + Qed. + + Lemma related_sts_a_pub_plus_world W W' a : + related_sts_a_world W W' a → related_sts_pub_plus_world W W'. + Proof. + intros [Hrel Hrel']. + apply related_sts_a_pub_plus in Hrel. + split;auto. + Qed. + + Lemma related_sts_pub_a_world W W' a : + related_sts_pub_world W W' → related_sts_a_world W W' a. + Proof. + intros [Hrel Hrel']. split. + - apply related_sts_pub_a. auto. + - apply related_sts_pub_pub_plus. auto. + Qed. + + (* --------------------- TRANSITIVITY --------------------- *) + + Lemma related_sts_pub_trans fs fr gs gr hs hr : + related_sts_pub fs gs fr gr → related_sts_pub gs hs gr hr → + related_sts_pub fs hs fr hr. + Proof. + intros [Hf1 [Hf2 Hf3]] [Hg1 [Hg2 Hg3]]; split; [|split]; try by etrans. + intros i r1 r2 r1' r2' r3 r3' Hfr Hhr. + specialize (Hf1 i); specialize (Hf2 i); + revert Hf1 Hf2; rewrite !elem_of_dom; intros Hf1 Hf2. + destruct Hf2; eauto. destruct x as [[x1 x2] x3]. + edestruct Hf3 as [Heq1 [Heq2 [Heq3 Hrtc]] ] ; eauto; simplify_eq. + edestruct Hg3 as [Heq1 [Heq2 [Heq3 Hrtc']] ] ; eauto; simplify_eq. + repeat (split;auto). + intros x y Hx Hy. + destruct Hf1;eauto. + etrans;eauto. + Qed. + + Lemma related_sts_std_pub_trans fsd gsd hsd : + related_sts_std_pub fsd gsd → related_sts_std_pub gsd hsd → + related_sts_std_pub fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. + Qed. + + Lemma related_sts_priv_pub_trans fs fr gs gr hs hr : + related_sts_priv fs gs fr gr → related_sts_pub gs hs gr hr → + related_sts_priv fs hs fr hr. + Proof. + intros [Hf1 [Hf2 Hf3]] [Hg1 [Hg2 Hg3]]; split; [|split]; try by etrans. + intros i r1 r2 r1' r2' r3 r3' Hfr Hhr. + specialize (Hf1 i); specialize (Hf2 i); + revert Hf1 Hf2; rewrite !elem_of_dom; intros Hf1 Hf2. + destruct Hf2; eauto. destruct x as [[x1 x2] x3]. + edestruct Hf3 as [Heq1 [Heq2 [Heq3 Hrtc]] ] ; eauto; simplify_eq. + edestruct Hg3 as [Heq1 [Heq2 [Heq3 Hrtc']] ] ; eauto; simplify_eq. + repeat (split;auto). + intros x y Hx Hy. + destruct Hf1;eauto. + etrans;eauto. + apply rtc_or_intro; auto. + Qed. + + Lemma related_sts_std_priv_pub_trans fsd gsd hsd : + related_sts_std_priv fsd gsd → related_sts_std_pub gsd hsd → + related_sts_std_priv fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. + apply rtc_or_intro; auto. + Qed. + + Lemma related_sts_pub_priv_trans fs fr gs gr hs hr : + related_sts_pub fs gs fr gr → related_sts_priv gs hs gr hr → + related_sts_priv fs hs fr hr. + Proof. + intros [Hf1 [Hf2 Hf3]] [Hg1 [Hg2 Hg3]]; split; [|split]; try by etrans. + intros i r1 r2 r1' r2' r3 r3' Hfr Hhr. + specialize (Hf1 i); specialize (Hf2 i); + revert Hf1 Hf2; rewrite !elem_of_dom; intros Hf1 Hf2. + destruct Hf2; eauto. destruct x as [[x1 x2] x3]. + edestruct Hf3 as [Heq1 [Heq2 [Heq3 Hrtc]] ] ; eauto; simplify_eq. + edestruct Hg3 as [Heq1 [Heq2 [Heq3 Hrtc']] ] ; eauto; simplify_eq. + repeat (split;auto). + intros x y Hx Hy. + destruct Hf1;eauto. + etrans;eauto. + apply rtc_or_intro; auto. + Qed. + + Lemma related_sts_std_pub_priv_trans fsd gsd hsd : + related_sts_std_pub fsd gsd → related_sts_std_priv gsd hsd → + related_sts_std_priv fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. + apply rtc_or_intro; auto. + Qed. + + Lemma related_sts_priv_trans fs fr gs gr hs hr : + related_sts_priv fs gs fr gr → related_sts_priv gs hs gr hr → + related_sts_priv fs hs fr hr. + Proof. + intros [Hf1 [Hf2 Hf3]] [Hg1 [Hg2 Hg3]]; split; [|split]; try by etrans. + intros i r1 r2 r1' r2' r3 r3' Hfr Hhr. + specialize (Hf1 i); specialize (Hf2 i); + revert Hf1 Hf2; rewrite !elem_of_dom; intros Hf1 Hf2. + destruct Hf2; eauto. destruct x as [[x1 x2] x3]. + edestruct Hf3 as [Heq1 [Heq2 [Heq3 Hrtc]] ] ; eauto; simplify_eq. + edestruct Hg3 as [Heq1 [Heq2 [Heq3 Hrtc']] ] ; eauto; simplify_eq. + repeat (split;auto). + intros x y Hx Hy. + destruct Hf1;eauto. + etrans;eauto. + Qed. + + Lemma related_sts_std_priv_trans fsd gsd hsd : + related_sts_std_priv fsd gsd → related_sts_std_priv gsd hsd → + related_sts_std_priv fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. + Qed. + + Lemma related_sts_a_trans_left fsd gsd hsd a a' : + le_a a a' → + related_sts_a fsd gsd a → related_sts_a gsd hsd a' → + related_sts_a fsd hsd a. + Proof. + intros Hle Hrel1 Hrel2. + apply related_sts_a_weak with (a':=a) in Hrel2;[|auto]. + destruct Hrel1 as [Hf1 Hf2]; destruct Hrel2 as [Hg1 Hg2]. + split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. + Qed. + + Lemma related_sts_a_trans_right fsd gsd hsd a a' : + le_a a a' → + related_sts_a fsd gsd a' → related_sts_a gsd hsd a → + related_sts_a fsd hsd a. + Proof. + intros Hle Hrel1 Hrel2. + apply related_sts_a_weak with (a':=a) in Hrel1;[|auto]. + destruct Hrel1 as [Hf1 Hf2]; destruct Hrel2 as [Hg1 Hg2]. + split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. + Qed. + + (* Helper functions for transitivity of sts pairs *) + Lemma related_sts_pub_priv_trans_world W W' W'' : + related_sts_pub_world W W' -> related_sts_priv_world W' W'' -> + related_sts_priv_world W W''. + Proof. + intros [Hpub_std Hpub_loc] [Hpriv_std Hpriv_loc]. + split. + - apply related_sts_std_pub_priv_trans with W'.1; auto. + - apply related_sts_pub_priv_trans with W'.2.1 W'.2.2; auto. + Qed. + + Lemma related_sts_priv_pub_trans_world W W' W'' : + related_sts_priv_world W W' -> related_sts_pub_world W' W'' -> + related_sts_priv_world W W''. + Proof. + intros [Hpub_std Hpub_loc] [Hpriv_std Hpriv_loc]. + split. + - apply related_sts_std_priv_pub_trans with W'.1; auto. + - apply related_sts_priv_pub_trans with W'.2.1 W'.2.2; auto. + Qed. + + Lemma related_sts_priv_trans_world W W' W'' : + related_sts_priv_world W W' -> related_sts_priv_world W' W'' -> + related_sts_priv_world W W''. + Proof. + intros [Hpub_std Hpub_loc] [Hpriv_std Hpriv_loc]. + split. + - apply related_sts_std_priv_trans with W'.1; auto. + - apply related_sts_priv_trans with W'.2.1 W'.2.2; auto. + Qed. + + Lemma related_sts_pub_trans_world W W' W'' : + related_sts_pub_world W W' -> related_sts_pub_world W' W'' -> + related_sts_pub_world W W''. + Proof. + intros [Hpub_std Hpub_loc] [Hpriv_std Hpriv_loc]. + split. + - apply related_sts_std_pub_trans with W'.1; auto. + - apply related_sts_pub_trans with W'.2.1 W'.2.2; auto. + Qed. + + + Lemma related_sts_priv_world_std_sta_is_Some W W' i : + related_sts_priv_world W W' -> is_Some ((W.1) !! i) -> is_Some ((W'.1) !! i). + Proof. + intros [ [Hdom1 _ ] _] Hsome. + rewrite -elem_of_dom. + rewrite -elem_of_dom in Hsome. + apply elem_of_subseteq in Hdom1. auto. + Qed. + + Lemma related_sts_priv_world_std_sta_region_type W W' i ρ : + related_sts_priv_world W W' -> + (W.1) !! i = Some ρ -> + ∃ ρ', (W'.1) !! i = Some ρ'. + Proof. + intros Hrelated Hρ. + assert (is_Some ((W'.1) !! i)) as [x Hx]. + { apply related_sts_priv_world_std_sta_is_Some with W; eauto. } + destruct Hrelated as [ [Hdom1 Hrevoked ] _]. + specialize (Hrevoked _ _ _ Hρ Hx). simplify_eq. + eauto. + Qed. + + Lemma sts_full_rel_loc W i Q Q' P : + sts_full_world W -∗ sts_rel_loc (A:=A) i Q Q' P -∗ + ⌜W.2.2 !! i = Some (convert_rel Q,convert_rel Q',convert_rel P)⌝. + Proof. + rewrite /sts_rel_loc /sts_full_world /sts_full. + destruct W as [Wstd [fs fr]]. + iIntros "[_ [_ H1]] H2 /=". + iDestruct (own_valid_2 with "H1 H2") as %[HR Hv]%auth_both_valid_discrete; + iPureIntro. + specialize (Hv i). + revert HR. rewrite /= singleton_included_l; + intros [z [Hz HR]]; revert HR; rewrite Some_included_total; intros HR. + rewrite lookup_fmap in Hz, Hv. + destruct (fr !! i) eqn:Heq; last by inversion Hz. + revert Hv; rewrite Hz; intros [u Hu]%to_agree_uninj. + revert HR; rewrite -Hu; intros HR%to_agree_included%leibniz_equiv; + simplify_eq. + inversion Hz as [? ? Hz'|]; simplify_eq. + revert Hz'; rewrite -Hu. intros Hz'%(to_agree_inj (A:=leibnizO _) p _)%leibniz_equiv. + by rewrite Hz'. + Qed. + + Lemma sts_full_state_std W a b : + sts_full_world W -∗ sts_state_std a b -∗ ⌜W.1 !! a = Some b⌝. + Proof. + rewrite /sts_full_world /sts_full /sts_state_std. + destruct W as [Wsta Wloc]. + iIntros "[H1 _] H2". + iDestruct (own_valid_2 with "H1 H2") as %[HR Hv]%auth_both_valid_discrete; + iPureIntro. + specialize (Hv a). + revert HR; rewrite /= singleton_included_l; + intros [z [Hz HR]]. + rewrite lookup_fmap in Hz Hv. + destruct (Wsta !! a) eqn:Heq; rewrite Heq /= in Hz Hv; last by inversion Hz. + apply leibniz_equiv in Hz; simplify_eq. + apply Some_included_exclusive in HR; auto; last by typeclasses eauto. + apply leibniz_equiv in HR; simplify_eq; eauto. + Qed. + + Lemma sts_full_state_loc W i d : + sts_full_world W -∗ sts_state_loc (A:=A) i d -∗ ⌜W.2.1 !! i = Some (encode d)⌝. + Proof. + rewrite /sts_full_world /sts_full /sts_state_loc. + destruct W as [Wstd [fs fr] ]. + iIntros "[_ [H1 _]] H2". + iDestruct (own_valid_2 with "H1 H2") as %[HR Hv]%auth_both_valid_discrete; + iPureIntro. + specialize (Hv i). + revert HR; rewrite /= singleton_included_l; + intros [z [Hz HR]]. + rewrite lookup_fmap in Hz Hv. + destruct (fs !! i) eqn:Heq; last by inversion Hz. + apply leibniz_equiv in Hz; simplify_eq. rewrite -Hz in HR. + apply Some_included_exclusive in HR; auto; last by typeclasses eauto. + apply leibniz_equiv in HR; simplify_eq; eauto. + Qed. + + Lemma sts_dealloc_std W a b : + sts_full_world W ∗ sts_state_std a b ==∗ sts_full_world (delete a W.1,W.2). + Proof. + rewrite /sts_full_world /sts_full /sts_state_std. + destruct W as [fs Wloc]. + iIntros "[ [Hsta Hloc] Hstate] /=". + iCombine "Hsta" "Hstate" as "H1". + iMod (own_update + (A := sts_std_stateUR A B) + _ _ + (● (Excl <$> (delete a fs))) + with "H1") as "H1". + { apply auth_update_dealloc. + rewrite fmap_delete /=. + apply: delete_singleton_local_update. } + iFrame. iModIntro. done. + Qed. + + Lemma sts_alloc_std_i W a b : + ⌜a ∉ dom W.1⌝ -∗ + sts_full_world W ==∗ + sts_full_world (<[a := b]>W.1,W.2) ∗ sts_state_std a b. + Proof. + rewrite /sts_full_world /sts_full /sts_state_std /=. + destruct W as [fsd Wloc]. rewrite /sts_full_std. + iIntros (Hfresh1) "[H1 Hloc] /=". + iMod (own_update + (A := sts_std_stateUR A B) + _ _ + (● (Excl <$> <[a :=b]> fsd) + ⋅ ◯ {[a := Excl b]}) + with "H1") as "[H1 Hs]". + { apply auth_update_alloc. + rewrite fmap_insert /=. + apply: alloc_singleton_local_update; last done. + apply (not_elem_of_dom (D := gset A)). + rewrite dom_fmap. auto. } + iFrame. done. + Qed. + + Lemma sts_alloc_loc W d Q Q' P: + sts_full_world W ==∗ + ∃ i, sts_full_world (W.1,((<[i := encode d ]>W.2.1),(<[i := (convert_rel Q,convert_rel Q',convert_rel P) ]>W.2.2))) + ∗ ⌜i ∉ dom W.2.1⌝ ∗ ⌜i ∉ dom W.2.2⌝ + ∗ sts_state_loc (A:=A) i d ∗ sts_rel_loc (A:=A) i Q Q' P. + Proof. + rewrite /sts_full_world /sts_full /sts_rel_loc /sts_state_loc. + (* iIntros "[Hd [H1 H2]]". *) + (* iDestruct "Hd" as %Hd. *) + destruct W as [Wstd [fs fr]]. + iIntros "[Hstd [H1 H2]] /=". + assert (fresh (dom fs ∪ dom fr) ∉ + (dom fs ∪ dom fr)) as Hfresh. + { apply is_fresh. } + apply not_elem_of_union in Hfresh as [Hfs Hfr]. + iMod (own_update + (A := sts_stateUR) + _ _ + (● (Excl <$> + <[fresh (dom fs ∪ dom fr) := encode d]> fs) + ⋅ ◯ {[fresh (dom fs ∪ dom fr) := Excl (encode d)]}) + with "H1") as "[H1 Hs]". + { apply auth_update_alloc. + rewrite fmap_insert /=. + apply: alloc_singleton_local_update; last done. + apply (not_elem_of_dom (D := gset positive)). + rewrite dom_fmap. + auto. } + iMod (own_update + (A := sts_relUR) + _ _ + (● (to_agree <$> + <[fresh (dom fs ∪ dom fr) := (convert_rel Q,convert_rel Q',convert_rel P)]> fr) + ⋅ ◯ {[fresh (dom fs ∪ dom fr) := to_agree (convert_rel Q,convert_rel Q',convert_rel P)]}) + with "H2") as "[H2 Hr]". + { apply auth_update_alloc. + rewrite fmap_insert /=. + apply: alloc_singleton_local_update; last done. + apply (not_elem_of_dom (D := gset positive)). + rewrite dom_fmap. + auto. } + iModIntro. + iExists _; iFrame. + repeat iSplit; auto. + Qed. + + Lemma sts_update_std W a b b' : + sts_full_world W -∗ sts_state_std a b ==∗ + sts_full_world (<[a := b' ]>W.1,W.2) ∗ sts_state_std a b'. + Proof. + iIntros "Hsf Hi". + iDestruct (sts_full_state_std with "Hsf Hi") as %Hfs. + rewrite /sts_full_world /sts_full /sts_state_std. + destruct W as [fsd Wloc]. + iDestruct "Hsf" as "[H1 Hloc] /=". + iCombine "H1" "Hi" as "H1". + iMod (own_update (A := sts_std_stateUR A B) + _ _ + (● (<[a := Excl b']> (Excl <$> fsd)) + ⋅ ◯ {[a := Excl b']}) + with "H1") as "[H1 Hs]". + { apply auth_update. + apply: singleton_local_update; eauto. + rewrite lookup_fmap Hfs //=. + by apply exclusive_local_update. } + iFrame. rewrite -fmap_insert; + first iModIntro; iFrame. + Qed. + + Lemma sts_update_loc W i d d' : + sts_full_world W -∗ sts_state_loc (A:=A) i d ==∗ + sts_full_world (W.1,((<[i := encode d' ]>W.2.1),W.2.2)) ∗ sts_state_loc (A:=A) i d'. + Proof. + iIntros "Hsf Hi". + iDestruct (sts_full_state_loc with "Hsf Hi") as %Hfs. + rewrite /sts_full_world /sts_full /sts_rel_loc /sts_state_loc. + destruct W as [Wstd [fs fr]]. + iDestruct "Hsf" as "[Hdst [H1 H2]] /=". + iCombine "H1" "Hi" as "H1". + iMod (own_update (A := sts_stateUR) + _ _ + (● (<[i := Excl (encode d')]> (Excl <$> fs)) + ⋅ ◯ {[i := Excl (encode d')]}) + with "H1") as "[H1 Hs]". + { apply auth_update. + apply: singleton_local_update; eauto. + rewrite lookup_fmap Hfs //=. + by apply exclusive_local_update. } + rewrite fmap_insert ; + first iModIntro; iFrame. + Qed. + + Lemma related_sts_pub_pub_plus_trans fs fr gs gr hs hr : + related_sts_pub fs gs fr gr → related_sts_pub_plus gs hs gr hr → + related_sts_pub_plus fs hs fr hr. + Proof. + intros [Hf1 [Hf2 Hf3]] [Hg1 [Hg2 Hg3]]; split; [|split]; try by etrans. + intros i r1 r2 r1' r2' r3 r3' Hfr Hhr. + specialize (Hf1 i); specialize (Hf2 i); + revert Hf1 Hf2; rewrite !elem_of_dom; intros Hf1 Hf2. + destruct Hf2; eauto. destruct x as [[x1 x2] x3]. + edestruct Hf3 as [Heq1 [Heq2 [Heq3 Hrtc]] ] ; eauto; simplify_eq. + edestruct Hg3 as [Heq1 [Heq2 [Heq3 Hrtc']] ] ; eauto; simplify_eq. + repeat (split;auto). + intros x y Hx Hy. + destruct Hf1;eauto. + etrans;eauto. + apply rtc_or_intro; auto. + Qed. + + Lemma related_sts_std_pub_pub_plus_trans fsd gsd hsd : + related_sts_std_pub fsd gsd → related_sts_std_pub_plus gsd hsd → + related_sts_std_pub_plus fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. + apply rtc_or_intro; auto. + Qed. + + Lemma related_sts_pub_pub_plus_trans_world W W' W'' : + related_sts_pub_world W W' → related_sts_pub_plus_world W' W'' + → related_sts_pub_plus_world W W''. + Proof. + intros [Hrel Hrel'] [Hrel2 Hrel2']. + split. + - apply related_sts_std_pub_pub_plus_trans with W'.1;auto. + - apply related_sts_pub_pub_plus_trans with W'.2.1 W'.2.2;auto. + Qed. + + Lemma related_sts_std_pub_a_trans a fsd gsd hsd : + related_sts_std_pub fsd gsd → related_sts_a gsd hsd a → + related_sts_a fsd hsd a. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. eapply rtc_implies;eauto. + intros r q Hr. destruct (decide (le_a a i));auto. + Qed. + + Lemma related_sts_std_a_refl a fsd : + related_sts_a fsd fsd a. + Proof. + apply related_sts_pub_a. + apply related_sts_std_pub_refl. + Qed. + + Lemma related_sts_std_a_pub_plus_trans a fsd gsd hsd : + related_sts_a fsd gsd a → related_sts_std_pub_plus gsd hsd → + related_sts_std_pub_plus fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. eapply rtc_implies;[|apply Hf2]. + intros r q Hr. destruct (decide (le_a a i));auto. + Qed. + + Lemma related_sts_std_a_priv_trans a fsd gsd hsd : + related_sts_a fsd gsd a → related_sts_std_priv gsd hsd → + related_sts_std_priv fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. eapply rtc_implies;[|apply Hf2]. + intros r q. destruct (decide (le_a a i));auto. + intros [? | ?];auto. + Qed. + + Lemma related_sts_std_pub_plus_priv_trans fsd gsd hsd : + related_sts_std_pub_plus fsd gsd → related_sts_std_priv gsd hsd → + related_sts_std_priv fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. eapply rtc_implies;[|apply Hf2]. + intros r q. intros [? | ?];auto. + Qed. + + Lemma related_sts_std_pub_plus_trans fsd gsd hsd : + related_sts_std_pub_plus fsd gsd → related_sts_std_pub_plus gsd hsd → + related_sts_std_pub_plus fsd hsd. + Proof. + intros [Hf1 Hf2] [Hg1 Hg2]; split; try by etrans. + intros i x y Hx Hy. + specialize (Hf1 i); + revert Hf1; rewrite !elem_of_dom; intros Hf1. + destruct Hf1 as [x0 Hx0]; eauto. + specialize (Hf2 i x x0 Hx Hx0); simplify_eq. + specialize (Hg2 i x0 y Hx0 Hy); simplify_eq. + etrans;eauto. + Qed. + + Lemma related_sts_pub_plus_trans fs fr gs gr hs hr : + related_sts_pub_plus fs gs fr gr → related_sts_pub_plus gs hs gr hr → + related_sts_pub_plus fs hs fr hr. + Proof. + intros [Hf1 [Hf2 Hf3]] [Hg1 [Hg2 Hg3]]; split; [|split]; try by etrans. + intros i r1 r2 r1' r2' r3 r3' Hfr Hhr. + specialize (Hf1 i); specialize (Hf2 i); + revert Hf1 Hf2; rewrite !elem_of_dom; intros Hf1 Hf2. + destruct Hf2; eauto. destruct x as [[x1 x2] x3]. + edestruct Hf3 as [Heq1 [Heq2 [Heq3 Hrtc]] ] ; eauto; simplify_eq. + edestruct Hg3 as [Heq1 [Heq2 [Heq3 Hrtc']] ] ; eauto; simplify_eq. + repeat (split;auto). + intros x y Hx Hy. + destruct Hf1;eauto. + etrans;eauto. + Qed. + + Lemma related_sts_pub_plus_priv_trans fs fr gs gr hs hr : + related_sts_pub_plus fs gs fr gr → related_sts_priv gs hs gr hr → + related_sts_priv fs hs fr hr. + Proof. + intros [Hf1 [Hf2 Hf3]] [Hg1 [Hg2 Hg3]]; split; [|split]; try by etrans. + intros i r1 r2 r1' r2' r3 r3' Hfr Hhr. + specialize (Hf1 i); specialize (Hf2 i); + revert Hf1 Hf2; rewrite !elem_of_dom; intros Hf1 Hf2. + destruct Hf2; eauto. destruct x as [[x1 x2] x3]. + edestruct Hf3 as [Heq1 [Heq2 [Heq3 Hrtc]] ] ; eauto; simplify_eq. + edestruct Hg3 as [Heq1 [Heq2 [Heq3 Hrtc']] ] ; eauto; simplify_eq. + repeat (split;auto). + intros x y Hx Hy. + destruct Hf1;eauto. + etrans;eauto. eapply rtc_implies;[|apply Hrtc];auto. + intros r q [Hr | Hr];auto. + Qed. + + Lemma related_sts_pub_a_trans_world W W' W'' a : + related_sts_pub_world W W' → related_sts_a_world W' W'' a + → related_sts_a_world W W'' a. + Proof. + intros [Hrel Hrel'] [Hrel2 Hrel2']. + split. + - apply related_sts_std_pub_a_trans with W'.1;auto. + - apply related_sts_pub_pub_plus_trans with W'.2.1 W'.2.2;auto. + Qed. + + Lemma related_sts_a_pub_plus_trans_world W W' W'' a : + related_sts_a_world W W' a → related_sts_pub_plus_world W' W'' + → related_sts_pub_plus_world W W''. + Proof. + intros [Hrel Hrel'] [Hrel2 Hrel2']. + split. + - apply related_sts_std_a_pub_plus_trans with a W'.1;auto. + - apply related_sts_pub_plus_trans with W'.2.1 W'.2.2;auto. + Qed. + + Lemma related_sts_a_priv_trans_world W W' W'' a : + related_sts_a_world W W' a → related_sts_priv_world W' W'' + → related_sts_priv_world W W''. + Proof. + intros [Hrel Hrel'] [Hrel2 Hrel2']. + split. + - apply related_sts_std_a_priv_trans with a W'.1;auto. + - apply related_sts_pub_plus_priv_trans with W'.2.1 W'.2.2;auto. + Qed. + + Lemma related_sts_a_trans_world W W' W'' a : + related_sts_a_world W W' a → related_sts_a_world W' W'' a → + related_sts_a_world W W'' a. + Proof. + intros [Hrel Hrel'] [Hrel2 Hrel2']. + split. + - apply related_sts_a_trans_left with W'.1 a;auto. + pose proof le_a_preorder as Hle_a_preorder. + inversion Hle_a_preorder. + apply PreOrder_Reflexive. + - apply related_sts_pub_plus_trans with W'.2.1 W'.2.2;auto. + Qed. + + + Lemma related_sts_pub_plus_priv_trans_world W W' W'' : + related_sts_pub_plus_world W W' → related_sts_priv_world W' W'' → + related_sts_priv_world W W''. + Proof. + intros [Hrel Hrel'] [Hrel2 Hrel2']. + split. + - apply related_sts_std_pub_plus_priv_trans with W'.1;auto. + - apply related_sts_pub_plus_priv_trans with W'.2.1 W'.2.2;auto. + Qed. + + Lemma related_sts_pub_plus_trans_world W W' W'' : + related_sts_pub_plus_world W W' → related_sts_pub_plus_world W' W'' → + related_sts_pub_plus_world W W''. + Proof. + intros [Hrel Hrel'] [Hrel2 Hrel2']. + split. + - apply related_sts_std_pub_plus_trans with W'.1;auto. + - apply related_sts_pub_plus_trans with W'.2.1 W'.2.2;auto. + Qed. + + Lemma related_sts_a_refl_world W a : + related_sts_a_world W W a. + Proof. + split. + - apply related_sts_std_a_refl. + - apply related_sts_pub_plus_refl. + Qed. + +End STS.