From e6e961a887f3a1b010f63cd438b907e280338f47 Mon Sep 17 00:00:00 2001 From: Jonas Kastberg Hinrichsen Date: Mon, 31 Jul 2023 14:39:10 +0200 Subject: [PATCH] Removed Trillium/Fairis and added Trillium as submodule (#37) --- .gitmodules | 3 + Makefile | 20 +- _CoqProject | 4 +- external/trillium | 1 + fairness/examples/choose_nat/choose_nat.v | 387 ---- fairness/examples/even_odd/even_odd.v | 398 ---- .../examples/even_odd/even_odd_adequacy.v | 650 ------ fairness/examples/yesno/yesno.v | 614 ------ fairness/examples/yesno/yesno_adequacy.v | 251 --- fairness/fair_termination.v | 104 - fairness/fairness.v | 170 -- fairness/fairness_finiteness.v | 371 ---- fairness/fuel.v | 775 ------- fairness/fuel_termination.v | 60 - fairness/heap_lang/lang.v | 750 ------- fairness/heap_lang/lifting.v | 1323 ------------ fairness/heap_lang/locations.v | 48 - fairness/heap_lang/notation.v | 159 -- fairness/heap_lang/proofmode.v | 1031 --------- fairness/heap_lang/tactics.v | 49 - fairness/inftraces.v | 596 ----- fairness/resources.v | 1471 ------------- fairness/trace_utils.v | 347 --- trillium/algebra/trace.v | 257 --- trillium/bi/weakestpre.v | 241 --- trillium/events/event.v | 438 ---- trillium/prelude/classical.v | 98 - trillium/prelude/classical_instances.v | 14 - trillium/prelude/finitary.v | 663 ------ trillium/prelude/fixpoint.v | 27 - trillium/prelude/iris_extraction.v | 211 -- trillium/prelude/quantifiers.v | 142 -- trillium/prelude/sigma.v | 51 - trillium/program_logic/adequacy.v | 1923 ----------------- trillium/program_logic/atomic.v | 183 -- trillium/program_logic/ectx_language.v | 374 ---- trillium/program_logic/ectx_lifting.v | 222 -- trillium/program_logic/ectxi_language.v | 198 -- trillium/program_logic/language.v | 511 ----- trillium/program_logic/lifting.v | 238 -- trillium/program_logic/traces.v | 406 ---- trillium/program_logic/weakestpre.v | 699 ------ trillium/traces/infinite_trace.v | 164 -- trillium/traces/trace.v | 859 -------- trillium/traces/trace_properties.v | 807 ------- 45 files changed, 9 insertions(+), 18299 deletions(-) create mode 160000 external/trillium delete mode 100644 fairness/examples/choose_nat/choose_nat.v delete mode 100644 fairness/examples/even_odd/even_odd.v delete mode 100644 fairness/examples/even_odd/even_odd_adequacy.v delete mode 100644 fairness/examples/yesno/yesno.v delete mode 100644 fairness/examples/yesno/yesno_adequacy.v delete mode 100644 fairness/fair_termination.v delete mode 100644 fairness/fairness.v delete mode 100644 fairness/fairness_finiteness.v delete mode 100644 fairness/fuel.v delete mode 100644 fairness/fuel_termination.v delete mode 100644 fairness/heap_lang/lang.v delete mode 100644 fairness/heap_lang/lifting.v delete mode 100644 fairness/heap_lang/locations.v delete mode 100644 fairness/heap_lang/notation.v delete mode 100644 fairness/heap_lang/proofmode.v delete mode 100644 fairness/heap_lang/tactics.v delete mode 100644 fairness/inftraces.v delete mode 100644 fairness/resources.v delete mode 100644 fairness/trace_utils.v delete mode 100644 trillium/algebra/trace.v delete mode 100644 trillium/bi/weakestpre.v delete mode 100644 trillium/events/event.v delete mode 100644 trillium/prelude/classical.v delete mode 100644 trillium/prelude/classical_instances.v delete mode 100644 trillium/prelude/finitary.v delete mode 100644 trillium/prelude/fixpoint.v delete mode 100644 trillium/prelude/iris_extraction.v delete mode 100644 trillium/prelude/quantifiers.v delete mode 100644 trillium/prelude/sigma.v delete mode 100644 trillium/program_logic/adequacy.v delete mode 100644 trillium/program_logic/atomic.v delete mode 100644 trillium/program_logic/ectx_language.v delete mode 100644 trillium/program_logic/ectx_lifting.v delete mode 100644 trillium/program_logic/ectxi_language.v delete mode 100644 trillium/program_logic/language.v delete mode 100644 trillium/program_logic/lifting.v delete mode 100644 trillium/program_logic/traces.v delete mode 100644 trillium/program_logic/weakestpre.v delete mode 100644 trillium/traces/infinite_trace.v delete mode 100644 trillium/traces/trace.v delete mode 100644 trillium/traces/trace_properties.v diff --git a/.gitmodules b/.gitmodules index 8a5293f3..8776f6b2 100644 --- a/.gitmodules +++ b/.gitmodules @@ -13,3 +13,6 @@ [submodule "actris"] path = external/actris url = https://gitlab.mpi-sws.org/iris/actris.git +[submodule "external/trillium"] + path = external/trillium + url = git@github.com:logsem/trillium.git diff --git a/Makefile b/Makefile index 425c19ab..2693b717 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,5 @@ -TRILLIUM_DIR := 'trillium' ANERIS_DIR := 'aneris' -FAIRNESS_DIR := 'fairness' -LOCAL_SRC_DIRS := $(TRILLIUM_DIR) $(ANERIS_DIR) $(FAIRNESS_DIR) +LOCAL_SRC_DIRS := $(ANERIS_DIR) SRC_DIRS := $(LOCAL_SRC_DIRS) 'external' ALL_VFILES := $(shell find $(SRC_DIRS) -name "*.v") @@ -44,19 +42,13 @@ clean: rm -f .coqdeps.d # project-specific targets -.PHONY: build clean-trillium clean-fairness clean-aneris trillium fairness aneris +.PHONY: build clean-aneris aneris -VPATH= $(TRILLIUM_DIR) $(ANERIS_DIR) $(FAIRNESS_DIR) +VPATH= $(ANERIS_DIR) VPATH_FILES := $(shell find $(VPATH) -name "*.v") build: $(VPATH_FILES:.v=.vo) -fairness : - @$(MAKE) build VPATH=$(FAIRNESS_DIR) - -trillium : - @$(MAKE) build VPATH=$(TRILLIUM_DIR) - aneris : @$(MAKE) build VPATH=$(ANERIS_DIR) @@ -65,11 +57,5 @@ clean-local: $(Q)find $(LOCAL_SRC_DIRS) \( -name "*.vo" -o -name "*.vo[sk]" \ -o -name ".*.aux" -o -name ".*.cache" -o -name "*.glob" \) -delete -clean-trillium: - @$(MAKE) clean-local LOCAL_SRC_DIRS=$(TRILLIUM_DIR) - clean-aneris: @$(MAKE) clean-local LOCAL_SRC_DIRS=$(ANERIS_DIR) - -clean-fairness: - @$(MAKE) clean-local LOCAL_SRC_DIRS=$(FAIRNESS_DIR) diff --git a/_CoqProject b/_CoqProject index 96f45291..099c327a 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,10 +1,9 @@ --Q trillium trillium -Q aneris aneris --Q fairness trillium.fairness -Q external/stdpp/stdpp stdpp -Q external/stdpp/stdpp_unstable stdpp.unstable -Q external/iris/iris iris +-Q external/trillium/trillium trillium -Q external/record-update/src RecordUpdate -Q external/paco/src Paco -Q external/actris/theories actris @@ -12,6 +11,7 @@ -Q external/iris/iris_deprecated iris.deprecated -Q external/iris/iris_unstable iris.unstable -Q external/iris/iris_heap_lang iris.heap_lang +-Q external/trillium/fairis trillium.fairness -arg -w -arg -notation-overridden -arg -w -arg -redundant-canonical-projection diff --git a/external/trillium b/external/trillium new file mode 160000 index 00000000..577dfbd9 --- /dev/null +++ b/external/trillium @@ -0,0 +1 @@ +Subproject commit 577dfbd9b1c07d37b30bf7135687be05f6f496d5 diff --git a/fairness/examples/choose_nat/choose_nat.v b/fairness/examples/choose_nat/choose_nat.v deleted file mode 100644 index e76b5452..00000000 --- a/fairness/examples/choose_nat/choose_nat.v +++ /dev/null @@ -1,387 +0,0 @@ -From stdpp Require Import finite decidable. -From iris.prelude Require Import options. -From iris.algebra Require Import excl_auth. -From iris.bi Require Import bi. -From iris.base_logic.lib Require Import invariants. -From iris.proofmode Require Import tactics. -From trillium.prelude Require Export finitary quantifiers sigma classical_instances. -From trillium.fairness Require Import fairness fair_termination fairness_finiteness. -From trillium.program_logic Require Export weakestpre. -From trillium.fairness.heap_lang Require Export lang lifting tactics proofmode. -From trillium.fairness.heap_lang Require Import notation. - -Import derived_laws_later.bi. - -Set Default Proof Using "Type". - -(** The program verify liveness for *) -(** Recursion is "off by one" to allow immediate termination after storing 0 *) -Definition decr_loop_prog (l : loc) : val := - rec: "go" <> := - let: "x" := !#l in - if: "x" = #1 then #l <- ("x" - #1) - else #l <- ("x" - #1);; "go" #(). -Definition choose_nat_prog (l : loc) : val := - λ: <>, - #l <- (ChooseNat + #1);; - decr_loop_prog l #(). - -(** The model state *) -Inductive CN := Start | N (n : nat). - -(** A mapping of model state to "program state" *) -Definition CN_Z (cn : CN) : Z := - match cn with - | Start => -1 - | N n => n - end. - -#[global] Instance CN_eqdec: EqDecision CN. -Proof. solve_decision. Qed. - -#[global] Instance CN_inhabited: Inhabited CN. -Proof. exact (populate Start). Qed. - -Inductive cntrans : CN → option unit → CN -> Prop := -| start_trans n : cntrans Start (Some ()) (N n) -| decr_trans n : cntrans (N $ S n) (Some ()) (N n). - -(* Free construction of the active labels on each state by [cntrans] *) -Definition cn_live_roles (cn : CN) : gset unit := - match cn with N 0 => ∅ | _ => {[ () ]} end. - -Lemma cn_live_spec_holds s ρ s' : cntrans s (Some ρ) s' -> ρ ∈ cn_live_roles s. -Proof. destruct s; [set_solver|]. destruct n; [|set_solver]. inversion 1. Qed. - -Definition cn_fair_model : FairModel. -Proof. - refine({| - fmstate := CN; - fmrole := unit; - fmtrans := cntrans; - live_roles := cn_live_roles; - fm_live_spec := cn_live_spec_holds; - |}). -Defined. - -(** Show that the model is fairly terminating *) - -Inductive cn_order : CN → CN → Prop := - | cn_order_Start cn : cn_order cn Start - | cn_order_N (n1 n2 : nat) : n1 ≤ n2 → cn_order (N n1) (N n2). - -Local Instance the_order_po: PartialOrder cn_order. -Proof. - split. - - split. - + by intros []; constructor. - + intros [] [] [] Hc12 Hc23; try constructor. - * inversion Hc23. - * inversion Hc12. - * inversion Hc23. - * inversion Hc12. inversion Hc23. simplify_eq. lia. - - intros [] []; inversion 1; simplify_eq; try eauto; try inversion 1. - simplify_eq. f_equal. lia. -Qed. - -Definition cn_decreasing_role (s : fmstate cn_fair_model) : unit := - match s with | _ => () end. - -#[local] Program Instance cn_model_terminates : - FairTerminatingModel cn_fair_model := - {| - ftm_leq := cn_order; - ftm_decreasing_role := cn_decreasing_role; - |}. -Next Obligation. - assert (∀ n, Acc (strict cn_order) (N n)). - { intros n. - induction n as [n IHn] using lt_wf_ind. - constructor. intros cn [Hcn1 Hcn2]. - inversion Hcn1 as [|n1 n2]; simplify_eq. - destruct (decide (n = n1)) as [->|Hneq]; [done|]. - apply IHn. lia. } - constructor. intros [] [Hc1 Hc2]; [|done]. - inversion Hc1; simplify_eq. done. -Qed. -Next Obligation. - intros cn [ρ' [cn' Htrans]]. - split. - - rewrite /cn_decreasing_role. simpl. rewrite /cn_live_roles. - destruct cn; [set_solver|]. - destruct n; [inversion Htrans|set_solver]. - - intros cn'' Htrans'. - destruct cn. - + split; [constructor|]. - intros Hrel. inversion Hrel; simplify_eq. inversion Htrans'. - + split. - * destruct cn''. - -- inversion Htrans'. - -- inversion Htrans'; simplify_eq. constructor. lia. - * intros Hrel. - inversion Htrans'; simplify_eq. - inversion Hrel; simplify_eq. - lia. -Qed. -Next Obligation. done. Qed. -Next Obligation. - intros cn1 ρ cn2 Htrans. - destruct cn1. - - inversion Htrans; simplify_eq. constructor. - - inversion Htrans; simplify_eq. constructor. lia. -Qed. - -Definition cn_model : LiveModel heap_lang cn_fair_model := - {| lm_fl _ := 40%nat |}. - -(** Determine additional restriction on relation to obtain finite branching *) -Definition ξ_cn (l:loc) (extr : execution_trace heap_lang) - (auxtr : finite_trace cn_fair_model (option unit)) := - ∃ (cn:CN), (trace_last extr).2.(heap) !!! l = #(CN_Z cn) ∧ - (trace_last auxtr) = cn. - -(** Verify that the program refines the model *) - -(* Set up necessary RA constructions *) -Class choose_natG Σ := ChooseNatG { choose_nat_G :> inG Σ (excl_authR ZO) }. - -Definition choose_natΣ : gFunctors := - #[ heapΣ cn_fair_model; GFunctor (excl_authR ZO) ]. - -Global Instance subG_choosenatΣ {Σ} : subG choose_natΣ Σ → choose_natG Σ. -Proof. solve_inG. Qed. - -Definition Ns := nroot .@ "choose_nat". - -Section proof. - Context `{!heapGS Σ cn_model, choose_natG Σ}. - - (** Determine invariant so we can eventually derive ξ_cn from it *) - Definition choose_nat_inv_inner (γ : gname) (l:loc) : iProp Σ := - ∃ (cn:CN), frag_model_is cn ∗ l ↦ #(CN_Z cn) ∗ own γ (●E (CN_Z cn)). - - Definition choose_nat_inv (γ : gname) (l:loc) := - inv Ns (choose_nat_inv_inner γ l). - - Lemma decr_loop_spec γ tid l (n:nat) (f:nat) : - 7 ≤ f → f ≤ 38 → - choose_nat_inv γ l -∗ - {{{ has_fuel tid () f ∗ frag_free_roles_are ∅ ∗ - own γ (◯E (Z.of_nat (S n))) }}} - decr_loop_prog l #() @ tid ; ⊤ - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iIntros (Hle1 Hle2) "#IH". - iIntros "!>" (Φ) "(Hf & Hr & Hm) HΦ". - iInduction n as [|n] "IHn". - { wp_lam. - (* Load - with invariant *) - wp_bind (Load _). - iApply wp_atomic. - iInv Ns as ">HI" "Hclose". - iDestruct "HI" as (cn) "(Hs & Hl & Hcn)". - iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L. - iModIntro. - wp_load. - iModIntro. - iMod ("Hclose" with "[Hs Hl Hcn]") as "_"; [ iExists _; iFrame | ]. - iModIntro. - rewrite Hvalid. clear cn Hvalid. - (* Store - with invariant *) - wp_pures. - replace (Z.of_nat 1 - 1)%Z with 0%Z by lia. - wp_bind (Store _ _). - iApply wp_atomic. - iInv Ns as ">HI" "Hclose". - iDestruct "HI" as (cn) "(Hs & Hl & Hcn)". - iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L. - iModIntro. - assert (cn = N 1) as ->. - { destruct cn; inversion Hvalid. by simplify_eq. } - (* Update the model state to maintain program correspondence *) - iApply (wp_store_step_singlerole _ _ (():fmrole cn_fair_model) (f - 7) (f-3) - with "[$Hl $Hs $Hr Hf]"). - { simpl. lia. } - { constructor. } - { set_solver. } - { replace (f - 1 - 1 - 1 - 1 - 1 - 1 - 1)%nat with (f - 7)%nat by lia. - by rewrite has_fuel_fuels. } - iIntros "!> (Hl & Hs & Hr & Hf)". - iMod (own_update_2 _ _ _ with "Hcn Hm") as "[Hcn Hm]". - { apply (excl_auth_update _ _ 0%Z). } - iMod ("Hclose" with "[Hs Hl Hcn]") as "_". - { iExists (N 0). iFrame. } - iModIntro. - simpl. - destruct (decide (() ∈ ∅)); [set_solver|]. - by iApply "HΦ". } - wp_lam. - (* Load - with invariant *) - wp_bind (Load _). - iApply wp_atomic. - iInv Ns as ">HI" "Hclose". - iModIntro. - iDestruct "HI" as (cn) "(Hs & Hl & Hcn)". - wp_load. - iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L. - iModIntro. iMod ("Hclose" with "[Hs Hl Hcn]") as "_". - { iExists _. iFrame. } - iModIntro. - rewrite Hvalid. clear cn Hvalid. - wp_pures. - case_bool_decide as Heq; [inversion Heq; lia|clear Heq]. - wp_pures. - replace (Z.of_nat (S (S n)) - 1)%Z with (Z.of_nat (S n)) %Z by lia. - (* Store - with invariant *) - wp_bind (Store _ _). - iApply wp_atomic. - iInv Ns as ">HI" "Hclose". - iModIntro. - iDestruct "HI" as (cn) "(Hs & Hl & Hcn)". - iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L. - assert (cn = N (S (S n))) as ->. - { destruct cn; inversion Hvalid. by simplify_eq. } - (* Update the model state to maintain program correspondence *) - iApply (wp_store_step_singlerole _ _ (():fmrole cn_fair_model) (f - 7) - (f+2) with "[$Hl $Hs $Hr Hf]"). - { simpl. lia. } - { constructor. } - { set_solver. } - { replace (f - 1 - 1 - 1 - 1 - 1 - 1 - 1)%nat with (f - 7)%nat by lia. - rewrite has_fuel_fuels. done. } - iIntros "!> (Hl & Hs & Hr & Hf)". - iMod (own_update_2 _ _ _ with "Hcn Hm") as "[Hcn Hm]". - { apply (excl_auth_update _ _ (Z.of_nat (S n))%Z). } - iMod ("Hclose" with "[Hs Hl Hcn]") as "_". - { iExists (N (S n)). iFrame. } - iModIntro. - simpl. destruct (decide (() ∈ {[()]})); [|set_solver]. - wp_pures. - replace (f + 2 - 1 - 1)%nat with f by lia. - by iApply ("IHn" with "Hf Hr Hm"). - Qed. - - Lemma choose_nat_spec γ l tid (f:nat) : - 12 ≤ f → f ≤ 40 → - choose_nat_inv γ l -∗ - {{{ has_fuel tid () f ∗ frag_free_roles_are ∅ ∗ own γ (◯E (-1)%Z) }}} - choose_nat_prog l #() @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iIntros (Hle1 Hle2) "#IH". - iIntros "!>" (Φ) "(Hf & Hr & Hm) HΦ". - wp_lam. - wp_bind ChooseNat. - iApply (wp_choose_nat_nostep _ _ _ {[() := (f - 2)%nat]} with "[Hf]"). - { set_solver. } - { rewrite -has_fuel_fuels_S has_fuel_fuels. - replace (S (f - 2))%nat with (f - 1)%nat by lia. done. } - iIntros "!>" (n) "Hf". - wp_pures. - (* Store - with invariant *) - wp_bind (Store _ _). - iApply wp_atomic. - iInv Ns as ">HI" "Hclose". - iModIntro. - iDestruct "HI" as (cn) "(Hs & Hl & Hcn)". - iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L. - assert (cn = Start) as ->. - { destruct cn; inversion Hvalid; [done|]. lia. } - (* Update the model state to maintain program correspondence *) - iApply (wp_store_step_singlerole _ _ (():fmrole cn_fair_model) - (f - 3) (f-2) _ _ (N (S n)) - with "[$Hl $Hs $Hr Hf]"). - { simpl. lia. } - { constructor. } - { set_solver. } - { replace (f - 2 - 1)%nat with (f - 3)%nat by lia. - rewrite has_fuel_fuels. done. } - iIntros "!> (Hl & Hs & Hr & Hf)". - iMod (own_update_2 _ _ _ with "Hcn Hm") as "[Hcn Hm]". - { apply (excl_auth_update _ _ (Z.of_nat (S n))%Z). } - iMod ("Hclose" with "[Hs Hl Hcn]") as "_". - { replace (Z.of_nat n + 1)%Z with (Z.of_nat (S n)) by lia. - iExists (N (S n)). iFrame. } - iModIntro. - simpl. destruct (decide (() ∈ {[()]})); [|set_solver]. - wp_pures. - rewrite -has_fuel_fuels. - by iApply (decr_loop_spec with "IH [$Hm $Hr $Hf]"); [lia|lia|]. - Qed. - -End proof. - -(** Construct inverse mapping of program state to model state, - to compute finite relation *) -Definition Z_CN (v : val) : CN := - match v with - | LitV (LitInt z) => - match z with - | Z0 => N 0 - | Zpos p => N (Pos.to_nat p) - | Zneg _ => Start (* Error case when z < -1 *) - end - | _ => Start (* Error case *) - end. - -Lemma Z_CN_CN_Z cn : Z_CN #(CN_Z cn) = cn. -Proof. destruct cn; [done|]; destruct n; [done|]=> /=; f_equal; lia. Qed. - -(** Derive that program is related to model by - [sim_rel_with_user cn_model (ξ_cn l) using Trillium adequacy *) -Lemma choose_nat_sim l : - continued_simulation - (sim_rel_with_user cn_model (ξ_cn l)) - (trace_singleton ([choose_nat_prog l #()], - {| heap := {[l:=#-1]}; - used_proph_id := ∅ |})) - (trace_singleton (initial_ls (LM := cn_model) Start 0%nat)). -Proof. - assert (heapGpreS choose_natΣ cn_model) as HPreG. - { apply _. } - eapply (strong_simulation_adequacy - choose_natΣ _ NotStuck _ _ _ ∅); [|set_solver|]. - { clear. - apply rel_finitary_sim_rel_with_user_ξ. - intros extr atr c' oζ. - eapply finite_smaller_card_nat=> /=. - eapply (in_list_finite [(Z_CN (heap c'.2 !!! l), None); - (Z_CN (heap c'.2 !!! l), Some ())]). - (* TODO: Figure out why this does not unify with typeclass *) - Unshelve. 2: intros x; apply make_proof_irrel. - intros [cn o] [cn' [Hextr Hatr]]. - rewrite Hextr Z_CN_CN_Z -Hatr. destruct o; [destruct u|]; set_solver. } - iIntros (?) "!> Hσ Hs Hr Hf". - iMod (own_alloc) as (γ) "He"; [apply (excl_auth_valid (-1)%Z)|]. - iDestruct "He" as "[He● He○]". - iMod (inv_alloc Ns ⊤ (choose_nat_inv_inner γ l) with "[He● Hσ Hs]") as "#IH". - { iIntros "!>". iExists _. iFrame. by rewrite big_sepM_singleton. } - iModIntro. - iSplitL. - { iApply (choose_nat_spec _ _ _ 40 with "IH [Hr Hf He○]"); - [lia|lia| |by eauto]=> /=. - replace (∅ ∖ {[()]}) with (∅:gset unit) by set_solver. - rewrite has_fuel_fuels gset_to_gmap_set_to_map. iFrame. } - iIntros (ex atr c Hvalid Hex Hatr Hends Hξ Hstuck) "Hσ _". - iInv Ns as ">H". - iDestruct "H" as (cn) "(Hf & Hl & H●)". - iDestruct "Hσ" as (Hvalid') "[Hσ Hs]". - iDestruct (gen_heap_valid with "Hσ Hl") as %Hlookup%lookup_total_correct. - iDestruct (model_agree' with "Hs Hf") as %Hlast. - iModIntro. iSplitL; [by iExists _; iFrame|]. - iApply fupd_mask_intro; [set_solver|]. iIntros "_". - iPureIntro. exists cn. - split; [done|]. - subst. by destruct atr. -Qed. - -Theorem choose_nat_terminates l extr : - trfirst extr = ([choose_nat_prog l #()], - {| heap := {[l:=#-1]}; - used_proph_id := ∅ |}) → - extrace_fairly_terminating extr. -Proof. - intros Hexfirst. - eapply heap_lang_continued_simulation_fair_termination; eauto. - rewrite Hexfirst. eapply choose_nat_sim. -Qed. diff --git a/fairness/examples/even_odd/even_odd.v b/fairness/examples/even_odd/even_odd.v deleted file mode 100644 index a13dd75d..00000000 --- a/fairness/examples/even_odd/even_odd.v +++ /dev/null @@ -1,398 +0,0 @@ -From iris.proofmode Require Import tactics. -From trillium.program_logic Require Export weakestpre. -From trillium.fairness Require Import fairness fair_termination. -From trillium.prelude Require Export finitary quantifiers sigma classical_instances. - -Require Import stdpp.decidable. -From trillium.fairness.heap_lang Require Export lang lifting tactics proofmode. -From trillium.fairness.heap_lang Require Import notation. -From iris.base_logic.lib Require Import invariants. -From iris.prelude Require Import options. -From iris.algebra Require Import excl_auth. -From iris.bi Require Import bi. - -Import derived_laws_later.bi. - -Set Default Proof Using "Type". - -Definition incr_loop : val := - rec: "incr_loop" "l" "n" := - (if: CAS "l" "n" ("n"+#1) - then "incr_loop" "l" ("n" + #2) - else "incr_loop" "l" "n"). - -Definition start : val := - λ: "l", - let: "x" := !"l" in - (Fork (incr_loop "l" "x") ;; - Fork (incr_loop "l" ("x"+#1))). - -(** * Definition of the model! *) - -Inductive EO := ρEven | ρOdd. - -#[global] Instance EO_eqdec: EqDecision EO. -Proof. solve_decision. Qed. - -#[global] Instance EO_countable: Countable EO. -Proof. - refine ({| - encode eo := match eo with ρEven => 1 | ρOdd => 2 end; - decode p := match p with 1 => Some ρEven | 2 => Some ρOdd | _ => None end; - |})%positive. - intros eo. by destruct eo. -Qed. - -#[global] Instance EO_inhabited: Inhabited EO. -Proof. exact (populate ρEven). Qed. - -Inductive eotrans: nat -> option EO -> nat -> Prop := -| even_trans n : Nat.even n → eotrans n (Some ρEven) (S n) -| even_fail n : Nat.odd n → eotrans n (Some ρEven) n -| no_trans n : Nat.odd n → eotrans n (Some ρOdd) (S n) -| no_fail n : Nat.even n → eotrans n (Some ρOdd) n -. - -Definition eo_live_roles : gset EO := {[ ρOdd; ρEven ]}. - -Lemma live_spec_holds : - forall s ρ s', eotrans s (Some ρ) s' -> ρ ∈ eo_live_roles. -Proof. - intros n eo n' Htrans. rewrite /eo_live_roles. - inversion Htrans; simplify_eq; try set_solver; try lia; destruct n'; try set_solver; lia. -Qed. - -Definition the_fair_model: FairModel. -Proof. - refine({| - fmstate := nat; - fmrole := EO; - fmtrans := eotrans; - live_roles _ := eo_live_roles; - fm_live_spec := live_spec_holds; - |}). -Defined. - -Definition the_model: LiveModel heap_lang the_fair_model := - {| - lm_fl (x: fmstate the_fair_model) := 61%nat; - |}. - -(** The CMRAs we need. *) -Class evenoddG Σ := EvenoddG { - even_name: gname; - odd_name: gname; - evenodd_n_G :> inG Σ (excl_authR natO); - }. -Class evenoddPreG Σ := { - evenodd_PreG :> inG Σ (excl_authR natO); - }. -Definition evenoddΣ : gFunctors := - #[ heapΣ the_fair_model; GFunctor (excl_authR natO) ; GFunctor (excl_authR boolO) ]. - -Global Instance subG_evenoddΣ {Σ} : subG evenoddΣ Σ → evenoddPreG Σ. -Proof. solve_inG. Qed. - -Section proof. - Context `{!heapGS Σ the_model, !evenoddG Σ}. - Let Ns := nroot .@ "even_odd". - - Definition even_at (n: nat) := own even_name (◯E n). - Definition odd_at (n: nat) := own odd_name (◯E n). - - Definition auth_even_at (n: nat) := own even_name (●E n). - Definition auth_odd_at (n: nat) := own odd_name (●E n). - - Lemma they_agree γ (N M: nat): - own γ (◯E N) -∗ own γ (●E M) -∗ ⌜ M = N ⌝. - Proof. - iIntros "HA HB". iCombine "HB HA" as "H". - iDestruct (own_valid with "H") as "%Hval". - iPureIntro. by apply excl_auth_agree_L. - Qed. - Lemma even_agree N M: - even_at N -∗ auth_even_at M -∗ ⌜ M = N ⌝. - Proof. apply they_agree. Qed. - Lemma odd_agree N M: - odd_at N -∗ auth_odd_at M -∗ ⌜ M = N ⌝. - Proof. apply they_agree. Qed. - - Lemma they_update γ (N M P: nat): - own γ (●E N) ∗ own γ (◯E M) ==∗ own γ (●E P) ∗ own γ (◯E P). - Proof. - rewrite -!own_op. iApply own_update. apply excl_auth_update. - Qed. - Lemma even_update P N M: - auth_even_at M ∗ even_at N ==∗ auth_even_at P ∗ even_at P. - Proof. apply they_update. Qed. - Lemma odd_update P N M: - auth_odd_at M ∗ odd_at N ==∗ auth_odd_at P ∗ odd_at P. - Proof. apply they_update. Qed. - - Definition evenodd_inv_inner n := - (∃ N, - frag_free_roles_are ∅ ∗ - frag_model_is N ∗ n ↦ #N ∗ - (if (Nat.even N) - then auth_even_at N ∗ auth_odd_at (N+1) - else auth_even_at (N+1) ∗ auth_odd_at N))%I. - Definition evenodd_inv n := inv Ns (evenodd_inv_inner n). - - Lemma even_go_spec tid n (N: nat) f (Hf: f > 40): - {{{ evenodd_inv n ∗ has_fuel tid ρEven f ∗ even_at N }}} - incr_loop #n #N @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iLöb as "Hg" forall (N f Hf). - iIntros (Φ) "(#Hinv & Hf & Heven) Hk". - wp_lam. - wp_pures. - wp_bind (CmpXchg _ _ _). - iApply wp_atomic. - iInv Ns as (M) "(>HFR & >Hmod & >Hn & Hauths)" "Hclose". - destruct (Nat.even M) eqn:Heqn; iDestruct "Hauths" as "[>Hay >Han]". - - iDestruct (even_agree with "Heven Hay") as "%Heq". - rewrite -has_fuel_fuels. - iApply (wp_cmpxchg_suc_step_singlerole _ tid (ρEven: fmrole the_fair_model) _ 55%nat _ - M (M + 1) - with "[$]"); eauto. - { by do 3 f_equiv. } - { simpl. lia. } - { rewrite Nat.add_1_r. econstructor. eauto. } - iModIntro. - iIntros "!> (Hb & Hmod & HFR & Hf)". - iMod (even_update (M + 2) with "[$]") as "[Hay Heven]". - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _. iFrame. rewrite Nat2Z.inj_add. - subst. iFrame. - rewrite Nat.add_1_r. - rewrite Nat.even_succ. - rewrite -Nat.negb_even. rewrite Heqn. simpl. iFrame. - rewrite Nat.add_1_r. - replace (S (S N)) with (N + 2) by lia. iFrame. } - iModIntro. rewrite decide_True; last first. - { set_solver. } - rewrite has_fuel_fuels. - wp_pures. - replace (Z.of_nat N + 2)%Z with (Z.of_nat (N + 2)) by lia. - iApply ("Hg" with "[] [Heven Hf] [$]"); last first. - { iFrame "∗#". rewrite has_fuel_fuels. - subst. iFrame. } - iPureIntro; lia. - - iDestruct (even_agree with "Heven Hay") as "%Heq". rewrite -> Heq in *. - rewrite -has_fuel_fuels. - iApply (wp_cmpxchg_fail_step_singlerole _ tid (ρEven: fmrole the_fair_model) _ 50%nat _ - M M - with "[$]"); eauto. - { intros Hne. simplify_eq. lia. } - { simpl. lia. } - { econstructor. rewrite -Nat.negb_even. rewrite Heqn. done. } - iIntros "!>!> (Hb & Hmod & HFR & Hf)". - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. simplify_eq. iExists _. iFrame. - subst. iFrame. - rewrite Nat.add_1_r. rewrite Heqn. iFrame. } - rewrite decide_True; last first. - { set_solver. } - iModIntro. - wp_pures. - rewrite -has_fuel_fuels. - iApply ("Hg" with "[] [Heven Hf] [$]"); last first. - { iFrame "∗#". } - iPureIntro; lia. - Qed. - - Lemma odd_go_spec tid n (N: nat) f (Hf: f > 40): - {{{ evenodd_inv n ∗ has_fuel tid ρOdd f ∗ odd_at N }}} - incr_loop #n #N @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iLöb as "Hg" forall (N f Hf). - iIntros (Φ) "(#Hinv & Hf & Hodd) Hk". - wp_lam. - wp_pures. - wp_bind (CmpXchg _ _ _). - iApply wp_atomic. - iInv Ns as (M) "(>HFR & >Hmod & >Hn & Hauths)" "Hclose". - destruct (Nat.even M) eqn:Heqn; iDestruct "Hauths" as "[>Hay >Han]"; last first. - - iDestruct (odd_agree with "Hodd Han") as "%Heq". - rewrite -has_fuel_fuels. - iApply (wp_cmpxchg_suc_step_singlerole _ tid (ρOdd: fmrole the_fair_model) _ 55%nat _ - M (S M) - with "[$]"); eauto. - { by do 3 f_equiv. } - { simpl. lia. } - { econstructor. rewrite -Nat.negb_even. rewrite Heqn. done. } - iModIntro. - iIntros "!> (Hb & Hmod & HFR & Hf)". - iMod (odd_update (M + 2) with "[$]") as "[Han Hodd]". - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _. iFrame. subst. - rewrite Nat.add_1_r. - rewrite Nat.even_succ. - rewrite -Nat.negb_even. rewrite Heqn. simpl. iFrame. - rewrite Nat.add_1_r. - replace (S (S N)) with (N + 2) by lia. - iFrame. - iEval (rewrite -Nat.add_1_r). - rewrite Nat2Z.inj_add. - iFrame. } - iModIntro. rewrite decide_True; last first. - { set_solver. } - rewrite has_fuel_fuels. - wp_pures. - rewrite -has_fuel_fuels. - replace (Z.of_nat N + 2)%Z with (Z.of_nat (N + 2)) by lia. - iApply ("Hg" with "[] [Hodd Hf] [$]"); last first. - { iFrame "∗#". simplify_eq. done. } - iPureIntro; lia. - - iDestruct (odd_agree with "Hodd Han") as "%Heq". rewrite -> Heq in *. - rewrite -has_fuel_fuels. simplify_eq. - iApply (wp_cmpxchg_fail_step_singlerole _ tid (ρOdd: fmrole the_fair_model) _ 50%nat _ - M M - with "[$]"); eauto. - { intros Hneq. simplify_eq. lia. } - { simpl. lia. } - { econstructor. eauto. } - iIntros "!>!> (Hb & Hmod & HFR & Hf)". - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. simplify_eq. iExists _. iFrame. - rewrite Heqn. iFrame. } - rewrite decide_True; last first. - { set_solver. } - iModIntro. - wp_pures. - rewrite -has_fuel_fuels. - iApply ("Hg" with "[] [Hodd Hf] [$]"); last first. - { iFrame "∗#". } - iPureIntro; lia. - Qed. - - Definition role_frag (eo : EO) : nat → iProp Σ := - match eo with - | ρEven => even_at - | ρOdd => odd_at - end. - - Lemma incr_loop_spec tid n (N : nat) f (Hf: f > 40) (eo : EO) : - {{{ evenodd_inv n ∗ has_fuel tid eo f ∗ (role_frag eo) N }}} - incr_loop #n #N @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iIntros (Φ) "(#Hinv & Hf & Heo) Hk". - destruct eo. - - iApply (even_go_spec with "[$Hf $Heo]"); [lia|done|done]. - - iApply (odd_go_spec with "[$Hf $Heo]"); [lia|done|done]. - Qed. - -End proof. - -Section proof_start. - Context `{!heapGS Σ the_model, !evenoddG Σ}. - Let Ns := nroot .@ "even_odd". - - Lemma start_spec tid n N1 N2 f (Hf: f > 60) : - {{{ evenodd_inv n ∗ has_fuels tid {[ ρEven := f; ρOdd := f ]} ∗ - even_at N1 ∗ odd_at N2 }}} - start #n @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof using All. - iIntros (Φ) "(#Hinv & Hf & Heven_at & Hodd_at) HΦ". unfold start. - wp_pures. - wp_bind (Load _). - iApply wp_atomic. - iInv Ns as (M) "(>HFR & >Hmod & >Hn & Hauths)" "Hclose". - iIntros "!>". - wp_load. - iIntros "!>". - destruct (Nat.even M) eqn:Heven. - - iDestruct "Hauths" as "[Heven Hodd]". - iDestruct (even_agree with "Heven_at Heven") as %<-. - iDestruct (odd_agree with "Hodd_at Hodd") as %<-. - iMod ("Hclose" with "[-Hf Heven_at Hodd_at HΦ]") as "_". - { iIntros "!>". iExists _. iFrame. rewrite Heven. iFrame. } - iIntros "!>". wp_pures. wp_bind (Fork _). - rewrite has_fuels_gt_1; last solve_fuel_positive. - iApply (wp_fork_nostep _ tid _ _ _ {[ ρOdd ]} {[ ρEven ]} {[ρEven := _; ρOdd := _]} - with "[Heven_at] [- Hf] [Hf]"); - [ set_solver | by apply insert_non_empty | | | | - rewrite !fmap_insert fmap_empty // ]; [set_solver | |]. - { iIntros (tid') "!> Hf". - rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_insert_not; last set_solver. - rewrite map_filter_empty insert_empty. - rewrite -has_fuel_fuels. - iApply (incr_loop_spec with "[Heven_at $Hf]"); [lia|iFrame "#∗"|]. - by iIntros "!>?". } - iIntros "!> Hf". - iIntros "!>". - rewrite map_filter_insert_not; last set_solver. - rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_empty insert_empty. - wp_pures. - rewrite has_fuels_gt_1; last solve_fuel_positive. - iApply (wp_fork_nostep _ tid _ _ _ ∅ {[ ρOdd ]} {[ρOdd := _]} with "[Hodd_at] [HΦ] [Hf]"); - [ set_solver | by apply insert_non_empty | | | | - rewrite !fmap_insert fmap_empty // ]; [set_solver| |]. - + iIntros (tid') "!> Hf". - rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_empty insert_empty. - rewrite -has_fuel_fuels. - wp_pures. - rewrite -has_fuel_fuels. - replace (Z.of_nat M + 1)%Z with (Z.of_nat (M + 1)) by lia. - iApply (incr_loop_spec with "[Hodd_at $Hf]"); [lia|iFrame "#∗"|]. - by iIntros "!>?". - + iIntros "!> Hf". - rewrite map_filter_insert_not; last set_solver. - rewrite map_filter_empty. - iApply "HΦ". iModIntro. - iDestruct "Hf" as "[Hf _]". - by rewrite dom_empty_L. - - iDestruct "Hauths" as "[Heven Hodd]". - iDestruct (even_agree with "Heven_at Heven") as %<-. - iDestruct (odd_agree with "Hodd_at Hodd") as %<-. - iMod ("Hclose" with "[-Hf Heven_at Hodd_at HΦ]") as "_". - { iIntros "!>". iExists _. iFrame. rewrite Heven. iFrame. } - iIntros "!>". wp_pures. wp_bind (Fork _). - rewrite has_fuels_gt_1; last solve_fuel_positive. - rewrite insert_commute; [|done]. - iApply (wp_fork_nostep _ tid _ _ _ {[ ρEven ]} {[ ρOdd ]} {[ρOdd := _; ρEven := _]} - with "[Hodd_at] [- Hf] [Hf]"); - [ set_solver | by apply insert_non_empty | | | | - rewrite !fmap_insert fmap_empty // ]; [set_solver | |]. - { iIntros (tid') "!> Hf". - rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_insert_not; last set_solver. - rewrite map_filter_empty insert_empty. - rewrite -has_fuel_fuels. - iApply (incr_loop_spec with "[Hodd_at $Hf]"); [lia|iFrame "#∗"|]. - by iIntros "!>?". } - iIntros "!> Hf". - iIntros "!>". - rewrite map_filter_insert_not; last set_solver. - rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_empty insert_empty. - wp_pures. - rewrite has_fuels_gt_1; last solve_fuel_positive. - iApply (wp_fork_nostep _ tid _ _ _ ∅ {[ ρEven ]} {[ρEven := _]} with "[Heven_at] [HΦ] [Hf]"); - [ set_solver | by apply insert_non_empty | | | | - rewrite !fmap_insert fmap_empty // ]; [set_solver| |]. - + iIntros (tid') "!> Hf". - rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_empty insert_empty. - rewrite -has_fuel_fuels. - wp_pures. - rewrite -has_fuel_fuels. - replace (Z.of_nat M + 1)%Z with (Z.of_nat (M + 1)) by lia. - iApply (incr_loop_spec with "[Heven_at $Hf]"); [lia|iFrame "#∗"|]. - by iIntros "!>?". - + iIntros "!> Hf". - rewrite map_filter_insert_not; last set_solver. - rewrite map_filter_empty. - iApply "HΦ". iModIntro. - iDestruct "Hf" as "[Hf _]". - by rewrite dom_empty_L. - Qed. - -End proof_start. diff --git a/fairness/examples/even_odd/even_odd_adequacy.v b/fairness/examples/even_odd/even_odd_adequacy.v deleted file mode 100644 index c6bae3c2..00000000 --- a/fairness/examples/even_odd/even_odd_adequacy.v +++ /dev/null @@ -1,650 +0,0 @@ -From Paco Require Import paco1 paco2 pacotac. -From iris.base_logic.lib Require Import invariants. -From iris.algebra Require Import excl_auth. -From iris.proofmode Require Import tactics. -From trillium.program_logic Require Export weakestpre. -From trillium.fairness Require Import fairness fair_termination fairness_finiteness. -From trillium.prelude Require Export finitary quantifiers sigma classical_instances. -From trillium.fairness.heap_lang Require Export lang lifting tactics. -From trillium.fairness.heap_lang Require Import notation. -From trillium.fairness Require Import trace_utils. -From trillium.fairness.examples.even_odd Require Import even_odd. -From stdpp Require Import finite. - -(** Helper lemmas for working with even and odd *) - -Lemma even_odd_False n : Nat.even n → Nat.odd n → False. -Proof. - intros Heven Hodd. rewrite -Nat.negb_odd in Heven. - apply Is_true_true_1 in Heven. - apply Is_true_true_1 in Hodd. - by rewrite Hodd in Heven. -Qed. - -Lemma even_not_odd n : Nat.even n → ¬ Nat.odd n. -Proof. intros Heven Hodd. by eapply even_odd_False. Qed. - -Lemma odd_not_even n : Nat.odd n → ¬ Nat.even n. -Proof. intros Heven Hodd. by eapply even_odd_False. Qed. - -(** The model is finitely branching *) - -Definition steppable n : list (nat * option EO) := - n' ← [S n; n]; - ℓ ← [Some ρEven; Some ρOdd]; - mret (n', ℓ). - -#[local] Instance proof_irrel_trans s x: - ProofIrrel ((let '(s', ℓ) := x in eotrans s ℓ s'): Prop). -Proof. apply make_proof_irrel. Qed. - -Lemma model_finitary s: - Finite { '(s', ℓ) | eotrans s ℓ s'}. -Proof. - assert (H: forall A (y x: A) xs, (y = x ∨ y ∈ xs) -> y ∈ x::xs) by set_solver. - eapply (in_list_finite (steppable s)). - intros [n w] Htrans. - inversion Htrans; try (repeat (rewrite ?Nat.sub_0_r; simpl; - eapply H; try (by left); right); done). -Qed. - -(** Proof that any fair execution of model visits all natural numbers *) - -Definition evenodd_mtrace : Type := mtrace the_fair_model. - -Definition evenodd_mdl_progress (tr : evenodd_mtrace) := - ∀ i, ∃ n, pred_at tr n (λ s _, s = i). - -Definition evenodd_mdl_mono (tr : evenodd_mtrace) := - ∀ n, ∃ i, pred_at tr n (λ s _, s = i) ∧ - pred_at tr (S n) (λ s _, ∃ j, s = j ∧ i ≤ j). - -Lemma evenodd_mdl_always_live ρ n (mtr : evenodd_mtrace) : - infinite_trace mtr → - pred_at mtr n - (λ (δ : the_fair_model) (_ : option (option (fmrole the_fair_model))), - role_enabled_model ρ δ). -Proof. - intros Hinf. specialize (Hinf n) as [mtr' Hafter]. - rewrite /pred_at Hafter /role_enabled_model. - destruct mtr'; destruct ρ; set_solver. -Qed. - -Lemma evenodd_mdl_always_eventually_scheduled ρ (mtr : evenodd_mtrace) : - infinite_trace mtr → fair_model_trace ρ mtr → - ∀ n, ∃ m, pred_at mtr (n+m) (λ _ ℓ, ℓ = Some (Some ρ)). -Proof. - intros Hinf Hfair n. - apply (evenodd_mdl_always_live ρ n mtr) in Hinf. - specialize (Hfair n Hinf) as [m [Hfair | Hfair]]. - - rewrite /pred_at in Hfair. destruct (after (n + m) mtr); [|done]. - rewrite /role_enabled_model in Hfair. destruct t; destruct ρ; set_solver. - - by exists m. -Qed. - -Lemma evenodd_mdl_noprogress_Even i n (mtr : evenodd_mtrace) : - infinite_trace mtr → mtrace_valid mtr → (trfirst mtr) = i → Nat.even i → - (∀ m, m < n → pred_at mtr m (λ _ l, l ≠ Some (Some ρEven))) → - pred_at mtr n (λ s _, s = i). -Proof. - intros Hinf Hvalid Hfirst Heven Hne. - induction n as [|n IHn]. - { rewrite /pred_at. destruct mtr; done. } - simpl in *. - assert (∀ m : nat, m < n → pred_at mtr m (λ _ l, l ≠ Some (Some ρEven))) as Hne'. - { intros. apply Hne. lia. } - specialize (IHn Hne'). rewrite /pred_at in IHn. - destruct (after n mtr) as [mtr'|] eqn:Hafter; rewrite Hafter in IHn; [|done]. - rewrite /pred_at. replace (S n) with (n + 1) by lia. - rewrite after_sum'. rewrite Hafter. specialize (Hinf (n+1)). - rewrite after_sum' in Hinf. rewrite Hafter in Hinf. - destruct mtr'; [by apply is_Some_None in Hinf|]. - eapply mtrace_valid_after in Hvalid; [|done]. - assert (ℓ ≠ Some ρEven) as Hneq. - { assert (n < S n) by lia. specialize (Hne n H). rewrite /pred_at in Hne. - rewrite Hafter in Hne. intros ->. apply Hne. done. } - pinversion Hvalid. simplify_eq. inversion H1; simplify_eq. - - by apply even_not_odd in Heven. - - by destruct mtr'. -Qed. - -Lemma evenodd_mdl_noprogress_Odd i n (mtr : evenodd_mtrace) : - infinite_trace mtr → mtrace_valid mtr → (trfirst mtr) = i → Nat.odd i → - (∀ m, m < n → pred_at mtr m (λ _ l, l ≠ Some (Some ρOdd))) → - pred_at mtr n (λ s _, s = i). -Proof. - intros Hinf Hvalid Hfirst Hodd Hne. - induction n as [|n IHn]. - { rewrite /pred_at. destruct mtr; done. } - simpl in *. - assert (∀ m : nat, m < n → pred_at mtr m (λ _ l, l ≠ Some (Some ρOdd))) as Hne'. - { intros. apply Hne. lia. } - specialize (IHn Hne'). rewrite /pred_at in IHn. - destruct (after n mtr) as [mtr'|] eqn:Hafter; rewrite Hafter in IHn; [|done]. - rewrite /pred_at. replace (S n) with (n + 1) by lia. - rewrite after_sum'. rewrite Hafter. specialize (Hinf (n+1)). - rewrite after_sum' in Hinf. rewrite Hafter in Hinf. - destruct mtr'; [by apply is_Some_None in Hinf|]. - eapply mtrace_valid_after in Hvalid; [|done]. - assert (ℓ ≠ Some ρOdd) as Hneq. - { assert (n < S n) by lia. specialize (Hne n H). rewrite /pred_at in Hne. - rewrite Hafter in Hne. intros ->. apply Hne. done. } - pinversion Hvalid. simplify_eq. inversion H1; simplify_eq. - - by apply odd_not_even in Hodd. - - by destruct mtr'. -Qed. - -Theorem evenodd_mdl_progresses_Even i (mtr : evenodd_mtrace) : - infinite_trace mtr → mtrace_valid mtr → (∀ ρ, fair_model_trace ρ mtr) → - (trfirst mtr) = i → Nat.even i → - ∃ m, pred_at mtr m (λ s _, s = S i). -Proof. - intros Hinf Hvalid Hfair Hfirst Heven. - specialize (Hfair ρEven). - pose proof (evenodd_mdl_always_eventually_scheduled ρEven mtr Hinf Hfair 0) as Hsched. - simpl in *. apply trace_eventually_until in Hsched as [m [Hsched Hschedne]]. - rewrite /pred_at in Hsched. - destruct (after m mtr) as [mtr'|] eqn:Hafter; last first. - { rewrite Hafter in Hsched. done. } - rewrite Hafter in Hsched. - destruct mtr'; [done|]. - simplify_eq. - assert (s = trfirst mtr) as ->. - { eapply evenodd_mdl_noprogress_Even in Hschedne; [|done..]. - rewrite /pred_at in Hschedne. rewrite Hafter in Hschedne. done. } - eapply mtrace_valid_after in Hvalid; [|done]. - pinversion Hvalid; simplify_eq. inversion H1; simplify_eq. - - exists (m + 1). - rewrite /pred_at. rewrite !after_sum'. rewrite Hafter. simpl. - destruct mtr'; simpl in *; simplify_eq; done. - - by apply even_not_odd in Heven. -Qed. - -Theorem evenodd_mdl_progresses_Odd i (mtr : evenodd_mtrace) : - infinite_trace mtr → mtrace_valid mtr → (∀ ρ, fair_model_trace ρ mtr) → - (trfirst mtr) = i → Nat.odd i → - ∃ m, pred_at mtr m (λ s _, s = S i). -Proof. - intros Hinf Hvalid Hfair Hfirst Hodd. - specialize (Hfair ρOdd). - pose proof (evenodd_mdl_always_eventually_scheduled ρOdd mtr Hinf Hfair 0) as Hsched. - simpl in *. apply trace_eventually_until in Hsched as [m [Hsched Hschedne]]. - rewrite /pred_at in Hsched. - destruct (after m mtr) as [mtr'|] eqn:Hafter; last first. - { rewrite Hafter in Hsched. done. } - rewrite Hafter in Hsched. - destruct mtr'; [done|]. - simplify_eq. - assert (s = trfirst mtr) as ->. - { eapply evenodd_mdl_noprogress_Odd in Hschedne; [|done..]. - rewrite /pred_at in Hschedne. rewrite Hafter in Hschedne. done. } - eapply mtrace_valid_after in Hvalid; [|done]. - pinversion Hvalid; simplify_eq. inversion H1; simplify_eq. - - exists (m + 1). - rewrite /pred_at. rewrite !after_sum'. rewrite Hafter. simpl. - destruct mtr'; simpl in *; simplify_eq; done. - - by apply odd_not_even in Hodd. -Qed. - -Theorem evenodd_mdl_progresses (mtr : evenodd_mtrace) : - infinite_trace mtr → mtrace_valid mtr → (∀ ρ, fair_model_trace ρ mtr) → - (trfirst mtr) = 0 → - evenodd_mdl_progress mtr. -Proof. - intros Hinf Hvalid Hfair Hfirst i. - induction i as [|i IHi]. - { exists 0. rewrite /pred_at. rewrite /trfirst in Hfirst. simpl. - destruct mtr; done. } - destruct IHi as [n Hpred]. - rewrite /pred_at in Hpred. - destruct (after n mtr) as [mtr'|] eqn:Hafter; [|done]. - eapply infinite_trace_after'' in Hinf; [|done]. - eapply mtrace_valid_after in Hvalid; [|done]. - destruct (Nat.even i) eqn:Heqn. - - assert (∀ ρ : fmrole the_fair_model, fair_model_trace ρ mtr') as Hfair'. - { intros. by eapply fair_model_trace_after. } - assert (trfirst mtr' = i) as Hfirst'. - { rewrite /trfirst. destruct mtr'; done. } - pose proof (evenodd_mdl_progresses_Even i mtr' Hinf Hvalid Hfair' Hfirst') - as [m Hpred']; [by eauto|]. - exists (n + m). - rewrite pred_at_sum. rewrite Hafter. done. - - assert (∀ ρ : fmrole the_fair_model, fair_model_trace ρ mtr') as Hfair'. - { intros. by eapply fair_model_trace_after. } - assert (trfirst mtr' = i) as Hfirst'. - { rewrite /trfirst. destruct mtr'; done. } - pose proof (evenodd_mdl_progresses_Odd i mtr' Hinf Hvalid Hfair' Hfirst') - as [m Hpred']; [by rewrite -Nat.negb_even Heqn|]. - exists (n + m). - rewrite pred_at_sum. rewrite Hafter. done. -Qed. - -Theorem evenodd_mdl_is_mono (mtr : evenodd_mtrace) : - infinite_trace mtr → mtrace_valid mtr → (∀ ρ, fair_model_trace ρ mtr) → - (trfirst mtr) = 0 → - evenodd_mdl_mono mtr. -Proof. - intros Hinf Hvalid Hfair Hfirst n. - pose proof (Hinf n) as [mtr' Hafter]. - destruct mtr' as [|s l mtr']. - { pose proof (Hinf (S n)) as [mtr'' Hafter']. - replace (S n) with (n + 1) in Hafter' by lia. - rewrite after_sum' in Hafter'. rewrite Hafter in Hafter'. done. } - exists s. - rewrite /pred_at. rewrite Hafter. - split; [done|]. - replace (S n) with (n + 1) by lia. - rewrite after_sum'. rewrite Hafter. simpl. - eapply mtrace_valid_after in Hvalid; [|done]. - punfold Hvalid. inversion Hvalid as [|??? Htrans]. simplify_eq. - inversion Htrans; simplify_eq. - - destruct mtr'. - + exists (S s); split; [done|lia]. - + exists (S s); split; [done|lia]. - - destruct mtr'. - + exists s; done. - + exists s; done. - - destruct mtr'. - + exists (S s); split; [done|lia]. - + exists (S s); split; [done|lia]. - - destruct mtr'. - + exists s; done. - + exists s; done. -Qed. - -(** Proof that fair progress is preserved through auxiliary trace *) - -Definition evenodd_aux_progress (auxtr : auxtrace the_model) := - ∀ i, ∃ n, pred_at auxtr n (λ s l, (λ s' _, s' = i) (ls_under s) (l ≫= Ul)). - -Lemma evenodd_mtr_aux_progress_preserved - (mtr : mtrace the_fair_model) - (auxtr : auxtrace the_model) : - upto_stutter ls_under Ul auxtr mtr → - evenodd_mdl_progress mtr → evenodd_aux_progress auxtr. -Proof. - intros Hstutter Hmtr n. specialize (Hmtr n). - by apply (trace_eventually_stutter_preserves - ls_under Ul auxtr mtr (λ s' _, s' = n)). -Qed. - -Definition evenodd_aux_mono (auxtr : auxtrace the_model) := - ∀ n, ∃ i, pred_at auxtr n (λ s l, (λ s' _, s' = i) (ls_under s) (l ≫= Ul)) ∧ - pred_at auxtr (S n) (λ s l, (λ s' _, ∃ j, s' = j ∧ i ≤ j) (ls_under s) (l ≫= Ul)). - -Lemma evenodd_mtr_aux_mono_preserved (mtr : mtrace the_fair_model) - (auxtr : auxtrace the_model) : - upto_stutter ls_under Ul auxtr mtr → - evenodd_mdl_mono mtr → evenodd_aux_mono auxtr. -Proof. - intros Hstutter Hmtr n. - revert auxtr mtr Hstutter Hmtr. - induction n as [|n IHn]; intros auxtr mtr Hstutter Hmtr. - { punfold Hstutter; [|apply upto_stutter_mono]. - induction Hstutter as - [|auxtr mtr s ℓ Hℓ Hauxtr_first Hmtr_first CIHstutter IHstutter| - auxtr mtr s ℓ δ ρ Hs Hℓ CIHstutter]. - - by destruct (Hmtr 0) as [? [? Hmtr']]. - - simplify_eq. - destruct (IHstutter Hmtr) as [i [Hpred ?]]. - rewrite /pred_at in Hpred. simpl in *. - exists i. rewrite /pred_at. simpl. - destruct auxtr as [|s' ℓ' auxtr']; [done|]. - rewrite /trfirst in Hauxtr_first. split; [by simplify_eq|]. - exists i. simplify_eq. lia. - - simplify_eq. - destruct (Hmtr 0) as [i [Hpred1 Hpred2]]. - rewrite /pred_at in Hpred1. simpl in *. - exists i. - rewrite /pred_at. split; [done|]. - rewrite /pred_at in Hpred2. simpl in *. - destruct CIHstutter as [CIHstutter|?]; [|done]. - punfold CIHstutter; [|apply upto_stutter_mono]. - induction CIHstutter as - [|mtr auxtr ??? Hauxtr_first Hmtr_first ? IHstutter|]; - [done| |by simplify_eq]. - specialize (IHstutter Hmtr Hpred2). - destruct mtr. - * destruct IHstutter as [j [Hj1 Hj2]]. exists j. by simplify_eq. - * destruct IHstutter as [j [Hj1 Hj2]]. exists j. by simplify_eq. } - punfold Hstutter; [|apply upto_stutter_mono]. - induction Hstutter as - [|auxtr mtr s ℓ Hℓ Hauxtr_first Hmtr_first CIHstutter IHstutter| - auxtr mtr s ℓ δ ρ Hs Hℓ CIHstutter]. - + by destruct (Hmtr 0) as [? [? Hmtr']]. - + simplify_eq. setoid_rewrite pred_at_S. eapply IHn; [by apply paco2_fold|done]. - + simplify_eq. destruct CIHstutter as [CIHstutter|?]; [|done]. - assert (evenodd_mdl_mono mtr) as Hmtr'. - { intros m. specialize (Hmtr (S m)). by setoid_rewrite pred_at_S in Hmtr. } - destruct (IHn auxtr mtr CIHstutter Hmtr') as [i [Hpred1 Hpred2]]. - exists i. by rewrite !pred_at_S. -Qed. - -(** Proof that progress is preserved between auxilary and execution trace, - for a specific ξ *) - -Definition evenodd_ex_progress (l:loc) (extr : heap_lang_extrace) := - ∀ (i:nat), ∃ n, pred_at extr n (λ s _, heap s.2 !! l = Some #i). - -Definition evenodd_ex_mono (l:loc) (extr : heap_lang_extrace) := - ∀ n, ∃ (i:nat), - pred_at extr n (λ s _, heap s.2 !! l = Some #i) ∧ - pred_at extr (S n) (λ s _, ∃ (j:nat), heap s.2 !! l = Some #j ∧ i ≤ j). - -Definition ξ_evenodd_model_match (l : loc) (c : cfg heap_lang) (δ : the_fair_model) := - ∃ (N:nat), heap c.2 !! l = Some #N ∧ δ = N. - -Definition ξ_evenodd_no_val_steps (c : cfg heap_lang) := - (Forall (λ e, is_Some $ to_val e) c.1 → False) ∧ - Forall (λ e, not_stuck e c.2) c.1. - -Definition ξ_evenodd (l : loc) (c : cfg heap_lang) (δ : the_fair_model) := - ξ_evenodd_no_val_steps c ∧ ξ_evenodd_model_match l c δ. - -Definition ξ_evenodd_trace (l : loc) (extr : execution_trace heap_lang) - (auxtr : finite_trace the_fair_model (option EO)) := - ξ_evenodd l (trace_last extr) (trace_last auxtr). - -(* TODO: This could be simplified to use [ξ_evenodd_model_match] *) -Lemma evenodd_aux_ex_progress_preserved l (extr : heap_lang_extrace) (auxtr : auxtrace the_model) : - traces_match labels_match (λ c (δ:the_model), ξ_evenodd l c δ) locale_step - (lm_ls_trans the_model) extr auxtr → - evenodd_aux_progress auxtr → evenodd_ex_progress l extr. -Proof. - intros Hξ Hauxtr n. specialize (Hauxtr n). - rewrite /pred_at in Hauxtr. destruct Hauxtr as [m Hauxtr]. - destruct (after m auxtr) as [auxtr'|] eqn:Heqn; [|done]. - eapply traces_match_after in Hξ as [extr' [Hafter' Hextr']]; [|done]. - exists m. rewrite /pred_at. rewrite Hafter'. - inversion Hextr' as [?? Hξ|??????? Hξ]; simplify_eq. - - destruct Hξ as (?&n&?&?). by simplify_eq. - - destruct Hξ as (?&n&?&?). by simplify_eq. -Qed. - -Lemma evenodd_aux_ex_mono_preserved l (extr : heap_lang_extrace) (auxtr : auxtrace the_model) : - traces_match labels_match (λ c (δ:the_model), ξ_evenodd l c δ) locale_step - (lm_ls_trans the_model) extr auxtr → - evenodd_aux_mono auxtr → evenodd_ex_mono l extr. -Proof. - intros Hξ Hauxtr n. specialize (Hauxtr n). - destruct Hauxtr as [i Hauxtr]. - exists i. - split. - - destruct Hauxtr as [Hauxtr _]. - rewrite /pred_at in Hauxtr. - destruct (after n auxtr) as [auxtr'|] eqn:Heqn; [|done]. - eapply traces_match_after in Hξ as [extr' [Hafter' Hextr']]; [|done]. - rewrite /pred_at. rewrite Hafter'. - inversion Hextr' as [?? Hξ|??????? Hξ]; simplify_eq. - + destruct Hξ as (?&i&?&?). by simplify_eq. - + destruct Hξ as (?&i&?&?). by simplify_eq. - - destruct Hauxtr as [_ Hauxtr]. - rewrite /pred_at in Hauxtr. - destruct (after (S n) auxtr) as [auxtr'|] eqn:Heqn; [|done]. - eapply traces_match_after in Hξ as [extr' [Hafter' Hextr']]; [|done]. - rewrite /pred_at. rewrite Hafter'. - inversion Hextr' as [?? Hξ|??????? Hξ]; simplify_eq. - + destruct Hauxtr as [j [<- Hle]]. - destruct Hξ as (?&j&?&?). exists j. by simplify_eq. - + destruct Hauxtr as [j [<- Hle]]. - destruct Hξ as (?&j&?&?). exists j. by simplify_eq. -Qed. - -Instance the_model_mstate_countable : EqDecision (mstate the_model). -Proof. intros x y. apply make_decision. Qed. -Instance the_model_mlabel_countable : EqDecision (mlabel the_model). -Proof. solve_decision. Qed. - -(** Proof that program refines model up to ξ_evenodd *) - -Lemma evenodd_sim l : - continued_simulation - (sim_rel_with_user the_model (ξ_evenodd_trace l)) - (trace_singleton ([start #l], {| heap := {[l:=#0]}; used_proph_id := ∅ |})) - (trace_singleton (initial_ls (LM := the_model) 0 0)). -Proof. - assert (evenoddPreG evenoddΣ) as HPreG'. - { apply _. } - assert (heapGpreS evenoddΣ the_model) as HPreG. - { apply _. } - eapply (strong_simulation_adequacy - evenoddΣ _ NotStuck _ _ _ ∅); [|set_solver|]. - { eapply rel_finitary_sim_rel_with_user_sim_rel. - eapply valid_state_evolution_finitary_fairness_simple. - intros ?. simpl. apply (model_finitary s1). } - iIntros (?) "!> Hσ Hs Hr Hf". - iMod (own_alloc (●E 0 ⋅ ◯E 0))%nat as (γ_even_at) "[Heven_at_auth Heven_at]". - { apply auth_both_valid_2; eauto. by compute. } - iMod (own_alloc (●E 1 ⋅ ◯E 1))%nat as (γ_odd_at) "[Hodd_at_auth Hodd_at]". - { apply auth_both_valid_2; eauto. by compute. } - pose (the_names := {| - even_name := γ_even_at; - odd_name := γ_odd_at; - |}). - iMod (inv_alloc (nroot .@ "even_odd") _ (evenodd_inv_inner l) with "[Hσ Hs Hr Heven_at_auth Hodd_at_auth]") as "#Hinv". - { iNext. unfold evenodd_inv_inner. iExists 0. - replace (∅ ∖ live_roles the_fair_model 0) with - (∅:gset (fmrole the_fair_model)) by set_solver. - rewrite /eo_live_roles big_sepM_singleton. by iFrame. } - iModIntro. - iSplitL. - { simpl. rewrite /eo_live_roles. - replace (gset_to_gmap 61 {[ρOdd; ρEven]}) with - ({[ρEven := 61; ρOdd := 61]} : gmap _ _); last first. - { rewrite /gset_to_gmap. simpl. - rewrite !map_fmap_union. rewrite !map_fmap_singleton. - rewrite map_union_comm; last first. - { rewrite map_disjoint_singleton_l. - by rewrite lookup_insert_ne. } - by rewrite -!insert_union_l left_id. } - iApply (start_spec with "[$Hf $Heven_at $Hodd_at $Hinv]"); [lia|]. - by iIntros "!>?". } - iIntros (extr auxtr c) "_ _ _ %Hends _ %Hnstuck [_ [Hσ Hδ]] Hposts". - iInv "Hinv" as (M) "(>HFR & >Hmod & >Hn & _)" "Hclose". - iApply fupd_mask_intro; [set_solver|]. - iIntros "Hclose'". - iDestruct (gen_heap_valid with "Hσ Hn") as %Hn. - iDestruct (model_state_interp_tids_smaller with "Hδ") as %Hsmaller. - iDestruct "Hδ" as (Mζ ?) "(Hf&HM&HFR_auth&%Hinverse&%Hlocales&Hδ&%Hdom)". - iDestruct (model_agree with "Hδ Hmod") as %Hn'. - iSplitL; last first. - { iPureIntro. exists M. split; [done|]. rewrite -Hn'. by destruct auxtr. } - rewrite /trace_ends_in in Hends. - rewrite Hends. - iSplit. - - iIntros "%Hall". - rewrite !big_sepL_omap !big_sepL_zip_with=> /=. - iAssert ([∗ list] k↦x ∈ c.1, k ↦M ∅)%I with "[Hposts]" as "Hposts". - { destruct c as [es σ]=> /=. - iApply (big_sepL_impl with "Hposts"). - iIntros "!>" (k x HSome) "Hk". - assert (is_Some (to_val x)) as [v Hv]. - { by eapply (Forall_lookup_1 (λ e : expr, is_Some (to_val e))). } - rewrite Hv. destruct k; [done|]. destruct es; [done|]. - simpl in *. rewrite drop_0. rewrite list_lookup_fmap. - erewrite prefixes_from_lookup; [|done]. - simpl. rewrite /locale_of. rewrite take_length. - assert (k < length es). - { apply lookup_lt_is_Some_1. by eauto. } - by replace (k `min` length es) with k by lia. } - iAssert (⌜∀ i, i < length c.1 → Mζ !! i = Some ∅⌝)%I as "%HMζ". - { iIntros (i Hlen). - assert (is_Some $ c.1 !! i) as [e HSome]. - { by apply lookup_lt_is_Some_2. } - iDestruct (big_sepL_delete with "Hposts") as "[Hpost _]"; [done|]. - by iDestruct (frag_mapping_same with "HM Hpost") as "?". } - assert (dom Mζ = list_to_set $ locales_of_list c.1). - { rewrite Hends in Hlocales. apply set_eq. - intros x. rewrite elem_of_dom. - rewrite elem_of_list_to_set. - split. - - intros HSome. - destruct (decide (x ∈ locales_of_list c.1)) as [|Hnin]; [done|]. - apply Hlocales in Hnin. - destruct HSome as [??]. simplify_eq. - - intros Hin. exists ∅. apply HMζ. - rewrite locales_of_list_indexes in Hin. - rewrite /indexes in Hin. - apply elem_of_lookup_imap_1 in Hin as (i&?&->&HSome). - by apply lookup_lt_is_Some_1. } - assert (ls_mapping (trace_last auxtr) = ∅) as Hmapping. - { apply map_eq. intros i. rewrite lookup_empty. - destruct (ls_mapping (trace_last auxtr) !! i) as [ζ|] eqn:Heqn; [|done]. - pose proof Heqn as [e He]%Hsmaller. - assert (Mζ !! ζ = Some ∅) as Hζ. - { apply HMζ. - apply from_locale_lookup in He. - rewrite Hends in He. - by apply lookup_lt_is_Some_1. } - eapply (no_locale_empty _ _ i) in Hζ; [|done]. - by simplify_eq. } - assert (live_roles _ M = ∅) as Hlive. - { cut (live_roles the_fair_model M ⊆ ∅); [by set_solver|]. - etrans. - - eapply (ls_mapping_dom (M:=the_fair_model)). - - erewrite Hmapping. done. } - rewrite /live_roles in Hlive. simpl in *. - rewrite /eo_live_roles in Hlive. set_solver. - - iPureIntro. - apply Forall_forall. - intros e He. by apply Hnstuck. -Qed. - -CoInductive extrace_maximal {Λ} : extrace Λ → Prop := -| extrace_maximal_singleton c : - (∀ oζ c', ¬ locale_step c oζ c') → extrace_maximal ⟨c⟩ -| extrace_maximal_cons c oζ tr : - locale_step c oζ (trfirst tr) -> - extrace_maximal tr → - extrace_maximal (c -[oζ]-> tr). - -Lemma extrace_maximal_valid {Λ} (extr : extrace Λ) : - extrace_maximal extr → extrace_valid extr. -Proof. - revert extr. cofix IH. intros extr Hmaximal. inversion Hmaximal. - - constructor 1. - - constructor 2; [done|by apply IH]. -Qed. - -Lemma extrace_maximal_after {Λ} n (extr extr' : extrace Λ) : - extrace_maximal extr → after n extr = Some extr' → extrace_maximal extr'. -Proof. - revert extr extr'. induction n; intros extr extr' Hafter Hvalid. - { destruct extr'; simpl in *; by simplify_eq. } - simpl in *. destruct extr; [done|]. eapply IHn; [|done]. by inversion Hafter. -Qed. - -Lemma infinite_trace_no_val_steps extr auxtr : - extrace_maximal extr → - traces_match - (labels_match (LM:=the_model)) - (λ c _ , ξ_evenodd_no_val_steps c) locale_step - (lm_ls_trans the_model) extr auxtr → - infinite_trace extr. -Proof. - intros Hmaximal Hmatch. - intros n. induction n as [|n IHn]; [done|]. - destruct IHn as [extr' Hafter]. - apply traces_match_flip in Hmatch. - eapply traces_match_after in Hmatch; [|done]. - destruct Hmatch as [auxtr' [Hafter' Hmatch]]. - replace (S n) with (n + 1) by lia. - rewrite after_sum'. - rewrite Hafter. - apply traces_match_first in Hmatch. - destruct Hmatch as [Hξ1 Hξ2]. - eapply extrace_maximal_after in Hmaximal; [|done]. - inversion Hmaximal as [? Hnstep|]; simplify_eq; [|done]. - assert (∃ oζ c', locale_step c oζ c') as Hstep; last first. - { exfalso. destruct Hstep as (?&?&Hstep). by eapply Hnstep. } - apply not_Forall_Exists in Hξ1; [|apply _]. - apply Exists_exists in Hξ1 as [e [Hξ11 Hξ12]]. - rewrite Forall_forall in Hξ2. - specialize (Hξ2 e Hξ11) as [|Hred]; [done|]. - destruct Hred as (e' & σ' & es' & Hred). - apply elem_of_list_split in Hξ11 as (es1&es2&Hes). - destruct c; simpl in *. - eexists (Some _), _. - econstructor; eauto. simpl in *. - by f_equiv. -Qed. - -(** Proof that the execution trace satisfies the liveness properties *) -Theorem evenodd_ex_liveness (l:loc) (extr : heap_lang_extrace) : - extrace_maximal extr → - (∀ tid, fair_ex tid extr) → - trfirst extr = ([start #l], {| heap := {[l:=#0]}; used_proph_id := ∅ |}) → - evenodd_ex_progress l extr ∧ evenodd_ex_mono l extr. -Proof. - intros Hmaximal Hfair Hfirst. - pose proof Hmaximal as Hvalid%extrace_maximal_valid. - pose proof (evenodd_sim l) as Hsim. - assert (∃ iatr, - valid_inf_system_trace - (continued_simulation (sim_rel_with_user the_model (ξ_evenodd_trace l))) - (trace_singleton (trfirst extr)) - (trace_singleton (initial_ls (LM:=the_model) 0 0)) - (from_trace extr) - iatr) as [iatr Hiatr]. - { eexists _. eapply produced_inf_aux_trace_valid_inf. econstructor. - Unshelve. - - rewrite Hfirst. done. - - eapply from_trace_preserves_validity; eauto; first econstructor. } - assert (∃ (auxtr : auxtrace the_model), - traces_match labels_match - (live_tids /2\ (ξ_evenodd l)) - locale_step - the_model.(lm_ls_trans) extr auxtr) as [auxtr Hmatch_strong]. - { exists (to_trace (initial_ls (LM := the_model) 0 0 ) iatr). - eapply (valid_inf_system_trace_implies_traces_match_strong - (continued_simulation (sim_rel_with_user the_model (ξ_evenodd_trace l)))); eauto. - - intros ? ? Hξ%continued_simulation_rel. by destruct Hξ as [[_ Hξ] _]. - - intros ? ? Hξ%continued_simulation_rel. by destruct Hξ as [[Hξ _] _]. - - intros extr' auxtr' Hξ%continued_simulation_rel. - destruct Hξ as [_ [Hξ1 Hξ2]]. - split; [done|]. - destruct Hξ2 as [n [Hξ21 Hξ22]]. - exists n. split; [done|]. by destruct auxtr'. - - by apply from_trace_spec. - - by apply to_trace_spec. } - assert (exaux_traces_match extr auxtr) as Hmatch. - { eapply traces_match_impl; [done| |done]. by intros ??[??]. } - assert (auxtrace_valid auxtr) as Hstutter. - { by eapply exaux_preserves_validity. } - apply can_destutter_auxtr in Hstutter. - destruct Hstutter as [mtr Hupto]. - assert (infinite_trace extr) as Hinf. - { eapply infinite_trace_no_val_steps; [done|]. - eapply traces_match_impl; [done| |apply Hmatch_strong]. - by intros s1 s2 [_ [? _]]. } - pose proof (fairness_preserved extr auxtr Hinf Hmatch Hfair) as Hfairaux. - have Hvalaux := exaux_preserves_validity extr auxtr Hmatch. - have Hfairm := upto_stutter_fairness auxtr mtr Hupto Hfairaux. - have Hmtrvalid := upto_preserves_validity auxtr mtr Hupto Hvalaux. - pose proof (fairness_preserved extr auxtr Hinf Hmatch Hfair) as Hfair'. - pose proof (upto_stutter_fairness auxtr mtr Hupto Hfair') as Hfair''. - assert (infinite_trace mtr) as Hinf''. - { eapply upto_stutter_infinite_trace; [done|]. - by eapply traces_match_infinite_trace. } - assert (mtrace_valid mtr) as Hvalid''. - { eapply upto_preserves_validity; [done|]. - by eapply exaux_preserves_validity. } - assert (trfirst mtr = 0) as Hfirst''. - { apply traces_match_first in Hmatch_strong. - destruct Hmatch_strong as [_ [_ [n [Hσ Hmdl]]]]. - rewrite Hfirst in Hσ. simpl in *. rewrite lookup_insert in Hσ. - simplify_eq. punfold Hupto; [|by apply upto_stutter_mono']. - assert (0 = ls_under (trfirst auxtr)) as Hσ' by lia. - inversion Hupto; simplify_eq; - by rewrite Hσ'. } - split. - - pose proof (evenodd_mdl_progresses mtr Hinf'' Hvalid'' Hfair'' Hfirst'') - as Hprogress. - eapply (evenodd_aux_ex_progress_preserved l _ auxtr). - { eapply traces_match_impl; [done| |apply Hmatch_strong]. by intros ??[??]. } - by eapply evenodd_mtr_aux_progress_preserved. - - pose proof (evenodd_mdl_is_mono mtr Hinf'' Hvalid'' Hfair'' Hfirst'') - as Hmono. - eapply (evenodd_aux_ex_mono_preserved l _ auxtr). - { eapply traces_match_impl; [done| |apply Hmatch_strong]. by intros ??[??]. } by eapply evenodd_mtr_aux_mono_preserved. -Qed. diff --git a/fairness/examples/yesno/yesno.v b/fairness/examples/yesno/yesno.v deleted file mode 100644 index 376587f2..00000000 --- a/fairness/examples/yesno/yesno.v +++ /dev/null @@ -1,614 +0,0 @@ -From iris.proofmode Require Import tactics. -From trillium.program_logic Require Export weakestpre. -From trillium.fairness Require Import fairness fair_termination. -From trillium.prelude Require Export finitary quantifiers sigma classical_instances. - -Require Import stdpp.decidable. -From trillium.fairness.heap_lang Require Export lang lifting tactics proofmode. -From trillium.fairness.heap_lang Require Import notation. -From iris.base_logic.lib Require Import invariants. -From iris.prelude Require Import options. -From iris.algebra Require Import excl_auth. -From iris.bi Require Import bi. - -Import derived_laws_later.bi. - -Set Default Proof Using "Type". - -Definition yes_go : val := - rec: "yes_go" "n" "b" := - (if: CAS "b" #true #false - then "n" <- !"n" - #1 - else #());; - if: #0 < !"n" - then "yes_go" "n" "b" - else #(). - -Definition yes : val := - λ: "N" "b", - let: "n" := Alloc "N" in - yes_go "n" "b". - -Definition no_go : val := - rec: "no_go" "n" "b" := - (if: CAS "b" #false #true - then "n" <- !"n" - #1 - else #());; - if: #0 < !"n" - then "no_go" "n" "b" - else #(). - -Definition no : val := - λ: "N" "b", - let: "n" := Alloc "N" in - no_go "n" "b". - -Definition start : val := - λ: "N", - let: "b" := Alloc #true in - (Fork (yes "N" "b") ;; - Fork (no "N" "b")). - -(** * Definition of the model! *) - -Inductive YN := Y | No. - -#[global] Instance YN_eqdec: EqDecision YN. -Proof. solve_decision. Qed. - -#[global] Instance YN_countable: Countable YN. -Proof. - refine ({| - encode yn := match yn with Y => 1 | No => 2 end; - decode p := match p with 1 => Some Y | 2 => Some No | _ => None end; - |})%positive. - intros yn. by destruct yn. -Qed. - -#[global] Instance YN_inhabited: Inhabited YN. -Proof. exact (populate Y). Qed. - -Inductive yntrans: nat*bool -> option YN -> nat*bool -> Prop := -| yes_trans n: (n > 0)%nat -> yntrans (n, true) (Some Y) (n, false) (* < *) -| yes_fail n: (n > 1)%nat -> yntrans (n, false) (Some Y) (n, false) (* ≤ *) -| no_trans n: yntrans (S n, false) (Some No) (n, true) (* < *) -| no_fail n: (n > 0)%nat → yntrans (n, true) (Some No) (n, true) (* ≤ *) -. - -Definition yn_live_roles nb : gset YN := - match nb with - | (0, _) => ∅ - | (1, false) => {[ No ]} - | _ => {[ No; Y ]} - end. - -Lemma live_spec_holds: - forall s ρ s', yntrans s (Some ρ) s' -> ρ ∈ yn_live_roles s. -Proof. - intros [n b] yn [n' ?] Htrans. rewrite /yn_live_roles. - inversion Htrans; simplify_eq; destruct n'; try set_solver; try lia; destruct n'; try set_solver; lia. -Qed. - -Definition the_fair_model: FairModel. -Proof. - refine({| - fmstate := nat * bool; - fmrole := YN; - fmtrans := yntrans; - live_roles nb := yn_live_roles nb; - fm_live_spec := live_spec_holds; - |}). -Defined. - -Definition the_model: LiveModel heap_lang the_fair_model := - {| - lm_fl (x: fmstate the_fair_model) := 61%nat; - |}. - -(** The CMRAs we need. *) -Class yesnoG Σ := YesnoG { - yes_name: gname; - no_name: gname; - yesno_n_G :> inG Σ (excl_authR natO); - yesno_f_G :> inG Σ (excl_authR boolO); - }. -Class yesnoPreG Σ := { - yesno_PreG :> inG Σ (excl_authR natO); - yesno_f_PreG :> inG Σ (excl_authR boolO); - }. -Definition yesnoΣ : gFunctors := - #[ heapΣ the_fair_model; GFunctor (excl_authR natO) ; GFunctor (excl_authR boolO) ]. - -Global Instance subG_yesnoΣ {Σ} : subG yesnoΣ Σ → yesnoPreG Σ. -Proof. solve_inG. Qed. - -Section proof. - Context `{!heapGS Σ the_model, !yesnoG Σ}. - Let Ns := nroot .@ "yes_no". - - Definition yes_at (n: nat) := own yes_name (◯E n). - Definition no_at (n: nat) := own no_name (◯E n). - - Definition auth_yes_at (n: nat) := own yes_name (●E n). - Definition auth_no_at (n: nat) := own no_name (●E n). - - Lemma they_agree γ (N M: nat): - own γ (◯E N) -∗ own γ (●E M) -∗ ⌜ M = N ⌝. - Proof. - iIntros "HA HB". iCombine "HB HA" as "H". - iDestruct (own_valid with "H") as "%Hval". - iPureIntro. by apply excl_auth_agree_L. - Qed. - Lemma yes_agree N M: - yes_at N -∗ auth_yes_at M -∗ ⌜ M = N ⌝. - Proof. apply they_agree. Qed. - Lemma no_agree N M: - no_at N -∗ auth_no_at M -∗ ⌜ M = N ⌝. - Proof. apply they_agree. Qed. - - Lemma they_update γ (N M P: nat): - own γ (●E N) ∗ own γ (◯E M) ==∗ own γ (●E P) ∗ own γ (◯E P). - Proof. - rewrite -!own_op. iApply own_update. apply excl_auth_update. - Qed. - Lemma yes_update P N M: - auth_yes_at M ∗ yes_at N ==∗ auth_yes_at P ∗ yes_at P. - Proof. apply they_update. Qed. - Lemma no_update P N M: - auth_no_at M ∗ no_at N ==∗ auth_no_at P ∗ no_at P. - Proof. apply they_update. Qed. - - Lemma they_finished_update γ (N M P: bool): - own γ (●E N) ∗ own γ (◯E M) ==∗ own γ (●E P) ∗ own γ (◯E P). - Proof. - rewrite -!own_op. iApply own_update. apply excl_auth_update. - Qed. - - Definition yesno_inv_inner b := - (∃ N B, - frag_free_roles_are ∅ ∗ - frag_model_is (N, B) ∗ b ↦ #B ∗ - (if B - then auth_yes_at N ∗ auth_no_at N - else auth_yes_at (N-1) ∗ auth_no_at N) ∗ - ⌜(N, B) ≠ (0, false)⌝ - )%I. - Definition yesno_inv b := inv Ns (yesno_inv_inner b). - - Lemma yes_go_spec tid n b (N: nat) f (Hf: f > 40): - {{{ yesno_inv b ∗ has_fuel tid Y f ∗ n ↦ #N ∗ ⌜N > 0⌝%nat ∗ yes_at N }}} - yes_go #n #b @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iLöb as "Hg" forall (N f Hf). - - iIntros (Φ) "(#Hinv & Hf & HnN & %HN & Hyes) Hk". unfold yes_go. - - wp_pures. - wp_bind (CmpXchg _ _ _). - - assert (∀ s, Atomic s (CmpXchg #b #true #false)) by apply _. - - iApply wp_atomic. - - iInv Ns as (M B) "(>HFR & >Hmod & >Bb & Hauths & >%Hnever)" "Hclose". - destruct B; iDestruct "Hauths" as "[>Hay >Han]". - - iDestruct (yes_agree with "Hyes Hay") as "%Heq". - - (* TODO *) - rewrite -has_fuel_fuels. - - destruct (decide (M = 0)) as [->|Nneq]; first lia. - destruct (decide (M = 1)) as [->|Nneq1]. - + iApply (wp_cmpxchg_suc_step_singlerole_keep_dead _ tid (Y: fmrole the_fair_model) _ 30%nat _ - (1, true) (1, false) - with "[$]") =>//. - { set_solver. } - { lia. } - { econstructor. lia. } - { set_solver. } - iModIntro. - iIntros "!> (Hb & Hmod & HFR & Hf)". - iMod (yes_update 0 with "[$]") as "[Hay Hyes]". - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. iExists _, _. iFrame. simpl. iFrame. by iPureIntro. } - - iModIntro. - - rewrite has_fuel_fuels. - wp_pures. - wp_load. - wp_pures. - wp_store. - wp_pures. - wp_load. - - wp_pure _. - simplify_eq. simpl. - - iApply wp_atomic. - - iInv Ns as (M B) "(>HFR & >Hmod & >Hb & Hauths & >%Hbever')" "Hclose". - - destruct B. - * iApply (wp_lift_pure_step_no_fork_remove_role {[ Y ]} ((0, true): fmstate the_fair_model) _ _ _ _ _ _ {[ Y := _ ]}) =>//. - { apply map_non_empty_singleton. } - { rewrite dom_singleton. set_solver. } - { simpl. set_solver. } - - repeat iModIntro. - - iDestruct "Hauths" as "[Hay Han]". iDestruct (yes_agree with "Hyes Hay") as %Heq. - assert (M = 0) by lia. simplify_eq. iFrame "Hmod". iSplitL "Hf". - { rewrite /has_fuels_S fmap_insert fmap_empty //. } - iIntros "Hmod Hf". - - wp_pures. repeat iModIntro. - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. done. } - iModIntro. iApply "Hk". - rewrite map_filter_singleton_False; last set_solver. rewrite /has_fuels dom_empty_L. - iDestruct "Hf" as "[??]". iFrame. - * iDestruct "Hauths" as "[>Hay >Han]". iDestruct (yes_agree with "Hyes Hay") as %Heq. - assert (M = 1) by (destruct M; [done|lia]). simplify_eq. - - iApply (wp_lift_pure_step_no_fork_remove_role {[ Y ]} ((1, false): fmstate the_fair_model) _ _ _ _ _ _ {[ Y := _ ]}) =>//. - { apply map_non_empty_singleton. } - { rewrite dom_singleton. set_solver. } - { simpl. set_solver. } - - repeat iModIntro. - - iFrame "Hmod". iSplitL "Hf". - { rewrite /has_fuels_S fmap_insert fmap_empty //. } - iIntros "Hmod Hf". - - wp_pures. repeat iModIntro. - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. done. } - iModIntro. iApply "Hk". - rewrite map_filter_singleton_False; last set_solver. rewrite /has_fuels dom_empty_L. - iDestruct "Hf" as "[??]". iFrame. - + assert (N = N) by lia. simplify_eq. iApply (wp_cmpxchg_suc_step_singlerole _ tid (Y: fmrole the_fair_model) _ 55%nat _ - (M, true) (M, false) - with "[$]"); eauto. - { simpl. lia. } - { econstructor. lia. } - { simpl. destruct M; [set_solver | destruct M; set_solver]. } - iModIntro. - iIntros "!> (Hb & Hmod & HFR & Hf)". - iMod (yes_update (M-1) with "[$]") as "[Hay Hyes]". - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. iPureIntro. intro contra. simplify_eq. } - iModIntro. rewrite decide_True; last first. - { do 2 (destruct M; try done). set_solver. } - - rewrite has_fuel_fuels. - wp_pures. - wp_load. - wp_pures. - wp_store. - wp_pures. - wp_load. - wp_pures. - - destruct (decide (0 < S M - 1)) as [Heq|Heq]. - * rewrite bool_decide_eq_true_2 //; last lia. - wp_pure _. - - rewrite -has_fuel_fuels. - iApply ("Hg" with "[] [Hyes HnN Hf] [$]"); last first. - { iFrame "∗#". iSplit; last by iPureIntro; lia. - iClear "Hg Hinv". - - assert (∀ l v v', v = v' → l ↦ v ⊣⊢ l ↦ v') as pointsto_proper. - { intros ??? ->. done. } - - iApply (pointsto_proper with "HnN"). do 2 f_equiv. destruct M; [done|]. lia. } - iPureIntro; lia. - * rewrite bool_decide_eq_false_2 //; last lia. - have ->: M = 0 by lia. simpl. lia. - - iDestruct (yes_agree with "Hyes Hay") as "%Heq". rewrite -> Heq in *. - have HM: M > 0 by lia. - - rewrite -has_fuel_fuels. - iApply (wp_cmpxchg_fail_step_singlerole _ tid (Y: fmrole the_fair_model) _ 50%nat _ - (M, false) (M, false) - with "[$]"); eauto. - { simpl. lia. } - { econstructor. lia. } - iIntros "!>!> (Hb & Hmod & HFR & Hf)". - (* iMod (yes_update (N-1) with "[$]") as "[Hay Hyes]". *) - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. simplify_eq. iExists _, _. iFrame. iSplit; [iFrame|done]. } - - rewrite decide_True; last first. - { destruct M; [done|destruct M; [lia|set_solver]]. } - - iModIntro. - wp_pures. - wp_load. - wp_pure _. rewrite bool_decide_eq_true_2; last lia. - wp_pure _. - - rewrite -has_fuel_fuels. - iApply ("Hg" with "[] [Hyes HnN Hf] [$]"); last first. - { iFrame "∗#". iPureIntro; lia. } - iPureIntro; lia. - Qed. - - Lemma yes_spec tid b (N: nat) f (Hf: f > 50): - {{{ yesno_inv b ∗ has_fuel tid Y f ∗ ⌜N > 0⌝ ∗ yes_at N }}} - yes #N #b @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iIntros (Φ) "(#Hinv & Hf & %HN & Hyes) Hk". unfold yes. - - wp_pures. - wp_bind (Alloc _). - - rewrite has_fuels_gt_1; last by solve_fuel_positive. - - iApply (wp_alloc_nostep _ _ _ _ {[Y := _]}%nat with "[Hf]"). - { apply map_non_empty_singleton. } - { rewrite fmap_insert fmap_empty. done. } - iNext. iIntros (n) "(HnN & _ & Hf)". - rewrite -has_fuel_fuels. - - wp_pures. - - rewrite -has_fuel_fuels. - - iApply (yes_go_spec with "[-Hk]"); try iFrame. - { lia. } - { iFrame "Hinv". iPureIntro; lia. } - Qed. - - Lemma no_go_spec tid n b (N: nat) f (Hf: f > 40): - {{{ yesno_inv b ∗ has_fuel tid No f ∗ n ↦ #N ∗ ⌜N > 0⌝ ∗ no_at N }}} - no_go #n #b @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iLöb as "Hg" forall (N f Hf). - - iIntros (Φ) "(#Hinv & Hf & HnN & %HN & Hno) Hk". unfold no_go. - - wp_pures. - wp_bind (CmpXchg _ _ _). - - assert (∀ s, Atomic s (CmpXchg #b #true #false)) by apply _. - - iApply wp_atomic. - - iInv Ns as (M B) "(>HFR & >Hmod & >Bb & Hauths & >%Hnever)" "Hclose". - destruct B; iDestruct "Hauths" as "[>Hay >Han]"; last first. - - iDestruct (no_agree with "Hno Han") as "%Heq". - - (* TODO *) - rewrite -has_fuel_fuels. - - destruct (decide (M = 0)) as [->|Nneq]; first lia. - destruct (decide (M = 1)) as [->|Nneq1]. - + iApply (wp_cmpxchg_suc_step_singlerole_keep_dead _ tid (No: fmrole the_fair_model) _ 30%nat _ - (1, false) (0, true) - with "[$]") =>//. - { lia. } - { econstructor. } - iModIntro. - iIntros "!> (Hb & Hmod & HFR & Hf)". - iMod (no_update 0 with "[$]") as "[Han Hno]". - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. iExists _, _. iFrame. simpl. iFrame. by iPureIntro. } - - iModIntro. - - rewrite has_fuel_fuels. - wp_pures. - wp_load. - wp_pures. - wp_store. - wp_pures. - wp_load. - - wp_pure _. - simplify_eq. simpl. - - iApply wp_atomic. - - iInv Ns as (M B) "(>HFR & >Hmod & >Hb & Hauths & >%Hbever')" "Hclose". - - destruct B. - * iApply (wp_lift_pure_step_no_fork_remove_role {[ No ]} ((0, true): fmstate the_fair_model) _ _ _ _ _ _ {[ No := _ ]}) =>//. - { apply map_non_empty_singleton. } - { rewrite dom_singleton. set_solver. } - { simpl. set_solver. } - - repeat iModIntro. - - iDestruct "Hauths" as "[Hay Han]". iDestruct (no_agree with "Hno Han") as %Heq. - assert (M = 0) by lia. simplify_eq. iFrame "Hmod". iSplitL "Hf". - { rewrite /has_fuels_S fmap_insert fmap_empty //. } - iIntros "Hmod Hf". - - wp_pures. repeat iModIntro. - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. done. } - iModIntro. iApply "Hk". - rewrite map_filter_singleton_False; last set_solver. rewrite /has_fuels dom_empty_L. - iDestruct "Hf" as "[??]". iFrame. - * iDestruct "Hauths" as "[>Hay >Han]". iDestruct (no_agree with "Hno Han") as %Heq. - assert (M = 0) by lia. simplify_eq. - + assert (N = N) by lia. simplify_eq. - destruct M; first done. - - iApply (wp_cmpxchg_suc_step_singlerole _ tid (No: fmrole the_fair_model) _ 55%nat _ - (S M, false) (M, true) - with "[$]"); eauto. - { simpl. lia. } - { econstructor. } - { simpl. destruct M; [set_solver | destruct M; set_solver]. } - iModIntro. - iIntros "!> (Hb & Hmod & HFR & Hf)". - iMod (no_update (M) with "[$]") as "[Han Hno]". - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. iSplit; last by iPureIntro. - iApply (own_proper with "Hay"). f_equiv. apply leibniz_equiv_iff. lia. } - - iModIntro. rewrite decide_True; last first. - { do 2 (destruct M; try done); set_solver. } - - rewrite has_fuel_fuels. - wp_pures. - wp_load. - wp_pures. - wp_store. - wp_pures. - wp_load. - wp_pures. - - destruct (decide (0 < S M - 1)) as [Heq|Heq]. - * rewrite bool_decide_eq_true_2 //; last lia. - wp_pure _. - - rewrite -has_fuel_fuels. - iApply ("Hg" with "[] [Hno HnN Hf] [$]"); last first. - { iFrame "∗#". assert ((S M - 1)%Z = M)%nat as -> by lia. iFrame. iPureIntro; lia. } - iPureIntro; lia. - * rewrite bool_decide_eq_false_2 //; last lia. - have ->: M = 0 by lia. simpl. lia. - - iDestruct (no_agree with "Hno Han") as "%Heq". rewrite -> Heq in *. - have HM: M > 0 by lia. - - rewrite -has_fuel_fuels. assert (M = N) by lia. simplify_eq. - iApply (wp_cmpxchg_fail_step_singlerole _ tid (No: fmrole the_fair_model) _ 50%nat _ - (N, true) (N, true) - with "[$]"); eauto. - { simpl. lia. } - { econstructor. lia. } - iIntros "!>!> (Hb & Hmod & HFR & Hf)". - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. simplify_eq. iExists _, _. iFrame. iSplit; [iFrame|done]. } - - rewrite decide_True; last first. - { destruct N; [lia|destruct N; set_solver]. } - - iModIntro. - wp_pures. - wp_load. - wp_pure _. rewrite bool_decide_eq_true_2; last lia. - wp_pure _. - - rewrite -has_fuel_fuels. - iApply ("Hg" with "[] [Hno HnN Hf] [$]"); last first. - { iFrame "∗#". iPureIntro; lia. } - iPureIntro; lia. - Qed. - - Lemma no_spec tid b (N: nat) f (Hf: f > 50): - {{{ yesno_inv b ∗ has_fuel tid No f ∗ ⌜N > 0⌝ ∗ no_at N }}} - no #N #b @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iIntros (Φ) "(#Hinv & Hf & %HN & Hyes) Hk". unfold no. - - wp_pures. - wp_bind (Alloc _). - - rewrite has_fuels_gt_1; last by solve_fuel_positive. - - iApply (wp_alloc_nostep _ _ _ _ {[No := _]}%nat with "[Hf]"). - { apply map_non_empty_singleton. } - { rewrite fmap_insert fmap_empty. done. } - iNext. iIntros (n) "(HnN & _ & Hf)". - rewrite -has_fuel_fuels. - - wp_pures. - - rewrite -has_fuel_fuels. - - iApply (no_go_spec with "[-Hk]"); try iFrame. - { lia. } - { iFrame "Hinv". done. } - Qed. -End proof. - - -Section proof_start. - Context `{!heapGS Σ the_model, !yesnoPreG Σ}. - Let Ns := nroot .@ "yes_no". - - Lemma start_spec tid (N: nat) f (Hf: f > 60): - {{{ frag_model_is (N, true) ∗ frag_free_roles_are ∅ ∗ - has_fuels tid {[ Y := f; No := f ]} ∗ ⌜N > 0⌝ }}} - start #N @ tid - {{{ RET #(); tid ↦M ∅ }}}. - Proof using All. - iIntros (Φ) "[Hst [HFR [Hf %HN]]] Hkont". unfold start. - - wp_pures. - - wp_bind (Alloc _). - iApply (wp_alloc_nostep _ _ _ _ {[Y := _; No := _]} with "[Hf]"). - { apply insert_non_empty. } - { rewrite has_fuels_gt_1; last solve_fuel_positive. - rewrite !fmap_insert fmap_empty //. } - - iIntros "!>" (l) "(Hl & _ & Hf)". - - wp_pures. - - (* Allocate the invariant. *) - iMod (own_alloc (●E N ⋅ ◯E N))%nat as (γ_yes_at) "[Hyes_at_auth Hyes_at]". - { apply auth_both_valid_2; eauto. by compute. } - iMod (own_alloc (●E N ⋅ ◯E N))%nat as (γ_no_at) "[Hno_at_auth Hno_at]". - { apply auth_both_valid_2; eauto. by compute. } - - pose (the_names := {| - yes_name := γ_yes_at; - no_name := γ_no_at; - |}). - - iApply fupd_wp. - iMod (inv_alloc Ns _ (yesno_inv_inner l) with "[-Hkont Hf Hyes_at Hno_at]") as "#Hinv". - { iNext. unfold yesno_inv_inner. iExists N, true. iFrame. done. } - iModIntro. - - wp_bind (Fork _). - rewrite has_fuels_gt_1; last solve_fuel_positive. - iApply (wp_fork_nostep _ tid _ _ _ {[ No ]} {[ Y ]} {[Y := _; No := _]} - with "[Hyes_at] [- Hf] [Hf]"); - [ set_solver | by apply insert_non_empty | | | | rewrite !fmap_insert fmap_empty // ]; - [set_solver | |]. - { iIntros (tid') "!> Hf". iApply (yes_spec with "[-]"); last first. - + by eauto. - + rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_insert_not; last set_solver. - rewrite map_filter_empty insert_empty. - rewrite has_fuel_fuels. by iFrame "#∗". - + lia. } - - iIntros "!> Hf". - rewrite map_filter_insert_not; last set_solver. - rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_empty insert_empty. - - iModIntro. - wp_pures. - - rewrite has_fuels_gt_1; last solve_fuel_positive. - iApply (wp_fork_nostep _ tid _ _ _ ∅ {[ No ]} {[No := _]} with "[Hno_at] [Hkont] [Hf]"); - [ set_solver | by apply insert_non_empty | | | | rewrite !fmap_insert fmap_empty // ]; - [set_solver | |]. - { iIntros (tid') "!> Hf". iApply (no_spec with "[-]"); last first. - + by eauto. - + rewrite map_filter_insert_True; last set_solver. - rewrite map_filter_empty insert_empty. - rewrite has_fuel_fuels. by iFrame "#∗". - + lia. } - - iNext. iIntros "[Hf _]". - iApply "Hkont". iModIntro. iApply (equiv_wand with "Hf"). do 2 f_equiv. - rewrite dom_empty_iff_L map_filter_empty_iff. - intros ???. set_solver. - Qed. -End proof_start. diff --git a/fairness/examples/yesno/yesno_adequacy.v b/fairness/examples/yesno/yesno_adequacy.v deleted file mode 100644 index 5e96a152..00000000 --- a/fairness/examples/yesno/yesno_adequacy.v +++ /dev/null @@ -1,251 +0,0 @@ -From trillium.fairness.examples.yesno Require Import yesno. -From iris.proofmode Require Import tactics. -From trillium.program_logic Require Export weakestpre. -From trillium.fairness Require Import fairness fair_termination fairness_finiteness. -From trillium.prelude Require Export finitary quantifiers sigma classical_instances. -From trillium.fairness.heap_lang Require Export lang lifting tactics. -From trillium.fairness.heap_lang Require Import notation. - -From stdpp Require Import finite. - - -Section product_of_orders. - Variables (A B : Type) (leA : relation A) (leB : relation B). - Context `{HlAtrans: Transitive _ leA}. - - Lemma prod_trans : - transitive _ leA -> - transitive _ leB -> - transitive _ (prod_relation leA leB). - Proof. - intros tA tB [x1 y1] [x2 y2] [x3 y3] H. - inversion H; subst; clear H. - intros H. - inversion H; subst; clear H. - split; eauto. - Qed. - - Theorem wf_prod : - well_founded leA -> - well_founded leB -> - well_founded (prod_relation leA leB). - Proof. - intros wfA wfB [x y]. generalize dependent y. - induction (wfA x) as [x _ IHx]; clear wfA. - intros y. - induction (wfB y) as [y _ IHy]; clear wfB. - constructor. - intros [x' y'] H. - now inversion H; subst; clear H; eauto. - Qed. - - Theorem wf_prod_strict : - well_founded (strict leA) -> - well_founded (strict leB) -> - well_founded (strict (prod_relation leA leB)). - Proof. - intros wfA wfB [x y]. generalize dependent y. - induction (wfA x) as [x _ IHx]; clear wfA. - intros y. - generalize dependent x. - induction (wfB y) as [y _ IHy]; clear wfB. - intros x IH. - constructor. - intros [x' y'] H. - inversion H as [[??] [?|?]%Classical_Prop.not_and_or]; subst; clear H; first by apply IH. - apply IHy; first done. intros ???. eapply IH, strict_transitive_l =>//. - Qed. - - Global Instance prod_relation_antisym : - AntiSymm eq leA → AntiSymm eq leB → AntiSymm eq (prod_relation leA leB). - Proof. - intros ??[??] [??] [??] [??]. - f_equal; firstorder eauto. - Qed. - - Global Instance prod_relation_preorder : - PreOrder leA → PreOrder leB → PreOrder (prod_relation leA leB). - Proof. firstorder eauto. Qed. - - Global Instance prod_relation_partialorder : - PartialOrder leA → PartialOrder leB → PartialOrder (prod_relation leA leB). - Proof. - intros. split; first (firstorder eauto). - typeclasses eauto. - Qed. -End product_of_orders. - -Section unstrict_order. - Context {A B : Type}. - Variables (lt : relation A). - - Definition unstrict x y := - x = y ∨ lt x y. -End unstrict_order. - -Definition the_order := unstrict (lexprod _ _ (strict Nat.le) (strict bool_le)). - -Ltac inv_lexs := - repeat match goal with - [ H: lexprod _ _ _ _ _ _ |- _ ] => inversion H; clear H; simplify_eq - end. - -Lemma lexprod_lexico x y: - lexprod _ _ (strict Nat.le) (strict bool_le) x y <-> lexico x y. -Proof. - split. - - intros [???? H|x' y' z' H]. - + left =>/=. compute. compute in H. lia. - + right =>/=. compute; split=>//. compute in H. destruct y'; destruct z' =>//; intuition. - - destruct x as [x1 x2]. destruct y as [y1 y2]. intros [H|[Heq H]]; simpl in *. - + left =>/=. compute. compute in H. lia. - + rewrite Heq. right =>/=. destruct x2; destruct y2 =>//; intuition. constructor =>//. eauto. -Qed. - -#[local] Instance the_order_po: PartialOrder the_order. -Proof. - constructor. - - constructor. - + intros ?. by left. - + unfold the_order. intros [x1 x2] [y1 y2] [z1 z2] [|H1] [|H2]; simplify_eq; try (by left); right; eauto. - rewrite -> lexprod_lexico in *. etransitivity =>//. - - intros [x1 x2] [y1 y2] [|H1] [|H2]; simplify_eq =>//. - inversion H1; inversion H2; simplify_eq; try (compute in *; lia). - destruct x2; destruct y2; compute in *; intuition. -Qed. - -Definition the_decreasing_role (s: the_fair_model): YN := - match s with - | (0%nat, false) => Y - | (_, true) => Y - | (_, false) => No - end. - -#[local] Instance eq_antisymm A: Antisymmetric A eq eq. -Proof. by intros ??. Qed. - -Lemma strict_unstrict {A} (R: relation A): - forall x y, strict (unstrict R) x y -> R x y. -Proof. - unfold strict, unstrict. - intros x y. - intros [[?|?] [Hneq HnR]%Classical_Prop.not_or_and] =>//. -Qed. - -Lemma wf_bool_le: wf (strict bool_le). -Proof. - intros b. destruct b; constructor; intros b' h; destruct b'; inversion h as [h1 h2]; - [done| | inversion h1| done]. clear h1 h2. - constructor; intros b' h'; inversion h' as [h1 h2]; destruct b'; [inversion h1 | exfalso; eauto]. -Qed. - -#[local] Instance lex_trans `{Transitive A R1, Transitive B R2}: Transitive (lexprod A B R1 R2). -Proof. - intros [x x'] [y y'] [z z'] Ha Hb. - inversion Ha; inversion Hb; simplify_eq. - - constructor 1. etransitivity =>//. - - by constructor 1. - - by constructor 1. - - constructor 2. etransitivity =>//. -Qed. - -#[local] Program Instance the_model_terminates: FairTerminatingModel the_fair_model := - {| - ftm_leq := the_order; - ftm_decreasing_role := the_decreasing_role; - |}. -Next Obligation. - unfold the_order. - assert (H: wf (lexprod nat bool (strict Nat.le) (strict bool_le))). - + apply wf_lexprod; last apply wf_bool_le. - eapply (wf_projected _ id); last apply Nat.lt_wf_0. - intros ??[??]. simpl. lia. - + eapply (wf_projected _ id); last exact H. - intros ???. apply strict_unstrict => //. -Qed. -Next Obligation. - intros [N B] Hex. - destruct B. - - split. - + simpl. destruct N. - * destruct Hex as [ρ' [s' Hex]]. - inversion Hex; subst; lia. - * destruct N; set_solver. - + intros [??] H. inversion H; simplify_eq. - * split; [right; right; compute; done| compute; intros [?|contra] =>//]. - inversion contra; simplify_eq; intuition. - * destruct n =>//. - - split. - + destruct N; simpl. - * destruct Hex as [ρ' [s' Hex]]. - inversion Hex; subst; lia. - * destruct N; set_solver. - + intros [[|?] ?] H. - * inversion H; simplify_eq; [lia|]. unfold strict, the_order; split. - ** right; left. compute. lia. - ** intros [|contra] =>//. inversion contra; simplify_eq. compute in *. lia. - * inversion H; simplify_eq. split; [right;left; compute; lia|]. - intros [|contra] =>//; inversion contra; simplify_eq; last lia. compute in *. lia. -Qed. -Next Obligation. - intros [N B] [N' B'] ρ Htrans Hnex. - inversion Htrans ; simplify_eq; eauto; simpl in *; - try (destruct N'; eauto); try lia; (try (destruct N'; done)); try done. -Qed. -Next Obligation. - intros [N B] ρ [N' B'] Htrans. - destruct ρ; last by inversion Htrans. - inversion Htrans; simplify_eq; simpl; try reflexivity. - - right; constructor 2; by compute. - - right; constructor 1; compute. lia. -Qed. - -(* The model is finitely branching *) -Definition steppable '(n, w): list ((nat * bool) * option YN) := - n' ← [n; (n-1)%nat]; - w' ← [w; negb w]; - ℓ ← [Some Y; Some No]; - mret ((n', w'), ℓ). - -#[local] Instance proof_irrel_trans s x: - ProofIrrel ((let '(s', ℓ) := x in yntrans s ℓ s'): Prop). -Proof. apply make_proof_irrel. Qed. - -Lemma model_finitary s: - Finite { '(s', ℓ) | yntrans s ℓ s'}. -Proof. - assert (H: forall A (y x: A) xs, (y = x ∨ y ∈ xs) -> y ∈ x::xs) by set_solver. - eapply (in_list_finite (steppable s)). - intros [n w] Htrans. - inversion Htrans; try (repeat (rewrite ?Nat.sub_0_r; simpl; - eapply H; try (by left); right); done). -Qed. - -Theorem yesno_terminates - (N : nat) - (HN: N > 1) - (extr : heap_lang_extrace) - (Hvex : extrace_valid extr) - (Hexfirst : (trfirst extr).1 = [start #N]): - (∀ tid, fair_ex tid extr) -> terminating_trace extr. -Proof. - assert (heapGpreS yesnoΣ the_model) as HPreG. - { apply _. } - eapply (simulation_adequacy_terminate_ftm yesnoΣ the_model NotStuck _ (N, true) ∅) =>//. - - eapply valid_state_evolution_finitary_fairness_simple. - intros ?. simpl. apply (model_finitary s1). - - destruct N; [lia|destruct N; set_solver]. - - intros ?. iStartProof. iIntros "!> Hm HFR Hf !>". simpl. - iApply (start_spec _ _ 61 with "[Hm Hf HFR]"); eauto. - + iSplitL "Hm"; eauto. do 2 (destruct N; first lia). - assert (∅ ∖ {[ No; Y ]} = ∅) as -> by set_solver. iFrame. iSplit; last (iPureIntro; lia). - assert ({[Y := 61%nat; No := 61%nat]} = gset_to_gmap 61 {[No;Y]}) as <-; last done. - rewrite -leibniz_equiv_iff. intros ρ. - destruct (gset_to_gmap 61 {[Y; No]} !! ρ) as [f|] eqn:Heq. - * apply lookup_gset_to_gmap_Some in Heq as [Heq ->]. - destruct (decide (ρ = Y)) as [-> |]. - ** rewrite lookup_insert //. rewrite lookup_gset_to_gmap option_guard_True //. set_solver. - ** rewrite lookup_insert_ne //. assert (ρ = No) as -> by set_solver. - rewrite lookup_insert // lookup_gset_to_gmap option_guard_True //. set_solver. - * apply lookup_gset_to_gmap_None in Heq. destruct ρ; set_solver. -Qed. diff --git a/fairness/fair_termination.v b/fairness/fair_termination.v deleted file mode 100644 index e34633cf..00000000 --- a/fairness/fair_termination.v +++ /dev/null @@ -1,104 +0,0 @@ -From trillium.fairness Require Export fairness. -From stdpp Require Import option. -From Paco Require Import pacotac. - -(* TODO: See if we can generalise the notion of fair terminating traces *) -Definition mtrace_fairly_terminating {Mdl : FairModel} (mtr : mtrace Mdl) := - mtrace_valid mtr → - (∀ ρ, fair_model_trace ρ mtr) → - terminating_trace mtr. - -Definition extrace_fairly_terminating {Λ} `{Countable (locale Λ)} - (extr : extrace Λ) := - extrace_valid extr → - (∀ tid, fair_ex tid extr) → - terminating_trace extr. - -Class FairTerminatingModel (Mdl: FairModel) := { - ftm_leq: relation Mdl; - ftm_order: PreOrder ftm_leq; - ftm_wf: wf (strict ftm_leq); - - ftm_decreasing_role: Mdl -> fmrole Mdl; - ftm_decr: - ∀ (s: Mdl), (∃ ρ' s', fmtrans _ s ρ' s') -> - ftm_decreasing_role s ∈ live_roles _ s ∧ - ∀ s', (fmtrans _ s (Some (ftm_decreasing_role s)) s' -> - (strict ftm_leq) s' s); - ftm_decreasing_role_preserved: - ∀ (s s': Mdl) ρ', - (fmtrans _ s ρ' s' -> ρ' ≠ Some (ftm_decreasing_role s) -> - ftm_decreasing_role s = ftm_decreasing_role s'); - ftm_notinc: - ∀ (s: Mdl) ρ s', (fmtrans _ s ρ s' -> ftm_leq s' s); -}. - -Arguments ftm_leq {_ _}. -Arguments ftm_wf {_ _}. -Arguments ftm_decr {_ _}. -Arguments ftm_decreasing_role {_ _}. - -#[global] Existing Instance ftm_order. - -Notation ftm_lt := (strict ftm_leq). -Local Infix "<" := ftm_lt. -Local Infix "≤" := ftm_leq. - -Lemma ftm_trans' `{FairTerminatingModel Mdl} a b c: - a < b -> b ≤ c -> a < c. -Proof. - intros [H1 H1'] H2. - (* TODO: Why do we need to extract this manually? *) - assert (EqDecision Mdl) by apply Mdl.(fmstate_eqdec). - destruct (decide (b = c)) as [->|Heq]; [done|]. - split; [by etransitivity|]. - intros H'. apply H1'. - by etransitivity. -Qed. - -Lemma fair_terminating_traces_terminate_rec `{FairTerminatingModel Mdl} - (s0: Mdl) (mtr: mtrace Mdl): - (trfirst mtr) ≤ s0 -> - mtrace_valid mtr -> - (∀ ρ, fair_model_trace ρ mtr) -> - terminating_trace mtr. -Proof. - revert mtr. induction s0 as [s0 IH] using (well_founded_ind ftm_wf). - intros mtr Hleq Hval Hfair. - destruct mtr as [|s ℓ mtr'] eqn:Heq; first by eexists 1. - destruct (ftm_decr (trfirst mtr)) as (Hlive & Htrdec). - { exists ℓ, (trfirst mtr'). punfold Hval. inversion Hval; subst; done. } - rewrite <- Heq in *. clear s ℓ Heq. - destruct (Hfair (ftm_decreasing_role (trfirst mtr)) 0) as [n Hev]; - first by rewrite /pred_at /=; destruct mtr. - revert mtr Hval Hleq Hfair Hlive IH Hev Htrdec. induction n as [| n IHn]; - intros mtr Hval Hleq Hfair Hlive IH Hev Htrdec. - - simpl in *. rewrite /pred_at /= in Hev. - destruct Hev as [Hev|Hev]; first by destruct mtr; done. - destruct mtr; first done. injection Hev => ->. - apply terminating_trace_cons. - eapply IH =>//; eauto. - + eapply ftm_trans' =>//. apply Htrdec. - punfold Hval. inversion Hval; simplify_eq; simpl in *; simplify_eq; done. - + punfold Hval. inversion Hval; simplify_eq. - destruct H4; done. - - simpl in *. destruct mtr; first (exists 1; done). - rewrite -> !pred_at_S in Hev. - punfold Hval; inversion Hval as [|??? Htrans Hval']; simplify_eq. - destruct Hval' as [Hval'|]; last done. - destruct (decide (ℓ = Some (ftm_decreasing_role s))) as [-> | Hnoteq]. - + apply terminating_trace_cons. eapply IH=>//; eauto. - eapply ftm_trans' =>//; apply Htrdec. simpl. destruct Hval;done. - + destruct mtr as [|s' ℓ' mtr''] eqn:Heq; first by eexists 2. - destruct (ftm_decr (trfirst mtr)) as (Hlive' & Htrdec'). - { exists ℓ', (trfirst mtr''). punfold Hval'; inversion Hval'; subst; done. } - apply terminating_trace_cons. eapply IHn=>//; eauto. - * etransitivity; eauto. eapply ftm_notinc =>//. - * simplify_eq. eapply Hlive'. - * erewrite <- ftm_decreasing_role_preserved =>//. - * intros s'' Htrans''. eapply ftm_decr; eauto. -Qed. - -Theorem fair_terminating_traces_terminate `{FairTerminatingModel Mdl} : - ∀ (mtrace : @mtrace Mdl), mtrace_fairly_terminating mtrace. -Proof. intros ???. eapply fair_terminating_traces_terminate_rec=>//. Qed. diff --git a/fairness/fairness.v b/fairness/fairness.v deleted file mode 100644 index c53c1831..00000000 --- a/fairness/fairness.v +++ /dev/null @@ -1,170 +0,0 @@ -From stdpp Require Import option. -From Paco Require Import paco1 paco2 pacotac. -From trillium.fairness Require Export inftraces. - -Record FairModel : Type := { - fmstate:> Type; - fmstate_eqdec: EqDecision fmstate; - fmstate_inhabited: Inhabited fmstate; - - fmrole: Type; - fmrole_eqdec: EqDecision fmrole; - fmrole_countable: Countable fmrole; - fmrole_inhabited: Inhabited fmrole; - - fmtrans: fmstate -> option fmrole -> fmstate -> Prop; - - live_roles: fmstate -> gset fmrole; - fm_live_spec: forall s ρ s', fmtrans s (Some ρ) s' -> ρ ∈ live_roles s; -}. - -#[global] Existing Instance fmrole_eqdec. -#[global] Existing Instance fmrole_countable. -#[global] Existing Instance fmrole_inhabited. -#[global] Existing Instance fmstate_inhabited. - -(* Basically, soundness of the logic and the lemmas above tell us that we have a program - trace and a model trace which are related by traces_match labels_math! - - We now prove that this relation transports the properties we care about; the first - place of which is fairness. - *) - -(* Definition of fairness for both kinds of traces *) - -Definition extrace Λ := trace (cfg Λ) (olocale Λ). - -Section exec_trace. - Context {Λ : language}. - Context `{EqDecision (locale Λ)}. - - Definition locale_enabled (ζ : locale Λ) (c: cfg Λ) := - ∃ e, from_locale c.1 ζ = Some e ∧ to_val e = None. - - Definition fair_ex ζ (extr: extrace Λ): Prop := - forall n, pred_at extr n (λ c _, locale_enabled ζ c) -> - ∃ m, pred_at extr (n+m) (λ c _, ¬locale_enabled ζ c) - ∨ pred_at extr (n+m) (λ _ otid, otid = Some (Some ζ)). - - Lemma fair_ex_after ζ tr tr' k: - after k tr = Some tr' -> - fair_ex ζ tr -> fair_ex ζ tr'. - Proof. - intros Haf Hf n Hp. - have Hh:= Hf (k+n). - have Hp': pred_at tr (k + n) (λ (c : cfg Λ) (_ : option (olocale Λ)), locale_enabled ζ c). - { rewrite (pred_at_sum _ k) Haf /= //. } - have [m Hm] := Hh Hp'. exists m. - by rewrite <- Nat.add_assoc, !(pred_at_sum _ k), Haf in Hm. - Qed. - - Lemma fair_ex_cons tid c tid' r: - fair_ex tid (c -[tid']-> r) -> fair_ex tid r. - Proof. intros H. by eapply (fair_ex_after tid (c -[tid']-> r) r 1). Qed. - - CoInductive extrace_valid: extrace Λ -> Prop := - | extrace_valid_singleton c: extrace_valid ⟨c⟩ - | extrace_valid_cons c oζ tr: - locale_step c oζ (trfirst tr) -> - extrace_valid tr → - extrace_valid (c -[oζ]-> tr). - - Lemma to_trace_preserves_validity ex iex: - extrace_valid (to_trace (trace_last ex) iex) -> valid_exec ex -> valid_inf_exec ex iex. - Proof. - revert ex iex. cofix CH. intros ex iex Hexval Hval. - rewrite (trace_unfold_fold (to_trace _ _)) in Hexval. - destruct iex as [|[??] iex]; first by econstructor. cbn in Hexval. - inversion Hexval. simplify_eq. - econstructor; try done. - - by destruct iex as [|[??]?]. - - apply CH; eauto. econstructor; try done. by destruct iex as [|[??]?]. - Qed. - - Lemma from_trace_preserves_validity (extr: extrace Λ) ex: - extrace_valid extr -> - valid_exec ex -> - trace_last ex = trfirst extr -> - valid_inf_exec ex (from_trace extr). - Proof. - revert ex extr. cofix CH. intros ex extr Hexval Hval Heq. - rewrite (inflist_unfold_fold (from_trace extr)). destruct extr as [c|c tid tr]; cbn; - first by econstructor. - inversion Hexval; simplify_eq; econstructor; eauto. apply CH; eauto. - by econstructor. - Qed. - - Lemma from_trace_preserves_validity_singleton (extr: extrace Λ): - extrace_valid extr -> - valid_inf_exec (trace_singleton (trfirst extr)) (from_trace extr). - Proof. - intros ?. eapply from_trace_preserves_validity; eauto. econstructor. - Qed. - -End exec_trace. - -Definition mtrace (M:FairModel) := trace M (option M.(fmrole)). - -Section model_traces. - Context `{M: FairModel}. - - Definition role_enabled_model ρ (s: M) := ρ ∈ M.(live_roles) s. - - Definition fair_model_trace ρ (mtr: mtrace M): Prop := - forall n, pred_at mtr n (λ δ _, role_enabled_model ρ δ) -> - ∃ m, pred_at mtr (n+m) (λ δ _, ¬role_enabled_model ρ δ) - ∨ pred_at mtr (n+m) (λ _ ℓ, ℓ = Some (Some ρ)). - - Lemma fair_model_trace_after ℓ tr tr' k: - after k tr = Some tr' -> - fair_model_trace ℓ tr -> fair_model_trace ℓ tr'. - Proof. - intros Haf Hf n Hp. - have Hh:= Hf (k+n). - have Hp': pred_at tr (k + n) (λ δ _, role_enabled_model ℓ δ). - { rewrite (pred_at_sum _ k) Haf /= //. } - have [m Hm] := Hh Hp'. exists m. - by rewrite <- Nat.add_assoc, !(pred_at_sum _ k), Haf in Hm. - Qed. - - Lemma fair_model_trace_cons ℓ δ ℓ' r: - fair_model_trace ℓ (δ -[ℓ']-> r) -> fair_model_trace ℓ r. - Proof. intros Hfm. by eapply (fair_model_trace_after ℓ _ r 1) =>//. Qed. - - Lemma fair_model_trace_cons_forall δ ℓ' r: - (∀ ℓ, fair_model_trace ℓ (δ -[ℓ']-> r)) -> (∀ ℓ, fair_model_trace ℓ r). - Proof. eauto using fair_model_trace_cons. Qed. - - Inductive mtrace_valid_ind (mtrace_valid_coind: mtrace M -> Prop) : - mtrace M -> Prop := - | mtrace_valid_singleton δ: mtrace_valid_ind _ ⟨δ⟩ - | mtrace_valid_cons δ ℓ tr: - fmtrans _ δ ℓ (trfirst tr) -> - mtrace_valid_coind tr → - mtrace_valid_ind _ (δ -[ℓ]-> tr). - Definition mtrace_valid := paco1 mtrace_valid_ind bot1. - - Lemma mtrace_valid_mono : - monotone1 mtrace_valid_ind. - Proof. - unfold monotone1. intros x0 r r' IN LE. - induction IN; try (econstructor; eauto; done). - Qed. - Hint Resolve mtrace_valid_mono : paco. - - Lemma mtrace_valid_after (mtr mtr' : mtrace M) k : - after k mtr = Some mtr' → mtrace_valid mtr → mtrace_valid mtr'. - Proof. - revert mtr mtr'. - induction k; intros mtr mtr' Hafter Hvalid. - { destruct mtr'; simpl in *; by simplify_eq. } - punfold Hvalid. - inversion Hvalid as [|??? Htrans Hval']; simplify_eq. - eapply IHk; [done|]. - by inversion Hval'. - Qed. - -End model_traces. - -Global Hint Resolve fair_model_trace_cons: core. -Global Hint Resolve mtrace_valid_mono : paco. diff --git a/fairness/fairness_finiteness.v b/fairness/fairness_finiteness.v deleted file mode 100644 index fefa9744..00000000 --- a/fairness/fairness_finiteness.v +++ /dev/null @@ -1,371 +0,0 @@ -From stdpp Require Import finite. -From trillium.prelude Require Import finitary quantifiers classical_instances. -From trillium.fairness Require Import fairness fuel. - -Section gmap. - Context `{!EqDecision K, !Countable K}. - - Definition max_gmap (m: gmap K nat) : nat := - map_fold (λ k v r, v `max` r) 0 m. - - Lemma max_gmap_spec m: - map_Forall (λ _ v, v <= max_gmap m) m. - Proof. - induction m using map_ind; first done. - apply map_Forall_insert =>//. rewrite /max_gmap map_fold_insert //. - - split; first lia. intros ?? Hnotin. specialize (IHm _ _ Hnotin). simpl in IHm. - unfold max_gmap in IHm. lia. - - intros **. lia. - Qed. -End gmap. - -Section finitary. - Context `{M: FairModel}. - Context `{Λ: language}. - Context `{LM: LiveModel Λ M}. - Context `{EqDecision M}. - Context `{EqDecision (locale Λ)}. - - Context `{HPI0: forall s x, ProofIrrel ((let '(s', ℓ) := x in M.(fmtrans) s ℓ s'): Prop) }. - - Variable (ξ: execution_trace Λ -> finite_trace M (option M.(fmrole)) -> Prop). - - Variable model_finitary: rel_finitary ξ. - - #[local] Instance eq_dec_next_states ex atr c' oζ: - EqDecision {'(δ', ℓ) : M * (option (fmrole M)) | - ξ (ex :tr[ oζ ]: c') (atr :tr[ ℓ ]: δ')}. - Proof. intros x y. apply make_decision. Qed. - - Lemma model_finite: ∀ (ex : execution_trace Λ) (atr : finite_trace _ _) c' oζ, - Finite (sig (λ '(δ', ℓ), ξ (ex :tr[oζ]: c') (atr :tr[ℓ]: δ'))). - Proof. - intros ex atr c' oζ. - pose proof (model_finitary ex atr c' oζ). - by apply smaller_card_nat_finite in H. - Qed. - - Definition enum_inner extr fmodtr c' oζ : list (M * option M.(fmrole)) := - map proj1_sig (@enum _ _ (model_finite extr fmodtr c' oζ)). - - Lemma enum_inner_spec (δ' : M) ℓ extr atr c' oζ : - ξ (extr :tr[oζ]: c') (atr :tr[ℓ]: δ') → (δ', ℓ) ∈ enum_inner extr atr c' oζ. - Proof. - intros H. unfold enum_inner. rewrite elem_of_list_fmap. - exists (exist _ (δ', ℓ) H). split =>//. apply elem_of_enum. - Qed. - - (* TODO: move *) - Fixpoint trace_map {A A' L L'} (sf: A → A') (lf: L -> L') (tr: finite_trace A L): finite_trace A' L' := - match tr with - | trace_singleton x => trace_singleton $ sf x - | trace_extend tr' ℓ x => trace_extend (trace_map sf lf tr') (lf ℓ) (sf x) - end. - - Fixpoint get_underlying_fairness_trace (M : FairModel) (LM: LiveModel Λ M) (ex : auxiliary_trace LM) := - match ex with - | trace_singleton δ => trace_singleton (ls_under δ) - | trace_extend ex' (Take_step ρ _) δ => trace_extend (get_underlying_fairness_trace M LM ex') ρ (ls_under δ) - | trace_extend ex' _ _ => get_underlying_fairness_trace M LM ex' - end. - - Definition get_role {M : FairModel} {LM: LiveModel Λ M} (lab: mlabel LM) := - match lab with - | Take_step ρ _ => Some ρ - | _ => None - end. - - Definition map_underlying_trace {M : FairModel} {LM: LiveModel Λ M} (aux : auxiliary_trace LM) := - (trace_map (λ s, ls_under s) (λ lab, get_role lab) aux). - - Program Definition enumerate_next extr (fmodtr: auxiliary_trace LM) c' oζ: - list (LM * @mlabel LM) := - let δ1 := trace_last fmodtr in - '(s2, ℓ) ← (δ1.(ls_under), None) :: enum_inner extr (map_underlying_trace fmodtr) c' oζ; - d ← enumerate_dom_gsets' (dom δ1.(ls_fuel) ∪ live_roles _ s2); - fs ← enum_gmap_bounded' (live_roles _ s2 ∪ d) (max_gmap δ1.(ls_fuel) `max` LM.(lm_fl) s2); - ms ← enum_gmap_range_bounded' (live_roles _ s2 ∪ d) (locales_of_list c'.1); - let ℓ' := match ℓ with - | None => match oζ with - Some ζ => Silent_step ζ - | None => Config_step - end - | Some ℓ => match oζ with - | None => Config_step - | Some ζ => Take_step ℓ ζ - end - end in - mret ({| ls_under := s2; - ls_fuel := `fs; - (* ls_fuel_dom := proj2_sig fs; *) (* TODO: why this does not work?*) - ls_mapping := `ms ; - |}, ℓ'). - Next Obligation. - intros ??????????. destruct fs as [? Heq]. rewrite /= Heq //. set_solver. - Qed. - Next Obligation. - intros ??????????. destruct fs as [? Heq]. destruct ms as [? Heq']. - rewrite /= Heq //. - Qed. - - Lemma valid_state_evolution_finitary_fairness (φ: execution_trace Λ -> auxiliary_trace LM -> Prop) : - rel_finitary (valid_lift_fairness (λ extr auxtr, ξ extr (map_underlying_trace auxtr) ∧ φ extr auxtr)). - Proof. - rewrite /valid_lift_fairness. - intros ex atr [e' σ'] oζ. - eapply finite_smaller_card_nat. - simpl. - eapply (in_list_finite (enumerate_next ex atr (e',σ') oζ)). - intros [δ' ℓ] [[Hlbl [Htrans Htids]] [Hξ Hφ]]. - unfold enumerate_next. apply elem_of_list_bind. - exists (δ'.(ls_under), match ℓ with Take_step l _ => Some l | _ => None end). - split; last first. - { destruct ℓ as [ρ tid' | |]. - - inversion Htrans as [Htrans']. apply elem_of_cons; right. - by apply enum_inner_spec. - - apply elem_of_cons; left. f_equal. inversion Htrans as (?&?&?&?&?); done. - - apply elem_of_cons; right. inversion Htrans as (?&?). by apply enum_inner_spec. } - apply elem_of_list_bind. eexists (dom $ δ'.(ls_fuel)). split; last first. - { apply enumerate_dom_gsets'_spec. destruct ℓ as [ρ tid' | |]. - - inversion Htrans as (?&?&?&?&?&?&?). intros ρ' Hin. destruct (decide (ρ' ∈ live_roles _ δ')); first set_solver. - destruct (decide (ρ' ∈ dom $ ls_fuel (trace_last atr))); first set_solver. set_solver. - - inversion Htrans as (?&?&?&?&?). set_solver. - - inversion Htrans as (?&?&?&?&?). done. } - apply elem_of_list_bind. - assert (Hfueldom: dom δ'.(ls_fuel) = live_roles M δ' ∪ dom (ls_fuel δ')). - { rewrite subseteq_union_1_L //. apply ls_fuel_dom. } - eexists (δ'.(ls_fuel) ↾ Hfueldom); split; last first. - { eapply enum_gmap_bounded'_spec; split =>//. - intros ρ f Hsome. destruct ℓ as [ρ' tid' | |]. - - destruct (decide (ρ = ρ')) as [-> | Hneq]. - + inversion Htrans as [? Hbig]. destruct Hbig as (Hmap&Hleq&?&Hlim&?&?). - destruct (decide (ρ' ∈ live_roles _ δ')). - * rewrite Hsome /= in Hlim. - assert (Hlive: ρ' ∈ live_roles _ δ') by set_solver. - specialize (Hlim Hlive). lia. - * unfold fuel_decr in Hleq. - apply elem_of_dom_2 in Hmap. rewrite ls_same_doms in Hmap. - pose proof Hsome as Hsome'. apply elem_of_dom_2 in Hsome'. - specialize (Hleq ρ' ltac:(done) ltac:(done)). - assert(must_decrease ρ' (Some ρ') (trace_last atr) δ' (Some tid')) as Hmd; first by constructor 3. - specialize (Hleq Hmd). rewrite Hsome /= in Hleq. - apply elem_of_dom in Hmap as [? Heq]. rewrite Heq in Hleq. - pose proof (max_gmap_spec _ _ _ Heq). simpl in *. lia. - + inversion Htrans as [? Hbig]. destruct Hbig as (Hmap&?&Hleq'&?&Hnew&?). - destruct (decide (ρ ∈ dom $ ls_fuel (trace_last atr))) as [Hin|Hnotin]. - * assert (Hok: oleq (ls_fuel δ' !! ρ) (ls_fuel (trace_last atr) !! ρ)). - { unfold fuel_must_not_incr in *. - assert (ρ ∈ dom $ ls_fuel (trace_last atr)) by SS. - specialize (Hleq' ρ ltac:(done) ltac:(congruence)) as [Hleq'|Hleq'] =>//. apply elem_of_dom_2 in Hsome. set_solver. } - rewrite Hsome in Hok. destruct (ls_fuel (trace_last atr) !! ρ) as [f'|] eqn:Heqn; last done. - pose proof (max_gmap_spec _ _ _ Heqn). simpl in *. lia. - * assert (Hok: oleq (ls_fuel δ' !! ρ) (Some (LM.(lm_fl) δ'))). - { apply Hnew. apply elem_of_dom_2 in Hsome. set_solver. } - rewrite Hsome in Hok. simpl in Hok. lia. - - inversion Htrans as [? [? [Hleq [Hincl Heq]]]]. specialize (Hleq ρ). - assert (ρ ∈ dom $ ls_fuel (trace_last atr)) as Hin. - { apply elem_of_dom_2 in Hsome. set_solver. } - specialize (Hleq Hin ltac:(done)) as [Hleq|Hleq]. - + rewrite Hsome in Hleq. destruct (ls_fuel (trace_last atr) !! ρ) as [f'|] eqn:Heqn. - * pose proof (max_gmap_spec _ _ _ Heqn). simpl in *. - rewrite Heqn in Hleq. - lia. - * simpl in *. rewrite Heqn in Hleq. done. - + apply elem_of_dom_2 in Hsome. set_solver. - - inversion Htrans as [? [? [Hleq [Hnew Hfalse]]]]. done. } - apply elem_of_list_bind. - assert (Hmappingdom: dom δ'.(ls_mapping) = live_roles M δ' ∪ dom (ls_fuel δ')). - { rewrite -Hfueldom ls_same_doms //. } - exists (δ'.(ls_mapping) ↾ Hmappingdom); split; last first. - { eapply enum_gmap_range_bounded'_spec; split=>//. - intros ρ' tid' Hsome. unfold tids_smaller in *. - apply locales_of_list_from_locale_from. eauto. } - rewrite elem_of_list_singleton; f_equal. - - destruct δ'; simpl. f_equal; apply ProofIrrelevance. - - destruct ℓ; simpl; destruct oζ =>//; by inversion Hlbl. - Unshelve. - + intros ??. apply make_decision. - + intros. apply make_proof_irrel. - + done. - + done. - Qed. -End finitary. - -Section finitary_simple. - Context `{M: FairModel}. - Context `{Λ: language}. - Context `{LM: LiveModel Λ M}. - Context `{EqDecision M}. - Context `{EqDecision (locale Λ)}. - - Context `{HPI0: forall s x, ProofIrrel ((let '(s', ℓ) := x in M.(fmtrans) s ℓ s'): Prop) }. - - Variable model_finitary: forall s1, Finite { '(s2, ℓ) | M.(fmtrans) s1 ℓ s2 }. - - Definition enum_inner_simple (s1: M): list (M * option M.(fmrole)) := - map proj1_sig (@enum _ _ (model_finitary s1)). - - Lemma enum_inner_spec_simple (s1 s2: M) ℓ: - M.(fmtrans) s1 ℓ s2 -> (s2, ℓ) ∈ enum_inner_simple s1. - Proof. - intros H. unfold enum_inner. rewrite elem_of_list_fmap. - exists (exist _ (s2, ℓ) H). split =>//. apply elem_of_enum. - Qed. - - Program Definition enumerate_next_simple (δ1: LM) (oζ : olocale Λ) (c': cfg Λ): - list (LM * @mlabel LM) := - '(s2, ℓ) ← (δ1.(ls_under), None) :: enum_inner_simple δ1.(ls_under); - d ← enumerate_dom_gsets' (dom δ1.(ls_fuel) ∪ live_roles _ s2); - fs ← enum_gmap_bounded' (live_roles _ s2 ∪ d) (max_gmap δ1.(ls_fuel) `max` LM.(lm_fl) s2); - ms ← enum_gmap_range_bounded' (live_roles _ s2 ∪ d) (locales_of_list c'.1); - let ℓ' := match ℓ with - | None => match oζ with - Some ζ => Silent_step ζ - | None => Config_step - end - | Some ℓ => match oζ with - | None => Config_step - | Some ζ => Take_step ℓ ζ - end - end in - mret ({| ls_under := s2; - ls_fuel := `fs; - (* ls_fuel_dom := proj2_sig fs; *) (* TODO: why this does not work?*) - ls_mapping := `ms ; - |}, ℓ'). - Next Obligation. - intros ??????????. destruct fs as [? Heq]. rewrite /= Heq //. set_solver. - Qed. - Next Obligation. - intros ??????????. destruct fs as [? Heq]. destruct ms as [? Heq']. - rewrite /= Heq //. - Qed. - - (* TODO: Derive this from the stronger version *) - Lemma valid_state_evolution_finitary_fairness_simple (φ: execution_trace Λ -> auxiliary_trace LM -> Prop) : - rel_finitary (valid_lift_fairness φ). - Proof. - intros extr auxtr [e' σ'] oζ. - eapply finite_smaller_card_nat. - eapply (in_list_finite (enumerate_next_simple (trace_last auxtr) oζ (e',σ'))). - intros [δ2 ℓ] [[Hlab [Htrans Hsmall]] ?]. - unfold enumerate_next. apply elem_of_list_bind. - exists (δ2.(ls_under), match ℓ with Take_step l _ => Some l | _ => None end). - split; last first. - { destruct ℓ as [ρ tid' | |]. - - inversion Htrans as [Htrans']. apply elem_of_cons; right. by apply enum_inner_spec_simple. - - apply elem_of_cons; left. f_equal. inversion Htrans as (?&?&?&?&?); done. - - apply elem_of_cons; right. inversion Htrans as (?&?). by apply enum_inner_spec_simple. } - apply elem_of_list_bind. eexists (dom $ δ2.(ls_fuel)). split; last first. - { apply enumerate_dom_gsets'_spec. destruct ℓ as [ρ tid' | |]. - - inversion Htrans as (?&?&?&?&?&?&?). intros ρ' Hin. destruct (decide (ρ' ∈ live_roles _ δ2)); first set_solver. - destruct (decide (ρ' ∈ dom $ ls_fuel (trace_last auxtr))); first set_solver. set_solver. - - inversion Htrans as (?&?&?&?&?). set_solver. - - inversion Htrans as (?&?&?&?&?). done. } - apply elem_of_list_bind. - assert (Hfueldom: dom δ2.(ls_fuel) = live_roles M δ2 ∪ dom (ls_fuel δ2)). - { rewrite subseteq_union_1_L //. apply ls_fuel_dom. } - - eexists (δ2.(ls_fuel) ↾ Hfueldom); split; last first. - { eapply enum_gmap_bounded'_spec; split =>//. - intros ρ f Hsome. destruct ℓ as [ρ' tid' | |]. - - destruct (decide (ρ = ρ')) as [-> | Hneq]. - + inversion Htrans as [? Hbig]. destruct Hbig as (Hmap&Hleq&?&Hlim&?&?). - destruct (decide (ρ' ∈ live_roles _ δ2)). - * rewrite Hsome /= in Hlim. - assert (Hlive: ρ' ∈ live_roles _ δ2) by set_solver. - specialize (Hlim Hlive). lia. - * unfold fuel_decr in Hleq. - apply elem_of_dom_2 in Hmap. rewrite ls_same_doms in Hmap. - pose proof Hsome as Hsome'. apply elem_of_dom_2 in Hsome'. - specialize (Hleq ρ' ltac:(done) ltac:(done)). - assert(must_decrease ρ' (Some ρ') (trace_last auxtr) δ2 (Some tid')) as Hmd; first by constructor 3. - specialize (Hleq Hmd). rewrite Hsome /= in Hleq. - apply elem_of_dom in Hmap as [? Heq]. rewrite Heq in Hleq. - pose proof (max_gmap_spec _ _ _ Heq). simpl in *. lia. - + inversion Htrans as [? Hbig]. destruct Hbig as (Hmap&?&Hleq'&?&Hnew&?). - destruct (decide (ρ ∈ dom $ ls_fuel (trace_last auxtr))) as [Hin|Hnotin]. - * assert (Hok: oleq (ls_fuel δ2 !! ρ) (ls_fuel (trace_last auxtr) !! ρ)). - { unfold fuel_must_not_incr in *. - assert (ρ ∈ dom $ ls_fuel (trace_last auxtr)) by SS. - specialize (Hleq' ρ ltac:(done) ltac:(congruence)) as [Hleq'|Hleq'] =>//. apply elem_of_dom_2 in Hsome. set_solver. } - rewrite Hsome in Hok. destruct (ls_fuel (trace_last auxtr) !! ρ) as [f'|] eqn:Heqn; last done. - pose proof (max_gmap_spec _ _ _ Heqn). simpl in *. lia. - * assert (Hok: oleq (ls_fuel δ2 !! ρ) (Some (LM.(lm_fl) δ2))). - { apply Hnew. apply elem_of_dom_2 in Hsome. set_solver. } - rewrite Hsome in Hok. simpl in Hok. lia. - - inversion Htrans as [? [? [Hleq [Hincl Heq]]]]. specialize (Hleq ρ). - assert (ρ ∈ dom $ ls_fuel (trace_last auxtr)) as Hin. - { apply elem_of_dom_2 in Hsome. set_solver. } - specialize (Hleq Hin ltac:(done)) as [Hleq|Hleq]. - + rewrite Hsome in Hleq. destruct (ls_fuel (trace_last auxtr) !! ρ) as [f'|] eqn:Heqn; last done. - pose proof (max_gmap_spec _ _ _ Heqn). simpl in *. lia. - + apply elem_of_dom_2 in Hsome. set_solver. - - inversion Htrans as [? [? [Hleq [Hnew Hfalse]]]]. done. } - apply elem_of_list_bind. - assert (Hmappingdom: dom δ2.(ls_mapping) = live_roles M δ2 ∪ dom (ls_fuel δ2)). - { rewrite -Hfueldom ls_same_doms //. } - - exists (δ2.(ls_mapping) ↾ Hmappingdom); split; last first. - { eapply enum_gmap_range_bounded'_spec; split=>//. - intros ρ' tid' Hsome. unfold tids_smaller in *. - apply locales_of_list_from_locale_from. eauto. } - rewrite elem_of_list_singleton; f_equal. - - destruct δ2; simpl. f_equal; apply ProofIrrelevance. - - destruct ℓ; simpl; destruct oζ =>//; by inversion Hlab. - Unshelve. - + intros ??. apply make_decision. - + intros. apply make_proof_irrel. - + done. - + done. - Qed. -End finitary_simple. - -(* TODO: Why do we need [LM] explicit here? *) -Definition live_rel `(LM: LiveModel Λ M) `{Countable (locale Λ)} - (ex : execution_trace Λ) (aux : auxiliary_trace LM) := - live_tids (LM:=LM) (trace_last ex) (trace_last aux). - -Definition sim_rel `(LM: LiveModel Λ M) `{Countable (locale Λ)} - (ex : execution_trace Λ) (aux : auxiliary_trace LM) := - valid_state_evolution_fairness ex aux ∧ live_rel LM ex aux. - -Definition sim_rel_with_user `(LM: LiveModel Λ M) `{Countable (locale Λ)} - (ξ : execution_trace Λ -> finite_trace M (option (fmrole M)) -> Prop) - (ex : execution_trace Λ) (aux : auxiliary_trace LM) := - sim_rel LM ex aux ∧ ξ ex (map_underlying_trace aux). - -(* TODO: Maybe redefine [sim_rel_with_user] in terms of [valid_lift_fairness] *) -Lemma valid_lift_fairness_sim_rel_with_user `{LM:LiveModel Λ Mdl} - `{Countable (locale Λ)} - (ξ : execution_trace Λ → finite_trace Mdl (option $ fmrole Mdl) → - Prop) extr atr : - valid_lift_fairness - (λ extr auxtr, ξ extr (map_underlying_trace (LM:=LM) auxtr) ∧ - live_rel LM extr auxtr) extr atr ↔ - sim_rel_with_user LM ξ extr atr. -Proof. split; [by intros [Hvalid [Hlive Hξ]]|by intros [[Hvalid Hlive] Hξ]]. Qed. - -Lemma rel_finitary_sim_rel_with_user_ξ `{LM:LiveModel Λ Mdl} - `{Countable (locale Λ)} ξ : - rel_finitary ξ → rel_finitary (sim_rel_with_user LM ξ). -Proof. - intros Hrel. - eapply rel_finitary_impl. - { intros ex aux. by eapply valid_lift_fairness_sim_rel_with_user. - (* TODO: Figure out if these typeclass subgoals should be resolved locally *) - Unshelve. - - intros ??. apply make_decision. - - intros ??. apply make_decision. } - by eapply valid_state_evolution_finitary_fairness. - Unshelve. - - intros ??. apply make_proof_irrel. -Qed. - -Lemma rel_finitary_sim_rel_with_user_sim_rel `{LM:LiveModel Λ Mdl} - `{EqDecision (mstate LM)} `{EqDecision (mlabel LM)} - `{Countable (locale Λ)} ξ : - rel_finitary (sim_rel LM) → rel_finitary (sim_rel_with_user LM ξ). -Proof. - intros Hrel. eapply rel_finitary_impl; [|done]. by intros ex aux [Hsim _]. -Qed. diff --git a/fairness/fuel.v b/fairness/fuel.v deleted file mode 100644 index db4204e0..00000000 --- a/fairness/fuel.v +++ /dev/null @@ -1,775 +0,0 @@ -From stdpp Require Import option. -From Paco Require Import paco1 paco2 pacotac. -From trillium.program_logic Require Export adequacy. -From trillium.fairness Require Export inftraces fairness. - -Section fairness. - Context {Λ : language}. - Context {M: FairModel}. - Context `{Countable (locale Λ)}. - - Record LiveState := MkLiveState { - ls_under:> M.(fmstate); - - ls_fuel: gmap M.(fmrole) nat; - ls_fuel_dom: M.(live_roles) ls_under ⊆ dom ls_fuel; - - ls_mapping: gmap M.(fmrole) (locale Λ); (* maps roles to thread id *) - - ls_same_doms: dom ls_mapping = dom ls_fuel; - }. - - Arguments ls_under {_}. - Arguments ls_fuel {_}. - Arguments ls_fuel_dom {_}. - Arguments ls_mapping {_}. - Arguments ls_same_doms {_}. - - Lemma ls_mapping_dom (m: LiveState): - M.(live_roles) m.(ls_under) ⊆ dom m.(ls_mapping). - Proof. rewrite ls_same_doms. apply ls_fuel_dom. Qed. - - Inductive FairLabel {Roles} := - | Take_step: Roles -> locale Λ -> FairLabel - | Silent_step: locale Λ -> FairLabel - | Config_step: FairLabel - . - Arguments FairLabel : clear implicits. - - Definition less (x y: option nat) := - match x, y with - | Some x, Some y => x < y - | _, _ => False - end. - - Inductive must_decrease (ρ': M.(fmrole)) (oρ: option M.(fmrole)) (a b: LiveState): - olocale Λ -> Prop := - | Same_tid tid (Hneqρ: Some ρ' ≠ oρ) (Hsametid: Some tid = a.(ls_mapping) !! ρ'): - must_decrease ρ' oρ a b (Some tid) - | Change_tid otid (Hneqtid: a.(ls_mapping) !! ρ' ≠ b.(ls_mapping) !! ρ') - (Hissome: is_Some (b.(ls_mapping) !! ρ')): - must_decrease ρ' oρ a b otid - | Zombie otid (Hismainrole: oρ = Some ρ') (Hnotalive: ρ' ∉ live_roles _ b) (Hnotdead: ρ' ∈ dom b.(ls_fuel)): - must_decrease ρ' oρ a b otid - . - - Definition fuel_decr (tid: olocale Λ) (oρ: option M.(fmrole)) - (a b: LiveState) := - ∀ ρ', ρ' ∈ dom a.(ls_fuel) -> ρ' ∈ dom b.(ls_fuel) → - must_decrease ρ' oρ a b tid -> - oless (b.(ls_fuel) !! ρ') (a.(ls_fuel) !! ρ'). - - Definition fuel_must_not_incr oρ (a b: LiveState) := - ∀ ρ', ρ' ∈ dom a.(ls_fuel) -> Some ρ' ≠ oρ -> - (oleq (b.(ls_fuel) !! ρ') (a.(ls_fuel) !! ρ') - ∨ (ρ' ∉ dom b.(ls_fuel) ∧ ρ' ∉ M.(live_roles) a.(ls_under))). - - Definition ls_trans fuel_limit (a: LiveState) ℓ (b: LiveState): Prop := - match ℓ with - | Take_step ρ tid => - M.(fmtrans) a (Some ρ) b - ∧ a.(ls_mapping) !! ρ = Some tid - ∧ fuel_decr (Some tid) (Some ρ) a b - ∧ fuel_must_not_incr (Some ρ) a b - ∧ (ρ ∈ live_roles _ b -> oleq (b.(ls_fuel) !! ρ) (Some (fuel_limit b))) - ∧ (∀ ρ, ρ ∈ dom b.(ls_fuel) ∖ dom a.(ls_fuel) -> oleq (b.(ls_fuel) !! ρ) (Some (fuel_limit b))) - ∧ dom b.(ls_fuel) ∖ dom a.(ls_fuel) ⊆ live_roles _ b ∖ live_roles _ a - | Silent_step tid => - (∃ ρ, a.(ls_mapping) !! ρ = Some tid) - ∧ fuel_decr (Some tid) None a b - ∧ fuel_must_not_incr None a b - ∧ dom b.(ls_fuel) ⊆ dom a.(ls_fuel) - ∧ a.(ls_under) = b.(ls_under) - | Config_step => - M.(fmtrans) a None b - ∧ fuel_decr None None a b - ∧ fuel_must_not_incr None a b - ∧ (∀ ρ, ρ ∈ M.(live_roles) b ∖ M.(live_roles) a -> oleq (b.(ls_fuel) !! ρ) (Some (fuel_limit b))) - ∧ False (* TODO: add support for config steps later! *) - end. - - Record LiveModel := { - lm_fl : M → nat; - lm_ls := LiveState; - lm_lbl := FairLabel M.(fmrole); - lm_ls_trans := ls_trans lm_fl; - }. - - Definition fair_model_model `(LM : LiveModel) : Model := {| - mstate := lm_ls LM; - mlabel := lm_lbl LM; - mtrans := lm_ls_trans LM; - |}. - - Definition tids_smaller (c : list (expr Λ)) (δ: LiveState) := - ∀ ρ ζ, δ.(ls_mapping) !! ρ = Some ζ -> is_Some (from_locale c ζ). - - Program Definition initial_ls `{LM: LiveModel} (s0: M) (ζ0: locale Λ) - : LM.(lm_ls) := - {| ls_under := s0; - ls_fuel := gset_to_gmap (LM.(lm_fl) s0) (M.(live_roles) s0); - ls_mapping := gset_to_gmap ζ0 (M.(live_roles) s0); - |}. - Next Obligation. intros ???. apply reflexive_eq. rewrite dom_gset_to_gmap //. Qed. - Next Obligation. intros ???. apply reflexive_eq. rewrite !dom_gset_to_gmap //. Qed. - - Definition labels_match `{LM:LiveModel} (oζ : olocale Λ) (ℓ : LM.(lm_lbl)) : Prop := - match oζ, ℓ with - | None, Config_step => True - | Some ζ, Silent_step ζ' => ζ = ζ' - | Some ζ, Take_step ρ ζ' => ζ = ζ' - | _, _ => False - end. - -End fairness. - -Arguments LiveState : clear implicits. -Arguments LiveModel : clear implicits. -Arguments fair_model_model _ {_} _. - -Definition live_model_to_model : forall Λ M, LiveModel Λ M -> Model := - λ Λ M lm, fair_model_model Λ lm. -Coercion live_model_to_model : LiveModel >-> Model. -Arguments live_model_to_model {_ _}. - -Definition auxtrace `(LM: LiveModel Λ M) := trace LM.(lm_ls) LM.(lm_lbl). - -Section aux_trace. - Context `{LM: LiveModel Λ M}. - - Definition role_enabled ρ (δ: LiveState Λ M) := ρ ∈ M.(live_roles) δ. - - Definition fair_aux ρ (auxtr: auxtrace LM): Prop := - forall n, pred_at auxtr n (λ δ _, role_enabled ρ δ) -> - ∃ m, pred_at auxtr (n+m) (λ δ _, ¬role_enabled ρ δ) - ∨ pred_at auxtr (n+m) (λ _ ℓ, ∃ tid, ℓ = Some (Take_step ρ tid)). - - Lemma fair_aux_after ρ auxtr n auxtr': - fair_aux ρ auxtr -> - after n auxtr = Some auxtr' -> - fair_aux ρ auxtr'. - Proof. - rewrite /fair_aux => Hfair Hafter m Hpa. - specialize (Hfair (n+m)). - rewrite -> (pred_at_sum _ n) in Hfair. rewrite Hafter in Hfair. - destruct (Hfair Hpa) as (p&Hp). - exists (p). by rewrite <-Nat.add_assoc, ->!(pred_at_sum _ n), Hafter in Hp. - Qed. - - CoInductive auxtrace_valid: auxtrace LM -> Prop := - | auxtrace_valid_singleton δ: auxtrace_valid ⟨δ⟩ - | auxtrace_valid_cons δ ℓ tr: - LM.(lm_ls_trans) δ ℓ (trfirst tr) -> - auxtrace_valid tr → - auxtrace_valid (δ -[ℓ]-> tr). - - Lemma auxtrace_valid_forall (tr: auxtrace LM) : - auxtrace_valid tr -> - ∀ n, match after n tr with - | Some ⟨ _ ⟩ | None => True - | Some (δ -[ℓ]-> tr') => LM.(lm_ls_trans) δ ℓ (trfirst tr') - end. - Proof. - intros Hval n. revert tr Hval. induction n as [|n]; intros tr Hval; - destruct (after _ tr) as [trn|] eqn: Heq =>//; simpl in Heq; - simplify_eq; destruct trn =>//; inversion Hval; simplify_eq; try done. - specialize (IHn _ H0) (* TODO *). rewrite Heq in IHn. done. - Qed. - -End aux_trace. - -Ltac SS := - epose proof ls_fuel_dom; - (* epose proof ls_mapping_dom; *) - set_solver. - -Definition live_tids `{LM:LiveModel Λ M} `{EqDecision (locale Λ)} - (c : cfg Λ) (δ : LM.(lm_ls)) : Prop := - (∀ ρ ζ, δ.(ls_mapping (Λ := Λ)) !! ρ = Some ζ -> is_Some (from_locale c.1 ζ)) ∧ - ∀ ζ e, from_locale c.1 ζ = Some e -> (to_val e ≠ None) -> - ∀ ρ, δ.(ls_mapping) !! ρ ≠ Some ζ. - -Definition exaux_traces_match `{LM:LiveModel Λ M} `{EqDecision (locale Λ)} : - extrace Λ → auxtrace LM → Prop := - traces_match labels_match - live_tids - locale_step - LM.(lm_ls_trans). - -Section fairness_preserved. - Context `{LM: LiveModel Λ M}. - Context `{Countable (locale Λ)}. - - Lemma exaux_preserves_validity extr (auxtr : auxtrace LM): - exaux_traces_match extr auxtr -> - auxtrace_valid auxtr. - Proof. - revert extr auxtr. cofix CH. intros extr auxtr Hmatch. - inversion Hmatch; first by constructor. - constructor =>//. by eapply CH. - Qed. - - Lemma exaux_preserves_termination extr (auxtr : auxtrace LM) : - exaux_traces_match extr auxtr -> - terminating_trace auxtr -> - terminating_trace extr. - Proof. - intros Hmatch [n HNone]. - revert extr auxtr Hmatch HNone. induction n as [|n IHn]; first done. - intros extr auxtr Hmatch HNone. - replace (S n) with (1 + n) in HNone =>//. - rewrite (after_sum' _ 1) in HNone. - destruct auxtr as [s| s ℓ auxtr']; - first by inversion Hmatch; simplify_eq; exists 1. - simpl in HNone. - inversion Hmatch; simplify_eq. - apply terminating_trace_cons. - eapply IHn =>//. - Qed. - - Lemma traces_match_labels tid ℓ c δ rex (raux : auxtrace LM) : - exaux_traces_match (c -[Some tid]-> rex) (δ -[ℓ]-> raux) -> - ((∃ ρ, ℓ = Take_step ρ tid) ∨ (ℓ = Silent_step tid)). - Proof. - intros Hm. inversion Hm as [|?????? Hlab]; simplify_eq. - destruct ℓ; eauto; inversion Hlab; simplify_eq; eauto. - Qed. - - Lemma mapping_live_role (δ: LiveState Λ M) ρ: - ρ ∈ M.(live_roles) δ -> - is_Some (ls_mapping (Λ := Λ) δ !! ρ). - Proof. rewrite -elem_of_dom ls_same_doms. SS. Qed. - Lemma fuel_live_role (δ: LiveState Λ M) ρ: - ρ ∈ M.(live_roles) δ -> - is_Some (ls_fuel (Λ := Λ) δ !! ρ). - Proof. rewrite -elem_of_dom. SS. Qed. - - Local Hint Resolve mapping_live_role: core. - Local Hint Resolve fuel_live_role: core. - - Lemma match_locale_enabled (extr : extrace Λ) (auxtr : auxtrace LM) ζ ρ: - exaux_traces_match extr auxtr -> - ls_mapping (trfirst auxtr) !! ρ = Some ζ -> - locale_enabled ζ (trfirst extr). - Proof. - intros Hm Hloc. - rewrite /locale_enabled. have [HiS Hneqloc] := traces_match_first _ _ _ _ _ _ Hm. - have [e Hein] := (HiS _ _ Hloc). exists e. split; first done. - destruct (to_val e) eqn:Heqe =>//. - exfalso. specialize (Hneqloc ζ e Hein). rewrite Heqe in Hneqloc. - have Hv: Some v ≠ None by []. by specialize (Hneqloc Hv ρ). - Qed. - - Local Hint Resolve match_locale_enabled: core. - Local Hint Resolve pred_first_trace: core. - - Definition fairness_induction_stmt ρ fm f m ζ extr (auxtr : auxtrace LM) δ c := - (infinite_trace extr -> - (forall ζ, fair_ex ζ extr) -> - fm = (f, m) -> - exaux_traces_match extr auxtr -> - c = trfirst extr -> δ = trfirst auxtr -> - δ.(ls_fuel) !! ρ = Some f -> - δ.(ls_mapping) !! ρ = Some ζ -> - (pred_at extr m (λ c _, ¬locale_enabled ζ c) ∨ pred_at extr m (λ _ oζ, oζ = Some (Some ζ))) -> - ∃ M, pred_at auxtr M (λ δ _, ¬role_enabled ρ δ) - ∨ pred_at auxtr M (λ _ ℓ, ∃ ζ0, ℓ = Some (Take_step ρ ζ0))). - - Local Lemma case1 ρ f m (extr' : extrace Λ) (auxtr' : auxtrace LM) δ ℓ : - (∀ m0 : nat * nat, - strict lt_lex m0 (f, m) - → ∀ (f m: nat) (ζ: locale Λ) (extr : extrace Λ) (auxtr : auxtrace LM) - (δ : LiveState Λ M) (c : cfg Λ), fairness_induction_stmt ρ m0 f m ζ extr auxtr δ c) -> - (ρ ∈ dom (ls_fuel (trfirst auxtr')) → oless (ls_fuel (trfirst auxtr') !! ρ) (ls_fuel δ !! ρ)) -> - exaux_traces_match extr' auxtr' -> - infinite_trace extr' -> - ls_fuel δ !! ρ = Some f -> - (∀ ζ, fair_ex ζ extr') -> - ∃ M0 : nat, - pred_at (δ -[ ℓ ]-> auxtr') M0 - (λ δ0 _, ¬ role_enabled ρ δ0) - ∨ pred_at (δ -[ ℓ ]-> auxtr') M0 - (λ _ ℓ, ∃ ζ0, ℓ = Some (Take_step ρ ζ0)). - Proof. - intros IH Hdec Hmatch Hinf Hsome Hfair. - unfold oless in Hdec. - simpl in *. - rewrite -> Hsome in *. - destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq. - - destruct (decide (ρ ∈ live_roles M (trfirst auxtr'))) as [Hρlive'|]; last first. - { exists 1. left. unfold pred_at. simpl. destruct auxtr'; eauto. } - have [ζ' Hζ'] : is_Some (ls_mapping (trfirst auxtr') !! ρ) by eauto. - - have Hloc'en: pred_at extr' 0 (λ (c : cfg Λ) (_ : option (olocale Λ)), - locale_enabled ζ' c). - { rewrite /pred_at /= pred_first_trace. eauto. } - - have [p Hp] := (Hfair ζ' 0 Hloc'en). - have [P Hind] : ∃ M0 : nat, pred_at auxtr' M0 (λ (δ0 : LiveState Λ M) _, ¬ role_enabled ρ δ0) - ∨ pred_at auxtr' M0 (λ (_ : LiveState Λ M) ℓ, ∃ ζ0, ℓ = Some (Take_step ρ ζ0)). - { eapply (IH _ _ _ p _ extr'); eauto. - Unshelve. unfold strict, lt_lex. specialize (Hdec ltac:(by eapply elem_of_dom_2)). lia. } - exists (1+P). rewrite !pred_at_sum. simpl. done. - - exists 1. left. rewrite /pred_at /=. rewrite /role_enabled. - destruct auxtr' =>/=. - + apply not_elem_of_dom in Heq; eapply not_elem_of_weaken; last (by apply ls_fuel_dom); set_solver. - + apply not_elem_of_dom in Heq; eapply not_elem_of_weaken; last (by apply ls_fuel_dom); set_solver. - Qed. - - Lemma fairness_preserved_ind ρ: - ∀ fm f m ζ (extr: extrace Λ) (auxtr: auxtrace LM) δ c, - fairness_induction_stmt ρ fm f m ζ extr auxtr δ c. - Proof. - induction fm as [fm IH] using lex_ind. - intros f m ζ extr auxtr δ c Hexinfin Hfair -> Htm -> -> Hfuel Hmapping Hexen. - destruct extr as [|c ζ' extr'] eqn:Heq. - { have [??] := Hexinfin 1. done. } - have Hfair': (forall ζ, fair_ex ζ extr'). - { intros. by eapply fair_ex_cons. } - destruct auxtr as [|δ ℓ auxtr']; first by inversion Htm. - destruct (decide (ρ ∈ live_roles M δ)) as [Hρlive|]; last first. - { exists 0. left. unfold pred_at. simpl. intros contra. eauto. } - destruct (decide (Some ζ = ζ')) as [Hζ|Hζ]. - - rewrite <- Hζ in *. - destruct (traces_match_labels _ _ _ _ _ _ Htm) as [[ρ' ->]| ->]; last first. - + inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. - unfold ls_trans in Hls. - destruct Hls as (? & Hlsdec & Hlsincr). - unfold fuel_decr in Hlsdec. - have Hmustdec: must_decrease ρ None δ (trfirst auxtr') (Some ζ). - { constructor; eauto. } - eapply case1 =>//. - * move=> Hinfuel; apply Hlsdec => //; first set_solver. - * eapply infinite_cons =>//. - + (* Three cases: *) -(* (1) ρ' = ρ and we are done *) -(* (2) ρ' ≠ ρ but they share the same ρ -> ρ decreases *) -(* (3) ρ' ≠ ρ and they don't have the same tid -> *) -(* impossible because tid and the label must match! *) - inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. - destruct (decide (ρ = ρ')) as [->|Hρneq]. - { exists 0. right. rewrite /pred_at /=. eauto. } - destruct Hls as (?&Hsame&Hdec&Hnotinc&_). - rewrite -Hsame /= in Hmapping. - have Hmustdec: must_decrease ρ (Some ρ') δ (trfirst auxtr') (Some ζ). - { constructor; eauto; congruence. } - (* Copy and paste begins here *) - eapply case1 =>//; last by eauto using infinite_cons. - intros Hinfuels. apply Hdec =>//. SS. - - (* Another thread is taking a step. *) - destruct (decide (ρ ∈ live_roles M (trfirst auxtr'))) as [Hρlive'|]; last first. - { exists 1. left. unfold pred_at. simpl. destruct auxtr'; eauto. } - have [ζ'' Hζ''] : is_Some (ls_mapping (trfirst auxtr') !! ρ) by eauto. - destruct (decide (ζ = ζ'')) as [<-|Hchange]. - + have [f' [Hfuel' Hff']] : exists f', ls_fuel (trfirst auxtr') !! ρ = Some f' ∧ f' ≤ f. - { destruct ζ' as [ζ'|]; last first; simpl in *. - - inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. - simpl in *. destruct ℓ; try done. destruct Hls as [_ [_ [Hnoninc _]]]. - have HnotNone: Some ρ ≠ None by congruence. - specialize (Hnoninc ρ ltac:(SS) HnotNone). - unfold oleq in Hnoninc. rewrite Hfuel in Hnoninc. - destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [|set_solver]. - eexists; split =>//. destruct Hnoninc as [Hnoninc|Hnoninc]=>//. - apply elem_of_dom_2 in Heq. set_solver. - - inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. - simpl in *. destruct ℓ as [ρ0 ζ0| ζ0|]; try done. - + destruct Hls as (?&?&?&Hnoninc&?). - unfold fuel_must_not_incr in Hnoninc. - have Hneq: Some ρ ≠ Some ρ0 by congruence. - specialize (Hnoninc ρ ltac:(SS) Hneq). - unfold oleq in Hnoninc. rewrite Hfuel in Hnoninc. - destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [|set_solver]. - eexists; split =>//. destruct Hnoninc as [Hnoninc|Hnoninc]=>//. - apply elem_of_dom_2 in Heq. set_solver. - + destruct Hls as (?&?&Hnoninc&?). - unfold fuel_must_not_incr in Hnoninc. - have Hneq: Some ρ ≠ None by congruence. - specialize (Hnoninc ρ ltac:(SS) Hneq). - unfold oleq in Hnoninc. rewrite Hfuel in Hnoninc. - destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [|set_solver]. - eexists; split =>//. destruct Hnoninc as [Hnoninc|Hnoninc]=>//. - apply elem_of_dom_2 in Heq. set_solver. } - - unfold fair_ex in *. - have Hζ'en: pred_at extr' 0 (λ (c : cfg Λ) _, locale_enabled ζ c). - { rewrite /pred_at /= pred_first_trace. inversion Htm; eauto. } - destruct m as [| m']. - { rewrite -> !pred_at_0 in Hexen. destruct Hexen as [Hexen|Hexen]. - - exfalso. apply Hexen. unfold locale_enabled. by eapply (match_locale_enabled _ _ _ _ Htm). - - simplify_eq. } - - have [P Hind] : ∃ M0 : nat, pred_at auxtr' M0 (λ δ0 _, ¬ role_enabled ρ δ0) - ∨ pred_at auxtr' M0 (λ _ ℓ, ∃ ζ0, ℓ = Some (Take_step ρ ζ0)). - { eapply (IH _ _ _ m' _ extr'); eauto. by eapply infinite_cons. by inversion Htm. - Unshelve. unfold strict, lt_lex. lia. } - exists (1+P). rewrite !pred_at_sum. simpl. done. - + have [f' [Hfuel' Hff']] : exists f', ls_fuel (trfirst auxtr') !! ρ = Some f' ∧ f' < f. - { destruct ζ' as [ζ'|]; last first; simpl in *. - - inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. - simpl in *. destruct ℓ; try done. destruct Hls as [_ [Hdec _]]. - unfold fuel_decr in Hdec. - have Hmd: must_decrease ρ None δ (trfirst auxtr') None. - { econstructor. congruence. rewrite Hζ''. eauto. } - specialize (Hdec ρ ltac:(SS) ltac:(SS) Hmd). - unfold oleq in Hdec. rewrite Hfuel in Hdec. - destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [by eexists|done]. - - inversion Htm as [|s1 ℓ1 r1 s2 ℓ2 r2 Hl Hs Hts Hls Hmatchrest]; simplify_eq. - simpl in *. destruct ℓ as [ρ0 ζ0| ζ0|]; try done. - + destruct Hls as (?&?&Hdec&?&?). - unfold fuel_decr in Hdec. simplify_eq. - have Hmd: must_decrease ρ (Some ρ0) δ (trfirst auxtr') (Some ζ0). - { econstructor 2. congruence. rewrite Hζ''; eauto. } - specialize (Hdec ρ ltac:(SS) ltac:(SS) Hmd). - unfold oleq in Hdec. rewrite Hfuel in Hdec. - destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [by eexists|done]. - + destruct Hls as (?&Hdec&_). - unfold fuel_decr in Hdec. simplify_eq. - have Hmd: must_decrease ρ None δ (trfirst auxtr') (Some ζ0). - { econstructor 2. congruence. rewrite Hζ''; eauto. } - specialize (Hdec ρ ltac:(SS) ltac:(SS) Hmd). - unfold oleq in Hdec. rewrite Hfuel in Hdec. - destruct (ls_fuel (trfirst auxtr') !! ρ) as [f'|] eqn:Heq; [by eexists|done]. } - - unfold fair_ex in *. - have: pred_at extr' 0 (λ c _, locale_enabled ζ'' c). - { rewrite /pred_at /= pred_first_trace. inversion Htm; eauto. } - have Hζ'en: pred_at extr' 0 (λ c _, locale_enabled ζ'' c). - { rewrite /pred_at /= pred_first_trace. inversion Htm; eauto. } - have [p Hp] := (Hfair' ζ'' 0 Hζ'en). - have [P Hind] : ∃ M0 : nat, pred_at auxtr' M0 (λ δ0 _, ¬ role_enabled ρ δ0) - ∨ pred_at auxtr' M0 (λ _ ℓ, ∃ ζ0, ℓ = Some (Take_step ρ ζ0)). - { eapply (IH _ _ _ p _ extr'); eauto. by eapply infinite_cons. by inversion Htm. - Unshelve. unfold strict, lt_lex. lia. } - exists (1+P). rewrite !pred_at_sum. simpl. done. - Qed. - - Theorem fairness_preserved (extr: extrace Λ) (auxtr: auxtrace LM): - infinite_trace extr -> - exaux_traces_match extr auxtr -> - (forall ζ, fair_ex ζ extr) -> (forall ρ, fair_aux ρ auxtr). - Proof. - intros Hinfin Hmatch Hex ρ n Hn. - unfold pred_at in Hn. - destruct (after n auxtr) as [tr|] eqn:Heq =>//. - setoid_rewrite pred_at_sum. rewrite Heq. - have Hen: role_enabled ρ (trfirst tr) by destruct tr. - have [ζ Hζ] : is_Some((trfirst tr).(ls_mapping) !! ρ) by eauto. - have [f Hfuel] : is_Some((trfirst tr).(ls_fuel) !! ρ) by eauto. - have Hex' := Hex ζ n. - have [tr1' [Heq' Htr]] : exists tr1', after n extr = Some tr1' ∧ exaux_traces_match tr1' tr - by eapply traces_match_after. - have Hte: locale_enabled ζ (trfirst tr1'). - { rewrite /locale_enabled. have [HiS Hneqζ] := traces_match_first _ _ _ _ _ _ Htr. - have [e Hein] := (HiS _ _ Hζ). exists e. split; first done. - destruct (to_val e) eqn:Heqe =>//. - exfalso. specialize (Hneqζ ζ e Hein). rewrite Heqe in Hneqζ. - have HnotNull: Some v ≠ None by []. specialize (Hneqζ HnotNull ρ). done. } - setoid_rewrite pred_at_sum in Hex'. rewrite Heq' in Hex'. - have Hpa: pred_at extr n (λ c _, locale_enabled ζ c). - { unfold pred_at. rewrite Heq'. destruct tr1'; eauto. } - destruct (Hex' Hpa) as [m Hm]. - have ?: infinite_trace tr1'. - { have Hinf := infinite_trace_after n extr Hinfin. by rewrite Heq' in Hinf. } - eapply (fairness_preserved_ind ρ _ f m ζ _ tr); eauto. - intros ?. by eapply fair_ex_after. - Qed. - - Tactic Notation "inv" open_constr(P) := match goal with - | [H: P |- _] => inversion H; clear H; simplify_eq - end. - - (* TODO: Why do we need explicit [LM] here? *) - Definition valid_state_evolution_fairness - (extr : execution_trace Λ) (auxtr : auxiliary_trace LM) := - match extr, auxtr with - | (extr :tr[oζ]: (es, σ)), auxtr :tr[ℓ]: δ => - labels_match (LM:=LM) oζ ℓ ∧ LM.(lm_ls_trans) (trace_last auxtr) ℓ δ ∧ - tids_smaller es δ - | _, _ => True - end. - - Definition valid_lift_fairness - (φ: execution_trace Λ -> auxiliary_trace LM -> Prop) - (extr : execution_trace Λ) (auxtr : auxiliary_trace LM) := - valid_state_evolution_fairness extr auxtr ∧ φ extr auxtr. - - (* TODO: Why do we need explicit [LM] here? *) - Lemma valid_inf_system_trace_implies_traces_match_strong - (φ : execution_trace Λ -> auxiliary_trace LM -> Prop) - (ψ : _ → _ → Prop) - ex atr iex iatr progtr (auxtr : auxtrace LM): - (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), - φ ex atr -> live_tids (LM:=LM) (trace_last ex) (trace_last atr)) -> - (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), - φ ex atr -> valid_state_evolution_fairness ex atr) -> - (∀ extr auxtr, φ extr auxtr → ψ (trace_last extr) (trace_last auxtr)) → - exec_trace_match ex iex progtr -> - exec_trace_match atr iatr auxtr -> - valid_inf_system_trace φ ex atr iex iatr -> - traces_match labels_match - (λ σ δ, live_tids σ δ ∧ ψ σ δ) - locale_step - LM.(lm_ls_trans) progtr auxtr. - Proof. - intros Hφ1 Hφ2 Hφψ. - revert ex atr iex iatr auxtr progtr. cofix IH. - intros ex atr iex iatr auxtr progtr Hem Ham Hval. - inversion Hval as [?? Hphi |ex' atr' c [? σ'] δ' iex' iatr' oζ ℓ Hphi [=] ? Hinf]; simplify_eq. - - inversion Hem; inversion Ham. econstructor; eauto. - pose proof (Hφ1 ex atr Hphi). - split; [by simplify_eq|]. simplify_eq. by apply Hφψ. - - inversion Hem; inversion Ham. subst. - pose proof (valid_inf_system_trace_inv _ _ _ _ _ Hinf) as Hphi'. - destruct (Hφ2 (ex :tr[ oζ ]: (l, σ')) (atr :tr[ ℓ ]: δ') Hphi') as (?&?&?). - econstructor. - + eauto. - + eauto. - + match goal with - | [H: exec_trace_match _ iex' _ |- _] => inversion H; clear H; simplify_eq - end; done. - + match goal with - | [H: exec_trace_match _ iatr' _ |- _] => inversion H; clear H; simplify_eq - end; done. - + eapply IH; eauto. - Qed. - - (* TODO: Why do we need explicit [LM] here? *) - Lemma valid_inf_system_trace_implies_traces_match - (φ: execution_trace Λ -> auxiliary_trace LM -> Prop) - ex atr iex iatr progtr (auxtr : auxtrace LM): - (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), - φ ex atr -> live_tids (LM:=LM) (trace_last ex) (trace_last atr)) -> - (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), - φ ex atr -> valid_state_evolution_fairness ex atr) -> - exec_trace_match ex iex progtr -> - exec_trace_match atr iatr auxtr -> - valid_inf_system_trace φ ex atr iex iatr -> - exaux_traces_match progtr auxtr. - Proof. - intros Hφ1 Hφ2. - revert ex atr iex iatr auxtr progtr. cofix IH. - intros ex atr iex iatr auxtr progtr Hem Ham Hval. - inversion Hval as [?? Hphi |ex' atr' c [? σ'] δ' iex' iatr' oζ ℓ Hphi [=] ? Hinf]; simplify_eq. - - inversion Hem; inversion Ham. econstructor; eauto. - pose proof (Hφ1 ex atr Hphi). - by simplify_eq. - - inversion Hem; inversion Ham. subst. - pose proof (valid_inf_system_trace_inv _ _ _ _ _ Hinf) as Hphi'. - destruct (Hφ2 (ex :tr[ oζ ]: (l, σ')) (atr :tr[ ℓ ]: δ') Hphi') as (?&?&?). - econstructor. - + eauto. - + eauto. - + match goal with - | [H: exec_trace_match _ iex' _ |- _] => inversion H; clear H; simplify_eq - end; done. - + match goal with - | [H: exec_trace_match _ iatr' _ |- _] => inversion H; clear H; simplify_eq - end; done. - + eapply IH; eauto. - Qed. - -End fairness_preserved. - -Section fuel_dec_unless. - Context `{LM: LiveModel Λ Mdl}. - Context `{Countable (locale Λ)}. - - Definition Ul (ℓ: LM.(mlabel)) := - match ℓ with - | Take_step ρ _ => Some (Some ρ) - | _ => None - end. - - Definition Ψ (δ: LiveState Λ Mdl) := - size δ.(ls_fuel) + [^ Nat.add map] ρ ↦ f ∈ δ.(ls_fuel (Λ := Λ)), f. - - Lemma fuel_dec_unless (auxtr: auxtrace LM) : - auxtrace_valid auxtr -> - dec_unless ls_under Ul Ψ auxtr. - Proof. - intros Hval n. revert auxtr Hval. induction n; intros auxtr Hval; last first. - { edestruct (after (S n) auxtr) as [auxtrn|] eqn:Heq; rewrite Heq =>//. - simpl in Heq; - simplify_eq. destruct auxtrn as [|δ ℓ auxtr']=>//; last first. - inversion Hval as [|???? Hmatch]; simplify_eq =>//. - specialize (IHn _ Hmatch). rewrite Heq // in IHn. } - edestruct (after 0 auxtr) as [auxtrn|] eqn:Heq; rewrite Heq =>//. - simpl in Heq; simplify_eq. destruct auxtrn as [|δ ℓ auxtr']=>//; last first. - - inversion Hval as [|??? Htrans Hmatch]; simplify_eq =>//. - destruct ℓ as [| tid' |]; - [left; eexists; done| right | inversion Htrans; naive_solver ]. - destruct Htrans as (Hne&Hdec&Hni&Hincl&Heq). rewrite -> Heq in *. split; last done. - - destruct (decide (dom $ ls_fuel δ = dom $ ls_fuel (trfirst auxtr'))) as [Hdomeq|Hdomneq]. - - destruct Hne as [ρ Hρtid]. - - assert (ρ ∈ dom $ ls_fuel δ) as Hin by rewrite -ls_same_doms elem_of_dom //. - pose proof Hin as Hin'. pose proof Hin as Hin''. - apply elem_of_dom in Hin as [f Hf]. - rewrite Hdomeq in Hin'. apply elem_of_dom in Hin' as [f' Hf']. - rewrite /Ψ -!size_dom Hdomeq. - apply Nat.add_lt_mono_l. - - rewrite /Ψ (big_opM_delete (λ _ f, f) (ls_fuel (trfirst _)) ρ) //. - rewrite (big_opM_delete (λ _ f, f) (ls_fuel δ) ρ) //. - apply Nat.add_lt_le_mono. - { rewrite /fuel_decr in Hdec. specialize (Hdec ρ). rewrite Hf Hf' /= in Hdec. - apply Hdec; [set_solver | set_solver | by econstructor]. } - - apply big_addM_leq_forall => ρ' Hρ'. - rewrite dom_delete_L in Hρ'. - have Hρneqρ' : ρ ≠ ρ' by set_solver. - rewrite !lookup_delete_ne //. - destruct (decide (ρ' ∈ dom δ.(ls_fuel))) as [Hin|Hnotin]; last set_solver. - rewrite /fuel_must_not_incr in Hni. - destruct (Hni ρ' ltac:(done) ltac:(done)); [done|set_solver]. - - assert (size $ ls_fuel (trfirst auxtr') < size $ ls_fuel δ). - { rewrite -!size_dom. apply subset_size. set_solver. } - apply Nat.add_lt_le_mono =>//. - apply big_addM_leq_forall => ρ' Hρ'. - destruct (Hni ρ' ltac:(set_solver) ltac:(done)); [done|set_solver]. - Qed. -End fuel_dec_unless. - -Section destuttering_auxtr. - Context `{LM: LiveModel Λ M}. - - Context `{Countable (locale Λ)}. - - (* Why is [LM] needed here? *) - Definition upto_stutter_auxtr := - upto_stutter (ls_under (Λ:=Λ) (M:=M)) (Ul (LM := LM)). - - Lemma can_destutter_auxtr auxtr: - auxtrace_valid auxtr → - ∃ mtr, upto_stutter_auxtr auxtr mtr. - Proof. - intros ?. eapply can_destutter. - eapply fuel_dec_unless =>//. - Qed. - -End destuttering_auxtr. - -Section upto_preserves. - Context `{LM: LiveModel Λ M}. - Context `{Countable (locale Λ)}. - - Lemma upto_stutter_mono' : - monotone2 (upto_stutter_ind (ls_under (Λ:=Λ) (M:=M)) (Ul (LM:=LM))). - Proof. - unfold monotone2. intros x0 x1 r r' IN LE. - induction IN; try (econstructor; eauto; done). - Qed. - Hint Resolve upto_stutter_mono' : paco. - - Lemma upto_preserves_validity (auxtr : auxtrace LM) mtr: - upto_stutter_auxtr auxtr mtr -> - auxtrace_valid auxtr -> - mtrace_valid mtr. - Proof. - revert auxtr mtr. pcofix CH. intros auxtr mtr Hupto Hval. - punfold Hupto. - induction Hupto as [| |btr str δ ????? IH]. - - pfold. constructor. - - apply IHHupto. inversion Hval. assumption. - - pfold; constructor=>//. - + subst. inversion Hval as [| A B C Htrans E F ] =>//. subst. unfold ls_trans in *. - destruct ℓ; try done. simpl in *. simplify_eq. - destruct Htrans as [??]. - have <- //: ls_under $ trfirst btr = trfirst str. - { destruct IH as [IH|]; last done. punfold IH. inversion IH =>//. } - + right. eapply CH. - { destruct IH =>//. } - subst. by inversion Hval. - Qed. - -End upto_preserves. - -Section upto_stutter_preserves_fairness_and_termination. - Context `{LM: LiveModel Λ M}. - Context `{Countable (locale Λ)}. - - Notation upto_stutter_aux := (upto_stutter (ls_under (Λ := Λ)) (Ul (Λ := Λ) (LM := LM))). - - Lemma upto_stutter_mono'' : (* TODO fix this proliferation *) - monotone2 (upto_stutter_ind (ls_under (Λ:=Λ) (M:=M)) (Ul (LM:=LM))). - Proof. - unfold monotone2. intros x0 x1 r r' IN LE. - induction IN; try (econstructor; eauto; done). - Qed. - Hint Resolve upto_stutter_mono' : paco. - - Lemma upto_stutter_fairness_0 ρ auxtr (mtr: mtrace M): - upto_stutter_aux auxtr mtr -> - (* role_enabled_model ρ (trfirst mtr) -> *) - (∃ n, pred_at auxtr n (λ δ _, ¬role_enabled (Λ := Λ) ρ δ) - ∨ pred_at auxtr n (λ _ ℓ, ∃ ζ, ℓ = Some (Take_step ρ ζ))) -> - ∃ m, pred_at mtr m (λ δ _, ¬role_enabled_model ρ δ) - ∨ pred_at mtr m (λ _ ℓ, ℓ = Some $ Some ρ). - Proof. - intros Hupto (* Hre *) [n Hstep]. - revert auxtr mtr Hupto (* Hre *) Hstep. - induction n as [|n]; intros auxtr mtr Hupto (* Hre *) Hstep. - - punfold Hupto. inversion Hupto; simplify_eq. - + destruct Hstep as [Hpa|[??]]; try done. - exists 0. left. rewrite /pred_at /=. rewrite /pred_at //= in Hpa. - + rewrite -> !pred_at_0 in Hstep. exists 0. - destruct Hstep as [Hstep| [tid Hstep]]; [left|right]. - * rewrite /pred_at /=. destruct mtr; simpl in *; try congruence. - * exfalso. injection Hstep => Heq. rewrite -> Heq in *. - unfold Ul in *. congruence. - + rewrite -> !pred_at_0 in Hstep. exists 0. - destruct Hstep as [Hstep| [tid Hstep]]; [left|right]. - * rewrite /pred_at //=. - * rewrite /pred_at //=. injection Hstep. intros Heq. simplify_eq. - unfold Ul in *. congruence. - - punfold Hupto. inversion Hupto as [| |?????? ?? IH ]; simplify_eq. - + destruct Hstep as [?|?]; done. - + rewrite -> !pred_at_S in Hstep. - eapply IHn; eauto. - by pfold. - + destruct (decide (ℓ' = Some ρ)). - * simplify_eq. - exists 0. right. rewrite pred_at_0 //. - * have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). - { intros P [x ?]. by exists (S x). } - apply Hw. setoid_rewrite pred_at_S. - eapply IHn; eauto. - { destruct IH as [|]; done. } - Qed. - - Lemma upto_stutter_fairness (auxtr:auxtrace LM) (mtr: mtrace M): - upto_stutter_aux auxtr mtr -> - (∀ ρ, fair_aux ρ auxtr) -> - (∀ ρ, fair_model_trace ρ mtr). - Proof. - intros Hupto Hfa ρ n Hpmod. - unfold pred_at in Hpmod. - destruct (after n mtr) as [mtr'|] eqn:Heq; last done. - destruct (upto_stutter_after _ _ n Hupto Heq) as (n'&auxtr'&Heq'&Hupto'). - have Hre: role_enabled_model ρ (trfirst mtr') by destruct mtr'. - specialize (Hfa ρ). - have Henaux : role_enabled ρ (trfirst auxtr'). - { have HUs: ls_under (trfirst auxtr') = trfirst mtr'. - - punfold Hupto'. by inversion Hupto'. - - unfold role_enabled, role_enabled_model in *. - rewrite HUs //. } - have Hfa' := (fair_aux_after ρ auxtr n' auxtr' Hfa Heq' 0). - have Hpredat: pred_at auxtr' 0 (λ δ _, role_enabled ρ δ). - { rewrite /pred_at /=. destruct auxtr'; done. } - destruct (upto_stutter_fairness_0 ρ auxtr' mtr' Hupto' (Hfa' Hpredat)) as (m&Hres). - exists m. rewrite !(pred_at_sum _ n) Heq //. - Qed. - - Lemma upto_stutter_finiteness auxtr (mtr: mtrace M): - upto_stutter_aux auxtr mtr -> - terminating_trace mtr -> - terminating_trace auxtr. - Proof. - intros Hupto [n Hfin]. - have [n' ?] := upto_stutter_after_None _ _ n Hupto Hfin. - eexists; done. - Qed. - -End upto_stutter_preserves_fairness_and_termination. diff --git a/fairness/fuel_termination.v b/fairness/fuel_termination.v deleted file mode 100644 index 95a3f71c..00000000 --- a/fairness/fuel_termination.v +++ /dev/null @@ -1,60 +0,0 @@ -From stdpp Require Import option. -From Paco Require Import pacotac. -From trillium.fairness Require Export fairness fair_termination fuel. - -Definition auxtrace_fairly_terminating {Λ} {Mdl : FairModel} - {LM : LiveModel Λ Mdl} (auxtr : auxtrace LM) := - auxtrace_valid (LM:=LM) auxtr → - (∀ ρ, fair_aux ρ auxtr) → - terminating_trace auxtr. - -Theorem continued_simulation_fair_termination - `{FairTerminatingModel FM} `(LM:LiveModel Λ FM) `{Countable (locale Λ)} - (ξ : execution_trace Λ → auxiliary_trace LM → Prop) a1 r1 extr : - (* TODO: This is required for destruttering - Not sure why *) - (∀ c c', locale_step (Λ := Λ) c None c' -> False) → - (* The relation must capture that live tids correspond *) - (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), - ξ ex atr -> live_tids (LM:=LM) (trace_last ex) (trace_last atr)) -> - (* The relation must capture that the traces evolve fairly *) - (forall (ex: execution_trace Λ) (atr: auxiliary_trace LM), - ξ ex atr -> valid_state_evolution_fairness ex atr) → - continued_simulation - ξ ({tr[trfirst extr]}) ({tr[initial_ls a1 r1]}) → - extrace_fairly_terminating extr. -Proof. - intros Hstep Hlive Hvalid Hsim Hvex. - destruct (infinite_or_finite extr) as [Hinf|]; [|by intros ?]. - assert (∃ iatr, - valid_inf_system_trace - (continued_simulation ξ) - (trace_singleton (trfirst extr)) - (trace_singleton (initial_ls a1 r1)) - (from_trace extr) - iatr) as [iatr Hiatr]. - { eexists _. eapply produced_inf_aux_trace_valid_inf. econstructor. - Unshelve. - - done. - - eapply from_trace_preserves_validity; eauto; first econstructor. } - assert (∃ (auxtr : auxtrace LM), exaux_traces_match extr auxtr) - as [auxtr Hmatch]. - { exists (to_trace (initial_ls a1 r1) iatr). - eapply (valid_inf_system_trace_implies_traces_match - (continued_simulation ξ)); eauto. - - intros ? ? ?%continued_simulation_rel. by apply Hlive. - - intros ? ? ?%continued_simulation_rel. by apply Hvalid. - - by apply from_trace_spec. - - by apply to_trace_spec. } - intros Hfair. - assert (auxtrace_valid auxtr) as Hstutter. - { by eapply exaux_preserves_validity. } - apply can_destutter_auxtr in Hstutter. - destruct Hstutter as [mtr Hupto]. - have Hfairaux := fairness_preserved extr auxtr Hinf Hmatch Hfair. - have Hvalaux := exaux_preserves_validity extr auxtr Hmatch. - have Hfairm := upto_stutter_fairness auxtr mtr Hupto Hfairaux. - have Hmtrvalid := upto_preserves_validity auxtr mtr Hupto Hvalaux. - eapply exaux_preserves_termination; [apply Hmatch|]. - eapply upto_stutter_finiteness =>//. - apply fair_terminating_traces_terminate=>//. -Qed. diff --git a/fairness/heap_lang/lang.v b/fairness/heap_lang/lang.v deleted file mode 100644 index 276fde03..00000000 --- a/fairness/heap_lang/lang.v +++ /dev/null @@ -1,750 +0,0 @@ -From stdpp Require Export binders strings. -From stdpp Require Import gmap. -From iris.algebra Require Export ofe. -From trillium Require Export language ectx_language ectxi_language adequacy. -From trillium.fairness.heap_lang Require Export locations. -Set Default Proof Using "Type". - -(** heap_lang. A fairly simple language used for common Iris examples. - -- This is a right-to-left evaluated language, like CakeML and OCaml. The reason - for this is that it makes curried functions usable: Given a WP for [f a b], we - know that any effects [f] might have to not matter until after *both* [a] and - [b] are evaluated. With left-to-right evaluation, that triple is basically - useless unless the user let-expands [b]. - -- For prophecy variables, we annotate the reduction steps with an "observation" - and tweak adequacy such that WP knows all future observations. There is - another possible choice: Use non-deterministic choice when creating a prophecy - variable ([NewProph]), and when resolving it ([Resolve]) make the - program diverge unless the variable matches. That, however, requires an - erasure proof that this endless loop does not make specifications useless. - -The expression [Resolve e p v] attaches a prophecy resolution (for prophecy -variable [p] to value [v]) to the top-level head-reduction step of [e]. The -prophecy resolution happens simultaneously with the head-step being taken. -Furthermore, it is required that the head-step produces a value (otherwise -the [Resolve] is stuck), and this value is also attached to the resolution. -A prophecy variable is thus resolved to a pair containing (1) the result -value of the wrapped expression (called [e] above), and (2) the value that -was attached by the [Resolve] (called [v] above). This allows, for example, -to distinguish a resolution originating from a successful [CmpXchg] from one -originating from a failing [CmpXchg]. For example: - - [Resolve (CmpXchg #l #n #(n+1)) #p v] will behave as [CmpXchg #l #n #(n+1)], - which means step to a value-boole pair [(n', b)] while updating the heap, but - in the meantime the prophecy variable [p] will be resolved to [(n', b), v)]. - - [Resolve (! #l) #p v] will behave as [! #l], that is return the value - [w] pointed to by [l] on the heap (assuming it was allocated properly), - but it will additionally resolve [p] to the pair [(w,v)]. - -Note that the sub-expressions of [Resolve e p v] (i.e., [e], [p] and [v]) -are reduced as usual, from right to left. However, the evaluation of [e] -is restricted so that the head-step to which the resolution is attached -cannot be taken by the context. For example: - - [Resolve (CmpXchg #l #n (#n + #1)) #p v] will first be reduced (with by a - context-step) to [Resolve (CmpXchg #l #n #(n+1) #p v], and then behave as - described above. - - However, [Resolve ((λ: "n", CmpXchg #l "n" ("n" + #1)) #n) #p v] is stuck. - Indeed, it can only be evaluated using a head-step (it is a β-redex), - but the process does not yield a value. - -The mechanism described above supports nesting [Resolve] expressions to -attach several prophecy resolutions to a head-redex. *) - -Delimit Scope expr_scope with E. -Delimit Scope val_scope with V. - -Module heap_lang. -Open Scope Z_scope. - -(** Expressions and vals. *) -Definition proph_id := positive. - -(** We have a notion of "poison" as a variant of unit that may not be compared -with anything. This is useful for erasure proofs: if we erased things to unit, -[ == unit] would evaluate to true after erasure, changing program -behavior. So we erase to the poison value instead, making sure that no legal -comparisons could be affected. *) -Inductive base_lit : Set := - | LitInt (n : Z) | LitBool (b : bool) | LitUnit | LitPoison - | LitLoc (l : loc) | LitProphecy (p: proph_id). -Inductive un_op : Set := - | NegOp | MinusUnOp. -Inductive bin_op : Set := - | PlusOp | MinusOp | MultOp | QuotOp | RemOp (* Arithmetic *) - | AndOp | OrOp | XorOp (* Bitwise *) - | ShiftLOp | ShiftROp (* Shifts *) - | LeOp | LtOp | EqOp (* Relations *) - | OffsetOp. (* Pointer offset *) - -Inductive expr := - (* Values *) - | Val (v : val) - (* Base lambda calculus *) - | Var (x : string) - | Rec (f x : binder) (e : expr) - | App (e1 e2 : expr) - (* Base types and their operations *) - | UnOp (op : un_op) (e : expr) - | BinOp (op : bin_op) (e1 e2 : expr) - | If (e0 e1 e2 : expr) - (* Products *) - | Pair (e1 e2 : expr) - | Fst (e : expr) - | Snd (e : expr) - (* Sums *) - | InjL (e : expr) - | InjR (e : expr) - | Case (e0 : expr) (e1 : expr) (e2 : expr) - (* Concurrency *) - | Fork (e : expr) - (* Heap *) - | AllocN (e1 e2 : expr) (* array length (positive number), initial value *) - | Load (e : expr) - | Store (e1 : expr) (e2 : expr) - | CmpXchg (e0 : expr) (e1 : expr) (e2 : expr) (* Compare-exchange *) - | FAA (e1 : expr) (e2 : expr) (* Fetch-and-add *) - (* Non-determinism *) - | ChooseNat -with val := - | LitV (l : base_lit) - | RecV (f x : binder) (e : expr) - | PairV (v1 v2 : val) - | InjLV (v : val) - | InjRV (v : val). - -Bind Scope expr_scope with expr. -Bind Scope val_scope with val. - -(** An observation associates a prophecy variable (identifier) to a pair of -values. The first value is the one that was returned by the (atomic) operation -during which the prophecy resolution happened (typically, a boolean when the -wrapped operation is a CmpXchg). The second value is the one that the prophecy -variable was actually resolved to. *) -Definition observation : Set := proph_id * (val * val). - -Notation of_val := Val (only parsing). - -Definition to_val (e : expr) : option val := - match e with - | Val v => Some v - | _ => None - end. - -(** We assume the following encoding of values to 64-bit words: The least 3 -significant bits of every word are a "tag", and we have 61 bits of payload, -which is enough if all pointers are 8-byte-aligned (common on 64bit -architectures). The tags have the following meaning: - -0: Payload is the data for a LitV (LitInt _). -1: Payload is the data for a InjLV (LitV (LitInt _)). -2: Payload is the data for a InjRV (LitV (LitInt _)). -3: Payload is the data for a LitV (LitLoc _). -4: Payload is the data for a InjLV (LitV (LitLoc _)). -4: Payload is the data for a InjRV (LitV (LitLoc _)). -6: Payload is one of the following finitely many values, which 61 bits are more - than enough to encode: - LitV LitUnit, InjLV (LitV LitUnit), InjRV (LitV LitUnit), - LitV LitPoison, InjLV (LitV LitPoison), InjRV (LitV LitPoison), - LitV (LitBool _), InjLV (LitV (LitBool _)), InjRV (LitV (LitBool _)). -7: Value is boxed, i.e., payload is a pointer to some read-only memory area on - the heap which stores whether this is a RecV, PairV, InjLV or InjRV and the - relevant data for those cases. However, the boxed representation is never - used if any of the above representations could be used. - -Ignoring (as usual) the fact that we have to fit the infinite Z/loc into 61 -bits, this means every value is machine-word-sized and can hence be atomically -read and written. Also notice that the sets of boxed and unboxed values are -disjoint. *) -Definition lit_is_unboxed (l: base_lit) : Prop := - match l with - (** Disallow comparing (erased) prophecies with (erased) prophecies, by - considering them boxed. *) - | LitProphecy _ | LitPoison => False - | _ => True - end. -Definition val_is_unboxed (v : val) : Prop := - match v with - | LitV l => lit_is_unboxed l - | InjLV (LitV l) => lit_is_unboxed l - | InjRV (LitV l) => lit_is_unboxed l - | _ => False - end. - -#[global] Instance lit_is_unboxed_dec l : Decision (lit_is_unboxed l). -Proof. destruct l; simpl; exact (decide _). Defined. -#[global] Instance val_is_unboxed_dec v : Decision (val_is_unboxed v). -Proof. destruct v as [ | | | [] | [] ]; simpl; exact (decide _). Defined. - -(** We just compare the word-sized representation of two values, without looking -into boxed data. This works out fine if at least one of the to-be-compared -values is unboxed (exploiting the fact that an unboxed and a boxed value can -never be equal because these are disjoint sets). *) -Definition vals_compare_safe (vl v1 : val) : Prop := - val_is_unboxed vl ∨ val_is_unboxed v1. -Arguments vals_compare_safe !_ !_ /. - -(** The state: heaps of vals. *) -Record state : Type := { - heap: gmap loc val; - used_proph_id: gset proph_id; -}. - -(** Equality and other typeclass stuff *) -Lemma to_of_val v : to_val (of_val v) = Some v. -Proof. by destruct v. Qed. - -Lemma of_to_val e v : to_val e = Some v → of_val v = e. -Proof. destruct e=>//=. by intros [= <-]. Qed. - -#[global] Instance of_val_inj : Inj (=) (=) of_val. -Proof. intros ??. congruence. Qed. - -#[global] Instance base_lit_eq_dec : EqDecision base_lit. -Proof. solve_decision. Defined. -#[global] Instance un_op_eq_dec : EqDecision un_op. -Proof. solve_decision. Defined. -#[global] Instance bin_op_eq_dec : EqDecision bin_op. -Proof. solve_decision. Defined. -#[global] Instance expr_eq_dec : EqDecision expr. -Proof. - refine ( - fix go (e1 e2 : expr) {struct e1} : Decision (e1 = e2) := - match e1, e2 with - | Val v, Val v' => cast_if (decide (v = v')) - | Var x, Var x' => cast_if (decide (x = x')) - | Rec f x e, Rec f' x' e' => - cast_if_and3 (decide (f = f')) (decide (x = x')) (decide (e = e')) - | App e1 e2, App e1' e2' => cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) - | UnOp o e, UnOp o' e' => cast_if_and (decide (o = o')) (decide (e = e')) - | BinOp o e1 e2, BinOp o' e1' e2' => - cast_if_and3 (decide (o = o')) (decide (e1 = e1')) (decide (e2 = e2')) - | If e0 e1 e2, If e0' e1' e2' => - cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) - | Pair e1 e2, Pair e1' e2' => - cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) - | Fst e, Fst e' => cast_if (decide (e = e')) - | Snd e, Snd e' => cast_if (decide (e = e')) - | InjL e, InjL e' => cast_if (decide (e = e')) - | InjR e, InjR e' => cast_if (decide (e = e')) - | Case e0 e1 e2, Case e0' e1' e2' => - cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) - | Fork e, Fork e' => cast_if (decide (e = e')) - | AllocN e1 e2, AllocN e1' e2' => - cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) - | Load e, Load e' => cast_if (decide (e = e')) - | Store e1 e2, Store e1' e2' => - cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) - | CmpXchg e0 e1 e2, CmpXchg e0' e1' e2' => - cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2')) - | FAA e1 e2, FAA e1' e2' => - cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) - | ChooseNat, ChooseNat => left _ - | _, _ => right _ - end - with gov (v1 v2 : val) {struct v1} : Decision (v1 = v2) := - match v1, v2 with - | LitV l, LitV l' => cast_if (decide (l = l')) - | RecV f x e, RecV f' x' e' => - cast_if_and3 (decide (f = f')) (decide (x = x')) (decide (e = e')) - | PairV e1 e2, PairV e1' e2' => - cast_if_and (decide (e1 = e1')) (decide (e2 = e2')) - | InjLV e, InjLV e' => cast_if (decide (e = e')) - | InjRV e, InjRV e' => cast_if (decide (e = e')) - | _, _ => right _ - end - for go); try (clear go gov; abstract intuition congruence). -Defined. -#[global] Instance val_eq_dec : EqDecision val. -Proof. solve_decision. Defined. - -#[global] Instance base_lit_countable : Countable base_lit. -Proof. - refine (inj_countable' (λ l, match l with - | LitInt n => (inl (inl n), None) - | LitBool b => (inl (inr b), None) - | LitUnit => (inr (inl false), None) - | LitPoison => (inr (inl true), None) - | LitLoc l => (inr (inr l), None) - | LitProphecy p => (inr (inl false), Some p) - end) (λ l, match l with - | (inl (inl n), None) => LitInt n - | (inl (inr b), None) => LitBool b - | (inr (inl false), None) => LitUnit - | (inr (inl true), None) => LitPoison - | (inr (inr l), None) => LitLoc l - | (_, Some p) => LitProphecy p - end) _); by intros []. -Qed. -#[global] Instance un_op_finite : Countable un_op. -Proof. - refine (inj_countable' (λ op, match op with NegOp => 0 | MinusUnOp => 1 end) - (λ n, match n with 0 => NegOp | _ => MinusUnOp end) _); by intros []. -Qed. -#[global] Instance bin_op_countable : Countable bin_op. -Proof. - refine (inj_countable' (λ op, match op with - | PlusOp => 0 | MinusOp => 1 | MultOp => 2 | QuotOp => 3 | RemOp => 4 - | AndOp => 5 | OrOp => 6 | XorOp => 7 | ShiftLOp => 8 | ShiftROp => 9 - | LeOp => 10 | LtOp => 11 | EqOp => 12 | OffsetOp => 13 - end) (λ n, match n with - | 0 => PlusOp | 1 => MinusOp | 2 => MultOp | 3 => QuotOp | 4 => RemOp - | 5 => AndOp | 6 => OrOp | 7 => XorOp | 8 => ShiftLOp | 9 => ShiftROp - | 10 => LeOp | 11 => LtOp | 12 => EqOp | _ => OffsetOp - end) _); by intros []. -Qed. -#[global] Instance expr_countable : Countable expr. -Proof. - set (enc := - fix go e := - match e with - | Val v => GenNode 0 [gov v] - | Var x => GenLeaf (inl (inl x)) - | Rec f x e => GenNode 1 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); go e] - | App e1 e2 => GenNode 2 [go e1; go e2] - | UnOp op e => GenNode 3 [GenLeaf (inr (inr (inl op))); go e] - | BinOp op e1 e2 => GenNode 4 [GenLeaf (inr (inr (inr op))); go e1; go e2] - | If e0 e1 e2 => GenNode 5 [go e0; go e1; go e2] - | Pair e1 e2 => GenNode 6 [go e1; go e2] - | Fst e => GenNode 7 [go e] - | Snd e => GenNode 8 [go e] - | InjL e => GenNode 9 [go e] - | InjR e => GenNode 10 [go e] - | Case e0 e1 e2 => GenNode 11 [go e0; go e1; go e2] - | Fork e => GenNode 12 [go e] - | AllocN e1 e2 => GenNode 13 [go e1; go e2] - | Load e => GenNode 14 [go e] - | Store e1 e2 => GenNode 15 [go e1; go e2] - | CmpXchg e0 e1 e2 => GenNode 16 [go e0; go e1; go e2] - | FAA e1 e2 => GenNode 17 [go e1; go e2] - | ChooseNat => GenNode 18 [] - end - with gov v := - match v with - | LitV l => GenLeaf (inr (inl l)) - | RecV f x e => - GenNode 0 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); go e] - | PairV v1 v2 => GenNode 1 [gov v1; gov v2] - | InjLV v => GenNode 2 [gov v] - | InjRV v => GenNode 3 [gov v] - end - for go). - set (dec := - fix go e := - match e with - | GenNode 0 [v] => Val (gov v) - | GenLeaf (inl (inl x)) => Var x - | GenNode 1 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); e] => Rec f x (go e) - | GenNode 2 [e1; e2] => App (go e1) (go e2) - | GenNode 3 [GenLeaf (inr (inr (inl op))); e] => UnOp op (go e) - | GenNode 4 [GenLeaf (inr (inr (inr op))); e1; e2] => BinOp op (go e1) (go e2) - | GenNode 5 [e0; e1; e2] => If (go e0) (go e1) (go e2) - | GenNode 6 [e1; e2] => Pair (go e1) (go e2) - | GenNode 7 [e] => Fst (go e) - | GenNode 8 [e] => Snd (go e) - | GenNode 9 [e] => InjL (go e) - | GenNode 10 [e] => InjR (go e) - | GenNode 11 [e0; e1; e2] => Case (go e0) (go e1) (go e2) - | GenNode 12 [e] => Fork (go e) - | GenNode 13 [e1; e2] => AllocN (go e1) (go e2) - | GenNode 14 [e] => Load (go e) - | GenNode 15 [e1; e2] => Store (go e1) (go e2) - | GenNode 16 [e0; e1; e2] => CmpXchg (go e0) (go e1) (go e2) - | GenNode 17 [e1; e2] => FAA (go e1) (go e2) - | GenNode 18 [] => ChooseNat - | _ => Val $ LitV LitUnit (* dummy *) - end - with gov v := - match v with - | GenLeaf (inr (inl l)) => LitV l - | GenNode 0 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); e] => RecV f x (go e) - | GenNode 1 [v1; v2] => PairV (gov v1) (gov v2) - | GenNode 2 [v] => InjLV (gov v) - | GenNode 3 [v] => InjRV (gov v) - | _ => LitV LitUnit (* dummy *) - end - for go). - refine (inj_countable' enc dec _). - refine (fix go (e : expr) {struct e} := _ with gov (v : val) {struct v} := _ for go). - - destruct e as [v| | | | | | | | | | | | | | | | | | |]; simpl; f_equal; - [exact (gov v)|done..]. - - destruct v; by f_equal. -Qed. -#[global] Instance val_countable : Countable val. -Proof. refine (inj_countable of_val to_val _); auto using to_of_val. Qed. - -#[global] Instance state_inhabited : Inhabited state := - populate {| heap := inhabitant; used_proph_id := inhabitant |}. -#[global] Instance val_inhabited : Inhabited val := populate (LitV LitUnit). -#[global] Instance expr_inhabited : Inhabited expr := populate (Val inhabitant). - -Canonical Structure stateO := leibnizO state. -Canonical Structure locO := leibnizO loc. -Canonical Structure valO := leibnizO val. -Canonical Structure exprO := leibnizO expr. - -(** Evaluation contexts *) -Inductive ectx_item := - | AppLCtx (v2 : val) - | AppRCtx (e1 : expr) - | UnOpCtx (op : un_op) - | BinOpLCtx (op : bin_op) (v2 : val) - | BinOpRCtx (op : bin_op) (e1 : expr) - | IfCtx (e1 e2 : expr) - | PairLCtx (v2 : val) - | PairRCtx (e1 : expr) - | FstCtx - | SndCtx - | InjLCtx - | InjRCtx - | CaseCtx (e1 : expr) (e2 : expr) - | AllocNLCtx (v2 : val) - | AllocNRCtx (e1 : expr) - | LoadCtx - | StoreLCtx (v2 : val) - | StoreRCtx (e1 : expr) - | CmpXchgLCtx (v1 : val) (v2 : val) - | CmpXchgMCtx (e0 : expr) (v2 : val) - | CmpXchgRCtx (e0 : expr) (e1 : expr) - | FaaLCtx (v2 : val) - | FaaRCtx (e1 : expr). - -(** Contextual closure will only reduce [e] in [Resolve e (Val _) (Val _)] if -the local context of [e] is non-empty. As a consequence, the first argument of -[Resolve] is not completely evaluated (down to a value) by contextual closure: -no head steps (i.e., surface reductions) are taken. This means that contextual -closure will reduce [Resolve (CmpXchg #l #n (#n + #1)) #p #v] into [Resolve -(CmpXchg #l #n #(n+1)) #p #v], but it cannot context-step any further. *) - -Definition fill_item (Ki : ectx_item) (e : expr) : expr := - match Ki with - | AppLCtx v2 => App e (of_val v2) - | AppRCtx e1 => App e1 e - | UnOpCtx op => UnOp op e - | BinOpLCtx op v2 => BinOp op e (Val v2) - | BinOpRCtx op e1 => BinOp op e1 e - | IfCtx e1 e2 => If e e1 e2 - | PairLCtx v2 => Pair e (Val v2) - | PairRCtx e1 => Pair e1 e - | FstCtx => Fst e - | SndCtx => Snd e - | InjLCtx => InjL e - | InjRCtx => InjR e - | CaseCtx e1 e2 => Case e e1 e2 - | AllocNLCtx v2 => AllocN e (Val v2) - | AllocNRCtx e1 => AllocN e1 e - | LoadCtx => Load e - | StoreLCtx v2 => Store e (Val v2) - | StoreRCtx e1 => Store e1 e - | CmpXchgLCtx v1 v2 => CmpXchg e (Val v1) (Val v2) - | CmpXchgMCtx e0 v2 => CmpXchg e0 e (Val v2) - | CmpXchgRCtx e0 e1 => CmpXchg e0 e1 e - | FaaLCtx v2 => FAA e (Val v2) - | FaaRCtx e1 => FAA e1 e - end. - -(** Substitution *) -Fixpoint subst (x : string) (v : val) (e : expr) : expr := - match e with - | Val _ => e - | Var y => if decide (x = y) then Val v else Var y - | Rec f y e => - Rec f y $ if decide (BNamed x ≠ f ∧ BNamed x ≠ y) then subst x v e else e - | App e1 e2 => App (subst x v e1) (subst x v e2) - | UnOp op e => UnOp op (subst x v e) - | BinOp op e1 e2 => BinOp op (subst x v e1) (subst x v e2) - | If e0 e1 e2 => If (subst x v e0) (subst x v e1) (subst x v e2) - | Pair e1 e2 => Pair (subst x v e1) (subst x v e2) - | Fst e => Fst (subst x v e) - | Snd e => Snd (subst x v e) - | InjL e => InjL (subst x v e) - | InjR e => InjR (subst x v e) - | Case e0 e1 e2 => Case (subst x v e0) (subst x v e1) (subst x v e2) - | Fork e => Fork (subst x v e) - | AllocN e1 e2 => AllocN (subst x v e1) (subst x v e2) - | Load e => Load (subst x v e) - | Store e1 e2 => Store (subst x v e1) (subst x v e2) - | CmpXchg e0 e1 e2 => CmpXchg (subst x v e0) (subst x v e1) (subst x v e2) - | FAA e1 e2 => FAA (subst x v e1) (subst x v e2) - | ChooseNat => ChooseNat - end. - -Definition subst' (mx : binder) (v : val) : expr → expr := - match mx with BNamed x => subst x v | BAnon => id end. - -(** The stepping relation *) -Definition un_op_eval (op : un_op) (v : val) : option val := - match op, v with - | NegOp, LitV (LitBool b) => Some $ LitV $ LitBool (negb b) - | NegOp, LitV (LitInt n) => Some $ LitV $ LitInt (Z.lnot n) - | MinusUnOp, LitV (LitInt n) => Some $ LitV $ LitInt (- n) - | _, _ => None - end. - -Definition bin_op_eval_int (op : bin_op) (n1 n2 : Z) : option base_lit := - match op with - | PlusOp => Some $ LitInt (n1 + n2) - | MinusOp => Some $ LitInt (n1 - n2) - | MultOp => Some $ LitInt (n1 * n2) - | QuotOp => Some $ LitInt (n1 `quot` n2) - | RemOp => Some $ LitInt (n1 `rem` n2) - | AndOp => Some $ LitInt (Z.land n1 n2) - | OrOp => Some $ LitInt (Z.lor n1 n2) - | XorOp => Some $ LitInt (Z.lxor n1 n2) - | ShiftLOp => Some $ LitInt (n1 ≪ n2) - | ShiftROp => Some $ LitInt (n1 ≫ n2) - | LeOp => Some $ LitBool (bool_decide (n1 ≤ n2)) - | LtOp => Some $ LitBool (bool_decide (n1 < n2)) - | EqOp => Some $ LitBool (bool_decide (n1 = n2)) - | OffsetOp => None (* Pointer arithmetic *) - end. - -Definition bin_op_eval_bool (op : bin_op) (b1 b2 : bool) : option base_lit := - match op with - | PlusOp | MinusOp | MultOp | QuotOp | RemOp => None (* Arithmetic *) - | AndOp => Some (LitBool (b1 && b2)) - | OrOp => Some (LitBool (b1 || b2)) - | XorOp => Some (LitBool (xorb b1 b2)) - | ShiftLOp | ShiftROp => None (* Shifts *) - | LeOp | LtOp => None (* InEquality *) - | EqOp => Some (LitBool (bool_decide (b1 = b2))) - | OffsetOp => None (* Pointer arithmetic *) - end. - -Definition bin_op_eval (op : bin_op) (v1 v2 : val) : option val := - if decide (op = EqOp) then - (* Crucially, this compares the same way as [CmpXchg]! *) - if decide (vals_compare_safe v1 v2) then - Some $ LitV $ LitBool $ bool_decide (v1 = v2) - else - None - else - match v1, v2 with - | LitV (LitInt n1), LitV (LitInt n2) => LitV <$> bin_op_eval_int op n1 n2 - | LitV (LitBool b1), LitV (LitBool b2) => LitV <$> bin_op_eval_bool op b1 b2 - | LitV (LitLoc l), LitV (LitInt off) => Some $ LitV $ LitLoc (l +ₗ off) - | _, _ => None - end. - -Definition state_upd_heap (f: gmap loc val → gmap loc val) (σ: state) : state := - {| heap := f σ.(heap); used_proph_id := σ.(used_proph_id) |}. -Arguments state_upd_heap _ !_ /. - -Definition state_upd_used_proph_id (f: gset proph_id → gset proph_id) (σ: state) : state := - {| heap := σ.(heap); used_proph_id := f σ.(used_proph_id) |}. -Arguments state_upd_used_proph_id _ !_ /. - -Fixpoint heap_array (l : loc) (vs : list val) : gmap loc val := - match vs with - | [] => ∅ - | v :: vs' => {[l := v]} ∪ heap_array (l +ₗ 1) vs' - end. - -Lemma heap_array_singleton l v : heap_array l [v] = {[l := v]}. -Proof. by rewrite /heap_array right_id. Qed. - -Lemma heap_array_lookup l vs w k : - heap_array l vs !! k = Some w ↔ - ∃ j, 0 ≤ j ∧ k = l +ₗ j ∧ vs !! (Z.to_nat j) = Some w. -Proof. - revert k l; induction vs as [|v' vs IH]=> l' l /=. - { rewrite lookup_empty. naive_solver lia. } - rewrite -insert_union_singleton_l lookup_insert_Some IH. split. - - intros [[-> ->] | (Hl & j & ? & -> & ?)]. - { exists 0. rewrite loc_add_0. naive_solver lia. } - exists (1 + j). rewrite loc_add_assoc !Z.add_1_l Z2Nat.inj_succ; auto with lia. - - intros (j & ? & -> & Hil). destruct (decide (j = 0)); simplify_eq/=. - { rewrite loc_add_0; eauto. } - right. split. - { rewrite -{1}(loc_add_0 l). intros ?%(inj _); lia. } - assert (Z.to_nat j = S (Z.to_nat (j - 1))) as Hj. - { rewrite -Z2Nat.inj_succ; last lia. f_equal; lia. } - rewrite Hj /= in Hil. - exists (j - 1). rewrite loc_add_assoc Z.add_sub_assoc Z.add_simpl_l. - auto with lia. -Qed. - -Lemma heap_array_map_disjoint (h : gmap loc val) (l : loc) (vs : list val) : - (∀ i, (0 ≤ i) → (i < length vs) → h !! (l +ₗ i) = None) → - (heap_array l vs) ##ₘ h. -Proof. - intros Hdisj. apply map_disjoint_spec=> l' v1 v2. - intros (j&?&->&Hj%lookup_lt_Some%inj_lt)%heap_array_lookup. - move: Hj. rewrite Z2Nat.id // => ?. by rewrite Hdisj. -Qed. - -(* [h] is added on the right here to make [state_init_heap_singleton] true. *) -Definition state_init_heap (l : loc) (n : Z) (v : val) (σ : state) : state := - state_upd_heap (λ h, heap_array l (replicate (Z.to_nat n) v) ∪ h) σ. - -Lemma state_init_heap_singleton l v σ : - state_init_heap l 1 v σ = state_upd_heap <[l:=v]> σ. -Proof. - destruct σ as [h p]. rewrite /state_init_heap /=. f_equiv. - rewrite right_id insert_union_singleton_l. done. -Qed. - -Inductive head_step : expr → state → expr → state → list expr → Prop := - | RecS f x e σ : - head_step (Rec f x e) σ (Val $ RecV f x e) σ [] - | PairS v1 v2 σ : - head_step (Pair (Val v1) (Val v2)) σ (Val $ PairV v1 v2) σ [] - | InjLS v σ : - head_step (InjL $ Val v) σ (Val $ InjLV v) σ [] - | InjRS v σ : - head_step (InjR $ Val v) σ (Val $ InjRV v) σ [] - | BetaS f x e1 v2 e' σ : - e' = subst' x v2 (subst' f (RecV f x e1) e1) → - head_step (App (Val $ RecV f x e1) (Val v2)) σ e' σ [] - | UnOpS op v v' σ : - un_op_eval op v = Some v' → - head_step (UnOp op (Val v)) σ (Val v') σ [] - | BinOpS op v1 v2 v' σ : - bin_op_eval op v1 v2 = Some v' → - head_step (BinOp op (Val v1) (Val v2)) σ (Val v') σ [] - | IfTrueS e1 e2 σ : - head_step (If (Val $ LitV $ LitBool true) e1 e2) σ e1 σ [] - | IfFalseS e1 e2 σ : - head_step (If (Val $ LitV $ LitBool false) e1 e2) σ e2 σ [] - | FstS v1 v2 σ : - head_step (Fst (Val $ PairV v1 v2)) σ (Val v1) σ [] - | SndS v1 v2 σ : - head_step (Snd (Val $ PairV v1 v2)) σ (Val v2) σ [] - | CaseLS v e1 e2 σ : - head_step (Case (Val $ InjLV v) e1 e2) σ (App e1 (Val v)) σ [] - | CaseRS v e1 e2 σ : - head_step (Case (Val $ InjRV v) e1 e2) σ (App e2 (Val v)) σ [] - | ForkS e σ: - head_step (Fork e) σ (Val $ LitV LitUnit) σ [e] - | AllocNS n v σ l : - 0 < n → - (∀ i, 0 ≤ i → i < n → σ.(heap) !! (l +ₗ i) = None) → - head_step (AllocN (Val $ LitV $ LitInt n) (Val v)) σ - (Val $ LitV $ LitLoc l) (state_init_heap l n v σ) - [] - | LoadS l v σ : - σ.(heap) !! l = Some v → - head_step (Load (Val $ LitV $ LitLoc l)) σ (of_val v) σ [] - | StoreS l v σ : - is_Some (σ.(heap) !! l) → - head_step (Store (Val $ LitV $ LitLoc l) (Val v)) σ - (Val $ LitV LitUnit) (state_upd_heap <[l:=v]> σ) - [] - | CmpXchgS l v1 v2 vl σ b : - σ.(heap) !! l = Some vl → - (* Crucially, this compares the same way as [EqOp]! *) - vals_compare_safe vl v1 → - b = bool_decide (vl = v1) → - head_step (CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) σ - (Val $ PairV vl (LitV $ LitBool b)) (if b then state_upd_heap <[l:=v2]> σ else σ) - [] - | FaaS l i1 i2 σ : - σ.(heap) !! l = Some (LitV (LitInt i1)) → - head_step (FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2)) σ - (Val $ LitV $ LitInt i1) (state_upd_heap <[l:=LitV (LitInt (i1 + i2))]>σ) - [] - | ChooseNatS (n:nat) σ: - head_step ChooseNat σ (Val $ LitV $ LitInt n) σ [] -. - -(** Basic properties about the language *) -#[global] Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki). -Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. - -Lemma fill_item_val Ki e : - is_Some (to_val (fill_item Ki e)) → is_Some (to_val e). -Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. - -Lemma val_head_stuck e1 σ1 e2 σ2 efs : head_step e1 σ1 e2 σ2 efs → to_val e1 = None. -Proof. destruct 1; naive_solver. Qed. - -Lemma head_ctx_step_val Ki e σ1 e2 σ2 efs : - head_step (fill_item Ki e) σ1 e2 σ2 efs → is_Some (to_val e). -Proof. revert e2. induction Ki; inversion_clear 1; simplify_option_eq; eauto. Qed. - -Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 : - to_val e1 = None → to_val e2 = None → - fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2. -Proof. revert Ki1. induction Ki2, Ki1; naive_solver eauto with f_equal. Qed. - -Lemma alloc_fresh v n σ : - let l := fresh_locs (dom σ.(heap)) in - 0 < n → - head_step (AllocN ((Val $ LitV $ LitInt $ n)) (Val v)) σ - (Val $ LitV $ LitLoc l) (state_init_heap l n v σ) []. -Proof. - intros. - apply AllocNS; first done. - intros. apply (not_elem_of_dom (D := gset loc)). - by apply fresh_locs_fresh. -Qed. - -Definition base_locale := nat. -Definition locale_of (c: list expr) (e : expr) := length c. - -Lemma locale_step_same e1 e2 t1 σ1 σ2 efs: - head_step e1 σ1 e2 σ2 efs -> - locale_of t1 e1 = locale_of t1 e2. -Proof. done. Qed. - -Lemma locale_fill e K t1: locale_of t1 (fill_item K e) = locale_of t1 e. -Proof. done. Qed. - -Lemma heap_locale_injective tp0 e0 tp1 tp e : - (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 → - locale_of tp0 e0 ≠ locale_of tp e. -Proof. - intros (?&?&->&?)%prefixes_from_spec. - rewrite /locale_of !app_length /=. lia. -Qed. - -Lemma heap_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step locale_of. -Proof. - split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck, - fill_item_val, fill_item_no_val_inj, head_ctx_step_val, locale_fill, locale_step_same, heap_locale_injective. - { intros ??? H%Forall2_length. rewrite !prefixes_from_length // in H. } -Qed. - -Definition context_step (_ _: state): Prop := False. -End heap_lang. - -(** Language *) -Canonical Structure heap_ectxi_lang := - EctxiLanguage heap_lang.head_step heap_lang.context_step heap_lang.locale_of heap_lang.heap_lang_mixin. -Canonical Structure heap_ectx_lang := EctxLanguageOfEctxi heap_ectxi_lang. -Canonical Structure heap_lang := LanguageOfEctx heap_ectx_lang. - -(* Prefer heap_lang names over ectx_language names. *) -Export heap_lang. - -(** The following lemma is not provable using the axioms of [ectxi_language]. -The proof requires a case analysis over context items ([destruct i] on the -last line), which in all cases yields a non-value. To prove this lemma for -[ectxi_language] in general, we would require that a term of the form -[fill_item i e] is never a value. *) -Lemma to_val_fill_some K e v : to_val (fill K e) = Some v → K = [] ∧ e = Val v. -Proof. - intro H. destruct K as [|Ki K]; first by apply of_to_val in H. exfalso. - assert (to_val e ≠ None) as He. - { intro A. by rewrite fill_not_val in H. } - assert (∃ w, e = Val w) as [w ->]. - { destruct e; try done; eauto. } - assert (to_val (fill (Ki :: K) (Val w)) = None). - { destruct Ki; simpl; apply fill_not_val; done. } - by simplify_eq. -Qed. - -Lemma prim_step_to_val_is_head_step e σ1 w σ2 efs : - prim_step e σ1 (Val w) σ2 efs → head_step e σ1 (Val w) σ2 efs. -Proof. - intro H. destruct H as [K e1 e2 H1 H2]. - assert (to_val (fill K e2) = Some w) as H3; first by rewrite -H2. - apply to_val_fill_some in H3 as [-> ->]. subst e. done. -Qed. - -(** If [e1] makes a head step to a value under some state [σ1] then any head - step from [e1] under any other state [σ1'] must necessarily be to a value. *) -Lemma head_step_to_val e1 σ1 e2 σ2 efs σ1' e2' σ2' efs' : - head_step e1 σ1 e2 σ2 efs → - head_step e1 σ1' e2' σ2' efs' → is_Some (to_val e2) → is_Some (to_val e2'). -Proof. destruct 1; inversion 1; naive_solver. Qed. diff --git a/fairness/heap_lang/lifting.v b/fairness/heap_lang/lifting.v deleted file mode 100644 index fe03d118..00000000 --- a/fairness/heap_lang/lifting.v +++ /dev/null @@ -1,1323 +0,0 @@ -From stdpp Require Import fin_maps. -From iris.proofmode Require Import tactics. -From iris.algebra Require Import auth gmap gset excl. -From iris.base_logic Require Export gen_heap. -From trillium.prelude Require Import classical_instances. -From trillium.program_logic Require Export weakestpre adequacy. -From trillium.fairness Require Export fairness resources fair_termination fairness_finiteness fuel fuel_termination. -From trillium.program_logic Require Import ectx_lifting. -From trillium.fairness.heap_lang Require Export lang. -From trillium.fairness.heap_lang Require Import tactics notation. -Set Default Proof Using "Type". - -Canonical Structure ModelO (M : FairModel) := leibnizO M. -Canonical Structure RoleO (M : FairModel) := leibnizO (M.(fmrole)). - -Class heapGpreS Σ `(LM: LiveModel heap_lang M) := HeapPreG { - heapGpreS_inv :> invGpreS Σ; - heapGpreS_gen_heap :> gen_heapGpreS loc val Σ; - heapGpreS_fairness :> fairnessGpreS LM Σ; -}. - -Class heapGS Σ `(LM:LiveModel heap_lang M) := HeapG { - heap_inG :> heapGpreS Σ LM; - - heap_invGS :> invGS_gen HasNoLc Σ; - heap_gen_heapGS :> gen_heapGS loc val Σ; - - heap_fairnessGS :> fairnessGS LM Σ; -}. - -Definition heapΣ (M : FairModel) : gFunctors := - #[ invΣ; gen_heapΣ loc val; fairnessΣ heap_lang M ]. - -Global Instance subG_heapPreG {Σ} `{LM : LiveModel heap_lang M} : - subG (heapΣ M) Σ → heapGpreS Σ LM. -Proof. solve_inG. Qed. - -#[global] Instance heapG_irisG `{LM:LiveModel heap_lang M} `{!heapGS Σ LM} : irisG heap_lang LM Σ := { - state_interp extr auxtr := - (⌜valid_state_evolution_fairness extr auxtr⌝ ∗ - gen_heap_interp (trace_last extr).2.(heap) ∗ - model_state_interp (trace_last extr).1 (trace_last auxtr))%I ; - fork_post tid := λ _, tid ↦M ∅; -}. - -Section adequacy. - -Lemma posts_of_empty_mapping `{heapGS Σ M} (e1 e: expr) v (tid : nat) (tp : list expr): - tp !! tid = Some e -> - to_val e = Some v -> - posts_of tp ((λ (_ : val), 0%nat ↦M ∅) :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop (length [e1]) tp)))) -∗ - tid ↦M ∅. -Proof. - intros Hsome Hval. simpl. - - rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, (λ _: val, tid ↦M ∅)) _) //. - apply elem_of_list_omap. - exists (e, (λ _: val, tid ↦M ∅)); split; last first. - - simpl. apply fmap_Some. exists v. split; done. - - destruct tp as [|e1' tp]; first set_solver. simpl. - apply elem_of_cons. - destruct tid as [|tid]; [left|right]; first by simpl in Hsome; simplify_eq. - apply elem_of_lookup_zip_with. eexists tid, e, _. do 2 split =>//. - rewrite /locale_of /=. - rewrite list_lookup_fmap fmap_Some. simpl in Hsome. - exists (e1 :: take tid tp, e). rewrite drop_0. split. - + erewrite prefixes_from_lookup =>//. - + rewrite /locale_of /= take_length_le //. - assert (tid < length tp)%nat; last lia. by eapply lookup_lt_Some. -Qed. - -(* Local Hint Resolve tid_step_tp_length_heap: core. *) - -Lemma from_locale_from_lookup tp0 tp tid e : - from_locale_from tp0 tp tid = Some e <-> (tp !! (tid - length tp0)%nat = Some e ∧ (length tp0 <= tid)%nat). -Proof. - split. - - revert tp0 tid. induction tp as [| e1 tp1 IH]; intros tp0 tid. - { unfold from_locale. simpl. done. } - unfold from_locale. simpl. - destruct (decide (locale_of tp0 e1 = tid)). - + intros ?; simplify_eq. rewrite /locale_of /= Nat.sub_diag. - split; [done|lia]. - + intros [H Hlen]%IH. rewrite app_length /= in H. - rewrite app_length /= in Hlen. - destruct tid as [|tid]; first lia. - assert (Heq1 : (length tp0 + 1 = S (length tp0))%nat) by lia. - rewrite Heq1 in Hlen. - assert (length tp0 ≤ tid)%nat by lia. - assert (Heq : (S tid - length tp0)%nat = (S ((tid - (length tp0))))%nat) by lia. - rewrite Heq /=. split. - * rewrite -H. f_equal. lia. - * transitivity tid; try lia. assumption. - - revert tp0 tid. induction tp as [|e1 tp1 IH]; intros tp0 tid. - { set_solver. } - destruct (decide (tid = length tp0)) as [-> | Hneq]. - + rewrite Nat.sub_diag /=. intros [? _]. simplify_eq. - rewrite decide_True //. - + intros [Hlk Hlen]. assert (length tp0 < tid)%nat as Hle by lia. - simpl. rewrite decide_False //. apply IH. split. - * assert (tid - length tp0 = S ((tid - 1) - length tp0))%nat as Heq by lia. - rewrite Heq /= in Hlk. rewrite -Hlk app_length /=. f_equal; lia. - * rewrite app_length /=. apply Nat.le_succ_l in Hle. rewrite Nat.add_comm //. -Qed. - -Lemma from_locale_lookup tp tid e : - from_locale tp tid = Some e <-> tp !! tid = Some e. -Proof. - assert (from_locale tp tid = Some e <-> (tp !! tid = Some e ∧ 0 ≤ tid)%nat) as H; last first. - { split; intros ?; apply H; eauto. split; [done|lia]. } - unfold from_locale. replace (tid) with (tid - length (A := expr) [])%nat at 2; - first apply from_locale_from_lookup. simpl; lia. -Qed. - -Definition indexes {A} (xs : list A) := imap (λ i _, i) xs. - -Lemma locales_of_list_from_indexes (es' es : list expr) : - locales_of_list_from es' es = imap (λ i _, length es' + i)%nat es. -Proof. - revert es'. induction es; [done|]; intros es'. - rewrite locales_of_list_from_cons=> /=. rewrite /locale_of. - f_equiv; [lia|]. rewrite IHes. apply imap_ext. - intros x ? Hin. rewrite app_length=> /=. lia. -Qed. - -Lemma locales_of_list_indexes (es : list expr) : - locales_of_list es = indexes es. -Proof. apply locales_of_list_from_indexes. Qed. - -Theorem heap_lang_continued_simulation_fair_termination {FM : FairModel} - `{FairTerminatingModel FM} {LM:LiveModel heap_lang FM} ξ a1 r1 extr : - continued_simulation - (sim_rel_with_user LM ξ) - ({tr[trfirst extr]}) ({tr[initial_ls (LM := LM) a1 r1]}) → - extrace_fairly_terminating extr. -Proof. - apply continued_simulation_fair_termination. - - intros ?? contra. inversion contra. - simplify_eq. inversion H2. - - by intros ex atr [[??]?]. - - by intros ex atr [[??]?]. -Qed. - -Definition rel_always_holds {Σ} `{LM:LiveModel heap_lang M} `{!heapGS Σ LM} - (s:stuckness) (ξ : execution_trace heap_lang → finite_trace M - (option $ fmrole M) → Prop) (c1:cfg heap_lang) - (c2:live_model_to_model LM) : iProp Σ := - ∀ ex atr c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex c1⌝ -∗ - ⌜trace_starts_in atr c2⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → - trace_contract atr ℓ atr' → - ξ ex' (map_underlying_trace atr')⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - state_interp ex atr -∗ - posts_of c.1 ((λ _, 0%nat ↦M ∅) :: ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from c1.1 (drop (length c1.1) c.1)))) -∗ - |={⊤, ∅}=> ⌜ξ ex (map_underlying_trace atr)⌝. - -Theorem strong_simulation_adequacy Σ `(LM:LiveModel heap_lang M) - `{!heapGpreS Σ LM} (s: stuckness) (e1 : expr) σ1 (s1: M) (FR: gset _) - (ξ : execution_trace heap_lang → finite_trace M (option $ fmrole M) → - Prop) : - rel_finitary (sim_rel_with_user LM ξ) → - live_roles M s1 ≠ ∅ -> - (∀ `{Hinv : !heapGS Σ LM}, - ⊢ |={⊤}=> - (* state_interp (trace_singleton ([e1], σ1)) (trace_singleton (initial_ls (LM := LM) s1 0%nat)) ∗ *) - ([∗ map] l ↦ v ∈ heap σ1, mapsto l (DfracOwn 1) v) -∗ - frag_model_is s1 -∗ - frag_free_roles_are (FR ∖ live_roles _ s1) -∗ - has_fuels (Σ := Σ) 0%nat (gset_to_gmap (LM.(lm_fl) s1) (M.(live_roles) s1)) ={⊤}=∗ - WP e1 @ s; locale_of [] e1; ⊤ {{ v, 0%nat ↦M ∅ }} ∗ - rel_always_holds s ξ ([e1], σ1) (initial_ls (LM := LM) s1 0%nat)) -> - continued_simulation (sim_rel_with_user LM ξ) (trace_singleton ([e1], σ1)) (trace_singleton (initial_ls (LM := LM) s1 0%nat)). -Proof. - intros Hfin Hfevol H. - apply (wp_strong_adequacy heap_lang LM Σ s); first by eauto. - iIntros (?) "". - iMod (gen_heap_init (heap σ1)) as (genheap)" [Hgen [Hσ _]]". - iMod (model_state_init s1) as (γmod) "[Hmoda Hmodf]". - iMod (model_mapping_init s1) as (γmap) "[Hmapa Hmapf]". - iMod (model_fuel_init s1) as (γfuel) "[Hfuela Hfuelf]". - iMod (model_free_roles_init s1 (FR ∖ live_roles _ s1)) as (γfr) "[HFR Hfr]". - set (distG := - {| - heap_fairnessGS := {| - fairness_model_name := γmod; - fairness_model_mapping_name := γmap; - fairness_model_fuel_name := γfuel; - fairness_model_free_roles_name := γfr; - |} - |}). - iMod (H distG) as "Hwp". clear H. - iExists state_interp, (λ _, 0%nat ↦M ∅)%I, fork_post. - iSplitR. - { unfold config_wp. iIntros "!>!>" (???????) "?". done. } - (* iAssert (state_interp with "[Hgen Hmoda Hmodf Hmapa Hfuela HFR] Hfr [Hfuelf Hmapf]"). *) - (* { iFrame "Hmodf". unfold state_interp. simpl. iFrame. iExists {[ 0%nat := (live_roles Mdl s1) ]}, _. *) - (* iSplitL "Hfuela"; first by rewrite /auth_fuel_is /= fmap_gset_to_gmap //. *) - (* iSplitL "Hmapa"; first by rewrite /auth_mapping_is /= map_fmap_singleton //. *) - (* iSplit; first done. *) - (* iSplit; iPureIntro; [|split]. *) - (* - intros ρ tid. rewrite lookup_gset_to_gmap_Some. *) - (* setoid_rewrite lookup_singleton_Some. split; naive_solver. *) - (* - intros tid Hlocs. rewrite lookup_singleton_ne //. compute in Hlocs. set_solver. *) - (* - rewrite dom_gset_to_gmap. set_solver. } *) - iSpecialize ("Hwp" with "Hσ Hmodf Hfr [Hfuelf Hmapf]"). - { rewrite /has_fuels /frag_mapping_is /= map_fmap_singleton. iFrame. - iAssert ([∗ set] ρ ∈ live_roles M s1, ρ ↦F (LM.(lm_fl) s1))%I with "[Hfuelf]" as "H". - - unfold frag_fuel_is. setoid_rewrite map_fmap_singleton. - rewrite -big_opS_own //. iApply (own_proper with "Hfuelf"). - rewrite -big_opS_auth_frag. f_equiv. rewrite gset_to_gmap_singletons //. - - rewrite dom_gset_to_gmap. iFrame. - iApply (big_sepS_mono with "H"). iIntros (ρ Hin) "H". - iExists _. iFrame. iPureIntro. apply lookup_gset_to_gmap_Some. done. } - iDestruct "Hwp" as ">[Hwp H]". - iModIntro. iFrame "Hwp". - iSplitL "Hgen Hmoda Hmapa Hfuela HFR". - { unfold state_interp. simpl. iFrame. iExists {[ 0%nat := (live_roles M s1) ]}, _. - iSplitL "Hfuela"; first by rewrite /auth_fuel_is /= fmap_gset_to_gmap //. - iSplitL "Hmapa"; first by rewrite /auth_mapping_is /= map_fmap_singleton //. - iSplit; first done. - iSplit; iPureIntro; [|split]. - - intros ρ tid. rewrite lookup_gset_to_gmap_Some. - setoid_rewrite lookup_singleton_Some. split; naive_solver. - - intros tid Hlocs. rewrite lookup_singleton_ne //. compute in Hlocs. set_solver. - - rewrite dom_gset_to_gmap. set_solver. } - iIntros (ex atr c Hvalex Hstartex Hstartatr Hendex Hcontr Hstuck Hequiv) "Hsi Hposts". - assert ( ∀ (ex' : finite_trace (cfg heap_lang) (olocale heap_lang)) (atr' : auxiliary_trace LM) (oζ : olocale heap_lang) (ℓ : mlabel LM), - trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' (map_underlying_trace atr')) as Hcontr'. - { intros ex' atr' oζ ℓ H1 H2. cut (sim_rel_with_user LM ξ ex' atr'); eauto. rewrite /sim_rel_with_user. intros [??]. done. } - iSpecialize ("H" $! ex atr c Hvalex Hstartex Hstartatr Hendex Hcontr' Hstuck). - unfold sim_rel_with_user. - iAssert (|={⊤}=> ⌜ξ ex (map_underlying_trace atr)⌝ ∗ state_interp ex atr ∗ posts_of c.1 - ((λ _ : language.val heap_lang, 0%nat ↦M ∅) - :: ((λ '(tnew, e), fork_post (language.locale_of tnew e)) <$> - prefixes_from [e1] (drop (length [e1]) c.1))))%I with "[Hsi H Hposts]" as "H". - { iApply fupd_plain_keep_l. iFrame. iIntros "[Hsi Hposts]". - iSpecialize ("H" with "Hsi Hposts"). - by iApply fupd_plain_mask_empty. } - iMod "H" as "[H1 [Hsi Hposts]]". - destruct ex as [c'|ex' tid (e, σ)]. - - (* We need to prove that the initial state satisfies the property *) - destruct atr as [δ|???]; last by inversion Hvalex. simpl. - have Heq1 := trace_singleton_ends_in_inv _ _ Hendex. - have Heq3 := trace_singleton_starts_in_inv _ _ Hstartex. - have Heq4 := trace_singleton_starts_in_inv _ _ Hstartex. - pose proof (trace_singleton_starts_in_inv _ _ Hstartatr). simpl. - simplify_eq. - iApply (fupd_mask_weaken ∅); first set_solver. iIntros "_ !>". - assert (∀ (ρ : fmrole M) (tid : nat), - ls_mapping (initial_ls (LM := LM) s1 0%nat) !! ρ = Some tid → - is_Some (([e1], σ1).1 !! tid)) as HA. - { simpl. intros ρ tid Hsome. apply lookup_gset_to_gmap_Some in Hsome as [??]. - simplify_eq. by eexists _. } - iSplit; last done. iClear "H1". - iSplit; first done. - destruct (to_val e1) as [v1|] eqn:Heq. - + iSplit. - { iPureIntro. intros ρ tid Hinit. - simpl in *. apply lookup_gset_to_gmap_Some in Hinit as [_ <-]. - rewrite /from_locale //. } - iIntros (tid e Hsome Hnoval ρ). destruct tid; last done. - simpl in Hsome. compute in Hsome. simplify_eq. simpl. - iAssert (0%nat ↦M ∅) with "[Hposts]" as "Hem". - { rewrite /= Heq /fmap /=. by iDestruct "Hposts" as "[??]". } - iDestruct "Hsi" as "(_&_&Hsi)". - iDestruct "Hsi" as "(%m&%FR'&Hfuela&Hmapa&HFR&%Hinvmap&%Hsmall&Hmodel&HfrFR)". - iDestruct (frag_mapping_same 0%nat m with "[Hmapa] Hem") as "%H"; first done. - iPureIntro. by eapply no_locale_empty. - + iSplit; iPureIntro. - { simpl. intros ρ tid Hsome. apply lookup_gset_to_gmap_Some in Hsome as [??]. - simplify_eq. by eexists _. } - intros tid e Hsome Hval' ρ. - destruct tid as [|tid]; rewrite /from_locale /= in Hsome; by simplify_eq. - - (* We need to prove that that the property is preserved *) - destruct atr as [|atr' ℓ δ]; first by inversion Hvalex. - (* rewrite (trace_singleton_ends_in_inv _ _ Hendex); last exact unit. *) - specialize (Hcontr ex' atr' tid ℓ). - have H: trace_contract (trace_extend ex' tid (e, σ)) tid ex' by eexists. - have H': trace_contract (trace_extend atr' ℓ δ) ℓ atr' by eexists. - specialize (Hcontr H H') as Hvs. clear H H' Hcontr. - (* destruct Hvalex as (Hlm & Hlt & Hts). *) - have H: trace_ends_in ex' (trace_last ex') by eexists. - have H': trace_ends_in atr' (trace_last atr') by eexists. - iApply (fupd_mask_weaken ∅); first set_solver. iIntros "_ !>". - apply (trace_singleton_ends_in_inv (L := unit)) in Hendex. - simpl in *. simplify_eq. - iDestruct "Hsi" as "((%&%&%Htids)&_&Hsi)". - iDestruct "Hsi" as "(%m&%&Hfuela&Hmapa&?&%Hinvmap&%Hsmall&Hmodel&?)". - iSplit; [|done]. - iSplit; [done|]. - iSplit. - + iPureIntro. intros ρ tid' Hsome. simpl. unfold tids_smaller in Htids. eapply Htids. done. - + iIntros (tid' e' Hsome Hnoval ρ). simpl. - iAssert (tid' ↦M ∅) with "[Hposts]" as "H". - { destruct (to_val e') as [?|] eqn:Heq; last done. - iApply posts_of_empty_mapping => //. - apply from_locale_lookup =>//. } - iDestruct (frag_mapping_same tid' m with "Hmapa H") as "%Hlk". - { rewrite /auth_mapping_is. iPureIntro. by eapply no_locale_empty. } -Qed. - -Theorem simulation_adequacy Σ `(LM:LiveModel heap_lang M) `{!heapGpreS Σ LM} (s: stuckness) (e1 : expr) σ1 (s1: M) (FR: gset _): - (* The model has finite branching *) - rel_finitary (sim_rel LM) → - live_roles M s1 ≠ ∅ -> - (* The initial configuration satisfies certain properties *) - (* A big implication, and we get back a Coq proposition *) - (* For any proper Aneris resources *) - (∀ `{!heapGS Σ LM}, - ⊢ |={⊤}=> - frag_model_is s1 -∗ - frag_free_roles_are (FR ∖ live_roles _ s1) -∗ - has_fuels (Σ := Σ) 0%nat (gset_to_gmap (LM.(lm_fl) s1) (M.(live_roles) s1)) - ={⊤}=∗ WP e1 @ s; 0%nat; ⊤ {{ v, 0%nat ↦M ∅ }} - ) -> - (* The coinductive pure coq proposition given by adequacy *) - @continued_simulation - heap_lang - LM - (sim_rel LM) - (trace_singleton ([e1], σ1)) - (trace_singleton (initial_ls (LM := LM) s1 0%nat)). -Proof. - intros Hfevol Hne H. - assert (sim_rel LM = sim_rel_with_user LM (λ _ _, True)) as Heq. - { Require Import Coq.Logic.FunctionalExtensionality. - Require Import Coq.Logic.PropExtensionality. - do 2 (apply functional_extensionality_dep; intros ?). - apply propositional_extensionality. - unfold sim_rel_with_user. intuition. } - - rewrite Heq. - apply (strong_simulation_adequacy Σ LM s _ _ _ FR) =>//. - { rewrite -Heq. done. } - iIntros (Hinv) "". - iPoseProof (H Hinv) as ">H". iModIntro. iIntros "Hσ Hm Hfr Hf". iSplitR "". - - iApply ("H" with "Hm Hfr Hf"). - - iIntros "!>%%%????????". iApply (fupd_mask_weaken ∅); first set_solver. by iIntros "_ !>". -Qed. - -Theorem simulation_adequacy_inftraces Σ `(LM: LiveModel heap_lang M) - `{!heapGpreS Σ LM} (s: stuckness) FR - e1 σ1 (s1: M) - (iex : inf_execution_trace heap_lang) - (Hvex : valid_inf_exec (trace_singleton ([e1], σ1)) iex) - : - (* The model has finite branching *) - rel_finitary (sim_rel LM) → - live_roles M s1 ≠ ∅ -> - (∀ `{!heapGS Σ LM}, - ⊢ |={⊤}=> - frag_model_is s1 -∗ - frag_free_roles_are (FR ∖ live_roles _ s1) -∗ - has_fuels (Σ := Σ) 0%nat (gset_to_gmap (LM.(lm_fl) s1) (M.(live_roles) s1)) - ={⊤}=∗ WP e1 @ s; 0%nat; ⊤ {{ v, 0%nat ↦M ∅ }} - ) -> - (* The coinductive pure coq proposition given by adequacy *) - exists iatr, - @valid_inf_system_trace _ LM - (@continued_simulation - heap_lang - LM - (sim_rel LM)) - (trace_singleton ([e1], σ1)) - (trace_singleton (initial_ls (LM := LM) s1 0%nat)) - iex - iatr. -Proof. - intros Hfin Hlr Hwp. - eexists. - eapply produced_inf_aux_trace_valid_inf. - Unshelve. - - econstructor. - - apply (simulation_adequacy Σ LM s _ _ _ FR) => //. - - done. -Qed. - -Definition heap_lang_extrace : Type := extrace heap_lang. - -Theorem simulation_adequacy_traces Σ `(LM : LiveModel heap_lang M) `{!heapGpreS Σ LM} (s: stuckness) FR - e1 (s1: M) - (extr : heap_lang_extrace) - (Hvex : extrace_valid extr) - (Hexfirst : (trfirst extr).1 = [e1]) - : - (* The model has finite branching *) - rel_finitary (sim_rel LM) → - live_roles M s1 ≠ ∅ -> - (∀ `{!heapGS Σ LM}, - ⊢ |={⊤}=> - frag_model_is s1 -∗ - frag_free_roles_are (FR ∖ live_roles _ s1) -∗ - has_fuels (Σ := Σ) 0%nat (gset_to_gmap (LM.(lm_fl) s1) (M.(live_roles) s1)) - ={⊤}=∗ WP e1 @ s; 0%nat; ⊤ {{ v, 0%nat ↦M ∅ }} - ) -> - (* The coinductive pure coq proposition given by adequacy *) - ∃ (auxtr : auxtrace LM), exaux_traces_match extr auxtr. -Proof. - intros Hfin Hlr Hwp. - have [iatr Hbig] : exists iatr, - @valid_inf_system_trace - heap_lang LM - (@continued_simulation - heap_lang - LM - (sim_rel LM)) - (trace_singleton ([e1], (trfirst extr).2)) - (trace_singleton (initial_ls (LM := LM) s1 0%nat)) - (from_trace extr) - iatr. - { apply (simulation_adequacy_inftraces _ _ s FR); eauto. - eapply from_trace_preserves_validity; eauto; first econstructor. - simpl. destruct (trfirst extr) eqn:Heq. - simpl in Hexfirst. rewrite -Hexfirst Heq //. } - exists (to_trace (initial_ls (LM := LM) s1 0%nat) iatr). - eapply (valid_inf_system_trace_implies_traces_match (continued_simulation (sim_rel LM))); eauto. - - by intros ? ? [? ?]%continued_simulation_rel. - - by intros ? ? [? ?]%continued_simulation_rel. - - apply from_trace_spec. simpl. destruct (trfirst extr) eqn:Heq. simplify_eq. f_equal. - simpl in Hexfirst. rewrite -Hexfirst Heq //. - - apply to_trace_spec. -Qed. - -Theorem simulation_adequacy_model_trace Σ `(LM : LiveModel heap_lang M) - `{!heapGpreS Σ LM} (s: stuckness) FR - e1 (s1: M) - (extr : heap_lang_extrace) - (Hvex : extrace_valid extr) - (Hexfirst : (trfirst extr).1 = [e1]) - : - (* The model has finite branching *) - rel_finitary (sim_rel LM) → - live_roles M s1 ≠ ∅ -> - (∀ `{!heapGS Σ LM}, - ⊢ |={⊤}=> - frag_model_is s1 -∗ - frag_free_roles_are (FR ∖ live_roles _ s1) -∗ - has_fuels (Σ := Σ) 0%nat (gset_to_gmap (LM.(lm_fl) s1) (M.(live_roles) s1)) - ={⊤}=∗ WP e1 @ s; 0%nat; ⊤ {{ v, 0%nat ↦M ∅ }} - ) -> - (* The coinductive pure coq proposition given by adequacy *) - ∃ (auxtr : auxtrace LM) mtr, exaux_traces_match extr auxtr ∧ - upto_stutter ls_under Ul auxtr mtr. -Proof. - intros Hfb Hlr Hwp. - destruct (simulation_adequacy_traces - Σ _ _ FR e1 s1 extr Hvex Hexfirst Hfb Hlr Hwp) as [auxtr Hmatch]. - assert (auxtrace_valid auxtr) as Hstutter. - { by eapply exaux_preserves_validity in Hmatch. } - destruct (can_destutter_auxtr auxtr) as [mtr Hupto] =>//. - eauto. -Qed. - -Theorem simulation_adequacy_terminate Σ `{LM:LiveModel heap_lang Mdl} - `{!heapGpreS Σ LM} (s: stuckness) - e1 (s1: Mdl) FR - (extr : heap_lang_extrace) - (Hexfirst : (trfirst extr).1 = [e1]) - : - (∀ mtr : @mtrace Mdl, mtrace_fairly_terminating mtr) -> - (* The model has finite branching *) - rel_finitary (sim_rel LM) → - live_roles Mdl s1 ≠ ∅ -> - (∀ `{!heapGS Σ LM}, - ⊢ |={⊤}=> - frag_model_is s1 -∗ - frag_free_roles_are (FR ∖ live_roles _ s1) -∗ - has_fuels (Σ := Σ) 0%nat (gset_to_gmap (LM.(lm_fl) s1) (Mdl.(live_roles) s1)) - ={⊤}=∗ WP e1 @ s; 0%nat; ⊤ {{ v, 0%nat ↦M ∅ }} - ) -> - (* The coinductive pure coq proposition given by adequacy *) - extrace_fairly_terminating extr. -Proof. - intros Hterm Hfb Hlr Hwp Hvex Hfair. - destruct (simulation_adequacy_model_trace - Σ _ _ FR e1 s1 extr Hvex Hexfirst Hfb Hlr Hwp) as (auxtr&mtr&Hmatch&Hupto). - destruct (infinite_or_finite extr) as [Hinf|] =>//. - have Hfairaux := fairness_preserved extr auxtr Hinf Hmatch Hfair. - have Hvalaux := exaux_preserves_validity extr auxtr Hmatch. - have Hfairm := upto_stutter_fairness auxtr mtr Hupto Hfairaux. - have Hmtrvalid := upto_preserves_validity auxtr mtr Hupto Hvalaux. - have Htermtr := Hterm mtr Hmtrvalid Hfairm. - eapply exaux_preserves_termination =>//. - eapply upto_stutter_finiteness =>//. -Qed. - -Theorem simulation_adequacy_terminate_ftm Σ `{FairTerminatingModel M} - `(LM : LiveModel heap_lang M) - `{!heapGpreS Σ LM} (s: stuckness) - e1 (s1: M) FR - (extr : heap_lang_extrace) - (Hexfirst : (trfirst extr).1 = [e1]) - : - (* The model has finite branching *) - rel_finitary (sim_rel LM) → - live_roles M s1 ≠ ∅ -> - (∀ `{!heapGS Σ LM}, - ⊢ |={⊤}=> - frag_model_is s1 -∗ - frag_free_roles_are (FR ∖ live_roles _ s1) -∗ - has_fuels (Σ := Σ) 0%nat (gset_to_gmap (LM.(lm_fl) s1) (M.(live_roles) s1)) - ={⊤}=∗ WP e1 @ s; 0%nat; ⊤ {{ v, 0%nat ↦M ∅ }} - ) -> - (* The coinductive pure coq proposition given by adequacy *) - extrace_fairly_terminating extr. -Proof. - eapply simulation_adequacy_terminate =>//. - apply fair_terminating_traces_terminate. -Qed. - -End adequacy. - -(** Override the notations so that scopes and coercions work out *) -Notation "l ↦{ q } v" := (mapsto (L:=loc) (V:=val) l (DfracOwn q) v%V) - (at level 20, q at level 50, format "l ↦{ q } v") : bi_scope. -Notation "l ↦ v" := - (mapsto (L:=loc) (V:=val) l (DfracOwn 1) v%V) (at level 20) : bi_scope. -Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I - (at level 20, q at level 50, format "l ↦{ q } -") : bi_scope. -Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : bi_scope. - -(** The tactic [inv_head_step] performs inversion on hypotheses of the shape -[head_step]. The tactic will discharge head-reductions starting from values, and -simplifies hypothesis related to conversions from and to values, and finite map -operations. This tactic is slightly ad-hoc and tuned for proving our lifting -lemmas. *) -Ltac inv_head_step := - repeat match goal with - | _ => progress simplify_map_eq/= (* simplify memory stuff *) - | H : to_val _ = Some _ |- _ => apply of_to_val in H - | H : head_step ?e _ _ _ _ |- _ => - try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable - and can thus better be avoided. *) - inversion H; subst; clear H - end. - -Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl : core. -(* Local Hint Extern 0 (head_reducible_no_obs _ _) => eexists _, _, _; simpl : core. *) - -(* [simpl apply] is too stupid, so we need extern hints here. *) -Local Hint Extern 1 (head_step _ _ _ _ _) => econstructor : core. -Local Hint Extern 0 (head_step (CmpXchg _ _ _) _ _ _ _) => eapply CmpXchgS : core. -Local Hint Extern 0 (head_step (AllocN _ _) _ _ _ _) => apply alloc_fresh : core. -Local Hint Resolve to_of_val : core. - -#[global] Instance into_val_val v : IntoVal (Val v) v. -Proof. done. Qed. -#[global] Instance as_val_val v : AsVal (Val v). -Proof. by eexists. Qed. - -Local Ltac solve_atomic := - apply strongly_atomic_atomic, ectx_language_atomic; - [inversion 1; naive_solver - |apply ectxi_language_sub_redexes_are_values; intros [] **; naive_solver]. - -#[global] Instance rec_atomic s f x e : Atomic s (Rec f x e). -Proof. solve_atomic. Qed. -#[global] Instance pair_atomic s v1 v2 : Atomic s (Pair (Val v1) (Val v2)). -Proof. solve_atomic. Qed. -#[global] Instance injl_atomic s v : Atomic s (InjL (Val v)). -Proof. solve_atomic. Qed. -#[global] Instance injr_atomic s v : Atomic s (InjR (Val v)). -Proof. solve_atomic. Qed. -(** The instance below is a more general version of [Skip] *) -#[global] Instance beta_atomic s f x v1 v2 : Atomic s (App (RecV f x (Val v1)) (Val v2)). -Proof. destruct f, x; solve_atomic. Qed. -#[global] Instance unop_atomic s op v : Atomic s (UnOp op (Val v)). -Proof. solve_atomic. Qed. -#[global] Instance binop_atomic s op v1 v2 : Atomic s (BinOp op (Val v1) (Val v2)). -Proof. solve_atomic. Qed. -#[global] Instance if_true_atomic s v1 e2 : Atomic s (If (Val $ LitV $ LitBool true) (Val v1) e2). -Proof. solve_atomic. Qed. -#[global] Instance if_false_atomic s e1 v2 : Atomic s (If (Val $ LitV $ LitBool false) e1 (Val v2)). -Proof. solve_atomic. Qed. -#[global] Instance fst_atomic s v : Atomic s (Fst (Val v)). -Proof. solve_atomic. Qed. -#[global] Instance snd_atomic s v : Atomic s (Snd (Val v)). -Proof. solve_atomic. Qed. - -#[global] Instance fork_atomic s e : Atomic s (Fork e). -Proof. solve_atomic. Qed. - -#[global] Instance alloc_atomic s v w : Atomic s (AllocN (Val v) (Val w)). -Proof. solve_atomic. Qed. -#[global] Instance load_atomic s v : Atomic s (Load (Val v)). -Proof. solve_atomic. Qed. -#[global] Instance store_atomic s v1 v2 : Atomic s (Store (Val v1) (Val v2)). -Proof. solve_atomic. Qed. -#[global] Instance cmpxchg_atomic s v0 v1 v2 : Atomic s (CmpXchg (Val v0) (Val v1) (Val v2)). -Proof. solve_atomic. Qed. -#[global] Instance faa_atomic s v1 v2 : Atomic s (FAA (Val v1) (Val v2)). -Proof. solve_atomic. Qed. - -Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto. -Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step. -Local Ltac solve_pure_exec := - subst; intros ?; apply nsteps_once, pure_head_step_pure_step; - constructor; [solve_exec_safe | solve_exec_puredet]. - -(** The behavior of the various [wp_] tactics with regard to lambda differs in -the following way: - -- [wp_pures] does *not* reduce lambdas/recs that are hidden behind a definition. -- [wp_rec] and [wp_lam] reduce lambdas/recs that are hidden behind a definition. - -To realize this behavior, we define the class [AsRecV v f x erec], which takes a -value [v] as its input, and turns it into a [RecV f x erec] via the instance -[AsRecV_recv : AsRecV (RecV f x e) f x e]. We register this instance via -[Hint Extern] so that it is only used if [v] is syntactically a lambda/rec, and -not if [v] contains a lambda/rec that is hidden behind a definition. - -To make sure that [wp_rec] and [wp_lam] do reduce lambdas/recs that are hidden -behind a definition, we activate [AsRecV_recv] by hand in these tactics. *) -Class AsRecV (v : val) (f x : binder) (erec : expr) := - as_recv : v = RecV f x erec. -#[global] Hint Mode AsRecV ! - - - : typeclass_instances. -Definition AsRecV_recv f x e : AsRecV (RecV f x e) f x e := eq_refl. -#[global] Hint Extern 0 (AsRecV (RecV _ _ _) _ _ _) => - apply AsRecV_recv : typeclass_instances. - -#[global] Instance pure_recc f x (erec : expr) : - PureExec True 1 (Rec f x erec) (Val $ RecV f x erec). -Proof. solve_pure_exec. Qed. -#[global] Instance pure_pairc (v1 v2 : val) : - PureExec True 1 (Pair (Val v1) (Val v2)) (Val $ PairV v1 v2). -Proof. solve_pure_exec. Qed. -#[global] Instance pure_injlc (v : val) : - PureExec True 1 (InjL $ Val v) (Val $ InjLV v). -Proof. solve_pure_exec. Qed. -#[global] Instance pure_injrc (v : val) : - PureExec True 1 (InjR $ Val v) (Val $ InjRV v). -Proof. solve_pure_exec. Qed. - -#[global] Instance pure_beta f x (erec : expr) (v1 v2 : val) `{!AsRecV v1 f x erec} : - PureExec True 1 (App (Val v1) (Val v2)) (subst' x v2 (subst' f v1 erec)). -Proof. unfold AsRecV in *. solve_pure_exec. Qed. - -#[global] Instance pure_unop op v v' : - PureExec (un_op_eval op v = Some v') 1 (UnOp op (Val v)) (Val v'). -Proof. solve_pure_exec. Qed. - -#[global] Instance pure_binop op v1 v2 v' : - PureExec (bin_op_eval op v1 v2 = Some v') 1 (BinOp op (Val v1) (Val v2)) (Val v') | 10. -Proof. solve_pure_exec. Qed. -(* Higher-priority instance for [EqOp]. *) -#[global] Instance pure_eqop v1 v2 : - PureExec (vals_compare_safe v1 v2) 1 - (BinOp EqOp (Val v1) (Val v2)) - (Val $ LitV $ LitBool $ bool_decide (v1 = v2)) | 1. -Proof. - intros Hcompare. - cut (bin_op_eval EqOp v1 v2 = Some $ LitV $ LitBool $ bool_decide (v1 = v2)). - { intros. revert Hcompare. solve_pure_exec. } - rewrite /bin_op_eval /= decide_True //. -Qed. - -#[global] Instance pure_if_true e1 e2 : PureExec True 1 (If (Val $ LitV $ LitBool true) e1 e2) e1. -Proof. solve_pure_exec. Qed. - -#[global] Instance pure_if_false e1 e2 : PureExec True 1 (If (Val $ LitV $ LitBool false) e1 e2) e2. -Proof. solve_pure_exec. Qed. - -#[global] Instance pure_fst v1 v2 : - PureExec True 1 (Fst (Val $ PairV v1 v2)) (Val v1). -Proof. solve_pure_exec. Qed. - -#[global] Instance pure_snd v1 v2 : - PureExec True 1 (Snd (Val $ PairV v1 v2)) (Val v2). -Proof. solve_pure_exec. Qed. - -#[global] Instance pure_case_inl v e1 e2 : - PureExec True 1 (Case (Val $ InjLV v) e1 e2) (App e1 (Val v)). -Proof. solve_pure_exec. Qed. - -#[global] Instance pure_case_inr v e1 e2 : - PureExec True 1 (Case (Val $ InjRV v) e1 e2) (App e2 (Val v)). -Proof. solve_pure_exec. Qed. - -Notation "f ⇂ R" := (filter (λ '(k,v), k ∈ R) f) (at level 30). - -Lemma own_proper `{inG Σ X} γ (x y: X): - x ≡ y -> - own γ x -∗ own γ y. -Proof. by intros ->. Qed. - -Lemma auth_fuel_is_proper `{heapGS Σ Mdl} (x y : gmap (fmrole Mdl) nat): - x = y -> - auth_fuel_is x -∗ auth_fuel_is y. -Proof. by intros ->. Qed. - -Section lifting. -Context `{LM:LiveModel heap_lang M}. -Context `{!heapGS Σ LM}. -Implicit Types P Q : iProp Σ. -Implicit Types Φ : val → iProp Σ. -Implicit Types efs : list expr. -Implicit Types σ : state. -Implicit Types v : val. -Implicit Types l : loc. -Implicit Types tid : nat. - - -Lemma wp_lift_pure_step_no_fork tid E E' Φ e1 e2 fs ϕ: - fs ≠ ∅ -> - PureExec ϕ 1 e1 e2 -> - ϕ -> - (|={E}[E']▷=> has_fuels_S tid fs ∗ ((has_fuels tid fs) -∗ WP e2 @ tid; E {{ Φ }})) - ⊢ WP e1 @ tid; E {{ Φ }}. -Proof. - intros NnO Hpe Hϕ. - have Hps: pure_step e1 e2. - { specialize (Hpe Hϕ). by apply nsteps_once_inv in Hpe. } - iIntros "H". iApply wp_lift_step; eauto. - { destruct Hps as [Hred _]. specialize (Hred inhabitant). eapply reducible_not_val; eauto. } - iIntros (extr auxtr K tp1 tp2 σ1 Hvalex Hexend Hloc) "Hsi". - iMod "H". iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. - iSplit; first by destruct Hps as [Hred _]. - iNext. iIntros (e2' σ2 efs Hpstep). - destruct Hps as [? Hdet]. specialize (Hdet _ _ _ _ Hpstep) as (?&?&?). - simplify_eq. iMod "Hclose" as "_". iMod "H" as "[Hfuels Hkont]". - rewrite !app_nil_r. - iDestruct "Hsi" as "(%&Hgh&Hmi)". - (* iDestruct "Hmi" as (??) "(?&?&?&?&?&?&%)". *) - - iMod (update_no_step_enough_fuel _ _ ∅ with "Hfuels Hmi") as "H"; eauto; - [by intros X%dom_empty_inv_L | set_solver | set_solver | econstructor =>//; by apply fill_step |]. - iModIntro. - iDestruct ("H") as (δ2 ℓ [Hlabels Hvse]) "[Hfuels Hmi]". - iExists δ2, ℓ. - rewrite /state_interp /=. - rewrite Hexend /=. list_simplifier. iFrame "Hgh Hmi". - repeat iSplit; last done. - - iPureIntro. destruct ℓ =>//. - - iPureIntro. destruct Hvse as (?&?&? )=>//. - - iPureIntro. destruct Hvse as (?&?&? )=>//. - - iApply "Hkont". iApply (has_fuels_proper with "Hfuels") =>//. - rewrite map_filter_id //. intros ?? ?%elem_of_dom_2; set_solver. -Qed. - -Lemma wp_lift_pure_step_no_fork_remove_role rem s tid E E' Φ e1 e2 fs ϕ: - fs ≠ ∅ -> - rem ⊆ dom fs → - rem ∩ live_roles _ s = ∅ → - PureExec ϕ 1 e1 e2 -> - ϕ -> - (|={E}[E']▷=> frag_model_is s ∗ has_fuels_S tid fs ∗ - (frag_model_is s -∗ (has_fuels tid (fs ⇂ (dom fs ∖ rem))) -∗ WP e2 @ tid; E {{ Φ }})) - ⊢ WP e1 @ tid; E {{ Φ }}. -Proof. - intros NnO Hincl Hdisj Hpe Hϕ. - have Hps: pure_step e1 e2. - { specialize (Hpe Hϕ). by apply nsteps_once_inv in Hpe. } - iIntros "H". iApply wp_lift_step; eauto. - { destruct Hps as [Hred _]. specialize (Hred inhabitant). eapply reducible_not_val; eauto. } - iIntros (extr auxtr K tp1 tp2 σ1 Hvalex Hexend Hloc) "Hsi". - iMod "H". iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. - iSplit; first by destruct Hps as [Hred _]. - iNext. iIntros (e2' σ2 efs Hpstep). - destruct Hps as [? Hdet]. specialize (Hdet _ _ _ _ Hpstep) as (?&?&?). - simplify_eq. iMod "Hclose" as "_". iMod "H" as "(Hmod & Hfuels & Hkont)". - rewrite !app_nil_r. - iDestruct "Hsi" as "(%&Hgh&Hmi)". - iDestruct (model_agree' with "Hmi Hmod") as %Heq. - - iMod (update_no_step_enough_fuel _ _ rem with "Hfuels Hmi") as "H"; eauto; - [by intros X%dom_empty_inv_L | set_solver | econstructor =>//; by apply fill_step |]. - iModIntro. - iDestruct ("H") as (δ2 ℓ [Hlabels Hvse]) "[Hfuels Hmi]". - iExists δ2, ℓ. - rewrite /state_interp /=. - rewrite Hexend /=. list_simplifier. iFrame "Hgh Hmi". - repeat iSplit; last done. - - iPureIntro. destruct ℓ =>//. - - iPureIntro. destruct Hvse as (?&?&? )=>//. - - iPureIntro. destruct Hvse as (?&?&? )=>//. - - iApply ("Hkont" with "Hmod"). iApply (has_fuels_proper with "Hfuels") =>//. -Qed. - -(* Lemma wp_lift_pure_step_no_fork_2 tid E E' Φ e1 e2 (fs: gmap (fmrole Mdl) nat) R ϕ: *) -(* R ≠ ∅ -> *) -(* PureExec ϕ 1 e1 e2 -> *) -(* ϕ -> *) -(* (forall (ρ: fmrole Mdl) (f: nat), fs !! ρ = Some f -> f > 0) -> *) -(* (|={E}[E']▷=> has_fuels tid R fs ∗ ((has_fuels tid R (fmap (λ (x: nat), (x - 1)%nat) fs)) -∗ WP e2 @ tid; E {{ Φ }})) *) -(* ⊢ WP e1 @ tid; E {{ Φ }}. *) -(* Proof. *) - -Lemma wp_lift_pure_step_no_fork' fs tid E E' Φ e1 e2: - fs ≠ ∅ -> - PureExec True 1 e1 e2 -> - (|={E}[E']▷=> has_fuels_S tid fs ∗ ((has_fuels tid fs) -∗ WP e2 @ tid; E {{ Φ }})) - ⊢ WP e1 @ tid; E {{ Φ }}. -Proof. - intros. by iApply wp_lift_pure_step_no_fork. -Qed. - -Lemma wp_lift_pure_step_no_fork_singlerole tid E E' Φ e1 e2 ρ f φ: - PureExec φ 1 e1 e2 -> φ -> - (|={E}[E']▷=> has_fuel tid ρ (S f) ∗ ((has_fuel tid ρ f) -∗ WP e2 @ tid; E {{ Φ }})) - ⊢ WP e1 @ tid; E {{ Φ }}. -Proof. - iIntros (??) "H". rewrite has_fuel_fuels_S. - iApply (wp_lift_pure_step_no_fork {[ ρ := f ]} {[ρ]}); eauto; last first. - rewrite has_fuel_fuels //. apply map_non_empty_singleton. -Qed. - -Lemma wp_lift_pure_step_no_fork_take_step s1 s2 tid E E' fs1 fs2 fr1 Φ e1 e2 ρ φ: - PureExec φ 1 e1 e2 -> φ -> - valid_new_fuelmap (LM := LM) fs1 fs2 s1 s2 ρ -> - live_roles M s2 ∖ live_roles M s1 ⊆ fr1 → - M.(fmtrans) s1 (Some ρ) s2 -> - (|={E}[E']▷=> frag_model_is s1 ∗ has_fuels tid fs1 ∗ frag_free_roles_are fr1 ∗ - (frag_model_is s2 -∗ frag_free_roles_are (fr1 ∖ (live_roles M s2 ∖ live_roles M s1)) - -∗ (has_fuels tid fs2 -∗ WP e2 @ tid; E {{ Φ }}))) - ⊢ WP e1 @ tid; E {{ Φ }}. -Proof. - iIntros (Hpe Hφ Hval Hfr Htrans). - have Hps: pure_step e1 e2. - { specialize (Hpe Hφ). by apply nsteps_once_inv in Hpe. } - iIntros "Hkont". - iApply wp_lift_step; eauto. - { destruct (pure_step_safe _ e2 Hps inhabitant) as (?&?&?&?). by eapply val_stuck. } - - iIntros (extr auxtr K tp1 tp2 σ1 Hvalex Hexend Hloc) "Hsi". - iMod "Hkont". iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. - iSplit; first by destruct Hps as [Hred _]. - iNext. iIntros (e2' σ2 efs Hpstep). - destruct Hps as [? Hdet]. specialize (Hdet _ _ _ _ Hpstep) as (?&?&?). - simplify_eq. iMod "Hclose" as "_". iMod "Hkont" as "(Hmod&Hfuels&Hfr&Hkont)". - rewrite !app_nil_r. - iDestruct "Hsi" as "(%&Hgh&Hmi)". simpl. - iDestruct (model_agree' with "Hmi Hmod") as %Hmeq. - - iMod (update_step_still_alive _ _ _ _ σ1 σ1 with "Hfuels Hmod Hmi Hfr") as "H"; eauto. - { rewrite Hexend. eauto. } - { econstructor =>//. - - rewrite Hexend //=. - - by apply fill_step. } - { rewrite Hmeq. apply Hval. } - iModIntro. iDestruct "H" as (δ2 ℓ [Hlabels Hvse]) "(Hfuels&Hmod&Hmi&Hfr)". - iExists δ2, ℓ. - rewrite Hexend /=. list_simplifier. iFrame "Hgh Hmi". - repeat iSplit; last done. - - iPureIntro. destruct ℓ =>//. - - iPureIntro. destruct Hvse as (?&?&? )=>//. - - iPureIntro. destruct Hvse as (?&?&? )=>//. - - by iSpecialize ("Hkont" with "Hmod Hfr Hfuels"). -Qed. - -Lemma wp_lift_pure_step_no_fork_singlerole_take_step s1 s2 tid E E' (f1 f2: nat) fr Φ e1 e2 ρ φ: - PureExec φ 1 e1 e2 -> φ -> - live_roles _ s2 ⊆ live_roles _ s1 -> - (f2 ≤ LM.(lm_fl) s2)%nat -> M.(fmtrans) s1 (Some ρ) s2 -> - (|={E}[E']▷=> frag_model_is s1 ∗ frag_free_roles_are fr ∗ has_fuel tid ρ f1 ∗ - (frag_model_is s2 -∗ frag_free_roles_are fr -∗ (if decide (ρ ∈ live_roles M s2) then has_fuel tid ρ f2 else tid ↦M ∅) -∗ - WP e2 @ tid; E {{ Φ }})) - ⊢ WP e1 @ tid; E {{ Φ }}. -Proof. - iIntros (Hpe Hφ Hroles Hfl Hmdl). - rewrite has_fuel_fuels. - iIntros "H". - iApply (wp_lift_pure_step_no_fork_take_step _ _ _ _ _ {[ρ := f1]} - (if decide (ρ ∈ live_roles M s2) then {[ρ := f2]} else ∅) fr with "[H]"); eauto. - - repeat split. - + intros ?. rewrite decide_True //. rewrite lookup_singleton //=. - + destruct (decide (ρ ∈ live_roles _ s2)); set_solver. - + set_solver. - + intros ρ' Hdom. destruct (decide (ρ ∈ live_roles M s2)); set_solver. - + intros ρ' Hneq Hin. destruct (decide (ρ ∈ live_roles M s2)); set_solver. - + destruct (decide (ρ ∈ live_roles M s2)); set_solver. - + destruct (decide (ρ ∈ live_roles M s2)); set_solver. - - set_solver. - - iMod "H". do 2 iModIntro. iMod "H" as "(Hmod&Hfr&Hfuels&Hkont)". iModIntro. - iFrame "Hmod Hfr Hfuels". iIntros "Hmod Hfr Hfuels". iApply ("Hkont" with "Hmod [Hfr] [Hfuels]"). - + replace (fr ∖ (live_roles M s2 ∖ live_roles M s1)) with fr; [done|set_solver]. - + destruct (decide (ρ ∈ live_roles M s2)). - * rewrite -has_fuel_fuels //. - * iDestruct "Hfuels" as "[Hf _]". rewrite dom_empty_L //. -Qed. - -Lemma wp_lift_pure_step_no_fork_singlerole' tid E E' Φ e1 e2 ρ f: - PureExec True 1 e1 e2 -> - (|={E}[E']▷=> has_fuel tid ρ (S f) ∗ ((has_fuel tid ρ f) -∗ WP e2 @ tid; E {{ Φ }})) - ⊢ WP e1 @ tid; E {{ Φ }}. -Proof. - iIntros (?) "H". rewrite has_fuel_fuels_S. - iApply (wp_lift_pure_step_no_fork' {[ ρ := f ]} {[ρ]}); last first. - rewrite has_fuel_fuels //. apply map_non_empty_singleton. -Qed. - -(** Fork: Not using Texan triples to avoid some unnecessary [True] *) -Lemma wp_fork_nostep s tid E e Φ R1 R2 fs (Hdisj: R1 ## R2) (Hnemp: fs ≠ ∅): - R1 ∪ R2 = dom fs -> - (∀ tid', ▷ (has_fuels tid' (fs ⇂ R2) -∗ WP e @ s; tid'; ⊤ {{ _, tid' ↦M ∅ }})) -∗ - ▷ (has_fuels tid (fs ⇂ R1) ={E}=∗ Φ (LitV LitUnit)) -∗ - has_fuels_S tid fs -∗ WP Fork e @ s; tid; E {{ Φ }}. -Proof. - iIntros (Hunioneq) "He HΦ Htid". iApply wp_lift_atomic_head_step; [done|]. - iIntros (extr auxtr K tp1 tp2 σ1 Hvalex Hexend Hloc) "(% & Hsi & Hmi)". - iMod (update_fork_split R1 R2 _ - (tp1 ++ ectx_language.fill K (Val $ LitV LitUnit) :: tp2 ++ [e]) fs _ _ _ e _ σ1 with "Htid Hmi") as - (δ2) "(Hfuels2 & Hfuels1 & Hσ & %Hvse)" => //. - { rewrite -Hloc. rewrite -(language.locale_fill _ _ K). econstructor 1 =>//. - apply fill_step, head_prim_step. econstructor. } - { list_simplifier. exists (tp1 ++ fill K #() :: tp2). split; first by list_simplifier. - rewrite !app_length //=. } - iModIntro. iSplit. iPureIntro; first by eauto. iNext. - iIntros (e2 σ2 efs Hstep). - have [-> [-> ->]] : σ2 = σ1 ∧ efs = [e] ∧ e2 = Val $ LitV LitUnit by inv_head_step. - iMod ("HΦ" with "Hfuels1") as "HΦ". iModIntro. iExists δ2, (Silent_step tid). iFrame. - rewrite Hexend /=. iFrame "Hsi". - iSplit; first by iPureIntro. - iSplit; [|done]. - iApply "He". by list_simplifier. -Qed. - -(** Heap *) -(** The usable rules for [allocN] stated in terms of the [array] proposition -are derived in te file [array]. *) -Lemma heap_array_to_seq_meta l vs (n : nat) : - length vs = n → - ([∗ map] l' ↦ _ ∈ heap_array l vs, meta_token l' ⊤) -∗ - [∗ list] i ∈ seq 0 n, meta_token (l +ₗ (i : nat)) ⊤. -Proof. - iIntros (<-) "Hvs". iInduction vs as [|v vs] "IH" forall (l)=> //=. - rewrite big_opM_union; last first. - { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _]. - intros (j&?&Hjl&_)%heap_array_lookup. - rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. } - rewrite loc_add_0 -fmap_S_seq big_sepL_fmap. - setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l. - setoid_rewrite <-loc_add_assoc. - rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH". -Qed. - -Lemma heap_array_to_seq_mapsto l v (n : nat) : - ([∗ map] l' ↦ v ∈ heap_array l (replicate n v), l' ↦ v) -∗ - [∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦ v. -Proof. - iIntros "Hvs". iInduction n as [|n] "IH" forall (l); simpl. - { done. } - rewrite big_opM_union; last first. - { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _]. - intros (j&?&Hjl&_)%heap_array_lookup. - rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. } - rewrite loc_add_0 -fmap_S_seq big_sepL_fmap. - setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l. - setoid_rewrite <-loc_add_assoc. - rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH". -Qed. - -(* TODO *) - -Lemma wp_allocN_seq_nostep s tid E v n fs: - fs ≠ ∅ -> - 0 < n → - {{{ has_fuels_S tid fs }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; tid; E - {{{ l, RET LitV (LitLoc l); has_fuels tid fs ∗ [∗ list] i ∈ seq 0 (Z.to_nat n), - (l +ₗ (i : nat)) ↦ v ∗ meta_token (l +ₗ (i : nat)) ⊤ }}}. -Proof. - iIntros (HnO Hn Φ) "HfuelS HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (extr auxtr K tp1 tp2 σ1 Hvalex Hexend Hloc) "(% & Hsi & Hmi)". - iModIntro; iSplit; first by eauto. - iIntros (e2 σ2 efs Hstep). iNext. - inv_head_step. - iMod (gen_heap_alloc_big _ (heap_array l (replicate (Z.to_nat n) v)) with "Hsi") - as "(Hsi & Hl & Hm)". - { apply heap_array_map_disjoint. - rewrite replicate_length Z2Nat.id ?Hexend; auto with lia. } - iMod (update_no_step_enough_fuel _ _ ∅ with "HfuelS Hmi") as (δ2 ℓ) "([%Hlabel %Hvse] & Hfuel & Hmi)" =>//. - { by intros ?%dom_empty_inv_L. } - { set_solver. } - { rewrite Hexend. apply head_locale_step. by econstructor. } - iModIntro; iExists δ2, ℓ. - rewrite Hexend //=. iFrame "Hmi Hsi". - repeat iSplit =>//. - iApply "HΦ". iSplitL "Hfuel". - { iApply (has_fuels_proper with "Hfuel") =>//. - rewrite map_filter_id //. intros ???%elem_of_dom_2; set_solver. } - iApply big_sepL_sep. iSplitL "Hl". - + by iApply heap_array_to_seq_mapsto. - + iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length. -Qed. - -Lemma wp_alloc_nostep s tid E v fs : - fs ≠ ∅ -> - {{{ has_fuels_S tid fs }}} Alloc (Val v) @ s; tid; E {{{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ ∗ has_fuels tid fs }}}. -Proof. - iIntros (? Φ) "HfuelS HΦ". iApply (wp_allocN_seq_nostep with "HfuelS"); auto with lia. - iIntros "!>" (l) "/= (? & ? & _)". rewrite loc_add_0. by iApply "HΦ"; iFrame. -Qed. - -Lemma wp_choose_nat_nostep s tid E fs : - fs ≠ ∅ -> - {{{ has_fuels_S tid fs }}} - ChooseNat @ s; tid; E - {{{ (n:nat), RET LitV (LitInt n); has_fuels tid fs }}}. -Proof. - iIntros (? Φ) "HfuelS HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (extr auxtr K tp1 tp2 σ1 Hvalex Hexend Hloc) "(% & Hsi & Hmi)". - iModIntro; iSplit; eauto. - (* TODO: Improve this so we hide the (arbitrary) choice of `n` *) - Unshelve. 2: apply O. - iIntros (e2 σ2 efs Hstep). iNext. - inv_head_step. - iMod (update_no_step_enough_fuel _ _ ∅ with "HfuelS Hmi") as (δ2 ℓ) "([%Hlabel %Hvse] & Hfuel & Hmi)" =>//. - { by intros ?%dom_empty_inv_L. } - { set_solver. } - { rewrite Hexend. apply head_locale_step. by econstructor. } - iModIntro; iExists δ2, ℓ. - rewrite Hexend //=. iFrame "Hmi Hsi". - repeat iSplit =>//. - iApply "HΦ". - iApply (has_fuels_proper with "Hfuel") =>//. - rewrite map_filter_id //. intros ???%elem_of_dom_2; set_solver. -Qed. - -Lemma wp_load_nostep s tid E l q v fs: - fs ≠ ∅ -> - {{{ ▷ l ↦{q} v ∗ has_fuels_S tid fs }}} Load (Val $ LitV $ LitLoc l) @ s; tid; E {{{ RET v; l ↦{q} v ∗ has_fuels tid fs }}}. -Proof. - iIntros (? Φ) "[>Hl HfuelS] HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (extr atr K tp1 tp2 σ1 Hval Hexend Hloc) "(% & Hsi & Hmi) !>". - iDestruct (@gen_heap_valid with "Hsi Hl") as %Hheap. - iSplit; first by rewrite Hexend // in Hheap; eauto. iIntros "!>" (e2 σ2 efs Hstep). - rewrite Hexend in Hheap. inv_head_step. - iMod (update_no_step_enough_fuel _ _ ∅ with "HfuelS Hmi") as (δ2 ℓ) "([%Hlabels %Hvse] & Hfuel & Hmod)" =>//. - { by intros ?%dom_empty_inv_L. } - { set_solver. } - { rewrite Hexend. apply head_locale_step. by econstructor. } - iModIntro; iExists _,_. - rewrite Hexend //=. iFrame "Hsi Hmod". - do 2 (iSplit=>//). - iApply "HΦ". iFrame. iApply (has_fuels_proper with "Hfuel") =>//. - rewrite map_filter_id //. intros ???%elem_of_dom_2; set_solver. -Qed. - -Lemma wp_store_nostep s tid E l v' v fs: - fs ≠ ∅ -> - {{{ ▷ l ↦ v' ∗ has_fuels_S tid fs }}} - Store (Val $ LitV (LitLoc l)) (Val v) @ s; tid; E - {{{ RET LitV LitUnit; l ↦ v ∗ has_fuels tid fs }}}. -Proof. - iIntros (? Φ) "[>Hl HfuelS] HΦ". - iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (extr atr K tp1 tp2 σ1 Hval Hexend Hloc) "(% & Hsi & Hmi) !>". - iDestruct (@gen_heap_valid with "Hsi Hl") as %Hheap. - iSplit; first by rewrite Hexend // in Hheap; eauto. iIntros "!>" (e2 σ2 efs Hstep). - rewrite Hexend in Hheap. inv_head_step. - iMod (@gen_heap_update with "Hsi Hl") as "[Hsi Hl]". - iMod (update_no_step_enough_fuel _ _ ∅ with "HfuelS Hmi") as (δ2 ℓ) "([%Hlabels %Hvse] & Hfuel & Hmod)" =>//. - { by intros ?%dom_empty_inv_L. } - { set_solver. } - { rewrite Hexend. apply head_locale_step. by econstructor. } - iModIntro; iExists _,_. - rewrite Hexend //=. iFrame "Hsi Hmod". - do 2 (iSplit=>//). - iApply "HΦ". iFrame. iApply (has_fuels_proper with "Hfuel") =>//. - rewrite map_filter_id //. intros ???%elem_of_dom_2; set_solver. -Qed. - -(* WIP solution for generic fuel-handling *) -Definition sswp (s : stuckness) E e1 (Φ : expr → iProp Σ) : iProp Σ := - match to_val e1 with - | Some v => |={E}=> Φ (of_val v) - | None => ∀ σ1, - gen_heap_interp σ1.(heap) ={E,∅}=∗ - ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, - ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅}▷=∗ |={∅,E}=> - gen_heap_interp σ2.(heap) ∗ Φ e2 ∗ ⌜efs = []⌝ - end%I. - -Lemma wp_store s tid E l v' v : - ▷ l ↦ v' -∗ - sswp s E (Store (Val $ LitV (LitLoc l)) (Val v)) - (λ w, ⌜w = LitV LitUnit⌝ ∗ l ↦ v ). -Proof. - iIntros ">Hl". simpl. - iIntros (σ1) "Hsi". - iDestruct (gen_heap_valid with "Hsi Hl") as %Hheap. - iApply fupd_mask_intro; [set_solver|]. iIntros "Hclose". - iSplit. - { destruct s; [|done]. iPureIntro. apply head_prim_reducible. by eauto. } - iIntros (e2 σ2 efs Hstep). iIntros "!>!>!>". - iMod "Hclose". - iMod (@gen_heap_update with "Hsi Hl") as "[Hsi Hl]". - iFrame. - apply head_reducible_prim_step in Hstep; [|by eauto]. - inv_head_step. iFrame. done. -Qed. - -Lemma wp_nostep s tid E e fs Φ : - TCEq (to_val e) None → - fs ≠ ∅ → - sswp s E e (λ e', has_fuels tid fs -∗ WP e' @ s; tid; E {{ Φ }} ) -∗ - has_fuels_S tid fs -∗ - WP e @ s; tid; E {{ Φ }}. -Proof. - iIntros (Hval ?) "Hwp HfuelS". - rewrite wp_unfold /wp_pre /sswp /= Hval. - iIntros (extr atr K tp1 tp2 σ1 Hvalid Hloc Hends) "(%Hvalid' & Hsi & Hmi)". - rewrite Hends. - iMod ("Hwp" with "Hsi") as (Hred) "Hwp". - iModIntro. iSplit; [done|]. - iIntros (e2 σ2 efs Hstep). simpl in *. - iMod ("Hwp" with "[//]") as "Hwp". - iIntros "!>!>". iMod "Hwp". iIntros "!>". - iApply step_fupdN_intro; [done|]. iIntros "!>". iMod "Hwp". - iMod (update_no_step_enough_fuel extr atr ∅ with "HfuelS [Hmi]") as (δ2 ℓ) "([%Hlabels %Hvse] & Hfuel & Hmod)" =>//. - { by intros ?%dom_empty_inv_L. } - { set_solver. } - { rewrite Hends -Hloc. eapply locale_step_atomic; eauto. by apply fill_step. } - { by rewrite Hends. } - iIntros "!>". - iDestruct "Hwp" as "[Hsi [Hwp ->]]". - iExists _, _. iFrame. iSplit; [done|]. - rewrite map_filter_id //; [|intros ???%elem_of_dom_2; set_solver]. - iDestruct ("Hwp" with "Hfuel") as "Hwp". iFrame. done. -Qed. - -Lemma sswp_wand s e E (Φ Ψ : expr → iProp Σ) : - (∀ e, Φ e -∗ Ψ e) -∗ sswp s E e Φ -∗ sswp s E e Ψ. -Proof. - iIntros "HΦΨ HΦ". - rewrite /sswp. - destruct (to_val e); [by iApply "HΦΨ"|]. - iIntros (?) "H". - iMod ("HΦ" with "H") as "[%Hs HΦ]". - iModIntro. iSplit; [done|]. - iIntros (????). - iDestruct ("HΦ" with "[//]") as "HΦ". - iMod "HΦ". iIntros "!>!>". iMod "HΦ". iIntros "!>". iMod "HΦ" as "(?&?&?)". - iIntros "!>". iFrame. - by iApply "HΦΨ". -Qed. - -(* Sanity check for sswp *) -Lemma wp_store_nostep_alt s tid E l v' v fs: - fs ≠ ∅ -> - ▷ l ↦ v' -∗ has_fuels_S tid fs -∗ - WP Store (Val $ LitV (LitLoc l)) (Val v) @ s; tid; E - {{ λ w, ⌜w = LitV LitUnit⌝ ∗ l ↦ v ∗ has_fuels tid fs}}. -Proof. - iIntros (?) ">Hl Hf". - iApply (wp_nostep with "[Hl]"); [done| |]. - { iApply sswp_wand; [|by iApply wp_store]. - iIntros (e) "[-> Hl] Hf". iApply wp_value. by iFrame. } - iFrame. -Qed. - -Lemma wp_store_step_singlerole s tid ρ (f1 f2: nat) fr s1 s2 E l v' v : - f2 ≤ LM.(lm_fl) s2 -> fmtrans M s1 (Some ρ) s2 -> - live_roles _ s2 ⊆ live_roles _ s1 -> - {{{ ▷ l ↦ v' ∗ ▷ frag_model_is s1 ∗ ▷ has_fuel tid ρ f1 ∗ ▷ frag_free_roles_are fr }}} - Store (Val $ LitV $ LitLoc l) (Val v) @ s; tid; E - {{{ RET LitV LitUnit; l ↦ v ∗ frag_model_is s2 ∗ frag_free_roles_are fr ∗ - (if decide (ρ ∈ live_roles M s2) then has_fuel tid ρ f2 else tid ↦M ∅ ) }}}. -Proof. - iIntros (Hfl Htrans ? Φ) "(>Hl & >Hst & >Hfuel1 & > Hfr) HΦ". - iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (extr atr K tp1 tp2 σ1 Hval Hexend Hloc) "(% & Hsi & Hmi) !>". - iDestruct (@gen_heap_valid with "Hsi Hl") as %Hheap. - iSplit; first by rewrite Hexend // in Hheap; eauto. - iIntros "!>" (e2 σ2 efs Hstep). - rewrite Hexend in Hheap. inv_head_step. - iDestruct (model_agree' with "Hmi Hst") as %Hmeq. - rewrite has_fuel_fuels Hexend. - iMod (@gen_heap_update with "Hsi Hl") as "[Hsi Hl]". - iMod (update_step_still_alive _ _ _ _ _ _ _ _ _ - (if decide (ρ ∈ live_roles M s2) then {[ ρ := f2 ]} else ∅) - with "Hfuel1 Hst Hmi Hfr") as - (δ2 ℓ) "([%Hlab %Hvse] & Hfuel & Hst & Hfr & Hmod)"; eauto. - - set_solver. - - destruct (decide (ρ ∈ live_roles M s2)); apply head_locale_step; econstructor =>//. - - destruct (decide (ρ ∈ live_roles M s2)). - + split; first by intros _; rewrite lookup_singleton /=; lia. - split; first set_solver. - split; first set_solver. - split; first (intros ρ' Hin; set_solver). - split; set_solver. - + repeat (split; set_solver). - - iModIntro; iExists δ2, ℓ. iSplit. - { iPureIntro. simpl in *. split =>//. } - iFrame. - iSplit; first done. - iApply "HΦ". iFrame. - replace (fr ∖ (live_roles M s2 ∖ live_roles M s1)) - with fr; [iFrame|set_solver]. - destruct (decide (ρ ∈ live_roles M s2)). - + rewrite has_fuel_fuels //. - + iDestruct "Hfuel" as "[?_]". rewrite dom_empty_L //. -Qed. - -Lemma wp_cmpxchg_fail_step_singlerole s tid ρ (f1 f2: nat) fr s1 s2 E l q v' v1 v2: - v' ≠ v1 → vals_compare_safe v' v1 → f2 ≤ LM.(lm_fl) s2 -> M.(fmtrans) s1 (Some ρ) s2 -> - live_roles _ s2 ⊆ live_roles _ s1 -> - {{{ ▷ l ↦{q} v' ∗ ▷ frag_model_is s1 ∗ ▷ has_fuel tid ρ f1 ∗ ▷ frag_free_roles_are fr }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; tid; E - {{{ RET PairV v' (LitV $ LitBool false); l ↦{q} v' ∗ frag_model_is s2 ∗ frag_free_roles_are fr ∗ - (if decide (ρ ∈ live_roles M s2) then has_fuel tid ρ f2 else tid ↦M ∅ ) }}}. -Proof. - iIntros (?? Hfl Htrans ? Φ) "(>Hl & >Hst & >Hfuel1 & > Hfr) HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (extr atr K tp1 tp2 σ1 Hval Hexend Hloc) "(% & Hsi & Hmi) !>". - iDestruct (@gen_heap_valid with "Hsi Hl") as %Hheap. - iSplit; first by rewrite Hexend // in Hheap; eauto. iIntros "!>" (e2 σ2 efs Hstep). - rewrite Hexend in Hheap. inv_head_step. - iDestruct (model_agree' with "Hmi Hst") as %Hmeq. - rewrite bool_decide_false //. - rewrite has_fuel_fuels Hexend. - iMod (update_step_still_alive _ _ _ _ _ _ _ _ _ - (if decide (ρ ∈ live_roles M s2) then {[ ρ := f2 ]} else ∅) - with "Hfuel1 Hst Hmi Hfr") as - (δ2 ℓ) "([%Hlab %Hvse] & Hfuel & Hst & Hfr & Hmod)"; eauto. - - set_solver. - - destruct (decide (ρ ∈ live_roles M s2)); apply head_locale_step; econstructor =>//. - - destruct (decide (ρ ∈ live_roles M s2)). - + split; first by intros _; rewrite lookup_singleton /=; lia. - split; first set_solver. - split; first set_solver. - split; first (intros ρ' Hin; set_solver). - split; set_solver. - + repeat (split; set_solver). - - rewrite -> bool_decide_eq_false_2 in *; eauto. - iModIntro; iExists δ2, ℓ. iSplit. - { iPureIntro. simpl in *. split =>//. } - iFrame. - iSplit; first done. iApply "HΦ". iFrame. - replace (fr ∖ (live_roles M s2 ∖ live_roles M s1)) with fr; [iFrame|set_solver]. - destruct (decide (ρ ∈ live_roles M s2)). - + rewrite has_fuel_fuels //. - + iDestruct "Hfuel" as "[?_]". rewrite dom_empty_L //. -Qed. - -Lemma wp_cmpxchg_suc_step_singlerole_keep_dead s tid ρ (f1 f2: nat) fr s1 s2 E l v' v1 v2: - ρ ∉ live_roles _ s2 → - v' = v1 → vals_compare_safe v' v1 → f2 < f1 -> M.(fmtrans) s1 (Some ρ) s2 -> - live_roles _ s2 ⊆ live_roles _ s1 -> - {{{ ▷ l ↦ v' ∗ ▷ frag_model_is s1 ∗ ▷ has_fuel tid ρ f1 ∗ ▷ frag_free_roles_are fr }}} - CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; tid; E - {{{ RET PairV v' (LitV $ LitBool true); l ↦ v2 ∗ frag_model_is s2 ∗ frag_free_roles_are fr ∗ - has_fuel tid ρ f2 }}}. -Proof. - iIntros (??? Hfl Htrans ? Φ) "(>Hl & >Hst & >Hfuel1 & >Hfr) HΦ". - iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (extr atr K tp1 tp2 σ1 Hval Hexend Hloc) "(% & Hsi & Hmi) !>". - iDestruct (@gen_heap_valid with "Hsi Hl") as %Hheap. - iSplit; first by rewrite Hexend // in Hheap; eauto. iIntros "!>" (e2 σ2 efs Hstep). - rewrite Hexend in Hheap. inv_head_step. - iDestruct (model_agree' with "Hmi Hst") as %Hmeq. - rewrite bool_decide_true //. - iMod (@gen_heap_update with "Hsi Hl") as "[Hsi Hl]". - rewrite has_fuel_fuels Hexend. - iMod (update_step_still_alive _ _ _ _ _ _ _ _ _ {[ ρ := f2 ]} with "Hfuel1 Hst Hmi Hfr") as - (δ2 ℓ) "([%Hlab %Hvse] & Hfuel & Hst & Hfr & Hmod)"; eauto. - - set_solver. - - apply head_locale_step; econstructor =>//. - - repeat (split; try done); [|set_solver|set_solver|set_solver| set_solver |]. - + intros ??. rewrite !lookup_singleton /=. lia. - + rewrite dom_singleton singleton_subseteq_l. simplify_eq. - destruct (decide (ρ ∈ live_roles _ (trace_last atr))); set_solver. - - rewrite -> bool_decide_eq_true_2 in *; eauto. - iModIntro; iExists δ2, ℓ. iSplit. - { iPureIntro. simpl in *. split =>//. } - iFrame. iSplit; first done. iApply "HΦ". iFrame. - replace (fr ∖ (live_roles M s2 ∖ live_roles M s1)) with fr; [iFrame|set_solver]. - by rewrite has_fuel_fuels. -Qed. - -Lemma wp_cmpxchg_suc_step_singlerole s tid ρ (f1 f2: nat) fr s1 s2 E l v' v1 v2: - v' = v1 → vals_compare_safe v' v1 → f2 ≤ LM.(lm_fl) s2 -> M.(fmtrans) s1 (Some ρ) s2 -> - live_roles _ s2 ⊆ live_roles _ s1 -> - {{{ ▷ l ↦ v' ∗ ▷ frag_model_is s1 ∗ ▷ has_fuel tid ρ f1 ∗ ▷ frag_free_roles_are fr }}} - CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; tid; E - {{{ RET PairV v' (LitV $ LitBool true); l ↦ v2 ∗ frag_model_is s2 ∗ frag_free_roles_are fr ∗ - (if decide (ρ ∈ live_roles M s2) then has_fuel tid ρ f2 else tid ↦M ∅ ) }}}. -Proof. - iIntros (?? Hfl Htrans ? Φ) "(>Hl & >Hst & >Hfuel1 & >Hfr) HΦ". - iApply wp_lift_atomic_head_step_no_fork; auto. - iIntros (extr atr K tp1 tp2 σ1 Hval Hexend Hloc) "(% & Hsi & Hmi) !>". - iDestruct (@gen_heap_valid with "Hsi Hl") as %Hheap. - iSplit; first by rewrite Hexend // in Hheap; eauto. iIntros "!>" (e2 σ2 efs Hstep). - rewrite Hexend in Hheap. inv_head_step. - iDestruct (model_agree' with "Hmi Hst") as %Hmeq. - rewrite bool_decide_true //. - iMod (@gen_heap_update with "Hsi Hl") as "[Hsi Hl]". - rewrite has_fuel_fuels Hexend. - iMod (update_step_still_alive _ _ _ _ _ _ _ _ _ - (if decide (ρ ∈ live_roles M s2) then {[ ρ := f2 ]} else ∅) - with "Hfuel1 Hst Hmi Hfr") as - (δ2 ℓ) "([%Hlab %Hvse] & Hfuel & Hst & Hfr & Hmod)"; eauto. - - set_solver. - - destruct (decide (ρ ∈ live_roles M s2)); apply head_locale_step; econstructor =>//. - - destruct (decide (ρ ∈ live_roles M s2)). - + split; first by intros _; rewrite lookup_singleton /=; lia. - split; first set_solver. - split; first set_solver. - split; set_solver. - + repeat (split; set_solver). - - rewrite -> bool_decide_eq_true_2 in *; eauto. - iModIntro; iExists δ2, ℓ. iSplit. - { iPureIntro. simpl in *. split =>//. } - iFrame. iSplit; first done. iApply "HΦ". iFrame. - replace (fr ∖ (live_roles M s2 ∖ live_roles M s1)) with fr; [iFrame|set_solver]. - destruct (decide (ρ ∈ live_roles M s2)). - + rewrite has_fuel_fuels //. - + iDestruct "Hfuel" as "[?_]". rewrite dom_empty_L //. -Qed. - -(* Lemma wp_faa s E l i1 i2 : *) -(* {{{ ▷ l ↦ LitV (LitInt i1) }}} FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E *) -(* {{{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }}}. *) -(* Proof. *) -(* iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. *) -(* iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. *) -(* iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. *) -(* iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". *) -(* iModIntro. iSplit=>//. iFrame. by iApply "HΦ". *) -(* Qed. *) -End lifting. diff --git a/fairness/heap_lang/locations.v b/fairness/heap_lang/locations.v deleted file mode 100644 index 75221dac..00000000 --- a/fairness/heap_lang/locations.v +++ /dev/null @@ -1,48 +0,0 @@ -From stdpp Require Import countable numbers gmap. -From iris.prelude Require Export prelude. -From iris.prelude Require Import options. - -Record loc := Loc { loc_car : Z }. - -Add Printing Constructor loc. - -Global Instance loc_eq_decision : EqDecision loc. -Proof. solve_decision. Defined. - -Global Instance loc_inhabited : Inhabited loc := populate {|loc_car := 0 |}. - -Global Instance loc_countable : Countable loc. -Proof. by apply (inj_countable' loc_car Loc); intros []. Defined. - -#[global] Program Instance loc_infinite : Infinite loc := - inj_infinite (λ p, {| loc_car := p |}) (λ l, Some (loc_car l)) _. -Next Obligation. done. Qed. - -Definition loc_add (l : loc) (off : Z) : loc := - {| loc_car := loc_car l + off|}. - -Notation "l +ₗ off" := - (loc_add l off) (at level 50, left associativity) : stdpp_scope. - -Lemma loc_add_assoc l i j : l +ₗ i +ₗ j = l +ₗ (i + j). -Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed. - -Lemma loc_add_0 l : l +ₗ 0 = l. -Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed. - -Global Instance loc_add_inj l : Inj eq eq (loc_add l). -Proof. destruct l; rewrite /Inj /loc_add /=; intros; simplify_eq; lia. Qed. - -Definition fresh_locs (ls : gset loc) : loc := - {| loc_car := set_fold (λ k r, (1 + loc_car k) `max` r)%Z 1%Z ls |}. - -Lemma fresh_locs_fresh ls i : - (0 ≤ i)%Z → fresh_locs ls +ₗ i ∉ ls. -Proof. - intros Hi. cut (∀ l, l ∈ ls → loc_car l < loc_car (fresh_locs ls) + i)%Z. - { intros help Hf%help. simpl in *. lia. } - apply (set_fold_ind_L (λ r ls, ∀ l, l ∈ ls → (loc_car l < r + i)%Z)); - set_solver by eauto with lia. -Qed. - -Global Opaque fresh_locs. diff --git a/fairness/heap_lang/notation.v b/fairness/heap_lang/notation.v deleted file mode 100644 index c43d8ced..00000000 --- a/fairness/heap_lang/notation.v +++ /dev/null @@ -1,159 +0,0 @@ -From trillium.program_logic Require Import language. -From trillium.fairness.heap_lang Require Export lang. -Set Default Proof Using "Type". - -Delimit Scope expr_scope with E. -Delimit Scope val_scope with V. - -(** Coercions to make programs easier to type. *) -Coercion LitInt : Z >-> base_lit. -Coercion LitBool : bool >-> base_lit. -Coercion LitLoc : loc >-> base_lit. -Coercion LitProphecy : proph_id >-> base_lit. - -Coercion App : expr >-> Funclass. - -Coercion Val : val >-> expr. -Coercion Var : string >-> expr. - -(** Define some derived forms. *) -Notation Lam x e := (Rec BAnon x e) (only parsing). -Notation Let x e1 e2 := (App (Lam x e2) e1) (only parsing). -Notation Seq e1 e2 := (Let BAnon e1 e2) (only parsing). -Notation LamV x e := (RecV BAnon x e) (only parsing). -Notation LetCtx x e2 := (AppRCtx (LamV x e2)) (only parsing). -Notation SeqCtx e2 := (LetCtx BAnon e2) (only parsing). -Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)) (only parsing). -Notation Alloc e := (AllocN (Val $ LitV $ LitInt 1) e) (only parsing). -(** Compare-and-set (CAS) returns just a boolean indicating success or failure. *) -Notation CAS l e1 e2 := (Snd (CmpXchg l e1 e2)) (only parsing). - -(* Skip should be atomic, we sometimes open invariants around - it. Hence, we need to explicitly use LamV instead of e.g., Seq. *) -Notation Skip := (App (Val $ LamV BAnon (Val $ LitV LitUnit)) (Val $ LitV LitUnit)). - -(* No scope for the values, does not conflict and scope is often not inferred -properly. *) -Notation "# l" := (LitV l%Z%V%stdpp) (at level 8, format "# l"). - -(** Syntax inspired by Coq/Ocaml. Constructions with higher precedence come - first. *) -Notation "( e1 , e2 , .. , en )" := (Pair .. (Pair e1 e2) .. en) : expr_scope. -Notation "( e1 , e2 , .. , en )" := (PairV .. (PairV e1 e2) .. en) : val_scope. - -(* -Using the '[hv' ']' printing box, we make sure that when the notation for match -does not fit on a single line, line breaks will be inserted for *each* breaking -point '/'. Note that after each breaking point /, one can put n spaces (for -example '/ '). That way, when the breaking point is turned into a line break, -indentation of n spaces will appear after the line break. As such, when the -match does not fit on one line, it will print it like: - - match: e0 with - InjL x1 => e1 - | InjR x2 => e2 - end - -Moreover, if the branches do not fit on a single line, it will be printed as: - - match: e0 with - InjL x1 => - lots of stuff bla bla bla bla bla bla bla bla - | InjR x2 => - even more stuff bla bla bla bla bla bla bla bla - end -*) -Notation "'match:' e0 'with' 'InjL' x1 => e1 | 'InjR' x2 => e2 'end'" := - (Match e0 x1%binder e1 x2%binder e2) - (e0, x1, e1, x2, e2 at level 200, - format "'[hv' 'match:' e0 'with' '/ ' '[' 'InjL' x1 => '/ ' e1 ']' '/' '[' | 'InjR' x2 => '/ ' e2 ']' '/' 'end' ']'") : expr_scope. -Notation "'match:' e0 'with' 'InjR' x1 => e1 | 'InjL' x2 => e2 'end'" := - (Match e0 x2%binder e2 x1%binder e1) - (e0, x1, e1, x2, e2 at level 200, only parsing) : expr_scope. - -Notation "()" := LitUnit : val_scope. -Notation "! e" := (Load e%E) (at level 9, right associativity) : expr_scope. -Notation "'ref' e" := (Alloc e%E) (at level 10) : expr_scope. -Notation "- e" := (UnOp MinusUnOp e%E) : expr_scope. - -Notation "e1 + e2" := (BinOp PlusOp e1%E e2%E) : expr_scope. -Notation "e1 +ₗ e2" := (BinOp OffsetOp e1%E e2%E) : expr_scope. -Notation "e1 - e2" := (BinOp MinusOp e1%E e2%E) : expr_scope. -Notation "e1 * e2" := (BinOp MultOp e1%E e2%E) : expr_scope. -Notation "e1 `quot` e2" := (BinOp QuotOp e1%E e2%E) : expr_scope. -Notation "e1 `rem` e2" := (BinOp RemOp e1%E e2%E) : expr_scope. -Notation "e1 ≪ e2" := (BinOp ShiftLOp e1%E e2%E) : expr_scope. -Notation "e1 ≫ e2" := (BinOp ShiftROp e1%E e2%E) : expr_scope. - -Notation "e1 ≤ e2" := (BinOp LeOp e1%E e2%E) : expr_scope. -Notation "e1 < e2" := (BinOp LtOp e1%E e2%E) : expr_scope. -Notation "e1 = e2" := (BinOp EqOp e1%E e2%E) : expr_scope. -Notation "e1 ≠ e2" := (UnOp NegOp (BinOp EqOp e1%E e2%E)) : expr_scope. - -Notation "~ e" := (UnOp NegOp e%E) (at level 75, right associativity) : expr_scope. -(* The unicode ← is already part of the notation "_ ← _; _" for bind. *) -Notation "e1 <- e2" := (Store e1%E e2%E) (at level 80) : expr_scope. - -(* The breaking point '/ ' makes sure that the body of the rec is indented -by two spaces in case the whole rec does not fit on a single line. *) -Notation "'rec:' f x := e" := (Rec f%binder x%binder e%E) - (at level 200, f at level 1, x at level 1, e at level 200, - format "'[' 'rec:' f x := '/ ' e ']'") : expr_scope. -Notation "'rec:' f x := e" := (RecV f%binder x%binder e%E) - (at level 200, f at level 1, x at level 1, e at level 200, - format "'[' 'rec:' f x := '/ ' e ']'") : val_scope. -Notation "'if:' e1 'then' e2 'else' e3" := (If e1%E e2%E e3%E) - (at level 200, e1, e2, e3 at level 200) : expr_scope. - -(** Derived notions, in order of declaration. The notations for let and seq -are stated explicitly instead of relying on the Notations Let and Seq as -defined above. This is needed because App is now a coercion, and these -notations are otherwise not pretty printed back accordingly. *) -Notation "'rec:' f x y .. z := e" := (Rec f%binder x%binder (Lam y%binder .. (Lam z%binder e%E) ..)) - (at level 200, f, x, y, z at level 1, e at level 200, - format "'[' 'rec:' f x y .. z := '/ ' e ']'") : expr_scope. -Notation "'rec:' f x y .. z := e" := (RecV f%binder x%binder (Lam y%binder .. (Lam z%binder e%E) ..)) - (at level 200, f, x, y, z at level 1, e at level 200, - format "'[' 'rec:' f x y .. z := '/ ' e ']'") : val_scope. - -(* The breaking point '/ ' makes sure that the body of the λ: is indented -by two spaces in case the whole λ: does not fit on a single line. *) -Notation "λ: x , e" := (Lam x%binder e%E) - (at level 200, x at level 1, e at level 200, - format "'[' 'λ:' x , '/ ' e ']'") : expr_scope. -Notation "λ: x y .. z , e" := (Lam x%binder (Lam y%binder .. (Lam z%binder e%E) ..)) - (at level 200, x, y, z at level 1, e at level 200, - format "'[' 'λ:' x y .. z , '/ ' e ']'") : expr_scope. - -Notation "λ: x , e" := (LamV x%binder e%E) - (at level 200, x at level 1, e at level 200, - format "'[' 'λ:' x , '/ ' e ']'") : val_scope. -Notation "λ: x y .. z , e" := (LamV x%binder (Lam y%binder .. (Lam z%binder e%E) .. )) - (at level 200, x, y, z at level 1, e at level 200, - format "'[' 'λ:' x y .. z , '/ ' e ']'") : val_scope. - -Notation "'let:' x := e1 'in' e2" := (Lam x%binder e2%E e1%E) - (at level 200, x at level 1, e1, e2 at level 200, - format "'[' 'let:' x := '[' e1 ']' 'in' '/' e2 ']'") : expr_scope. -Notation "e1 ;; e2" := (Lam BAnon e2%E e1%E) - (at level 100, e2 at level 200, - format "'[' '[hv' '[' e1 ']' ;; ']' '/' e2 ']'") : expr_scope. - -(* Shortcircuit Boolean connectives *) -Notation "e1 && e2" := - (If e1%E e2%E (LitV (LitBool false))) (only parsing) : expr_scope. -Notation "e1 || e2" := - (If e1%E (LitV (LitBool true)) e2%E) (only parsing) : expr_scope. - -(** Notations for option *) -Notation NONE := (InjL (LitV LitUnit)) (only parsing). -Notation NONEV := (InjLV (LitV LitUnit)) (only parsing). -Notation SOME x := (InjR x) (only parsing). -Notation SOMEV x := (InjRV x) (only parsing). - -Notation "'match:' e0 'with' 'NONE' => e1 | 'SOME' x => e2 'end'" := - (Match e0 BAnon e1 x%binder e2) - (e0, e1, x, e2 at level 200, only parsing) : expr_scope. -Notation "'match:' e0 'with' 'SOME' x => e2 | 'NONE' => e1 'end'" := - (Match e0 BAnon e1 x%binder e2) - (e0, e1, x, e2 at level 200, only parsing) : expr_scope. diff --git a/fairness/heap_lang/proofmode.v b/fairness/heap_lang/proofmode.v deleted file mode 100644 index a62a19c5..00000000 --- a/fairness/heap_lang/proofmode.v +++ /dev/null @@ -1,1031 +0,0 @@ -From iris.proofmode Require Import coq_tactics reduction spec_patterns. -From iris.proofmode Require Export tactics. -From trillium.program_logic Require Import atomic. -From trillium.fairness.heap_lang Require Export tactics lifting. (* derived_laws. *) -From trillium.fairness.heap_lang Require Import notation. -From iris.prelude Require Import options. -Import uPred. - -Lemma tac_wp_expr_eval `{LM:LiveModel heap_lang M} `{!heapGS Σ LM} Δ tid E Φ e e' : - (∀ (e'':=e'), e = e'') → - envs_entails Δ (WP e' @ tid; E {{ Φ }}) → envs_entails Δ (WP e @ tid; E {{ Φ }}). -Proof. by intros ->. Qed. - -Tactic Notation "wp_expr_eval" tactic3(t) := - iStartProof; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?locale ?e ?Q) => - notypeclasses refine (tac_wp_expr_eval _ _ _ _ e _ _ _); - [let x := fresh in intros x; t; unfold x; notypeclasses refine eq_refl|] - | _ => fail "wp_expr_eval: not a 'wp'" - end. -Ltac wp_expr_simpl := wp_expr_eval simpl. - -Lemma tac_wp_pure_helper `{LM:LiveModel heap_lang M} `{!heapGS Σ LM} tid E K e1 e2 fs φ n Φ : - fs ≠ ∅ -> - PureExec φ n e1 e2 → - φ → - ( ▷^n (has_fuels tid fs -∗ WP (fill K e2) @ tid; E {{ Φ }})) -∗ - has_fuels_plus n tid fs -∗ - WP (fill K e1) @ tid; E {{ Φ }}. -Proof. - intros Hne HPE Hφ. specialize (HPE Hφ). - revert e1 e2 fs Hne HPE. induction n; intros e1 e2 fs Hne HPE. - { inversion HPE. rewrite has_fuel_fuels_plus_0. by simplify_eq. } - - inversion HPE; simplify_eq. - - iIntros "H Hf". - rewrite has_fuels_plus_split_S. - - iApply (wp_lift_pure_step_no_fork _ _ _ _ _ _ ((λ m : nat, (n + m)%nat) <$> fs)) =>//. - { by intros ?%fmap_empty_inv. } - { econstructor =>//; [ by eapply pure_step_ctx | constructor ]. } - iModIntro; iFrame. do 2 iModIntro. - iIntros "Hf". - iApply (IHn _ _ _ with "[H] [Hf]") => //. -Qed. - -Lemma equiv_wand {Σ} (P Q: iProp Σ): - P ≡ Q -> - P -∗ Q. -Proof. by intros ->. Qed. - -Lemma maps_gt_n {Mdl} (fs: gmap (fmrole Mdl) _) n: - (∀ ρ f, fs !! ρ = Some f -> f >= n)%nat -> - fs = (λ m, n + m)%nat <$> ((λ m, m - n)%nat <$> fs). -Proof. - intros Hgt. - rewrite -leibniz_equiv_iff => ρ. - rewrite -map_fmap_compose !lookup_fmap. - destruct (fs !! ρ) as [f|] eqn:? =>//=. f_equiv. - assert (f >= n)%nat by eauto. - apply leibniz_equiv_iff. lia. -Qed. - -Lemma has_fuels_gt_n `{LM : LiveModel heap_lang M} `{!heapGS Σ LM} (fs: gmap (fmrole M) _) n tid: - (∀ ρ f, fs !! ρ = Some f -> f >= n)%nat -> - has_fuels tid fs ⊣⊢ has_fuels tid ((λ m, n + m)%nat <$> ((λ m, m - n)%nat <$> fs)). -Proof. intros ?. rewrite {1}(maps_gt_n fs n) //. Qed. - -Lemma has_fuels_gt_1 `{LM:LiveModel heap_lang M} - `{!heapGS Σ LM} (fs: gmap (fmrole M) _) tid: - (∀ ρ f, fs !! ρ = Some f -> f >= 1)%nat -> - has_fuels tid fs ⊣⊢ has_fuels_S tid (((λ m, m - 1)%nat <$> fs)). -Proof. intros ?. by rewrite has_fuels_gt_n //. Qed. - -Lemma tac_wp_pure_helper_2 `{LM:LiveModel heap_lang M} - `{!heapGS Σ LM} tid E K e1 e2 fs φ n Φ : - (∀ ρ f, fs !! ρ = Some f -> f >= n)%nat -> - fs ≠ ∅ -> - PureExec φ n e1 e2 → - φ → - ( ▷^n ((has_fuels tid ((λ m, m - n)%nat <$> fs)) -∗ WP (fill K e2) @ tid; E {{ Φ }})) -∗ - has_fuels tid fs -∗ - WP (fill K e1) @ tid; E {{ Φ }}. -Proof. - iIntros (Hfs Hne Hpe Hphi) "H Hf". - rewrite (has_fuels_gt_n fs n) //. - iApply (tac_wp_pure_helper with "H [Hf]") =>//. - by intros ?%fmap_empty_inv. -Qed. - -(* Upstream? *) -Lemma maybe_into_latersN_envs_dom {PROP} (Γ Δ: envs PROP) n i: - MaybeIntoLaterNEnvs n Γ Δ → - envs_lookup i Γ = None → - envs_lookup i Δ = None. -Proof. - intros [??] ?. destruct Γ as [Γp Γs]. destruct Δ as [Δp Δs]. - simpl. - destruct (env_lookup i Δp) eqn:Hlk. - - assert (HnN: env_lookup i Γp ≠ None). - { intros contra%transform_intuitionistic_env_dom. - rewrite /= in contra. simplify_eq. } - rewrite not_eq_None_Some in HnN. destruct HnN as [? Hlk']. - by rewrite /= Hlk' in H. - - rewrite /= in H. - destruct (env_lookup i Γp); [simplify_eq|]. - destruct (env_lookup i Γs) eqn:Heq =>//. - apply transform_spatial_env_dom in Heq. - by rewrite Heq. -Qed. - -Lemma maybe_into_latersN_envs_wf {PROP} (Γ Δ: envs PROP) n: - MaybeIntoLaterNEnvs n Γ Δ → - envs_wf Γ → - envs_wf Δ. -Proof. - intros [??] [? ? Hdisj]. destruct Γ as [Γp Γs]. destruct Δ as [Δp Δs]. constructor. - - by apply transform_intuitionistic_env_wf. - - by apply transform_spatial_env_wf. - - intros i. destruct (Hdisj i); - [ by left; apply transform_intuitionistic_env_dom | - by right; apply transform_spatial_env_dom]. -Qed. - -Lemma envs_delete_wf {PROP} i p (Δ: envs PROP) : envs_wf Δ → envs_wf (envs_delete true i p Δ). -Proof. - intros [?? Hdisj]; destruct Δ. constructor. - - destruct p; simpl; [by apply env_delete_wf|done]. - - destruct p; simpl; [done|by apply env_delete_wf]. - - intro j. destruct (Hdisj j). - + left. destruct p; [|done]. simpl in *. - destruct (decide (i = j)) as [->|?]. - * rewrite env_lookup_env_delete //. - * rewrite env_lookup_env_delete_ne //. - + right. destruct p; [done|]. - destruct (decide (i = j)) as [->|?]. - * rewrite env_lookup_env_delete //. - * rewrite env_lookup_env_delete_ne //. -Qed. - -Lemma tac_wp_pure `{LM:LiveModel heap_lang M} - `{!heapGS Σ LM} Δ Δ'other tid E i K e1 e2 φ n Φ fs : - (∀ (ρ : fmrole M) (f : nat), fs !! ρ = Some f → (f ≥ n)%nat) -> - fs ≠ ∅ -> - PureExec φ n e1 e2 → - φ → - envs_lookup i Δ = Some (false, has_fuels tid fs)%I → - let Δother := envs_delete true i false Δ in - MaybeIntoLaterNEnvs n Δother Δ'other → - let Δ' := envs_snoc Δ'other false i (has_fuels tid ((λ m, m - n)%nat <$> fs)) in - envs_entails Δ' (WP (fill K e2) @ tid; E {{ Φ }}) → - envs_entails Δ (WP (fill K e1) @ tid; E {{ Φ }}). -Proof. - rewrite envs_entails_unseal=> ???. - intros ?? Δother Hlater Δ' Hccl. - iIntros "H". - iAssert (⌜envs_wf Δ⌝)%I as %Hwf. - { unfold of_envs, of_envs', envs_wf. iDestruct "H" as "[%H1 _]". by iPureIntro. } - - rewrite envs_lookup_sound // /= -/Δother. iDestruct "H" as "[H1 H2]". - rewrite into_laterN_env_sound. - - iApply (tac_wp_pure_helper_2 with "[H2] [H1]") =>//. - iNext. simpl. iIntros "H". iApply Hccl. - rewrite /Δ' /= (envs_snoc_sound Δ'other false i); first by iApply "H2". - eapply maybe_into_latersN_envs_dom =>//. rewrite /Δother. - eapply envs_lookup_envs_delete =>//. -Qed. - - -Lemma tac_wp_value_nofupd `{LM:LiveModel heap_lang M} - `{!heapGS Σ LM} Δ tid E Φ v : - envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ tid; E {{ Φ }}). -Proof. rewrite envs_entails_unseal=> ->. by apply wp_value. Qed. - -Lemma tac_wp_value `{LM:LiveModel heap_lang M} - `{!heapGS Σ LM} Δ tid E (Φ : val → iPropI Σ) v : - envs_entails Δ (|={E}=> Φ v) → envs_entails Δ (WP (Val v) @ tid; E {{ Φ }}). -Proof. rewrite envs_entails_unseal=> ->. iIntros "?". by iApply wp_value_fupd. Qed. - -(** Simplify the goal if it is [WP] of a value. - If the postcondition already allows a fupd, do not add a second one. - But otherwise, *do* add a fupd. This ensures that all the lemmas applied - here are bidirectional, so we never will make a goal unprovable. *) -Ltac wp_value_head := - lazymatch goal with - | |- envs_entails _ (wp ?s ?E (Val _) (λ _, fupd ?E _ _)) => - eapply tac_wp_value_nofupd - | |- envs_entails _ (wp ?s ?E (Val _) (λ _, wp _ ?E _ _ _)) => - eapply tac_wp_value_nofupd - | |- envs_entails _ (wp ?s ?E _ (Val _) _) => - eapply tac_wp_value - end. - -Ltac wp_finish := - wp_expr_simpl; (* simplify occurences of subst/fill *) - try wp_value_head; (* in case we have reached a value, get rid of the WP *) - pm_prettify. (* prettify ▷s caused by [MaybeIntoLaterNEnvs] and - λs caused by wp_value *) - -Ltac solve_vals_compare_safe := - (* The first branch is for when we have [vals_compare_safe] in the context. *) -(* The other two branches are for when either one of the branches reduces to *) -(* [True] or we have it in the context. *) - fast_done || (left; fast_done) || (right; fast_done). - -Tactic Notation "solve_pure_exec" := - lazymatch goal with - | |- PureExec _ _ ?e _ => - let e := eval simpl in e in - reshape_expr e ltac:(fun K e' => - eapply (pure_exec_fill K _ _ e'); - [tc_solve (* PureExec *) - (* |try solve_vals_compare_safe (* The pure condition for PureExec -- handles trivial goals, including [vals_compare_safe] *) *) - ]) - || fail "failed :(" - end. - - -Global Hint Extern 0 (PureExec _ _ _ _) => solve_pure_exec: core. -Global Hint Extern 0 (vals_compare_safe _ _) => solve_vals_compare_safe: core. - - -Ltac solve_fuel_positive := - unfold singletonM, map_singleton; intros ??; - repeat progress match goal with - | [|- <[ ?x := _ ]> _ !! ?r = Some _ -> _] => - destruct (decide (x = r)) as [->| ?]; - [rewrite lookup_insert; intros ?; simplify_eq; lia | - rewrite lookup_insert_ne; [ try done | done]] - end. -Ltac simpl_has_fuels := - iEval (rewrite ?[in has_fuels _ _]fmap_insert ?[in has_fuels _ _]/= ?[in has_fuels _ _]fmap_empty) in "#∗". -Tactic Notation "wp_pure" open_constr(efoc) := - let solve_fuel _ := - let fs := match goal with |- _ = Some (_, has_fuels _ ?fs) => fs end in - iAssumptionCore || fail "wp_pure: cannot find" fs in - iStartProof; - rewrite ?has_fuel_fuels; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?locale ?e ?Q) => - let e := eval simpl in e in - reshape_expr e ltac:(fun K e' => - unify e' efoc; - eapply (tac_wp_pure _ _ _ _ _ K e'); - [ - | - | tc_solve - | trivial - | let fs := match goal with |- _ = Some (_, has_fuels _ ?fs) => fs end in - iAssumptionCore || fail "wp_pures: cannot find" fs - |tc_solve - | pm_reduce; - simpl_has_fuels; - wp_finish - ] ; [ solve_fuel_positive - | try apply map_non_empty_singleton; try apply insert_non_empty; try done - |]) - || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex" - | _ => fail "wp_pure: not a 'wp'" - end. - -(* TODO: do this in one go, without [repeat]. *) -Ltac wp_pures := - iStartProof; - first [ (* The `;[]` makes sure that no side-condition magically spawns. *) - progress repeat (wp_pure _; []) - | wp_finish (* In case wp_pure never ran, make sure we do the usual cleanup. *) - ]. - -(** Unlike [wp_pures], the tactics [wp_rec] and [wp_lam] should also reduce -lambdas/recs that are hidden behind a definition, i.e. they should use -[AsRecV_recv] as a proper instance instead of a [Hint Extern]. - -We achieve this by putting [AsRecV_recv] in the current environment so that it -can be used as an instance by the typeclass resolution system. We then perform -the reduction, and finally we clear this new hypothesis. *) -Tactic Notation "wp_rec" := - let H := fresh in - assert (H := AsRecV_recv); - wp_pure (App _ _); - clear H. - -Tactic Notation "wp_if" := wp_pure (If _ _ _). -Tactic Notation "wp_if_true" := wp_pure (If (LitV (LitBool true)) _ _). -Tactic Notation "wp_if_false" := wp_pure (If (LitV (LitBool false)) _ _). -Tactic Notation "wp_unop" := wp_pure (UnOp _ _). -Tactic Notation "wp_binop" := wp_pure (BinOp _ _ _). -Tactic Notation "wp_op" := wp_unop || wp_binop. -Tactic Notation "wp_lam" := wp_rec. -Tactic Notation "wp_let" := wp_pure (Rec BAnon (BNamed _) _); wp_lam. -Tactic Notation "wp_seq" := wp_pure (Rec BAnon BAnon _); wp_lam. -Tactic Notation "wp_proj" := wp_pure (Fst _) || wp_pure (Snd _). -Tactic Notation "wp_case" := wp_pure (Case _ _ _). -Tactic Notation "wp_match" := wp_case; wp_pure (Rec _ _ _); wp_lam. -Tactic Notation "wp_inj" := wp_pure (InjL _) || wp_pure (InjR _). -Tactic Notation "wp_pair" := wp_pure (Pair _ _). -Tactic Notation "wp_closure" := wp_pure (Rec _ _ _). - -Lemma tac_wp_bind `{LM:LiveModel heap_lang M} `{!heapGS Σ LM} K Δ s E Φ e f : - f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *) - envs_entails Δ (WP e @ s; E {{ v, WP f (Val v) @ s; E {{ Φ }} }})%I → - envs_entails Δ (WP fill K e @ s; E {{ Φ }}). -Proof. rewrite envs_entails_unseal=> -> ->. by apply: wp_bind. Qed. - -Ltac wp_bind_core K := - lazymatch eval hnf in K with - | [] => idtac - | _ => eapply (tac_wp_bind K); [simpl; reflexivity|reduction.pm_prettify] - end. - -Tactic Notation "wp_bind" open_constr(efoc) := - iStartProof; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?locale ?e ?Q) => - first [ reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core K) - | fail 1 "wp_bind: cannot find" efoc "in" e ] - | _ => fail "wp_bind: not a 'wp'" - end. - -(** Heap tactics *) -Section heap. -Context `{LM:LiveModel heap_lang M}. -Context `{!heapGS Σ LM}. -Implicit Types P Q : iProp Σ. -Implicit Types Φ : val → iProp Σ. -Implicit Types Δ : envs (uPredI (iResUR Σ)). -Implicit Types v : val. -Implicit Types tid : locale heap_lang. - -(* Lemma tac_wp_allocN Δ Δ' s E j K v n Φ : *) -(* (0 < n)%Z → *) -(* MaybeIntoLaterNEnvs 1 Δ Δ' → *) -(* (∀ l, *) -(* match envs_app false (Esnoc Enil j (heap_array l (DfracOwn 1) (replicate (Z.to_nat n) v))) Δ' with *) -(* | Some Δ'' => *) -(* envs_entails Δ'' (WP fill K (Val $ LitV $ LitLoc l) @ s; E {{ Φ }}) *) -(* | None => False *) -(* end) → *) -(* envs_entails Δ (WP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E {{ Φ }}). *) -(* Proof. *) -(* rewrite envs_entails_eq=> ? ? HΔ. *) -(* rewrite -wp_bind. eapply wand_apply; first exact: wp_allocN. *) -(* rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l. *) -(* specialize (HΔ l). *) -(* destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ]. *) -(* rewrite envs_app_sound //; simpl. *) -(* apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r. *) -(* Qed. *) -(* Lemma tac_twp_allocN Δ s E j K v n Φ : *) -(* (0 < n)%Z → *) -(* (∀ l, *) -(* match envs_app false (Esnoc Enil j (array l (DfracOwn 1) (replicate (Z.to_nat n) v))) Δ with *) -(* | Some Δ' => *) -(* envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }]) *) -(* | None => False *) -(* end) → *) -(* envs_entails Δ (WP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E [{ Φ }]). *) -(* Proof. *) -(* rewrite envs_entails_eq=> ? HΔ. *) -(* rewrite -twp_bind. eapply wand_apply; first exact: twp_allocN. *) -(* rewrite left_id. apply forall_intro=> l. *) -(* specialize (HΔ l). *) -(* destruct (envs_app _ _ _) as [Δ'|] eqn:HΔ'; [ | contradiction ]. *) -(* rewrite envs_app_sound //; simpl. *) -(* apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r. *) -(* Qed. *) - -(* Lemma tac_wp_alloc Δ Δ' s E j K v Φ : *) -(* MaybeIntoLaterNEnvs 1 Δ Δ' → *) -(* (∀ l, *) -(* match envs_app false (Esnoc Enil j (l ↦ v)) Δ' with *) -(* | Some Δ'' => *) -(* envs_entails Δ'' (WP fill K (Val $ LitV l) @ s; E {{ Φ }}) *) -(* | None => False *) -(* end) → *) -(* envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E {{ Φ }}). *) -(* Proof. *) -(* rewrite envs_entails_eq=> ? HΔ. *) -(* rewrite -wp_bind. eapply wand_apply; first exact: wp_alloc. *) -(* rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l. *) -(* specialize (HΔ l). *) -(* destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ]. *) -(* rewrite envs_app_sound //; simpl. *) -(* apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r. *) -(* Qed. *) -(* Lemma tac_twp_alloc Δ s E j K v Φ : *) -(* (∀ l, *) -(* match envs_app false (Esnoc Enil j (l ↦ v)) Δ with *) -(* | Some Δ' => *) -(* envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }]) *) -(* | None => False *) -(* end) → *) -(* envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E [{ Φ }]). *) -(* Proof. *) -(* rewrite envs_entails_eq=> HΔ. *) -(* rewrite -twp_bind. eapply wand_apply; first exact: twp_alloc. *) -(* rewrite left_id. apply forall_intro=> l. *) -(* specialize (HΔ l). *) -(* destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ]. *) -(* rewrite envs_app_sound //; simpl. *) -(* apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r. *) -(* Qed. *) - -(* Lemma tac_wp_free Δ Δ' s E i K l v Φ : *) -(* MaybeIntoLaterNEnvs 1 Δ Δ' → *) -(* envs_lookup i Δ' = Some (false, l ↦ v)%I → *) -(* (let Δ'' := envs_delete false i false Δ' in *) -(* envs_entails Δ'' (WP fill K (Val $ LitV LitUnit) @ s; E {{ Φ }})) → *) -(* envs_entails Δ (WP fill K (Free (LitV l)) @ s; E {{ Φ }}). *) -(* Proof. *) -(* rewrite envs_entails_eq=> ? Hlk Hfin. *) -(* rewrite -wp_bind. eapply wand_apply; first exact: wp_free. *) -(* rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl. *) -(* rewrite -Hfin wand_elim_r (envs_lookup_sound' _ _ _ _ _ Hlk). *) -(* apply later_mono, sep_mono_r, wand_intro_r. rewrite right_id //. *) -(* Qed. *) -(* Lemma tac_twp_free Δ s E i K l v Φ : *) -(* envs_lookup i Δ = Some (false, l ↦ v)%I → *) -(* (let Δ' := envs_delete false i false Δ in *) -(* envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E [{ Φ }])) → *) -(* envs_entails Δ (WP fill K (Free (LitV l)) @ s; E [{ Φ }]). *) -(* Proof. *) -(* rewrite envs_entails_eq=> Hlk Hfin. *) -(* rewrite -twp_bind. eapply wand_apply; first exact: twp_free. *) -(* rewrite envs_lookup_split //; simpl. *) -(* rewrite -Hfin wand_elim_r (envs_lookup_sound' _ _ _ _ _ Hlk). *) -(* apply sep_mono_r, wand_intro_r. rewrite right_id //. *) -(* Qed. *) - -Lemma tac_wp_load K fs tid Δ Δ'other E i j l q v Φ : - (∀ (ρ : fmrole M) (f : nat), fs !! ρ = Some f → (f ≥ 1)%nat) -> - fs ≠ ∅ -> - i ≠ j -> - envs_lookup i Δ = Some (false, has_fuels tid fs)%I → - let Δother := envs_delete true i false Δ in - MaybeIntoLaterNEnvs 1 Δother Δ'other → - envs_lookup j Δ'other = Some (false, l ↦{q} v)%I → - let Δ' := envs_snoc Δ'other false i (has_fuels tid ((λ m, m - 1)%nat <$> fs)) in - envs_entails Δ' (WP fill K (Val v) @ tid; E {{ Φ }}) → - envs_entails Δ (WP fill K (Load (LitV l)) @ tid; E {{ Φ }}). -Proof. - intros ?? Hij ?. - rewrite envs_entails_unseal=> Δother ?? Δ' Hccl. - rewrite -wp_bind. - iIntros "H". - iAssert (⌜envs_wf Δ⌝)%I as %Hwf. - { unfold of_envs, of_envs', envs_wf. iDestruct "H" as "[% _]". by iPureIntro. } - - rewrite (envs_lookup_sound _ i) // /= -/Δother. iDestruct "H" as "[H1 H2]". - rewrite into_laterN_env_sound /=. - - rewrite (envs_lookup_sound _ j) // /=. - pose Δ'' := envs_delete true j false Δ'other. rewrite -/Δ''. - iDestruct "H2" as "[H2 H3]". - - rewrite has_fuels_gt_1 //. - iApply (wp_load_nostep with "[H1 H2]"); [| iFrame |]; [by intros ?%fmap_empty_inv|]. - iIntros "!> [Hl Hf]". iApply Hccl. rewrite /Δ' /=. - iApply (envs_snoc_sound Δ'other false i with "[H3 Hl] [Hf]") =>//. - - rewrite maybe_into_latersN_envs_dom // /Δother. - erewrite envs_lookup_envs_delete =>//. - - iApply (envs_lookup_sound_2 Δ'other) =>//; [| by iFrame]. - eapply maybe_into_latersN_envs_wf =>//. - rewrite /Δother. by apply envs_delete_wf. -Qed. - - -Lemma tac_wp_store K fs tid Δ Δ'other E i j l v v' Φ : - (∀ (ρ : fmrole M) (f : nat), fs !! ρ = Some f → (f ≥ 1)%nat) -> - fs ≠ ∅ -> - i ≠ j -> - envs_lookup i Δ = Some (false, has_fuels tid fs)%I → - let Δother := envs_delete true i false Δ in - MaybeIntoLaterNEnvs 1 Δother Δ'other → - envs_lookup j Δ'other = Some (false, (l ↦ v)%I) -> - match envs_simple_replace j false (Esnoc Enil j (l ↦ v')%I) Δ'other with - | Some Δ'other2 => - let Δ' := envs_snoc Δ'other2 false i (has_fuels tid ((λ m, m - 1)%nat <$> fs)) in - envs_lookup i Δ'other2 = None (* redondent but easier than proving it. *) ∧ - envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ tid; E {{ Φ }}) - | None => False - end → - envs_entails Δ (WP fill K (Store (LitV l) (Val v')) @ tid; E {{ Φ }}). -Proof. - intros ?? Hij ?. - rewrite envs_entails_unseal=> Δother ??. - destruct (envs_simple_replace j false (Esnoc Enil j (l ↦ v'))%I Δ'other) as [Δ'other2|] eqn:Heq; last done. - move=> /= [Hhack Hccl]. - - rewrite -wp_bind. - iIntros "H". - iAssert (⌜envs_wf Δ⌝)%I as %Hwf. - { unfold of_envs, of_envs', envs_wf. iDestruct "H" as "[% _]". by iPureIntro. } - - rewrite (envs_lookup_sound _ i) // /= -/Δother. iDestruct "H" as "[H1 H2]". - rewrite into_laterN_env_sound /=. - - rewrite (envs_lookup_sound _ j) //. - pose Δ'' := envs_delete true j false Δ'other. rewrite -/Δ''. - iDestruct "H2" as "[H2 H3]". - - rewrite has_fuels_gt_1 //. - iApply (wp_store_nostep with "[H1 H2]"); [| iFrame |]; [by intros ?%fmap_empty_inv|]. - iIntros "!> [Hl Hf]". - set Δ' := envs_snoc Δ'other2 false i (has_fuels tid ((λ m, m - 1)%nat <$> fs)). - fold Δ' in Hccl. - - iApply Hccl. unfold Δ'. - iApply (envs_snoc_sound Δ'other2 false i with "[H3 Hl] [Hf]") =>//. - rewrite envs_simple_replace_sound' //=. simpl. - iApply "H3". iFrame. -Qed. - -End heap. - -Tactic Notation "wp_load" := - let solve_fuel _ := - let fs := match goal with |- _ = Some (_, has_fuels _ ?fs) => fs end in - iAssumptionCore || fail "wp_load: cannot find" fs in - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_load: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?locale ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_load K)) - |fail 1 "wp_load: cannot find 'Load' in" e]; - [ (* dealt with later *) - | - | - | let fs := match goal with |- _ = Some (_, has_fuels _ ?fs) => fs end in - iAssumptionCore || fail "wp_load: cannot find" fs - | tc_solve - | let fs := match goal with |- _ = Some (_, ?l ↦{_} _)%I => l end in - iAssumptionCore || fail "wp_load: cannot find" fs - | pm_reduce; - simpl_has_fuels; - wp_finish - ]; [ solve_fuel_positive - | try apply map_non_empty_singleton; try apply insert_non_empty; try done - | intros ?; by simplify_eq - | - ] - | _ => fail "wp_load: not a 'wp'" - end. - -Tactic Notation "wp_store" := - let solve_fuel _ := - let fs := match goal with |- _ = Some (_, has_fuels _ ?fs) => fs end in - iAssumptionCore || fail "wp_store: cannot find" fs in - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_store: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?locale ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_store K)) - |fail 1 "wp_load: cannot find 'Load' in" e]; - [ (* dealt with later *) - | - | - | let fs := match goal with |- _ = Some (_, has_fuels _ ?fs) => fs end in - iAssumptionCore || fail "wp_store: cannot find" fs - | tc_solve - | let fs := match goal with |- _ = Some (_, ?l ↦{_} _)%I => l end in - iAssumptionCore || fail "wp_store: cannot find" fs - | split; [done | pm_reduce; - simpl_has_fuels; - wp_finish] - ]; [ solve_fuel_positive - | try apply map_non_empty_singleton; try apply insert_non_empty; try done - | intros ?; by simplify_eq - | - ] - | _ => fail "wp_store: not a 'wp'" - end. -(* -Lemma tac_wp_xchg Δ Δ' s E i K l v v' Φ : - MaybeIntoLaterNEnvs 1 Δ Δ' → - envs_lookup i Δ' = Some (false, l ↦ v)%I → - match envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ' with - | Some Δ'' => envs_entails Δ'' (WP fill K (Val $ v) @ s; E {{ Φ }}) - | None => False - end → - envs_entails Δ (WP fill K (Xchg (LitV l) (Val v')) @ s; E {{ Φ }}). -Proof. - rewrite envs_entails_eq=> ???. - destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ]. - rewrite -wp_bind. eapply wand_apply; first by eapply wp_xchg. - rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl. - rewrite right_id. - by apply later_mono, sep_mono_r, wand_mono. -Qed. -Lemma tac_twp_xchg Δ s E i K l v v' Φ : - envs_lookup i Δ = Some (false, l ↦ v)%I → - match envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ with - | Some Δ' => envs_entails Δ' (WP fill K (Val $ v) @ s; E [{ Φ }]) - | None => False - end → - envs_entails Δ (WP fill K (Xchg (LitV l) v') @ s; E [{ Φ }]). -Proof. - rewrite envs_entails_eq. intros. - destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ]. - rewrite -twp_bind. eapply wand_apply; first by eapply twp_xchg. - rewrite envs_simple_replace_sound //; simpl. - rewrite right_id. by apply sep_mono_r, wand_mono. -Qed. - -Lemma tac_wp_cmpxchg Δ Δ' s E i K l v v1 v2 Φ : - MaybeIntoLaterNEnvs 1 Δ Δ' → - envs_lookup i Δ' = Some (false, l ↦ v)%I → - vals_compare_safe v v1 → - match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' with - | Some Δ'' => - v = v1 → - envs_entails Δ'' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }}) - | None => False - end → - (v ≠ v1 → - envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }})) → - envs_entails Δ (WP fill K (CmpXchg (LitV l) (Val v1) (Val v2)) @ s; E {{ Φ }}). -Proof. - rewrite envs_entails_eq=> ??? Hsuc Hfail. - destruct (envs_simple_replace _ _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ]. - destruct (decide (v = v1)) as [Heq|Hne]. - - rewrite -wp_bind. eapply wand_apply. - { eapply wp_cmpxchg_suc; eauto. } - rewrite into_laterN_env_sound -later_sep /= {1}envs_simple_replace_sound //; simpl. - apply later_mono, sep_mono_r. rewrite right_id. apply wand_mono; auto. - - rewrite -wp_bind. eapply wand_apply. - { eapply wp_cmpxchg_fail; eauto. } - rewrite into_laterN_env_sound -later_sep /= {1}envs_lookup_split //; simpl. - apply later_mono, sep_mono_r. apply wand_mono; auto. -Qed. -Lemma tac_twp_cmpxchg Δ s E i K l v v1 v2 Φ : - envs_lookup i Δ = Some (false, l ↦ v)%I → - vals_compare_safe v v1 → - match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ with - | Some Δ' => - v = v1 → - envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E [{ Φ }]) - | None => False - end → - (v ≠ v1 → - envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E [{ Φ }])) → - envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]). -Proof. - rewrite envs_entails_eq=> ?? Hsuc Hfail. - destruct (envs_simple_replace _ _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ]. - destruct (decide (v = v1)) as [Heq|Hne]. - - rewrite -twp_bind. eapply wand_apply. - { eapply twp_cmpxchg_suc; eauto. } - rewrite /= {1}envs_simple_replace_sound //; simpl. - apply sep_mono_r. rewrite right_id. apply wand_mono; auto. - - rewrite -twp_bind. eapply wand_apply. - { eapply twp_cmpxchg_fail; eauto. } - rewrite /= {1}envs_lookup_split //; simpl. - apply sep_mono_r. apply wand_mono; auto. -Qed. - -Lemma tac_wp_cmpxchg_fail Δ Δ' s E i K l q v v1 v2 Φ : - MaybeIntoLaterNEnvs 1 Δ Δ' → - envs_lookup i Δ' = Some (false, l ↦{q} v)%I → - v ≠ v1 → vals_compare_safe v v1 → - envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }}) → - envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}). -Proof. - rewrite envs_entails_eq=> ?????. - rewrite -wp_bind. eapply wand_apply; first exact: wp_cmpxchg_fail. - rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl. - by apply later_mono, sep_mono_r, wand_mono. -Qed. -Lemma tac_twp_cmpxchg_fail Δ s E i K l q v v1 v2 Φ : - envs_lookup i Δ = Some (false, l ↦{q} v)%I → - v ≠ v1 → vals_compare_safe v v1 → - envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E [{ Φ }]) → - envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]). -Proof. - rewrite envs_entails_eq. intros. rewrite -twp_bind. - eapply wand_apply; first exact: twp_cmpxchg_fail. - (* [//] solves some evars and enables further simplification. *) - rewrite envs_lookup_split /= // /=. by do 2 f_equiv. -Qed. - -Lemma tac_wp_cmpxchg_suc Δ Δ' s E i K l v v1 v2 Φ : - MaybeIntoLaterNEnvs 1 Δ Δ' → - envs_lookup i Δ' = Some (false, l ↦ v)%I → - v = v1 → vals_compare_safe v v1 → - match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' with - | Some Δ'' => - envs_entails Δ'' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }}) - | None => False - end → - envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}). -Proof. - rewrite envs_entails_eq=> ?????; subst. - destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ]. - rewrite -wp_bind. eapply wand_apply. - { eapply wp_cmpxchg_suc; eauto. } - rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl. - rewrite right_id. by apply later_mono, sep_mono_r, wand_mono. -Qed. -Lemma tac_twp_cmpxchg_suc Δ s E i K l v v1 v2 Φ : - envs_lookup i Δ = Some (false, l ↦ v)%I → - v = v1 → vals_compare_safe v v1 → - match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ with - | Some Δ' => - envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E [{ Φ }]) - | None => False - end → - envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]). -Proof. - rewrite envs_entails_eq=>????; subst. - destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ]. - rewrite -twp_bind. eapply wand_apply. - { eapply twp_cmpxchg_suc; eauto. } - rewrite envs_simple_replace_sound //; simpl. - rewrite right_id. by apply sep_mono_r, wand_mono. -Qed. - -Lemma tac_wp_faa Δ Δ' s E i K l z1 z2 Φ : - MaybeIntoLaterNEnvs 1 Δ Δ' → - envs_lookup i Δ' = Some (false, l ↦ LitV z1)%I → - match envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (LitInt (z1 + z2)))) Δ' with - | Some Δ'' => envs_entails Δ'' (WP fill K (Val $ LitV z1) @ s; E {{ Φ }}) - | None => False - end → - envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E {{ Φ }}). -Proof. - rewrite envs_entails_eq=> ???. - destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ]. - rewrite -wp_bind. eapply wand_apply; first exact: (wp_faa _ _ _ z1 z2). - rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl. - rewrite right_id. by apply later_mono, sep_mono_r, wand_mono. -Qed. -Lemma tac_twp_faa Δ s E i K l z1 z2 Φ : - envs_lookup i Δ = Some (false, l ↦ LitV z1)%I → - match envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (LitInt (z1 + z2)))) Δ with - | Some Δ' => envs_entails Δ' (WP fill K (Val $ LitV z1) @ s; E [{ Φ }]) - | None => False - end → - envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E [{ Φ }]). -Proof. - rewrite envs_entails_eq=> ??. - destruct (envs_simple_replace _ _ _) as [Δ'|] eqn:HΔ'; [ | contradiction ]. - rewrite -twp_bind. eapply wand_apply; first exact: (twp_faa _ _ _ z1 z2). - rewrite envs_simple_replace_sound //; simpl. - rewrite right_id. by apply sep_mono_r, wand_mono. -Qed. -End heap. - -(** The tactic [wp_apply_core lem tac_suc tac_fail] evaluates [lem] to a -hypothesis [H] that can be applied, and then runs [wp_bind_core K; tac_suc H] -for every possible evaluation context [K]. - -- The tactic [tac_suc] should do [iApplyHyp H] to actually apply the hypothesis, - but can perform other operations in addition (see [wp_apply] and [awp_apply] - below). -- The tactic [tac_fail cont] is called when [tac_suc H] fails for all evaluation - contexts [K], and can perform further operations before invoking [cont] to - try again. - -TC resolution of [lem] premises happens *after* [tac_suc H] got executed. *) -Ltac wp_apply_core lem tac_suc tac_fail := first - [iPoseProofCore lem as false (fun H => - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - reshape_expr e ltac:(fun K e' => - wp_bind_core K; tac_suc H) - | |- envs_entails _ (twp ?s ?E ?e ?Q) => - reshape_expr e ltac:(fun K e' => - twp_bind_core K; tac_suc H) - | _ => fail 1 "wp_apply: not a 'wp'" - end) - |tac_fail ltac:(fun _ => wp_apply_core lem tac_suc tac_fail) - |let P := type of lem in - fail "wp_apply: cannot apply" lem ":" P ]. - -Tactic Notation "wp_apply" open_constr(lem) := - wp_apply_core lem ltac:(fun H => iApplyHyp H; try iNext; try wp_expr_simpl) - ltac:(fun cont => fail). -Tactic Notation "wp_smart_apply" open_constr(lem) := - wp_apply_core lem ltac:(fun H => iApplyHyp H; try iNext; try wp_expr_simpl) - ltac:(fun cont => wp_pure _; []; cont ()). - -(** Tactic tailored for atomic triples: the first, simple one just runs -[iAuIntro] on the goal, as atomic triples always have an atomic update as their -premise. The second one additionaly does some framing: it gets rid of [Hs] from -the context, which is intended to be the non-laterable assertions that iAuIntro -would choke on. You get them all back in the continuation of the atomic -operation. *) -Tactic Notation "awp_apply" open_constr(lem) := - wp_apply_core lem ltac:(fun H => iApplyHyp H) ltac:(fun cont => fail); - last iAuIntro. -Tactic Notation "awp_apply" open_constr(lem) "without" constr(Hs) := - (* Convert "list of hypothesis" into specialization pattern. *) - let Hs := words Hs in - let Hs := eval vm_compute in (INamed <$> Hs) in - wp_apply_core lem - ltac:(fun H => - iApply (wp_frame_wand with - [SGoal $ SpecGoal GSpatial false [] Hs false]); [iAccu|iApplyHyp H]) - ltac:(fun cont => fail); - last iAuIntro. - -Tactic Notation "wp_alloc" ident(l) "as" constr(H) := - let Htmp := iFresh in - let finish _ := - first [intros l | fail 1 "wp_alloc:" l "not fresh"]; - pm_reduce; - lazymatch goal with - | |- False => fail 1 "wp_alloc:" H "not fresh" - | _ => iDestructHyp Htmp as H; wp_finish - end in - wp_pures; - (** The code first tries to use allocation lemma for a single reference, - ie, [tac_wp_alloc] (respectively, [tac_twp_alloc]). - If that fails, it tries to use the lemma [tac_wp_allocN] - (respectively, [tac_twp_allocN]) for allocating an array. - Notice that we could have used the array allocation lemma also for single - references. However, that would produce the resource l ↦∗ [v] instead of - l ↦ v for single references. These are logically equivalent assertions - but are not equal. *) - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - let process_single _ := - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_alloc _ _ _ _ Htmp K)) - |fail 1 "wp_alloc: cannot find 'Alloc' in" e]; - [tc_solve - |finish ()] - in - let process_array _ := - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_allocN _ _ _ _ Htmp K)) - |fail 1 "wp_alloc: cannot find 'Alloc' in" e]; - [idtac|tc_solve - |finish ()] - in (process_single ()) || (process_array ()) - | |- envs_entails _ (twp ?s ?E ?e ?Q) => - let process_single _ := - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_alloc _ _ _ Htmp K)) - |fail 1 "wp_alloc: cannot find 'Alloc' in" e]; - finish () - in - let process_array _ := - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_allocN _ _ _ Htmp K)) - |fail 1 "wp_alloc: cannot find 'Alloc' in" e]; - [idtac - |finish ()] - in (process_single ()) || (process_array ()) - | _ => fail "wp_alloc: not a 'wp'" - end. - -Tactic Notation "wp_alloc" ident(l) := - wp_alloc l as "?". - -Tactic Notation "wp_free" := - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_free: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_free _ _ _ _ _ K)) - |fail 1 "wp_free: cannot find 'Free' in" e]; - [tc_solve - |solve_mapsto () - |pm_reduce; wp_finish] - | |- envs_entails _ (twp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_free _ _ _ _ K)) - |fail 1 "wp_free: cannot find 'Free' in" e]; - [solve_mapsto () - |pm_reduce; wp_finish] - | _ => fail "wp_free: not a 'wp'" - end. - -Tactic Notation "wp_store" := - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_store: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_store _ _ _ _ _ K)) - |fail 1 "wp_store: cannot find 'Store' in" e]; - [tc_solve - |solve_mapsto () - |pm_reduce; first [wp_seq|wp_finish]] - | |- envs_entails _ (twp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_store _ _ _ _ K)) - |fail 1 "wp_store: cannot find 'Store' in" e]; - [solve_mapsto () - |pm_reduce; first [wp_seq|wp_finish]] - | _ => fail "wp_store: not a 'wp'" - end. - -Tactic Notation "wp_xchg" := - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_xchg: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_xchg _ _ _ _ _ K)) - |fail 1 "wp_xchg: cannot find 'Xchg' in" e]; - [tc_solve - |solve_mapsto () - |pm_reduce; first [wp_seq|wp_finish]] - | |- envs_entails _ (twp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_xchg _ _ _ _ K)) - |fail 1 "wp_xchg: cannot find 'Xchg' in" e]; - [solve_mapsto () - |pm_reduce; first [wp_seq|wp_finish]] - | _ => fail "wp_xchg: not a 'wp'" - end. - -Tactic Notation "wp_cmpxchg" "as" simple_intropattern(H1) "|" simple_intropattern(H2) := - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_cmpxchg: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg _ _ _ _ _ K)) - |fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e]; - [tc_solve - |solve_mapsto () - |try solve_vals_compare_safe - |pm_reduce; intros H1; wp_finish - |intros H2; wp_finish] - | |- envs_entails _ (twp ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg _ _ _ _ K)) - |fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e]; - [solve_mapsto () - |try solve_vals_compare_safe - |pm_reduce; intros H1; wp_finish - |intros H2; wp_finish] - | _ => fail "wp_cmpxchg: not a 'wp'" - end. - -Tactic Notation "wp_cmpxchg_fail" := - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_cmpxchg_fail: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg_fail _ _ _ _ _ K)) - |fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e]; - [tc_solve - |solve_mapsto () - |try (simpl; congruence) (* value inequality *) - |try solve_vals_compare_safe - |wp_finish] - | |- envs_entails _ (twp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg_fail _ _ _ _ K)) - |fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e]; - [solve_mapsto () - |try (simpl; congruence) (* value inequality *) - |try solve_vals_compare_safe - |wp_finish] - | _ => fail "wp_cmpxchg_fail: not a 'wp'" - end. - -Tactic Notation "wp_cmpxchg_suc" := - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_cmpxchg_suc: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg_suc _ _ _ _ _ K)) - |fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e]; - [tc_solve - |solve_mapsto () - |try (simpl; congruence) (* value equality *) - |try solve_vals_compare_safe - |pm_reduce; wp_finish] - | |- envs_entails _ (twp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg_suc _ _ _ _ K)) - |fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e]; - [solve_mapsto () - |try (simpl; congruence) (* value equality *) - |try solve_vals_compare_safe - |pm_reduce; wp_finish] - | _ => fail "wp_cmpxchg_suc: not a 'wp'" - end. - -Tactic Notation "wp_faa" := - let solve_mapsto _ := - let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in - iAssumptionCore || fail "wp_faa: cannot find" l "↦ ?" in - wp_pures; - lazymatch goal with - | |- envs_entails _ (wp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_wp_faa _ _ _ _ _ K)) - |fail 1 "wp_faa: cannot find 'FAA' in" e]; - [tc_solve - |solve_mapsto () - |pm_reduce; wp_finish] - | |- envs_entails _ (twp ?s ?E ?e ?Q) => - first - [reshape_expr e ltac:(fun K e' => eapply (tac_twp_faa _ _ _ _ K)) - |fail 1 "wp_faa: cannot find 'FAA' in" e]; - [solve_mapsto () - |pm_reduce; wp_finish] - | _ => fail "wp_faa: not a 'wp'" - end. - -*) diff --git a/fairness/heap_lang/tactics.v b/fairness/heap_lang/tactics.v deleted file mode 100644 index e13b022d..00000000 --- a/fairness/heap_lang/tactics.v +++ /dev/null @@ -1,49 +0,0 @@ -From trillium.fairness.heap_lang Require Export lang. -Set Default Proof Using "Type". -Import heap_lang. - -(** The tactic [reshape_expr e tac] decomposes the expression [e] into an -evaluation context [K] and a subexpression [e']. It calls the tactic [tac K e'] -for each possible decomposition until [tac] succeeds. *) -Ltac reshape_expr e tac := - (* Note that the current context is spread into a list of fully-constructed - items [K], and a list of pairs of values [vs] (prophecy identifier and - resolution value) that is only non-empty if a [ResolveLCtx] item (maybe - having several levels) is in the process of being constructed. Note that - a fully-constructed item is inserted into [K] by calling [add_item], and - that is only the case when a non-[ResolveLCtx] item is built. When [vs] - is non-empty, [add_item] also wraps the item under several [ResolveLCtx] - constructors: one for each pair in [vs]. *) - let rec go K vs e := - match e with - | _ => lazymatch vs with [] => tac K e | _ => fail end - | App ?e (Val ?v) => add_item (AppLCtx v) vs K e - | App ?e1 ?e2 => add_item (AppRCtx e1) vs K e2 - | UnOp ?op ?e => add_item (UnOpCtx op) vs K e - | BinOp ?op ?e (Val ?v) => add_item (BinOpLCtx op v) vs K e - | BinOp ?op ?e1 ?e2 => add_item (BinOpRCtx op e1) vs K e2 - | If ?e0 ?e1 ?e2 => add_item (IfCtx e1 e2) vs K e0 - | Pair ?e (Val ?v) => add_item (PairLCtx v) vs K e - | Pair ?e1 ?e2 => add_item (PairRCtx e1) vs K e2 - | Fst ?e => add_item FstCtx vs K e - | Snd ?e => add_item SndCtx vs K e - | InjL ?e => add_item InjLCtx vs K e - | InjR ?e => add_item InjRCtx vs K e - | Case ?e0 ?e1 ?e2 => add_item (CaseCtx e1 e2) vs K e0 - | AllocN ?e (Val ?v) => add_item (AllocNLCtx v) vs K e - | AllocN ?e1 ?e2 => add_item (AllocNRCtx e1) vs K e2 - | Load ?e => add_item LoadCtx vs K e - | Store ?e (Val ?v) => add_item (StoreLCtx v) vs K e - | Store ?e1 ?e2 => add_item (StoreRCtx e1) vs K e2 - | CmpXchg ?e0 (Val ?v1) (Val ?v2) => add_item (CmpXchgLCtx v1 v2) vs K e0 - | CmpXchg ?e0 ?e1 (Val ?v2) => add_item (CmpXchgMCtx e0 v2) vs K e1 - | CmpXchg ?e0 ?e1 ?e2 => add_item (CmpXchgRCtx e0 e1) vs K e2 - | FAA ?e (Val ?v) => add_item (FaaLCtx v) vs K e - | FAA ?e1 ?e2 => add_item (FaaRCtx e1) vs K e2 - end - with add_item Ki vs K e := - lazymatch vs with - | [] => go (Ki :: K) (@nil (val * val)) e - end - in - go (@nil ectx_item) (@nil (val * val)) e. diff --git a/fairness/inftraces.v b/fairness/inftraces.v deleted file mode 100644 index fe8e24eb..00000000 --- a/fairness/inftraces.v +++ /dev/null @@ -1,596 +0,0 @@ -From trillium.program_logic Require Export adequacy. -From stdpp Require Import option. -From Paco Require Import paco1 paco2 pacotac. - -Require Import - Coq.Relations.Relation_Definitions - Coq.Relations.Relation_Operators. -Require Import Coq.Arith.Wf_nat. - -Section traces. - - Delimit Scope trace_scope with trace. - - CoInductive trace (S L: Type) := - | tr_singl (s: S) - | tr_cons (s: S) (ℓ: L) (r: trace S L). - Bind Scope trace_scope with trace. - - Arguments tr_singl {_} {_}, _. - Arguments tr_cons {_} {_} _ _ _%trace. - Notation "⟨ s ⟩" := (tr_singl s) : trace_scope. - Notation "s -[ ℓ ]-> r" := (tr_cons s ℓ r) (at level 33) : trace_scope. - Open Scope trace. - - Lemma trace_unfold_fold {S L} (tr: trace S L) : - tr = match tr with - | ⟨s⟩ => ⟨s⟩ - | s -[ℓ]-> rest => s -[ℓ]-> rest - end. - Proof. destruct tr; trivial. Qed. - - Definition trfirst {S L} (tr: trace S L): S := - match tr with - | ⟨s⟩ => s - | s -[ℓ]-> r => s - end. - - Lemma pred_first_trace (S T : Type) (tr: trace S T ) (P: S -> Prop): - match tr with - | ⟨ s ⟩ | s -[ _ ]-> _ => P s - end <-> P (trfirst tr). - Proof. destruct tr; done. Qed. - - Section after. - Context {St L: Type}. - - Fixpoint after (n: nat) (t: trace St L) : option (trace St L):= - match n with - | 0 => Some t - | Datatypes.S n => - match t with - | ⟨ s ⟩ => None - | s -[ ℓ ]-> xs => after n xs - end - end. - - Definition pred_at (tr: trace St L) (n: nat) (P: St -> option L -> Prop): Prop := - match after n tr with - | None => False - | Some ⟨s⟩ => P s None - | Some (s -[ℓ]-> _) => P s (Some ℓ) - end. - - Lemma after_sum m: forall k (tr: trace St L), - after (k+m) tr = - match after m tr with - | None => None - | Some tr' => after k tr' - end. - Proof. - induction m. - - intros k tr. by have ->: k+0=k by lia. - - intros k tr. simpl. - have -> /=: (k + S m) = S (k+m) by lia. - destruct tr as [s|s l r]; simpl; auto. - Qed. - - Lemma after_sum' m: forall k (tr: trace St L), - after (k+m) tr = - match after k tr with - | None => None - | Some tr' => after m tr' - end. - Proof. intros. rewrite Nat.add_comm. apply after_sum. Qed. - - Lemma pred_at_sum P n m tr: - pred_at tr (n + m) P <-> - match after n tr with - | None => False - | Some tr' => pred_at tr' m P - end. - Proof. - rewrite /pred_at after_sum'. - by destruct (after n tr). - Qed. - - Lemma pred_at_sum' P n m tr: - pred_at tr (n + m) P <-> - match after m tr with - | None => False - | Some tr' => pred_at tr' n P - end. - Proof. - rewrite /pred_at after_sum. - by destruct (after m tr). - Qed. - - Lemma pred_at_0 s ℓ r P: - pred_at (s -[ℓ]-> r) 0 P <-> P s (Some ℓ). - Proof. by unfold pred_at. Qed. - - Lemma pred_at_S s ℓ r n P: - pred_at (s -[ℓ]-> r) (S n) P <-> pred_at r n P. - Proof. by unfold pred_at. Qed. - - Definition infinite_trace tr := - forall n, is_Some (after n tr). - - Definition terminating_trace tr := - ∃ n, after n tr = None. - - Lemma terminating_trace_cons s ℓ tr: - terminating_trace tr -> terminating_trace (s -[ℓ]-> tr). - Proof. intros [n Hterm]. by exists (1+n). Qed. - - Lemma infinite_trace_after n tr: - infinite_trace tr -> match after n tr with - | None => False - | Some tr' => infinite_trace tr' - end. - Proof. - intros Hinf. have [tr' Htr'] := (Hinf n). rewrite Htr'. - intros m. - have Hnm := Hinf (n+m). rewrite after_sum' Htr' // in Hnm. - Qed. - - Lemma infinite_cons s ℓ r: - infinite_trace (s -[ℓ]-> r) -> infinite_trace r. - Proof. - intros Hinf n. specialize (Hinf (1+n)). - rewrite (after_sum' _ 1) // in Hinf. - Qed. - End after. - -End traces. - -Delimit Scope trace_scope with trace. -Arguments tr_singl {_} {_}, _. -Arguments tr_cons {_} {_} _ _ _%trace. -Notation "⟨ s ⟩" := (tr_singl s) : trace_scope. -Notation "s -[ ℓ ]-> r" := (tr_cons s ℓ r) (at level 33) : trace_scope. -Open Scope trace. - -Section simulation. - Context {L1 L2 S1 S2: Type}. - Context (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop). - Context (trans1: S1 -> L1 -> S1 -> Prop). - Context (trans2: S2 -> L2 -> S2 -> Prop). - - CoInductive traces_match : trace S1 L1 -> trace S2 L2 -> Prop := - | trace_match_singl s1 s2: Rs s1 s2 -> traces_match ⟨ s1 ⟩ ⟨ s2 ⟩ - | trace_match_cons s1 ℓ1 r1 s2 ℓ2 r2 : Rℓ ℓ1 ℓ2 -> Rs s1 s2 -> - trans1 s1 ℓ1 (trfirst r1) -> - trans2 s2 ℓ2 (trfirst r2) -> - traces_match r1 r2 -> - traces_match (s1 -[ℓ1]-> r1) (s2 -[ℓ2]-> r2). - - Lemma traces_match_after tr1 tr2 n tr2': - traces_match tr1 tr2 -> - after n tr2 = Some tr2' -> - (exists tr1', after n tr1 = Some tr1' ∧ traces_match tr1' tr2'). - Proof. - revert tr1 tr2. - induction n; intros tr1 tr2. - { simpl. intros. exists tr1. simplify_eq. done. } - move=> /= Hm Ha. destruct tr2 as [|s ℓ tr2''] eqn:Heq; first done. - destruct tr1; first by inversion Hm. - inversion Hm; simplify_eq. by eapply IHn. - Qed. - - Lemma traces_match_first tr1 tr2: - traces_match tr1 tr2 -> - Rs (trfirst tr1) (trfirst tr2). - Proof. intros Hm. inversion Hm; done. Qed. - -End simulation. - -Section execs_and_traces. - Context {S L: Type}. - - CoInductive exec_trace_match: finite_trace S L -> inflist (L * S) -> trace S L -> Prop := - | exec_trace_match_singl ft s: trace_last ft = s -> exec_trace_match ft infnil ⟨s⟩ - | exec_trace_match_cons ft s ℓ ift tr: - exec_trace_match (trace_extend ft ℓ s) ift tr -> - exec_trace_match ft (infcons (ℓ, s) ift) (trace_last ft -[ℓ]-> tr). - - CoFixpoint to_trace (s: S) (il: inflist (L * S)) : trace S L := - match il with - | infnil => ⟨ s ⟩ - | infcons (ℓ, s') rest => s -[ℓ]-> (to_trace s' rest) - end. - - Lemma to_trace_spec (fl: finite_trace S L) (il: inflist (L * S)): - exec_trace_match fl il (to_trace (trace_last fl) il). - Proof. - revert fl il. cofix CH. intros s il. - rewrite (trace_unfold_fold (to_trace _ il)). destruct il as [| [ℓ x]?]; simpl in *. - - by econstructor. - - econstructor. have ->: x = trace_last (trace_extend s ℓ x) by done. - apply CH. - Qed. - - Lemma to_trace_singleton s (il: inflist (L * S)): - exec_trace_match (trace_singleton s) il (to_trace s il). - Proof. apply to_trace_spec. Qed. - - CoFixpoint from_trace (tr: trace S L): inflist (L * S) := - match tr with - | ⟨ s ⟩ => infnil - | s -[ℓ]-> tr' => infcons (ℓ, trfirst tr') (from_trace tr') - end. - - Lemma from_trace_spec (fl: finite_trace S L) (tr: trace S L): - trace_last fl = trfirst tr -> - exec_trace_match fl (from_trace tr) tr. - Proof. - revert fl tr. cofix CH. intros fl tr Heq. - rewrite (inflist_unfold_fold (from_trace tr)). destruct tr; simpl in *. - - by econstructor. - - rewrite -Heq. econstructor. apply CH; done. - Qed. - -End execs_and_traces. - -Definition oleq (a b : option nat) : Prop := - match a, b with - | Some x, Some y => x ≤ y - | _, _ => False - end. - -Definition oless (a b : option nat) : Prop := - match a, b with - | Some x, Some y => x < y - | _, _ => False - end. - -Lemma oleq_oless a b : oless a b -> oleq a b. -Proof. destruct a; destruct b=>//. unfold oless, oleq. lia. Qed. - - -Section dec_unless. - Context {St S' L L': Type}. - Context (Us: St -> S'). - Context (Ul: L -> option L'). - - Definition dec_unless Ψ (tr: trace St L) := - ∀ n, match after n tr with - | Some ⟨ _ ⟩ | None => True - | Some (s -[ℓ]-> tr') => - (∃ ℓ', Ul ℓ = Some ℓ') ∨ - (Ψ (trfirst tr') < Ψ s ∧ Us s = Us (trfirst tr')) - end. - - Lemma dec_unless_next Ψ s ℓ tr (Hdec: dec_unless Ψ (s -[ℓ]-> tr)): dec_unless Ψ tr. - Proof. - intros n. specialize (Hdec (n+1)). rewrite (after_sum 1) // in Hdec. - Qed. - -End dec_unless. - -Section destuttering. - Context {St S' L L': Type}. - Context (Us: St -> S'). - Context (Ul: L -> option L'). - - Inductive upto_stutter_ind (upto_stutter_coind: trace St L -> trace S' L' -> Prop): - trace St L -> trace S' L' -> Prop := - | upto_stutter_singleton s: - upto_stutter_ind upto_stutter_coind ⟨s⟩ ⟨Us s⟩ - | upto_stutter_stutter btr str s ℓ: - Ul ℓ = None -> - (* (Us s = Us (trfirst btr) -> (or something like this...?) *) - Us s = Us (trfirst btr) -> - Us s = trfirst str -> - upto_stutter_ind upto_stutter_coind btr str -> - upto_stutter_ind upto_stutter_coind (s -[ℓ]-> btr) str - | upto_stutter_step btr str s ℓ s' ℓ': - Us s = s' -> - Ul ℓ = Some ℓ' -> - upto_stutter_coind btr str -> - upto_stutter_ind upto_stutter_coind (s -[ℓ]-> btr) (s' -[ℓ']-> str). - - Definition upto_stutter := paco2 upto_stutter_ind bot2. - - Lemma upto_stutter_mono : - monotone2 (upto_stutter_ind). - Proof. - unfold monotone2. intros x0 x1 r r' IN LE. - induction IN; try (econstructor; eauto; done). - Qed. - Hint Resolve upto_stutter_mono : paco. - - Lemma upto_stutter_after {btr str} n {str'}: - upto_stutter btr str -> - after n str = Some str' -> - ∃ n' btr', after n' btr = Some btr' ∧ upto_stutter btr' str'. - Proof. - have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). - { intros P [x ?]. by exists (S x). } - revert btr str str'. induction n as [|n IH]; intros btr str str' Hupto Hafter. - { injection Hafter => <-. clear Hafter. exists 0, btr. done. } - revert str' Hafter. punfold Hupto. induction Hupto as - [s|btr str s ℓ HUl HUs1 HUs2 Hind IHH|btr str s ℓ s' ℓ' ?? Hind]. - - intros str' Hafter. done. - - intros str' Hafter. - apply Hw. simpl. by apply IHH. - - intros str' Hafter. simpl in Hafter. - apply Hw. simpl. eapply IH =>//. - by destruct Hind. - Qed. - - Lemma upto_stutter_after_None {btr str} n: - upto_stutter btr str -> - after n str = None -> - ∃ n', after n' btr = None. - Proof. - have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). - { intros P [x ?]. by exists (S x). } - revert btr str. induction n as [|n IH]; intros btr str Hupto Hafter. - { exists 0. done. } - revert Hafter. punfold Hupto. induction Hupto as - [s|btr str s ℓ HUl HUs1 HUs2 Hind IHH|btr str s ℓ s' ℓ' ?? Hind]. - - intros Hafter. by exists 1. - - intros Hafter. - apply Hw. simpl. by apply IHH. - - intros Hafter. simpl in Hafter. - apply Hw. simpl. eapply IH =>//. - by destruct Hind. - Qed. - - Lemma upto_stutter_infinite_trace tr1 tr2 : - upto_stutter tr1 tr2 → infinite_trace tr1 → infinite_trace tr2. - Proof. - intros Hstutter Hinf n. - revert tr1 tr2 Hstutter Hinf. - induction n as [|n IHn]; intros tr1 tr2 Hstutter Hinf. - - punfold Hstutter. - - punfold Hstutter. - induction Hstutter. - + specialize (Hinf (1 + n)). - rewrite after_sum' in Hinf. simpl in *. apply is_Some_None in Hinf. done. - + apply IHHstutter. - intros m. specialize (Hinf (1 + m)). - rewrite after_sum' in Hinf. simpl in *. done. - + simpl. eapply (IHn btr str); [by destruct H1|]. - intros m. specialize (Hinf (1 + m)). - rewrite after_sum' in Hinf. simpl in *. done. - Qed. - - Program Fixpoint destutter_once_step N Ψ (btr: trace St L) : - Ψ (trfirst btr) < N → - dec_unless Us Ul Ψ btr → - S' + (S' * L' * { btr' : trace St L | dec_unless Us Ul Ψ btr'}) := - match N as n return - Ψ (trfirst btr) < n → - dec_unless Us Ul Ψ btr → - S' + (S' * L' * { btr' : trace St L | dec_unless Us Ul Ψ btr'}) - with - | O => λ Hlt _, False_rect _ (Nat.nlt_0_r _ Hlt) - | S N' => - λ Hlt Hdec, - match btr as z return btr = z → S' + (S' * L' * { btr' : trace St L | dec_unless Us Ul Ψ btr'}) with - | tr_singl s => λ _, inl (Us s) - | tr_cons s l btr' => - λ Hbtreq, - match Ul l as z return Ul l = z → S' + (S' * L' * { btr' : trace St L | dec_unless Us Ul Ψ btr'}) with - | Some l' => λ _, inr (Us s, l', exist _ btr' _) - | None => λ HUll, destutter_once_step N' Ψ btr' _ _ - end eq_refl - end eq_refl - end. - Next Obligation. - Proof. - intros _ Ψ btr N' Hlt Hdec s l btr' -> l' HUll; simpl. - eapply dec_unless_next; done. - Qed. - Next Obligation. - Proof. - intros _ Ψ btr N' Hlt Hdec s l btr' -> HUll; simpl in *. - pose proof (Hdec 0) as [[? ?]|[? ?]]; [congruence|lia]. - Qed. - Next Obligation. - Proof. - intros _ Ψ btr N' Hlt Hdec s l btr' -> HUll; simpl. - eapply dec_unless_next; done. - Qed. - - CoFixpoint destutter_gen Ψ N (btr: trace St L) : - Ψ (trfirst btr) < N -> - dec_unless Us Ul Ψ btr → trace S' L' := - λ Hlt Hdec, - match destutter_once_step N Ψ btr Hlt Hdec with - | inl s' => tr_singl s' - | inr (s', l', z) => tr_cons s' l' (destutter_gen Ψ (S (Ψ (trfirst $ proj1_sig z))) - (proj1_sig z) (Nat.lt_succ_diag_r _) (proj2_sig z)) - end. - - Definition destutter Ψ (btr: trace St L) : - dec_unless Us Ul Ψ btr → trace S' L' := - λ Hdec, - destutter_gen Ψ (S (Ψ (trfirst btr))) btr (Nat.lt_succ_diag_r _) Hdec. - - Lemma destutter_same_Us N Ψ btr Hlt Hdec: - match destutter_once_step N Ψ btr Hlt Hdec with - | inl s' | inr (s', _, _) => Us (trfirst btr) = s' - end. - Proof. - revert btr Hlt Hdec. induction N as [|N]; first lia. - intros btr Hlt Hdec. simpl. - destruct btr as [s|s ℓ btr']; first done. - generalize (destutter_once_step_obligation_1 Ψ (s -[ ℓ ]-> btr') N - Hlt Hdec s ℓ btr' eq_refl). - generalize (destutter_once_step_obligation_2 Ψ (s -[ ℓ ]-> btr') N Hlt Hdec s ℓ btr' eq_refl). - generalize (destutter_once_step_obligation_3 Ψ (s -[ ℓ ]-> btr') N Hlt Hdec s ℓ btr' eq_refl). - intros HunlessNone HltNone HdecSome. - destruct (Ul ℓ) as [ℓ'|] eqn:Heq; cbn; first done. - unfold dec_unless in Hdec. - destruct (Hdec 0) as [[??]|[? Hsame]]; first congruence. - rewrite Hsame. apply IHN. - Qed. - - Lemma destutter_spec_ind N Ψ (btr: trace St L) (Hdec: dec_unless Us Ul Ψ btr) - (Hlt: Ψ (trfirst btr) < N): - upto_stutter btr (destutter_gen Ψ N btr Hlt Hdec). - Proof. - revert N btr Hlt Hdec. - pcofix CH. pfold. - induction N. - { intros; lia. } - intros btr Hlt Hdec. - rewrite (trace_unfold_fold (destutter_gen _ _ _ _ _)). - destruct btr as [s|s ℓ btr']. - { simpl in *. econstructor. } - cbn. - generalize (destutter_once_step_obligation_1 Ψ (s -[ ℓ ]-> btr') N - Hlt Hdec s ℓ btr' eq_refl). - generalize (destutter_once_step_obligation_2 Ψ (s -[ ℓ ]-> btr') N Hlt Hdec s ℓ btr' eq_refl). - generalize (destutter_once_step_obligation_3 Ψ (s -[ ℓ ]-> btr') N Hlt Hdec s ℓ btr' eq_refl). - intros HunlessNone HltNone HdecSome. - destruct (Ul ℓ) as [ℓ'|] eqn:Heq; cbn. - - econstructor 3 =>//. right. apply (CH (S (Ψ $ trfirst btr'))). - - econstructor 2=>//. - + destruct (Hdec 0) as [[??]|[??]];congruence. - + have ?: Us s = Us (trfirst btr'). - { destruct (Hdec 0) as [[??]|[? Hsame]]; congruence. } - have HH := destutter_same_Us N Ψ btr' (HltNone eq_refl) (HunlessNone eq_refl). - destruct (destutter_once_step N Ψ btr' (HltNone eq_refl) (HunlessNone eq_refl)) as - [|[[??][??]]]eqn:Heq'; simpl in *; congruence. - + rewrite -trace_unfold_fold. - specialize (IHN btr' (HltNone eq_refl) (HunlessNone eq_refl)). - match goal with - [H : context[upto_stutter_ind] |- ?Y] => let X := type of H in - suffices <-: X <-> Y; first done - end. - f_equiv. - rewrite {1}(trace_unfold_fold (destutter_gen _ _ _ _ _)) /= -trace_unfold_fold //. - Qed. - - Lemma destutter_spec Ψ (btr: trace St L) (Hdec: dec_unless Us Ul Ψ btr): - upto_stutter btr (destutter Ψ btr Hdec). - Proof. eapply destutter_spec_ind. Qed. - - Lemma can_destutter Ψ (btr: trace St L) (Hdec: dec_unless Us Ul Ψ btr): - ∃ str, upto_stutter btr str. - Proof. exists (destutter Ψ btr Hdec). apply destutter_spec. Qed. - -End destuttering. - -(* TODO: Does this belong here? *) -(* Adapted from Arthur Azevedo De Amorim *) -Section lex_ind. - Section Lexicographic. - - Variables (A B : Type) (leA : relation A) (leB : relation B). - - Inductive lexprod : A * B -> A * B -> Prop := - | left_lex : forall x x' y y', leA x x' -> lexprod (x, y) (x', y') - | right_lex : forall x y y', leB y y' -> lexprod (x, y) (x, y'). - - Theorem wf_trans : - transitive _ leA -> - transitive _ leB -> - transitive _ lexprod. - Proof. - intros tA tB [x1 y1] [x2 y2] [x3 y3] H. - inversion H; subst; clear H. - - intros H. - inversion H; subst; clear H; apply left_lex; now eauto. - - intros H. - inversion H; subst; clear H. - + now apply left_lex. - + now apply right_lex; eauto. - Qed. - - Theorem wf_lexprod : - well_founded leA -> - well_founded leB -> - well_founded lexprod. - Proof. - intros wfA wfB [x y]. generalize dependent y. - induction (wfA x) as [x _ IHx]; clear wfA. - intros y. - induction (wfB y) as [y _ IHy]; clear wfB. - constructor. - intros [x' y'] H. - now inversion H; subst; clear H; eauto. - Qed. - - End Lexicographic. - - Definition lt_lex : relation (nat * nat) := fun '(x, y) '(x', y') => - x < x' ∨ (x = x' ∧ y <= y'). - - #[global] Instance lt_lex_partial_order : PartialOrder lt_lex. - Proof. - constructor. - + constructor. - * move=> [x y]. right; split; reflexivity. - * move=> [x1 y1] [x2 y2] [x3 y3] [H1|H1] [H2|H2]; unfold lt_lex; lia. - + move=> [x1 y1] [x2 y2] [?|[??]] [H2|[??]]; f_equal; try lia. - Qed. - - Definition myrel : relation (nat * nat) := - lexprod _ _ lt lt. - - Lemma lex_ind: - ∀ (n : nat*nat) (P : nat*nat → Prop), - (∀ n0 : nat*nat, (∀ m : nat*nat, (strict lt_lex) m n0 → P m) → P n0) → P n. - Proof. - assert (well_founded myrel) as Hwf. - - { apply wf_lexprod; apply lt_wf. } - induction n using (well_founded_ind Hwf). - intros P HI. apply HI =>//. intros m [Ha Hb]. - apply H =>//. destruct n as [n1 n2]; destruct m as [m1 m2]. - unfold strict, lt_lex in *. - destruct Ha as [Ha | [Ha1 Ha2]]. - - constructor 1. done. - - rewrite Ha1. constructor 2. lia. - Qed. - -End lex_ind. - -#[global] Program Instance add_monoid: Monoid Nat.add := - {| monoid_unit := 0 |}. - -Section addition_monoid. - Context `{Countable K}. - - Lemma big_addM_leq_forall (X Y: gmap K nat): - (∀ k, k ∈ dom X -> oleq (X !! k) (Y !! k)) -> - ([^ Nat.add map] k ↦ x ∈ X, x) ≤ ([^ Nat.add map] k ↦ y ∈ Y, y). - Proof. - revert Y. - induction X as [|k v X HXk IH] using map_ind. - { intros Y Hx. rewrite big_opM_empty /=. lia. } - intros Y Hx. rewrite big_opM_insert //. - have Hol: oleq (<[k:=v]> X !! k) (Y !! k) by apply Hx; set_solver. - rewrite lookup_insert in Hol. - destruct (Y!!k) as [v'|] eqn:Heq; last done. - rewrite (big_opM_delete _ Y k v') //. - apply Nat.add_le_mono=>//. - apply IH=> k' Hin. - have ?: k ≠ k'. - { intros ->. apply elem_of_dom in Hin. rewrite HXk in Hin. by destruct Hin. } - rewrite -(lookup_insert_ne X k k' v) // (lookup_delete_ne Y k) //. - apply Hx. set_solver. - Qed. -End addition_monoid. - -(* Classical *) - -Require Import Coq.Logic.Classical. -Section infinite_or_finite. - Context {St L: Type}. - - Lemma infinite_or_finite (tr: trace St L): - infinite_trace tr ∨ terminating_trace tr. - Proof. - destruct (classic (infinite_trace tr)) as [|Hni]; first by eauto. - rewrite /infinite_trace in Hni. - apply not_all_ex_not in Hni. destruct Hni as [n Hni%eq_None_not_Some]. - by right; exists n. - Qed. - -End infinite_or_finite. diff --git a/fairness/resources.v b/fairness/resources.v deleted file mode 100644 index 0e573807..00000000 --- a/fairness/resources.v +++ /dev/null @@ -1,1471 +0,0 @@ -From iris.algebra Require Import auth gmap gset excl. -From iris.proofmode Require Import tactics. -From trillium.fairness Require Import fairness fuel. - -Canonical Structure ModelO (Mdl : FairModel) := leibnizO Mdl. -Canonical Structure RoleO (Mdl : FairModel) := leibnizO (Mdl.(fmrole)). -Canonical Structure localeO (Λ : language) := leibnizO (locale Λ). - -Class fairnessGpreS `(LM: LiveModel Λ M) Σ `{Countable (locale Λ)} := { - fairnessGpreS_model :> inG Σ (authUR (optionUR (exclR (ModelO M)))); - fairnessGpreS_model_mapping :> inG Σ (authUR (gmapUR (localeO Λ) (exclR (gsetR (RoleO M))))); - fairnessGpreS_model_fuel :> inG Σ (authUR (gmapUR (RoleO M) (exclR natO))); - fairnessGpreS_model_free_roles :> inG Σ (authUR (gset_disjUR (RoleO M))); -}. - -Class fairnessGS `(LM : LiveModel Λ M) Σ `{Countable (locale Λ)} := FairnessGS { - fairness_inG :> fairnessGpreS LM Σ; - (** Underlying model *) - fairness_model_name : gname; - (** Mapping of threads to sets of roles *) - fairness_model_mapping_name : gname; - (** Mapping of roles to fuel *) - fairness_model_fuel_name : gname; - (** Set of free/availble roles *) - fairness_model_free_roles_name : gname; -}. - -Global Arguments fairnessGS {_ _} LM Σ {_ _}. -Global Arguments FairnessGS {_ _} LM Σ {_ _ _} _ _ _. -Global Arguments fairness_model_name {_ _ LM Σ _ _} _. -Global Arguments fairness_model_mapping_name {Λ M LM Σ _ _} _ : assert. -Global Arguments fairness_model_fuel_name {Λ M LM Σ _ _} _ : assert. -Global Arguments fairness_model_free_roles_name {Λ M LM Σ _ _} _ : assert. - -Definition fairnessΣ Λ M `{Countable (locale Λ)} : gFunctors := #[ - GFunctor (authUR (optionUR (exclR (ModelO M)))); - GFunctor (authUR (gmapUR (localeO Λ) (exclR (gsetR (RoleO M))))); - GFunctor (authUR (gmapUR (RoleO M) (exclR natO))); - GFunctor (authUR (gset_disjUR (RoleO M))) -]. - -Global Instance subG_fairnessGpreS {Σ} `{LM : LiveModel Λ M} - `{Countable (locale Λ)} : - subG (fairnessΣ Λ M) Σ -> fairnessGpreS LM Σ. -Proof. solve_inG. Qed. - -Notation "f ⇂ R" := (filter (λ '(k,v), k ∈ R) f) (at level 30). - -Lemma dom_domain_restrict `{Countable X} {A} (f: gmap X A) (R: gset X): - R ⊆ dom f -> - dom (f ⇂ R) = R. -Proof. - intros ?. apply dom_filter_L. - intros i; split; [|set_solver]. - intros Hin. assert (Hin': i ∈ dom f) by set_solver. - apply elem_of_dom in Hin' as [??]. set_solver. -Qed. - -Lemma dom_domain_restrict_union_l `{Countable X} {A} (f: gmap X A) R1 R2: - R1 ∪ R2 ⊆ dom f -> - dom (f ⇂ R1) = R1. -Proof. - intros ?. apply dom_domain_restrict. set_solver. -Qed. -Lemma dom_domain_restrict_union_r `{Countable X} {A} (f: gmap X A) R1 R2: - R1 ∪ R2 ⊆ dom f -> - dom (f ⇂ R2) = R2. -Proof. - intros ?. apply dom_domain_restrict. set_solver. -Qed. - -Section bigop_utils. - Context `{Monoid M o}. - Context `{Countable K}. - - Lemma big_opMS (g: gset K) (P: K -> M): - ([^ o set] x ∈ g, P x) ≡ [^ o map] x ↦ y ∈ (mapset_car g), P x. - Proof. - rewrite big_opS_elements /elements /gset_elements /mapset_elements. - rewrite big_opM_map_to_list. - destruct g as [g]. simpl. rewrite big_opL_fmap. - f_equiv. - Qed. -End bigop_utils. - -Section bigop_utils. - Context `{Countable K} {A : cmra}. - Implicit Types m : gmap K A. - Implicit Types i : K. - - Lemma gset_to_gmap_singletons (a : A) (g : gset K): - ([^op set] x ∈ g, {[x := a]}) ≡ gset_to_gmap a g. - Proof. - rewrite big_opMS. - rewrite -(big_opM_singletons (gset_to_gmap a g)). - rewrite /gset_to_gmap big_opM_fmap //. - Qed. -End bigop_utils. - -Section map_utils. - Context `{Countable K, Countable V, EqDecision K}. - - Definition maps_inverse_match (m: gmap K V) (m': gmap V (gset K)) := - ∀ (k: K) (v: V), m !! k = Some v <-> ∃ (ks: gset K), m' !! v = Some ks ∧ k ∈ ks. - - Lemma no_locale_empty M M' ρ ζ: - maps_inverse_match M M' -> - M' !! ζ = Some ∅ -> - M !! ρ ≠ Some ζ. - Proof. - intros Hinv Hem contra. - destruct (Hinv ρ ζ) as [Hc _]. destruct (Hc contra) as (?&?&?). - by simplify_eq. - Qed. - - Lemma maps_inverse_bij M M' ρ X1 X2 ζ ζ': - maps_inverse_match M M' -> - M' !! ζ = Some X1 -> ρ ∈ X1 -> - M' !! ζ' = Some X2 -> ρ ∈ X2 -> - ζ = ζ'. - Proof. - intros Hinv Hζ Hρ Hζ' Hρ'. - assert (M !! ρ = Some ζ); first by apply Hinv; eexists; done. - assert (M !! ρ = Some ζ'); first by apply Hinv; eexists; done. - congruence. - Qed. - -End map_utils. - -Section fin_map_dom. -Context `{FinMapDom K M D}. -Lemma dom_empty_iff {A} (m : M A) : dom m ≡ ∅ ↔ m = ∅. -Proof. - split; [|intros ->; by rewrite dom_empty]. - intros E. apply map_empty. intros. apply not_elem_of_dom. - rewrite E. set_solver. -Qed. - -Section leibniz. - Context `{!LeibnizEquiv D}. - Lemma dom_empty_iff_L {A} (m : M A) : dom m = ∅ ↔ m = ∅. - Proof. unfold_leibniz. apply dom_empty_iff. Qed. -End leibniz. -End fin_map_dom. - -Section map_imap. - Context `{Countable K}. - Lemma map_imap_dom_inclusion {A B} (f : K → A → option B) (m : gmap K A) : - dom (map_imap f m) ⊆ dom m. - Proof. - intros i [k Hk]%elem_of_dom. rewrite map_lookup_imap in Hk. - destruct (m !! i) eqn:?; last done. - rewrite elem_of_dom. by eexists. - Qed. - Lemma map_imap_dom_eq {A B} (f : K → A → option B) (m : gmap K A) : - (forall k a, k ∈ dom m -> is_Some (f k a)) -> - dom (map_imap f m) = dom m. - Proof. - rewrite -leibniz_equiv_iff. intros HisSome i. split. - - intros [x Hx]%elem_of_dom. rewrite map_lookup_imap in Hx. - apply elem_of_dom. destruct (m !! i) eqn:Heq; eauto. - by simpl in Hx. - - intros [x Hx]%elem_of_dom. - rewrite elem_of_dom map_lookup_imap Hx /=. apply HisSome, elem_of_dom. eauto. - Qed. -End map_imap. - -Section model_state_interp. - Context `{LM: LiveModel Λ M}. - Context `{Countable (locale Λ)}. - Context {Σ : gFunctors}. - Context {fG: fairnessGS LM Σ}. - - Notation Role := (M.(fmrole)). - - Definition auth_fuel_is (F: gmap Role nat): iProp Σ := - own (fairness_model_fuel_name fG) - (● (fmap (λ f, Excl f) F : ucmra_car (gmapUR (RoleO M) (exclR natO)))). - - Definition frag_fuel_is (F: gmap Role nat): iProp Σ := - own (fairness_model_fuel_name fG) - (◯ (fmap (λ f, Excl f) F : ucmra_car (gmapUR (RoleO M) (exclR natO)))). - - Definition auth_mapping_is (m: gmap (locale Λ) (gset Role)): iProp Σ := - own (fairness_model_mapping_name fG) - (● ( (fmap (λ (f: gset M.(fmrole)), Excl f) m) : - ucmra_car (gmapUR _ (exclR (gsetR (RoleO M)))) - )). - - Definition frag_mapping_is (m: gmap (locale Λ) (gset Role)): iProp Σ := - own (fairness_model_mapping_name fG) - (◯ ( (fmap (λ (f: gset M.(fmrole)), Excl f) m) : - ucmra_car (gmapUR _ (exclR (gsetR (RoleO M)))) - )). - - Definition auth_model_is (fm: M): iProp Σ := - own (fairness_model_name fG) (● Excl' fm). - - Definition frag_model_is (fm: M): iProp Σ := - own (fairness_model_name fG) (◯ Excl' fm). - - Definition auth_free_roles_are (FR: gset Role): iProp Σ := - own (fairness_model_free_roles_name fG) (● (GSet FR)). - - Definition frag_free_roles_are (FR: gset Role): iProp Σ := - own (fairness_model_free_roles_name fG) (◯ (GSet FR)). - - Definition model_state_interp (tp: list $ expr Λ) (δ: LiveState Λ M): iProp Σ := - ∃ M FR, auth_fuel_is δ.(ls_fuel) ∗ auth_mapping_is M ∗ auth_free_roles_are FR ∗ - ⌜maps_inverse_match δ.(ls_mapping) M⌝ ∗ - ⌜ ∀ ζ, ζ ∉ locales_of_list tp → M !! ζ = None ⌝ ∗ - auth_model_is δ ∗ ⌜ FR ∩ dom δ.(ls_fuel) = ∅ ⌝. - - Lemma model_state_interp_tids_smaller δ tp : - model_state_interp tp δ -∗ ⌜ tids_smaller tp δ ⌝. - Proof. - iIntros "(%m&%FR&_&_&_&%Hminv&%Hbig&_)". iPureIntro. - intros ρ ζ Hin. - assert (¬ (ζ ∉ locales_of_list tp)). - - intros contra. - apply Hminv in Hin as [? [Hsome _]]. - specialize (Hbig _ contra). - by rewrite Hbig in Hsome. - - destruct (decide (ζ ∈ locales_of_list tp)) as [Hin'|] =>//. - apply elem_of_list_fmap in Hin' as [[tp' e'] [-> Hin']]. - unfold from_locale. exists e'. by apply from_locale_from_Some. - Qed. -End model_state_interp. - -Lemma own_proper `{inG Σ X} γ (x y: X): - x ≡ y -> - own γ x -∗ own γ y. -Proof. by intros ->. Qed. - -Lemma auth_fuel_is_proper `{fairnessGS (LM:=LM) Σ} - (x y : gmap (fmrole M) nat): - x = y -> - auth_fuel_is x -∗ auth_fuel_is y. -Proof. by intros ->. Qed. - -Notation "tid ↦M R" := (frag_mapping_is {[ tid := R ]}) (at level 33). -Notation "tid ↦m ρ" := (frag_mapping_is {[ tid := {[ ρ ]} ]}) (at level 33). -Notation "ρ ↦F f" := (frag_fuel_is {[ ρ := f ]}) (at level 33). - -Section model_state_lemmas. - Context `{LM: LiveModel Λ M}. - Context `{Countable (locale Λ)}. - Context {Σ : gFunctors}. - Context {fG: fairnessGS LM Σ}. - - Notation Role := (M.(fmrole)). - - Definition has_fuel (ζ: locale Λ) (ρ: Role) (f: nat): iProp Σ := - ζ ↦m ρ ∗ ρ ↦F f. - - Definition has_fuels (ζ: locale Λ) (fs: gmap Role nat): iProp Σ := - ζ ↦M dom fs ∗ [∗ set] ρ ∈ dom fs, ∃ f, ⌜fs !! ρ = Some f⌝ ∧ ρ ↦F f. - - #[global] Instance has_fuels_proper : - Proper ((≡) ==> (≡) ==> (≡)) (has_fuels). - Proof. solve_proper. Qed. - - #[global] Instance has_fuels_timeless (ζ: locale Λ) (fs: gmap Role nat): - Timeless (has_fuels ζ fs). - Proof. rewrite /has_fuels. apply _. Qed. - - Lemma has_fuel_fuels (ζ: locale Λ) (ρ: Role) (f: nat): - has_fuel ζ ρ f ⊣⊢ has_fuels ζ {[ ρ := f ]}. - Proof. - rewrite /has_fuel /has_fuels. iSplit. - - iIntros "[Hζ Hρ]". rewrite dom_singleton_L big_sepS_singleton. iFrame. - iExists f. iFrame. iPureIntro. by rewrite lookup_singleton. - - iIntros "(?&H)". rewrite dom_singleton_L big_sepS_singleton. iFrame. - iDestruct "H" as (?) "H". rewrite lookup_singleton. - iDestruct "H" as "[% ?]". by simplify_eq. - Qed. - - Definition has_fuels_S (ζ: locale Λ) (fs: gmap Role nat): iProp Σ := - has_fuels ζ (fmap S fs). - - Definition has_fuels_plus (n: nat) (ζ: locale Λ) (fs: gmap Role nat): iProp Σ := - has_fuels ζ (fmap (fun m => n+m) fs). - - Lemma has_fuel_fuels_S (ζ: locale Λ) (ρ: Role) (f: nat): - has_fuel ζ ρ (S f) ⊣⊢ has_fuels_S ζ {[ ρ := f ]}. - Proof. - rewrite has_fuel_fuels /has_fuels_S map_fmap_singleton //. - Qed. - - Lemma has_fuel_fuels_plus_1 (ζ: locale Λ) fs: - has_fuels_plus 1 ζ fs ⊣⊢ has_fuels_S ζ fs. - Proof. - rewrite /has_fuels_plus /has_fuels_S. do 2 f_equiv. - intros m m' ->. apply leibniz_equiv_iff. lia. - Qed. - - Lemma has_fuel_fuels_plus_0 (ζ: locale Λ) fs: - has_fuels_plus 0 ζ fs ⊣⊢ has_fuels ζ fs. - Proof. - rewrite /has_fuels_plus /=. f_equiv. intros ?. - rewrite lookup_fmap. apply leibniz_equiv_iff. - destruct (fs !! i) eqn:Heq; rewrite Heq //. - Qed. - - Lemma has_fuels_plus_split_S n (ζ: locale Λ) fs: - has_fuels_plus (S n) ζ fs ⊣⊢ has_fuels_S ζ ((λ m, n + m) <$> fs). - Proof. - rewrite /has_fuels_plus /has_fuels_S. f_equiv. - rewrite -map_fmap_compose /= => ρ. - rewrite !lookup_fmap //. - Qed. - - Lemma frag_mapping_same ζ m R: - auth_mapping_is m -∗ ζ ↦M R -∗ ⌜ m !! ζ = Some R ⌝. - Proof. - iIntros "Ha Hf". iCombine "Ha Hf" as "H". rewrite own_valid. - iDestruct "H" as "%Hval". iPureIntro. - apply auth_both_valid in Hval as [HA HB]. - rewrite map_fmap_singleton in HA. - specialize (HA 0%nat). - apply cmra_discrete_included_iff in HA. - apply -> (@singleton_included_l (locale Λ)) in HA. destruct HA as (R' & HA & Hsub). - assert (✓ Some R'). by rewrite -HA. - destruct R' as [R'|]; last done. - apply Excl_included in Hsub. apply leibniz_equiv in Hsub. - rewrite Hsub. - apply leibniz_equiv in HA. rewrite -> lookup_fmap_Some in HA. - destruct HA as (?&?&?). congruence. - Qed. - -End model_state_lemmas. - -Section adequacy. - Context `{LM: LiveModel Λ M}. - Context `{Countable (locale Λ)}. - Context {Σ : gFunctors}. - Context {fG: fairnessGpreS LM Σ}. - - Lemma model_state_init (s0: M): - ⊢ |==> ∃ γ, - own (A := authUR (optionUR (exclR (ModelO M)))) γ - (● (Excl' s0) ⋅ ◯ (Excl' s0)). - Proof. - iMod (own_alloc (● Excl' s0 ⋅ ◯ Excl' s0)) as (γ) "[Hfl Hfr]". - { by apply auth_both_valid_2. } - iExists _. by iSplitL "Hfl". - Qed. - - Lemma model_mapping_init (s0: M) (ζ0: locale Λ): - ⊢ |==> ∃ γ, - own (A := authUR (gmapUR _ (exclR (gsetR (RoleO M))))) γ - (● ({[ ζ0 := Excl (M.(live_roles) s0) ]}) ⋅ - ◯ ({[ ζ0 := Excl (M.(live_roles) s0) ]})). - Proof. - iMod (own_alloc (● ({[ ζ0 := Excl (M.(live_roles) s0) ]}) ⋅ - ◯ ({[ ζ0 := Excl (M.(live_roles) s0) ]}))) as (γ) "[Hfl Hfr]". - { apply auth_both_valid_2; eauto. by apply singleton_valid. } - iExists _. by iSplitL "Hfl". - Qed. - - Lemma model_fuel_init (s0: M): - ⊢ |==> ∃ γ, - own (A := authUR (gmapUR (RoleO M) (exclR natO))) γ - (● gset_to_gmap (Excl (LM.(lm_fl) s0)) (M.(live_roles) s0) ⋅ - (◯ gset_to_gmap (Excl (LM.(lm_fl) s0)) (M.(live_roles) s0))). - Proof. - iMod (own_alloc - (● gset_to_gmap (Excl (LM.(lm_fl) s0)) (M.(live_roles) s0) ⋅ - (◯ gset_to_gmap (Excl (LM.(lm_fl) s0)) (M.(live_roles) s0)))) as (γ) "[H1 H2]". - { apply auth_both_valid_2;eauto. intros ρ. - destruct (gset_to_gmap (Excl (LM.(lm_fl) s0)) (live_roles M s0) !! ρ) eqn:Heq; - rewrite Heq; last done. - apply lookup_gset_to_gmap_Some in Heq. - destruct Heq as [?<-]. done. } - iExists _. by iSplitL "H1". - Qed. - - Lemma model_free_roles_init (s0: M) (FR: gset _): - ⊢ |==> ∃ γ, - own (A := authUR (gset_disjUR (RoleO M))) γ (● GSet FR ⋅ ◯ GSet FR). - Proof. - iMod (own_alloc (● GSet FR ⋅ ◯ GSet FR)) as (γ) "[H1 H2]". - { apply auth_both_valid_2 =>//. } - iExists _. by iSplitL "H1". - Qed. -End adequacy. - -Section model_state_lemmas. - Context `{LM: LiveModel Λ M}. - Context `{Countable (locale Λ)}. - Context `{EqDecision (expr Λ)}. - Context {Σ : gFunctors}. - Context {fG: fairnessGS LM Σ}. - - Lemma update_model δ δ1 δ2: - auth_model_is δ1 -∗ frag_model_is δ2 ==∗ auth_model_is δ ∗ frag_model_is δ. - Proof. - iIntros "H1 H2". iCombine "H1 H2" as "H". - iMod (own_update with "H") as "[??]" ; eauto. - - by apply auth_update, option_local_update, (exclusive_local_update _ (Excl δ)). - - iModIntro. iFrame. - Qed. - - Lemma free_roles_inclusion FR fr: - auth_free_roles_are FR -∗ - frag_free_roles_are fr -∗ - ⌜fr ⊆ FR⌝. - Proof. - iIntros "HFR Hfr". - iDestruct (own_valid_2 with "HFR Hfr") as %Hval. iPureIntro. - apply auth_both_valid_discrete in Hval as [??]. - by apply gset_disj_included. - Qed. - - Lemma update_free_roles rem FR fr1: - rem ⊆ fr1 -> - auth_free_roles_are FR -∗ - frag_free_roles_are fr1 ==∗ - auth_free_roles_are (FR ∖ rem) ∗ - frag_free_roles_are (fr1 ∖ rem). - Proof. - iIntros (?) "HFR Hfr1". - - iDestruct (free_roles_inclusion with "HFR Hfr1") as %Hincl. - - replace FR with ((FR ∖ rem) ∪ rem); last first. - { rewrite difference_union_L. set_solver. } - replace fr1 with ((fr1 ∖ rem) ∪ rem); last first. - { rewrite difference_union_L. set_solver. } - - iAssert (frag_free_roles_are (fr1 ∖ rem) ∗ frag_free_roles_are rem)%I with "[Hfr1]" as "[Hfr2 Hrem]". - { rewrite /frag_free_roles_are -own_op -auth_frag_op gset_disj_union //. set_solver. } - - iCombine "HFR Hrem" as "H". - iMod (own_update with "H") as "[??]" ; eauto. - - apply auth_update, gset_disj_dealloc_local_update. - - iModIntro. iFrame. iApply (own_proper with "Hfr2"). - do 2 f_equiv. set_solver. - Qed. - - Lemma model_agree s1 s2: - auth_model_is s1 -∗ frag_model_is s2 -∗ ⌜ s1 = s2 ⌝. - Proof. - iIntros "Ha Hf". - by iDestruct (own_valid_2 with "Ha Hf") as - %[Heq%Excl_included%leibniz_equiv ?]%auth_both_valid_discrete. - Qed. - - Lemma model_agree' δ1 s2 n: - model_state_interp n δ1 -∗ frag_model_is s2 -∗ ⌜ ls_under δ1 = s2 ⌝. - Proof. - iIntros "Hsi Hs2". iDestruct "Hsi" as (??) "(_&_&_&_&_&Hs1&_)". - iApply (model_agree with "Hs1 Hs2"). - Qed. - - Lemma update_fuel_delete ρ f F: - auth_fuel_is F -∗ ρ ↦F f ==∗ auth_fuel_is (delete ρ F). - Proof. - iIntros "Hafuel Hfuel". - iCombine "Hafuel Hfuel" as "H". - iMod (own_update with "H") as "H"; last first. - { iModIntro. iFrame. } - rewrite map_fmap_singleton fmap_delete. - eapply auth_update_dealloc. - apply delete_singleton_local_update. - typeclasses eauto. - Qed. - - Definition fuel_apply (fs' F: gmap (fmrole M) nat) (LR: gset (fmrole M)): - gmap (fmrole M) nat := - map_imap - (λ (ρ: fmrole M ) (fold : nat), - match decide (ρ ∈ dom fs') with - | left x => fs' !! ρ - | right _ => F !! ρ - end) (gset_to_gmap (0%nat) LR). - - Definition update_fuel_resource (δ1: LiveState Λ M) (fs1 fs2: gmap (fmrole M) nat) (s2: M): - gmap (fmrole M) nat := - - - fuel_apply fs2 (δ1.(ls_fuel (Λ := Λ))) (((dom $ ls_fuel δ1) ∪ dom fs2) ∖ (dom fs1 ∖ dom fs2)). - - Lemma elem_of_frame_excl_map - (fs F: gmap (fmrole M) nat) - (mf: gmap (fmrole M) (excl nat)) - (ρ: fmrole M) - (f: excl nat): - ✓ ((λ f : nat, Excl f) <$> F) -> - ((λ f : nat, Excl f) <$> F ≡ ((Excl <$> fs) ⋅? (Some mf))) -> - mf !! ρ = Some f -> - ρ ∈ dom F ∖ dom fs. - Proof. - intros Hval Heq Hlk. simpl in Heq. - specialize (Heq ρ). rewrite lookup_op Hlk !lookup_fmap in Heq. - destruct (decide (ρ ∈ dom F)) as [HF|HF]; last first. - { exfalso. apply not_elem_of_dom in HF. rewrite HF //= in Heq. - destruct (fs !! ρ) eqn:Hfs; inversion Heq as [A S D G Habs|A Habs]; - setoid_rewrite -> Hfs in Habs; by compute in Habs. } - destruct (decide (ρ ∈ dom fs)) as [Hfs|Hfs]. - { exfalso. apply elem_of_dom in Hfs as [f' Hlk']. - rewrite Hlk' /= in Heq. - suffices: Some f = None by eauto. - eapply exclusive_Some_l; last first. - - specialize (Hval ρ). rewrite -> lookup_fmap, Heq in Hval. - apply Hval. - - typeclasses eauto. } - set_solver. - Qed. - - Lemma update_fuel fs fs' F: - let LR := (dom F ∪ dom fs') ∖ (dom fs ∖ dom fs') in - (fs ≠ ∅) -> - (dom fs' ∖ dom fs ∩ dom F = ∅) -> - auth_fuel_is F -∗ - ([∗ map] ρ ↦ f ∈ fs, ρ ↦F f) ==∗ - auth_fuel_is (fuel_apply fs' F LR) ∗ - ([∗ map] ρ ↦ f ∈ fs', ρ ↦F f). - Proof. - iIntros (? Hnotemp Hdisj) "Hafuel Hfuel". - rewrite {1}/frag_fuel_is -big_opM_own //. - setoid_rewrite map_fmap_singleton. - rewrite -big_opM_auth_frag. - iCombine "Hafuel Hfuel" as "H". - iMod (own_update with "H") as "[A B]"; last first. - { iModIntro. - destruct (decide (fs' = ∅)) as [Heq|]; last first. - - rewrite {1}/frag_fuel_is -big_opM_own //. - iSplitL "A"; done. - - rewrite Heq. iSplitL "A"; first done. done. } - - simpl. - setoid_rewrite map_fmap_singleton. - rewrite -big_opM_auth_frag. - - simpl. - apply auth_update. - - apply local_update_discrete. - - intros mf Hval Heq. - split. - { intros ρ. rewrite /fuel_apply lookup_fmap map_lookup_imap. - rewrite lookup_gset_to_gmap. - destruct (decide (ρ ∈ LR)). - - rewrite option_guard_True //=. - destruct (decide (ρ ∈ dom fs')) as [Hd|Hd]. - + rewrite decide_True //=. apply elem_of_dom in Hd as [? Hsome]. - rewrite Hsome //. - + rewrite decide_False //= -lookup_fmap. apply (Hval ρ). - - rewrite option_guard_False //=. } - - intros ρ. rewrite /fuel_apply lookup_fmap map_lookup_imap. - rewrite lookup_gset_to_gmap. - rewrite -big_opM_fmap big_opM_singletons. - rewrite <-big_opM_fmap in Heq. setoid_rewrite big_opM_singletons in Heq. - destruct (decide (ρ ∈ LR)). - - rewrite option_guard_True //=. - destruct (decide (ρ ∈ dom fs')) as [Hd'|Hd']. - + rewrite decide_True //=. apply elem_of_dom in Hd' as [? Hsome]. - rewrite Hsome //= lookup_opM. - rewrite lookup_fmap Hsome. - destruct mf as [mf|]; simpl; last done. - destruct (mf !! ρ) as [f|] eqn:Hlk; rewrite Hlk //. - - assert (ρ ∈ dom F ∖ dom fs). - { eauto using elem_of_frame_excl_map. } - assert (ρ ∈ dom fs'). - { apply elem_of_dom. eauto. } - set_solver. - + rewrite decide_False //= -lookup_fmap. - rewrite Heq. - destruct (decide (ρ ∈ dom fs)) as [Hd|Hd]; - first set_solver. - pose proof Hd as Hd2. pose proof Hd' as Hd'2. - apply not_elem_of_dom in Hd2, Hd'2. rewrite !lookup_opM !lookup_fmap Hd2 Hd'2 //. - - rewrite option_guard_False //=. - rewrite lookup_opM lookup_fmap. - destruct mf as [mf|]; simpl. - + destruct (mf !! ρ) as [f|] eqn:Hlk; rewrite Hlk //. - * assert (ρ ∈ dom F ∖ dom fs). - { eauto using elem_of_frame_excl_map. } - set_solver. - * assert (Hnotin: ρ ∉ dom fs') by set_solver. - apply not_elem_of_dom in Hnotin. rewrite Hnotin //. - + assert (Hnotin: ρ ∉ dom fs') by set_solver. - apply not_elem_of_dom in Hnotin. rewrite Hnotin //. - Qed. - - Lemma update_mapping ζ (R' : gset $ fmrole M) (R: gset (fmrole M)) m : - auth_mapping_is m -∗ ζ ↦M R ==∗ auth_mapping_is (<[ ζ := R' ]> m) ∗ ζ ↦M R'. - Proof. - iIntros "Hamap Hmap". - iCombine "Hamap Hmap" as "H". - iMod (own_update with "H") as "[A B]"; last first. - { iModIntro. iSplitL "A"; iFrame. } - rewrite !map_fmap_singleton fmap_insert. - eapply auth_update, singleton_local_update_any. - intros. by apply exclusive_local_update. - Qed. - - Lemma mapping_lookup ζ m R: - auth_mapping_is m -∗ ζ ↦M R -∗ ⌜ ζ ∈ dom m ⌝. - Proof. - unfold auth_mapping_is, frag_mapping_is. - iIntros "Ham Hm". - iCombine "Ham Hm" as "H". - iDestruct (own_valid with "H") as %Hval. iPureIntro. - apply auth_both_valid_discrete in Hval as [Hval ?]. - rewrite map_fmap_singleton in Hval. - apply singleton_included_exclusive_l in Hval =>//; last by typeclasses eauto. - rewrite -> lookup_fmap, leibniz_equiv_iff in Hval. - apply fmap_Some_1 in Hval as (f'&Hfuelρ&?). simplify_eq. - apply elem_of_dom. eauto. - Qed. - - Lemma update_mapping_new_locale ζ ζ' (R R1 R2 : gset $ fmrole M) m : - ζ' ∉ dom m -> - auth_mapping_is m -∗ - ζ ↦M R ==∗ - auth_mapping_is (<[ ζ' := R2]> (<[ ζ := R1 ]> m)) ∗ - ζ ↦M R1 ∗ ζ' ↦M R2. - Proof. - iIntros (Hnotin) "Hamap Hmap". - iDestruct (mapping_lookup with "Hamap Hmap") as %Hin. - iCombine "Hamap Hmap" as "H". - iMod (own_update (A := (authUR (gmapUR _ (exclR (gsetR (RoleO M)))))) _ _ ( - ● ((λ f : gset (fmrole M), Excl f) <$> ((<[ ζ := R1 ]> m))) - ⋅ ◯ ((λ f : gset (fmrole M), Excl f) <$> {[ζ := R1]}) - ) with "H") as "[A B]". - { rewrite !map_fmap_singleton fmap_insert. - eapply auth_update. eapply singleton_local_update_any. - intros. by apply exclusive_local_update. } - iCombine "A B" as "H". - iMod (own_update (A := (authUR (gmapUR _ (exclR (gsetR (RoleO M)))))) _ _ ( - ● ((λ f : gset (fmrole M), Excl f) <$> (<[ ζ' := R2]> (<[ ζ := R1 ]> m))) - ⋅ ◯ ((λ f : gset (fmrole M), Excl f) <$> {[ζ := R1 ; ζ' := R2]}) - ) with "H") as "[A B]"; last first. - { iModIntro. iSplitL "A"; first iFrame. rewrite !fmap_insert fmap_empty insert_empty. - replace (◯ {[ζ := Excl R1; ζ' := Excl R2]}) with (◯ {[ζ := Excl R1]} ⋅ ◯ {[ζ' := Excl R2]}). - - iDestruct "B" as "[A B]". iSplitL "A"; rewrite /frag_mapping_is map_fmap_singleton //. - - rewrite -auth_frag_op insert_singleton_op //. rewrite lookup_singleton_ne //. set_solver. } - rewrite !map_fmap_singleton fmap_insert !fmap_insert. - rewrite (insert_commute _ _ _ (Excl R1) (Excl R2)); last set_solver. - eapply auth_update. rewrite fmap_empty. eapply alloc_local_update; eauto. - - rewrite lookup_insert_ne; last set_solver. apply not_elem_of_dom. set_solver. - - done. - Qed. - - Lemma update_mapping_delete ζ (Rrem : gset $ fmrole M) (R: gset (fmrole M)) m : - auth_mapping_is m -∗ ζ ↦M R ==∗ auth_mapping_is (<[ ζ := R ∖ Rrem ]> m) ∗ ζ ↦M (R ∖ Rrem). - Proof. - eauto using update_mapping. - Qed. - - Lemma update_mapping_add ζ (Radd : gset $ fmrole M) (R: gset (fmrole M)) m : - auth_mapping_is m -∗ ζ ↦M R ==∗ auth_mapping_is (<[ ζ := R ∪ Radd ]> m) ∗ ζ ↦M (R ∪ Radd). - Proof. - eauto using update_mapping. - Qed. - - Lemma has_fuels_equiv fs ζ: - has_fuels ζ fs ⊣⊢ ζ ↦M (dom fs) ∗ ([∗ map] ρ ↦ f ∈ fs, ρ ↦F f). - Proof. - rewrite /has_fuels -big_opM_dom. iSplit. - - iIntros "($ & H)". iApply (big_sepM_impl with "H"). - iIntros "!#" (ρ f Hin) "(%f' & %Hin' & ?)". - by simplify_eq. - - iIntros "($&H)". - iApply (big_sepM_impl with "H"). - iIntros "!#" (ρ f Hin) "?". iExists f. iSplit; done. - Qed. - - Lemma update_has_fuels ζ fs fs' F m : - let LR := (dom F ∪ dom fs') ∖ (dom fs ∖ dom fs') in - (fs ≠ ∅) -> - (dom fs' ∖ dom fs ∩ dom F = ∅) -> - has_fuels ζ fs -∗ - auth_fuel_is F -∗ - auth_mapping_is m ==∗ - auth_fuel_is (fuel_apply fs' F LR) ∗ - has_fuels ζ fs' ∗ - auth_mapping_is (<[ ζ := dom fs' ]> m). - Proof. - iIntros (LR Hfs Hdom) "Hfuels Hafuels Hamapping". - rewrite !has_fuels_equiv. iDestruct "Hfuels" as "[Hmapping Hfuels]". - iMod (update_fuel with "Hafuels Hfuels") as "[Hafuels Hfuels]" =>//. - iMod (update_mapping with "Hamapping Hmapping") as "[Hamapping Hmapping]". - iModIntro. - iFrame. - Qed. - - Lemma update_has_fuels_no_step ζ fs fs' F m : - let LR := (dom F ∪ dom fs') ∖ (dom fs ∖ dom fs') in - (fs ≠ ∅) -> - (dom fs' ⊆ dom fs) -> - has_fuels ζ fs -∗ - auth_fuel_is F -∗ - auth_mapping_is m ==∗ - auth_fuel_is (fuel_apply fs' F LR) ∗ - has_fuels ζ fs' ∗ - auth_mapping_is (<[ ζ := dom fs' ]> m). - Proof. - iIntros (LR Hfs Hdom) "Hfuels Hafuels Hamapping". - rewrite !has_fuels_equiv. iDestruct "Hfuels" as "[Hmapping Hfuels]". - iMod (update_fuel fs fs' with "Hafuels Hfuels") as "[Hafuels Hfuels]"; [done|set_solver|]. - iMod (update_mapping with "Hamapping Hmapping") as "[Hamapping Hmapping]". - iModIntro. iFrame. - Qed. - - Lemma update_has_fuels_no_step_no_change ζ fs fs' F m : - let LR := (dom F ∪ dom fs') ∖ (dom fs ∖ dom fs') in - (fs ≠ ∅) -> - (dom fs' = dom fs) -> - has_fuels ζ fs -∗ - auth_fuel_is F -∗ - auth_mapping_is m ==∗ - auth_fuel_is (fuel_apply fs' F LR) ∗ - has_fuels ζ fs' ∗ - auth_mapping_is m. - Proof. - iIntros (LR Hfs Hdom) "Hfuels Hafuels Hamapping". - rewrite !has_fuels_equiv. iDestruct "Hfuels" as "[Hmapping Hfuels]". - iMod (update_fuel fs fs' with "Hafuels Hfuels") as "[Hafuels Hfuels]" =>//. - { rewrite Hdom. set_solver. } - iModIntro. - iFrame. rewrite Hdom //. - Qed. - - Lemma has_fuel_in ζ δ fs n: - has_fuels ζ fs -∗ model_state_interp n δ -∗ ⌜ ∀ ρ, ls_mapping δ !! ρ = Some ζ <-> ρ ∈ dom fs ⌝. - Proof. - unfold model_state_interp, has_fuels, auth_mapping_is, frag_mapping_is. - iIntros "[Hζ Hfuels] (%m&%FR&Hafuel&Hamapping &HFR&%Hmapinv&Hamod&Hfr) %ρ". - iCombine "Hamapping Hζ" as "H". - iDestruct (own_valid with "H") as %Hval. iPureIntro. - apply auth_both_valid_discrete in Hval as [Hval ?]. - rewrite map_fmap_singleton in Hval. - apply singleton_included_exclusive_l in Hval =>//; last by typeclasses eauto. - rewrite -> lookup_fmap, leibniz_equiv_iff in Hval. - apply fmap_Some_1 in Hval as (R'&HMζ&?). simplify_eq. - rewrite (Hmapinv ρ ζ) HMζ. split. - - intros (?&?&?). by simplify_eq. - - intros ?. eexists. split; eauto. - Qed. - - Lemma has_fuel_fuel ζ δ fs n: - has_fuels ζ fs -∗ model_state_interp n δ -∗ - ⌜ ∀ ρ, ρ ∈ dom fs -> ls_fuel δ !! ρ = fs !! ρ ⌝. - Proof. - unfold has_fuels, model_state_interp, auth_fuel_is. - iIntros "[Hζ Hfuels] (%m&%FR&Hafuel&Hamapping&HFR&%Hmapinv&Hamod)" (ρ Hρ). - iDestruct (big_sepS_delete _ _ ρ with "Hfuels") as "[(%f&%Hfs&Hfuel) _]" =>//. - iCombine "Hafuel Hfuel" as "H". - iDestruct (own_valid with "H") as %Hval. iPureIntro. - apply auth_both_valid_discrete in Hval as [Hval ?]. - rewrite map_fmap_singleton in Hval. - apply singleton_included_exclusive_l in Hval =>//; last by typeclasses eauto. - rewrite -> lookup_fmap, leibniz_equiv_iff in Hval. - apply fmap_Some_1 in Hval as (f'&Hfuelρ&?). simplify_eq. - rewrite Hfuelρ Hfs //. - Qed. - - Lemma update_no_step_enough_fuel extr (auxtr : auxiliary_trace LM) rem c2 fs ζ: - (dom fs ≠ ∅) -> - (live_roles _ (trace_last auxtr)) ∩ rem = ∅ → - rem ⊆ dom fs → - locale_step (trace_last extr) (Some ζ) c2 -> - has_fuels_S ζ fs -∗ model_state_interp (trace_last extr).1 (trace_last auxtr) - ==∗ ∃ δ2 (ℓ : mlabel LM), - ⌜labels_match (LM:=LM) (Some ζ) ℓ - ∧ valid_state_evolution_fairness (extr :tr[Some ζ]: c2) (auxtr :tr[ℓ]: δ2)⌝ - ∗ has_fuels ζ (fs ⇂ (dom fs ∖ rem)) ∗ model_state_interp c2.1 δ2. - Proof. - iIntros "%HnotO %Holdroles %Hincl %Hstep Hf Hmod". - destruct c2 as [tp2 σ2]. - destruct (set_choose_L _ HnotO) as [??]. - iDestruct (has_fuel_in with "Hf Hmod") as %Hxdom; eauto. - iDestruct (has_fuel_fuel with "Hf Hmod") as "%Hfuel"; eauto. - iDestruct (model_state_interp_tids_smaller with "Hmod") as %Hζs. - iDestruct "Hmod" as "(%m & %FR & Hfuel & Hamapping & HFR & %Hminv & %Hlocssmall & Hmodel & %HFR)". - unfold has_fuels_S. - simpl in *. - - set new_dom := ((dom (ls_fuel (trace_last auxtr)) ∪ dom fs) ∖ rem). - set new_mapping := ls_mapping (trace_last auxtr) ⇂ new_dom. - - assert (dom (fuel_apply (filter (λ '(k, _), k ∈ dom fs ∖ rem) fs) (ls_fuel (trace_last auxtr)) - ((dom (ls_fuel (trace_last auxtr)) ∪ dom fs) ∖ rem)) = new_dom) as Hnewdom. - { rewrite /fuel_apply map_imap_dom_eq ?dom_gset_to_gmap //. - intros ρ0 _ Hindom. - case_decide as Hninf; [by apply elem_of_dom|]. - apply elem_of_difference in Hindom as [Hin1 ?]. - apply elem_of_union in Hin1 as [?|Hin2]; first by apply elem_of_dom. - exfalso. apply Hninf. apply elem_of_dom in Hin2 as [f ?]. - eapply elem_of_dom_2. rewrite map_filter_lookup_Some. split =>//. - apply elem_of_difference; split =>//. by eapply elem_of_dom_2. } - - assert (Hsamedoms: dom new_mapping = - dom (fuel_apply (fs ⇂ (dom fs ∖ rem)) - (ls_fuel (trace_last auxtr)) - ((dom (ls_fuel (trace_last auxtr)) ∪ dom fs) ∖ rem))). - { rewrite /new_mapping /new_dom. unfold fuel_apply. - assert (dom fs ⊆ dom (trace_last auxtr).(ls_fuel)) as Hdom_le. - { intros ρ Hin. rewrite elem_of_dom Hfuel; last set_solver. - apply elem_of_dom in Hin as [? Hin]. rewrite lookup_fmap Hin //=. } - rewrite map_imap_dom_eq; last first. - { intros ρ _ Hin. rewrite dom_gset_to_gmap in Hin. - case_decide; [by apply elem_of_dom|]. - apply elem_of_dom. set_solver +Hin Hdom_le. } - rewrite dom_domain_restrict ?dom_gset_to_gmap ?ls_same_doms //. - set_solver +Hdom_le. } - assert (Hfueldom: live_roles _ (trace_last auxtr) ⊆ - dom (fuel_apply (fs ⇂ (dom fs ∖ rem)) - (ls_fuel (trace_last auxtr)) - ((dom (ls_fuel (trace_last auxtr)) ∪ dom fs) ∖ rem))). - { rewrite /fuel_apply Hnewdom. - intros ρ Hin. apply elem_of_difference; split; - [apply ls_fuel_dom in Hin; set_solver +Hin| - set_solver -Hlocssmall Hnewdom Hsamedoms]. } - iMod (update_has_fuels_no_step ζ (S <$> fs) (fs ⇂ (dom fs ∖ rem)) with "[Hf] [Hfuel] [Hamapping]") as "(Hafuels&Hfuels&Hamapping)" =>//. - { rewrite -dom_empty_iff_L. set_solver -Hnewdom Hsamedoms Hfueldom. } - { rewrite dom_domain_restrict; set_solver -Hnewdom Hsamedoms Hfueldom. } - iModIntro. - iExists {| - ls_under := (trace_last auxtr).(ls_under); - ls_fuel := _; - ls_fuel_dom := Hfueldom; - ls_same_doms := Hsamedoms; - |}. - iExists (Silent_step ζ). simpl. - iSplit; last first. - { rewrite (dom_fmap_L _ fs). iFrame "Hfuels". iExists _, FR. rewrite /maps_inverse_match //=. iFrame. - assert (dom fs ⊆ dom (ls_fuel $ trace_last auxtr)). - { intros ρ Hin. setoid_rewrite dom_fmap in Hxdom. - specialize (Hxdom ρ). rewrite -ls_same_doms. apply elem_of_dom. exists ζ. - by apply Hxdom. } - iSplit. - { iApply (auth_fuel_is_proper with "Hafuels"). f_equiv. - rewrite dom_domain_restrict; last set_solver -Hnewdom Hsamedoms Hfueldom. - replace (dom fs ∖ (dom fs ∖ rem)) with rem; [set_solver +|]. - rewrite -leibniz_equiv_iff. intros ρ. split; [set_solver -Hnewdom Hsamedoms Hfueldom|]. - intros [? [?|?]%not_elem_of_difference]%elem_of_difference =>//. } - iPureIntro. split; last split. - - intros ρ ζ'. rewrite /new_mapping dom_domain_restrict; last set_solver +. split. - + intros [Hlk Hin]%map_filter_lookup_Some. destruct (decide (ζ' = ζ)) as [->|Hneq]. - * rewrite lookup_insert. eexists; split=>//. set_solver -Hnewdom Hsamedoms Hfueldom. - * rewrite lookup_insert_ne //. by apply Hminv. - + intros Hin. destruct (decide (ζ' = ζ)) as [->|Hneq]. - * rewrite lookup_insert in Hin. apply map_filter_lookup_Some. - destruct Hin as (?&?&?). simplify_eq. split; last set_solver -Hnewdom Hsamedoms Hfueldom. - apply Hxdom. rewrite dom_fmap. set_solver -Hnewdom Hsamedoms Hfueldom. - * rewrite lookup_insert_ne // -Hminv in Hin. apply map_filter_lookup_Some; split=>//. - rewrite /new_dom. apply elem_of_difference; split. - ** apply elem_of_dom_2 in Hin. rewrite ls_same_doms in Hin. set_solver -Hnewdom Hsamedoms Hfueldom. - ** assert (ρ ∉ dom fs); last set_solver -Hnewdom Hsamedoms Hfueldom. - rewrite dom_fmap_L in Hxdom. - intros contra%Hxdom. congruence. - - intros ζ0 Hnotin. apply lookup_insert_None; split. - + apply Hlocssmall. - destruct (trace_last extr). - have Hle := locales_of_list_step_incl _ _ _ _ _ Hstep. simpl. - clear -Hnotin Hle. set_solver. - + intros <-. destruct (trace_last extr). - have ? := locales_of_list_step_incl _ _ _ _ _ Hstep. simpl. - clear Hfueldom Hsamedoms. inversion Hstep. simplify_eq. - assert (locale_of t1 e1 ∈ locales_of_list (t1 ++ e1 :: t2)); - last by eauto. - apply locales_of_list_from_locale_from. - rewrite from_locale_from_Some //. - eapply prefixes_from_spec. - eexists _,_. by list_simplifier. - - rewrite Hnewdom /new_dom. apply elem_of_equiv_empty_L. intros ρ [Hin1 Hin2]%elem_of_intersection. - assert (ρ ∈ dom (ls_fuel (trace_last auxtr))) - by set_solver -Hnewdom Hsamedoms Hfueldom. - set_solver -Hnewdom Hsamedoms Hfueldom. } - iPureIntro. - do 2 split; first done. split; [split; [|split; [|split; [|split]]]|] =>//. - - eexists. apply Hxdom. by rewrite dom_fmap. - - unfold fuel_decr. simpl. - intros ρ' Hin Hin' Hmustdec. - rewrite Hnewdom in Hin'. - - inversion Hmustdec; simplify_eq. - + have Hinfs: ρ' ∈ dom (S <$> fs) by set_solver. - rewrite map_lookup_imap Hfuel // lookup_fmap. rewrite dom_fmap in Hinfs. - rewrite lookup_gset_to_gmap option_guard_True //=. - - pose proof Hinfs as Hinfs'. apply elem_of_dom in Hinfs' as [f Heqf]. - assert (filter (λ '(k, _), k ∈ dom fs ∖ rem) fs !! ρ' = Some f) as Heqfilter. - { rewrite map_filter_lookup Heqf /= option_guard_True //. set_solver -Hnewdom Hsamedoms Hfueldom Hmustdec. } - rewrite decide_True // ?Heqfilter ?lookup_fmap ?Heqf /=; last by eapply elem_of_dom_2. lia. - + rewrite /= /new_mapping map_filter_lookup in Hneqtid. - pose proof Hin as Hin2. rewrite -ls_same_doms in Hin2. apply elem_of_dom in Hin2 as [f Hf]. - rewrite Hf /= option_guard_True // in Hneqtid. - - intros ρ' Hin _. simpl. destruct (decide (ρ' ∈ rem)) as [Hin'|Hnin']. - + right; split; last set_solver -Hnewdom Hsamedoms Hfueldom. - rewrite /fuel_apply map_imap_dom_eq ?dom_gset_to_gmap; first set_solver. - intros ρ0 _ Hin0. - case_decide as Hnin; [by apply elem_of_dom|]. - apply elem_of_difference in Hin0 as [Hin1 ?]. - apply elem_of_union in Hin1 as [?|Hin2]; first by apply elem_of_dom. - exfalso. apply Hnin. apply elem_of_dom in Hin2 as [f ?]. - eapply elem_of_dom_2. rewrite map_filter_lookup_Some. split =>//. - apply elem_of_difference; split =>//. by eapply elem_of_dom_2. - + left. rewrite map_lookup_imap lookup_gset_to_gmap option_guard_True //=; - last set_solver -Hnewdom Hsamedoms Hfueldom. - apply elem_of_dom in Hin as [f Hf]. - case_decide as Hin; [|by rewrite !Hf //=]. - apply elem_of_dom in Hin as [f' Hf']. rewrite Hf'. - apply map_filter_lookup_Some in Hf' as [Hfs Hf']. - rewrite Hfuel ?lookup_fmap ?Hfs /=; [lia |]. - rewrite dom_fmap; set_solver -Hnewdom Hsamedoms Hfueldom. - - rewrite Hnewdom. assert (dom fs ⊆ dom $ ls_fuel (trace_last auxtr)); - last set_solver -Hnewdom Hsamedoms Hfueldom. - intros ρ Hin. apply elem_of_dom. - rewrite Hfuel ?dom_fmap // -elem_of_dom dom_fmap //. - - unfold tids_smaller; simpl. intros ρ ζ0 Hin. - destruct (trace_last extr); destruct (trace_last extr). - eapply from_locale_step =>//. - rewrite /tids_smaller /= in Hζs. eapply Hζs. - rewrite /new_mapping map_filter_lookup_Some in Hin. - by destruct Hin. - Qed. - - Lemma update_fork_split R1 R2 tp1 tp2 fs (extr : execution_trace Λ) - (auxtr: auxiliary_trace LM) ζ efork σ1 σ2 (Hdisj: R1 ## R2): - fs ≠ ∅ -> - R1 ∪ R2 = dom fs -> - trace_last extr = (tp1, σ1) -> - locale_step (tp1, σ1) (Some ζ) (tp2, σ2) -> - (∃ tp1', tp2 = tp1' ++ [efork] ∧ length tp1' = length tp1) -> - has_fuels_S ζ fs -∗ model_state_interp (trace_last extr).1 (trace_last auxtr) ==∗ - ∃ δ2, has_fuels (locale_of tp1 efork) (fs ⇂ R2) ∗ has_fuels ζ (fs ⇂ R1) ∗ model_state_interp tp2 δ2 - ∧ ⌜valid_state_evolution_fairness (extr :tr[Some ζ]: (tp2, σ2)) (auxtr :tr[Silent_step ζ]: δ2)⌝. - Proof. - iIntros (Hnemp Hunioneq -> Hstep Htlen) "Hf Hmod". - unfold has_fuels_S. - simpl in *. - iDestruct (has_fuel_fuel with "Hf Hmod") as %Hfuels. - iDestruct (model_state_interp_tids_smaller with "Hmod") as %Hts. - iDestruct "Hmod" as (m FR) "(Haf&Ham&HFR&%Hminv&%Hsmall&Hamod&%HFR)". - pose Hlocincl := locales_of_list_step_incl _ _ _ _ _ Hstep. - iMod (update_has_fuels_no_step_no_change ζ (S <$> fs) fs with "Hf Haf Ham") as "(Haf&Hf&Ham)". - { intros contra. apply fmap_empty_inv in contra. set_solver. } - { rewrite dom_fmap_L //. } - iDestruct "Hf" as "(Hf & Hfuels)". - iDestruct (frag_mapping_same with "Ham Hf") as %Hmapping. - assert (Hnewζ: (locale_of tp1 efork) ∉ dom m). - { apply not_elem_of_dom. apply Hsmall. - unfold tids_smaller in Hsmall. - rewrite elem_of_list_fmap. intros ([??]&Hloc&Hin). - symmetry in Hloc. - rewrite -> prefixes_from_spec in Hin. - destruct Hin as (?&t0&?&?). - simplify_eq. list_simplifier. - eapply locale_injective=>//. - apply prefixes_from_spec. - exists t0, []. split =>//. by list_simplifier. } - iMod (update_mapping_new_locale ζ (locale_of tp1 efork) _ R1 R2 with "Ham Hf") as "(Ham&HR1&HR2)"; eauto. - pose δ1 := trace_last auxtr. - assert (Hsamedoms: dom (map_imap - (λ ρ o, - if decide (ρ ∈ R2) then Some $ locale_of tp1 efork else Some o) - (ls_mapping δ1)) = - dom (map_imap - (λ ρ o, - if decide (ρ ∈ R1 ∪ R2) then Some (o - 1)%nat else Some o) - (ls_fuel δ1)) - ). - { rewrite !map_imap_dom_eq; first by rewrite ls_same_doms. - - by intros ρ??; destruct (decide (ρ ∈ R1 ∪ R2)). - - by intros ρ??; destruct (decide (ρ ∈ R2)). } - assert (Hfueldom: live_roles _ δ1 ⊆ dom (map_imap - (λ ρ o, - if decide (ρ ∈ R1 ∪ R2) then Some (o - 1)%nat else Some o) - (ls_fuel δ1))). - { rewrite map_imap_dom_eq; first by apply ls_fuel_dom. - - by intros ρ??; destruct (decide (ρ ∈ R1 ∪ R2)). } - iExists {| - ls_under := δ1.(ls_under); - ls_fuel := _; - ls_fuel_dom := Hfueldom; - ls_mapping := _; - ls_same_doms := Hsamedoms; - |}. - iModIntro. - assert (Hdomincl: dom fs ⊆ dom (ls_fuel δ1)). - { intros ρ' Hin'. rewrite elem_of_dom Hfuels; last first. - { rewrite dom_fmap_L //. } - rewrite lookup_fmap fmap_is_Some. by apply elem_of_dom. } - rewrite -Hunioneq big_sepS_union //. iDestruct "Hfuels" as "[Hf1 Hf2]". - iSplitL "Hf2 HR2". - { unfold has_fuels. - rewrite dom_domain_restrict; - [|set_solver -Hsamedoms Hsamedoms Hfueldom Hlocincl Hdomincl]. - iFrame. - iApply (big_sepS_impl with "Hf2"). iIntros "!#" (x Hin) "(%f&%&?)". - iExists _; iFrame. iPureIntro. rewrite map_filter_lookup_Some //. } - iSplitL "Hf1 HR1". - { unfold has_fuels. - rewrite dom_domain_restrict; - [|set_solver -Hsamedoms Hsamedoms Hfueldom Hlocincl Hdomincl]. - iFrame. - iApply (big_sepS_impl with "Hf1"). iIntros "!#" (x Hin) "(%f&%&?)". - iExists _; iFrame. iPureIntro. rewrite map_filter_lookup_Some //. } - iSplitL "Ham Haf Hamod HFR". - { iExists _, FR; simpl. iFrame "Ham Hamod HFR". - iSplit. - - iApply (auth_fuel_is_proper with "Haf"). unfold fuel_apply. - rewrite -leibniz_equiv_iff. intros ρ. rewrite !map_lookup_imap. - rewrite Hunioneq dom_fmap_L difference_diag_L difference_empty_L. - rewrite lookup_gset_to_gmap. - destruct (decide (ρ ∈ dom (ls_fuel δ1) ∪ dom fs)) as [Hin|Hin]. - + rewrite option_guard_True //=. - assert (Hmap: ρ ∈ dom (ls_fuel δ1)). - { set_unfold. naive_solver. } - destruct (decide (ρ ∈ dom fs)) as [Hinfs|Hinfs]. - * apply elem_of_dom in Hmap as [? Hinfuels]. rewrite Hinfuels /=. - rewrite Hfuels in Hinfuels; last set_solver. - rewrite lookup_fmap in Hinfuels. - rewrite leibniz_equiv_iff. - rewrite -lookup_fmap in Hinfuels. - rewrite lookup_fmap_Some in Hinfuels. - destruct Hinfuels as [y [<- Hinfuels]]. - rewrite Hinfuels. f_equiv. lia. - * apply elem_of_dom in Hmap as [? Hinfuels]. - rewrite Hinfuels //. - + rewrite option_guard_False //=. - rewrite -> not_elem_of_union in Hin. destruct Hin as [Hin ?]. - rewrite -> not_elem_of_dom in Hin. rewrite Hin //. - - iPureIntro. split; first last; [split|]. - { intros ζ' Hζ'. rewrite lookup_insert_ne; last first. - { pose proof (locales_of_list_step_incl _ _ _ _ _ Hstep). - clear Hfueldom Hsamedoms. - assert (ζ' ∉ locales_of_list tp1) by eauto. - intros contra. simplify_eq. - destruct Htlen as [tp1' [-> Hlen]]. - inversion Hstep as [? ? e1 ? e2 ? efs t1 t2 Hf1 YY Hprimstep |]. - simplify_eq. - assert (efs = [efork]) as ->. - { symmetry. assert (length tp1' = length (t1 ++ e2 :: t2)). - rewrite app_length //=; rewrite app_length //= in Hlen. - clear Hlen. eapply app_inj_1 =>//. by list_simplifier. } - rewrite H2 in Hζ'. - apply Hζ'. apply elem_of_list_fmap. - eexists (t1 ++ e2 :: t2, _); split =>//. - - erewrite locale_equiv =>//. apply locales_equiv_middle. - eapply locale_step_preserve => //. - - replace (t1 ++ e2 :: t2 ++ [efork]) with ((t1 ++ e2 :: t2) ++ [efork]); last by list_simplifier. - rewrite prefixes_from_app. set_unfold; naive_solver. } - rewrite lookup_insert_ne; last first. - { intros <-. rewrite Hsmall in Hmapping; [congruence | naive_solver]. } - apply Hsmall; set_unfold; naive_solver. } - { rewrite map_imap_dom_eq // => ρ f Hin. by destruct (decide (ρ ∈ R1 ∪ R2)). } - intros ρ ζ'. rewrite map_lookup_imap. - destruct (decide (ρ ∈ dom (ls_mapping δ1))) as [Hin|Hin]. - + apply elem_of_dom in Hin as [ζ'' Hρ]. rewrite Hρ. simpl. - destruct (decide (ρ ∈ R2)) as [Hin'|Hin']. - * split. - -- intros. simplify_eq. rewrite lookup_insert. eauto. - -- intros (ks & Hlk & H'). destruct (decide (ζ' = locale_of tp1 efork)); first congruence. - rewrite lookup_insert_ne // in Hlk. exfalso. - assert (ρ ∈ dom fs). - { set_unfold. naive_solver. } - destruct (decide (ζ = ζ')); simplify_eq. - ** rewrite lookup_insert in Hlk. set_unfold. naive_solver. - ** rewrite lookup_insert_ne // in Hlk. - assert (ζ = ζ'); last done. - { eapply (maps_inverse_bij _ _ _ _ ks); eauto. } - * split. - -- intros ?. simplify_eq. specialize (Hminv ρ ζ'). - apply Hminv in Hρ as (?&?&?). - destruct (decide (ζ' = locale_of tp1 efork)). - { simplify_eq. apply not_elem_of_dom in Hnewζ. - simpl in Hnewζ. rewrite -> Hnewζ in *. congruence. } - destruct (decide (ζ' = ζ)). - { simplify_eq. assert (ρ ∈ R1); first set_solver. - exists R1. rewrite lookup_insert_ne // lookup_insert //. } - rewrite lookup_insert_ne // lookup_insert_ne //. eauto. - -- intros (ks&Hin&?). - destruct (decide (ζ' = locale_of tp1 efork)). - { simplify_eq. rewrite lookup_insert in Hin. set_solver. } - rewrite lookup_insert_ne // in Hin. - destruct (decide (ζ' = ζ)). - { simplify_eq. rewrite lookup_insert // in Hin. - f_equal. simplify_eq. - assert (ls_mapping δ1 !! ρ = Some ζ). - { eapply Hminv. eexists _. split; eauto. set_unfold; naive_solver. } - congruence. } - rewrite lookup_insert_ne // in Hin. - assert (ls_mapping δ1 !! ρ = Some ζ'). - { eapply Hminv. eexists _. split; eauto. } - congruence. - + apply not_elem_of_dom in Hin. rewrite Hin /=. split; first done. - intros (?&Hin'&?). rewrite -ls_same_doms in Hdomincl. - apply not_elem_of_dom in Hin. - destruct (decide (ζ' = locale_of tp1 efork)). - { simplify_eq. rewrite lookup_insert in Hin'. simplify_eq. - set_unfold; naive_solver. } - rewrite lookup_insert_ne // in Hin'. - destruct (decide (ζ' = ζ)). - { simplify_eq. rewrite lookup_insert // in Hin'. simplify_eq. - set_unfold; naive_solver. } - rewrite lookup_insert_ne // in Hin'. - assert (ls_mapping δ1 !! ρ = Some ζ'). - { eapply Hminv. eauto. } - apply not_elem_of_dom in Hin. congruence. } - iSplit; first done. - iSplit; last first. - { iPureIntro. intros ρ ζ'. simpl. rewrite map_lookup_imap. - destruct (ls_mapping δ1 !!ρ) eqn:Heq; last done. simpl. - destruct (decide (ρ ∈ R2)); first (intros ?; simplify_eq). - - destruct Htlen as [tp1' [-> Hlen]]. - inversion Hstep as [? ? e1 ? e2 ? efs t1 t2 Hf1 YY Hprimstep |]. simplify_eq. - assert (efs = [efork]) as ->. - { symmetry. assert (length tp1' = length (t1 ++ e2 :: t2)). - rewrite app_length //=; rewrite app_length //= in Hlen. - clear Hlen. eapply app_inj_1 =>//. by list_simplifier. } - assert (is_Some (from_locale (t1 ++ e1 :: t2 ++ [efork]) (locale_of (t1 ++ e1 :: t2) efork))). - + unfold from_locale. erewrite from_locale_from_Some; eauto. - apply prefixes_from_spec. list_simplifier. eexists _, []. split=>//. - by list_simplifier. - + eapply from_locale_from_equiv =>//; [constructor |]. rewrite H0. - replace (t1 ++ e1 :: t2 ++ [efork]) with ((t1 ++ e1 :: t2) ++ [efork]); - last by list_simplifier. - replace (t1 ++ e2 :: t2 ++ [efork]) with ((t1 ++ e2 :: t2) ++ [efork]); - last by list_simplifier. - assert (locales_equiv (t1 ++ e1 :: t2) (t1 ++ e2 :: t2)). - { apply locales_equiv_middle. eapply locale_step_preserve =>//. } - apply locales_equiv_from_app =>//. by eapply locales_equiv_from_refl. - - intros ?; simplify_eq. - assert (is_Some (from_locale tp1 ζ')) by eauto. - eapply from_locale_step =>//. } - iSplit. - { iPureIntro. destruct (map_choose _ Hnemp) as [ρ[??]]. exists ρ. - apply Hminv. eexists _. split; eauto. apply elem_of_dom. eauto. } - iSplit. - { iPureIntro. intros ρ Hlive Hlive' Hmd. simpl. inversion Hmd; simplify_eq. - - rewrite map_lookup_imap. - assert (Hin: ρ ∈ dom (ls_fuel δ1)). - { rewrite -ls_same_doms elem_of_dom. eauto. } - apply elem_of_dom in Hin. destruct Hin as [f' Hin']. - rewrite Hin' /=. - destruct (decide (ρ ∈ R1 ∪ R2)) as [Hin''|Hin'']. - { rewrite dom_fmap_L -Hunioneq in Hfuels. - specialize (Hfuels _ Hin''). rewrite lookup_fmap Hin' in Hfuels. - destruct (fs !! ρ); simplify_eq. simpl in Hfuels. injection Hfuels. - intros ->. simpl. lia. } - symmetry in Hsametid. apply Hminv in Hsametid as (?&?&?). - set_unfold; naive_solver. - - rewrite map_lookup_imap. simpl in *. clear Hmd. - destruct (decide (ρ ∈ dom (ls_mapping δ1))) as [Hin|Hin]; last first. - { apply not_elem_of_dom in Hin. rewrite map_lookup_imap Hin //= in Hissome. by inversion Hissome. } - apply elem_of_dom in Hin as [ζ' Hin']. - rewrite map_lookup_imap Hin' /= in Hneqtid. - destruct (decide (ρ ∈ R2)) as [Hin''|Hin'']; last done. - rewrite Hfuels; last (set_unfold; naive_solver). rewrite lookup_fmap. - assert (Hindom: ρ ∈ dom fs); first by set_unfold; naive_solver. - apply elem_of_dom in Hindom as [f Hindom]. rewrite Hindom /= decide_True /=; [lia|set_unfold; naive_solver]. } - iSplit. - { iPureIntro. intros ρ' Hρ' _. simpl. left. - rewrite map_lookup_imap. rewrite elem_of_dom in Hρ'. - destruct Hρ' as [f Hf]. rewrite Hf /=. destruct (decide ((ρ' ∈ R1 ∪ R2))); simpl; lia. } - iSplit; [simpl| done]. rewrite map_imap_dom_eq //. - by intros ρ??; destruct (decide (ρ ∈ R1 ∪ R2)). - Qed. - - Definition valid_new_fuelmap (fs1 fs2: gmap (fmrole M) nat) (s1 s2: M) (ρ: fmrole M) := - (ρ ∈ live_roles _ s2 -> oleq (fs2 !! ρ) (Some (LM.(lm_fl) s2))) ∧ - (ρ ∉ live_roles _ s2 -> ρ ∈ dom fs1 ∩ dom fs2 -> oless (fs2 !! ρ) (fs1 !! ρ)) ∧ - ρ ∈ dom fs1 ∧ - (forall ρ', ρ' ∈ dom fs2 ∖ dom fs1 -> oleq (fs2 !! ρ') (Some $ LM.(lm_fl) s2)) ∧ - (forall ρ', ρ ≠ ρ' -> ρ' ∈ dom fs1 ∩ dom fs2 -> oless (fs2 !! ρ') (fs1 !! ρ')) ∧ - (dom fs1 ∖ {[ ρ ]}) ∪ (live_roles _ s2 ∖ live_roles _ s1) ⊆ dom fs2 ∧ - dom fs2 ⊆ - (* new roles *) (live_roles _ s2 ∖ live_roles _ s1) ∪ - (* surviving roles *) (live_roles _ s2 ∩ live_roles _ s1 ∩ dom fs1) ∪ - (* already dead *) (dom fs1 ∖ live_roles _ s1) ∪ - (* new deads *) ((live_roles _ s1 ∖ live_roles _ s2) ∩ dom fs1). - - Ltac by_contradiction := - match goal with - | |- ?goal => destruct_decide (decide (goal)); first done; exfalso - end. - - Lemma update_step_still_alive - (extr : execution_trace Λ) - (auxtr: auxiliary_trace LM) - tp1 tp2 σ1 σ2 s1 s2 fs1 fs2 ρ (δ1 : LM) ζ fr1: - (live_roles _ s2 ∖ live_roles _ s1) ⊆ fr1 -> - trace_last extr = (tp1, σ1) → - trace_last auxtr = δ1 -> - locale_step (tp1, σ1) (Some ζ) (tp2, σ2) -> - fmtrans _ s1 (Some ρ) s2 -> valid_new_fuelmap fs1 fs2 δ1 s2 ρ -> - has_fuels ζ fs1 -∗ frag_model_is s1 -∗ model_state_interp tp1 δ1 -∗ - frag_free_roles_are fr1 - ==∗ ∃ (δ2: LM) ℓ, - ⌜labels_match (Some ζ) ℓ - ∧ valid_state_evolution_fairness (extr :tr[Some ζ]: (tp2, σ2)) (auxtr :tr[ℓ]: δ2)⌝ - ∗ has_fuels ζ fs2 ∗ frag_model_is s2 ∗ model_state_interp tp2 δ2 ∗ - frag_free_roles_are (fr1 ∖ (live_roles _ s2 ∖ live_roles _ s1)). - Proof. - iIntros (Hfr_new Htrlast Hauxtrlast Hstep Htrans Hfuelsval) "Hfuel Hmod Hsi Hfr1". - - assert (Hfsne: fs1 ≠ ∅). - { destruct Hfuelsval as (_&_&?&_). intros ->. set_solver. } - - iDestruct (has_fuel_in with "Hfuel Hsi") as "%Hxdom"; eauto. - iDestruct (has_fuel_fuel with "Hfuel Hsi") as %Hfuel; eauto. - iDestruct (model_state_interp_tids_smaller with "Hsi") as %Hless. - - iDestruct "Hsi" as "(%m&%FR&Hafuel&Hamapping&HFR&%Hinv&%Hsmall&Hamod&%HFR)". - iDestruct (model_agree with "Hamod Hmod") as "%Heq". - - iDestruct (free_roles_inclusion with "HFR Hfr1") as %HfrFR. - - assert (Hsamedoms: - dom (map_imap - (λ ρ' _, if decide (ρ' ∈ dom $ ls_fuel δ1) then ls_mapping δ1 !! ρ' else Some ζ) - (gset_to_gmap 333 ((dom (ls_fuel δ1) ∪ dom fs2) ∖ (dom fs1 ∖ dom fs2)))) = - dom (update_fuel_resource δ1 fs1 fs2 s2)). - { unfold update_fuel_resource, fuel_apply. rewrite -leibniz_equiv_iff. - intros ρ'; split. - - intros Hin. destruct (decide (ρ' ∈ dom fs2)) as [[f Hin1]%elem_of_dom|Hin1]. - + apply elem_of_dom. eexists f. rewrite map_lookup_imap lookup_gset_to_gmap option_guard_True //=. - rewrite decide_True //. apply elem_of_dom. rewrite Hin1; eauto. - rewrite map_imap_dom_eq dom_gset_to_gmap in Hin; first set_solver. - intros ρ0??. destruct (decide (ρ0 ∈ dom $ ls_fuel δ1)); [|done]. - apply elem_of_dom. rewrite ls_same_doms. SS. - + rewrite map_imap_dom_eq dom_gset_to_gmap; last first. - { intros ρ0 ? Hin0. destruct (decide (ρ0 ∈ dom fs2)) as [|Hnotin]; apply elem_of_dom; first done. - unfold valid_new_fuelmap in Hfuelsval. - destruct Hfuelsval as (_&_&_&_& Hdomfs2). set_solver. } - - rewrite map_imap_dom_eq dom_gset_to_gmap in Hin; first set_solver. - intros ρ0??. destruct (decide (ρ0 ∈ dom $ ls_fuel δ1)); [|done]. - apply elem_of_dom. rewrite ls_same_doms. SS. - - intros [f Hin]%elem_of_dom. rewrite map_lookup_imap in Hin. - rewrite map_imap_dom_eq dom_gset_to_gmap. - + by_contradiction. rewrite lookup_gset_to_gmap option_guard_False // in Hin. - + intros ρ0??. destruct (decide (ρ0 ∈ dom $ ls_fuel δ1)); [|done]. - apply elem_of_dom. rewrite ls_same_doms. SS. } - - assert (Hnewdom: dom (update_fuel_resource δ1 fs1 fs2 s2) = - (dom (ls_fuel δ1) ∪ dom fs2) ∖ (dom fs1 ∖ dom fs2)). - { unfold update_fuel_resource, fuel_apply. rewrite map_imap_dom_eq ?dom_gset_to_gmap //. - intros ρ' _ Hin. destruct (decide (ρ' ∈ dom fs2)); apply elem_of_dom =>//. set_solver. } - - assert (Hfueldom: live_roles _ s2 ⊆ dom $ update_fuel_resource δ1 fs1 fs2 s2). - { rewrite -Hsamedoms map_imap_dom_eq dom_gset_to_gmap //. - { epose proof ls_fuel_dom as Hfueldom. intros ρ' Hin. - destruct Hfuelsval as (?&?&?&?&?&Hdom_le). - destruct (decide (ρ' ∈ live_roles _ δ1)). - - apply elem_of_difference. - split; [set_solver -Hnewdom Hsamedoms Hdom_le|]. - intros [? Habs]%elem_of_difference. - destruct (decide (ρ' = ρ)). - + simplify_eq. apply not_elem_of_dom in Habs. - rewrite -> Habs in *. simpl in *. eauto. - + apply Habs. - assert (ρ' ∈ dom fs1 ∖ {[ρ]}); set_solver -Hnewdom Hsamedoms. - - apply elem_of_difference. - split; [apply elem_of_union; right; set_unfold; naive_solver| - set_unfold; naive_solver]. } - intros ρ0??. destruct (decide (ρ0 ∈ dom $ ls_fuel δ1)); [|done]. - apply elem_of_dom. rewrite ls_same_doms. SS. } - iExists {| - ls_under := s2; - ls_fuel := _; - ls_fuel_dom := Hfueldom; - ls_mapping := _; - ls_same_doms := Hsamedoms; - |}, (Take_step ρ ζ). - Unshelve. - iMod (update_has_fuels _ fs1 fs2 with "Hfuel Hafuel Hamapping") as "(Hafuel & Hfuel & Hmapping)". - { set_solver. } - { unfold valid_new_fuelmap in Hfuelsval. - destruct Hfuelsval as (_&_&?&?& Hfs2_inf&Hfs2_sup). - apply elem_of_equiv_empty_L => ρ0 Hin. - apply elem_of_intersection in Hin as [Hin1 Hin2]. - apply elem_of_difference in Hin1 as [Hin11 Hin12]. - assert (ρ0 ∈ live_roles _ s2 ∖ live_roles _ s1) - by set_solver -Hsamedoms Hnewdom. - assert (ρ0 ∈ fr1) by set_solver -Hsamedoms Hnewdom. - assert (ρ0 ∈ FR) by set_solver -Hsamedoms Hnewdom. - assert (ρ0 ∉ dom (ls_fuel δ1)) by set_solver -Hsamedoms Hnewdom. - done. } - iMod (update_model s2 with "Hamod Hmod") as "[Hamod Hmod]". - iMod (update_free_roles (live_roles M s2 ∖ live_roles M s1) - with "HFR Hfr1") as "[HFR Hfr2]"; [set_solver|]. - iModIntro. iSplit. - { iSplit; first done. iPureIntro. - destruct Hfuelsval as (Hlim&Hzombie&Hinfs1m&Hnewlim&Hdec&Hinf&Hsup). - constructor =>//; split. - - constructor; simpl; first by rewrite Hauxtrlast Heq //. - split; first by rewrite Hauxtrlast; apply Hxdom; set_solver. - split. - { intros ? ? Hdom Hmd. inversion Hmd; clear Hmd; simplify_eq. - + symmetry in Hsametid. rewrite -> Hxdom in Hsametid. simpl. - unfold update_fuel_resource, fuel_apply. - rewrite map_lookup_imap lookup_gset_to_gmap. - destruct (decide (ρ' ∈ live_roles M s2 ∪ dom fs2)) as [Hin|Hin]. - * rewrite option_guard_True //=. - { destruct (decide (ρ' ∈ dom fs2)) as [Hin2|Hin2]. - ** rewrite Hfuel; last set_solver. - apply Hdec; [congruence|set_solver -Hsamedoms Hnewdom Hdom]. - ** exfalso. set_solver -Hsamedoms Hnewdom Hdom. } - apply elem_of_difference; split; - [set_solver -Hsamedoms Hnewdom Hdom|]. - apply not_elem_of_difference; right. - apply elem_of_union in Hin as [|]; [|done]. - destruct (decide (ρ' = ρ)); simplify_eq. - apply Hinf; set_solver -Hsamedoms Hnewdom Hdom. - * rewrite option_guard_False //=. - ** assert (ρ' ∈ dom fs2); set_solver -Hsamedoms Hnewdom Hdom. - ** apply not_elem_of_difference; right; set_solver -Hsamedoms Hnewdom Hdom. - + simpl in *. unfold update_fuel_resource, fuel_apply. - rewrite map_lookup_imap lookup_gset_to_gmap. - - destruct (decide (ρ' ∈ (dom (ls_fuel (trace_last auxtr)) ∪ dom fs2) ∖ (dom fs1 ∖ dom fs2))) as [Hin|Hin]. - * rewrite map_lookup_imap lookup_gset_to_gmap option_guard_True //= decide_True //= in Hneqtid. - * apply not_elem_of_difference in Hin as [?|Hin]; - [set_solver -Hsamedoms Hnewdom Hdom|]. - apply elem_of_difference in Hin as [??]. - rewrite map_lookup_imap lookup_gset_to_gmap /= option_guard_False /= in Hissome; - [inversion Hissome; congruence|set_solver -Hsamedoms Hnewdom Hdom]. - + simpl in *. rewrite Hfuel; last set_solver -Hsamedoms Hnewdom Hdom. - unfold update_fuel_resource, fuel_apply. - rewrite Hnewdom in Hnotdead. rewrite map_lookup_imap lookup_gset_to_gmap option_guard_True //=. - assert (ρ' ∈ dom fs2) by (set_solver -Hsamedoms Hnewdom Hdom). - rewrite decide_True; [apply Hzombie =>//; set_solver -Hsamedoms Hnewdom Hdom | done]. } - split. - + intros ? Hin ?. simplify_eq; simpl. - unfold update_fuel_resource, fuel_apply. - rewrite map_lookup_imap lookup_gset_to_gmap. - destruct (decide (ρ' ∈ (dom (ls_fuel (trace_last auxtr)) ∪ dom fs2) ∖ (dom fs1 ∖ dom fs2))) as [Hlive|Hlive]. - * rewrite option_guard_True //=. - apply elem_of_difference in Hlive as [Hin1 Hnin]. - apply not_elem_of_difference in Hnin. - destruct (decide (ρ' ∈ dom fs2)) as [Hin2|Hin2]. - ** destruct (decide (ρ' ∈ live_roles _ (trace_last auxtr)));left. - *** destruct (decide (ρ' ∈ dom fs1)). - { rewrite Hfuel //. apply oleq_oless, Hdec; [congruence|set_solver -Hsamedoms Hnewdom]. } - { exfalso. set_solver -Hsamedoms Hnewdom. } - *** assert (ρ' ∉ live_roles _ s2). - { by_contradiction. assert (ρ' ∈ fr1); [eapply elem_of_subseteq; eauto; set_solver -Hsamedoms Hnewdom|]. - assert (ρ' ∈ FR); [eapply elem_of_subseteq; eauto; set_solver -Hsamedoms Hnewdom|set_solver -Hsamedoms Hnewdom]. } - assert (ρ' ∈ dom fs1) by set_solver -Hsamedoms Hnewdom. - rewrite Hfuel //. apply oleq_oless, Hdec; [congruence|set_solver -Hsamedoms Hnewdom]. - ** left. rewrite elem_of_dom in Hin. destruct Hin as [? ->]. simpl;lia. - * right; split. - ** eapply not_elem_of_weaken; [|by apply map_imap_dom_inclusion; rewrite dom_gset_to_gmap]. - rewrite dom_gset_to_gmap //. - ** apply not_elem_of_difference in Hlive as [?|Hlive]; [set_solver -Hsamedoms Hnewdom|]. - apply elem_of_difference in Hlive as [? Habs]. - exfalso. apply Habs. set_solver -Hsamedoms Hnewdom Hfueldom. - + split. - { intros Hlive. unfold update_fuel_resource, fuel_apply. - destruct (decide (ρ ∈ (dom (ls_fuel (trace_last auxtr)) ∪ dom fs2) ∖ (dom fs1 ∖ dom fs2))) as [Hin|Hnin]. - - rewrite map_lookup_imap lookup_gset_to_gmap option_guard_True //=; last set_solver -Hsamedoms Hnewdom Hfueldom. - rewrite decide_True; [by apply Hlim |set_solver -Hsamedoms Hnewdom Hfueldom]. - - exfalso; apply not_elem_of_difference in Hnin as [Hnin|Hnin]. - + assert (ρ ∉ live_roles _ (trace_last auxtr)). - eapply not_elem_of_weaken => //. - { epose proof ls_fuel_dom. set_solver -Hsamedoms Hnewdom Hfueldom. } - assert (ρ ∈ dom fs2) by set_solver -Hsamedoms Hnewdom Hfueldom. set_solver -Hsamedoms Hnewdom Hfueldom. - + apply elem_of_difference in Hnin as [? Hnin]. - apply not_elem_of_dom in Hnin. rewrite Hnin /= in Hlim. - by apply Hlim. } - split. - { intros ρ'. unfold update_fuel_resource, fuel_apply => Hin. - rewrite map_imap_dom_eq in Hin; last first. - { intros ρ0 _ Hin'. destruct (decide (ρ0 ∈ dom fs2)); [by apply elem_of_dom|]. - rewrite dom_gset_to_gmap elem_of_difference in Hin'. - destruct Hin' as [Hin' ?]. apply elem_of_union in Hin' as [?|?]; [by apply elem_of_dom|done]. } - rewrite dom_gset_to_gmap in Hin. rewrite map_lookup_imap lookup_gset_to_gmap option_guard_True /=; last set_solver -Hsamedoms Hnewdom Hfueldom. - assert (ρ' ∈ dom fs2) by set_solver -Hsamedoms Hnewdom Hfueldom. rewrite decide_True //. apply Hnewlim. apply elem_of_difference; split =>//. - intros contra%Hxdom%elem_of_dom_2. rewrite ls_same_doms in contra. simplify_eq. set_solver -Hsamedoms Hnewdom Hfueldom. } - intros ρ0 Hin. - assert (ρ0 ∉ live_roles _ (trace_last auxtr)). - { eapply not_elem_of_weaken; last apply ls_fuel_dom. set_solver -Hsamedoms Hnewdom Hfueldom. } - apply elem_of_difference in Hin as [Hin1 Hnin]. - assert (ρ0 ∈ live_roles _ s2). - { by_contradiction. - assert (ρ0 ∈ dom fs2). - { unfold update_fuel_resource, fuel_apply in Hin1. - eapply elem_of_subseteq in Hin1; last apply map_imap_dom_inclusion. - rewrite dom_gset_to_gmap in Hin1. set_solver -Hsamedoms Hnewdom Hfueldom. } - exfalso. assert (Hinabs: ρ0 ∈ dom fs1) by set_solver -Hsamedoms Hnewdom Hfueldom. - apply not_elem_of_dom in Hnin. rewrite Hauxtrlast Hfuel // in Hnin. - apply elem_of_dom in Hinabs. rewrite Hnin in Hinabs. simpl in Hinabs. - by inversion Hinabs. } - set_solver -Hsamedoms Hnewdom Hfueldom. - - simplify_eq. unfold tids_smaller; simpl. - intros ρ' ? Hmim. - rewrite map_lookup_imap in Hmim. rewrite lookup_gset_to_gmap in Hmim. - destruct (decide (ρ' ∈ (dom (ls_fuel (trace_last auxtr)) ∪ dom fs2) ∖ (dom fs1 ∖ dom fs2))); - last by rewrite option_guard_False in Hmim. - rewrite option_guard_True //= in Hmim. - destruct (decide (ρ' ∈ dom (ls_fuel (trace_last auxtr)))). - + rewrite decide_True // in Hmim. - inversion Hstep; simplify_eq. - eapply from_locale_step =>//. by eapply Hless. - + rewrite decide_False // in Hmim. simplify_eq. - inversion Hstep; simplify_eq. - eapply from_locale_step =>//. unfold from_locale. rewrite from_locale_from_Some //. - apply prefixes_from_spec. exists t1, t2. by list_simplifier. } - - iFrame "Hfuel Hmod Hfr2". iExists _, _. iFrame. all: eauto. (* TODO: find source... *) - iPureIntro; split. - - { intros ρ' ζ'. simpl. rewrite map_lookup_imap. - rewrite lookup_gset_to_gmap //=. - destruct (decide (ρ' ∈ (dom (ls_fuel δ1) ∪ dom fs2) ∖ (dom fs1 ∖ dom fs2))) as [Hin|Hnotin]. - - rewrite option_guard_True //=. destruct (decide (ρ' ∈ dom (ls_fuel δ1))). - + destruct (decide (ζ' = ζ)) as [->|Hneq]. - * rewrite lookup_insert. split. - { eexists; split =>//. apply elem_of_difference in Hin as [? Hin]. - apply not_elem_of_difference in Hin as [?|?]; [|done]. - set_solver -Hsamedoms Hnewdom Hfueldom. } - { intros (?&?&?). simplify_eq. apply Hxdom. - destruct Hfuelsval as (?&?&?&?&?). by_contradiction. - assert (ρ' ∈ live_roles M s2 ∖ live_roles M (trace_last auxtr)) by set_solver -Hsamedoms Hnewdom Hfueldom. - assert (ρ' ∈ fr1) by set_solver -Hsamedoms Hnewdom Hfueldom. - assert (ρ' ∈ FR) by set_solver -Hsamedoms Hnewdom Hfueldom. - assert (ρ' ∉ dom $ ls_fuel (trace_last auxtr)) by set_solver -Hsamedoms Hnewdom Hfueldom. - done. } - * rewrite lookup_insert_ne //. - + split. - * intros Htid. simplify_eq. rewrite lookup_insert. eexists; split=>//. - set_solver -Hsamedoms Hnewdom Hfueldom. - * assert (ρ' ∈ dom fs2) by set_solver -Hsamedoms Hnewdom Hfueldom. intros Hm. by_contradiction. - rewrite lookup_insert_ne in Hm; last congruence. - rewrite -Hinv in Hm. apply elem_of_dom_2 in Hm. rewrite ls_same_doms // in Hm. - - destruct Hfuelsval as (?&?&?&?&Hinf&?). rewrite option_guard_False //=. split; first done. - destruct (decide (ζ' = ζ)) as [->|Hneq]. - { rewrite lookup_insert //. intros (?&?&?). simplify_eq. set_solver -Hsamedoms Hnewdom Hfueldom. } - rewrite lookup_insert_ne //. - rewrite -Hinv. intros Habs. - - apply not_elem_of_difference in Hnotin as [Hnin|Hin]. - + apply elem_of_dom_2 in Habs. rewrite ls_same_doms in Habs. set_solver -Hsamedoms Hnewdom Hfueldom. - + apply elem_of_difference in Hin as [Hin Hnin]. - apply Hxdom in Hin. congruence. } - split. - { intros ζ' ?. pose proof (locales_of_list_step_incl _ _ _ _ _ Hstep). simpl. - rewrite lookup_insert_ne; first by apply Hsmall; set_solver -Hsamedoms Hnewdom Hfueldom. - intros <-. destruct Hfuelsval as (_&_&Hfs1&_). - rewrite <-Hxdom in Hfs1. apply Hinv in Hfs1 as (?&HM&?). - rewrite Hsmall // in HM. set_solver -Hsamedoms Hnewdom Hfueldom. } - { simpl. rewrite /update_fuel_resource /fuel_apply. - rewrite map_imap_dom_eq ?dom_gset_to_gmap. - + apply elem_of_equiv_empty_L. intros ρ' [Hin1 Hin2]%elem_of_intersection. - apply elem_of_difference in Hin1 as [Hin11 Hin12]. - apply not_elem_of_difference in Hin12. - apply elem_of_difference in Hin2 as [Hin21 Hin22]. - apply not_elem_of_difference in Hin22. - assert (ρ' ∉ dom $ ls_fuel δ1) by set_solver -Hsamedoms Hnewdom Hfueldom. - assert (ρ' ∈ dom fs2) by set_solver -Hsamedoms Hnewdom Hfueldom. - destruct Hin12 as [Hin12|Hin12]; last by (epose proof ls_fuel_dom; set_solver -Hsamedoms Hnewdom Hfueldom). - destruct Hfuelsval as (?&?&?&?&?&?). - assert (ρ' ∉ dom fs1); last set_solver -Hsamedoms Hnewdom Hfueldom. - intros contra. pose proof (Hfuel _ contra) as Habs. apply elem_of_dom in contra as [? contra]. - rewrite contra in Habs. apply elem_of_dom_2 in Habs. done. - + intros ρ' _ Hin. destruct (decide (ρ' ∈ dom fs2)) as [Hin'|]. - * apply elem_of_dom in Hin' as [? ->]. done. - * assert (ρ' ∈ dom (ls_fuel δ1)) as Hin' by set_solver -Hsamedoms Hnewdom Hfueldom. apply elem_of_dom in Hin' as [? ->]. done. } -Qed. - -End model_state_lemmas. diff --git a/fairness/trace_utils.v b/fairness/trace_utils.v deleted file mode 100644 index 40dc554a..00000000 --- a/fairness/trace_utils.v +++ /dev/null @@ -1,347 +0,0 @@ -From stdpp Require Import option. -From Paco Require Import paco1 paco2 pacotac. -From trillium.fairness Require Export inftraces. - -Definition trace_implies {S L} (P Q : S → option L → Prop) (tr : trace S L) : Prop := - ∀ n, pred_at tr n P → ∃ m, pred_at tr (n+m) Q. - -Lemma trace_implies_after {S L : Type} (P Q : S → option L → Prop) tr tr' k : - after k tr = Some tr' → - trace_implies P Q tr → trace_implies P Q tr'. -Proof. - intros Haf Hf n Hp. - have Hh:= Hf (k+n). - have Hp': pred_at tr (k + n) P. - { rewrite (pred_at_sum _ k) Haf /= //. } - have [m Hm] := Hh Hp'. exists m. - by rewrite <- Nat.add_assoc, !(pred_at_sum _ k), Haf in Hm. -Qed. - -Lemma trace_implies_cons {S L : Type} (P Q : S → option L → Prop) s l tr : - trace_implies P Q (s -[l]-> tr) → trace_implies P Q tr. -Proof. intros H. by eapply (trace_implies_after _ _ (s -[l]-> tr) tr 1). Qed. - -Lemma pred_at_or {S L : Type} (P1 P2 : S → option L → Prop) tr n : - pred_at tr n (λ s l, P1 s l ∨ P2 s l) ↔ - pred_at tr n P1 ∨ - pred_at tr n P2. -Proof. - split. - - revert tr. - induction n as [|n IHn]; intros tr Htr. - + destruct tr; [done|]. - rewrite !pred_at_0. rewrite !pred_at_0 in Htr. - destruct Htr as [Htr | Htr]; [by left|by right]. - + destruct tr; [done|by apply IHn]. - - revert tr. - induction n as [|n IHn]; intros tr Htr. - + destruct tr; [done|]. - rewrite !pred_at_0 in Htr. rewrite !pred_at_0. - destruct Htr as [Htr | Htr]; [by left|by right]. - + by destruct tr; [by destruct Htr as [Htr|Htr]|apply IHn]. -Qed. - -Lemma traces_match_flip {S1 S2 L1 L2} - (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop) - (trans1: S1 -> L1 -> S1 -> Prop) - (trans2: S2 -> L2 -> S2 -> Prop) - tr1 tr2 : - traces_match Rℓ Rs trans1 trans2 tr1 tr2 ↔ - traces_match (flip Rℓ) (flip Rs) trans2 trans1 tr2 tr1. -Proof. - split. - - revert tr1 tr2. cofix CH. - intros tr1 tr2 Hmatch. inversion Hmatch; simplify_eq. - { by constructor. } - constructor; [done..|]. - by apply CH. - - revert tr1 tr2. cofix CH. - intros tr1 tr2 Hmatch. inversion Hmatch; simplify_eq. - { by constructor. } - constructor; [done..|]. - by apply CH. -Qed. - -Lemma traces_match_impl {S1 S2 L1 L2} - (Rℓ1: L1 -> L2 -> Prop) (Rs1: S1 -> S2 -> Prop) - (Rℓ2: L1 -> L2 -> Prop) (Rs2: S1 -> S2 -> Prop) - (trans1: S1 -> L1 -> S1 -> Prop) - (trans2: S2 -> L2 -> S2 -> Prop) - tr1 tr2 : - (∀ ℓ1 ℓ2, Rℓ1 ℓ1 ℓ2 → Rℓ2 ℓ1 ℓ2) → - (∀ s1 s2, Rs1 s1 s2 → Rs2 s1 s2) → - traces_match Rℓ1 Rs1 trans1 trans2 tr1 tr2 → - traces_match Rℓ2 Rs2 trans1 trans2 tr1 tr2. -Proof. - intros HRℓ HRs. revert tr1 tr2. cofix IH. intros tr1 tr2 Hmatch. - inversion Hmatch; simplify_eq. - - constructor 1. by apply HRs. - - constructor 2; [by apply HRℓ|by apply HRs|done|done|]. by apply IH. -Qed. - -Lemma traces_match_infinite_trace {L1 L2 S1 S2: Type} - (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop) - (trans1: S1 -> L1 -> S1 -> Prop) - (trans2: S2 -> L2 -> S2 -> Prop) tr1 tr2 : - traces_match Rℓ Rs trans1 trans2 tr1 tr2 → infinite_trace tr1 → infinite_trace tr2. -Proof. - intros Hmatch Hinf n. - specialize (Hinf n) as [tr' Hafter]. - apply traces_match_flip in Hmatch. - by eapply traces_match_after in Hafter as [tr'' [Hafter' _]]. -Qed. - -Lemma traces_match_traces_implies {S1 S2 L1 L2} - (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop) - (trans1: S1 -> L1 -> S1 -> Prop) - (trans2: S2 -> L2 -> S2 -> Prop) - (P1 Q1 : S1 → option L1 → Prop) - (P2 Q2 : S2 → option L2 → Prop) - tr1 tr2 : - traces_match Rℓ Rs trans1 trans2 tr1 tr2 → - (∀ s1 s2 oℓ1 oℓ2, Rs s1 s2 → - match oℓ1, oℓ2 with - | Some ℓ1, Some ℓ2 => Rℓ ℓ1 ℓ2 - | None, None => True - | _, _ => False - end → - P2 s2 oℓ2 → P1 s1 oℓ1) → - (∀ s1 s2 oℓ1 oℓ2, Rs s1 s2 → - match oℓ1, oℓ2 with - | Some ℓ1, Some ℓ2 => Rℓ ℓ1 ℓ2 - | None, None => True - | _, _ => False - end → Q1 s1 oℓ1 → Q2 s2 oℓ2) → - trace_implies P1 Q1 tr1 → trace_implies P2 Q2 tr2. -Proof. - intros Hmatch HP HQ Htr1. - intros n Hpred_at. - rewrite /pred_at in Hpred_at. - assert (traces_match (flip Rℓ) - (flip Rs) - trans2 trans1 - tr2 tr1) as Hmatch'. - { by rewrite -traces_match_flip. } - destruct (after n tr2) as [tr2'|] eqn:Htr2eq; [|done]. - eapply (traces_match_after) in Hmatch as (tr1' & Htr1eq & Hmatch); [|done]. - specialize (Htr1 n). - rewrite {1}/pred_at in Htr1. - rewrite Htr1eq in Htr1. - destruct tr1' as [|s ℓ tr']; inversion Hmatch; simplify_eq; try by done. - - assert (P1 s None) as HP1 by by eapply (HP _ _ _ None). - destruct (Htr1 HP1) as [m Htr1']. - exists m. rewrite pred_at_sum. rewrite pred_at_sum in Htr1'. - destruct (after n tr1) as [tr1'|] eqn:Htr1eq'; [|done]. - eapply (traces_match_after) in Hmatch' as (tr2' & Htr2eq' & Hmatch'); [|done]. - rewrite Htr2eq'. - rewrite /pred_at. - rewrite /pred_at in Htr1'. - destruct (after m tr1') as [tr1''|] eqn:Htr1eq''; [|done]. - eapply (traces_match_after) in Hmatch' as (tr2'' & Htr2eq'' & Hmatch''); [|done]. - rewrite Htr2eq''. - destruct tr1''; inversion Hmatch''; simplify_eq; try by done. - + by eapply (HQ _ _ None None). - + by (eapply (HQ _ _ (Some _) _)). - - assert (P1 s (Some ℓ)) as HP1 by by (eapply (HP _ _ _ (Some _))). - destruct (Htr1 HP1) as [m Htr1']. - exists m. rewrite pred_at_sum. rewrite pred_at_sum in Htr1'. - destruct (after n tr1) as [tr1'|] eqn:Htr1eq'; [|done]. - eapply (traces_match_after) in Hmatch' as (tr2' & Htr2eq' & Hmatch'); [|done]. - rewrite Htr2eq'. - rewrite /pred_at. - rewrite /pred_at in Htr1'. - destruct (after m tr1') as [tr1''|] eqn:Htr1eq''; [|done]. - eapply (traces_match_after) in Hmatch' as (tr2'' & Htr2eq'' & Hmatch''); [|done]. - rewrite Htr2eq''. - destruct tr1''; inversion Hmatch''; simplify_eq; try by done. - + by eapply (HQ _ _ None None). - + by (eapply (HQ _ _ (Some _) _)). -Qed. - -Lemma traces_match_after_None {S1 S2 L1 L2} - (Rℓ: L1 -> L2 -> Prop) (Rs: S1 -> S2 -> Prop) - (trans1: S1 -> L1 -> S1 -> Prop) - (trans2: S2 -> L2 -> S2 -> Prop) - tr1 tr2 n : - traces_match Rℓ Rs trans1 trans2 tr1 tr2 -> - after n tr2 = None -> - after n tr1 = None. -Proof. - revert tr1 tr2. - induction n; intros tr1 tr2; [done|]. - move=> /= Hm Ha. - destruct tr1; first by inversion Hm. - inversion Hm; simplify_eq. by eapply IHn. -Qed. - -Fixpoint trace_take {S L} (n : nat) (tr : trace S L) : finite_trace S L := - match tr with - | ⟨s⟩ => {tr[s]} - | s -[ℓ]-> r => match n with - | 0 => {tr[s]} - | S n => (trace_take n r) :tr[ℓ]: s - end - end. - -Fixpoint trace_filter {S L} (f : S → L → Prop) - `{∀ s l, Decision (f s l)} - (tr : finite_trace S L) : finite_trace S L := - match tr with - | {tr[s]} => {tr[s]} - | tr :tr[ℓ]: s => if (bool_decide (f s ℓ)) - then trace_filter f tr :tr[ℓ]: s - else trace_filter f tr - end. - -Fixpoint count_labels {S L} (ft : finite_trace S L) : nat := - match ft with - | {tr[_]} => 0 - | ft' :tr[_]: _ => Datatypes.S (count_labels ft') - end. - -Lemma count_labels_sum {S L} (P : S → L → Prop) - `{∀ s l, Decision (P s l)} n m mtr mtr' : - after n mtr = Some mtr' → - count_labels (trace_filter P $ trace_take (n+m) mtr) = - count_labels ((trace_filter P $ trace_take n mtr)) + - count_labels ((trace_filter P $ trace_take m mtr')). -Proof. - revert mtr mtr'. - induction n=> /=; intros mtr mtr' Hafter. - { simplify_eq. by destruct mtr'. } - destruct mtr; [done|]. simpl. - case_bool_decide. - - simpl. f_equiv. by apply IHn. - - by apply IHn. -Qed. - -Lemma pred_at_impl {S L} (tr:trace S L) n (P Q : S → option L → Prop) : - (∀ s l, P s l → Q s l) → pred_at tr n P → pred_at tr n Q. -Proof. - rewrite /pred_at. intros HPQ HP. - destruct (after n tr); [|done]. - by destruct t; apply HPQ. -Qed. - -Lemma pred_at_neg {S L} (tr:trace S L) n (P : S → option L → Prop) : - is_Some (after n tr) → - ¬ pred_at tr n P ↔ pred_at tr n (λ s l, ¬ P s l). -Proof. - rewrite /pred_at. intros Hafter. split. - - intros HP. - destruct (after n tr). - + by destruct t. - + by apply is_Some_None in Hafter. - - intros HP. - destruct (after n tr). - + by destruct t. - + by apply is_Some_None in Hafter. -Qed. - -Lemma infinite_trace_after' {S T} n (tr : trace S T) : - infinite_trace tr -> ∃ tr', after n tr = Some tr' ∧ infinite_trace tr'. -Proof. - revert tr. - induction n; intros tr Hinf. - { exists tr. done. } - pose proof (IHn _ Hinf) as [tr' [Hafter Hinf']]. - pose proof (Hinf' 1) as [tr'' Htr']. - exists tr''. - replace (Datatypes.S n) with (n + 1) by lia. - rewrite after_sum'. rewrite Hafter. split; [done|]. - intros n'. - specialize (Hinf' (Datatypes.S n')). - destruct tr'; [done|]. - simpl in *. simplify_eq. done. -Qed. - -Lemma infinite_trace_after'' {S T} n (tr tr' : trace S T) : - after n tr = Some tr' → infinite_trace tr → infinite_trace tr'. -Proof. - intros Hafter Hinf m. specialize (Hinf (n+m)). - rewrite after_sum' in Hinf. rewrite Hafter in Hinf. done. -Qed. - -Fixpoint finite_trace_to_trace {S L} (tr : finite_trace S L) : trace S L := - match tr with - | {tr[s]} => ⟨s⟩ - | tr :tr[ℓ]: s => s -[ℓ]-> (finite_trace_to_trace tr) - end. - -Definition trace_now {S T} (tr : trace S T) P := pred_at tr 0 P. -Definition trace_always {S T} (tr : trace S T) P := ∀ n, pred_at tr n P. -Definition trace_eventually {S T} (tr : trace S T) P := ∃ n, pred_at tr n P. -Definition trace_until {S T} (tr : trace S T) P Q := - ∃ n, pred_at tr n Q ∧ ∀ m, m < n → pred_at tr m P. - -Lemma pred_at_after_is_Some {S T} (tr : trace S T) n P : - pred_at tr n P → is_Some $ after n tr. -Proof. rewrite /pred_at. by case_match. Qed. - -Lemma after_is_Some_le {S T} (tr : trace S T) n m : - m ≤ n → is_Some $ after n tr → is_Some $ after m tr. -Proof. - revert tr m. - induction n; intros tr m Hle. - { intros. assert (m = 0) as -> by lia. done. } - intros. - destruct m; [done|]. - simpl in *. - destruct tr; [done|]. - apply IHn. lia. done. -Qed. - -Lemma trace_eventually_until {S T} (tr : trace S T) P : - trace_eventually tr P → trace_until tr (λ s l, ¬ P s l) P. -Proof. - intros [n Hn]. - induction n as [n IHn] using lt_wf_ind. - assert ((∀ m, m < n → pred_at tr m (λ s l, ¬ P s l)) ∨ - ¬ (∀ m, m < n → pred_at tr m (λ s l, ¬ P s l))) as [HP|HP]; - [|by eexists _|]. - { apply ExcludedMiddle. } - eapply not_forall_exists_not in HP as [n' HP]. - apply Classical_Prop.imply_to_and in HP as [Hlt HP]. - apply pred_at_neg in HP; last first. - { eapply after_is_Some_le; [|by eapply pred_at_after_is_Some]. lia. } - eapply pred_at_impl in HP; last first. - { intros s l H. apply NNP_P. apply H. } - specialize (IHn n' Hlt HP) as [n'' [H' H'']]. - exists n''. done. -Qed. - -Lemma trace_eventually_cons {S T} s l (tr : trace S T) P : - trace_eventually tr P → trace_eventually (s -[l]-> tr) P. -Proof. intros [n HP]. by exists (Datatypes.S n). Qed. - -Lemma trace_eventually_stutter_preserves - {St S' L L': Type} (Us: St -> S') (Ul: L -> option L') - tr1 tr2 P : - upto_stutter Us Ul tr1 tr2 → - trace_eventually tr2 P → - trace_eventually tr1 (λ s l, P (Us s) (l ≫= Ul)). -Proof. - intros Hstutter [n Heventually]. - revert tr1 tr2 Hstutter Heventually. - induction n as [|n IHn]; intros tr1 tr2 Hstutter Heventually. - - punfold Hstutter; [|apply upto_stutter_mono]. - induction Hstutter. - + rewrite /pred_at in Heventually. simpl in *. exists 0. rewrite /pred_at. simpl in *. done. - + destruct (IHHstutter Heventually) as [n Heventually']. - exists (1 + n). rewrite /pred_at. rewrite after_sum'. simpl. - done. - + rewrite /pred_at in Heventually. simpl in *. exists 0. rewrite /pred_at. simpl. - simplify_eq. rewrite H0. done. - - punfold Hstutter; [|apply upto_stutter_mono]. - induction Hstutter. - + rewrite /pred_at in Heventually. simpl in *. exists 0. rewrite /pred_at. simpl in *. done. - + destruct (IHHstutter Heventually) as [n' Heventually']. - exists (1 + n'). rewrite /pred_at. rewrite after_sum'. simpl. - done. - + apply trace_eventually_cons. - assert (pred_at str n P) as Heventually'. - { rewrite /pred_at in Heventually. - simpl in *. done. } - eapply IHn; [|done]. - rewrite /upaco2 in H1. destruct H1; [done|done]. -Qed. diff --git a/trillium/algebra/trace.v b/trillium/algebra/trace.v deleted file mode 100644 index 3711be62..00000000 --- a/trillium/algebra/trace.v +++ /dev/null @@ -1,257 +0,0 @@ -From trillium.traces Require Export trace. -From iris.algebra Require Export ofe cmra local_updates. - -Inductive trace_alg (A L : Type) : Type := -| trace_alg_trace (ft : finite_trace A L) -| trace_alg_bot. - -Global Arguments trace_alg_trace {_ _} _. -Global Arguments trace_alg_bot {_ _}, _. - -Canonical Structure traceO (A L : Type) := leibnizO (finite_trace A L). -Canonical Structure trace_algO (A L: Type) := leibnizO (trace_alg A L). - -Section trace_alg_cmra. - Context `{!EqDecision A, !EqDecision L}. - - Implicit Types a b : A. - Implicit Types ℓ : L. - Implicit Types ft : finite_trace A L. - Implicit Types fa : trace_alg A L. - - Local Instance trace_alg_pcore_instance : PCore (trace_alg A L) := λ fa, Some fa. - - Local Instance trace_alg_op : Op (trace_alg A L) := - λ fa fa', - match fa with - | trace_alg_trace ft => - match fa' with - | trace_alg_trace ft' => - if (bool_decide (ft `trace_prefix_of` ft')) then - trace_alg_trace ft' - else - if (bool_decide (ft' `trace_prefix_of` ft)) then - trace_alg_trace ft - else - trace_alg_bot - | trace_alg_bot => trace_alg_bot - end - | trace_alg_bot => trace_alg_bot - end. - - Arguments trace_alg_op _ _ : simpl never. - - Lemma trace_alg_op_traces ft ft' : - (trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = trace_alg_bot ∧ - (¬ ft `trace_prefix_of` ft' ∧ - ¬ ft' `trace_prefix_of` ft)) ∨ - ((trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = - trace_alg_trace ft' ∧ ft `trace_prefix_of` ft') ∨ - (trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = - trace_alg_trace ft ∧ ft' `trace_prefix_of` ft)). - Proof. - rewrite /trace_alg_op. - rewrite -!decide_bool_decide. - repeat destruct decide; eauto. - Qed. - - Lemma trace_alg_op_eq_right' ft ft' : - ft `trace_prefix_of` ft' → - trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = trace_alg_trace ft'. - Proof. - intros ?. - rewrite /trace_alg_op -!decide_bool_decide. - repeat destruct decide; done. - Qed. - - Lemma trace_alg_op_eq_left' ft ft' : - ft' `trace_prefix_of` ft → - trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = trace_alg_trace ft. - Proof. - intros ?. - rewrite /trace_alg_op -!decide_bool_decide. - repeat destruct decide; [|done|done]. - f_equal; apply trace_prefix_antisym; done. - Qed. - - Lemma trace_alg_op_eq_neither' ft ft' : - ¬ ft `trace_prefix_of` ft' → - ¬ ft' `trace_prefix_of` ft → - trace_alg_op (trace_alg_trace ft) (trace_alg_trace ft') = trace_alg_bot. - Proof. - intros ??. - rewrite /trace_alg_op -!decide_bool_decide. - repeat destruct decide; done. - Qed. - - Lemma trace_alg_op_right_bot' fa : - trace_alg_op fa trace_alg_bot = trace_alg_bot. - Proof. destruct fa; done. Qed. - - Lemma trace_alg_op_left_bot' fa : - trace_alg_op trace_alg_bot fa = trace_alg_bot. - Proof. destruct fa; done. Qed. - - Lemma trace_alg_op_com fa fa' : - trace_alg_op fa fa' = trace_alg_op fa' fa. - Proof. - destruct fa as [ft|]; destruct fa' as [ft'|]; [|done|done|done]. - destruct (decide (ft `trace_prefix_of` ft')). - { rewrite (trace_alg_op_eq_right' ft ft'); last done. - rewrite (trace_alg_op_eq_left' ft' ft); done. } - destruct (decide (ft' `trace_prefix_of` ft)). - { rewrite (trace_alg_op_eq_left' ft ft'); last done. - rewrite (trace_alg_op_eq_right' ft' ft); done. } - rewrite !trace_alg_op_eq_neither'; done. - Qed. - - Lemma trace_alg_op_assoc fa fa' fa'' : - trace_alg_op fa (trace_alg_op fa' fa'') = - trace_alg_op (trace_alg_op fa fa') fa''. - Proof. - destruct fa as [ft|]; last done. - destruct fa' as [ft'|]; last done. - destruct fa'' as [ft''|]; last first. - { by rewrite !trace_alg_op_right_bot'. } - destruct (trace_alg_op_traces ft ft') as - [[-> [Hf1 Hf2]]|[[-> Hf]|[-> Hf]]]. - - destruct (trace_alg_op_traces ft' ft'') - as [[-> [Hg1 Hg2]]|[[-> Hg]|[-> Hg]]]; first done. - + destruct (decide (ft `trace_prefix_of` ft'')). - { edestruct (trace_prefixes_related ft ft'); done. } - destruct (decide (ft' `trace_prefix_of` ft)); first done. - rewrite (trace_alg_op_eq_neither' ft ft''); [done|done|]. - intros ?; apply Hf2; etrans; done. - + rewrite (trace_alg_op_eq_neither' ft ft'); [done|done|]. - intros ?; apply Hf2; etrans; done. - - destruct (trace_alg_op_traces ft' ft'') - as [[-> [Hg1 Hg2]]|[[-> Hg]|[-> Hg]]]; first done. - + apply trace_alg_op_eq_right'; etrans; done. - + apply trace_alg_op_eq_right'; etrans; done. - - destruct (trace_alg_op_traces ft' ft'') - as [[-> [Hg1 Hg2]]|[[-> Hg]|[-> Hg]]]; [|done|]. - + rewrite (trace_alg_op_eq_neither' ft ft''); first done. - * intros ?; apply Hg1; etrans; done. - * intros ?. - edestruct (trace_prefixes_related ft'' ft'); done. - + rewrite !trace_alg_op_eq_left'; [done|etrans; done|done]. - Qed. - - Lemma trace_alg_op_idemp' fa : trace_alg_op fa fa = fa. - Proof. - destruct fa; last done. - rewrite trace_alg_op_eq_left'; done. - Qed. - - Local Instance trace_alg_valid_instance : Valid (trace_alg A L) := - λ fa, match fa with - | trace_alg_trace _ => True - | _ => False - end. - - Lemma trace_alg_RAMixin : RAMixin (trace_alg A L). - Proof. - apply ra_total_mixin. - - eauto. - - intros fa fa' fa'' ->%leibniz_equiv; done. - - by intros ?? ->%leibniz_equiv. - - by intros ?? ->%leibniz_equiv. - - intros ???; apply trace_alg_op_assoc. - - intros ??; apply trace_alg_op_com. - - intros ?; apply trace_alg_op_idemp'. - - done. - - done. - - intros [] []; done. - Qed. - - Canonical Structure trace_algR := discreteR (trace_alg A L) trace_alg_RAMixin. - - Global Instance trace_alg_cmra_total : CmraTotal trace_algR. - Proof. econstructor; done. Qed. - - Global Instance trace_alg_cmra_discrete : CmraDiscrete trace_algR. - Proof. econstructor; [apply _|done]. Qed. - - Global Instance trace_alg_core_id fa : CoreId fa. - Proof. by constructor. Qed. - - Lemma trace_alg_included ft ft' : - trace_alg_trace ft ≼ trace_alg_trace ft' ↔ ft `trace_prefix_of` ft'. - Proof. - split. - - intros [fa'' Heq%leibniz_equiv]. - rewrite /op in Heq. - destruct fa'' as [ft''|]; last by rewrite trace_alg_op_right_bot' in Heq. - destruct (trace_alg_op_traces ft ft'') as [[Hop Hf]|[[Hop Hf]|[Hop Hf]]]. - + rewrite Hop in Heq; done. - + rewrite Hop in Heq; simplify_eq; done. - + rewrite Hop in Heq; simplify_eq; done. - - intros Hincl; exists (trace_alg_trace ft'). - rewrite /op trace_alg_op_eq_right'; done. - Qed. - - Lemma trace_alg_includedN ft ft' n : - trace_alg_trace ft ≼{n} trace_alg_trace ft' ↔ ft `trace_prefix_of` ft'. - Proof. apply trace_alg_included. Qed. - - Lemma trace_alg_op_idemp'' : IdemP eq (@op (trace_alg A L) _). - Proof. intros ?; apply trace_alg_op_idemp'. Qed. - - Lemma trace_alg_op_idemp fa : fa ⋅ fa = fa. - Proof. apply trace_alg_op_idemp'. Qed. - - Lemma trace_alg_op_eq_right ft ft' : - ft `trace_prefix_of` ft' → - trace_alg_trace ft ⋅ trace_alg_trace ft' = trace_alg_trace ft'. - Proof. apply trace_alg_op_eq_right'. Qed. - - Lemma trace_alg_op_eq_left ft ft' : - ft' `trace_prefix_of` ft → - trace_alg_trace ft ⋅ trace_alg_trace ft' = trace_alg_trace ft. - Proof. apply trace_alg_op_eq_left'. Qed. - - Lemma trace_alg_op_eq_neither ft ft' : - ¬ ft `trace_prefix_of` ft' → - ¬ ft' `trace_prefix_of` ft → - trace_alg_trace ft ⋅ trace_alg_trace ft' = trace_alg_bot. - Proof. apply trace_alg_op_eq_neither'. Qed. - - Lemma trace_alg_op_right_bot fa : - fa ⋅ trace_alg_bot = trace_alg_bot. - Proof. apply trace_alg_op_right_bot'. Qed. - - Lemma trace_alg_op_left_bot fa : - trace_alg_op trace_alg_bot fa = trace_alg_bot. - Proof. apply trace_alg_op_left_bot'. Qed. - - Lemma trace_alg_validN fa n : ✓{n} fa → ∃ ft, fa = trace_alg_trace ft. - Proof. destruct fa; by eauto. Qed. - - Lemma trace_alg_valid fa : ✓ fa → ∃ ft, fa = trace_alg_trace ft. - Proof. destruct fa; by eauto. Qed. - - Lemma trace_alg_pcore fa : pcore fa = Some fa. - Proof. done. Qed. - - Lemma trace_alg_core fa : core fa = fa. - Proof. done. Qed. - - Lemma trace_alg_local_update ft fa ft' : - ft `trace_prefix_of` ft' → - (trace_alg_trace ft, fa) ~l~> (trace_alg_trace ft', trace_alg_trace ft'). - Proof. - intros Hpf. - apply local_update_total_valid. - intros _ [ft'' ->]%trace_alg_valid Hfts%trace_alg_included. - setoid_replace (trace_alg_trace ft') with - (trace_alg_trace ft' ⋅ trace_alg_trace ft) at 1; last first. - { rewrite trace_alg_op_eq_left; done. } - setoid_replace (trace_alg_trace ft') with - (trace_alg_trace ft' ⋅ trace_alg_trace ft'') at 2; last first. - { rewrite trace_alg_op_eq_left; etrans; done. } - apply op_local_update. - intros ??. - rewrite trace_alg_op_eq_left; done. - Qed. - -End trace_alg_cmra. diff --git a/trillium/bi/weakestpre.v b/trillium/bi/weakestpre.v deleted file mode 100644 index 324f7c86..00000000 --- a/trillium/bi/weakestpre.v +++ /dev/null @@ -1,241 +0,0 @@ -From stdpp Require Export coPset. -From iris.bi Require Import interface derived_connectives. -From trillium.program_logic Require Import language. -From iris.prelude Require Import options. - -Inductive stuckness := NotStuck | MaybeStuck. - -Definition stuckness_leb (s1 s2 : stuckness) : bool := - match s1, s2 with - | MaybeStuck, NotStuck => false - | _, _ => true - end. -#[global] Instance stuckness_le : SqSubsetEq stuckness := stuckness_leb. -#[global] Instance stuckness_le_po : PreOrder stuckness_le. -Proof. split; by repeat intros []. Qed. - -Definition stuckness_to_atomicity (s : stuckness) : atomicity := - if s is MaybeStuck then StronglyAtomic else WeaklyAtomic. - -(** Weakest preconditions [WP e @ s ; E {{ Φ }}] have an additional argument [s] -of arbitrary type [A], that can be chosen by the one instantiating the [Wp] type -class. This argument can be used for e.g. the stuckness bit (as in Iris) or -thread IDs (as in iGPS). - -For the case of stuckness bits, there are two specific notations -[WP e @ E {{ Φ }}] and [WP e @ E ?{{ Φ }}], which forces [A] to be [stuckness], -and [s] to be [NotStuck] or [MaybeStuck]. This will fail to typecheck if [A] is -not [stuckness]. If we ever want to use the notation [WP e @ E {{ Φ }}] with a -different [A], the plan is to generalize the notation to use [Inhabited] instead -to pick a default value depending on [A]. *) -Class Wp (Λ : language) (PROP A : Type) := - wp : A → coPset -> locale Λ -> expr Λ → (val Λ → PROP) → PROP. -Arguments wp {_ _ _ _} _ _ _ _%E _%I. -#[global] Instance: Params (@wp) 8 := {}. - -(** Notations for partial weakest preconditions *) -(** Notations without binder -- only parsing because they overlap with the -notations with binder. *) - - -Notation "'WP' e @ s ; tid ; E {{ Φ } }" := (wp s E tid e%E Φ) - (at level 20, e, Φ at level 200, only parsing) : bi_scope. -Notation "'WP' e @ tid ; E {{ Φ } }" := (wp NotStuck E tid e%E Φ) - (at level 20, e, Φ at level 200, only parsing) : bi_scope. -Notation "'WP' e @ tid ; E ? {{ Φ } }" := (wp MaybeStuck E tid e%E Φ) - (at level 20, e, Φ at level 200, only parsing) : bi_scope. -Notation "'WP' e @ tid {{ Φ } }" := (wp NotStuck ⊤ tid e%E Φ) - (at level 20, e, Φ at level 200, only parsing) : bi_scope. -Notation "'WP' e @ tid ? {{ Φ } }" := (wp MaybeStuck ⊤ tid e%E Φ) - (at level 20, e, Φ at level 200, only parsing) : bi_scope. - -(** Notations with binder. The indentation for the inner format block is chosen -such that *if* one has a single-character mask (e.g. [E]), the second line -should align with the binder(s) on the first line. *) -Notation "'WP' e @ s ; tid ; E {{ v , Q } }" := (wp s E tid e%E (λ v, Q)) - (at level 20, e, Q at level 200, - format "'[' 'WP' e '/' '[ ' @ s ; tid ; E {{ v , Q } } ']' ']'") : bi_scope. -Notation "'WP' e @ tid ; E {{ v , Q } }" := (wp NotStuck E tid e%E (λ v, Q)) - (at level 20, e, Q at level 200, - format "'[' 'WP' e '/' '[ ' @ tid ; E {{ v , Q } } ']' ']'") : bi_scope. -Notation "'WP' e @ tid ; E ? {{ v , Q } }" := (wp MaybeStuck E tid e%E (λ v, Q)) - (at level 20, e, Q at level 200, - format "'[' 'WP' e '/' '[ ' @ tid ; E ? {{ v , Q } } ']' ']'") : bi_scope. -Notation "'WP' e @ tid {{ v , Q } }" := (wp NotStuck ⊤ tid e%E (λ v, Q)) - (at level 20, e, Q at level 200, - format "'[' 'WP' e @ tid '/' '[ ' {{ v , Q } } ']' ']'") : bi_scope. -Notation "'WP' e @ tid ? {{ v , Q } }" := (wp MaybeStuck ⊤ tid e%E (λ v, Q)) - (at level 20, e, Q at level 200, - format "'[' 'WP' e @ tid '/' '[ ' ? {{ v , Q } } ']' ']'") : bi_scope. - -(* Texan triples *) -Notation "'{{{' P } } } e @ tid ; s ; E {{{ x .. y , 'RET' pat ; Q } } }" := - (□ ∀ Φ, - P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid ; s; E {{ Φ }})%I - (at level 20, x closed binder, y closed binder, - format "'[hv' {{{ P } } } '/ ' e '/' @ tid ; s ; E {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. -Notation "'{{{' P } } } e @ tid ; E {{{ x .. y , 'RET' pat ; Q } } }" := - (□ ∀ Φ, - P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid ; E {{ Φ }})%I - (at level 20, x closed binder, y closed binder, - format "'[hv' {{{ P } } } '/ ' e '/' @ tid ; E {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. -Notation "'{{{' P } } } e @ tid ; E ? {{{ x .. y , 'RET' pat ; Q } } }" := - (□ ∀ Φ, - P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid ; E ?{{ Φ }})%I - (at level 20, x closed binder, y closed binder, - format "'[hv' {{{ P } } } '/ ' e '/' @ tid ; E ? {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. -Notation "'{{{' P } } } e @ tid {{{ x .. y , 'RET' pat ; Q } } }" := - (□ ∀ Φ, - P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid {{ Φ }})%I - (at level 20, x closed binder, y closed binder, - format "'[hv' {{{ P } } } '/ ' e @ tid '/' {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. -Notation "'{{{' P } } } e @ tid ? {{{ x .. y , 'RET' pat ; Q } } }" := - (□ ∀ Φ, - P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid ?{{ Φ }})%I - (at level 20, x closed binder, y closed binder, - format "'[hv' {{{ P } } } '/ ' e @ tid '/' ? {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. - -Notation "'{{{' P } } } e @ s ; tid ; E {{{ 'RET' pat ; Q } } }" := - (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ s; tid ; E {{ Φ }})%I - (at level 20, - format "'[hv' {{{ P } } } '/ ' e '/' @ s ; tid ; E {{{ RET pat ; Q } } } ']'") : bi_scope. -Notation "'{{{' P } } } e @ tid ; E {{{ 'RET' pat ; Q } } }" := - (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ tid ; E {{ Φ }})%I - (at level 20, - format "'[hv' {{{ P } } } '/ ' e '/' @ tid ; E {{{ RET pat ; Q } } } ']'") : bi_scope. -Notation "'{{{' P } } } e @ tid ; E ? {{{ 'RET' pat ; Q } } }" := - (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ tid ; E ?{{ Φ }})%I - (at level 20, - format "'[hv' {{{ P } } } '/ ' e '/' @ tid ; E ? {{{ RET pat ; Q } } } ']'") : bi_scope. -Notation "'{{{' P } } } e @ tid {{{ 'RET' pat ; Q } } }" := - (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ tid {{ Φ }})%I - (at level 20, - format "'[hv' {{{ P } } } '/ ' e @ tid '/' {{{ RET pat ; Q } } } ']'") : bi_scope. -Notation "'{{{' P } } } e @ tid ? {{{ 'RET' pat ; Q } } }" := - (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ tid ?{{ Φ }})%I - (at level 20, - format "'[hv' {{{ P } } } '/ ' e @ tid '/' ? {{{ RET pat ; Q } } } ']'") : bi_scope. - -(** Aliases for stdpp scope -- they inherit the levels and format from above. *) -Notation "'{{{' P } } } e @ s ; tid ; E {{{ x .. y , 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ s; tid ; E {{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ tid ; E {{{ x .. y , 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid ; E {{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ tid ; E ? {{{ x .. y , 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid ; E ?{{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ tid {{{ x .. y , 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid {{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ tid ? {{{ x .. y , 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ tid ?{{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ s ; tid ; E {{{ 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ s; tid; E {{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ tid ; E {{{ 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ tid; E {{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ tid ; E ? {{{ 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ tid; E ?{{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ tid {{{ 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ tid {{ Φ }}) : stdpp_scope. -Notation "'{{{' P } } } e @ tid ? {{{ 'RET' pat ; Q } } }" := - (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ tid ?{{ Φ }}) : stdpp_scope. - - - -(* Notation "'WP' e @ s ; E {{ Φ } }" := (wp s E e%E Φ) *) -(* (at level 20, e, Φ at level 200, only parsing) : bi_scope. *) -(* Notation "'WP' e @ E {{ Φ } }" := (wp NotStuck E e%E Φ) *) -(* (at level 20, e, Φ at level 200, only parsing) : bi_scope. *) -(* Notation "'WP' e @ E ? {{ Φ } }" := (wp MaybeStuck E e%E Φ) *) -(* (at level 20, e, Φ at level 200, only parsing) : bi_scope. *) -(* Notation "'WP' e {{ Φ } }" := (wp NotStuck ⊤ e%E Φ) *) -(* (at level 20, e, Φ at level 200, only parsing) : bi_scope. *) -(* Notation "'WP' e ? {{ Φ } }" := (wp MaybeStuck ⊤ e%E Φ) *) -(* (at level 20, e, Φ at level 200, only parsing) : bi_scope. *) - -(* (** Notations with binder. The indentation for the inner format block is chosen *) -(* such that *if* one has a single-character mask (e.g. [E]), the second line *) -(* should align with the binder(s) on the first line. *) *) -(* Notation "'WP' e @ s ; E {{ v , Q } }" := (wp s E e%E (λ v, Q)) *) -(* (at level 20, e, Q at level 200, *) -(* format "'[' 'WP' e '/' '[ ' @ s ; E {{ v , Q } } ']' ']'") : bi_scope. *) -(* Notation "'WP' e @ E {{ v , Q } }" := (wp NotStuck E e%E (λ v, Q)) *) -(* (at level 20, e, Q at level 200, *) -(* format "'[' 'WP' e '/' '[ ' @ E {{ v , Q } } ']' ']'") : bi_scope. *) -(* Notation "'WP' e @ E ? {{ v , Q } }" := (wp MaybeStuck E e%E (λ v, Q)) *) -(* (at level 20, e, Q at level 200, *) -(* format "'[' 'WP' e '/' '[ ' @ E ? {{ v , Q } } ']' ']'") : bi_scope. *) -(* Notation "'WP' e {{ v , Q } }" := (wp NotStuck ⊤ e%E (λ v, Q)) *) -(* (at level 20, e, Q at level 200, *) -(* format "'[' 'WP' e '/' '[ ' {{ v , Q } } ']' ']'") : bi_scope. *) -(* Notation "'WP' e ? {{ v , Q } }" := (wp MaybeStuck ⊤ e%E (λ v, Q)) *) -(* (at level 20, e, Q at level 200, *) -(* format "'[' 'WP' e '/' '[ ' ? {{ v , Q } } ']' ']'") : bi_scope. *) - -(* (* Texan triples *) *) -(* Notation "'{{{' P } } } e @ s ; E {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, *) -(* P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ s; E {{ Φ }})%I *) -(* (at level 20, x closed binder, y closed binder, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' @ s ; E {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. *) -(* Notation "'{{{' P } } } e @ E {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, *) -(* P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ E {{ Φ }})%I *) -(* (at level 20, x closed binder, y closed binder, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' @ E {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. *) -(* Notation "'{{{' P } } } e @ E ? {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, *) -(* P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ E ?{{ Φ }})%I *) -(* (at level 20, x closed binder, y closed binder, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' @ E ? {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. *) -(* Notation "'{{{' P } } } e {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, *) -(* P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e {{ Φ }})%I *) -(* (at level 20, x closed binder, y closed binder, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. *) -(* Notation "'{{{' P } } } e ? {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, *) -(* P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e ?{{ Φ }})%I *) -(* (at level 20, x closed binder, y closed binder, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' ? {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope. *) - -(* Notation "'{{{' P } } } e @ s ; E {{{ 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ s; E {{ Φ }})%I *) -(* (at level 20, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' @ s ; E {{{ RET pat ; Q } } } ']'") : bi_scope. *) -(* Notation "'{{{' P } } } e @ E {{{ 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ E {{ Φ }})%I *) -(* (at level 20, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' @ E {{{ RET pat ; Q } } } ']'") : bi_scope. *) -(* Notation "'{{{' P } } } e @ E ? {{{ 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ E ?{{ Φ }})%I *) -(* (at level 20, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' @ E ? {{{ RET pat ; Q } } } ']'") : bi_scope. *) -(* Notation "'{{{' P } } } e {{{ 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e {{ Φ }})%I *) -(* (at level 20, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' {{{ RET pat ; Q } } } ']'") : bi_scope. *) -(* Notation "'{{{' P } } } e ? {{{ 'RET' pat ; Q } } }" := *) -(* (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e ?{{ Φ }})%I *) -(* (at level 20, *) -(* format "'[hv' {{{ P } } } '/ ' e '/' ? {{{ RET pat ; Q } } } ']'") : bi_scope. *) - -(* (** Aliases for stdpp scope -- they inherit the levels and format from above. *) *) -(* Notation "'{{{' P } } } e @ s ; E {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ s; E {{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e @ E {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ E {{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e @ E ? {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e @ E ?{{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e {{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e ? {{{ x .. y , 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ WP e ?{{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e @ s ; E {{{ 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ s; E {{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e @ E {{{ 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ E {{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e @ E ? {{{ 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e @ E ?{{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e {{{ 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e {{ Φ }}) : stdpp_scope. *) -(* Notation "'{{{' P } } } e ? {{{ 'RET' pat ; Q } } }" := *) -(* (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ WP e ?{{ Φ }}) : stdpp_scope. *) diff --git a/trillium/events/event.v b/trillium/events/event.v deleted file mode 100644 index 63287b72..00000000 --- a/trillium/events/event.v +++ /dev/null @@ -1,438 +0,0 @@ -From trillium.prelude Require Import classical. -From trillium.traces Require Import trace. -From trillium.program_logic Require Import - ectx_language language traces. - -(** Ideally, all definitions in this file should be computational. - But that's is too much work. Hence, since we already assume classical - axioms in this work we can use those to axiomatize the function that - given an execution extracts its observations. *) - -Record Event (Λ : language) := mkEvent { - is_triggered :> expr Λ → state Λ → expr Λ → state Λ → Prop; - (* The following two axioms ensure that events are only triggered - on head steps. *) - is_triggered_not_val : - ∀ e1 σ1 e2 σ2, is_triggered e1 σ1 e2 σ2 → to_val e1 = None; - is_triggered_ectx_free : - ∀ e1 σ1 e2 σ2, - is_triggered e1 σ1 e2 σ2 → - ∀ K e1', e1 = ectx_fill K e1' → is_Some (to_val e1') ∨ K = ectx_emp; - is_triggered_not_stuttering : - ∀ e1 σ1 e2 σ2, - is_triggered e1 σ1 e2 σ2 → e1 ≠ e2; -}. - -Arguments is_triggered {_} _ _ _ _. -Arguments is_triggered_not_val {_} _ _ _ _. -Arguments is_triggered_ectx_free {_} _. -Arguments is_triggered_not_stuttering {_} _. - -Record EventObservation (Λ : language) := mkEventObservation { - pre_expr : expr Λ; - pre_state : state Λ; - post_expr : expr Λ; - post_state : state Λ; -}. - -Arguments mkEventObservation {_} _ _ _ _. -Arguments pre_state {_} _. -Arguments pre_expr {_} _. -Arguments post_state {_} _. -Arguments post_expr {_} _. - -Definition validEventObservation - {Λ : language} (EV : Event Λ) (eo : EventObservation Λ) := - EV eo.(pre_expr) eo.(pre_state) eo.(post_expr) eo.(post_state). - -Definition event_obs (Λ : language) := list (EventObservation Λ). - -Definition valid_event_obs - {Λ : language} (EV : Event Λ) (eo : event_obs Λ) : Prop := - Forall (validEventObservation EV) eo. - -Inductive trace_has_events {Λ : language} (EV : Event Λ) : - execution_trace Λ → event_obs Λ → Prop := -| singleton_events c : trace_has_events EV {tr[c]} [] -| extend_observed ex c c' tp1 tp2 efs K eo eobs oζ: - trace_ends_in ex c → - c.2 = eo.(pre_state) → - c.1 = tp1 ++ ectx_fill K eo.(pre_expr) :: tp2 → - c'.2 = eo.(post_state) → - c'.1 = tp1 ++ ectx_fill K eo.(post_expr) :: tp2 ++ efs → - validEventObservation EV eo → - trace_has_events EV ex eobs → - trace_has_events EV (ex :tr[oζ]: c') (eobs ++ [eo]) -| extend_not_observed ex c c' eobs oζ: - trace_ends_in ex c → - (∀ tp1 tp2 efs K e1 e2, - c.1 = tp1 ++ ectx_fill K e1 :: tp2 → - c'.1 = tp1 ++ ectx_fill K e2 :: tp2 ++ efs → - ¬ EV e1 c.2 e2 c'.2) → - trace_has_events EV ex eobs → - trace_has_events EV (ex :tr[oζ]: c') eobs. - -Section properties. - Context {Λ : language} (EV : Event Λ). - - Implicit Types e : expr Λ. - Implicit Types tp : list (expr Λ). - Implicit Types σ : state Λ. - Implicit Types eobs : event_obs Λ. - Implicit Types obs : EventObservation Λ. - Implicit Types ex : execution_trace Λ. - - Lemma validEventObservation_exprs_neq obs : - validEventObservation EV obs → obs.(pre_expr) ≠ obs.(post_expr). - Proof. intros; eapply is_triggered_not_stuttering; done. Qed. - - Lemma validEventObservation_not_val obs : - validEventObservation EV obs → to_val obs.(pre_expr) = None. - Proof. intros; eapply is_triggered_not_val; done. Qed. - - Lemma trace_has_events_valid ex eobs : - trace_has_events EV ex eobs → valid_event_obs EV eobs. - Proof. - induction 1 as [|ex [tp σ] [tp' σ']|]; simplify_eq/=. - - by constructor. - - apply Forall_app; split; first done. - apply Forall_singleton; done. - - done. - Qed. - - Lemma event_in_the_middle tp1 tp2 K e1 e2 efs tp1' tp2' K' eo efs' : - validEventObservation EV eo → - to_val e1 = None → - (∀ e1' K'', e1 = ectx_fill K'' e1' → is_Some (to_val e1') ∨ K'' = ectx_emp) → - tp1 ++ ectx_fill K e1 :: tp2 = tp1' ++ ectx_fill K' (pre_expr eo) :: tp2' → - tp1 ++ ectx_fill K e2 :: tp2 ++ efs = - tp1' ++ ectx_fill K' (post_expr eo) :: tp2' ++ efs' → - pre_expr eo = e1 ∧ post_expr eo = e2. - Proof. - intros HEV He1 Hnectx Heq1 Heq2. - destruct (decide (length tp1' < length tp1)). - { pose proof (f_equal (λ x, x !! length tp1') Heq1) as Heq1'. - rewrite /= lookup_app_l // lookup_app_r // Nat.sub_diag /= in Heq1'. - pose proof (f_equal (λ x, x !! length tp1') Heq2) as Heq2'. - rewrite /= lookup_app_l // lookup_app_r // Nat.sub_diag /= in Heq2'. - rewrite Heq1' in Heq2'; simplify_eq. - apply ectx_fill_inj in Heq2'. - exfalso; eapply validEventObservation_exprs_neq; done. } - pose proof (f_equal (λ x, x !! length tp1') Heq1) as Heq1'. - rewrite /= lookup_app_r in Heq1'; last lia. - rewrite // lookup_app_r // Nat.sub_diag /= in Heq1'. - pose proof (f_equal (λ x, x !! length tp1') Heq2) as Heq2'. - rewrite /= lookup_app_r in Heq2'; last lia. - rewrite // lookup_app_r // Nat.sub_diag /= in Heq2'. - rewrite /= app_comm_cons lookup_app_l in Heq2'; last first. - { simpl. - assert (length tp1' < length tp1 + S (length tp2)); last lia. - pose proof (f_equal length Heq1) as Heq'. - rewrite !app_length //= in Heq'; lia. } - destruct (length tp1' - length tp1); last first. - { simpl in *. - rewrite Heq1' in Heq2'; simplify_eq. - apply ectx_fill_inj in Heq2'. - exfalso; eapply validEventObservation_exprs_neq; done. } - simplify_eq/=. - pose proof Heq1' as Heq1''. - apply ectx_fill_positive in Heq1'' as [[K'' ->]|[K'' ->]]; - [| |done| - by apply validEventObservation_not_val]. - - rewrite ectx_comp_comp in Heq2'. - apply ectx_fill_inj in Heq2'. - rewrite ectx_comp_comp in Heq1'. - apply ectx_fill_inj in Heq1'. - simplify_eq. - assert (K'' = ectx_emp) as ->. - { edestruct Hnectx as [[]|]; [done| |done]. - pose proof (validEventObservation_not_val _ HEV); simplify_eq. } - rewrite !ectx_fill_emp; done. - - rewrite ectx_comp_comp in Heq1'. - apply ectx_fill_inj in Heq1'. - rewrite ectx_comp_comp in Heq2'. - apply ectx_fill_inj in Heq2'. - assert (K'' = ectx_emp) as ->. - { edestruct @is_triggered_ectx_free as [[]|]; - [done|symmetry; done| |done]. - pose proof (validEventObservation_not_val _ HEV); simplify_eq. } - rewrite ectx_fill_emp in Heq1'. - rewrite ectx_fill_emp in Heq2'. - simplify_eq; done. - Qed. - - (** This lemma, proven completely constructively, is an evidence why we - are justified in using classical logic in constructing observations of - a valid execution trace. *) - Lemma trace_has_events_functional ex eobs eobs' : - valid_exec ex → - trace_has_events EV ex eobs → - trace_has_events EV ex eobs' → - eobs = eobs'. - Proof. - intros Hex; revert eobs eobs'. - induction Hex as [|ex [tp σ] oζ [tp' σ'] Hendsin Hstep Hex IHex]; - intros eobs eobs'. - { do 2 inversion 1; simplify_eq; done. } - inversion 1 as [|ex' [tpz σz] [tpy σy] tp1z tp2z ? ? obs3 ? eobs3 Hendsin'| - ex' [tpz σz] [tpy σy] ? ? Hendsin' Hnobs]; simplify_eq/=. - - pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin'); simplify_eq. - inversion 1 as [|ex' [tpx σx] [tpw σw] tp1x tp2x ? ? obs4 ? eobs4 Hendsin'' - ??? Htpseq| ex' [tpx σx] [tpw σw] ? ? Hendsin'' Hnobs]; - simplify_eq/=. - + repeat f_equal; first by apply IHex. - pose proof (trace_ends_in_inj _ _ _ Hendsin' Hendsin'') as Htpseq'. - simplify_eq Htpseq'; intros Htpseq'1 Htpseq'2; clear Htpseq'. - assert (pre_expr obs3 = pre_expr obs4 ∧ post_expr obs3 = post_expr obs4) - as [? ?]. - eapply event_in_the_middle; [done| | |done|]. - { apply validEventObservation_not_val; done. } - { intros; eapply is_triggered_ectx_free; eauto. } - { done. } - destruct obs3; destruct obs4; simplify_eq/=; done. - + pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin''); simplify_eq. - exfalso; eapply Hnobs; eauto. - - pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin'); simplify_eq. - inversion 1 as [|ex' [tpx σx] [tpw σw] ? ? ? ? obs4 eobs4 ? Hendsin''| - ex' [tpx σx] [tpw σw] ? Hendsin'' Hnobs']; simplify_eq/=. - + pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin''); simplify_eq. - exfalso; eapply Hnobs; eauto. - + apply IHex; done. - Qed. - - Lemma trace_has_valid_events ex eobs : - trace_has_events EV ex eobs → valid_event_obs EV eobs. - Proof. - induction 1; [constructor| |done]. - apply Forall_app_2; first done. - apply Forall_singleton; done. - Qed. - - Lemma events_for_trace ex : ∃ eobs, trace_has_events EV ex eobs. - Proof. - induction ex as [c|ex [eobs Hthe] ? c]. - { eexists; econstructor. } - destruct (ExcludedMiddle ((∃ tp1 tp2 efs K e1 e2, - (trace_last ex).1 = tp1 ++ ectx_fill K e1 :: tp2 ∧ - c.1 = tp1 ++ ectx_fill K e2 :: tp2 ++ efs ∧ - EV e1 (trace_last ex).2 e2 c.2))) as - [(tp1&tp2&efs&K&e1&e2&Heq1&Heq2&HEV)|Hnex]. - - exists (eobs ++ [mkEventObservation e1 (trace_last ex).2 e2 c.2]). - econstructor; eauto using trace_ends_in_last. - - exists eobs; econstructor; [done| |done]. - intros ?????????; apply Hnex; eauto 10. - Qed. - - Definition events_of_trace ex : event_obs Λ := epsilon (events_for_trace ex). - - Lemma trace_has_events_of_trace ex : - trace_has_events EV ex (events_of_trace ex). - Proof. apply (epsilon_correct _ (events_for_trace ex)). Qed. - - Lemma events_of_trace_valid ex : valid_event_obs EV (events_of_trace ex). - Proof. eapply trace_has_valid_events; apply trace_has_events_of_trace. Qed. - - Lemma events_of_trace_extend_same_tp ex c c' oζ: - valid_exec (ex :tr[oζ]: c') → - c.1 = c'.1 → - trace_ends_in ex c → - events_of_trace (ex :tr[oζ]: c') = events_of_trace ex. - Proof. - intros Hex Htps Hc. - destruct c as [tp σ]; destruct c' as [tp' σ']; simplify_eq/=. - cut (∀ eobs, trace_has_events EV (ex :tr[oζ]: (tp', σ')) eobs → events_of_trace ex = eobs). - { intros Help. erewrite Help; first done. apply trace_has_events_of_trace. } - intros eobs Heobs. - eapply trace_has_events_functional; [|apply trace_has_events_of_trace|]. - { inversion Hex; done. } - inversion Heobs as [|?????? K ??? Hei|]; simplify_eq/=; last done. - pose proof (trace_ends_in_inj _ _ _ Hc Hei); simplify_eq/=. - exfalso; eapply validEventObservation_exprs_neq; first done. - eapply ectx_fill_inj; done. - Qed. - - Lemma events_of_singleton_trace c : events_of_trace {tr[c]} = []. - Proof. - eapply trace_has_events_functional; - [constructor|apply trace_has_events_of_trace|constructor]. - Qed. - - Lemma events_of_trace_extend_pure ex c c' oζ: - (∀ eo, validEventObservation EV eo → eo.(pre_state) ≠ eo.(post_state)) → - valid_exec (ex :tr[oζ]: c') → - c.2 = c'.2 → - trace_ends_in ex c → - events_of_trace (ex :tr[oζ]: c') = events_of_trace ex. - Proof. - intros Himpure Hex Htps Hc. - destruct c as [tp σ]; destruct c' as [tp' σ']; simplify_eq/=. - cut (∀ eobs, trace_has_events EV (ex :tr[oζ]: (tp', σ')) eobs → events_of_trace ex = eobs). - { intros Help. erewrite Help; first done. apply trace_has_events_of_trace. } - intros eobs Heobs. - eapply trace_has_events_functional; [|apply trace_has_events_of_trace|]. - { inversion Hex; done. } - inversion Heobs as [|?????? K ??? Hei|]; simplify_eq/=; last done. - pose proof (trace_ends_in_inj _ _ _ Hc Hei); simplify_eq/=. - exfalso; eapply Himpure; eauto. - Qed. - - Definition event_is_triggered (ob : EventObservation Λ) (c c' : cfg Λ) := - ∃ K tp1 tp2 efs, - c.2 = ob.(pre_state) ∧ - c.1 = tp1 ++ ectx_fill K ob.(pre_expr) :: tp2 ∧ - c'.2 = ob.(post_state) ∧ - c'.1 = tp1 ++ ectx_fill K ob.(post_expr) :: tp2 ++ efs. - - Lemma events_of_trace_extend_app (ex : execution_trace Λ) (c : cfg Λ) oζ: - valid_exec (ex :tr[oζ]: c) → - ∃ evs, - length evs ≤ 1 ∧ - events_of_trace (ex :tr[oζ]: c) = events_of_trace ex ++ evs ∧ - ∀ ev, ev ∈ evs → event_is_triggered ev (trace_last ex) c. - Proof. - intros Hvl. - pose proof (trace_has_events_of_trace (ex :tr[oζ]: c)) as Hthe. - inversion Hthe as [|?????????? Hend|]; simplify_eq. - - eexists [_]; split; first done. - erewrite (trace_has_events_functional ex (events_of_trace ex)); - [|by eapply valid_exec_exec_extend_inv; eauto|by apply trace_has_events_of_trace|by eauto]. - split; first done. - intros ev; rewrite elem_of_list_singleton; intros ->. - apply last_eq_trace_ends_in in Hend; simplify_eq. - eexists _, _, _, _; eauto. - - exists []; split; simpl; first lia. - rewrite app_nil_r. - split; last set_solver. - apply (trace_has_events_functional (ex :tr[oζ]: c)); [done|by apply trace_has_events_of_trace|]. - eapply extend_not_observed; [eauto|eauto|by apply trace_has_events_of_trace]. - Qed. - - Lemma events_of_trace_app (ex : execution_trace Λ) (l : list (olocale Λ * cfg Λ)) : - valid_exec (ex +trl+ l) → - ∃ evs, - length evs ≤ length l ∧ - events_of_trace (ex +trl+ l) = events_of_trace ex ++ evs ∧ - ∀ ev oζ1 oζ2, - ev ∈ evs → - ∃ i c1 c2 oζ1' oζ2', - ((oζ1, trace_last ex) :: l) !! i = Some (oζ1', c1) ∧ - ((oζ2, trace_last ex) :: l) !! S i = Some (oζ2', c2) ∧ - event_is_triggered ev c1 c2. - Proof. - induction l as [|[??] ?] using rev_ind. - { exists []; rewrite /= app_nil_r; split_and!; [done|done|]. set_solver. } - rewrite -trace_append_list_assoc /=. - intros Hvl. - destruct IHl as (evs & Hevs1 & Hevs2 & Hevs3). - { eapply valid_exec_exec_extend_inv; eauto. } - apply events_of_trace_extend_app in Hvl as (evs' & Hevs'1 & Hevs'2 & Hevs'3). - rewrite Hevs2 in Hevs'2; rewrite Hevs'2. - rewrite -app_assoc. - eexists; split_and!; [|done|]. - { rewrite !app_length /=; lia. } - intros ev oζ1 oζ2 [Hev|Hev]%elem_of_app. - - destruct (Hevs3 ev oζ1 oζ2 Hev) as (i & c1 & c2 & oζ1' & oζ2' & Hc1 & Hc2 & Htrg). - exists i, c1, c2, oζ1', oζ2'. - rewrite (lookup_app_l (_ :: _)); last first. - { apply lookup_lt_Some in Hc1; simpl in *; lia. } - rewrite lookup_app_l; last first. - { apply lookup_lt_Some in Hc2; simpl in *; lia. } - done. - - destruct (trace_last_of_append_list ex l oζ1) as [oζ Heq]. - eexists (length l), _, _, oζ, _; split_and!; last by apply Hevs'3. - + rewrite -Heq. - rewrite (lookup_app_l (_ :: _)); first done. - simpl; lia. - + rewrite lookup_app_r; last done. - rewrite Nat.sub_diag //. - Qed. - - Lemma events_of_trace_app_map (ex : execution_trace Λ) (l : list (olocale Λ * cfg Λ)) : - valid_exec (ex +trl+ l) → - ∃ evs, - length evs ≤ length l ∧ - events_of_trace (ex +trl+ l) = events_of_trace ex ++ evs ∧ - ∀ ev, - ev ∈ evs → - ∃ i c1 c2, - (trace_last ex :: map snd l) !! i = Some c1 ∧ - (trace_last ex :: map snd l) !! S i = Some c2 ∧ - event_is_triggered ev c1 c2. - Proof. - intros Hval. destruct (events_of_trace_app ex l Hval) as (evs & Hlen & Hevs & H). - exists evs; repeat (split =>//). intros ev Hin. - destruct (H ev inhabitant inhabitant Hin) as (i & c1 & c2 & oζ1 & oζ2 & Hi & HSi & Htrig). - exists i, c1, c2. change (trace_last ex :: map snd l) with (map snd $ (inhabitant, trace_last ex) :: l). - rewrite ->!list_lookup_fmap, Hi, HSi. done. - Qed. -End properties. - -Section properties. - Context {Λ : ectxLanguage} (EV : Event Λ). - - Implicit Types e : expr Λ. - Implicit Types tp : list (expr Λ). - Implicit Types K : ectx Λ. - Implicit Types σ : state Λ. - Implicit Types eobs : event_obs Λ. - Implicit Types obs : EventObservation Λ. - Implicit Types ex : execution_trace Λ. - - Lemma events_of_trace_extend_triggered ex tp1 tp2 K e1 e2 efs σ1 σ2 oζ : - valid_exec ex → - trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → - head_step e1 σ1 e2 σ2 efs → - EV e1 σ1 e2 σ2 → - events_of_trace EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) = - events_of_trace EV ex ++ [mkEventObservation e1 σ1 e2 σ2]. - Proof. - intros HexV Hex Hhstep HEV. - pose proof (trace_has_events_of_trace - EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2))) as Hhasevs. - inversion Hhasevs as - [|??? tp1' tp2' efs' K' eo eobs ? Hei ? Heq1 ? Heq2 HEV' ? Heq3 Heq4| - ????? Hei HnEV]; simplify_eq. - - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq. - rewrite -Heq4. - assert (eobs = events_of_trace EV ex) as ->. - { eapply trace_has_events_functional; - [done|done| apply trace_has_events_of_trace]. } - repeat f_equal. simpl in *. - assert (pre_expr eo = e1 ∧ post_expr eo = e2) as [? ?]. - eapply event_in_the_middle; [done| | |done|]. - { eapply val_head_stuck; done. } - { intros ?? ->; eapply head_ctx_step_val; done. } - { done. } - destruct eo; simplify_eq/=; done. - - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq. - exfalso; eapply HnEV; eauto. - Qed. - - Lemma events_of_trace_extend_not_triggered ex tp1 tp2 K e1 e2 efs σ1 σ2 oζ: - valid_exec ex → - trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) → - head_step e1 σ1 e2 σ2 efs → - ¬ EV e1 σ1 e2 σ2 → - events_of_trace EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) = - events_of_trace EV ex. - Proof. - intros HexV Hex Hhstep HEV. - pose proof (trace_has_events_of_trace - EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2))) as Hhasevs. - inversion Hhasevs as - [|??? tp1' tp2' efs' K' eo eobs ? Hei ? Heq1 ? Heq2 HEV' ? Heq3 Heq4| - ????? Hei HnEV Hhasevs']; simplify_eq/=. - - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq/=. - exfalso. - assert (pre_expr eo = e1 ∧ post_expr eo = e2) as [? ?]. - eapply event_in_the_middle; [done| | |done|]. - { eapply val_head_stuck; done. } - { intros ?? ->; eapply head_ctx_step_val; done. } - { done. } - destruct eo; simplify_eq/=; done. - - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq. - eapply trace_has_events_functional; - [done|done| apply trace_has_events_of_trace]. - Qed. - -End properties. diff --git a/trillium/prelude/classical.v b/trillium/prelude/classical.v deleted file mode 100644 index daf71497..00000000 --- a/trillium/prelude/classical.v +++ /dev/null @@ -1,98 +0,0 @@ -From Coq.Unicode Require Import Utf8. - -Axiom FunExt : - ∀ (A : Type) (B : A → Type) (f g : ∀ x, B x), (∀ x, f x = g x) → f = g. - -Axiom PropExt : ∀ P Q : Prop, P ↔ Q → P = Q. - -Lemma ProofIrrelevance : ∀ P : Prop, ∀ p q : P, p = q. -Proof. - intros P p q. - assert (True = P) as HP. - { apply PropExt; split; auto. } - revert p q. - refine (match HP in _ = u return ∀ p q : u, p = q :> u with eq_refl => _ end). - intros [] []; trivial. -Qed. - -Axiom Choice : - ∀ A B (R : A → B → Prop), (∀ x, ∃ y, R x y) → {f : A → B | ∀ x, R x (f x)}. - -Definition epsilon {A : Type} {P : A → Prop} (Hex : ∃ x, P x) : A := - proj1_sig (Choice unit A (λ _ x, P x) (λ _, Hex)) tt. - -Lemma epsilon_correct {A : Type} (P : A → Prop) (Hex : ∃ x, P x) : - P (epsilon Hex). -Proof. - exact (proj2_sig (Choice unit A (λ _ x, P x) (λ _, Hex)) tt). -Qed. - -Lemma ExcludedMiddle (P : Prop) : P ∨ ¬ P. -Proof. - set (PA b := b = true ∨ P). - set (PB b := b = false ∨ P). - set (U := sig (λ s, s = PA ∨ s = PB)). - set (R := (λ u b, proj1_sig u b) : U → bool → Prop). - assert (∀ u, ∃ b, R u b) as HR. - { intros u. - unfold R. - destruct (proj2_sig u) as [->| ->]; unfold PA, PB; eauto. } - apply Choice in HR as [f Hf]. - set (A := exist _ _ (or_introl eq_refl) : U); simpl in *. - set (B := exist _ _ (or_intror eq_refl) : U); simpl in *. - assert (P ↔ A = B) as HPAB. - { split. - - intros HP. - unfold A, B. - assert (PA = PB) as ->. - { unfold PA, PB. - apply FunExt; intros x; apply PropExt; tauto. } - rewrite (ProofIrrelevance _ (or_introl eq_refl) (or_intror eq_refl)); - trivial. - - intros HAB. - assert (proj1_sig A = proj1_sig B) as HPAB; [rewrite HAB; trivial|]. - simpl in *. - assert (PA false) as HPAf; [rewrite HPAB; unfold PB; auto; fail|]. - destruct HPAf; [congruence| trivial]. } - pose proof (Hf A) as HfA. - pose proof (Hf B) as HfB. - simpl in *. - destruct (f A) eqn:Aeq. - - destruct (f B) eqn:Beq. - + destruct HfB; [congruence| auto]. - + right. intros HP; apply HPAB in HP. congruence. - - destruct HfA; [congruence| auto]. -Qed. - -Lemma NNP_P : ∀ P : Prop, ¬ ¬ P → P. -Proof. - intros P NNP. - destruct (ExcludedMiddle P); [trivial; fail|]. - exfalso; apply NNP; trivial. -Qed. - -Lemma P_NNP : ∀ P : Prop, P → ¬ ¬ P. -Proof. - intros P HP HnP; apply HnP; trivial. -Qed. - -Lemma contrapositive : ∀ P Q : Prop, (¬ Q → ¬ P) → P → Q. -Proof. - intros P Q Hcontra HP. - destruct (ExcludedMiddle Q); [trivial; fail|]. - exfalso; apply Hcontra; trivial. -Qed. - -Lemma not_exists_forall_not : - ∀ (A : Type) (P : A → Prop), ¬ (∃ x, P x) → ∀ x, ¬ P x. -Proof. intros A P Hnex x HP; apply Hnex; eauto. Qed. - -Lemma not_forall_exists_not : - ∀ (A : Type) (P : A → Prop), ¬ (∀ x, P x) → ∃ x, ¬ P x. -Proof. - intros A P. - apply contrapositive. - intros Hnex; apply P_NNP. - intros x; apply NNP_P; revert x. - apply not_exists_forall_not; trivial. -Qed. diff --git a/trillium/prelude/classical_instances.v b/trillium/prelude/classical_instances.v deleted file mode 100644 index 94979e42..00000000 --- a/trillium/prelude/classical_instances.v +++ /dev/null @@ -1,14 +0,0 @@ -From trillium.prelude Require Import classical. -From stdpp Require Import prelude. - -Lemma make_proof_irrel (P : Prop) : ProofIrrel P. -Proof. intros ??; apply ProofIrrelevance. Qed. - -Lemma make_decision P : Decision P. -Proof. - assert (∃ x : Decision P, True) as Hdecex. - { destruct (ExcludedMiddle P) as [HP|HnP]. - - exists (left HP); done. - - exists (right HnP); done. } - apply epsilon in Hdecex; done. -Qed. diff --git a/trillium/prelude/finitary.v b/trillium/prelude/finitary.v deleted file mode 100644 index ea29c32d..00000000 --- a/trillium/prelude/finitary.v +++ /dev/null @@ -1,663 +0,0 @@ -From Coq.Unicode Require Import Utf8. -From Coq.micromega Require Import Lia. -From trillium.prelude Require Import - classical quantifiers sigma classical_instances. -From stdpp Require Import finite fin_sets gmap list. - -Section finite_smaller_card_nat. - Context {A} `{!EqDecision A}. - - Fixpoint list_generated_by (f : nat → A) (n : nat) : list A := - match n with - | O => [f 0] - | S n => f (S n) :: list_generated_by f n - end. - - Lemma list_generated_by_length (f : nat → A) n : - length (list_generated_by f n) = S n. - Proof. induction n as [|? IHn]; [|simpl; rewrite IHn]; done. Qed. - - Lemma elem_of_list_generated_by (f : nat → A) n x : - x ∈ list_generated_by f n ↔ ∃ m, m ≤ n ∧ x = f m. - Proof. - split. - - induction n; simpl. - + intros ->%elem_of_list_singleton; eauto. - + intros [->|Hn]%elem_of_cons; [by eauto|]. - apply IHn in Hn as (?&?&?); eauto. - - intros [m [Hm1 ->]]. - revert m Hm1; induction n; intros m Hm. - + replace m with 0 by lia. - apply elem_of_list_singleton; done. - + destruct (decide (m = S n)) as [->|]. - * simpl; apply elem_of_cons; auto. - * simpl; apply elem_of_cons; auto with lia. - Qed. - - Lemma list_generated_by_NoDup (f : nat → A) n : - injective f → NoDup (list_generated_by f n). - Proof. - intros Hf. - induction n; simpl. - - repeat constructor; set_solver. - - constructor; [|done]. - intros (?&?&?%Hf)%elem_of_list_generated_by; lia. - Qed. - - Lemma finite_smaller_card_nat : Finite A → smaller_card A nat. - Proof. - destruct 1 as [enum Henum Hin]. - intros f Hf. - assert (length (list_generated_by f (length enum)) ≤ length enum) as Hlen. - { apply submseteq_length. - apply NoDup_submseteq; auto using list_generated_by_NoDup. } - rewrite list_generated_by_length in Hlen; lia. - Qed. - -End finite_smaller_card_nat. - -Definition surjective {A B} (f : A → B) := ∀ y, ∃ x, f x = y. - -Section smaller_card_nat_finite. - Context {A} `{!EqDecision A}. - - Section no_fin_inj. - Context (Hnfin : Finite A → False). - - Lemma no_fin_new_elem_exist (l : list A) : ∃ x, x ∉ l. - Proof. - destruct (ExcludedMiddle (∀ x : A, x ∈ l)); last first. - { apply not_forall_exists_not; done. } - exfalso; apply Hnfin. - refine {| enum := remove_dups l |}. - - apply NoDup_remove_dups. - - intros; apply elem_of_remove_dups; done. - Qed. - - Fixpoint no_fin_make_list (l : list A) (n : nat) : list A := - match n with - | 0 => l - | S n' => - no_fin_make_list l n' ++ - [epsilon (no_fin_new_elem_exist (no_fin_make_list l n'))] - end. - - Lemma no_fin_make_list_length l n : - length (no_fin_make_list l n) = length l + n. - Proof. - induction n as [|n IHn]; [simpl; lia|]. - simpl; rewrite app_length, IHn; simpl; lia. - Qed. - - Lemma no_fin_make_list_prefix l n1 n2 : - n1 ≤ n2 → (no_fin_make_list l n1) `prefix_of` (no_fin_make_list l n2). - Proof. - induction 1 as [|n2 IHn12]; [done|]. - simpl; apply prefix_app_r; done. - Qed. - - Lemma no_fin_make_list_NoDup l n : NoDup l → NoDup (no_fin_make_list l n). - Proof. - revert l; induction n; intros l Hl; [done|]. - simpl. - apply NoDup_app; split; [auto; done|]. - split; [|apply NoDup_singleton]. - intros x Hx ->%elem_of_list_singleton. - apply (epsilon_correct _ (no_fin_new_elem_exist (no_fin_make_list l n))); - done. - Qed. - - Definition no_fin_make_inj_fun (n : nat) : A := - default (epsilon (no_fin_new_elem_exist [])) (no_fin_make_list [] (S n) !! n). - - Lemma no_fin_make_inj_fun_inj : injective no_fin_make_inj_fun. - Proof. - assert (∀ n m, n ≤ m → no_fin_make_inj_fun n = no_fin_make_inj_fun m → n = m) - as Hnm. - { intros n m Hnm Hfnm. - unfold no_fin_make_inj_fun in Hfnm. - pose proof (lookup_lt_is_Some_2 (no_fin_make_list [] (S n)) n) as [k Hk]. - { rewrite no_fin_make_list_length; lia. } - pose proof (lookup_lt_is_Some_2 (no_fin_make_list [] (S m)) m) as [l Hl]. - { rewrite no_fin_make_list_length; lia. } - rewrite Hk, Hl in Hfnm; simpl in Hfnm; simplify_eq. - apply (NoDup_lookup (no_fin_make_list [] (S m)) n m l); [| |done]. - - apply no_fin_make_list_NoDup, NoDup_nil_2. - - apply (prefix_lookup_Some - (no_fin_make_list [] (S n)) (no_fin_make_list [] (S m)) n l); - [done|]. - apply no_fin_make_list_prefix; lia. - } - intros n m. - destruct (decide (n < m)). - - apply Hnm; lia. - - intros; symmetry; apply Hnm; [lia|done]. - Qed. - - End no_fin_inj. - - Lemma smaller_card_nat_finite : smaller_card A nat → Finite A. - Proof. - intros HA. - apply (epsilon (P := λ _, True)). - destruct (ExcludedMiddle (∃ _ : Finite A, True)); [done|]. - assert (∀ x : Finite A, False) as Hnfin. - { cut (∀ x : Finite A, ¬ True); [tauto|]. - eapply not_exists_forall_not; done. } - exfalso. - apply (HA (no_fin_make_inj_fun Hnfin)). - apply no_fin_make_inj_fun_inj. - Qed. - -End smaller_card_nat_finite. - -(* move *) - -Lemma NoDup_list_prod {A B} (l : list A) (l' : list B) : - NoDup l → NoDup l' → NoDup (list_prod l l'). -Proof. - revert l'; induction l as [|a l]; intros l' Hl Hl'. - { apply NoDup_nil_2. } - inversion Hl; simplify_eq. - simpl. - apply NoDup_app; split; [|split]. - - apply NoDup_fmap; [|done]. - intros ? ?; inversion 1; trivial. - - intros [x y] [z [Hz1 Hz2]]%elem_of_list_fmap; simplify_eq. - intros Hin%elem_of_list_In. - apply in_prod_iff in Hin as [Hin1%elem_of_list_In Hin2]; done. - - apply IHl; done. -Qed. - -Section finite_lemmas. - Context `{!EqDecision A} `{!EqDecision B}. - - Program Instance sig_finite_and (P : A → Prop) (Q : B → Prop) - `{!∀ x, Decision (P x)} `{!∀ x, ProofIrrel (P x)} - `{!∀ x, Decision (Q x)} `{!∀ x, ProofIrrel (Q x)} - (HfP : Finite {x : A | P x}) - (HfQ : Finite {x : B | Q x}) : - Finite {x : A * B | P (fst x) ∧ (Q (snd x))} := - {| enum := - (λ x, sig_prod_and x.1 x.2) - <$> (list_prod (@enum _ _ HfP) (@enum _ _ HfQ)) |}. - Next Obligation. - Proof. - intros. - apply NoDup_fmap. - { intros [[] []] [[] []]. - unfold sig_prod_and; simpl; inversion 1; simplify_eq. - f_equal; apply sig_eq; done. } - apply NoDup_list_prod; apply NoDup_enum. - Qed. - Next Obligation. - Proof. - intros ? ? ? ? ? ? ? ? [[a b] [Ha Hb]]. - apply elem_of_list_fmap. - exists (a ↾ Ha, b ↾ Hb); split. - { apply sig_eq; done. } - apply elem_of_list_In, in_prod_iff. - split; apply elem_of_list_In, elem_of_enum. - Qed. - - Program Definition sig_finite_and2 (P : A → Prop) (Q : A → Prop) - `{!∀ x, Decision (P x)} `{!∀ x, ProofIrrel (P x)} - `{!∀ x, Decision (Q x)} `{!∀ x, ProofIrrel (Q x)} - (HfP : Finite {x : A | P x}) : - Finite {x : A | P x ∧ Q x} := - {| enum := sig_and_list P Q (@enum _ _ HfP) |}. - Next Obligation. - Proof. - intros. - assert (NoDup (enum {x : A | P x})) as HNoDup by apply NoDup_enum. - induction enum as [|e enum IHenum]; [by apply NoDup_nil|]=> /=. - destruct (decide (Q (`e))); [|by eapply IHenum, NoDup_cons_1_2]. - apply NoDup_cons. - split; [|by eapply IHenum, NoDup_cons_1_2]. - apply NoDup_cons in HNoDup as [HNoDup1 HNoDup2]. - intros Hin. apply HNoDup1. - by eapply sig_and_list_le. - Qed. - Next Obligation. - Proof. - intros. - assert (∀ (x : {x : A | P x}), x ∈ enum {x : A | P x}) - as Hin by apply elem_of_enum. - destruct x as [x [HP HQ]]. - specialize (Hin (exist _ _ HP)). - induction enum as [|e enum IHenum]; [by apply elem_of_nil in Hin|]. - apply elem_of_cons in Hin as [Hin|Hin]; simplify_eq /=. - - case_decide as HQ'; [|done]. - pose proof (proof_irrel HQ HQ') as <-; simplify_eq. - apply elem_of_cons. by left. - - case_decide; [right|]; by apply IHenum. - Qed. - - Program Instance sig_finite_eq1 (a : A) : Finite {x : A | x = a} := - {| enum := [a ↾ eq_refl] |}. - Next Obligation. - Proof. intros; apply NoDup_singleton. Qed. - Next Obligation. - Proof. intros ? [? ?]; apply elem_of_list_singleton; apply sig_eq; done. Qed. - - Program Instance sig_finite_eq2 (a : A) : Finite {x : A | a = x} := - {| enum := [a ↾ eq_refl] |}. - Next Obligation. - Proof. intros; apply NoDup_singleton. Qed. - Next Obligation. - Proof. intros ? [? ?]; apply elem_of_list_singleton; apply sig_eq; done. Qed. - - Program Instance sig_finite_or (P : A → Prop) (Q : A → Prop) - `{!∀ x, Decision (P x)} `{!∀ x, ProofIrrel (P x)} - `{!∀ x, Decision (Q x)} `{!∀ x, ProofIrrel (Q x)} - `{!EqDecision {x : A | P x ∨ Q x}} - (HfP : Finite {x : A | P x}) - (HfQ : Finite {x : A | Q x}) : - Finite {x : A | P x ∨ Q x} := - {| enum := - remove_dups ((sig_prod_or_l <$> (@enum _ _ HfP)) - ++ (sig_prod_or_r <$> (@enum _ _ HfQ))) |}. - Next Obligation. - Proof. intros; apply NoDup_remove_dups. Qed. - Next Obligation. - Proof. - intros ? ? ? ? ? ? ? ? ? [a [Ha|Ha]]. - - pose proof (@elem_of_enum _ _ HfP (a ↾ Ha)). - apply elem_of_remove_dups. - apply elem_of_app. - left. - apply elem_of_list_fmap; eexists; split; last done; done. - - pose proof (@elem_of_enum _ _ HfQ (a ↾ Ha)). - apply elem_of_remove_dups. - apply elem_of_app. - right. - apply elem_of_list_fmap; eexists; split; last done; done. - Qed. - -End finite_lemmas. - -Section in_gset_finite. - Context `{!EqDecision A, !Countable A}. - Context {P : A → Prop} `{!∀ x : A, ProofIrrel (P x)}. - - Local Instance: ∀ x, Decision (P x). - Proof. intros ?; apply make_decision. Qed. - - Program Fixpoint Forall_to_sig (l : list A) : Forall P l → list (sig P) := - match l as u return Forall P u → list (sig P) with - | [] => λ _, [] - | a :: l' => λ Hal, (exist P a _) :: Forall_to_sig l' _ - end. - Next Obligation. - Proof. intros ?; inversion 1; simplify_eq; done. Qed. - Next Obligation. - Proof. intros ?; inversion 1; simplify_eq; done. Qed. - - Lemma elem_of_Forall_to_sig_1 l HPl x : x ∈ Forall_to_sig l HPl → `x ∈ l. - Proof. - revert HPl; induction l as [|a l IHl]; simpl; intros HPl Hx. - - by apply elem_of_nil in Hx. - - apply elem_of_cons; apply elem_of_cons in Hx as [->|]; simpl in *; eauto. - Qed. - - Lemma elem_of_Forall_to_sig_2 l HPl x : - x ∈ l → ∃ Hx, x ↾ Hx ∈ Forall_to_sig l HPl. - Proof. - revert HPl; induction l as [|a l IHl]; simpl; intros HPl Hx. - - by apply elem_of_nil in Hx. - - inversion HPl as [|? ? Ha HPl']; simplify_eq. - apply elem_of_cons in Hx as [->|]; simpl in *. - + exists Ha; apply elem_of_cons; left; apply sig_eq; done. - + edestruct IHl as [Hx Hxl]; first done. - exists Hx; apply elem_of_cons; eauto. - Qed. - - Lemma Forall_to_sig_NoDup l HPl : NoDup l → NoDup (Forall_to_sig l HPl). - Proof. - revert HPl; induction l as [|a l IHl]; simpl; - intros HPl; first by constructor. - inversion 1; inversion HPl; simplify_eq. - constructor; last by apply IHl. - intros ?%elem_of_Forall_to_sig_1; done. - Qed. - - Lemma in_gset_finite (g : gset A) : (∀ x, P x → x ∈ g) → Finite {x : A | P x}. - Proof. - intros Hg. - assert (Forall P (filter P (elements g))) as Hels. - { apply Forall_forall. intros ?; rewrite elem_of_list_filter; tauto. } - refine {| enum := Forall_to_sig (filter P (elements g)) Hels |}. - - apply Forall_to_sig_NoDup. apply NoDup_filter. apply NoDup_elements. - - intros x. - edestruct (elem_of_Forall_to_sig_2 _ Hels) as [Hx' ?]. - { apply elem_of_list_filter; split; first apply (proj2_sig x). - apply elem_of_elements, Hg; apply (proj2_sig x). } - replace x with (`x ↾ Hx'); last by apply sig_eq. - done. - Qed. - -End in_gset_finite. - -Section in_list_finite. - Context `{!EqDecision A}. - Context {P : A → Prop} `{!∀ x : A, ProofIrrel (P x)}. - - Local Instance: ∀ x, Decision (P x). - Proof. intros ?; apply make_decision. Qed. - - Lemma in_list_finite (l : list A) : (∀ x, P x → x ∈ l) → Finite {x : A | P x}. - Proof. - intros Hl. - assert (Forall P (filter P (remove_dups l))) as Hels. - { apply Forall_forall. intros ?; rewrite elem_of_list_filter; tauto. } - refine {| enum := Forall_to_sig (filter P (remove_dups l)) Hels |}. - - apply Forall_to_sig_NoDup. apply NoDup_filter, NoDup_remove_dups. - - intros x. - edestruct (elem_of_Forall_to_sig_2 _ Hels) as [Hx' ?]. - { apply elem_of_list_filter; split; first apply (proj2_sig x). - apply elem_of_remove_dups, Hl; apply (proj2_sig x). } - replace x with (`x ↾ Hx'); last by apply sig_eq. - done. - Qed. - -End in_list_finite. - -Require Import Coq.Logic.Epsilon. -Require Import Coq.Sorting.Permutation. - -Section finite_range_gmap. - Context `{!EqDecision K, !Countable K}. - - Definition set_choose_L' (X: gset K) (Hne: X ≠ ∅): { k : K | k ∈ X } := - constructive_indefinite_description _ (set_choose_L X Hne). - - Fixpoint enumerate_gmaps (D: list K) (N: nat) : list (gmap K nat) := - match D with - | [] => [ ∅ ] - | k::ks => - m1 ← enumerate_gmaps ks N; - new ← seq 0 (N+1); - mret (<[ k := new ]> m1) - end. - - Local Instance all_the_instances A (P: A -> Prop) : ∀ x, Decision (P x). - Proof. intros ?; apply make_decision. Qed. - - Lemma enumerate_gmaps_spec N l D m : - elements D ≡ₚ l ∧ dom m = D ∧ - map_Forall (λ (_ : K) (v : nat), v ≤ N) m → m ∈ enumerate_gmaps l N. - Proof. - revert l D m. - induction l; intros D m. - - { simpl. intros (Hel&Hl&?). eapply list.Permutation_nil_r in Hel. apply elements_empty_inv in Hel. - rewrite leibniz_equiv_iff in Hel. rewrite Hel in *. - apply dom_empty_inv_L in Hl as ->. set_solver. } - simpl. intros (Hel & Hl & Hbound). - - assert (Hdecomp: ∃ m1 m2, m = m1 ∪ m2 ∧ dom m1 = {[a]} ∧ dom m2 = list_to_set l). - { assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)). - { by rewrite Hel. } - rewrite list_to_set_elements_L in H. simpl in H. rewrite <-Hl in H. - apply dom_union_inv_L in H as (m1&m2&Hunion&Hmdisj&[Hdom1 Hdom2]); eauto. - assert (a ∉ l); last set_solver. - assert (NoDup (a :: l)). - - rewrite <-Hel. apply NoDup_elements. - - by apply NoDup_cons_1_1. } - - destruct Hdecomp as (m1&m2&Hunion&Hdom1&Hdom2). rewrite Hunion in *. - assert (Hanotin: a ∉ dom m2). - { rewrite Hdom2, elem_of_list_to_set. - apply NoDup_cons_1_1. rewrite <-Hel. apply NoDup_elements. } - apply dom_singleton_inv_L in Hdom1 as [v ->]. - apply elem_of_list_bind. exists m2; split; last first. - - apply (IHl (dom m2)). repeat split. - + rewrite <-Hl in Hel. rewrite dom_union in Hel. - rewrite dom_singleton in Hel. - rewrite elements_union_singleton in Hel; last done. - by eapply Permutation_cons_inv. - + eapply map_Forall_union_1_2; eauto. - apply map_disjoint_singleton_l_2. by apply not_elem_of_dom. - - apply elem_of_list_bind. exists v; split; last first. - { specialize (Hbound a v). rewrite <-insert_union_singleton_l, lookup_insert in Hbound. - specialize (Hbound eq_refl). - apply elem_of_seq. split; lia. } - rewrite insert_union_singleton_l. set_solver. - Qed. - - Local Instance proof_irrel_P D N (m: gmap K nat): - ProofIrrel (dom m = D ∧ map_Forall (λ _ v, v <= N) m). - Proof. apply make_proof_irrel. Qed. - - Lemma bounded_maps_finite (D: gset K) (N : nat): - Finite { m : gmap K nat | dom m = D ∧ map_Forall (λ _ v, v <= N) m}. - Proof. - apply (in_list_finite (enumerate_gmaps (elements D) N)). - intros **. by eapply enumerate_gmaps_spec. - Qed. - - Definition enum_gmap_bounded (D: gset K) (N : nat): list (gmap K nat) := - enumerate_gmaps (elements D) N. - - Lemma enum_gmap_bounded_spec N D m: - dom m = D ∧ map_Forall (λ (_ : K) (v : nat), v ≤ N) m → m ∈ enum_gmap_bounded D N. - Proof. - intros **. unfold enum_gmap_bounded. eapply enumerate_gmaps_spec; done. - Qed. - - Lemma enum_gmap_dom N D: - Forall (λ m, dom m = D) (enum_gmap_bounded D N). - Proof. - assert (Hok: forall l D, - elements D ≡ₚ l -> Forall (λ m, dom m = D) (enumerate_gmaps l N) - ); last first. - { rewrite Forall_forall. setoid_rewrite Forall_forall in Hok. by apply Hok. } - induction l. - { intros ? Hp. eapply list.Permutation_nil_r in Hp. eauto. apply elements_empty_inv in Hp. - rewrite leibniz_equiv_iff in Hp. rewrite Hp. simpl. by rewrite Forall_singleton, dom_empty_L. } - clear D. intros D Hel. simpl. rewrite Forall_forall. intros m Hin. - apply elem_of_list_bind in Hin as (m'&Hin&Hin'). - - assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)). - { by rewrite Hel. } - rewrite list_to_set_elements_L in H. simpl in H. - rewrite H in Hel. rewrite elements_union_singleton in Hel; last first. - { rewrite elem_of_list_to_set. apply NoDup_cons_1_1. rewrite <-Hel. - apply NoDup_elements. } - - apply Permutation_cons_inv in Hel; eauto. - setoid_rewrite Forall_forall in IHl. specialize (IHl (list_to_set l) Hel _ Hin'). - - rewrite H. - apply elem_of_list_bind in Hin as (?&Hfin&Hseq). - apply elem_of_list_singleton in Hfin as ->. - rewrite dom_insert_L, IHl. done. - Qed. - - Definition enum_gmap_bounded' (D: gset K) (N : nat): list { m : (gmap K nat) | dom m = D }:= - Forall_to_sig _ (enum_gmap_dom N D). - - Lemma enum_gmap_bounded'_spec N D m Hdom: - dom m = D ∧ map_Forall (λ (_ : K) (v : nat), v ≤ N) m → m ↾ Hdom ∈ enum_gmap_bounded' D N. - Proof. - intros * H. apply enum_gmap_bounded_spec, - (elem_of_Forall_to_sig_2 _ (enum_gmap_dom N D)) in H as [Hdom' ?]. - assert (Hdom = Hdom') as -> by apply ProofIrrelevance. done. - Qed. - -End finite_range_gmap. - -Section finite_range_gmap. - Context {A : Type}. - Context `{!EqDecision K, !Countable K, !EqDecision A}. - - Fixpoint enumerate_range_gmaps (D: list K) (lr: list A) : list (gmap K A) := - match D with - | [] => [ ∅ ] - | k::ks => - m1 ← enumerate_range_gmaps ks lr; - new ← lr; - mret (<[ k := new ]> m1) - end. - - Local Instance all_the_range_instances B (P: B -> Prop) : ∀ x, Decision (P x). - Proof. intros ?; apply make_decision. Qed. - - Lemma enumerate_range_gmaps_spec l lr D m: - elements D ≡ₚ l ∧ dom m = D ∧ - map_Forall (λ (_ : K) (v : A), v ∈ lr) m → m ∈ enumerate_range_gmaps l lr. - Proof. - revert l D m. - induction l; intros D m. - - { simpl. intros (Hel&Hl&?). eapply list.Permutation_nil_r in Hel. apply elements_empty_inv in Hel. - rewrite leibniz_equiv_iff in Hel. rewrite Hel in *. - apply dom_empty_inv_L in Hl as ->. set_solver. } - simpl. intros (Hel & Hl & Hbound). - - assert (Hdecomp: ∃ m1 m2, m = m1 ∪ m2 ∧ dom m1 = {[a]} ∧ dom m2 = list_to_set l). - { assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)). - { by rewrite Hel. } - rewrite list_to_set_elements_L in H. simpl in H. rewrite <-Hl in H. - apply dom_union_inv_L in H as (m1&m2&Hunion&Hmdisj&[Hdom1 Hdom2]); eauto. - assert (a ∉ l); last set_solver. - assert (NoDup (a :: l)). - - rewrite <-Hel. apply NoDup_elements. - - by apply NoDup_cons_1_1. } - - destruct Hdecomp as (m1&m2&Hunion&Hdom1&Hdom2). rewrite Hunion in *. - assert (Hanotin: a ∉ dom m2). - { rewrite Hdom2, elem_of_list_to_set. - apply NoDup_cons_1_1. rewrite <-Hel. apply NoDup_elements. } - apply dom_singleton_inv_L in Hdom1 as [v ->]. - apply elem_of_list_bind. exists m2; split; last first. - - apply (IHl (dom m2)). repeat split. - + rewrite <-Hl in Hel. rewrite dom_union in Hel. - rewrite dom_singleton in Hel. - rewrite elements_union_singleton in Hel; last done. - by eapply Permutation_cons_inv. - + eapply map_Forall_union_1_2; eauto. - apply map_disjoint_singleton_l_2. by apply not_elem_of_dom. - - apply elem_of_list_bind. exists v; split; last first. - { specialize (Hbound a v). rewrite <-insert_union_singleton_l, lookup_insert in Hbound. - by specialize (Hbound eq_refl). } - rewrite insert_union_singleton_l. set_solver. - Qed. - - Local Instance proof_irrel_range_P D (lr : list A) (m: gmap K A): - ProofIrrel (dom m = D ∧ map_Forall (λ _ v, v ∈ lr) m). - Proof. apply make_proof_irrel. Qed. - - Lemma bounded_range_maps_finite (D: gset K) (lr: list A): - Finite { m : gmap K A | dom m = D ∧ map_Forall (λ _ v, v ∈ lr) m}. - Proof. - apply (in_list_finite (enumerate_range_gmaps (elements D) lr)). - intros **. by eapply enumerate_range_gmaps_spec. - Qed. - - Definition enum_gmap_range_bounded (D: gset K) (lr : list A): list (gmap K A) := - enumerate_range_gmaps (elements D) lr. - - Lemma enum_gmap_range_bounded_spec D m (lr : list A): - dom m = D ∧ map_Forall (λ (_ : K) (v : A), v ∈ lr) m → m ∈ enum_gmap_range_bounded D lr. - Proof. - intros **. unfold enum_gmap_range_bounded. eapply enumerate_range_gmaps_spec; done. - Qed. - - Lemma enum_gmap_range_dom lr D: - Forall (λ m, dom m = D) (enum_gmap_range_bounded D lr). - Proof. - assert (Hok: forall l D, - elements D ≡ₚ l -> Forall (λ m, dom m = D) (enumerate_range_gmaps l lr) - ); last first. - { rewrite Forall_forall. setoid_rewrite Forall_forall in Hok. by apply Hok. } - induction l. - { intros ? Hp. eapply list.Permutation_nil_r in Hp. eauto. apply elements_empty_inv in Hp. - rewrite leibniz_equiv_iff in Hp. rewrite Hp. simpl. by rewrite Forall_singleton, dom_empty_L. } - clear D. intros D Hel. simpl. rewrite Forall_forall. intros m Hin. - apply elem_of_list_bind in Hin as (m'&Hin&Hin'). - - assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)). - { by rewrite Hel. } - rewrite list_to_set_elements_L in H. simpl in H. - rewrite H in Hel. rewrite elements_union_singleton in Hel; last first. - { rewrite elem_of_list_to_set. apply NoDup_cons_1_1. rewrite <-Hel. - apply NoDup_elements. } - - apply Permutation_cons_inv in Hel; eauto. - setoid_rewrite Forall_forall in IHl. specialize (IHl (list_to_set l) Hel _ Hin'). - - rewrite H. - apply elem_of_list_bind in Hin as (?&Hfin&Hseq). - apply elem_of_list_singleton in Hfin as ->. - rewrite dom_insert_L, IHl. done. - Qed. - - Definition enum_gmap_range_bounded' (D: gset K) (lr : list A): - list { m : (gmap K A) | dom m = D } - := Forall_to_sig _ (enum_gmap_range_dom lr D). - - Lemma enum_gmap_range_bounded'_spec lr D m Hdom: - dom m = D ∧ map_Forall (λ (_ : K) (v : A), v ∈ lr) m → m ↾ Hdom ∈ enum_gmap_range_bounded' D lr. - Proof. - intros * H. apply enum_gmap_range_bounded_spec, - (elem_of_Forall_to_sig_2 _ (enum_gmap_range_dom lr D)) in H as [Hdom' ?]. - assert (Hdom = Hdom') as -> by apply ProofIrrelevance. done. - Qed. - -End finite_range_gmap. - - -Section enumerate_gsets. - Context {A : Type}. - Context `{!EqDecision A, !Countable A}. - - Fixpoint enumerate_dom_gsets (D: list A) : list (gset A) := - match D with - | [] => [ ∅ ] - | k::ks => - s_wo ← enumerate_dom_gsets ks; - b ← [ true; false]; - if (b : bool) then mret s_wo else mret $ {[ k ]} ∪ s_wo - end. - - Definition enumerate_dom_gsets' (D: gset A) : list (gset A) := - enumerate_dom_gsets (elements D). - - Local Instance all_the_range_instances' B (P: B -> Prop) : ∀ x, Decision (P x). - Proof. intros ?; apply make_decision. Qed. - - Lemma enumerate_gsets_spec D l m : - elements D ≡ₚ l ∧ m ⊆ D → m ∈ enumerate_dom_gsets l. - Proof. - revert l D m. - induction l; intros D m. - - { simpl. intros (Hel&Hl). eapply list.Permutation_nil_r in Hel. apply elements_empty_inv in Hel. - rewrite leibniz_equiv_iff in Hel. rewrite Hel in *. assert (m = ∅); set_solver. } - simpl. intros (Hel & Hl). - - assert (Hdecomp: ∃ m1 m2, m = m1 ∪ m2 ∧ m1 ⊆ {[a]} ∧ m2 ⊆ list_to_set l). - { assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)). - { by rewrite Hel. } - rewrite list_to_set_elements_L in H. simpl in H. exists (m ∩ {[a]}), (m ∩ list_to_set l). - split; last split; [set_solver|set_solver|set_solver]. } - - destruct Hdecomp as (m1&m2&Hunion&Hdom1&Hdom2). rewrite Hunion in *. - assert (Hanotin: a ∉ m2). - { intros contra. eapply elem_of_subseteq in contra; eauto. rewrite elem_of_list_to_set in contra. - assert (a ∉ l); last done. apply NoDup_cons_1_1. rewrite <-Hel. apply NoDup_elements. } - apply elem_of_list_bind. exists m2; split; last first. - - apply (IHl (list_to_set l)). split; last set_solver. apply elements_list_to_set. - eapply (NoDup_cons_1_2 a). rewrite <-Hel. apply NoDup_elements. - - destruct (decide (a ∈ m1)). - + assert (m1 = {[a]}) by set_solver. simplify_eq. set_solver. - + assert (m1 = ∅) by set_solver. simplify_eq. rewrite union_empty_l_L. set_solver. - Qed. - - Lemma enumerate_dom_gsets'_spec D s: - s ⊆ D → s ∈ enumerate_dom_gsets' D. - Proof. - intros H. unfold enumerate_dom_gsets'. eapply (enumerate_gsets_spec D). split; set_solver. - Qed. -End enumerate_gsets. diff --git a/trillium/prelude/fixpoint.v b/trillium/prelude/fixpoint.v deleted file mode 100644 index ccf39e82..00000000 --- a/trillium/prelude/fixpoint.v +++ /dev/null @@ -1,27 +0,0 @@ -From Coq.Unicode Require Import Utf8. -From Coq.ssr Require Import ssreflect. - -Definition monotone {A} (Ψ : (A → Prop) → (A → Prop)) := - ∀ (P Q : A → Prop), (∀ x, P x → Q x) → ∀ x, Ψ P x → Ψ Q x. - -Definition GFX {A} (Ψ : (A → Prop) → (A → Prop)) : A → Prop := - λ x, ∃ P, P x ∧ (∀ x, P x → Ψ P x). - -Lemma GFX_post_fixpoint {A} (Ψ : (A → Prop) → (A → Prop)) : - monotone Ψ → ∀ x, GFX Ψ x → Ψ (GFX Ψ) x. -Proof. - intros Hmono x (P & HP & HΨP). - eapply Hmono; [|by apply HΨP]. - intros; exists P; split; auto. -Qed. - -Lemma GFX_fixpoint {A} (Ψ : (A → Prop) → (A → Prop)) : - monotone Ψ → ∀ x, Ψ (GFX Ψ) x ↔ GFX Ψ x. -Proof. - intros Hmono x; split. - - intros HΨ. - exists (Ψ (GFX Ψ)); split; first done. - intros ? ?; eapply Hmono; last by eauto. - apply GFX_post_fixpoint; done. - - apply GFX_post_fixpoint; done. -Qed. diff --git a/trillium/prelude/iris_extraction.v b/trillium/prelude/iris_extraction.v deleted file mode 100644 index 39fa8cac..00000000 --- a/trillium/prelude/iris_extraction.v +++ /dev/null @@ -1,211 +0,0 @@ -From iris.base_logic Require Import bi. -From trillium.prelude Require Import quantifiers. -From iris.proofmode Require Import tactics. - -Import uPred. - -Local Arguments uPred_holds _ !_. - -Section extraction. - Context {M : ucmra}. - - Lemma extract_forall {A} (Φ : A → uPred M) : (⊢ ∀ x, Φ x) ↔ (∀ x, ⊢ Φ x). - Proof. - split; intros HP. - - constructor; unseal. - intros ? ? ? _. - destruct HP as [HP]; revert HP; unseal; intros HP. - apply HP; auto. - - iIntros (x); iApply HP. - Qed. - - Local Coercion uPred_holds : uPred >-> Funclass. - - Lemma extract_exists {A} (Φ : A → uPred M) : - smaller_card A nat → (⊢ ∃ x, Φ x) ↔ (∃ x, ⊢ Φ x). - Proof. - intros Hcard. - split; intros HP. - - destruct HP as [HP]; revert HP; unseal; intros HP. - assert (∀ n, ∃ x, Φ x n ε) as HP'. - { intros; apply HP; eauto using ucmra_unit_validN. } - apply (forall_exists_swap _ le) in HP' as [x Hx]; - auto using nat_regular with lia; last first. - { intros ?????; eapply uPred_mono; eauto. } - exists x. - constructor; unseal. - intros ? ? ? _. - eapply uPred_mono; [apply Hx|apply ucmra_unit_leastN |auto]. - - destruct HP as [x Hx]. - iExists _; iApply Hx. - Qed. - - Lemma extract_exists_alt {A} (P : A → Prop) (Φ : A → uPred M) : - smaller_card (sig P) nat → (⊢ ∃ x, ⌜P x⌝ ∧ Φ x) ↔ (∃ x, ⊢ ⌜P x⌝ ∧ Φ x). - Proof. - intros Hcard. - split; intros HP. - - assert (⊢ ∃ x : sig P, Φ (proj1_sig x)) as HP'. - { iDestruct HP as (x) "[HPx Hx]". - iDestruct "HPx" as %HPx. - iExists (exist _ _ HPx); done. } - apply extract_exists in HP' as [[x HPx] HΦ]; last done. - eexists; iSplit; done. - - destruct HP as [x Hx]. - iExists _; iApply Hx. - Qed. - - Lemma extract_exists_alt2 {A B} (P : A -> B → Prop) (Φ : A → B -> uPred M) : - smaller_card (sig (fun '(x, y) => P x y)) nat → (⊢ ∃ x y, ⌜P x y⌝ ∧ Φ x y) ↔ (∃ x y, ⊢ ⌜P x y⌝ ∧ Φ x y). - Proof. - intros Hcard. - split; intros HP. - - assert (⊢ ∃ x : sig (fun '(x, y) => P x y), Φ (proj1_sig x).1 (proj1_sig x).2)%I as HP'. - { iDestruct HP as (x y) "[HPx Hx]". - iDestruct "HPx" as %HPx. - iExists (exist _ (x,y) HPx); done. } - apply extract_exists in HP' as [[x HPx] HΦ]; last done. - eexists _,_; iSplit; eauto. by iPureIntro; destruct x. - - destruct HP as [x [y Hxy]]. - by iExists _, _. - Qed. - - Lemma extract_and (P Q : uPred M) : (⊢ P ∧ Q) ↔ ((⊢ P) ∧ (⊢ Q)). - Proof. - split; intros HPQ. - - destruct HPQ as [HPQ]; revert HPQ; unseal; intros HPQ. - repeat constructor; intros ? ? ? _; apply HPQ; auto. - - destruct HPQ as [HP HQ]. - iSplit; [iApply HP|iApply HQ]. - Qed. - - Lemma extract_or (P Q : uPred M) : (⊢ P ∨ Q) ↔ ((⊢ P) ∨ (⊢ Q)). - Proof. - split; intros HPQ. - - assert (⊢ ∃ b : bool, if b then P else Q) as HPQ'. - { iPoseProof HPQ as "[HP|HQ]"; [iExists true|iExists false]; done. } - apply extract_exists in HPQ'; last first. - { intros f Hf. - destruct (f 0) eqn:Hf0; destruct (f 1) eqn:Hf1. - - rewrite -Hf1 in Hf0; apply Hf in Hf0; lia. - - destruct (f 2) eqn:Hf2. - + rewrite -Hf2 in Hf0; apply Hf in Hf0; lia. - + rewrite -Hf2 in Hf1; apply Hf in Hf1; lia. - - destruct (f 2) eqn:Hf2. - + rewrite -Hf2 in Hf1; apply Hf in Hf1; lia. - + rewrite -Hf2 in Hf0; apply Hf in Hf0; lia. - - rewrite -Hf1 in Hf0; apply Hf in Hf0; lia. } - destruct HPQ' as [[|] ?]; eauto. - - destruct HPQ as [HP|HQ]; [iLeft|iRight]; done. - Qed. - - Lemma extract_pure φ : (⊢@{uPredI M} ⌜φ⌝) ↔ φ. - Proof. - split; last by intros HP; auto. - intros [Hφ]; revert Hφ; unseal; intros Hφ. - apply (Hφ 0 ε); first apply ucmra_unit_validN; done. - Qed. - - Lemma extract_True : (⊢@{uPredI M} True) ↔ (True). - Proof. apply extract_pure. Qed. - - Lemma extract_False : (⊢@{uPredI M} False) ↔ (False). - Proof. apply extract_pure. Qed. - - Lemma extract_impl (P Q : uPred M) : (⊢ P → Q) → ((⊢ P) → (⊢ Q)). - Proof. intros HPQ HP; iApply HPQ; auto. Qed. - - Lemma extract_sep (P Q : uPred M) : (⊢ P ∗ Q) ↔ ((⊢ P) ∧ (⊢ Q)). - Proof. - split; intros HPQ. - - destruct HPQ as [HPQ]; revert HPQ; unseal; intros HPQ. - repeat constructor; intros ? ? ? _. - + edestruct (λ He, HPQ n ε He I) as (? & ? & Hrs & ? & ?); - [apply ucmra_unit_validN|]. - eapply uPred_mono; eauto. - transitivity (ε : M); last apply ucmra_unit_leastN. - rewrite Hrs; apply cmra_includedN_l. - + edestruct (λ He, HPQ n ε He I) as (? & ? & Hrs & ? & ?); - [apply ucmra_unit_validN|]. - eapply uPred_mono; eauto. - transitivity (ε : M); last apply ucmra_unit_leastN. - rewrite Hrs; apply cmra_includedN_r. - - destruct HPQ as [HP HQ]. - iSplitL; auto. - Qed. - - Lemma extract_wand (P Q : uPred M) : (⊢ P -∗ Q) → ((⊢ P) → (⊢ Q)). - Proof. intros HPQ HP; iApply HPQ; auto. Qed. - - Lemma extract_later (P : uPred M) : (⊢ ▷ P) ↔ (⊢ P). - Proof. - split; intros HP; destruct HP as [HP]; constructor; revert HP; unseal; - intros HP n x Hx _. - - eapply uPred_mono; first apply (HP (S n) ε); - eauto using ucmra_unit_validN, ucmra_unit_leastN. - - destruct n; [|apply HP]; auto using cmra_validN_S. - Qed. - - Lemma extract_except_0 (P : uPred M) : (⊢ ◇ P) ↔ (⊢ P). - Proof. - unfold bi_except_0. - split; intros HP; destruct HP as [HP]; constructor; revert HP; unseal; - intros HP n x Hx _. - - specialize (HP (S n)); simpl in *. - destruct (HP ε); auto using ucmra_unit_validN; first done. - eapply uPred_mono; eauto using ucmra_unit_validN, ucmra_unit_leastN. - - destruct n; first by left. - right. - apply HP; auto. - Qed. - - Lemma extract_bupd (P : uPred M) `{!Plain P} : (⊢ |==> P) ↔ (⊢ P). - Proof. - split; intros HP. - - iMod HP as "HP"; done. - - iModIntro; iApply HP. - Qed. - - Lemma extract_internal_eq (A : ofe) (x y : A) : (⊢@{uPredI M} x ≡ y) ↔ (x ≡ y). - Proof. - split; intros Hxy. - - destruct Hxy as [Hxy]; revert Hxy; unseal; intros Hxy. - apply equiv_dist; intros n. - apply (Hxy n ε); auto using ucmra_unit_validN. - - by rewrite Hxy; auto. - Qed. - - Lemma extract_plainly (P : uPred M) : (⊢ ■ P) ↔ (⊢ P). - Proof. - split; intros HP. - - iApply HP. - - iModIntro; iApply HP. - Qed. - - Lemma extract_persistently (P : uPred M) : (⊢ □ P) ↔ (⊢ P). - Proof. - split; intros HP. - - iApply HP. - - iModIntro; iApply HP. - Qed. - - Lemma extract_own (x : M) : (⊢ uPred_ownM x) ↔ ∀ n, x ≼{n} ε. - Proof. - split; intros Hx. - - destruct Hx as [Hx]; revert Hx; unseal; intros Hx. - intros n; apply Hx; first apply ucmra_unit_validN; done. - - constructor; intros. - eapply uPred_mono; first (by unseal; apply (Hx n); eauto); - auto using ucmra_unit_leastN. - Qed. - - Lemma extract_valid {A : ucmra} (x : A) : (⊢@{uPredI M} ✓ x) ↔ ✓ x. - Proof. - split; intros Hx. - - destruct Hx as [Hx]; revert Hx; unseal; intros Hx. - apply cmra_valid_validN. - intros n; apply (Hx n ε); first apply ucmra_unit_validN; done. - - constructor; intros; unseal; apply cmra_valid_validN; done. - Qed. - -End extraction. diff --git a/trillium/prelude/quantifiers.v b/trillium/prelude/quantifiers.v deleted file mode 100644 index d90273ff..00000000 --- a/trillium/prelude/quantifiers.v +++ /dev/null @@ -1,142 +0,0 @@ -From Coq.Unicode Require Import Utf8. -From Coq.micromega Require Import Lia. -From trillium.prelude Require Import classical sigma. - -Definition injective {A B} (f : A → B) := ∀ x y, f x = f y → x = y. - -Lemma injective_compose {A B C} (f : A → B) (g : B → C) : - injective f → injective g → injective (λ x, g (f x)). -Proof. intros Hf Hg x y Hxy; apply Hf, Hg; trivial. Qed. - -Definition smaller_card A B := ∀ f : B → A, ¬ injective f. - -Section quantifiers. - Context (A : Type) (R : A → A → Prop) - (Htotal : ∀ x y, R x y ∨ R y x) - (Htrans : ∀ x y z, R x y → R y z → R x z). - - Definition subset := A → Prop. - - Definition subset_type (S : subset) : Type := sig S. - - Definition cofinal (S : subset) := ∀ x, ∃ y, S y ∧ R x y. - - Definition regular := - ∀ (S : subset), cofinal S → ∃ f : A → (subset_type S), injective f. - - Lemma not_cofinal_smaller S : - ¬ cofinal S → ∃ x, ∀ y, S y → ¬ R x y. - Proof. - intros Hncf. - apply not_forall_exists_not in Hncf as [x Hncf]; eauto 10. - Qed. - - Definition union {I : Type} (fam : I → subset) : subset := λ x, ∃ i, fam i x. - - Lemma regular_union_of_smaller (I : Type) (fam : I → subset) : - regular → - smaller_card I A → - (∀ i, ¬ cofinal (fam i)) → - ¬ (cofinal (union fam)). - Proof. - intros Hreg HI Hfam Hcnf. - pose proof (Hreg _ Hcnf) as [f Hf]. - assert (∀ i, ∃ x, ∀ y, fam i y → ¬ R x y) as Hmax. - { intros i. apply not_cofinal_smaller; auto. } - apply Choice in Hmax as [g Hg]. - set (Img := λ x, ∃ i, g i = x). - assert (∀ x : subset_type Img, ∃ i : I, proj1_sig x = g i) as Himgback. - { intros [? [? ?]]; eauto. } - apply Choice in Himgback as [h Hh]. - assert (injective h). - { intros x y Hxy. - apply sig_eq; rewrite !Hh, Hxy; trivial. } - assert (¬ cofinal Img) as Himgncnf. - { intros Himgcnf. - destruct (Hreg _ Himgcnf) as [h' Hh']. - apply (HI (λ x, h (h' x))). - apply injective_compose; auto. } - apply not_cofinal_smaller in Himgncnf as [z Hz]. - destruct (Hcnf z) as [u [[i Hu1] Hu2]]. - assert (R z (g i)) as Hzgi. - { pose proof (Hg i _ Hu1). - destruct (Htotal (g i) u); [tauto|]. - eapply Htrans; eauto. } - apply Hz in Hzgi; [|unfold Img]; eauto. - Qed. - - Lemma regular_union_biger (I : Type) (fam : I → subset) : - regular → - smaller_card I A → - (cofinal (union fam)) → - ∃ i, cofinal (fam i). - Proof. - intros Hreg HI Hcnf. - cut (∃ i, ¬ ¬ cofinal (fam i)). - { intros [? ?]; eexists; apply NNP_P; eauto. } - apply not_forall_exists_not. - intros Hfam. - eapply regular_union_of_smaller; eauto. - Qed. - - Context (B : Type) (P : A → B → Prop). - - Definition fiber (b : B) : subset := λ x, P x b. - - Context (Hmono : ∀ x y z, R x y → P y z → P x z). - - Lemma cofinal_fiber_forall (b : B) : cofinal (fiber b) → ∀ x, P x b. - Proof. - intros Hb x. - destruct (Hb x) as (y & Hy1 & Hy2). - eapply Hmono; eauto. - Qed. - - Context (Hrefl : ∀ x, R x x). - - Lemma forall_exists_swap : - regular → - smaller_card B A → - (∀ x : A, ∃ y : B, P x y) → ∃ y, ∀ x, P x y. - Proof. - intros Hreg HB Hfe. - destruct (regular_union_biger _ fiber) as [y Hy]; [trivial|trivial| |]. - { intros x. destruct (Hfe x) as [y Hy]. - exists x; split; [|apply Hrefl]. - eexists; eauto. } - exists y; apply cofinal_fiber_forall; trivial. - Qed. - -End quantifiers. - -Example nat_regular : regular nat le. -Proof. - intros St HS. - pose proof (Choice _ _ _ HS) as [f Hf]. - set (g := - fix g n := - match n with - | 0 => f 0 - | S n' => f (S (g n')) - end). - assert (∀ n, St (g n)) as Hg. - { destruct n; apply Hf. } - assert (∀ x y, x < y → g x < g y) as Hglt. - { intros x y; revert x. - induction y as [|y IHy]; simpl; [lia|]. - intros x Hx. - destruct (PeanoNat.Nat.eq_dec x y) as [->|]. - - pose proof (Hf (S (g y))) as [_ ?]. - lia. - - pose proof (Hf (S (g y))) as [_ ?]. - assert (g x < g y). - { apply IHy; lia. } - lia. } - set (G n := exist _ _ (Hg n)). - exists G. - intros x y Hxy. - assert (proj1_sig (G x) = proj1_sig (G y)) by (rewrite Hxy; auto); simpl in *. - destruct (Compare_dec.lt_eq_lt_dec x y) as [[|]|]; [|trivial; fail|]. - - assert (g x < g y) by (apply Hglt; lia); lia. - - assert (g y < g x) by (apply Hglt; lia); lia. -Qed. diff --git a/trillium/prelude/sigma.v b/trillium/prelude/sigma.v deleted file mode 100644 index 8d32aac6..00000000 --- a/trillium/prelude/sigma.v +++ /dev/null @@ -1,51 +0,0 @@ -From Coq.Unicode Require Import Utf8. -From stdpp Require Import base list. -From trillium.prelude Require Import classical. -From Coq.ssr Require Import ssreflect. - -Lemma sig_eq {A} (P : A → Prop) (x y : sig P) : - proj1_sig x = proj1_sig y → x = y. -Proof. - destruct x as [x Px]; simpl. - destruct y as [y Py]; simpl. - intros ->. - rewrite (ProofIrrelevance _ Px Py); trivial. -Qed. - -Definition sig_prod_and {A B P Q} (a : {x : A | P x}) (b : {x : B | Q x}) : - {x : A * B | P (fst x) ∧ Q (snd x)} := - (proj1_sig a, proj1_sig b) ↾ (conj (proj2_sig a) (proj2_sig b)). - -Definition sig_prod_or_l {A P Q} (a : {x : A | P x}) : - {x : A | P x ∨ Q x} := (proj1_sig a) ↾ (or_introl (proj2_sig a)). - -Definition sig_prod_or_r {A P Q} (a : {x : A | Q x}) : - {x : A | P x ∨ Q x} := (proj1_sig a) ↾ (or_intror (proj2_sig a)). - -Definition sig_and {A} {P Q : A -> Prop} (a : {x : A | P x}) (HQ: Q (proj1_sig a)) : - { x : A | P x ∧ Q x } := (proj1_sig a) ↾ (conj (proj2_sig a) (HQ)). - -Fixpoint sig_and_list {A} (P Q : A → Prop) `{!∀ x, Decision (Q x)} - (enum : list { x | P x }) : list { x | P x ∧ Q x } := - match enum with - | [] => [] - | x :: xs => match (decide (Q $ proj1_sig x)) with - | left HQ => (sig_and x HQ) :: sig_and_list P Q xs - | _ => sig_and_list P Q xs - end - end. - -Lemma sig_and_list_le {A} (P Q : A → Prop) - `{!EqDecision A} `{!∀ x, Decision (Q x)} - `{!∀ x, ProofIrrel (P x)} `{!∀ x, ProofIrrel (Q x)} - (enum : list { x | P x }) : - ∀ x HQ, sig_and x HQ ∈ (sig_and_list P Q enum) → x ∈ enum. -Proof. - intros x y Hin. - induction enum; [by apply elem_of_nil in Hin|]. - apply elem_of_cons. - destruct (decide (x = a)) as [Heq|Hneq]; simplify_eq /=; [left;done|right]. - destruct (decide (Q (`a))); [|by apply IHenum]. - apply elem_of_cons in Hin as [Hin|Hin]; [|by apply IHenum]. - inversion Hin as [Heq]. by apply proj1_sig_inj in Heq. -Qed. diff --git a/trillium/program_logic/adequacy.v b/trillium/program_logic/adequacy.v deleted file mode 100644 index 3d7f8169..00000000 --- a/trillium/program_logic/adequacy.v +++ /dev/null @@ -1,1923 +0,0 @@ -From stdpp Require Import finite. -From iris.algebra Require Import gmap auth agree gset coPset. -From iris.bi.lib Require Import fixpoint. -From iris.base_logic.lib Require Import wsat later_credits. -From iris.proofmode Require Import tactics. -From trillium.prelude Require Import quantifiers iris_extraction finitary classical_instances. -From trillium.program_logic Require Export weakestpre traces. - -Set Default Proof Using "Type". -Import uPred. - -(* TODO: move *) -Lemma step_tp_length {Λ} c c' oζ: - locale_step (Λ := Λ) c oζ c' → length c.1 ≤ length c'.1. -Proof. - inversion 1; simplify_eq; last done. - rewrite !app_length /= !app_length; lia. -Qed. - -Lemma valid_exec_length {Λ} ex (tp1 tp2 : list $ expr Λ) σ1 σ2: - valid_exec ex -> - trace_starts_in ex (tp1, σ1) -> - trace_ends_in ex (tp2, σ2) -> - length tp1 ≤ length tp2. -Proof. - revert σ1 σ2 tp1 tp2. induction ex as [| ex IH oζ c']; intros σ1 σ2 tp1 tp2. - - intros ? -> Heq. inversion Heq; simplify_eq; done. - - intros Hval Hstarts Hends. - inversion Hval as [A B|A [tp' σ'] C D E Hstep]. simplify_eq. - etransitivity; first eapply IH =>//. - pose proof (step_tp_length _ _ _ Hstep) as Hlen. simpl in *. - rewrite ->Hends in Hlen. simpl in Hlen. lia. -Qed. - -Notation wptp_from t0 s t Φs := ([∗ list] tp1_e;Φ ∈ (prefixes_from t0 t);Φs, WP tp1_e.2 @ s; locale_of tp1_e.1 tp1_e.2; ⊤ {{ Φ }})%I. -Notation wptp s t Φs := (wptp_from [] s t Φs). - -Notation posts_of t Φs := - ([∗ list] vΦ ∈ - (omap (λ x, (λ v, (v, x.2)) <$> to_val x.1) - (zip_with (λ x y, (x, y)) t Φs)), vΦ.2 vΦ.1)%I. - -Definition config_wp `{!irisG Λ M Σ} : iProp Σ := - □ ∀ ex atr c1 σ2 , - ⌜valid_exec ex⌝ → - ⌜trace_ends_in ex c1⌝ → - ⌜config_step c1.2 σ2⌝ → - state_interp ex atr ={⊤,∅}=∗ |={∅}▷=>^(S $ trace_length ex) |={∅,⊤}=> - ∃ δ2 ℓ, state_interp (trace_extend ex None (c1.1, σ2)) - (trace_extend atr ℓ δ2). - -#[global] Instance config_wp_persistent `{!irisG Λ M Σ} : Persistent config_wp. -Proof. apply _. Qed. - -#[global] Typeclasses Opaque config_wp. - -(* the guarded definition of simulation. *) -Definition Gsim_pre Σ {Λ} (M : Model) (s : stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - (gsim : execution_trace Λ -d> auxiliary_trace M -d> iPropO Σ) : - execution_trace Λ -d> auxiliary_trace M -d> iPropO Σ := - (λ ex atr, - ▷ (⌜ξ ex atr⌝ ∧ - ∀ c oζ c', - ⌜trace_ends_in ex c⌝ → - ⌜locale_step c oζ c'⌝ → - ▷ ▷^(S $ trace_length ex) (∃ δ' ℓ, gsim (trace_extend ex oζ c') (trace_extend atr ℓ δ'))))%I. - -#[local] Instance Gsim_pre_contractive Σ M Λ s ξ : - Contractive (@Gsim_pre Σ M Λ s ξ). -Proof. - rewrite /Gsim_pre=> n wp wp' HGsm ex sm. - repeat (f_contractive || f_equiv). - repeat (eapply dist_lt; try apply HGsm). auto. -Qed. - -Definition Gsim Σ {Λ} (M : Model) (s : stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) : - execution_trace Λ → auxiliary_trace M → iProp Σ := - fixpoint (Gsim_pre Σ M s ξ). - -#[global] Instance is_except_0_wptp {Σ} Λ M s ξ ex sm: - IsExcept0 (@Gsim Σ Λ M s ξ ex sm). -Proof. - rewrite /IsExcept0; iIntros "H". - rewrite /Gsim (fixpoint_unfold (Gsim_pre _ _ _ _) _ _). - iMod "H". - iApply "H"; done. -Qed. - -#[global] Instance Gsim_plain Σ M {Λ} s ξ ex sm : Plain (@Gsim Σ M Λ s ξ ex sm). -Proof. - rewrite /Plain. - iIntros "H". - iLöb as "IH" forall (ex sm). - rewrite /Gsim (fixpoint_unfold (Gsim_pre _ _ _ _) _ _). - rewrite {3 5}/Gsim_pre. - iApply later_plainly_1; iNext. - iDestruct "H" as "(#H1 & H)". - iSplit; first (iClear "IH H"; iModIntro; done). - iIntros (c ? ? ? ?). - iDestruct ("H" with "[] []") as "H"; [done|done|]. - do 2 (iApply later_plainly_1; iNext). - iApply laterN_plainly. - iModIntro. - iDestruct "H" as (δ' ℓ) "H". - iExists _, _. iApply "IH"; done. -Qed. - -Notation locales_equiv_from t0 t0' t1 t1' := - (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') - (prefixes_from t0 t1) (prefixes_from t0' t1')). - -Section locales_helpers. - Context {Λ: language}. - - Lemma locales_equiv_from_app (t0 t0' t1 t1' t2 t2': list (expr Λ)): - locales_equiv_from t0 t0' t1 t1' -> - locales_equiv_from (t0 ++ t1) (t0' ++ t1') t2 t2' -> - locales_equiv_from t0 t0' (t1 ++ t2) (t1' ++ t2'). - Proof. - revert t0 t0' t1 t2 t2'. induction t1' ; intros t0 t0' t1 t2 t2' Hequiv1 Hequiv2. - - destruct t1; last by apply Forall2_cons_nil_inv in Hequiv1. simpl. - clear Hequiv1. revert t0 t0' t2 Hequiv2; induction t2'; intros t0 t0' t2 Hequiv2. - + destruct t2; last by apply Forall2_cons_nil_inv in Hequiv2. constructor. - + destruct t2; first by inversion Hequiv2. - rewrite !(right_id_L [] (++)) // in Hequiv2. - - destruct t1; first by inversion Hequiv1. - replace ((e :: t1) ++ t2) with (e :: (t1 ++ t2)); last by list_simplifier. - replace ((a :: t1') ++ t2') with (a :: (t1' ++ t2')); last by list_simplifier. - simpl. constructor. - + inversion Hequiv1 =>//. - + apply IHt1'. - * inversion Hequiv1 =>//. - * by list_simplifier. - Qed. - - Lemma prefixes_from_length {A} (t0 t1: list A): - length (prefixes_from t0 t1) = length t1. - Proof. revert t0; induction t1; intros ?; [done|]; rewrite /= IHt1 //. Qed. - - Lemma locales_equiv_from_impl (t0 t0' t1 t1' t2 t2': list (expr Λ)): - length t2 = length t2' -> - locales_equiv_from t0 t0' (t1 ++ t2) (t1' ++ t2') -> - locales_equiv_from (t0 ++ t1) (t0' ++ t1') t2 t2'. - Proof. - revert t0 t0' t1 t1' t2. induction t2'; intros t0 t0' t1 t1' t2 Hlen Hequiv. - - destruct t2 ; simpl in *; done. - - destruct t2; first done. - revert e a t0 t0' t1 t2' t2 IHt2' Hlen Hequiv. induction t1'; intros x y t0 t0' t1 t2' t2 IHt2' Hlen Hequiv. - + destruct t1; first by simpl; constructor; list_simplifier. - apply Forall2_length in Hequiv. rewrite !prefixes_from_length app_length /= in Hequiv. - simpl in Hlen. lia. - + destruct t1. - { apply Forall2_length in Hequiv. rewrite !prefixes_from_length !app_length /= in Hequiv. - simpl in Hlen. lia. } - assert (H: locales_equiv_from (t0 ++ e :: t1) (t0' ++ a :: t1') - (x :: t2) (y :: t2')). - { replace (t0 ++ e :: t1) with ((t0 ++ [e]) ++ t1); last by list_simplifier. - replace (t0' ++ a :: t1') with ((t0' ++ [a]) ++ t1'); last by list_simplifier. - apply IHt1' =>//. - by list_simplifier. } - simpl; constructor; [inversion H =>// |]. - apply IHt2'; first by simpl in Hlen; lia. done. - Qed. - - Lemma locales_equiv_from_refl (t0 t0' t: list (expr Λ)): - locales_equiv t0 t0' -> - locales_equiv_from t0 t0' t t. - Proof. - revert t0 t0'; induction t; intros t0 t0' H; simpl; constructor =>//. - { apply locale_equiv =>//. } - apply IHt. apply locales_equiv_from_app =>//. simpl. - constructor; [ by apply locale_equiv | done]. - Qed. - - Lemma locales_equiv_refl (t: list (expr Λ)): - locales_equiv t t. - Proof. apply locales_equiv_from_refl. constructor. Qed. - - Lemma locales_equiv_snoc t0 t0' (e e' : expr Λ) t1 t1': - locales_equiv t0 t0' -> - locales_equiv_from t0 t0' t1 t1' -> - locale_of (t0 ++ t1) e = locale_of (t0' ++ t1') e' -> - locales_equiv_from t0 t0' (t1 ++ [e]) (t1' ++ [e']). - Proof. - intros ???. - apply locales_equiv_from_app =>//. - simpl. by constructor. - Qed. - - Lemma locales_equiv_snoc_same t0 (e e' : expr Λ) t1: - locale_of (t0 ++ t1) e = locale_of (t0 ++ t1) e' -> - locales_equiv_from t0 t0 (t1 ++ [e]) (t1 ++ [e']). - Proof. - intros ?. apply locales_equiv_snoc =>//; apply locales_equiv_from_refl; apply locales_equiv_refl. - Qed. - - Lemma locales_equiv_from_middle t0 (e e' : expr Λ) t1 t2: - locale_of (t0 ++ t1) e = locale_of (t0 ++ t1) e' -> - locales_equiv_from t0 t0 (t1 ++ e :: t2) (t1 ++ e' :: t2). - Proof. - intros ?. - apply locales_equiv_from_app. - - apply locales_equiv_from_refl. apply locales_equiv_refl. - - simpl. constructor; first done. - apply locales_equiv_from_impl =>//=. - constructor =>//. apply locales_equiv_from_refl. - apply locales_equiv_snoc_same. by list_simplifier. - Qed. - - Lemma locales_equiv_middle (e e' : expr Λ) t1 t2: - locale_of t1 e = locale_of t1 e' -> - locales_equiv (t1 ++ e :: t2) (t1 ++ e' :: t2). - Proof. - intros ?. apply locales_equiv_from_middle. - by list_simplifier. - Qed. - - Lemma locale_step_equiv (c c' : cfg Λ) oζ: - locale_step c oζ c' -> - locales_equiv c.1 (take (length c.1) c'.1). - Proof. - intros H. inversion H as [? ? e1 ? e2 ? efs t1 t2|]; simplify_eq; simpl. - - replace (t1 ++ e2 :: t2 ++ efs) with ((t1 ++ e2 :: t2) ++ efs); last by list_simplifier. - replace (length (t1 ++ e1 :: t2)) with (length (t1 ++ e2 :: t2)); last first. - { rewrite !app_length //=. } - rewrite take_app. apply locales_equiv_middle. - eapply locale_step_preserve =>//. - - rewrite take_ge =>//. apply locales_equiv_refl. - Qed. - - Lemma locales_equiv_from_take (t0 t0' t1 t1' : list $ expr Λ) n: - locales_equiv_from t0 t0' t1 t1' -> - locales_equiv_from t0 t0' (take n t1) (take n t1'). - Proof. - revert t0 t0' t1 t1'. induction n as [|n IHn]; intros t0 t0' t1 t1' Hequiv; first constructor. - destruct t1 as [|e1 t1]; destruct t1' as [|e1' t1']; try by inversion Hequiv. - simpl. constructor; first by inversion Hequiv. - apply IHn. by inversion Hequiv. - Qed. - - Lemma locales_equiv_take (t1 t2 : list $ expr Λ) n: - locales_equiv t1 t2 -> - locales_equiv (take n t1) (take n t2). - Proof. apply locales_equiv_from_take. Qed. - - Lemma locales_equiv_from_transitive (s1 s2 s3 t1 t2 t3 : list $ expr Λ): - locales_equiv s1 s2 -> - locales_equiv s2 s3 -> - locales_equiv_from s1 s2 t1 t2 -> - locales_equiv_from s2 s3 t2 t3 -> - locales_equiv_from s1 s3 t1 t3. - Proof. - revert s1 s2 s3 t1 t2. induction t3 as [|e3 t3] ; intros s1 s2 s3 t1 t2 Hpref1 Hpref2 Hequiv1 Hequiv2; - destruct t2 as [|e2 t2]; try by inversion Hequiv2; simplify_eq. - destruct t1 as [|e1 t1]; try by inversion Hequiv1; simplify_eq. - simpl; constructor; first by etransitivity; [inversion Hequiv1 | inversion Hequiv2]. - eapply (IHt3 _ (s2 ++ [e2]) _ _ t2). - - inversion Hequiv1; simplify_eq =>//. by apply locales_equiv_snoc =>//. - - inversion Hequiv2; simplify_eq =>//. by apply locales_equiv_snoc =>//. - - inversion Hequiv1 =>//. - - inversion Hequiv2 => //. - Qed. - - Lemma locales_equiv_transitive (t1 t2 t3 : list $ expr Λ): - locales_equiv t1 t2 -> - locales_equiv t2 t3 -> - locales_equiv t1 t3. - Proof. apply locales_equiv_from_transitive; constructor. Qed. - - Lemma locale_valid_exec ex (tp1 tp2 : list $ expr Λ) σ1 σ2: - valid_exec ex -> - trace_starts_in ex (tp1, σ1) -> - trace_ends_in ex (tp2, σ2) -> - locales_equiv tp1 (take (length tp1) tp2). - Proof. - revert σ1 σ2 tp1 tp2. induction ex as [| ex IH oζ c']; intros σ1 σ2 tp1 tp2. - - intros ? -> Heq. inversion Heq; simplify_eq. - rewrite take_ge //. apply locales_equiv_refl. - - intros Hval Hstarts Hends. - inversion Hval as [A B|A [tp' σ'] C D E Hstep]. simplify_eq. - eapply locales_equiv_transitive. - eapply IH =>//. - pose proof (locale_step_equiv _ _ _ Hstep) as Hequiv. - rewrite /trace_ends_in /trace_last in Hends. - rewrite Hends in Hequiv. - apply (locales_equiv_take _ _ (length tp1)) in Hequiv. - rewrite take_take in Hequiv. - assert (length tp1 ≤ length tp'). - { eapply (valid_exec_length ex ) =>//. } - simpl in Hequiv. - replace (length tp1 `min` length tp') with (length tp1) in Hequiv; - [done|lia]. - Qed. - -End locales_helpers. - -Section from_locale. - Context {Λ: language}. - Context `{ EqDecision (locale Λ)}. - - Fixpoint from_locale_from tp0 tp ζ := - match tp with - | [] => None - | e::tp' => if decide (locale_of tp0 e = ζ) then Some e else from_locale_from (tp0 ++ [e]) tp' ζ - end. - - Definition from_locale tp ζ := from_locale_from [] tp ζ. - - (* Other possibility is: - Definition from_locale tp ζ := list_find (λ '(tp, e), locale_of tp e = ζ) (prefixes tp).*) - - Lemma from_locale_from_Some_app tp0 tp tp' ζ e : - from_locale_from tp0 tp ζ = Some e -> - from_locale_from tp0 (tp ++ tp') ζ = Some e. - Proof. - revert tp0 tp'. induction tp as [|e' tp IH]; first by list_simplifier. - simpl. intros tp0 tp' Hfl. - destruct (decide (locale_of tp0 e' = ζ)) =>//. - apply IH =>//. - Qed. - - Lemma from_locale_from_is_Some_app tp0 tp tp' ζ : - is_Some (from_locale_from tp0 tp ζ) -> - is_Some (from_locale_from tp0 (tp ++ tp') ζ). - Proof. - intros [? HS]. eapply from_locale_from_Some_app in HS. eauto. - Qed. - - Lemma from_locale_from_equiv tp0 tp0' tp tp' ζ : - locales_equiv tp0 tp0' -> - locales_equiv_from tp0 tp0' tp tp' -> - is_Some (from_locale_from tp0 tp ζ) -> - is_Some (from_locale_from tp0' tp' ζ). - Proof. - revert tp0 tp0' tp'. induction tp as [|e tp IH]; intros tp0 tp0' tp' Heq0 Heq [eζ Heζ]; - destruct tp' as [|e' tp']; try by apply Forall2_length in Heq. - simpl in *. - destruct (decide (locale_of tp0 e' = ζ)). - - rewrite decide_True //; eauto. erewrite <-locale_equiv =>//. - - rewrite decide_False; last by erewrite <-locale_equiv. - apply Forall2_cons_1 in Heq as [Hlocs ?]. - rewrite decide_False // in Heζ; last by erewrite Hlocs, <-locale_equiv =>//. - apply (IH (tp0 ++ [e])); eauto. - apply locales_equiv_snoc =>//. - Qed. - - Lemma from_locale_step tp1 tp2 ζ oζ σ1 σ2 : - locale_step (tp1, σ1) oζ (tp2, σ2) → - is_Some(from_locale tp1 ζ) → - is_Some(from_locale tp2 ζ). - Proof. - intros Hstep. inversion Hstep; simplify_eq=>//. - intros HiS. replace (t1 ++ e2 :: t2 ++ efs) with ((t1 ++ e2 :: t2) ++ efs); - last by list_simplifier. - apply from_locale_from_is_Some_app. - eapply from_locale_from_equiv; eauto; [constructor|]. - apply locales_equiv_from_middle. list_simplifier. by eapply locale_step_preserve. - Qed. - - Lemma from_locale_from_Some tp0 tp1 tp e : - (tp, e) ∈ prefixes_from tp0 tp1 → - from_locale_from tp0 tp1 (locale_of tp e) = Some e. - Proof. - revert tp0 tp e; induction tp1 as [| e1 tp1 IH]; intros tp0 tp e Hin; first set_solver. - apply elem_of_cons in Hin as [Heq|Hin]. - { simplify_eq. rewrite /= decide_True //. } - rewrite /= decide_False; first by apply IH. - fold (prefixes_from (A := expr Λ)) in Hin. - by eapply locale_injective. - Qed. - -End from_locale. - -(* TODO: Move *) -Lemma Forall2_eq {A B} (f : A → B) xs ys : - Forall2 (λ x y, f x = f y) xs ys ↔ f <$> xs = f <$> ys. -Proof. - split. - - revert ys. - induction xs as [|x xs IHxs]; intros ys Hforall. - { eapply Forall2_nil_inv_l in Hforall. by simplify_eq. } - destruct ys as [|y ys]. - { by apply Forall2_cons_nil_inv in Hforall. } - apply Forall2_cons_1 in Hforall as [Hf Hforall]=> /=. - f_equiv; [done|by apply IHxs]. - - revert ys. - induction xs as [|x xs IHxs]; intros ys Hf. - { rewrite fmap_nil comm in Hf. eapply fmap_nil_inv in Hf. by simplify_eq. } - rewrite fmap_cons comm in Hf. - apply fmap_cons_inv in Hf as (y & ys' & Hfxy & Hf & ->). - apply Forall2_cons. split; [done|by apply IHxs]. -Qed. - -Section locales_utils. - Context {Λ: language}. - - Definition locales_of_list_from tp0 (tp: list $ expr Λ): list $ locale Λ := - (λ '(t, e), locale_of t e) <$> (prefixes_from tp0 tp). - Notation locales_of_list tp := (locales_of_list_from [] tp). - - Lemma locales_of_list_from_cons es' (e : expr Λ) es : - locales_of_list_from es' (e :: es) = - locale_of es' e :: locales_of_list_from (es' ++ [e]) es. - Proof. done. Qed. - - Lemma locales_of_list_equiv (tp0 tp0' tp1 tp2 : list $ expr Λ) : - locales_equiv_from tp0 tp0' tp1 tp2 ↔ - locales_of_list_from tp0 tp1 = locales_of_list_from tp0' tp2. - Proof. - split; intros Heq. - - apply (Forall2_impl _ (λ x y, uncurry locale_of x = uncurry locale_of y)) - in Heq; [|by intros [] [] HP]. - by rewrite Forall2_eq in Heq. - - apply (Forall2_impl (λ x y, uncurry locale_of x = uncurry locale_of y)); - [|by intros [] [] HP]. - by rewrite Forall2_eq. - Qed. - - Lemma locales_of_list_step_incl σ1 σ2 oζ tp1 tp2 : - locale_step (tp1, σ1) oζ (tp2, σ2) -> - locales_of_list tp1 ⊆ locales_of_list tp2. - Proof. - intros H. inversion H; simplify_eq=>//. - replace (t1 ++ e2 :: t2 ++ efs) with ((t1 ++ e2 :: t2) ++ efs); last by list_simplifier. - rewrite /locales_of_list_from. rewrite [in X in _ ⊆ X]prefixes_from_app /= fmap_app. - assert ((λ '(t, e), locale_of t e) <$> prefixes (t1 ++ e1 :: t2) = (λ '(t, e), locale_of t e) <$> prefixes (t1 ++ e2 :: t2)) - as ->; last set_solver. - apply locales_of_list_equiv, locales_equiv_middle. by eapply locale_step_preserve. - Qed. - - Lemma locales_of_list_from_locale_from `{EqDecision (locale Λ)} tp0 tp1 ζ: - is_Some (from_locale_from tp0 tp1 ζ) -> - ζ ∈ locales_of_list_from tp0 tp1. - Proof. - revert tp0; induction tp1 as [|e1 tp1 IH]; intros tp0. - { simpl. intros H. inversion H. congruence. } - simpl. intros [e Hsome]. rewrite /locales_of_list_from /=. - destruct (decide (locale_of tp0 e1 = ζ)); simplify_eq; first set_solver. - apply elem_of_cons; right. apply IH. eauto. - Qed. - - Definition locales_equiv_prefix_from {Λ} (tp0 tp1 tp2 : list $ expr Λ) := - locales_equiv_from tp0 tp0 tp1 (take (length tp1) tp2). - Notation locales_equiv_prefix tp1 tp2 := (locales_equiv_prefix_from [] tp1 tp2). - - Lemma locales_equiv_from_length (tp0 tp0' tp1 tp2 : list $ expr Λ) : - locales_equiv_from tp0 tp0' tp1 tp2 → length tp1 = length tp2. - Proof. intros Heq%Forall2_length. by rewrite !prefixes_from_length in Heq. Qed. - - Lemma locales_equiv_prefix_from_length (tp0 tp1 tp2 : list $ expr Λ) : - locales_equiv_prefix_from tp0 tp1 tp2 → length tp1 ≤ length tp2. - Proof. - rewrite /locales_equiv_prefix_from. - intros ->%locales_equiv_from_length. - revert tp2. induction tp1; [simpl; lia|]. - destruct tp2; [done|by apply le_n_S]. - Qed. - - Lemma locales_equiv_prefix_from_trans (tp0 tp1 tp2 tp3 : list $ expr Λ) : - locales_equiv_prefix_from tp0 tp1 tp2 → - locales_equiv_prefix_from tp0 tp2 tp3 → - locales_equiv_prefix_from tp0 tp1 tp3. - Proof. - rewrite /locales_equiv_prefix_from. intros. - assert (length tp1 ≤ length tp2); - [by eapply locales_equiv_prefix_from_length|]. - eapply locales_equiv_from_transitive; - [apply locales_equiv_refl..|done|]. - assert (length tp1 = length tp1 `min` length tp2) as Heq by lia. - rewrite {2}Heq -take_take. by apply locales_equiv_from_take. - Qed. - - Lemma locales_equiv_prefix_trans (tp1 tp2 tp3 : list $ expr Λ) : - locales_equiv_prefix tp1 tp2 → - locales_equiv_prefix tp2 tp3 → - locales_equiv_prefix tp1 tp3. - Proof. intros. by eapply locales_equiv_prefix_from_trans. Qed. - - Lemma locales_equiv_from_comm (tp0 tp0' tp1 tp2 : list $ expr Λ) : - locales_equiv_from tp0 tp0' tp1 tp2 → - locales_equiv_from tp0' tp0 tp2 tp1. - Proof. by rewrite !locales_of_list_equiv. Qed. - - Lemma locales_equiv_from_locale_of (tp0 tp0' tp1 tp2 tp3 : list $ expr Λ) : - locales_equiv tp0 tp0' → - locales_equiv_from tp0 tp1 tp2 tp3 ↔ - locales_equiv_from tp0' tp1 tp2 tp3. - Proof. - rewrite !locales_of_list_equiv. intros Heq. - split. - - intros <-. - rewrite -locales_of_list_equiv. - rewrite -locales_of_list_equiv in Heq. - apply locales_equiv_from_refl. - by apply locales_equiv_from_comm. - - intros <-. - rewrite -locales_of_list_equiv. - rewrite -locales_of_list_equiv in Heq. - by apply locales_equiv_from_refl. - Qed. - - Lemma locales_equiv_prefix_from_drop (tp0 tp1 tp2 : list $ expr Λ) : - locales_equiv_prefix_from tp0 tp1 tp2 → - locales_equiv_from tp0 tp0 tp2 (tp1 ++ (drop (length tp1) tp2)). - Proof. - revert tp0 tp2. - induction tp1 as [|e1 tp1 IHtp1]; intros tp0 tp2 Heq. - { by rewrite /locales_equiv_prefix_from !locales_of_list_equiv. } - destruct tp2 as [|e2 tp2]. - { by rewrite /locales_equiv_prefix_from !locales_of_list_equiv - /locales_of_list_from in Heq. } - rewrite /locales_equiv_prefix_from !locales_of_list_equiv - /locales_of_list_from in Heq. - rewrite /locales_of_list_from=> /=. - inversion Heq as [[Hlocale Htail]]. - f_equiv; [done|]. - rewrite /locales_of_list_from in IHtp1. - eapply (locales_equiv_from_locale_of _ (tp0 ++ [e1])). - { apply locales_equiv_from_app; - [by apply locales_equiv_refl|by apply Forall2_cons]. } - apply IHtp1, locales_equiv_from_comm. - apply (locales_equiv_from_locale_of (tp0 ++ [e1]) (tp0 ++ [e2])). - { apply locales_equiv_from_app; - [by apply locales_equiv_refl|by apply Forall2_cons]. } - apply locales_equiv_from_comm. - rewrite /locales_equiv_prefix_from locales_of_list_equiv - /locales_of_list_from. - by apply Htail. - Qed. - - Lemma locales_equiv_from_drop (t0 t1 t2 t2' : list $ expr Λ) : - locales_equiv_prefix_from t0 t1 t2 → - locales_equiv_prefix_from t0 t1 t2' → - locales_equiv_from t0 t0 t2 t2' → - locales_equiv_from (t0++t1) (t0++t1) (drop (length t1) t2) (drop (length t1) t2'). - Proof. - intros Hprefix1 Hprefix2 Hequiv. - apply locales_equiv_from_impl. - { apply Forall2_length in Hequiv. rewrite !prefixes_from_length in Hequiv. - by rewrite !skipn_length Hequiv. } - apply locales_equiv_prefix_from_drop in Hprefix1. - apply locales_equiv_prefix_from_drop in Hprefix2. - apply locales_equiv_from_comm in Hprefix1. - assert (locales_equiv_from t0 t0 (t1 ++ drop (length t1) t2) t2'). - { eapply locales_equiv_from_transitive. - - apply locales_equiv_refl. - - apply locales_equiv_refl. - - apply Hprefix1. - - apply Hequiv. } - assert (locales_equiv_from t0 t0 (t1 ++ drop (length t1) t2) (t1 ++ drop (length t1) t2')). - { eapply locales_equiv_from_transitive. - - apply locales_equiv_refl. - - apply locales_equiv_refl. - - apply H. - - apply Hprefix2. } - done. - Qed. - - (* TODO: Find an alternative to this. Used to resolve coercions. *) - Lemma fmap_fmap : forall (A B C:Type)(f:A->B)(g:B->C) (l : list A), - g <$> (f <$> l) = (fun x => g (f x)) <$> l. - Proof. apply map_map. Qed. - - (* TODO: this can likely be removed by redefining [locale_of] - to take one argument *) - Lemma locales_of_list_from_fork_post `{!irisG Λ M Σ} - (xs ys : list ((list $ expr Λ) * (expr Λ))) : - (λ '(t,e), locale_of t e) <$> xs = - (λ '(t,e), locale_of t e) <$> ys → - (λ '(t,e) v, fork_post (locale_of t e) v) <$> xs = - (λ '(t,e) v, fork_post (locale_of t e) v) <$> ys. - Proof. - intros. - set f := locale_of. - set g := (λ ζ, λ v, flip weakestpre.fork_post v ζ). - assert (∀ (xs : list ((list $ expr Λ) * (expr Λ))), - g <$> ((λ '(x,y), f x y) <$> xs) = - ((λ '(x,y), g (f x y)) <$> xs)) as Hmap. - { intros. rewrite fmap_fmap. f_equiv. apply FunExt. by intros []. } - rewrite /f /g in Hmap. rewrite -!Hmap. clear Hmap. by f_equiv. - Qed. - - Lemma locales_equiv_prefix_from_drop_alt (tp0 tp1 tp2 : list $ expr Λ) : - locales_equiv_prefix_from tp0 tp1 tp2 → - (λ '(t, e), locale_of t e) <$> prefixes_from (tp0 ++ tp1) (drop (length tp1) tp2) = - drop (length tp1) ((λ '(t, e), locale_of t e) <$> prefixes_from tp0 tp2). - Proof. - revert tp0 tp2. - induction tp1; intros tp0 tp2 Hprefix; [by rewrite right_id|]. - destruct tp2; [done|]. - rewrite /locales_equiv_prefix_from in Hprefix. simpl in *. - apply Forall2_cons in Hprefix as [Hlocale Hprefix]. - rewrite -IHtp1; last first. - { eapply locales_equiv_from_locale_of; - [by apply locales_equiv_snoc_same|done]. } - rewrite -locales_of_list_equiv. - eapply locales_equiv_from_locale_of; - [|apply locales_equiv_from_refl, locales_equiv_refl]. - rewrite -assoc. by eapply locales_equiv_middle. - Qed. - - Lemma locales_equiv_prefix_drop_alt (tp0 tp1 : list $ expr Λ) : - locales_equiv_prefix tp0 tp1 → - (λ '(t, e), locale_of t e) <$> prefixes_from tp0 (drop (length tp0) tp1) = - drop (length tp0) ((λ '(t, e), locale_of t e) <$> prefixes tp1). - Proof. apply (locales_equiv_prefix_from_drop_alt []). Qed. - -End locales_utils. -Notation locales_of_list tp := (locales_of_list_from [] tp). -Notation locales_equiv_prefix tp1 tp2 := (locales_equiv_prefix_from [] tp1 tp2). - -Section adequacy_helper_lemmas. - Context `{!irisG Λ M Σ}. - - Lemma wp_take_step s Φ ex atr tp1 e1 tp2 σ1 e2 σ2 efs ζ: - valid_exec ex → - prim_step e1 σ1 e2 σ2 efs → - trace_ends_in ex (tp1 ++ e1 :: tp2, σ1) → - locale_of tp1 e1 = ζ -> - state_interp ex atr -∗ - WP e1 @ s; ζ; ⊤ {{ v, Φ v } } ={⊤,∅}=∗ |={∅}▷=>^(S $ trace_length ex) - |={∅,⊤}=> - ∃ δ' ℓ, - state_interp (trace_extend ex (Some ζ) (tp1 ++ e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ') ∗ - WP e2 @ s; ζ; ⊤ {{ v, Φ v } } ∗ - ([∗ list] i↦ef ∈ efs, - WP ef @ s; locale_of (tp1 ++ e1 :: tp2 ++ take i efs) ef; ⊤ - {{ v, fork_post (locale_of (tp1 ++ e1 :: tp2 ++ take i efs) ef) v }}). - Proof. - iIntros (Hex Hstp Hei Hlocale) "HSI Hwp". - rewrite wp_unfold /wp_pre. - destruct (to_val e1) eqn:He1. - { erewrite val_stuck in He1; done. } - iMod ("Hwp" $! _ _ ectx_emp with "[//] [] [] HSI") as "[Hs Hwp]"; - [by rewrite locale_fill|by rewrite ectx_fill_emp|]. - iDestruct ("Hwp" with "[]") as "Hwp"; first done. - iModIntro. - iApply (step_fupdN_wand with "[Hwp]"); first by iApply "Hwp". - iIntros "Hwp". - rewrite !ectx_fill_emp. - iMod "Hwp" as (δ' ℓ) "(? & ? & ?)". - iModIntro; iExists _, _; iFrame; done. - Qed. - - Lemma wp_not_stuck ex atr K tp1 tp2 σ e s Φ ζ : - valid_exec ex → - trace_ends_in ex (tp1 ++ ectx_fill K e :: tp2, σ) → - locale_of tp1 e = ζ -> - state_interp ex atr -∗ - WP e @ s; ζ; ⊤ {{ v, Φ v }} ={⊤}=∗ - state_interp ex atr ∗ - WP e @ s; ζ; ⊤ {{ v, Φ v }} ∗ - ⌜s = NotStuck → not_stuck e (trace_last ex).2⌝. - Proof. - iIntros (???) "HSI Hwp". - rewrite /not_stuck assoc. - iApply fupd_plain_keep_r; iFrame. - iIntros "[HSI Hwp]". - rewrite wp_unfold /wp_pre. - destruct (to_val e) eqn:He. - - iModIntro; iPureIntro; eauto. - - iApply fupd_plain_mask. - iMod ("Hwp" with "[] [] [] HSI") as "[Hs Hwp]"; [done| by erewrite locale_fill|done|]. - erewrite last_eq_trace_ends_in; last done; simpl. - iModIntro; destruct s; [iDestruct "Hs" as %?|]; iPureIntro; by eauto. - Qed. - - Lemma wptp_from_same_locales t0' t0 s tp Φs: - locales_equiv t0 t0' -> - wptp_from t0' s tp Φs -∗ wptp_from t0 s tp Φs. - Proof. - revert Φs t0 t0'. induction tp; intros Φs t0 t0'; iIntros (Hequiv) "H" =>//. - simpl. - iDestruct (big_sepL2_cons_inv_l with "H") as (Φ Φs' ->) "[??]". - rewrite big_sepL2_cons. simpl. erewrite <-locale_equiv =>//. iFrame. - iApply IHtp =>//. apply locales_equiv_snoc =>//. - apply locale_equiv =>//. - Qed. - - Lemma wptp_not_stuck ex atr σ tp t0 t0' trest s Φs : - Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0') -> - valid_exec ex → - trace_ends_in ex (t0 ++ tp ++ trest, σ) → - state_interp ex atr -∗ wptp_from t0' s tp Φs ={⊤}=∗ - state_interp ex atr ∗ wptp_from t0 s tp Φs ∗ - ⌜∀ e, e ∈ tp → s = NotStuck → not_stuck e (trace_last ex).2⌝. - Proof. - iIntros (Hsame Hexvalid Hex) "HSI Ht". - rewrite assoc. - rewrite (wptp_from_same_locales t0') =>//. - iApply fupd_plain_keep_r; iFrame. - iIntros "[HSI Ht]". - iIntros (e He). - apply elem_of_list_split in He as (t1 & t2 & ->). - rewrite prefixes_from_app. - iDestruct (big_sepL2_app_inv_l with "Ht") as (Φs1 Φs2') "[-> [Ht1 Het2]]". - iDestruct (big_sepL2_cons_inv_l with "Het2") as (Φ Φs2) "[-> [He Ht2]]". - iMod (wp_not_stuck _ _ ectx_emp with "HSI He") as "(_ & _ & ?)"; - [done| rewrite ectx_fill_emp // | |done]. - - replace (t0 ++ (t1 ++ e :: t2) ++ trest) with ((t0 ++ t1) ++ e :: (t2 ++ trest)) in Hex. - + simpl. done. - + list_simplifier. done. - - done. - Qed. - - Lemma wptp_not_stuck_same ex atr σ tp t0 trest s Φs : - valid_exec ex → - trace_ends_in ex (t0 ++ tp ++ trest, σ) → - state_interp ex atr -∗ wptp_from t0 s tp Φs ={⊤}=∗ - state_interp ex atr ∗ wptp_from t0 s tp Φs ∗ - ⌜∀ e, e ∈ tp → s = NotStuck → not_stuck e (trace_last ex).2⌝. - Proof. - iIntros (??) "??". iApply (wptp_not_stuck with "[$] [$]") =>//. - eapply Forall2_lookup. intros i. destruct (prefixes t0 !! i) as [[??]|]; by constructor. - Qed. - - Lemma wp_of_val_post e s Φ ζ: - WP e @ s; ζ; ⊤ {{ v, Φ v }} ={⊤}=∗ - from_option Φ True (to_val e) ∗ - (from_option Φ True (to_val e) -∗ WP e @ s; ζ; ⊤ {{ v, Φ v }}). - Proof. - iIntros "Hwp". - rewrite wp_unfold /wp_pre. - destruct (to_val e) eqn:He; simpl. - - iMod "Hwp"; simpl; iFrame; auto. - - iModIntro. - iSplit; first by iClear "Hwp". - iIntros "_"; done. - Qed. - - Lemma wptp_app s t0 t1 t0t1 Φs1 t2 Φs2 : - t0t1 = t0 ++ t1 -> - wptp_from t0 s t1 Φs1 -∗ wptp_from t0t1 s t2 Φs2 -∗ wptp_from t0 s (t1 ++ t2) (Φs1 ++ Φs2). - Proof. - iIntros (->) "H1 H2". rewrite prefixes_from_app. - iApply (big_sepL2_app with "[H1] [H2]"); eauto. - Qed. - - Lemma wptp_cons_r s e Φ Φs t0 t1: - WP e @ s; locale_of (t0 ++ t1) e; ⊤ {{v, Φ v}} -∗ wptp_from t0 s t1 Φs - -∗ wptp_from t0 s (t1 ++ [e]) (Φs ++ [Φ]). - Proof. - iIntros "H1 H2". rewrite !prefixes_from_app. - iApply (big_sepL2_app with "[H2] [H1]"); eauto. - rewrite big_sepL2_singleton. done. - Qed. - - Lemma wptp_cons_l s e Φ t Φs t0: - WP e @ s; locale_of t0 e; ⊤ {{v, Φ v}} -∗ - wptp_from (t0 ++[e]) s t Φs -∗ - wptp_from t0 s (e :: t) (Φ :: Φs). - Proof. iIntros "? ?"; rewrite big_sepL2_cons; iFrame. Qed. - - Lemma wptp_of_val_post t s Φs t0: - wptp_from t0 s t Φs ={⊤}=∗ posts_of t Φs ∗ (posts_of t Φs -∗ wptp_from t0 s t Φs). - Proof. - iIntros "Ht"; simpl. - iInduction t as [|e t IHt] "IH" forall (Φs t0); simpl. - { iDestruct (big_sepL2_nil_inv_l with "Ht") as %->; eauto. } - iDestruct (big_sepL2_cons_inv_l with "Ht") as (Φ Φs') "[-> [He Ht]] /=". - iMod (wp_of_val_post with "He") as "[Hpost Hback]". - iMod ("IH" with "Ht") as "[Ht Htback]". - iModIntro. - destruct (to_val e); simpl. - - iFrame. - iIntros "[Hpost Htpost]". - iSplitL "Hpost Hback"; [iApply "Hback"|iApply "Htback"]; iFrame. - - iFrame. - iIntros "Hefspost". - iSplitL "Hback"; [iApply "Hback"|iApply "Htback"]; iFrame; done. - Qed. - - Notation newelems t t' := (drop (length t) t'). - Notation newposts t t' := - ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> - (prefixes_from t (newelems t t'))). - - Lemma newposts_locales_equiv_helper (t0 t0' t1 t1' t : list (expr Λ)): - length t1 = length t1' -> - locales_equiv t0 t0' -> - (λ '(tnew, e0), fork_post (locale_of tnew e0)) <$> - (prefixes_from t0 (newelems t1 t)) = - (λ '(tnew, e0), fork_post (locale_of tnew e0)) <$> - (prefixes_from t0' (newelems t1' t)). - Proof. - intros Hlen1 H. - assert (Hlen2: length t0 = length t0'). - { apply Forall2_length in H. rewrite !prefixes_from_length // in H. } - revert t0 t0' t1 t1' Hlen1 Hlen2 H. induction t; intros t0 t0' t1 t1' Hlen1 Hlen2 H. - - rewrite !drop_nil //. - - destruct t1; destruct t1' =>//. - + simpl; f_equal; first erewrite locale_equiv=> //. - specialize (IHt (t0 ++ [a]) (t0' ++ [a]) _ _ Hlen1). - simpl in IHt. rewrite !drop_0 in IHt. apply IHt. - * rewrite !app_length. lia. - * apply locales_equiv_snoc =>//. list_simplifier. apply locale_equiv =>//. - + simpl. apply IHt =>//. simpl in Hlen1. lia. - Qed. - - Lemma forkposts_locales_equiv (t0 t0' t1 t1' : list (expr Λ)): - locales_equiv_from t0 t0' t1 t1' -> - (λ '(tnew, e0), fork_post (locale_of tnew e0)) <$> - (prefixes_from t0 t1) = - (λ '(tnew, e0), fork_post (locale_of tnew e0)) <$> - (prefixes_from t0' t1'). - Proof. - intros H. - revert t0 t0' t1' H. induction t1; intros t0 t0' t1' H. - - destruct t1' =>//. inversion H. - - destruct t1' =>//; first inversion H. - inversion H; simplify_eq. - simpl; f_equal; first by f_equal. - by apply IHt1. - Qed. - - Lemma newposts_locales_equiv t0 t0' t: - locales_equiv t0 t0' -> - newposts t0 t = newposts t0' t. - Proof. - intros H; apply newposts_locales_equiv_helper =>//. - eapply Forall2_length in H. rewrite !prefixes_from_length // in H. - Qed. - - Lemma newposts_same_empty t: - newposts t t = []. - Proof. rewrite drop_ge //. Qed. - - Lemma new_threads_wptp_from s t efs: - (([∗ list] i ↦ ef ∈ efs, - WP ef @ s; locale_of (t ++ take i efs) ef ; ⊤ - {{ v, fork_post (locale_of (t ++ take i efs) ef) v }}) - ⊣⊢ wptp_from t s efs (newposts t (t ++ efs))). - Proof. - (* TODO: factorize the two halves *) - rewrite big_sepL2_alt; iSplit. - - iIntros "H". iSplit. - { rewrite drop_app_alt // map_length !prefixes_from_length //. } - iInduction efs as [|ef efs] "IH" forall (t); first done. - rewrite /= !drop_app_alt //=. - iDestruct "H" as "[H1 H]". rewrite (right_id [] (++)). iFrame. - replace (map (λ '(tnew, e), fork_post (locale_of tnew e)) - (prefixes_from (t ++ [ef]) efs)) - with - (newposts (t ++[ef]) ((t ++ [ef]) ++ efs)). - + iApply "IH". iApply (big_sepL_impl with "H"). - iIntros "!>" (k e Hin) "H". by list_simplifier. - + list_simplifier. - replace (t ++ ef :: efs) with ((t ++ [ef]) ++ efs); last by list_simplifier. - rewrite drop_app_alt //. - - iIntros "[_ H]". - iInduction efs as [|ef efs] "IH" forall (t); first done. - rewrite /= !drop_app_alt //=. - iDestruct "H" as "[H1 H]". rewrite (right_id [] (++)). iFrame. - replace (map (λ '(tnew, e), fork_post (locale_of tnew e)) - (prefixes_from (t ++ [ef]) efs)) - with - (newposts (t ++[ef]) ((t ++ [ef]) ++ efs)). - + iSpecialize ("IH" with "H"). iApply (big_sepL_impl with "IH"). - iIntros "!>" (k e Hin) "H". by list_simplifier. - + list_simplifier. - replace (t ++ ef :: efs) with ((t ++ [ef]) ++ efs); last by list_simplifier. - rewrite drop_app_alt //. - Qed. - - Lemma take_step s Φs ex atr c c' oζ: - valid_exec ex → - trace_ends_in ex c → - locale_step c oζ c' → - config_wp -∗ - state_interp ex atr -∗ - wptp s c.1 Φs ={⊤,∅}=∗ |={∅}▷=>^(S (trace_length ex)) - |={∅,⊤}=> - ⌜∀ e2, s = NotStuck → e2 ∈ c'.1 → not_stuck e2 c'.2⌝ ∗ - ∃ δ' ℓ, - state_interp (trace_extend ex oζ c') (trace_extend atr ℓ δ') ∗ - posts_of c'.1 (Φs ++ newposts c.1 c'.1) ∗ - (posts_of c'.1 (Φs ++ newposts c.1 c'.1) -∗ - wptp s c'.1 (Φs ++ newposts c.1 c'.1)). - Proof. - iIntros (Hexvalid Hexe Hstep) "config_wp HSI Hc1". - inversion Hstep as - [ρ1 ρ2 e1 σ1 e2 σ2 efs t1 t2 -> -> Hpstep | ρ1 ρ2 σ1 σ2 t -> -> Hcfgstep]. - - rewrite /= !prefixes_from_app. - iDestruct (big_sepL2_app_inv_l with "Hc1") as - (Φs1 Φs2') "[-> [Ht1 Het2]]". - iDestruct (big_sepL2_cons_inv_l with "Het2") as (Φ Φs2) "[-> [He Ht2]]". - iDestruct (wp_take_step with "HSI He") as "He"; [done|done|done|done|]. - iMod "He" as "He". iModIntro. iMod "He" as "He". iModIntro. iNext. - iMod "He" as "He". iModIntro. - iApply (step_fupdN_wand with "[He]"); first by iApply "He". - iIntros "He". - iMod "He" as (δ' ℓ) "(HSI & He2 & Hefs) /=". - have Heq: forall a b c d, a ++ e1 :: c ++ d = (a ++ e1 :: c) ++ d. - { intros **. by list_simplifier. } - iAssert (wptp_from (t1 ++ e2 :: t2) s efs (newposts (t1 ++ e2 :: t2) ((t1 ++ e2 :: t2) ++ efs))) - with "[Hefs]" as "Hefs". - { rewrite -new_threads_wptp_from. iApply (big_sepL_impl with "Hefs"). - iIntros "!#" (i e Hin) "Hwp". list_simplifier. - erewrite locale_equiv; first by iFrame. - apply locales_equiv_middle. erewrite locale_step_preserve =>//. } - assert (valid_exec (ex :tr[Some (locale_of t1 e1)]: (t1 ++ e2 :: t2 ++ efs, σ2))). - { econstructor; eauto. } - iMod (wptp_not_stuck_same _ _ σ2 _ _ [] with "HSI Hefs") as "[HSI [Hefs %]]"; [done| | ]. - { list_simplifier. done. } - iMod (wptp_not_stuck_same _ _ σ2 _ _ (e2 :: (t2 ++ efs)) with "HSI Ht1") as "[HSI [Ht1 %]]"; [done| |]. - { list_simplifier. done. } - iMod (wptp_not_stuck _ _ σ2 _ (t1 ++ [e2]) _ efs with "HSI Ht2") as "[HSI [Ht2 %]]"; [| done | |]. - { rewrite !prefixes_from_app. apply Forall2_app. - - apply locales_equiv_refl. - - constructor; last constructor. list_simplifier. erewrite <-locale_step_preserve =>//. } - { list_simplifier. done. } - iMod (wp_not_stuck _ _ ectx_emp with "HSI He2") as "[HSI [He2 %]]"; - [done|by rewrite ectx_fill_emp|by erewrite <-locale_step_preserve|]. - - iDestruct (wptp_app with "Ht2 Hefs") as "Ht2efs". - { by list_simplifier. } - erewrite (locale_step_preserve e1 e2) =>//. - iDestruct (wptp_cons_l with "He2 Ht2efs") as "He2t2efs". - iDestruct (wptp_app with "Ht1 He2t2efs") as "Hc2"; [by list_simplifier|]. - iMod (wptp_of_val_post with "Hc2") as "[Hc2posts Hc2back]". - iModIntro; simpl in *. - iSplit. - { iPureIntro; set_solver. } - iExists δ', ℓ. - rewrite -!app_assoc. - iFrame. - list_simplifier. - erewrite newposts_locales_equiv; - [iFrame | apply locales_equiv_middle; erewrite <-locale_step_preserve =>//]. - iIntros "H". iSpecialize ("Hc2back" with "H"). - rewrite prefixes_from_app //. - - rewrite /= /config_wp. - iDestruct ("config_wp" with "[] [] [] HSI") as "Hcfg"; [done|done|done|]. - iMod "Hcfg". iModIntro. iMod "Hcfg". iModIntro. - iNext. iMod "Hcfg". iModIntro. - iApply (step_fupdN_wand with "[Hcfg]"); first by iApply "Hcfg". - iIntros "Hcfg". - iMod "Hcfg" as (δ2 ℓ) "HSI". - assert (valid_exec (ex :tr[None]: ((t, σ1).1, σ2))). - { econstructor; eauto. } - iMod (wptp_not_stuck _ _ σ2 _ _ _ [] with "HSI Hc1") as "[HSI [Hc1 %]]"; - [apply locales_equiv_refl|done|by list_simplifier|]. - iMod (wptp_of_val_post with "Hc1") as "[Hc1posts Hc1back]". - iModIntro. - iSplit; first by auto. - iExists δ2, ℓ. - rewrite newposts_same_empty. list_simplifier. - iFrame. - Qed. - -End adequacy_helper_lemmas. - -(** Fixpoint definition of the soundness goal of Trillium *) -Definition fupd_to_bupd_aux `{invGS_gen hlc Σ} - (rec : coPset → iProp Σ) (E1 : coPset) : iProp Σ := - ∀ (P : iProp Σ) E2, ((|={E1,E2}=> rec E2 -∗ P) ==∗ ◇ P). - -Definition fupd_to_bupd `{invGS_gen hlc Σ} := - bi_greatest_fixpoint fupd_to_bupd_aux. - -Instance fupd_to_bupd_aux_bi_mono `{invGS_gen hlc Σ} : - BiMonoPred (fupd_to_bupd_aux). -Proof. - split. - - iIntros (Φ Ψ HΦne HΨne) "#H". iIntros (E1) "HE". iIntros (P E2) "HP". - iApply "HE"; iMod "HP"; iModIntro. by iIntros; iApply "HP"; iApply "H". - - iIntros (Φ HΦne). by intros ??? ->%leibniz_equiv. -Qed. - -Lemma fupd_to_bupd_unfold `{invGS_gen hlc Σ} E : - fupd_to_bupd E ≡ fupd_to_bupd_aux fupd_to_bupd E. -Proof. by rewrite /fupd_to_bupd greatest_fixpoint_unfold. Qed. - -Lemma fupd_to_bupd_soundness_no_lc `{!invGpreS Σ} (Q : iProp Σ) : - (∀ `{Hinv: !invGS_gen HasNoLc Σ}, fupd_to_bupd ⊤ -∗ Q) → ⊢ |==> Q. -Proof. - iIntros (Hfupd). - iMod (@wsat_alloc _ (invGpreS0.(invGpreS_wsat))) as (Hw) "[Hw HE]". - iMod (@later_credits.le_upd.lc_alloc _ (invGpreS0.(invGpreS_lc)) 0) as (Hc) "_". - set (Hi := InvG HasNoLc _ Hw Hc). - iApply (@Hfupd Hi). - assert (NonExpansive (λ E, wsat ∗ ownE E)%I). - { by intros ??? ->%leibniz_equiv. } - iApply (greatest_fixpoint_coiter _ (λ E, wsat ∗ ownE E)%I with "[] [$Hw $HE]"). - iIntros "!>" (E1) "?". - iIntros (P E2) "HP". - rewrite fancy_updates.uPred_fupd_unseal /fancy_updates.uPred_fupd_def /=. - iMod ("HP" with "[$]") as ">(Hw & HE & HP)". - do 2 iModIntro; iApply "HP"; iFrame. -Qed. - -Lemma fupd_to_bupd_soundness_no_lc' `{!invGpreS Σ} (Q : iProp Σ) `{!Plain Q} : - (∀ `{Hinv: !invGS_gen HasNoLc Σ}, fupd_to_bupd ⊤ -∗ Q) → ⊢ Q. -Proof. by iIntros; iApply bupd_plain; iApply fupd_to_bupd_soundness_no_lc. Qed. - -Theorem wp_strong_adequacy_multiple_helper Σ Λ M `{!invGpreS Σ} - (s: stuckness) (ξ : execution_trace Λ → auxiliary_trace M → Prop) - es σ δ: - length es ≥ 1 → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (trace_inv : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φs : list (val Λ → iProp Σ)) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - config_wp ∗ - stateI (trace_singleton (es, σ)) (trace_singleton δ) ∗ - wptp s es Φs ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex (es, σ)⌝ -∗ - ⌜trace_starts_in atr δ⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → - trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv es (take (length es) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φs ++ ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> - (prefixes_from es (drop (length es) c.1)))) -∗ - □ (stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → - ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗ - ((∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → - ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤, ∅}=∗ ⌜ξ ex atr⌝))) → - ⊢ Gsim Σ M s ξ (trace_singleton (es, σ)) (trace_singleton δ). -Proof. - intros Hes Hwp. - apply extract_except_0. - iApply fupd_to_bupd_soundness_no_lc'. - iIntros (Hinv) "HFtB". - rewrite fupd_to_bupd_unfold /fupd_to_bupd_aux. - iApply bupd_plain. - iApply "HFtB". - iPoseProof (Hwp Hinv) as "Hwp". - iMod "Hwp" as (stateI trace_inv Φs fork_post) - "(#config_wp & HSI & Hwp & Hstep)". - clear Hwp. - set (IrisG Λ M Σ Hinv stateI fork_post). - iAssert (∃ ex atr c1 δ1, - ⌜trace_singleton (es, σ) = ex⌝ ∗ - ⌜trace_singleton δ = atr⌝ ∗ - ⌜(es, σ) = c1⌝ ∗ - ⌜δ = δ1⌝ ∗ - ⌜length c1.1 ≥ 1⌝ ∗ - stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → - ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') ∗ - wptp s c1.1 (Φs ++ ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> - (prefixes_from es (drop (length es) c1.1)))))%I - with "[HSI Hwp]" as "Hex". - { iExists (trace_singleton (es, σ)), (trace_singleton δ), (es, σ), δ; simpl. - rewrite drop_ge; [|lia]. rewrite right_id. - iFrame. - repeat (iSplit; first by auto). - iIntros (???? ?%not_trace_contract_singleton); done. } - iDestruct "Hex" as (ex atr c1 δ1 Hexsing Hatrsing Hc1 Hδ1 Hlen) "(HSI & HTI & Htp)". - assert - (valid_system_trace ex atr ∧ - trace_starts_in ex (es, σ) ∧ - trace_ends_in ex c1 ∧ - trace_starts_in atr δ ∧ - (∀ ex' atr' oζ ℓ, - trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr') ∧ - locales_equiv es (take (length es) c1.1) ∧ - length es ≤ length c1.1) - as Hextras. - { rewrite -Hexsing -Hatrsing -Hc1. - split; first apply valid_system_trace_singletons. - repeat (split; first done). - split; [intros ? ? ? ? ? ?%not_trace_contract_singleton; done|]. - split; [|done]. - rewrite take_ge; [apply locales_equiv_refl|done]. - } - clear Hc1 Hδ1. - rewrite Hexsing Hatrsing; clear Hexsing Hatrsing. - iLöb as "IH" forall (ex atr c1 Hextras Hlen) "HSI HTI Htp". - destruct Hextras as (Hv & Hex & Hc1 & Hatr & Hξ & Htake & Htakelen). - rewrite {2}/Gsim (fixpoint_unfold (Gsim_pre _ _ _ _) _ _). - destruct c1 as [tp σ1']. - assert (valid_exec ex) as Hexv. - { by eapply valid_system_trace_valid_exec_trace. } - iPoseProof (wptp_not_stuck _ _ _ _ _ _ [] with "[$HSI] Htp") as "Htp"; - [apply locales_equiv_refl|done|by list_simplifier|]. - iMod ("Htp") as "(HSI & Htp & %Hnstk)". - rewrite (last_eq_trace_ends_in _ (tp, σ1')) in Hnstk; last done. - iPoseProof (wptp_of_val_post with "Htp") as "Htp". - iMod ("Htp") as "(Hpost & Hback)". - iAssert (|={⊤}=> ▷ ⌜ξ ex atr⌝ ∗ (_ ∗ _ ∗ _ ∗ _))%I with "[Hstep HTI HSI Hpost]" - as ">[Hξ (HSI & Hpost & HTI & Hstep)]". - { iCombine "HTI" "Hstep" as "HS". - iCombine "Hpost" "HS" as "HS". - iCombine "HSI" "HS" as "HS". - iApply fupd_plain_keep_l; iSplitR; [|iExact "HS"]. - iIntros "(HSI & Hpost & HTI & Hstep)". - iDestruct ("Hstep" with "[] [] [] [] [] [] [] HSI Hpost") as "[_ Hξ]"; auto. - iApply fupd_plain_mask. - iMod ("Hξ" with "HTI") as "%"; auto. } - iAssert (□ (stateI ex atr -∗ - (∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → - ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr))%I as "#HTIextend". - { iDestruct ("Hstep" with "[] [] [] [] [] [] [] HSI Hpost") as "[#Hext _]"; - auto. - iModIntro. - iIntros "HSI HTI". - iApply ("Hext" with "[$HSI $HTI]"). } - iMod ("HTIextend" with "HSI HTI") as "[HSI HTI]". - iDestruct ("Hback" with "Hpost") as "Htp". - iModIntro. - iIntros "HFtB". - iNext; iSplit; first done. - iDestruct "Hξ" as %Hξ'. - iIntros (c oζ c' Hc Hstep). - pose proof (trace_ends_in_inj ex c (tp, σ1') Hc Hc1); simplify_eq. - iPoseProof (take_step with "config_wp HSI Htp") as "Hstp"; [done|done|done|]. - assert (∃ n, n = trace_length ex) as [n Hn] by eauto. - rewrite -Hn. - clear Hn. - rewrite -> fupd_to_bupd_unfold; rewrite /fupd_to_bupd_aux. - iApply except_0_later. - iApply bupd_plain. - iApply "HFtB". - iMod "Hstp"; simpl. - iMod "Hstp". - iModIntro. - iIntros "HFtB". - rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. - iNext. - iApply except_0_later. - iApply bupd_plain. - iApply "HFtB". - iMod "Hstp". - iModIntro. - iIntros "HFtB". - (* TODO: This should be generalisable in a lemma *) - iInduction n as [|n] "IHlen"; simpl; last first. - { rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. - iApply except_0_later. - iApply bupd_plain. - iApply "HFtB". - iMod "Hstp". - iModIntro. - iIntros "HFtB". - rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. - iNext. - iApply except_0_later. - iApply bupd_plain. - iApply "HFtB". - iMod "Hstp". - iModIntro. - iIntros "HFtB". - rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. - iApply ("IHlen" with "Hstep HTI Hstp"); done. } - rewrite (fupd_to_bupd_unfold (∅ : coPset)); rewrite /fupd_to_bupd_aux. - iApply except_0_later. - iApply bupd_plain. - iApply "HFtB". - iMod "Hstp" as "(% & H)". - iModIntro. - iIntros "HFtB". - iDestruct "H" as (δ'' ℓ) "(HSI & Hpost & Hback)"; simpl in *. - iSpecialize ("Hback" with "Hpost"). - (* TODO: Generalise this as its own lemma *) - assert (Hlocales: ((λ '(tnew, e), weakestpre.fork_post (locale_of tnew e)) <$> - (prefixes_from es (drop (length es) tp))) ++ - ((λ '(tnew, e), weakestpre.fork_post (locale_of tnew e)) <$> - (prefixes_from tp (drop (length tp) c'.1))) = - ((λ '(tnew, e), weakestpre.fork_post (locale_of tnew e)) <$> - (prefixes_from es (drop (length es) c'.1)))). - { rewrite -fmap_app. apply locales_of_list_from_fork_post. rewrite fmap_app. - apply locale_step_equiv in Hstep. - rewrite (locales_equiv_prefix_drop_alt _ tp); [|done]. - rewrite -drop_app_le; last first. - { rewrite fmap_length. rewrite prefixes_from_length. lia. } - rewrite (locales_equiv_prefix_drop_alt es c'.1); - [|by eapply locales_equiv_prefix_trans]. - f_equiv. - rewrite -fmap_app -prefixes_from_app -locales_of_list_equiv. - by apply locales_equiv_from_comm, locales_equiv_prefix_from_drop. } - iAssert (▷ ⌜ξ (ex :tr[oζ]: c') (atr :tr[ℓ]: δ'')⌝)%I as "#Hextend'". - { iDestruct ("Hstep" with "[] [] [] [] [] [] [] HSI") as "H"; [iPureIntro..|]. - - eapply valid_system_trace_extend; eauto. - - eapply trace_extend_starts_in; eauto. - - eapply trace_extend_starts_in; eauto. - - eapply trace_extend_ends_in; eauto. - - by intros ? ? ? ? [-> ->]%trace_contract_of_extend [-> ->]%trace_contract_of_extend. - - done. - - eapply locales_equiv_from_transitive; - [by apply locales_equiv_refl|by apply locales_equiv_refl|done|]. - apply locale_step_equiv in Hstep. - eapply (locales_equiv_from_take _ _ _ _ (length es)) in Hstep. - rewrite !firstn_firstn in Hstep. - rewrite !min_l in Hstep; [done|simpl; lia]. - - rewrite -app_assoc Hlocales. - iPoseProof (wptp_of_val_post with "Hback") as "Hback". - rewrite -> (fupd_to_bupd_unfold (⊤ : coPset)); rewrite /fupd_to_bupd_aux. - iApply except_0_later. - iApply bupd_plain. - iApply "HFtB". - iMod "Hback" as "(Hpost & Hwptp)". - iDestruct ("H" with "Hpost") as "[? Hξ]". - iMod ("Hξ" with "[HTI]") as "%". - + iIntros (? ? ? ? [-> ->]%trace_contract_of_extend - [-> ->]%trace_contract_of_extend); done. - + iModIntro. - iIntros "HFtB"; done. } - iExists _, _. - rewrite -> (fupd_to_bupd_unfold (⊤ : coPset)); rewrite /fupd_to_bupd_aux. - iApply except_0_later. - iApply bupd_plain. - iApply "HFtB". - iMod ("IH" with "[] [] Hstep HSI [HTI] [Hback]") as "IH'". - - iPureIntro; split_and!. - + eapply valid_system_trace_extend; eauto. - + eapply trace_extend_starts_in; eauto. - + eapply trace_extend_ends_in; eauto. - + eapply trace_extend_starts_in; eauto. - + by intros ???? [-> ->]%trace_contract_of_extend - [-> ->]%trace_contract_of_extend. - + eapply locales_equiv_from_transitive; - [by apply locales_equiv_refl|by apply locales_equiv_refl|done|]. - apply locale_step_equiv in Hstep. - eapply (locales_equiv_from_take _ _ _ _ (length es)) in Hstep. - rewrite !firstn_firstn in Hstep. - rewrite !min_l in Hstep; [done|simpl; lia]. - + eapply step_tp_length in Hstep. by etransitivity. - - iPureIntro. pose proof (step_tp_length _ _ _ Hstep). simpl in *. lia. - - iIntros (???? [-> ->]%trace_contract_of_extend - [-> ->]%trace_contract_of_extend); done. - - rewrite -app_assoc Hlocales //. - - iModIntro. iIntros "HFtB". iNext. iApply "IH'"; done. -Qed. - -Theorem wp_strong_adequacy_helper Σ Λ M `{!invGpreS Σ} - (s: stuckness) (ξ : execution_trace Λ → auxiliary_trace M → Prop) - e1 σ1 δ: - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (trace_inv : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φ : val Λ → iProp Σ) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - config_wp ∗ - stateI (trace_singleton ([e1], σ1)) (trace_singleton δ) ∗ - WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex ([e1], σ1)⌝ -∗ - ⌜trace_starts_in atr δ⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv [e1] (take (length [e1]) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φ :: ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗ - □ (stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗ - ((∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤, ∅}=∗ ⌜ξ ex atr⌝))) → - ⊢ Gsim Σ M s ξ (trace_singleton ([e1], σ1)) (trace_singleton δ). -Proof. - intros Hwp. apply wp_strong_adequacy_multiple_helper; [done|simpl;lia|]. - iIntros (Hinv). - iMod (Hwp Hinv) as (stateI trace_inv Φs fork_post) - "(#config_wp & HSI & Hwp & Hstep)". - iIntros "!>". iExists stateI, trace_inv, [Φs], fork_post. by iFrame "#∗". -Qed. - -Definition rel_finitary {A B C D} - (ξ : finite_trace A B → finite_trace C D → Prop) := - ∀ (ex : finite_trace A B) (atr : finite_trace C D) c' oζ, - smaller_card (sig (λ '(δ', ℓ), ξ (ex :tr[oζ]: c') (atr :tr[ℓ]: δ'))) nat. - -Section finitary_lemma. - Lemma rel_finitary_impl {A B C D} `{EqDecision C, EqDecision D} - (ξ ξ' : finite_trace A B -> finite_trace C D -> Prop): - (∀ ex aux, ξ ex aux -> ξ' ex aux) -> - rel_finitary ξ' -> - rel_finitary ξ. - Proof. - intros Himpl Hξ' ex aux c' oζ. - assert ( - ∀ ξ x, ProofIrrel - (match x return Prop with (δ', ℓ) => - ξ (ex :tr[ oζ ]: c') (aux :tr[ ℓ ]: δ') - end)). - { intros ?[??]. apply make_proof_irrel. } - apply finite_smaller_card_nat. - specialize (Hξ' ex aux c' oζ). apply smaller_card_nat_finite in Hξ'. - eapply (in_list_finite (map proj1_sig (@enum _ _ Hξ'))). - intros [δ' ℓ] ?. apply elem_of_list_fmap. - assert ((λ '(δ', ℓ), ξ' (ex :tr[ oζ ]: c') (aux :tr[ ℓ ]: δ')) (δ', ℓ)) by eauto. - exists ((δ', ℓ) ↾ ltac:(eauto)). split =>//. - apply elem_of_enum. - Qed. -End finitary_lemma. - -(** We can extract the simulation correspondence in the meta-logic - from a proof of the simulation correspondence in the object-logic. *) -Theorem simulation_correspondence_multiple Λ M Σ `{!invGpreS Σ} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - es σ δ : - rel_finitary ξ → - (⊢ Gsim Σ M s ξ {tr[ (es, σ) ]} {tr[ δ ]}) → - continued_simulation ξ {tr[ (es, σ) ]} {tr[δ]}. -Proof. - intros Hsc Hwptp. - exists (λ exatr, ⊢ Gsim Σ M s ξ exatr.1 exatr.2); split; first done. - clear Hwptp. - intros [ex atr]. - rewrite {1}/Gsim (fixpoint_unfold (Gsim_pre _ _ _ _) _ _); simpl; intros Hgsim. - revert Hgsim; rewrite extract_later; intros Hgsim. - apply extract_and in Hgsim as [Hvlt Hgsim]. - revert Hvlt; rewrite extract_pure; intros Hvlt. - split; first done. - intros c c' oζ Hsmends Hstep. - revert Hgsim; rewrite extract_forall; intros Hgsim. - specialize (Hgsim c). - revert Hgsim; rewrite extract_forall; intros Hgsim. - specialize (Hgsim oζ). - revert Hgsim; rewrite extract_forall; intros Hgsim. - specialize (Hgsim c'). - apply (extract_impl ⌜_⌝) in Hgsim; last by apply extract_pure. - apply (extract_impl ⌜_⌝) in Hgsim; last by apply extract_pure. - induction (trace_length ex) as [|n IHlen]; last first. - { simpl in *. - revert Hgsim; do 3 rewrite extract_later; intros Hgsim. - apply IHlen. do 2 rewrite extract_later. apply Hgsim. } - revert Hgsim; rewrite !extract_later; intros Hgsim. - simpl in *. - assert (⊢ ▷ ∃ (δ': M) ℓ, - (⌜ξ (ex :tr[oζ]: c') (atr :tr[ℓ]: δ')⌝) ∧ - fixpoint (Gsim_pre Σ M s ξ) (ex :tr[oζ]: c') (atr :tr[ℓ]: δ')). - { iStartProof. iDestruct Hgsim as (δ'' ℓ) "Hfix". iExists δ'', ℓ. - iSplit; last done. - rewrite (fixpoint_unfold (Gsim_pre _ _ _ _) _ _) /Gsim_pre. - iNext. by iDestruct "Hfix" as "[? _]". } - rewrite -> extract_later in H. - apply extract_exists_alt2 in H as (δ'' & ℓ & H); last done. - exists δ'', ℓ. - revert H. - rewrite !extract_and. - intros [_ ?]; done. -Qed. - -(** We can extract the simulation correspondence in the meta-logic - from a proof of the simulation correspondence in the object-logic. *) -Theorem simulation_correspondence Λ M Σ `{!invGpreS Σ} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - e1 σ1 δ1 : - rel_finitary ξ → - (⊢ Gsim Σ M s ξ {tr[ ([e1], σ1) ]} {tr[ δ1 ]}) → - continued_simulation ξ {tr[ ([e1], σ1) ]} {tr[δ1]}. -Proof. by apply simulation_correspondence_multiple. Qed. - -Theorem wp_strong_adequacy_multiple_with_trace_inv Λ M Σ `{!invGpreS Σ} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - es σ δ : - length es ≥ 1 → - rel_finitary ξ → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (trace_inv : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φs : list (val Λ → iProp Σ)) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - config_wp ∗ - stateI (trace_singleton (es, σ)) (trace_singleton δ) ∗ - wptp s es Φs ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) (c : cfg Λ), - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex (es, σ)⌝ -∗ - ⌜trace_starts_in atr δ⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv es (take (length es) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φs ++ ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from es (drop (length es) c.1)))) -∗ - □ (stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗ - ((∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤, ∅}=∗ ⌜ξ ex atr⌝))) → - continued_simulation ξ (trace_singleton (es, σ)) (trace_singleton δ). -Proof. - intros Hlen Hsc Hwptp%wp_strong_adequacy_multiple_helper; [|by done..]. - by eapply simulation_correspondence_multiple. -Qed. - -Theorem wp_strong_adequacy_with_trace_inv Λ M Σ `{!invGpreS Σ} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - e1 σ1 δ1 : - rel_finitary ξ → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (trace_inv : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φ : val Λ → iProp Σ) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - config_wp ∗ - stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗ - WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) (c : cfg Λ), - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex ([e1], σ1)⌝ -∗ - ⌜trace_starts_in atr δ1⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv [e1] (take (length [e1]) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φ :: ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗ - □ (stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗ - ((∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤, ∅}=∗ ⌜ξ ex atr⌝))) → - continued_simulation ξ (trace_singleton ([e1], σ1)) (trace_singleton δ1). -Proof. - intros Hsc Hwptp%wp_strong_adequacy_helper; last done. - by eapply simulation_correspondence. -Qed. - -Theorem wp_strong_adequacy_multiple Λ M Σ `{!invGpreS Σ} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - es σ δ : - length es ≥ 1 → - rel_finitary ξ → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φs : list (val Λ → iProp Σ)) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - config_wp ∗ - stateI (trace_singleton (es, σ)) (trace_singleton δ) ∗ - wptp s es Φs ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex (es, σ)⌝ -∗ - ⌜trace_starts_in atr δ⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv es (take (length es) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φs ++ ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from es (drop (length es) c.1)))) -∗ - |={⊤, ∅}=> ⌜ξ ex atr⌝)) -> - continued_simulation ξ (trace_singleton (es, σ)) (trace_singleton δ). -Proof. - intros Hlen Hsc Hwptp. - eapply wp_strong_adequacy_multiple_with_trace_inv; [done|done|done|]. - iIntros (Hinv) "". - iMod (Hwptp Hinv) as (stateI Φ fork_post) "(Hwpcfg & HSI & Hwp & Hstep)". - iModIntro. - iExists stateI, (λ _ _, True)%I, Φ, fork_post; iFrame "Hwpcfg HSI Hwp". - iIntros (ex atr c ? ? ? ? ? ? ?) "HSI Hposts". - iSplit; last first. - { iIntros "?". iApply ("Hstep" with "[] [] [] [] [] [] [] HSI"); eauto. } - iModIntro; iIntros "[$ ?]"; done. -Qed. - -Theorem wp_strong_adequacy Λ M Σ `{!invGpreS Σ} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - e1 σ1 δ1 : - rel_finitary ξ → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φ : val Λ → iProp Σ) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - config_wp ∗ - stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗ - WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex ([e1], σ1)⌝ -∗ - ⌜trace_starts_in atr δ1⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv [e1] (take (length [e1]) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φ :: ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗ - |={⊤, ∅}=> ⌜ξ ex atr⌝)) -> - continued_simulation ξ (trace_singleton ([e1], σ1)) (trace_singleton δ1). -Proof. - intros Hsc Hwptp. - eapply wp_strong_adequacy_with_trace_inv; [done|done|]. - iIntros (Hinv) "". - iMod (Hwptp Hinv) as (stateI Φ fork_post) "(Hwpcfg & HSI & Hwp & Hstep)". - iModIntro. - iExists stateI, (λ _ _, True)%I, Φ, fork_post; iFrame "Hwpcfg HSI Hwp". - iIntros (ex atr c ? ? ? ? ? ? ?) "HSI Hposts". - iSplit; last first. - { iIntros "?". iApply ("Hstep" with "[] [] [] [] [] [] [] HSI"); eauto. } - iModIntro; iIntros "[$ ?]"; done. -Qed. - -(** Since the full adequacy statement is quite a mouthful, we prove some more -intuitive and simpler corollaries. These lemmas are morover stated in terms of -[rtc erased_step] so one does not have to provide the trace. *) -Record adequate_multiple {Λ} (s : stuckness) (es : list $ expr Λ) (σ1 : state Λ) - (φs : list (val Λ → state Λ → Prop)) : Prop := { - adequate_result ex t2 σ2 i v : - i < length es → - i < length φs → - valid_exec ex → - trace_starts_in ex (es, σ1) → - trace_ends_in ex (t2, σ2) → - t2 !! i ≫= to_val = Some v → - from_option (λ φ, φ v σ2) False (φs !! i); - adequate_not_stuck ex t2 σ2 e2 : - s = NotStuck → - valid_exec ex → - trace_starts_in ex (es, σ1) → - trace_ends_in ex (t2, σ2) → - e2 ∈ t2 → not_stuck e2 σ2 -}. - -Definition adequate {Λ} (s : stuckness) (e : expr Λ) (σ1 : state Λ) - (φ : val Λ → state Λ → Prop) : Prop := - adequate_multiple s [e] σ1 [φ]. - -Lemma adequate_multiple_alt {Λ} s es σ1 (φs : list (val Λ → state Λ → Prop)) : - adequate_multiple s es σ1 φs ↔ ∀ ex t2 σ2, - valid_exec ex → - trace_starts_in ex (es, σ1) → - trace_ends_in ex (t2, σ2) → - (∀ i v, - i < length es → - i < length φs → - t2 !! i ≫= to_val = Some v → - from_option (λ φ, φ v σ2) False (φs !! i)) ∧ - (∀ e2, s = NotStuck → e2 ∈ t2 → not_stuck e2 σ2). -Proof. - split. - - intros []; naive_solver. - - constructor; naive_solver. -Qed. - -Theorem adequate_multiple_tp_safe {Λ} (es : list $ expr Λ) ex t2 σ1 σ2 φs : - adequate_multiple NotStuck es σ1 φs → - valid_exec ex → - trace_starts_in ex (es, σ1) → - trace_ends_in ex (t2, σ2) → - Forall (λ e, is_Some (to_val e)) t2 ∨ ∃ t3 σ3, step (t2, σ2) (t3, σ3). -Proof. - intros Had ? ? ?. - destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|]. - apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2). - destruct (adequate_not_stuck NotStuck es σ1 φs Had ex t2 σ2 e2) - as [?|(e3&σ3&efs&?)]; - rewrite ?eq_None_not_Some; auto. - { exfalso. eauto. } - destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto. - right; exists (t2' ++ e3 :: t2'' ++ efs), σ3; econstructor; eauto. -Qed. - -Local Definition wp_adequacy_relation Λ M s (φs : list (val Λ → Prop)) - (ex : execution_trace Λ) (atr : auxiliary_trace M) : Prop := - ∀ c, trace_ends_in ex c → - (∀ i v, - i < length φs → - c.1 !! i ≫= to_val = Some v → - from_option (λ φ, φ v) False (φs !! i)) ∧ - (∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2). - -Local Lemma wp_adequacy_relation_adequacy_multiple {Λ M} s es σ δ φs (ξ : _ -> _ -> Prop): - (forall ex aux, ξ ex aux -> wp_adequacy_relation Λ M s φs ex aux) -> - continued_simulation - ξ - (trace_singleton (es, σ)) - (trace_singleton δ) → - adequate_multiple s es σ ((λ φ v _, φ v) <$> φs). -Proof. - intros Himpl Hsm; apply adequate_multiple_alt. - intros ex t2 σ2 Hex Hexstr Hexend. - eapply simulation_does_continue in Hex as [atr [? Hatr]]; eauto. - rewrite -> continued_simulation_unfold in Hatr. - destruct Hatr as (Hψ & Hatr). - apply Himpl in Hψ. - specialize (Hψ (t2, σ2)) as [Hsafe Hstuck]; [done|]. - split; [|done]. - intros i v Hlen1 Hlen2 Ht2. - rewrite fmap_length in Hlen2. - specialize (Hsafe i v Hlen2 Ht2). - clear Himpl Ht2 Hsm Hexstr. revert i es Hlen1 Hlen2 Hsafe. - induction φs as [|φ φs Hφs]; intros i es Hlen1 Hlen2 Hsafe; [done|]. - destruct es as [|e es]; [simpl in *;lia|]. - rewrite fmap_cons. destruct i; [done|]. simpl in *. - eapply (Hφs _ es); [lia|lia|done]. -Qed. - -Corollary adequacy_multiple_xi Λ M Σ `{!invGpreS Σ} `{EqDecision (mlabel M), EqDecision M} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - (φs : list (val Λ → Prop)) - es σ1 δ1 : - length es ≥ 1 → - rel_finitary ξ → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (trace_inv : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φs : list (val Λ → iProp Σ)) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - ⌜length φs = length Φs⌝ ∗ - config_wp ∗ - ([∗ list] Φ;φ ∈ Φs;φs, ∀ v, Φ v -∗ ⌜φ v⌝) ∗ - stateI (trace_singleton (es, σ1)) (trace_singleton δ1) ∗ - wptp s es Φs ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex (es, σ1)⌝ -∗ - ⌜trace_starts_in atr δ1⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv es (take (length es) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φs ++ ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from es (drop (length es) c.1)))) -∗ - □ (stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗ - ((∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤, ∅}=∗ ⌜ξ ex atr⌝))) → - adequate_multiple s es σ1 ((λ φ v _, φ v) <$> φs). -Proof. - pose (ξ' := λ ex aux, ξ ex aux ∧ wp_adequacy_relation Λ M s φs ex aux). - intros ?? Hwp; apply (wp_adequacy_relation_adequacy_multiple (M := M) _ _ _ δ1 _ ξ'). - { by intros ??[??]. } - apply (wp_strong_adequacy_multiple_with_trace_inv Λ M Σ s); [done|..]. - { apply (rel_finitary_impl ξ' ξ) =>//. by intros ??[??]. } - iIntros (?) "". - iMod Hwp as (stateI post Φs fork_post) "(%Hlen & config_wp & HΦs & HSI & Hwp & H)". - iModIntro; iExists _, _, _, _. iFrame "config_wp HSI Hwp". - iIntros (ex atr c Hvlt Hexs Hexe Hatre Hψ Hnst Hlocale) "HSI Hposts". - iSpecialize ("H" with "[//] [//] [//] [//] [] [//] [//]"). - - iPureIntro. intros ??????. by eapply Hψ. - - iAssert (⌜∀ i v, - i < length φs → - c.1 !! i ≫= to_val = Some v → - from_option (λ φ, φ v) False (φs !! i)⌝)%I - as %Hφ. - { iIntros (i v Hi HSome). - iClear "H HSI". - clear Hwp ξ' Hψ. - rewrite big_sepL_omap big_sepL_zip_with. - assert (∃ e, c.1 !! i = Some e ∧ to_val e = Some v) as [e [HSome' Hv]]. - { by apply bind_Some. } - iDestruct (big_sepL_lookup with "Hposts") as "Hposts"; [done|]. - rewrite lookup_app_l; [|lia]. - assert (∃ φ, φs !! i = Some φ) as [φ Heqφ]. - { by apply lookup_lt_is_Some_2. } - assert (∃ Φ, Φs !! i = Some Φ) as [Φ HeqΦ]. - { rewrite Hlen in Hi. by apply lookup_lt_is_Some_2. } - rewrite HeqΦ Hv /=. - iDestruct (big_sepL2_insert_acc with "HΦs") as "[HΦs _]"; [done|done|]. - iDestruct ("HΦs" with "Hposts") as "Hφ". - by rewrite Heqφ. } - iDestruct ("H" with "HSI Hposts") as "[? H]". iSplit =>//. - iIntros "H1". iMod ("H" with "H1"). iModIntro. iSplit=>//. - iIntros (c' Hc'). - assert (c' = c) as -> by by eapply trace_ends_in_inj. eauto. -Qed. - -Corollary adequacy_xi Λ M Σ `{!invGpreS Σ} `{EqDecision (mlabel M), EqDecision M} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - (φ : val Λ → Prop) - e1 σ1 δ1 : - rel_finitary ξ → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (trace_inv : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φ : val Λ → iProp Σ) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - config_wp ∗ - (∀ v, Φ v -∗ ⌜φ v⌝) ∗ - stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗ - WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex ([e1], σ1)⌝ -∗ - ⌜trace_starts_in atr δ1⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv [e1] (take (length [e1]) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φ :: ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗ - □ (stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗ - ((∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤, ∅}=∗ ⌜ξ ex atr⌝))) → - adequate s e1 σ1 (λ v _, φ v). -Proof. - intros Hsc Hwptp. - rewrite /adequate. - assert ([λ (v : val Λ) (_ : state Λ), φ v] = - (λ φ (v : val Λ) (_ : state Λ), φ v) <$> [φ]) as -> by done. - eapply adequacy_multiple_xi; [done|done|done|eauto|done|]. - iIntros (Hinv) "". - iMod (Hwptp Hinv) as (stateI trace_inv Φ fork_post) "(Hwpcfg & HΦ & HSI & Hwp & Hstep)". - iModIntro. - iExists stateI, trace_inv, [Φ], fork_post; iFrame "Hwpcfg HΦ HSI Hwp". - iSplit; [done|]. iSplit; [done|]. iSplit; [done|]. - iIntros (ex atr c ? ? ? ? ? ? ?) "HSI Hposts". - iApply ("Hstep" with "[] [] [] [] [] [] [] HSI"); eauto. -Qed. - -Corollary sim_and_adequacy_multiple_xi Λ M Σ `{!invGpreS Σ} `{EqDecision (mlabel M), EqDecision M} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - (φs : list (val Λ → Prop)) - es σ1 δ1 : - length es ≥ 1 → - rel_finitary ξ → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (trace_inv : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φs : list (val Λ → iProp Σ)) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - ⌜length φs = length Φs⌝ ∗ - config_wp ∗ - ([∗ list] Φ;φ ∈ Φs;φs, ∀ v, Φ v -∗ ⌜φ v⌝) ∗ - stateI (trace_singleton (es, σ1)) (trace_singleton δ1) ∗ - wptp s es Φs ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex (es, σ1)⌝ -∗ - ⌜trace_starts_in atr δ1⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv es (take (length es) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φs ++ ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from es (drop (length es) c.1)))) -∗ - □ (stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗ - ((∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤, ∅}=∗ ⌜ξ ex atr⌝))) → - (continued_simulation ξ (trace_singleton (es, σ1)) (trace_singleton δ1) ∧ - adequate_multiple s es σ1 ((λ φ v _, φ v) <$> φs)). -Proof. - intros ?? Hwp. split; eauto using adequacy_multiple_xi. - eapply wp_strong_adequacy_multiple_with_trace_inv; [done|done|done|]. - iIntros (?). iMod Hwp as (? ? ? ?) "(?&?&?&?&?)". - iModIntro. iExists _, _, _, _. iFrame. -Qed. - -Corollary sim_and_adequacy_xi Λ M Σ `{!invGpreS Σ} `{EqDecision (mlabel M), EqDecision M} - (s: stuckness) - (ξ : execution_trace Λ → auxiliary_trace M → Prop) - (φ : val Λ → Prop) - e1 σ1 δ1 : - rel_finitary ξ → - (∀ `{Hinv : !invGS_gen HasNoLc Σ}, - ⊢ |={⊤}=> ∃ - (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) - (trace_inv : execution_trace Λ → auxiliary_trace M → iProp Σ) - (Φ : val Λ → iProp Σ) - (fork_post : locale Λ → val Λ → iProp Σ), - let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in - config_wp ∗ - (∀ v, Φ v -∗ ⌜φ v⌝) ∗ - stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗ - WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗ - (∀ (ex : execution_trace Λ) (atr : auxiliary_trace M) c, - ⌜valid_system_trace ex atr⌝ -∗ - ⌜trace_starts_in ex ([e1], σ1)⌝ -∗ - ⌜trace_starts_in atr δ1⌝ -∗ - ⌜trace_ends_in ex c⌝ -∗ - ⌜∀ ex' atr' oζ ℓ, trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ - ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗ - ⌜locales_equiv [e1] (take (length [e1]) c.1)⌝ -∗ - stateI ex atr -∗ - posts_of c.1 (Φ :: ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗ - □ (stateI ex atr ∗ - (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗ - ((∀ ex' atr' oζ ℓ, - ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') - ={⊤, ∅}=∗ ⌜ξ ex atr⌝))) → - (continued_simulation ξ (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∧ - adequate s e1 σ1 (λ v _, φ v)). -Proof. - intros ? Hwp. split; eauto using adequacy_xi. - eapply wp_strong_adequacy_with_trace_inv; [done|done|]. - iIntros (?). iMod Hwp as (? ? ? ?) "(?&?&?&?&?)". - iModIntro. iExists _, _, _, _. iFrame. -Qed. - -(* Corollary wp_adequacy Λ M Σ `{!invGpreS Σ} s e σ δ φ : *) -(* (∀ `{Hinv : !invGS_gen HasNoLc Σ}, *) -(* ⊢ |={⊤}=> ∃ *) -(* (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) *) -(* (fork_post : locale Λ -> val Λ → iProp Σ), *) -(* let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in *) -(* config_wp ∗ stateI (trace_singleton ([e], σ)) (trace_singleton δ) ∗ *) -(* WP e @ s; locale_of [] e; ⊤ {{ v, ⌜φ v⌝ }}) → *) -(* adequate s e σ (λ v _, φ v). *) -(* Proof. *) -(* intros Hwp. *) -(* pose (ξ := λ ex aux, wp_adequacy_relation Λ M s φ ex aux). *) -(* eapply (wp_adequacy_relation_adequacy (M := M) _ _ _ δ φ ξ)=>//. *) -(* apply (wp_strong_adequacy Λ M Σ s). *) -(* { admit. } *) -(* iIntros (?) "". *) -(* iMod Hwp as (stateI fork_post) "(config_wp & HSI & Hwp)". *) -(* iModIntro; iExists _, _, _; iFrame. *) -(* iIntros (ex atr c Hvlt Hexs Hatrs Hexe Hψ Hnst) "HSI Hposts". *) -(* iApply fupd_mask_intro_discard; first done. *) -(* (* iPureIntro. *) *) -(* (* iSplit. *) *) -(* (* { *) *) -(* (* admit. *) *) -(* (* iSplit. *) *) -(* (* { *) *) -(* iIntros (c' Hc'). *) -(* assert (c' = c) as -> by by eapply trace_ends_in_inj. *) -(* iSplit; last done. *) -(* iIntros (v2 t2 ->). rewrite /= to_of_val /=. *) -(* iDestruct "Hposts" as "[% ?]"; done. *) -(* Qed. *) - -(* Local Definition wp_invariance_relation Λ M e1 σ1 t2 σ2 (φ : Prop) *) -(* (ex : execution_trace Λ) (atr : auxiliary_trace M) : Prop := *) -(* trace_starts_in ex ([e1], σ1) → trace_ends_in ex (t2, σ2) → φ. *) - -(* Local Lemma wp_invariance_relation_invariance {Λ M} e1 σ1 δ1 t2 σ2 φ : *) -(* continued_simulation *) -(* (wp_invariance_relation Λ M e1 σ1 t2 σ2 φ) *) -(* (trace_singleton ([e1], σ1)) *) -(* (trace_singleton δ1) → *) -(* ∀ ex, *) -(* valid_exec ex → *) -(* trace_starts_in ex ([e1], σ1) → *) -(* trace_ends_in ex (t2, σ2) → *) -(* φ. *) -(* Proof. *) -(* intros Hsm ex Hex Hexstr Hexend. *) -(* eapply simulation_does_continue in Hsm as [atr [? Hatr]]; eauto. *) -(* rewrite -> continued_simulation_unfold in Hatr. *) -(* destruct Hatr as (Hψ & Hatr); auto. *) -(* Qed. *) - -(* Corollary wp_invariance Λ M Σ `{!invGpreS Σ} s e1 σ1 δ1 t2 σ2 φ : *) -(* rel_finitary (wp_invariance_relation Λ M e1 σ1 t2 σ2 φ) → *) -(* (∀ `{Hinv : !invGS_gen HasNoLc Σ}, *) -(* ⊢ |={⊤}=> ∃ *) -(* (stateI : execution_trace Λ → auxiliary_trace M → iProp Σ) *) -(* (fork_post : locale Λ -> val Λ → iProp Σ), *) -(* let _ : irisG Λ M Σ := IrisG _ _ _ Hinv stateI fork_post in *) -(* config_wp ∗ stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗ *) -(* WP e1 @ s; locale_of [] e1; ⊤ {{ _, True }} ∗ *) -(* (∀ ex atr, *) -(* ⌜valid_system_trace ex atr⌝ → *) -(* ⌜trace_starts_in ex ([e1], σ1)⌝ → *) -(* ⌜trace_starts_in atr δ1⌝ → *) -(* ⌜trace_ends_in ex (t2, σ2)⌝ → *) -(* stateI ex atr -∗ ∃ E, |={⊤,E}=> ⌜φ⌝)) → *) -(* ∀ ex, *) -(* valid_exec ex → *) -(* trace_starts_in ex ([e1], σ1) → *) -(* trace_ends_in ex (t2, σ2) → *) -(* φ. *) -(* Proof. *) -(* intros ? Hwp. *) -(* apply (wp_invariance_relation_invariance _ _ δ1). *) -(* apply (wp_strong_adequacy Λ M Σ s); first done. *) -(* iIntros (?) "". *) -(* iMod Hwp as (stateI fork_post) "(config_wp & HSI & Hwp & Hφ)". *) -(* iModIntro; iExists _, _, _; iFrame. *) -(* iIntros (ex atr c Hvlt Hexs Hatrs Hexe Hψ Hnst) "HSI Hposts". *) -(* rewrite /wp_invariance_relation. *) -(* iAssert ((∀ _ : trace_starts_in ex ([e1], σ1) ∧ trace_ends_in ex (t2, σ2), *) -(* |={⊤}=> ⌜φ⌝)%I) with "[HSI Hφ]" as "H". *) -(* { iIntros ([? ?]). *) -(* assert (c = (t2, σ2)) as -> by by eapply trace_ends_in_inj. *) -(* iDestruct ("Hφ" with "[] [] [] [] HSI") as (E) "Hφ"; [done|done|done|done|]. *) -(* iDestruct (fupd_plain_mask with "Hφ") as ">Hφ"; done. } *) -(* rewrite -fupd_plain_forall'. *) -(* iMod "H". *) -(* iApply fupd_mask_intro_discard; first done. *) -(* iIntros (Hexs' Hexe'); iApply "H"; done. *) -(* Qed. *) diff --git a/trillium/program_logic/atomic.v b/trillium/program_logic/atomic.v deleted file mode 100644 index 82aed1a9..00000000 --- a/trillium/program_logic/atomic.v +++ /dev/null @@ -1,183 +0,0 @@ -From stdpp Require Import namespaces. -From iris.bi Require Import telescopes. -From iris.bi.lib Require Export atomic laterable. -From iris.proofmode Require Import tactics classes. -From trillium.program_logic Require Export weakestpre. -From iris.base_logic Require Import invariants. -From iris.prelude Require Import options. - -(* This hard-codes the inner mask to be empty, because we have yet to find an -example where we want it to be anything else. *) -Definition atomic_wp `{!irisG Λ AS Σ} {TA TB : tele} - (e: expr Λ) (* expression *) - (Eo : coPset) (* (outer) mask *) - (ζ : locale Λ) (* locale *) - (α: TA → iProp Σ) (* atomic pre-condition *) - (β: TA → TB → iProp Σ) (* atomic post-condition *) - (f: TA → TB → val Λ) (* Turn the return data into the return value *) - : iProp Σ := - (∀ (Φ : val Λ → iProp Σ), - atomic_update Eo ∅ α β (λ.. x y, Φ (f x y)) -∗ - WP e @ ζ {{ Φ }})%I. -(* Note: To add a private postcondition, use - atomic_update α β Eo Ei (λ x y, POST x y -∗ Φ (f x y)) *) - -Notation "'<<<' ∀ x1 .. xn , α '>>>' e @ Eo ; ζ '<<<' ∃ y1 .. yn , β , 'RET' v '>>>'" := - (atomic_wp (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) - (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. )) - e%E - Eo - ζ - (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $ - λ x1, .. (λ xn, α%I) ..) - (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $ - λ x1, .. (λ xn, - tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. )) - (λ y1, .. (λ yn, β%I) .. ) - ) .. ) - (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $ - λ x1, .. (λ xn, - tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. )) - (λ y1, .. (λ yn, v%V) .. ) - ) .. ) - ) - (at level 20, Eo, α, β, v at level 200, x1 binder, xn binder, y1 binder, yn binder, - format "'[hv' '<<<' ∀ x1 .. xn , α '>>>' '/ ' e @ Eo ; ζ '/' '[ ' '<<<' ∃ y1 .. yn , β , '/' 'RET' v '>>>' ']' ']'") - : bi_scope. - -Notation "'<<<' ∀ x1 .. xn , α '>>>' e @ Eo ; ζ '<<<' β , 'RET' v '>>>'" := - (atomic_wp (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) - (TB:=TeleO) - e%E - Eo - ζ - (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $ - λ x1, .. (λ xn, α%I) ..) - (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $ - λ x1, .. (λ xn, - tele_app (TT:=TeleO) β%I - ) .. ) - (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $ - λ x1, .. (λ xn, - tele_app (TT:=TeleO) v%V - ) .. ) - ) - (at level 20, Eo, α, β, v at level 200, x1 binder, xn binder, - format "'[hv' '<<<' ∀ x1 .. xn , α '>>>' '/ ' e @ Eo ; ζ '/' '[ ' '<<<' β , '/' 'RET' v '>>>' ']' ']'") - : bi_scope. - -Notation "'<<<' α '>>>' e @ Eo ; ζ '<<<' ∃ y1 .. yn , β , 'RET' v '>>>'" := - (atomic_wp (TA:=TeleO) - (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. )) - e%E - Eo - ζ - (tele_app (TT:=TeleO) α%I) - (tele_app (TT:=TeleO) $ - tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. )) - (λ y1, .. (λ yn, β%I) .. )) - (tele_app (TT:=TeleO) $ - tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. )) - (λ y1, .. (λ yn, v%V) .. )) - ) - (at level 20, Eo, α, β, v at level 200, y1 binder, yn binder, - format "'[hv' '<<<' α '>>>' '/ ' e @ Eo ; ζ '/' '[ ' '<<<' ∃ y1 .. yn , β , '/' 'RET' v '>>>' ']' ']'") - : bi_scope. - -Notation "'<<<' α '>>>' e @ Eo ; ζ '<<<' β , 'RET' v '>>>'" := - (atomic_wp (TA:=TeleO) - (TB:=TeleO) - e%E - Eo - ζ - (tele_app (TT:=TeleO) α%I) - (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) β%I) - (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) v%V) - ) - (at level 20, Eo, α, β, v at level 200, - format "'[hv' '<<<' α '>>>' '/ ' e @ Eo ; ζ '/' '[ ' '<<<' β , '/' 'RET' v '>>>' ']' ']'") - : bi_scope. - -(** Theory *) -Section lemmas. - Context `{!irisG Λ AS Σ} {TA TB : tele}. - Notation iProp := (iProp Σ). - Implicit Types (α : TA → iProp) (β : TA → TB → iProp) (f : TA → TB → val Λ). - - Lemma atomic_wp_mask_weaken e Eo1 Eo2 α β f ζ : - Eo2 ⊆ Eo1 → atomic_wp e Eo1 ζ α β f -∗ atomic_wp e Eo2 ζ α β f. - Proof. - iIntros (HEo) "Hwp". iIntros (Φ) "AU". iApply "Hwp". - iApply atomic_update_mask_weaken; last done. done. - Qed. - - (* Atomic triples imply sequential triples if the precondition is laterable. *) - Lemma atomic_wp_seq e Eo ζ α β f {HL : ∀.. x, Laterable (α x)} : - atomic_wp e Eo ζ α β f -∗ - ∀ Φ, ∀.. x, α x -∗ (∀.. y, β x y -∗ Φ (f x y)) -∗ WP e @ ζ {{ Φ }}. - Proof. - rewrite ->tforall_forall in HL. iIntros "Hwp" (Φ x) "Hα HΦ". - iApply wp_frame_wand_l. iSplitL "HΦ"; first iAccu. iApply "Hwp". - iAuIntro. iAaccIntro with "Hα"; first by eauto. iIntros (y) "Hβ !>". - (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *) - rewrite ->!tele_app_bind. iIntros "HΦ". iApply "HΦ". done. - Qed. - - (** This version matches the Texan triple, i.e., with a later in front of the - [(∀.. y, β x y -∗ Φ (f x y))]. *) - Lemma atomic_wp_seq_step e Eo ζ α β f {HL : ∀.. x, Laterable (α x)} : - TCEq (to_val e) None → - atomic_wp e Eo ζ α β f -∗ - ∀ Φ, ∀.. x, α x -∗ ▷ (∀.. y, β x y -∗ Φ (f x y)) -∗ WP e @ ζ {{ Φ }}. - Proof. - iIntros (?) "H"; iIntros (Φ x) "Hα HΦ". - iApply (wp_step_fupd _ _ ⊤ _ _ (∀.. y : TB, β x y -∗ Φ (f x y)) - with "[$HΦ //]"); first done. - iApply (atomic_wp_seq with "H Hα"); first done. - iIntros (y) "Hβ HΦ". by iApply "HΦ". - Qed. - - (* Sequential triples with the empty mask for a physically atomic [e] are atomic. *) - Lemma atomic_seq_wp_atomic e Eo ζ α β f `{!Atomic WeaklyAtomic e} : - (∀ Φ, ∀.. x, α x -∗ (∀.. y, β x y -∗ Φ (f x y)) -∗ WP e @ ζ ; ∅ {{ Φ }}) -∗ - atomic_wp e Eo ζ α β f. - Proof. - iIntros "Hwp" (Φ) "AU". iMod "AU" as (x) "[Hα [_ Hclose]]". - iApply ("Hwp" with "Hα"). iIntros (y) "Hβ". - iMod ("Hclose" with "Hβ") as "HΦ". - rewrite ->!tele_app_bind. iApply "HΦ". - Qed. - - (* Sequential triples with a persistent precondition and no initial quantifier - are atomic. *) - Lemma persistent_seq_wp_atomic e Eo ζ (α : [tele] → iProp) (β : [tele] → TB → iProp) - (f : [tele] → TB → val Λ) {HP : Persistent (α [tele_arg])} : - (∀ Φ, α [tele_arg] -∗ (∀.. y, β [tele_arg] y -∗ Φ (f [tele_arg] y)) -∗ WP e @ ζ {{ Φ }}) -∗ - atomic_wp e Eo ζ α β f. - Proof. - simpl in HP. iIntros "Hwp" (Φ) "HΦ". iApply fupd_wp. - iMod ("HΦ") as "[#Hα [Hclose _]]". iMod ("Hclose" with "Hα") as "HΦ". - iApply wp_fupd. iApply ("Hwp" with "Hα"). iIntros "!>" (y) "Hβ". - iMod ("HΦ") as "[_ [_ Hclose]]". iMod ("Hclose" with "Hβ") as "HΦ". - (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *) - rewrite ->!tele_app_bind. done. - Qed. - - (* We can open invariants around atomic triples. - (Just for demonstration purposes; we always use [iInv] in proofs.) *) - Lemma wp_atomic_inv e Eo ζ α β f N I : - ↑N ⊆ Eo → - atomic_wp e Eo ζ (λ.. x, ▷ I ∗ α x) (λ.. x y, ▷ I ∗ β x y) f -∗ - inv N I -∗ atomic_wp e (Eo ∖ ↑N) ζ α β f. - Proof. - intros ?. iIntros "Hwp #Hinv" (Φ) "AU". iApply "Hwp". iAuIntro. - iInv N as "HI". iApply (aacc_aupd with "AU"); first done. - iIntros (x) "Hα". iAaccIntro with "[HI Hα]"; rewrite ->!tele_app_bind; first by iFrame. - - (* abort *) - iIntros "[HI $]". by eauto with iFrame. - - (* commit *) - iIntros (y). rewrite ->!tele_app_bind. iIntros "[HI Hβ]". iRight. - iExists y. rewrite ->!tele_app_bind. by eauto with iFrame. - Qed. - -End lemmas. diff --git a/trillium/program_logic/ectx_language.v b/trillium/program_logic/ectx_language.v deleted file mode 100644 index 1b77a871..00000000 --- a/trillium/program_logic/ectx_language.v +++ /dev/null @@ -1,374 +0,0 @@ -(** An axiomatization of evaluation-context based languages, including a proof - that this gives rise to a "language" in the Iris sense. *) -From iris.prelude Require Export prelude. -From trillium.program_logic Require Import language. - -(** TAKE CARE: When you define an [ectxLanguage] canonical structure for your -language, you need to also define a corresponding [language] canonical -structure. Use the coercion [LanguageOfEctx] as defined in the bottom of this -file for doing that. *) - -Section ectx_language_mixin. - Context {expr val ectx state : Type}. - Context {locale : Type}. - Context (of_val : val → expr). - Context (to_val : expr → option val). - Context (empty_ectx : ectx). - Context (comp_ectx : ectx → ectx → ectx). - Context (fill : ectx → expr → expr). - Context (head_step : expr → state → expr → state → list expr → Prop). - Context (locale_of : list expr -> expr -> locale). - - Notation locales_equiv t0 t0' := - (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). - - Record EctxLanguageMixin := { - mixin_to_of_val v : to_val (of_val v) = Some v; - mixin_of_to_val e v : to_val e = Some v → of_val v = e; - mixin_val_head_stuck e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 efs → to_val e1 = None; - - mixin_fill_empty e : fill empty_ectx e = e; - mixin_fill_comp K1 K2 e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e; - mixin_fill_inj K : Inj (=) (=) (fill K); - mixin_fill_val K e : is_Some (to_val (fill K e)) → is_Some (to_val e); - mixin_fill_positive K K' e e' : - to_val e = None → to_val e' = None → - fill K e = fill K' e' → - (∃ K'', K' = comp_ectx K K'') ∨ (∃ K'', K = comp_ectx K' K''); - - (** Given a head redex [e1_redex] somewhere in a term, and another - decomposition of the same term into [fill K' e1'] such that [e1'] is not - a value, then the head redex context is [e1']'s context [K'] filled with - another context [K'']. In particular, this implies [e1 = fill K'' - e1_redex] by [fill_inj], i.e., [e1]' contains the head redex.) - - This implies there can be only one head redex, see - [head_redex_unique]. *) - mixin_step_by_val K' K_redex e1' e1_redex σ1 e2 σ2 efs : - fill K' e1' = fill K_redex e1_redex → - to_val e1' = None → - head_step e1_redex σ1 e2 σ2 efs → - ∃ K'', K_redex = comp_ectx K' K''; - - (** If [fill K e] takes a head step, then either [e] is a value or [K] is - the empty evaluation context. In other words, if [e] is not a value - wrapping it in a context does not add new head redex positions. *) - mixin_head_ctx_step_val K e σ1 e2 σ2 efs : - head_step (fill K e) σ1 e2 σ2 efs → is_Some (to_val e) ∨ K = empty_ectx; - mixin_locale_step e1 e2 t1 σ1 σ2 efs: head_step e1 σ1 e2 σ2 efs -> - locale_of t1 e1 = locale_of t1 e2; - mixin_locale_fill e K t1: locale_of t1 (fill K e) = locale_of t1 e; - mixin_locale_equiv t t' e: locales_equiv t t' -> locale_of t e = locale_of t' e; - mixin_locale_injective tp0 e0 tp1 tp e: - (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 -> locale_of tp0 e0 ≠ locale_of tp e; - }. -End ectx_language_mixin. - -Structure ectxLanguage := EctxLanguage { - expr : Type; - val : Type; - ectx : Type; - state : Type; - locale : Type; - - of_val : val → expr; - to_val : expr → option val; - empty_ectx : ectx; - comp_ectx : ectx → ectx → ectx; - fill : ectx → expr → expr; - head_step : expr → state → expr → state → list expr → Prop; - config_step : state → state → Prop; - locale_of : list expr -> expr -> locale; - - ectx_language_mixin : - EctxLanguageMixin of_val to_val empty_ectx comp_ectx fill head_step locale_of -}. - -Bind Scope expr_scope with expr. -Bind Scope val_scope with val. - -Arguments EctxLanguage {_ _ _ _ _ _ _ _ _ _} _ _. -Arguments of_val {_} _. -Arguments to_val {_} _. -Arguments empty_ectx {_}. -Arguments comp_ectx {_} _ _. -Arguments fill {_} _ _. -Arguments head_step {_} _ _ _ _ _. -Arguments config_step {_} _ _. -Arguments locale_of {_} _ _. - -Notation locales_equiv t0 t0' := - (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). - -(* From an ectx_language, we can construct a language. *) -Section ectx_language. - Context {Λ : ectxLanguage}. - Implicit Types v : val Λ. - Implicit Types e : expr Λ. - Implicit Types K : ectx Λ. - - (* Only project stuff out of the mixin that is not also in language *) - Lemma val_head_stuck e1 σ1 e2 σ2 efs : head_step e1 σ1 e2 σ2 efs → to_val e1 = None. - Proof. apply ectx_language_mixin. Qed. - Lemma fill_empty e : fill empty_ectx e = e. - Proof. apply ectx_language_mixin. Qed. - Lemma fill_comp K1 K2 e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e. - Proof. apply ectx_language_mixin. Qed. - Global Instance fill_inj K : Inj (=) (=) (fill K). - Proof. apply ectx_language_mixin. Qed. - Lemma fill_val K e : is_Some (to_val (fill K e)) → is_Some (to_val e). - Proof. apply ectx_language_mixin. Qed. - Lemma fill_positive K K' e e' : - to_val e = None → to_val e' = None → - fill K e = fill K' e' → - (∃ K'', K' = comp_ectx K K'') ∨ (∃ K'', K = comp_ectx K' K''). - Proof. apply ectx_language_mixin. Qed. - Lemma step_by_val K' K_redex e1' e1_redex σ1 e2 σ2 efs : - fill K' e1' = fill K_redex e1_redex → - to_val e1' = None → - head_step e1_redex σ1 e2 σ2 efs → - ∃ K'', K_redex = comp_ectx K' K''. - Proof. apply ectx_language_mixin. Qed. - Lemma head_ctx_step_val K e σ1 e2 σ2 efs : - head_step (fill K e) σ1 e2 σ2 efs → is_Some (to_val e) ∨ K = empty_ectx. - Proof. apply ectx_language_mixin. Qed. - - Definition head_reducible (e : expr Λ) (σ : state Λ) := - ∃ e' σ' efs, head_step e σ e' σ' efs. - Definition head_irreducible (e : expr Λ) (σ : state Λ) := - ∀ e' σ' efs, ¬head_step e σ e' σ' efs. - Definition head_stuck (e : expr Λ) (σ : state Λ) := - to_val e = None ∧ head_irreducible e σ. - - Lemma locale_fill e K t1: locale_of t1 (fill K e) = locale_of t1 e. - Proof. apply ectx_language_mixin. Qed. - - (* All non-value redexes are at the root. In other words, all sub-redexes are - values. *) - Definition sub_redexes_are_values (e : expr Λ) := - ∀ K e', e = fill K e' → to_val e' = None → K = empty_ectx. - - Inductive prim_step (e1 : expr Λ) (σ1 : state Λ) - (e2 : expr Λ) (σ2 : state Λ) (efs : list (expr Λ)) : Prop := - Ectx_step K e1' e2' : - e1 = fill K e1' → e2 = fill K e2' → - head_step e1' σ1 e2' σ2 efs → prim_step e1 σ1 e2 σ2 efs. - - Lemma Ectx_step' K e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. - Proof. econstructor; eauto. Qed. - - Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None. - Proof. rewrite !eq_None_not_Some. eauto using fill_val. Qed. - - Definition ectx_lang_mixin : - LanguageMixin of_val to_val prim_step locale_of comp_ectx empty_ectx fill. - Proof. - split. - - apply ectx_language_mixin. - - apply ectx_language_mixin. - - intros ????? [??? -> -> ?%val_head_stuck]. - apply eq_None_not_Some. by intros ?%fill_val%eq_None_not_Some. - - intros K; split_and!. - + eauto using fill_not_val. - + intros ????? [K' e1' e2' Heq1 Heq2 Hstep]. - exists (comp_ectx K K') e1' e2'; rewrite ?Heq1 ?Heq2 ?fill_comp; done. - + intros e1 σ1 e2 σ2 efs Hnval [K'' e1'' e2'' Heq1 -> Hstep]. - destruct (step_by_val K K'' e1 e1'' σ1 e2'' σ2 efs) as [K' ->]; eauto. - rewrite -fill_comp in Heq1; apply (inj (fill _)) in Heq1. - exists (fill K' e2''); rewrite -fill_comp; split; auto. - econstructor; eauto. - - apply fill_empty. - - intros ? ? ?; rewrite fill_comp; done. - - apply fill_inj. - - apply fill_positive. - - intros e1 e2 t1 σ1 σ2 efs Hpstep. inversion Hpstep; simplify_eq. - do 2 (erewrite mixin_locale_fill; last apply ectx_language_mixin). - eapply mixin_locale_step; first apply ectx_language_mixin. done. - - apply ectx_language_mixin. - - apply ectx_language_mixin. - - apply ectx_language_mixin. - Qed. - - Canonical Structure ectx_lang : language := - Language (config_step := config_step) prim_step empty_ectx fill ectx_lang_mixin. - - Definition head_atomic (a : atomicity) (e : expr Λ) : Prop := - ∀ σ e' σ' efs, - head_step e σ e' σ' efs → - if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e'). - - Definition head_stutteringatomic (a : atomicity) (e : expr Λ) : Prop := - ∀ σ e' σ' efs, - head_step e σ e' σ' efs → - (e' = e ∧ σ' = σ ∧ efs = []) - ∨ - if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e'). - - Lemma not_head_reducible e σ : ¬head_reducible e σ ↔ head_irreducible e σ. - Proof. unfold head_reducible, head_irreducible. naive_solver. Qed. - - (** The decomposition into head redex and context is unique. - - In all sensible instances, [comp_ectx K' empty_ectx] will be the same as - [K'], so the conclusion is [K = K' ∧ e = e'], but we do not require a law - to actually prove that so we cannot use that fact here. *) - Lemma head_redex_unique K K' e e' σ : - fill K e = fill K' e' → - head_reducible e σ → - head_reducible e' σ → - K = comp_ectx K' empty_ectx ∧ e = e'. - Proof. - intros Heq (e2 & σ2 & efs & Hred) (e2' & σ2' & efs' & Hred'). - edestruct (step_by_val K' K e' e) as [K'' HK]; - [by eauto using val_head_stuck..|]. - subst K. move: Heq. rewrite -fill_comp. intros <-%(inj (fill _)). - destruct (head_ctx_step_val _ _ _ _ _ _ Hred') as [[]%not_eq_None_Some|HK'']. - { by eapply val_head_stuck. } - subst K''. rewrite fill_empty. done. - Qed. - - Lemma head_prim_step e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 efs → prim_step e1 σ1 e2 σ2 efs. - Proof. apply Ectx_step with empty_ectx; by rewrite ?fill_empty. Qed. - - Lemma head_step_not_stuck e σ e' σ' efs : head_step e σ e' σ' efs → not_stuck e σ. - Proof. rewrite /not_stuck /reducible /=. eauto 10 using head_prim_step. Qed. - - Lemma fill_prim_step K e1 σ1 e2 σ2 efs : - prim_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. - Proof. - destruct 1 as [K' e1' e2' -> ->]. - rewrite !fill_comp. by econstructor. - Qed. - Lemma fill_reducible K e σ : reducible e σ → reducible (fill K e) σ. - Proof. - intros (e'&σ'&efs&?). exists (fill K e'), σ', efs. - by apply fill_prim_step. - Qed. - Lemma head_prim_reducible e σ : head_reducible e σ → reducible e σ. - Proof. intros (e'&σ'&efs&?). eexists e', σ', efs. by apply head_prim_step. Qed. - Lemma head_prim_fill_reducible e K σ : - head_reducible e σ → reducible (fill K e) σ. - Proof. intro. by apply fill_reducible, head_prim_reducible. Qed. - Lemma head_prim_irreducible e σ : irreducible e σ → head_irreducible e σ. - Proof. - rewrite -not_reducible -not_head_reducible. eauto using head_prim_reducible. - Qed. - - Lemma prim_head_reducible e σ : - reducible e σ → sub_redexes_are_values e → head_reducible e σ. - Proof. - intros (e'&σ'&efs&[K e1' e2' -> -> Hstep]) ?. - assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck. - rewrite fill_empty /head_reducible; eauto. - Qed. - Lemma prim_head_irreducible e σ : - head_irreducible e σ → sub_redexes_are_values e → irreducible e σ. - Proof. - rewrite -not_reducible -not_head_reducible. eauto using prim_head_reducible. - Qed. - - Lemma head_stuck_stuck e σ : - head_stuck e σ → sub_redexes_are_values e → stuck e σ. - Proof. - intros [] ?. split; first done. - by apply prim_head_irreducible. - Qed. - - Lemma ectx_language_atomic a e : - head_atomic a e → sub_redexes_are_values e → Atomic a e. - Proof. - intros Hatomic_step Hatomic_fill σ e' σ' efs [K e1' e2' -> -> Hstep]. - assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck. - rewrite fill_empty. eapply Hatomic_step. by rewrite fill_empty. - Qed. - - Lemma ectx_language_stutteringatomic a e : - head_stutteringatomic a e → sub_redexes_are_values e → StutteringAtomic a e. - Proof. - intros Hatomic_step Hatomic_fill σ e' σ' efs [K e1' e2' -> -> Hstep]. - assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck. - revert Hatomic_step; rewrite !fill_empty; intros Hatomic_step. - eapply Hatomic_step; done. - Qed. - - Lemma head_reducible_prim_step_ctx K e1 σ1 e2 σ2 efs : - head_reducible e1 σ1 → - prim_step (fill K e1) σ1 e2 σ2 efs → - ∃ e2', e2 = fill K e2' ∧ head_step e1 σ1 e2' σ2 efs. - Proof. - intros (e2''&σ2''&efs''&HhstepK) [K' e1' e2' HKe1 -> Hstep]. - edestruct (step_by_val K) as [K'' ?]; - eauto using val_head_stuck; simplify_eq/=. - rewrite -fill_comp in HKe1; simplify_eq. - exists (fill K'' e2'). rewrite fill_comp; split; first done. - apply head_ctx_step_val in HhstepK as [[v ?]|?]; simplify_eq. - { apply val_head_stuck in Hstep; simplify_eq. } - by rewrite !fill_empty. - Qed. - - Lemma head_reducible_prim_step e1 σ1 e2 σ2 efs : - head_reducible e1 σ1 → - prim_step e1 σ1 e2 σ2 efs → - head_step e1 σ1 e2 σ2 efs. - Proof. - intros. - edestruct (head_reducible_prim_step_ctx empty_ectx) as (?&?&?); - rewrite ?fill_empty; eauto. - by simplify_eq; rewrite fill_empty. - Qed. - - Record pure_head_step (e1 e2 : expr Λ) := { - pure_head_step_safe σ1 : head_reducible e1 σ1; - pure_head_step_det σ1 e2' σ2 efs : - head_step e1 σ1 e2' σ2 efs → σ2 = σ1 ∧ e2' = e2 ∧ efs = [] - }. - - Lemma pure_head_step_pure_step e1 e2 : pure_head_step e1 e2 → pure_step e1 e2. - Proof. - intros [Hp1 Hp2]. split. - - intros σ. destruct (Hp1 σ) as (e2' & σ2 & efs & ?). - eexists e2', σ2, efs. by apply head_prim_step. - - intros σ1 e2' σ2 efs ?%head_reducible_prim_step; eauto. - Qed. - - (** This is not an instance because HeapLang's [wp_pure] tactic already takes - care of handling the evaluation context. So the instance is redundant. - If you are defining your own language and your [wp_pure] works - differently, you might want to specialize this lemma to your language and - register that as an instance. *) - Lemma pure_exec_fill K φ n e1 e2 : - PureExec φ n e1 e2 → - PureExec φ n (fill K e1) (fill K e2). - Proof. apply: pure_exec_ctx. Qed. - - Lemma head_locale_step K e1 e2 tp1 tp2 efs σ1 σ2 : - head_step e1 σ1 e2 σ2 efs → - locale_step - (tp1 ++ fill K e1 :: tp2, σ1) - (Some (locale_of tp1 e1)) - (tp1 ++ fill K e2 :: tp2 ++ efs, σ2). - Proof. - intros Hstep. rewrite -(locale_fill _ K). econstructor =>//. - by apply fill_step, head_prim_step. - Qed. - -End ectx_language. - -Arguments ectx_lang : clear implicits. -Coercion ectx_lang : ectxLanguage >-> language. - -(* This definition makes sure that the fields of the [language] record do not -refer to the projections of the [ectxLanguage] record but to the actual fields -of the [ectxLanguage] record. This is crucial for canonical structure search to -work. - -Note that this trick no longer works when we switch to canonical projections -because then the pattern match [let '...] will be desugared into projections. *) -Definition LanguageOfEctx (Λ : ectxLanguage) : language := - let '@EctxLanguage E V C St Loc of_val to_val empty comp fill head config loc_of mix := Λ in - @Language E V C St Loc of_val to_val _ config loc_of comp empty fill - (@ectx_lang_mixin - (@EctxLanguage E V C St Loc of_val to_val empty comp fill head config loc_of mix)). diff --git a/trillium/program_logic/ectx_lifting.v b/trillium/program_logic/ectx_lifting.v deleted file mode 100644 index f0ef2d45..00000000 --- a/trillium/program_logic/ectx_lifting.v +++ /dev/null @@ -1,222 +0,0 @@ -(** Some derived lemmas for ectx-based languages *) -From iris.proofmode Require Import tactics. -From trillium.program_logic Require Export - ectx_language weakestpre lifting. -Set Default Proof Using "Type". - -Section wp. -Context {Λ : ectxLanguage} `{!irisG Λ M Σ} {Hinh : Inhabited (state Λ)}. -Implicit Types s : stuckness. -Implicit Types P : iProp Σ. -Implicit Types Φ : val Λ → iProp Σ. -Implicit Types v : val Λ. -Implicit Types e : expr Λ. -Hint Resolve head_prim_reducible head_reducible_prim_step : core. -Local Definition reducible_not_val_inhabitant e := - reducible_not_val e inhabitant. -Hint Resolve reducible_not_val_inhabitant : core. -Hint Resolve head_stuck_stuck : core. - -Lemma wp_lift_head_step_fupd {s E Φ} e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ - state_interp extr atr ={E,∅}=∗ - ⌜head_reducible e1 σ1⌝ ∗ - ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅,E}=> - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - WP e2 @ s; ζ; E {{ Φ }} ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (?) "H". iApply wp_lift_step_fupd=>//. - iIntros (ex atr K tp1 tp2 σ1 Hexvalid hex Hloc) "Hsi". - iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". - iModIntro. - iSplit; first by destruct s; eauto. - iIntros (e2 σ2 efs ?). - iApply "H"; eauto. -Qed. - -Lemma wp_lift_head_step {s E Φ} e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ fill K e1 :: tp2, σ1)⌝ → - state_interp extr atr ={E,∅}=∗ - ⌜head_reducible e1 σ1⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗ - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - WP e2 @ s; ζ; E {{ Φ }} ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (?) "H". iApply wp_lift_head_step_fupd; [done|]. iIntros (?????????) "?". - iMod ("H" with "[//] [//] [$]") as "[$ H]". - iIntros "!>" (e2 σ2 efs ?) "!> !>". - iApply "H"; done. -Qed. - -Lemma wp_lift_head_stuck E Φ e ζ: - to_val e = None → - sub_redexes_are_values e → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ fill K e :: tp2, σ)⌝ → - state_interp extr atr ={E,∅}=∗ ⌜head_stuck e σ⌝) - ⊢ WP e @ ζ; E ?{{ Φ }}. -Proof. - iIntros (??) "H". iApply wp_lift_stuck; first done. - iIntros (????????) "Hsi". iMod ("H" with "[] [] Hsi") as "%"; by auto. -Qed. - -Lemma wp_lift_pure_head_stuck E Φ e : - to_val e = None → - sub_redexes_are_values e → - (∀ σ, head_stuck e σ) → - ⊢ WP e @ E ?{{ Φ }}. -Proof using Hinh. - iIntros (?? Hstuck). iApply wp_lift_head_stuck; [done|done|]. - iIntros (???????) "_". iMod (fupd_mask_subseteq ∅) as "_"; first set_solver. - auto; done. -Qed. - -Lemma wp_lift_atomic_head_step_fupd {s E1 E2 Φ} e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 e1 = ζ⌝ → - state_interp extr atr ={E1}=∗ - ⌜head_reducible e1 σ1⌝ ∗ - ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E1}[E2]▷=∗ - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - from_option Φ False (to_val e2) ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|]. - iIntros (?????????) "Hsi". iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". - iModIntro. - iSplit; first by destruct s; auto. - iIntros (e2 σ2 efs Hstep). - iApply "H"; eauto. -Qed. - -Lemma wp_lift_atomic_head_step {s E Φ} e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 e1 = ζ⌝ → - state_interp extr atr ={E}=∗ - ⌜head_reducible e1 σ1⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E}=∗ - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - from_option Φ False (to_val e2) ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (?) "H". iApply wp_lift_atomic_step; eauto. - iIntros (?????????) "Hsi". iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". - iModIntro. - iSplit; first by destruct s; auto. iNext. iIntros (e2 σ2 efs Hstep). - iApply "H"; eauto. -Qed. - -Lemma wp_lift_atomic_head_step_no_fork_fupd {s E1 E2 Φ} e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 e1 = ζ⌝ → - state_interp extr atr ={E1}=∗ - ⌜head_reducible e1 σ1⌝ ∗ - ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E1}[E2]▷=∗ - ∃ δ2 ℓ, - ⌜efs = [] ⌝∗ - state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - from_option Φ False (to_val e2)) - ⊢ WP e1 @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros (?) "H". iApply wp_lift_atomic_head_step_fupd; [done|]. - iIntros (?????????) "Hsi". - iMod ("H" with "[//] [//] [//] Hsi") as "[$ H]". - iModIntro. - iIntros (v2 σ2 efs Hstep). - iMod ("H" $! v2 σ2 efs with "[# //]") as "H". - iIntros "!> !>". iMod "H" as (st' ℓ) "(-> & ? & ?) /=". - iModIntro; iExists _, _. - iFrame. -Qed. - -Lemma wp_lift_atomic_head_step_no_fork {s E Φ} e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 e1 = ζ⌝ → - state_interp extr atr ={E}=∗ - ⌜head_reducible e1 σ1⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E}=∗ - ∃ δ2 ℓ, - ⌜efs = []⌝ ∗ state_interp - (trace_extend extr (Some ζ) (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - from_option Φ False (to_val e2)) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (?) "H". iApply wp_lift_atomic_head_step; eauto. - iIntros (?????????) "Hsi". - iMod ("H" with "[//] [//] [//] Hsi") as "[$ H]". - iModIntro. - iNext; iIntros (v2 σ2 efs Hstep). - iMod ("H" $! v2 σ2 efs with "[//]") as (st' ℓ) "(-> & ? & ?) /=". - iModIntro; iExists _, _. - iFrame. -Qed. - -Lemma wp_lift_pure_det_head_step_no_fork - `{!AllowsPureStep M Σ} {s E E' Φ} e1 e2 ζ: - to_val e1 = None → - (∀ σ1, head_reducible e1 σ1) → - (∀ σ1 e2' σ2 efs', - head_step e1 σ1 e2' σ2 efs' → σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → - (|={E}[E']▷=> WP e2 @ s; ζ; E {{ Φ }}) ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof using Hinh. - intros. rewrite -(wp_lift_pure_det_step_no_fork e1 e2); eauto. - destruct s; by auto. -Qed. - -Lemma wp_lift_pure_det_head_step_no_fork' - `{!AllowsPureStep M Σ} {s E Φ} e1 e2 ζ: - to_val e1 = None → - (∀ σ1, head_reducible e1 σ1) → - (∀ σ1 e2' σ2 efs', - head_step e1 σ1 e2' σ2 efs' → σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → - ▷ WP e2 @ s; ζ; E {{ Φ }} ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof using Hinh. - intros. rewrite -[(WP e1 @ s; _; _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //. - rewrite -step_fupd_intro //. -Qed. -End wp. diff --git a/trillium/program_logic/ectxi_language.v b/trillium/program_logic/ectxi_language.v deleted file mode 100644 index 247ffe23..00000000 --- a/trillium/program_logic/ectxi_language.v +++ /dev/null @@ -1,198 +0,0 @@ -(** An axiomatization of languages based on evaluation context items, including - a proof that these are instances of general ectx-based languages. *) -From iris.prelude Require Export prelude. -From trillium.program_logic Require Import language ectx_language. - -(** TAKE CARE: When you define an [ectxiLanguage] canonical structure for your -language, you need to also define a corresponding [language] and [ectxLanguage] -canonical structure for canonical structure inference to work properly. You -should use the coercion [EctxLanguageOfEctxi] and [LanguageOfEctx] for that, and -not [ectxi_lang] and [ectxi_lang_ectx], otherwise the canonical projections will -not point to the right terms. - -A full concrete example of setting up your language can be found in [heap_lang]. -Below you can find the relevant parts: - - Module heap_lang. - (* Your language definition *) - - Lemma heap_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step. - Proof. (* ... *) Qed. - End heap_lang. - - Canonical Structure heap_ectxi_lang := EctxiLanguage heap_lang.heap_lang_mixin. - Canonical Structure heap_ectx_lang := EctxLanguageOfEctxi heap_ectxi_lang. - Canonical Structure heap_lang := LanguageOfEctx heap_ectx_lang. -*) - -Section ectxi_language_mixin. - Context {expr val ectx_item state locale : Type}. - Context (of_val : val → expr). - Context (to_val : expr → option val). - Context (fill_item : ectx_item → expr → expr). - Context (head_step : expr → state → expr → state → list expr → Prop). - Context (config_step : state → state → Prop). - Context (locale_of : list expr -> expr -> locale). - - Notation locales_equiv t0 t0' := - (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). - - Record EctxiLanguageMixin := { - mixin_to_of_val v : to_val (of_val v) = Some v; - mixin_of_to_val e v : to_val e = Some v → of_val v = e; - mixin_val_stuck e1 σ1 e2 σ2 efs : head_step e1 σ1 e2 σ2 efs → to_val e1 = None; - - mixin_fill_item_val Ki e : is_Some (to_val (fill_item Ki e)) → is_Some (to_val e); - (** [fill_item] is always injective on the expression for a fixed - context. *) - mixin_fill_item_inj Ki : Inj (=) (=) (fill_item Ki); - (** [fill_item] with (potentially different) non-value expressions is - injective on the context. *) - mixin_fill_item_no_val_inj Ki1 Ki2 e1 e2 : - to_val e1 = None → to_val e2 = None → - fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2; - - (** If [fill_item Ki e] takes a head step, then [e] is a value (unlike for - [ectx_language], an empty context is impossible here). In other words, - if [e] is not a value then wrapping it in a context does not add new - head redex positions. *) - mixin_head_ctx_step_val Ki e σ1 e2 σ2 efs : - head_step (fill_item Ki e) σ1 e2 σ2 efs → is_Some (to_val e); - - mixin_locale_step e1 e2 t1 σ1 σ2 efs: head_step e1 σ1 e2 σ2 efs -> - locale_of t1 e1 = locale_of t1 e2; - mixin_locale_fill e K t1: locale_of t1 (fill_item K e) = locale_of t1 e; - mixin_locale_equiv t t' e: locales_equiv t t' -> locale_of t e = locale_of t' e; - mixin_locale_injective tp0 e0 tp1 tp e: - (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 -> locale_of tp0 e0 ≠ locale_of tp e; - }. -End ectxi_language_mixin. - -Structure ectxiLanguage := EctxiLanguage { - expr : Type; - val : Type; - ectx_item : Type; - state : Type; - locale : Type; - - of_val : val → expr; - to_val : expr → option val; - fill_item : ectx_item → expr → expr; - head_step : expr → state → expr → state → list expr → Prop; - config_step : state → state → Prop; - locale_of : list expr -> expr -> locale; - - ectxi_language_mixin : - EctxiLanguageMixin of_val to_val fill_item head_step locale_of -}. - -Bind Scope expr_scope with expr. -Bind Scope val_scope with val. - -Arguments EctxiLanguage {_ _ _ _ _ _ _ _} _ _. -Arguments of_val {_} _. -Arguments to_val {_} _. -Arguments fill_item {_} _ _. -Arguments head_step {_} _ _ _ _ _. -Arguments config_step {_} _ _. -Arguments locale_of {_} _ _. - -Section ectxi_language. - Context {Λ : ectxiLanguage}. - Implicit Types (e : expr Λ) (Ki : ectx_item Λ). - Notation ectx := (list (ectx_item Λ)). - - (* Only project stuff out of the mixin that is not also in ectxLanguage *) - Global Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki). - Proof. apply ectxi_language_mixin. Qed. - Lemma fill_item_val Ki e : is_Some (to_val (fill_item Ki e)) → is_Some (to_val e). - Proof. apply ectxi_language_mixin. Qed. - Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 : - to_val e1 = None → to_val e2 = None → - fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2. - Proof. apply ectxi_language_mixin. Qed. - Lemma head_ctx_step_val Ki e σ1 e2 σ2 efs : - head_step (fill_item Ki e) σ1 e2 σ2 efs → is_Some (to_val e). - Proof. apply ectxi_language_mixin. Qed. - - Definition fill (K : ectx) (e : expr Λ) : expr Λ := foldl (flip fill_item) e K. - - Lemma fill_app (K1 K2 : ectx) e : fill (K1 ++ K2) e = fill K2 (fill K1 e). - Proof. apply foldl_app. Qed. - - Definition ectxi_lang_ectx_mixin : - EctxLanguageMixin of_val to_val [] (flip (++)) fill head_step locale_of. - Proof. - assert (fill_val : ∀ K e, is_Some (to_val (fill K e)) → is_Some (to_val e)). - { intros K. induction K as [|Ki K IH]=> e //=. by intros ?%IH%fill_item_val. } - assert (fill_not_val : ∀ K e, to_val e = None → to_val (fill K e) = None). - { intros K e. rewrite !eq_None_not_Some. eauto. } - split. - - apply ectxi_language_mixin. - - apply ectxi_language_mixin. - - apply ectxi_language_mixin. - - done. - - intros K1 K2 e. by rewrite /fill /= foldl_app. - - intros K; induction K as [|Ki K IH]; rewrite /Inj; naive_solver. - - done. - - intros K; induction K as [|Ki K IHK] using rev_ind; simpl in *; - first by setoid_rewrite app_nil_r; eauto. - intros K'. - destruct K' as [|Ki' K' _] using rev_ind; simpl in *; - first by setoid_rewrite app_nil_r; eauto. - intros e e' He He' Hes. - rewrite !fill_app /= in Hes. - pose proof Hes as Hes'. - apply fill_item_no_val_inj in Hes'; [|naive_solver|naive_solver]; - simplify_eq. - apply IHK in Hes as [[Kx ->]|[Kx ->]]; [| |done|done]. - + left; eexists; rewrite -assoc; done. - + right; eexists; rewrite -assoc; done. - - intros K K' e1 e1' σ1 e2 σ2 efs Hfill Hred Hstep; revert K' Hfill. - induction K as [|Ki K IH] using rev_ind=> /= K' Hfill; eauto using app_nil_r. - destruct K' as [|Ki' K' _] using @rev_ind; simplify_eq/=. - { rewrite fill_app in Hstep. apply head_ctx_step_val in Hstep. - apply fill_val in Hstep. by apply not_eq_None_Some in Hstep. } - rewrite !fill_app /= in Hfill. - assert (Ki = Ki') as ->. - { eapply fill_item_no_val_inj, Hfill; eauto using val_head_stuck. - apply fill_not_val. revert Hstep. apply ectxi_language_mixin. } - simplify_eq. destruct (IH K') as [K'' ->]; auto. - exists K''. by rewrite assoc. - - intros K e1 σ1 e2 σ2 efs. - destruct K as [|Ki K _] using rev_ind; simpl; first by auto. - rewrite fill_app /=. - intros ?%head_ctx_step_val; eauto using fill_val. - - apply ectxi_language_mixin. - - intros e K; revert e. induction K as [|Ki K IH]; first naive_solver. - intros e t1. rewrite IH. apply ectxi_language_mixin. - - apply ectxi_language_mixin. - - apply ectxi_language_mixin. - Qed. - - Canonical Structure ectxi_lang_ectx := EctxLanguage head_step config_step locale_of ectxi_lang_ectx_mixin. - Canonical Structure ectxi_lang := LanguageOfEctx ectxi_lang_ectx. - - Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None. - Proof. rewrite !eq_None_not_Some. eauto using fill_val. Qed. - - Lemma ectxi_language_sub_redexes_are_values e : - (∀ Ki e', e = fill_item Ki e' → is_Some (to_val e')) → - sub_redexes_are_values e. - Proof. - intros Hsub K e' ->. destruct K as [|Ki K _] using @rev_ind=> //=. - intros []%eq_None_not_Some. eapply fill_val, Hsub. by rewrite /= fill_app. - Qed. - -End ectxi_language. - -Arguments ectxi_lang_ectx : clear implicits. -Arguments ectxi_lang : clear implicits. -Coercion ectxi_lang_ectx : ectxiLanguage >-> ectxLanguage. -Coercion ectxi_lang : ectxiLanguage >-> language. - -Definition EctxLanguageOfEctxi (Λ : ectxiLanguage) : ectxLanguage := - let '@EctxiLanguage E V C St L of_val to_val fill head config locale_of mix := Λ in - @EctxLanguage E V (list C) St L of_val to_val _ _ _ _ config locale_of - (@ectxi_lang_ectx_mixin - (@EctxiLanguage E V C St L of_val to_val fill head config locale_of mix)). diff --git a/trillium/program_logic/language.v b/trillium/program_logic/language.v deleted file mode 100644 index 357715c1..00000000 --- a/trillium/program_logic/language.v +++ /dev/null @@ -1,511 +0,0 @@ -From iris.algebra Require Export ofe. - -Section prefixes. - Context {A : Type}. - - Fixpoint prefixes_from pref l : list (list A * A) := - match l with - | [] => [] - | x::xs => (pref, x) :: prefixes_from (pref ++ [x]) xs - end. - - Notation prefixes l := (prefixes_from [] l). - - Lemma prefixes_from_app l0 l1 l2: - prefixes_from l0 (l1 ++ l2) = prefixes_from l0 l1 ++ prefixes_from (l0++l1) l2. - Proof. - revert l0 l2. induction l1 ; intros l0 l2; first by list_simplifier. - list_simplifier. - replace (a :: l1 ++ l2) with (a :: (l1 ++ l2)); last by list_simplifier. - rewrite IHl1. by list_simplifier. - Qed. - - Lemma prefixes_from_spec `{EqDecision A} tp0 tp1 e tp: - (tp, e) ∈ prefixes_from tp0 tp1 <-> - (∃ t t', tp = tp0 ++ t ∧ tp1 = t ++ e :: t'). - Proof. - revert tp e tp0. induction tp1 as [|e' t' IH]; intros tp e0 tp'. - { list_simplifier. split; first set_solver. intros (?&?&?&Hf). - by apply app_cons_not_nil in Hf. } - split. - - simpl. intros [Hin|Hin]%elem_of_cons. - + simplify_eq. eexists [], t'. by list_simplifier. - + destruct (iffLR (IH _ _ _) Hin) as (?&?&?&?). list_simplifier. eauto. - - intros (t1&t2&Heq1&Heq2). simpl. apply elem_of_cons. - destruct (decide (tp = tp' ∧ e0 = e')) as [[??]|Hneq]. - + simplify_eq. left; congruence. - + right. apply IH. simplify_eq. - assert (∃ t1', t1 = e' :: t1') as [t1' ->]. - { assert ((t1 ++ e0 :: t2) !! 0 = Some e') as H; first by rewrite -Heq2; set_solver. - destruct t1 as [| e1 t1]; first by apply not_and_l in Hneq as [Hneq|Hneq]; list_simplifier. - exists t1. f_equal. simpl in H. congruence. } - list_simplifier. eexists _, _. by list_simplifier. - Qed. - - Lemma prefixes_from_lookup tp0 tp1 n e : - tp1 !! n = Some e -> - prefixes_from tp0 tp1 !! n = Some (tp0 ++ take n tp1, e). - Proof. - revert tp0 n; induction tp1 as [| e1 tp1 IH]; intros tp0 n Hlk; first done. - destruct n as [|n]; simpl in *; first by list_simplifier. - replace (tp0 ++ e1 :: take n tp1) with ((tp0 ++ [e1]) ++ take n tp1); last by list_simplifier. - by apply IH. - Qed. -End prefixes. -Notation prefixes l := (prefixes_from [] l). - -Section language_mixin. - Context {expr val ectx state : Type}. - Context {locale : Type}. - - Context (of_val : val → expr). - Context (to_val : expr → option val). - - Context (prim_step : expr → state → expr → state → list expr → Prop). - Context (config_step : state → state → Prop). - - Context (locale_of : list expr -> expr -> locale). - - (** Evaluation contexts: we need to include them in the definition of the - language because they are used in the program logic for forming - program traces. *) - Context (ectx_comp : ectx → ectx → ectx). - Context (ectx_emp : ectx). - Context (ectx_fill : ectx → expr → expr). - - Notation locales_equiv t0 t0' := - (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). - - Record LanguageMixin := { - mixin_to_of_val v : to_val (of_val v) = Some v; - mixin_of_to_val e v : to_val e = Some v → of_val v = e; - mixin_val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None; - mixin_is_eval_ctx K : - (∀ e, to_val e = None → to_val (ectx_fill K e) = None) ∧ - (∀ e1 σ1 e2 σ2 efs, - prim_step e1 σ1 e2 σ2 efs → - prim_step (ectx_fill K e1) σ1 (ectx_fill K e2) σ2 efs) ∧ - (∀ e1' σ1 e2 σ2 efs, - to_val e1' = None → prim_step (ectx_fill K e1') σ1 e2 σ2 efs → - ∃ e2', e2 = ectx_fill K e2' ∧ prim_step e1' σ1 e2' σ2 efs); - mixin_ectx_fill_emp e : ectx_fill ectx_emp e = e; - mixin_ectx_comp_comp K K' e : - ectx_fill (ectx_comp K K') e = ectx_fill K (ectx_fill K' e); - mixin_ectx_fill_inj K e e' : ectx_fill K e = ectx_fill K e' → e = e'; - mixin_ectx_fill_positive K K' e e' : - to_val e = None → to_val e' = None → - ectx_fill K e = ectx_fill K' e' → - (∃ K'', K' = ectx_comp K K'') ∨ (∃ K'', K = ectx_comp K' K''); - mixin_locale_step e1 e2 t1 σ1 σ2 efs: prim_step e1 σ1 e2 σ2 efs -> - locale_of t1 e1 = locale_of t1 e2; - mixin_locale_fill e K t1: locale_of t1 (ectx_fill K e) = locale_of t1 e; - mixin_locale_equiv t t' e: locales_equiv t t' -> locale_of t e = locale_of t' e; - mixin_locale_injective tp0 e0 tp1 tp e: - (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 -> locale_of tp0 e0 ≠ locale_of tp e; - }. -End language_mixin. - - -Structure language := Language { - expr : Type; - val : Type; - ectx : Type; - state : Type; - locale : Type; - of_val : val → expr; - to_val : expr → option val; - prim_step : expr → state → expr → state → list expr → Prop; - config_step : state → state → Prop; - locale_of : list expr -> expr -> locale; - ectx_comp : ectx → ectx → ectx; - ectx_emp : ectx; - ectx_fill : ectx → expr → expr; - language_mixin : - LanguageMixin of_val to_val prim_step locale_of ectx_comp ectx_emp ectx_fill -}. - -Declare Scope expr_scope. -Delimit Scope expr_scope with E. -Bind Scope expr_scope with expr. - -Declare Scope val_scope. -Delimit Scope val_scope with V. -Bind Scope val_scope with val. - -Arguments Language {_ _ _ _ _ _ _} _ {_ _ _} _. -Arguments of_val {_} _. -Arguments to_val {_} _. -Arguments prim_step {_} _ _ _ _ _. -Arguments config_step {_} _ _. -Arguments ectx_comp {_} _ _. -Arguments ectx_emp {_}. -Arguments ectx_fill {_} _ _. -Arguments locale_of {_} _ _. - -Notation locales_equiv t0 t0' := - (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0')). - -Canonical Structure stateO Λ := leibnizO (state Λ). -Canonical Structure valO Λ := leibnizO (val Λ). -Canonical Structure exprO Λ := leibnizO (expr Λ). - -Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type. - -Inductive atomicity := StronglyAtomic | WeaklyAtomic. - -Record is_an_eval_ctx {Λ : language} (K : expr Λ → expr Λ) := { - is_an_eval_ctx_fill_not_val e : - to_val e = None → to_val (K e) = None; - is_an_eval_ctx_fill_step e1 σ1 e2 σ2 efs : - prim_step e1 σ1 e2 σ2 efs → - prim_step (K e1) σ1 (K e2) σ2 efs; - is_an_eval_ctx_fill_step_inv e1' σ1 e2 σ2 efs : - to_val e1' = None → prim_step (K e1') σ1 e2 σ2 efs → - ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 e2' σ2 efs -}. - -Global Arguments is_an_eval_ctx_fill_not_val {_ _} _. -Global Arguments is_an_eval_ctx_fill_step {_ _} _. -Global Arguments is_an_eval_ctx_fill_step_inv {_ _} _. - -Section language. - Context {Λ : language}. - Implicit Types v : val Λ. - Implicit Types e : expr Λ. - Implicit Types K : ectx Λ. - - Lemma to_of_val v : to_val (of_val v) = Some v. - Proof. apply language_mixin. Qed. - Lemma of_to_val e v : to_val e = Some v → of_val v = e. - Proof. apply language_mixin. Qed. - Lemma val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None. - Proof. apply language_mixin. Qed. - Lemma is_eval_ctx K : is_an_eval_ctx (ectx_fill K). - Proof. split; apply language_mixin. Qed. - Lemma ectx_fill_emp e : ectx_fill ectx_emp e = e. - Proof. apply language_mixin. Qed. - Lemma ectx_comp_comp K K' e : - ectx_fill (ectx_comp K K') e = ectx_fill K (ectx_fill K' e). - Proof. apply language_mixin. Qed. - Lemma ectx_fill_inj K e e' : ectx_fill K e = ectx_fill K e' → e = e'. - Proof. apply language_mixin. Qed. - Lemma ectx_fill_positive K K' e e' : - to_val e = None → to_val e' = None → - ectx_fill K e = ectx_fill K' e' → - (∃ K'', K' = ectx_comp K K'') ∨ (∃ K'', K = ectx_comp K' K''). - Proof. apply language_mixin. Qed. - - Lemma fill_not_val K e : - to_val e = None → to_val (ectx_fill K e) = None. - Proof. apply is_an_eval_ctx_fill_not_val, is_eval_ctx. Qed. - Lemma fill_step K e1 σ1 e2 σ2 efs : - prim_step e1 σ1 e2 σ2 efs → - prim_step (ectx_fill K e1) σ1 (ectx_fill K e2) σ2 efs. - Proof. apply is_an_eval_ctx_fill_step, is_eval_ctx. Qed. - Lemma fill_step_inv K e1' σ1 e2 σ2 efs : - to_val e1' = None → prim_step (ectx_fill K e1') σ1 e2 σ2 efs → - ∃ e2', e2 = ectx_fill K e2' ∧ prim_step e1' σ1 e2' σ2 efs. - Proof. apply is_an_eval_ctx_fill_step_inv, is_eval_ctx. Qed. - - - Lemma locale_fill e t1 K: - locale_of t1 (ectx_fill K e) = locale_of t1 (e). - Proof. - erewrite !mixin_locale_fill; [done | apply language_mixin]. - Qed. - Lemma locale_step_preserve e1 e2 σ1 σ2 t1 efs: - prim_step e1 σ1 e2 σ2 efs -> - locale_of t1 e1 = locale_of t1 e2. - Proof. - intros ?. eapply mixin_locale_step; [apply language_mixin|done]. - Qed. - Lemma locale_fill_step e1 e2 σ1 σ2 t1 efs K: - prim_step e1 σ1 e2 σ2 efs -> - locale_of t1 (ectx_fill K e1) = locale_of t1 (ectx_fill K e2). - Proof. - erewrite !locale_fill. intros ?. by eapply locale_step_preserve. - Qed. - Lemma locale_equiv t t' e: locales_equiv t t' -> locale_of t e = locale_of t' e. - Proof. apply language_mixin. Qed. - Lemma locale_injective tp0 e0 tp1 tp e : - (tp, e) ∈ prefixes_from (tp0 ++ [e0]) tp1 -> locale_of tp0 e0 ≠ locale_of tp e. - Proof. eapply language_mixin. Qed. - - Definition reducible (e : expr Λ) (σ : state Λ) := - ∃ e' σ' efs, prim_step e σ e' σ' efs. - Definition irreducible (e : expr Λ) (σ : state Λ) := - ∀ e' σ' efs, ¬prim_step e σ e' σ' efs. - Definition stuck (e : expr Λ) (σ : state Λ) := - to_val e = None ∧ irreducible e σ. - Definition not_stuck (e : expr Λ) (σ : state Λ) := - is_Some (to_val e) ∨ reducible e σ. - - (* [Atomic WeaklyAtomic]: This (weak) form of atomicity is enough to open - invariants when WP ensures safety, i.e., programs never can get stuck. We - have an example in lambdaRust of an expression that is atomic in this - sense, but not in the stronger sense defined below, and we have to be able - to open invariants around that expression. See `CasStuckS` in - [lambdaRust](https://gitlab.mpi-sws.org/FP/LambdaRust-coq/blob/master/theories/lang/lang.v). - - [Atomic StronglyAtomic]: To open invariants with a WP that does not ensure - safety, we need a stronger form of atomicity. With the above definition, - in case `e` reduces to a stuck non-value, there is no proof that the - invariants have been established again. *) - Class Atomic (a : atomicity) (e : expr Λ) : Prop := - atomic σ e' σ' efs : - prim_step e σ e' σ' efs → - if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e'). - - Class StutteringAtomic (a : atomicity) (e : expr Λ) : Prop := - stutteringatomic σ e' σ' efs : - prim_step e σ e' σ' efs → - (e' = e ∧ σ' = σ ∧ efs = []) - ∨ - if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e'). - - Global Instance atomic_stutteringatomic a e : - Atomic a e → StutteringAtomic a e. - Proof. - rewrite /Atomic /StutteringAtomic. - intros Hat ?????; right; eapply Hat; eauto. - Qed. - - Inductive step (ρ1 : cfg Λ) (ρ2 : cfg Λ) : Prop := - | step_atomic e1 σ1 e2 σ2 efs t1 t2 : - ρ1 = (t1 ++ e1 :: t2, σ1) → - ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) → - prim_step e1 σ1 e2 σ2 efs → - step ρ1 ρ2 - | step_state σ1 σ2 t : - ρ1 = (t, σ1) → - ρ2 = (t, σ2) → - config_step σ1 σ2 → - step ρ1 ρ2. - Hint Constructors step : core. - - Inductive locale_step: cfg Λ -> option(locale Λ) -> cfg Λ -> Prop := - | locale_step_atomic ρ1 ρ2 e1 σ1 e2 σ2 efs t1 t2 : - ρ1 = (t1 ++ e1 :: t2, σ1) → - ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) → - prim_step e1 σ1 e2 σ2 efs → - locale_step ρ1 (Some $ locale_of t1 e1) ρ2 - | locale_step_state ρ1 ρ2 σ1 σ2 t : - ρ1 = (t, σ1) → - ρ2 = (t, σ2) → - config_step σ1 σ2 → - locale_step ρ1 None ρ2. - Hint Constructors locale_step : core. - - Inductive nsteps : nat → cfg Λ → cfg Λ → Prop := - | nsteps_refl ρ : nsteps 0 ρ ρ - | nsteps_l n ρ1 ρ2 ρ3 : step ρ1 ρ2 → nsteps n ρ2 ρ3 → nsteps (S n) ρ1 ρ3. - Hint Constructors nsteps : core. - - (** [rtc step] and [nsteps] encode the same thing, just packaged - in a different way. *) - Lemma steps_nsteps ρ1 ρ2 : - rtc step ρ1 ρ2 ↔ ∃ n, nsteps n ρ1 ρ2. - Proof. - split. - - induction 1; firstorder eauto. (* FIXME: [naive_solver eauto] should be able to handle this *) - - intros (n & Hsteps). - induction Hsteps; eauto using rtc_refl, rtc_l. - Qed. - - Lemma of_to_val_flip v e : of_val v = e → to_val e = Some v. - Proof. intros <-. by rewrite to_of_val. Qed. - - Lemma not_reducible e σ : ¬reducible e σ ↔ irreducible e σ. - Proof. unfold reducible, irreducible. naive_solver. Qed. - Lemma reducible_not_val e σ : reducible e σ → to_val e = None. - Proof. intros (?&?&?&?); eauto using val_stuck. Qed. - Lemma val_irreducible e σ : is_Some (to_val e) → irreducible e σ. - Proof. intros [??] ??? ?%val_stuck. by destruct (to_val e). Qed. - Global Instance of_val_inj : Inj (=) (=) (@of_val Λ). - Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed. - Lemma not_not_stuck e σ : ¬not_stuck e σ ↔ stuck e σ. - Proof. - rewrite /stuck /not_stuck -not_eq_None_Some -not_reducible. - destruct (decide (to_val e = None)); naive_solver. - Qed. - - Lemma strongly_atomic_atomic e a : - Atomic StronglyAtomic e → Atomic a e. - Proof. unfold Atomic. destruct a; eauto using val_irreducible. Qed. - - Lemma strongly_stutteringatomic_stutteringatomic e a : - StutteringAtomic StronglyAtomic e → StutteringAtomic a e. - Proof. - unfold StutteringAtomic. - destruct a; intros Hat; first tauto. - intros ? ? ? ? [|]%Hat; auto using val_irreducible. - Qed. - Lemma reducible_fill K e σ : - reducible e σ → reducible (ectx_fill K e) σ. - Proof. - unfold reducible in *. - naive_solver eauto using fill_step. - Qed. - Lemma reducible_fill_inv K e σ : - to_val e = None → reducible (ectx_fill K e) σ → reducible e σ. - Proof. - intros ? (e'&σ'&efs&Hstep); unfold reducible. - apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto. - Qed. - Lemma irreducible_fill K e σ : - to_val e = None → irreducible e σ → irreducible (ectx_fill K e) σ. - Proof. - rewrite -!not_reducible. naive_solver eauto using reducible_fill_inv. - Qed. - Lemma irreducible_fill_inv K e σ : - irreducible (ectx_fill K e) σ → irreducible e σ. - Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill. Qed. - - Lemma not_stuck_fill_inv K e σ : - not_stuck (ectx_fill K e) σ → not_stuck e σ. - Proof. - rewrite /not_stuck -!not_eq_None_Some. intros [?|?]. - - auto using fill_not_val. - - destruct (decide (to_val e = None)); eauto using reducible_fill_inv. - Qed. - - Lemma stuck_fill K e σ : - stuck e σ → stuck (ectx_fill K e) σ. - Proof. rewrite -!not_not_stuck. eauto using not_stuck_fill_inv. Qed. - - Lemma step_Permutation (t1 t1' t2 : list (expr Λ)) σ1 σ2 : - t1 ≡ₚ t1' → step (t1,σ1) (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ step (t1',σ1) (t2',σ2). - Proof. - intros Ht Hs. - inversion Hs as [e1 σ1' e2 σ2' efs tl tr ?? Hstep|]; simplify_eq /=. - - move: Ht. rewrite -Permutation_middle (symmetry_iff (≡ₚ)). - intros (tl'&tr'&->&Ht)%Permutation_cons_inv_r. - exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor]. - by rewrite -!Permutation_middle !assoc_L Ht. - - exists t1'; split; first done. - econstructor 2; eauto. - Qed. - - Lemma step_insert i t2 σ2 e e' σ3 efs : - t2 !! i = Some e → - prim_step e σ2 e' σ3 efs → - step (t2, σ2) (<[i:=e']>t2 ++ efs, σ3). - Proof. - intros. - edestruct (elem_of_list_split_length t2) as (t21&t22&?&?); - first (by eauto using elem_of_list_lookup_2); simplify_eq. - econstructor; eauto. - by rewrite insert_app_r_alt // Nat.sub_diag /= -assoc_L. - Qed. - - Record pure_step (e1 e2 : expr Λ) := { - pure_step_safe σ1 : reducible e1 σ1; - pure_step_det σ1 e2' σ2 efs : - prim_step e1 σ1 e2' σ2 efs → σ2 = σ1 ∧ e2' = e2 ∧ efs = [] - }. - - Notation pure_steps_tp := (Forall2 (rtc pure_step)). - - (* TODO: Exclude the case of [n=0], either here, or in [wp_pure] to avoid it - succeeding when it did not actually do anything. *) - Class PureExec (φ : Prop) (n : nat) (e1 e2 : expr Λ) := - pure_exec : φ → relations.nsteps pure_step n e1 e2. - - Lemma pure_step_ctx K e1 e2 : - pure_step e1 e2 → - pure_step (ectx_fill K e1) (ectx_fill K e2). - Proof. - intros [Hred Hstep]. split. - - unfold reducible in *. - naive_solver eauto using fill_step. - - intros σ1 e2' σ2 efs Hpstep. - destruct (fill_step_inv K e1 σ1 e2' σ2 efs) - as (e2'' & -> & ?); [|exact Hpstep|]. - + destruct (Hred σ1) as (? & ? & ? & ?); eauto using val_stuck. - + edestruct (Hstep σ1 e2'' σ2 efs) as (-> & -> & ->); auto. - Qed. - - Lemma pure_step_nsteps_ctx K n e1 e2 : - relations.nsteps pure_step n e1 e2 → - relations.nsteps pure_step n (ectx_fill K e1) (ectx_fill K e2). - Proof. eauto using nsteps_congruence, pure_step_ctx. Qed. - - Lemma rtc_pure_step_ctx K e1 e2 : - rtc pure_step e1 e2 → rtc pure_step (ectx_fill K e1) (ectx_fill K e2). - Proof. eauto using rtc_congruence, pure_step_ctx. Qed. - - (* We do not make this an instance because it is awfully general. *) - Lemma pure_exec_ctx K φ n e1 e2 : - PureExec φ n e1 e2 → - PureExec φ n (ectx_fill K e1) (ectx_fill K e2). - Proof. rewrite /PureExec; eauto using pure_step_nsteps_ctx. Qed. - - (* This is a family of frequent assumptions for PureExec *) - Class IntoVal (e : expr Λ) (v : val Λ) := - into_val : of_val v = e. - - Class AsVal (e : expr Λ) := as_val : ∃ v, of_val v = e. - (* There is no instance [IntoVal → AsVal] as often one can solve [AsVal] more - efficiently since no witness has to be computed. *) - Global Instance as_vals_of_val vs : TCForall AsVal (of_val <$> vs). - Proof. - apply TCForall_Forall, Forall_fmap, Forall_true=> v. - rewrite /AsVal /=; eauto. - Qed. - - Lemma as_val_is_Some e : - (∃ v, of_val v = e) → is_Some (to_val e). - Proof. intros [v <-]. rewrite to_of_val. eauto. Qed. - - Lemma prim_step_not_stuck e σ e' σ' efs : - prim_step e σ e' σ' efs → not_stuck e σ. - Proof. rewrite /not_stuck /reducible. eauto 10. Qed. - - Lemma rtc_pure_step_val `{!Inhabited (state Λ)} v e : - rtc pure_step (of_val v) e → to_val e = Some v. - Proof. - intros ?; rewrite <- to_of_val. - f_equal; symmetry; eapply rtc_nf; first done. - intros [e' [Hstep _]]. - destruct (Hstep inhabitant) as (?&?&?&Hval%val_stuck). - by rewrite to_of_val in Hval. - Qed. - (* FIXME: add a new case *) - (** Let thread pools [t1] and [t3] be such that each thread in [t1] makes - (zero or more) pure steps to the corresponding thread in [t3]. Furthermore, - let [t2] be a thread pool such that [t1] under state [σ1] makes a (single) - step to thread pool [t2] and state [σ2]. In this situation, either the step - from [t1] to [t2] corresponds to one of the pure steps between [t1] and [t3], - or, there is an [i] such that [i]th thread does not participate in the - pure steps between [t1] and [t3] and [t2] corresponds to taking a step in - the [i]th thread starting from [t1]. *) - Lemma step_pure_step_tp t1 σ1 t2 σ2 t3 : - step (t1, σ1) (t2, σ2) → - pure_steps_tp t1 t3 → - (σ1 = σ2 ∧ pure_steps_tp t2 t3) ∨ - (∃ i e efs e', - t1 !! i = Some e ∧ t3 !! i = Some e ∧ - t2 = <[i:=e']>t1 ++ efs ∧ - prim_step e σ1 e' σ2 efs) ∨ config_step σ1 σ2. - Proof. - intros Ht Hps. - inversion Ht as [e σ e' σ' efs t11 t12 ?? Hstep|]; simplify_eq/=. - - apply Forall2_app_inv_l in Hps - as (t31&?&Hpsteps&(e''&t32&Hps&?&->)%Forall2_cons_inv_l&->). - destruct Hps as [e|e1 e2 e3 [_ Hprs]]. - + right; left. - exists (length t11), e, efs, e'; split_and!; last done. - * by rewrite lookup_app_r // Nat.sub_diag. - * apply Forall2_length in Hpsteps. - by rewrite lookup_app_r Hpsteps // Nat.sub_diag. - * by rewrite insert_app_r_alt // Nat.sub_diag /= -assoc_L. - + edestruct Hprs as (?&?&?); first done; simplify_eq. - left; split; first done. - rewrite right_id_L. - eauto using Forall2_app. - - right; right; eauto. - Qed. - -End language. - -Notation pure_steps_tp := (Forall2 (rtc pure_step)). diff --git a/trillium/program_logic/lifting.v b/trillium/program_logic/lifting.v deleted file mode 100644 index 31e07b39..00000000 --- a/trillium/program_logic/lifting.v +++ /dev/null @@ -1,238 +0,0 @@ -(** The "lifting lemmas" in this file serve to lift the rules of the operational -semantics to the program logic. *) - -From iris.proofmode Require Import tactics. -From trillium.program_logic Require Export weakestpre. -Set Default Proof Using "Type". - -Section lifting. -Context `{!irisG Λ M Σ}. -Implicit Types s : stuckness. -Implicit Types v : val Λ. -Implicit Types e : expr Λ. -Implicit Types σ : state Λ. -Implicit Types δ : mstate M. -Implicit Types P Q : iProp Σ. -Implicit Types Φ : val Λ → iProp Σ. - -Lemma wp_lift_step_fupdN s E Φ e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ ectx_fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ - state_interp extr atr ={E,∅}=∗ - ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅}▷=∗^(S $ trace_length extr) |={∅,E}=> - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - WP e2 @ s; ζ; E {{ Φ }} ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - rewrite wp_unfold /wp_pre=>->. - iIntros "H" (exre atr K tp1 tp2 σ1 Hexvald Hlocale Hexe) "Hsi". - iMod ("H" with "[//] [//] [//] Hsi") as "[$ H]". - iIntros "!#" (e2 σ2 efs Hstep). - iMod ("H" with "[//]") as "H". - iModIntro; iNext. - iApply "H". -Qed. - -Lemma wp_lift_step_fupd s E Φ e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ ectx_fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ - state_interp extr atr ={E,∅}=∗ - ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅,E}=> - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - WP e2 @ s; ζ; E {{ Φ }} ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - intros ?. rewrite -wp_lift_step_fupdN; [|done]. simpl. do 26 f_equiv. - rewrite -step_fupdN_intro; [|done]. rewrite -bi.laterN_intro. auto. -Qed. - -Lemma wp_lift_stuck E Φ e ζ: - to_val e = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ ectx_fill K e :: tp2, σ)⌝ → - state_interp extr atr ={E,∅}=∗ ⌜stuck e σ⌝) - ⊢ WP e @ ζ; E ?{{ Φ }}. -Proof. - rewrite wp_unfold /wp_pre=>->. - iIntros "H" (ex atr K tp1 tp2 σ Hexvalid Hlocale Hex) "Hsi". - iMod ("H" with "[//] [//] Hsi") as %[? Hirr]. - iModIntro. iSplit; first done. - iIntros (e2 σ2 efs ?). by case: (Hirr e2 σ2 efs). - Qed. - -(** Derived lifting lemmas. *) -Lemma wp_lift_step s E Φ e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ ectx_fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ - state_interp extr atr ={E,∅}=∗ - ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗ - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - WP e2 @ s; ζ; E {{ Φ }} ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (?) "H". iApply wp_lift_step_fupd; [done|]. iIntros (?????????) "Hsi". - iMod ("H" with "[//] [//] [//] Hsi") as "[$ H]". - iIntros "!> * % !> !>". by iApply "H". -Qed. - -Lemma wp_lift_pure_step_no_fork - `{!AllowsPureStep M Σ} `{!Inhabited (state Λ)} s E E' Φ e1 ζ: - (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) → - (∀ σ1 e2 σ2 efs, prim_step e1 σ1 e2 σ2 efs → σ2 = σ1 ∧ efs = []) → - (|={E}[E']▷=> ∀ e2 efs σ, ⌜prim_step e1 σ e2 σ efs⌝ → WP e2 @ s; ζ; E {{ Φ }}) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (Hsafe Hstep) "H". iApply wp_lift_step. - { specialize (Hsafe inhabitant). destruct s; eauto using reducible_not_val. } - iIntros (ex atr K tp1 tp2 σ1 Hexvalid Hex Hloc) "Hsi". iMod "H". - iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. - iSplit. - { iPureIntro. destruct s; done. } - iNext. iIntros (e2 σ2 efs ?). - destruct (Hstep σ1 e2 σ2 efs) as (<- & ->); auto. - iMod "Hclose" as "_". iMod "H". - iMod (allows_pure_step with "Hsi") as "Hsi"; [done|done|done| |]. - { econstructor 1; [done| |by apply fill_step]; by rewrite app_nil_r. } - rewrite !app_nil_r. - iModIntro. - iDestruct ("H" with "[//]") as "H". - iFrame. simplify_eq. - iExists (trace_last atr), pure_label; iSplit; eauto. -Qed. - -Lemma wp_lift_pure_stuck `{!Inhabited (state Λ)} E Φ e : - (∀ σ, stuck e σ) → - ⊢ WP e @ E ?{{ Φ }}. -Proof. - iIntros (Hstuck). iApply wp_lift_stuck. - - destruct(to_val e) as [v|] eqn:He; last done. - rewrite -He. by case: (Hstuck inhabitant). - - iIntros (ex atr K ? tp1 tp2 σ) "_". - iMod (fupd_mask_subseteq ∅) as "_"; first set_solver; eauto. -Qed. - -(* Atomic steps don't need any mask-changing business here, one can - use the generic lemmas here. *) -Lemma wp_lift_atomic_step_fupd {s E1 E2 Φ} e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ ectx_fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 e1 = ζ⌝ → - state_interp extr atr ={E1}=∗ - ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E1}[E2]▷=∗ - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - from_option Φ False (to_val e2) ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros (?) "H". - iApply (wp_lift_step_fupd s E1 _ e1); first done. - iIntros (ex atr K tp1 tp2 σ1 Hvalidex ? Hloc) "Hsi". - iMod ("H" with "[//] [//] [] Hsi") as "[$ H]". - { iPureIntro. by erewrite <-locale_fill. } - iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver. - iIntros "!>" (e2 σ2 efs ?). iMod "Hclose" as "_". - iMod ("H" $! e2 σ2 efs with "[#]") as "H"; [done|]. - iMod (fupd_mask_subseteq ∅) as "Hclose"; [set_solver|]. iIntros "!> !>". - iMod "Hclose" as "_". iMod "H" as (st' ℓ) "(? & HQ & $)". - destruct (to_val e2) eqn:?; last by iExFalso. - iModIntro; iExists _, _. - iFrame. - iApply wp_value; last done. by apply of_to_val. -Qed. - -Lemma wp_lift_atomic_step {s E Φ} e1 ζ: - to_val e1 = None → - (∀ (extr : execution_trace Λ) (atr : auxiliary_trace M) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ ectx_fill K e1 :: tp2, σ1)⌝ → - ⌜locale_of tp1 e1 = ζ⌝ → - state_interp extr atr ={E}=∗ - ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E}=∗ - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - from_option Φ False (to_val e2) ∗ - [∗ list] i ↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef; ⊤ - {{ fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) }}) - ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|]. - iIntros (?????????) "?". iMod ("H" with "[//] [//] [//] [$]") as "[$ H]". - iIntros "!> *". iIntros (Hstep) "!> !>". - by iApply "H". -Qed. - -Lemma wp_lift_pure_det_step_no_fork - `{!AllowsPureStep M Σ} `{!Inhabited (state Λ)} {s E E' Φ} e1 e2 ζ: - (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) → - (∀ σ1 e2' σ2 efs', prim_step e1 σ1 e2' σ2 efs' → - σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → - (|={E}[E']▷=> WP e2 @ s; ζ; E {{ Φ }}) ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (? Hpuredet) "H". iApply (wp_lift_pure_step_no_fork s E E'); try done. - { naive_solver. } - iApply (step_fupd_wand with "H"); iIntros "H". - iIntros (e' efs' σ (?&->&?)%Hpuredet); auto. -Qed. - -Lemma wp_pure_step_fupd - `{!AllowsPureStep M Σ} `{!Inhabited (state Λ)} s E E' ζ e1 e2 φ n Φ : - PureExec φ n e1 e2 → - φ → - (|={E}[E']▷=>^n WP e2 @ s; ζ; E {{ Φ }}) ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ). - iInduction Hexec as [e|n e1 e2 e3 [Hsafe ?]] "IH"; simpl; first done. - iApply wp_lift_pure_det_step_no_fork. - - intros σ. specialize (Hsafe σ). destruct s; eauto using reducible_not_val. - - done. - - by iApply (step_fupd_wand with "Hwp"). -Qed. - -Lemma wp_pure_step_later - `{!AllowsPureStep M Σ} `{!Inhabited (state Λ)} s E ζ e1 e2 φ n Φ : - PureExec φ n e1 e2 → - φ → - ▷^n WP e2 @ s; ζ; E {{ Φ }} ⊢ WP e1 @ s; ζ; E {{ Φ }}. -Proof. - intros Hexec ?. rewrite -wp_pure_step_fupd //. clear Hexec. - induction n as [|n IH]; by rewrite //= -step_fupd_intro // IH. -Qed. -End lifting. diff --git a/trillium/program_logic/traces.v b/trillium/program_logic/traces.v deleted file mode 100644 index 99f4fd39..00000000 --- a/trillium/program_logic/traces.v +++ /dev/null @@ -1,406 +0,0 @@ -From trillium.traces Require Export trace infinite_trace. -From trillium.program_logic Require Import language. - -Import InfListNotations. - -Definition execution_trace Λ := finite_trace (cfg Λ) (option (locale Λ)). - -Record Model : Type := MkModel { - mstate:> Type; - mlabel: Type; - mtrans: mstate -> mlabel -> mstate -> Prop; -}. - -Arguments mtrans {_} _ _ _. - -Notation olocale Λ := (option (locale Λ)). - -Notation auxiliary_trace m := (finite_trace m.(mstate) m.(mlabel)). - -Section execution_trace. - Context {Λ : language}. - - Implicit Types c : cfg Λ. - - Definition valid_exec (ex : execution_trace Λ) : Prop := trace_steps locale_step ex. - - Lemma valid_singleton_exec c : valid_exec (trace_singleton c). - Proof. constructor. Qed. - - Lemma extend_valid_exec ex c ζ c': - valid_exec ex → - trace_ends_in ex c → - locale_step c ζ c' → - valid_exec (ex :tr[ζ]: c'). - Proof. econstructor; done. Qed. - - Lemma valid_exec_exec_extend_inv ex ζ c': - valid_exec (trace_extend ex ζ c') → - valid_exec ex ∧ - ∃ c, trace_ends_in ex c ∧ locale_step c ζ c'. - Proof. apply trace_steps_step_inv. Qed. - -End execution_trace. - -Section system_trace. - Context {Λ : language} {M : Model}. - - Implicit Types ex : execution_trace Λ. - Implicit Types atr : auxiliary_trace M. - Implicit Types ζ : olocale Λ. - Implicit Types ℓ : mlabel M. - - Inductive valid_system_trace : execution_trace Λ → auxiliary_trace M → Prop := - | valid_system_trace_singleton c δ : - valid_system_trace (trace_singleton c) (trace_singleton δ) - | valid_system_trace_step ex atr c c' δ' ζ ℓ: - trace_ends_in ex c → - locale_step c ζ c' → - valid_system_trace ex atr → - valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ'). - - Lemma valid_system_trace_valid_exec_trace ex atr : - valid_system_trace ex atr → valid_exec ex. - Proof. induction 1; econstructor; eauto. Qed. - - Lemma valid_system_trace_singletons c δ : - valid_system_trace (trace_singleton c) (trace_singleton δ). - Proof. constructor. Qed. - - Lemma valid_system_trace_extend ex atr c c' δ' ζ ℓ: - valid_system_trace ex atr → - trace_ends_in ex c → - locale_step c ζ c' → - valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ'). - Proof. - intros Heatr; revert c c' δ' ζ ℓ. - induction ex; econstructor; eauto. - Qed. - - Lemma valid_system_trace_extend_inv ex atr c' δ' ζ ℓ: - valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ') → - ∃ c, - valid_system_trace ex atr ∧ - trace_ends_in ex c ∧ - locale_step c ζ c'. - Proof. inversion 1; eauto. Qed. - - Lemma valid_system_trace_ends_in ex atr : - valid_system_trace ex atr → ∃ c δ, trace_ends_in ex c ∧ trace_ends_in atr δ. - Proof. - inversion 1; - eauto using trace_extend_ends_in, trace_singleton_ends_in, - trace_extend_ends_in, trace_singleton_ends_in. - Qed. - - Lemma trace_steps2_trace_steps (R : M -> mlabel M -> M -> Prop) : - (∀ ex atr c δ c' δ' ζ ℓ, - trace_ends_in ex c → - trace_ends_in atr δ → - locale_step c ζ c' → - R δ ℓ δ') → - ∀ ex atr, valid_system_trace ex atr → valid_exec ex ∧ trace_steps R atr. - Proof. - intros HR ex ex' Hexs. - induction Hexs as [|?????????? []]. - - split; constructor. - - split; econstructor; [done|done|done|done|eapply HR=>//|done]. - Qed. - -End system_trace. - -Section simulation. - Context {Λ : language} {M : Model}. - Variable (labels_match : olocale Λ → mlabel M → Prop). - - Implicit Types ex : execution_trace Λ. - Implicit Types atr : auxiliary_trace M. - - Definition continued_simulation_pre - (φ : execution_trace Λ → auxiliary_trace M → Prop) - (continued_simulation : - execution_trace Λ → auxiliary_trace M → Prop) : - execution_trace Λ → auxiliary_trace M → Prop := - λ ex atr, - φ ex atr ∧ - ∀ c c' ζ, - trace_ends_in ex c → - locale_step c ζ c' → - ∃ δ' ℓ, continued_simulation (trace_extend ex ζ c') (trace_extend atr ℓ δ'). - - Local Definition continued_simulation_pre_curried - (φ : execution_trace Λ → auxiliary_trace M → Prop) : - (execution_trace Λ * auxiliary_trace M → Prop) → - (execution_trace Λ * auxiliary_trace M → Prop) := - λ ψ (exatr : execution_trace Λ * auxiliary_trace M), - (continued_simulation_pre φ (λ ex atr, ψ (ex, atr)) exatr.1 exatr.2). - - Lemma continued_simulation_pre_curried_mono - (φ : execution_trace Λ → auxiliary_trace M → Prop) : - monotone (continued_simulation_pre_curried φ). - Proof. - intros P Q HPQ [ex atr]. - intros [? HP]. split; [done|]. - intros ?????. - edestruct HP as (?&?&?); eauto. - Qed. - - Definition continued_simulation (φ : execution_trace Λ → auxiliary_trace M → Prop) := - λ ex atr, GFX (continued_simulation_pre_curried φ) (ex, atr). - - Lemma continued_simulation_unfold - (φ : execution_trace Λ → auxiliary_trace M → Prop) ex atr : - continued_simulation φ ex atr ↔ - continued_simulation_pre φ (continued_simulation φ) ex atr. - Proof. - symmetry; rewrite /continued_simulation /=. - apply (λ H, GFX_fixpoint (continued_simulation_pre_curried φ) H (_, _)). - apply continued_simulation_pre_curried_mono. - Qed. - - Lemma continued_simulation_rel Φ ex tr: - continued_simulation Φ ex tr → Φ ex tr. - Proof. - rewrite continued_simulation_unfold /continued_simulation_pre; intuition. - Qed. - - Lemma continued_simulation_next_aux_state_exists - (φ : execution_trace Λ → auxiliary_trace M → Prop) - (ex : execution_trace Λ) (atr : auxiliary_trace M) - (c : cfg Λ) ζ: - continued_simulation φ ex atr → - valid_exec (trace_extend ex ζ c) → - ∃ δℓ, continued_simulation φ (trace_extend ex ζ c) (trace_extend atr δℓ.2 δℓ.1). - Proof. - rewrite continued_simulation_unfold /continued_simulation_pre. - intros (HΦ & Hext) Hvex. - apply valid_exec_exec_extend_inv in Hvex as [Hvex (c1 & Hc1 & Hstep)]. - edestruct Hext as (?&?&?); [done..|]. - by eexists (_,_). - Qed. - - Lemma simulation_does_continue es σ δ φ : - continued_simulation φ (trace_singleton (es, σ)) (trace_singleton δ) → - ∀ ex, trace_starts_in ex (es, σ) → - valid_exec ex → - ∃ atr, trace_starts_in atr δ ∧ continued_simulation φ ex atr. - Proof. - intros Hsm ex Hexstr Hex. - induction Hex as [|? ? ? ? ? ? ? IHex]. - - apply trace_singleton_starts_in_inv in Hexstr as ->. - exists (trace_singleton δ). done. - - destruct IHex as [atr [Hstarts Hsim]]. - { eapply trace_extend_starts_in_inv; eauto. } - edestruct (continued_simulation_next_aux_state_exists φ ex atr) as ([??]&?); - [done| |]. - { econstructor; eauto. } - eexists. split; [|done]. - by apply trace_extend_starts_in. - Qed. - - Lemma continued_simulation_impl (Φ Ψ: execution_trace Λ → auxiliary_trace M → Prop) ex tr: - (∀ ex tr, Φ ex tr → Ψ ex tr) → - continued_simulation Φ ex tr → continued_simulation Ψ ex tr. - Proof. - intros Himpl Hphi. - rewrite /continued_simulation /GFX. - exists (λ '(ex, atr), continued_simulation Φ ex atr). - split; [done|]. - intros [? ?] ?. - rewrite /continued_simulation_pre_curried /continued_simulation_pre /=. - split. - { by eapply Himpl, continued_simulation_rel. } - intros c c' ζ ? ?. - move: H. - rewrite continued_simulation_unfold /continued_simulation_pre. - intros [? ?]. eauto. - Qed. - -End simulation. - -Definition inf_execution_trace Λ := inflist (olocale Λ * cfg Λ). - -Section inf_execution_trace. - Context {Λ : language}. - - Definition inf_exec_prepend ζ (c : cfg Λ) - (iex : inf_execution_trace Λ) : inf_execution_trace Λ := - ((ζ, c) :: iex)%inflist. - - CoInductive valid_inf_exec : - execution_trace Λ → inf_execution_trace Λ → Prop := - | valid_inf_exec_singleton ex : - valid_exec ex → valid_inf_exec ex []%inflist - | valid_inf_exec_step ex c c' iex ζ: - valid_exec ex → - trace_ends_in ex c → - locale_step c ζ c' → - valid_inf_exec (trace_extend ex ζ c') iex → - valid_inf_exec ex (inf_exec_prepend ζ c' iex). - -End inf_execution_trace. - -Definition inf_auxiliary_trace (M : Model) := inflist ((mlabel $ M) * M). - -Definition inf_auxtr_prepend {M : Model} ℓ (δ : M) (atr : inf_auxiliary_trace M) := - infcons (ℓ,δ) atr. - -CoInductive valid_inf_system_trace {Λ M} - (Ψ : execution_trace Λ → auxiliary_trace M → Prop) : - execution_trace Λ → auxiliary_trace M → - inf_execution_trace Λ → inf_auxiliary_trace M → Prop := -| valid_inf_system_trace_singleton ex atr : - Ψ ex atr → - valid_inf_system_trace Ψ ex atr []%inflist []%inflist -| valid_inf_system_trace_step ex atr c c' δ' iex iatr ζ ℓ: - Ψ ex atr → - trace_ends_in ex c → - locale_step c ζ c' → - valid_inf_system_trace - Ψ (trace_extend ex ζ c') (trace_extend atr ℓ δ') iex iatr → - valid_inf_system_trace - Ψ ex atr (inf_exec_prepend ζ c' iex) (inf_auxtr_prepend ℓ δ' iatr). - -Lemma valid_inf_system_trace_inv {Λ M} - (Ψ : execution_trace Λ → auxiliary_trace M → Prop) ex atr iex itr : - valid_inf_system_trace Ψ ex atr iex itr → - Ψ ex atr. -Proof. by inversion 1. Qed. - -Section simulation. - Context {Λ : language} {M : Model} - (φ : execution_trace Λ → auxiliary_trace M → Prop). - - Implicit Types ex : execution_trace Λ. - Implicit Types iex : inf_execution_trace Λ. - Implicit Types atr : auxiliary_trace M. - Implicit Types ζ : olocale Λ. - Implicit Types ℓ : mlabel M. - - Lemma valid_system_trace_start_or_contract ex atr : - valid_system_trace ex atr → - (ex = {tr[trace_first ex]} ∧ atr = {tr[trace_first atr]}) ∨ - (∃ ex' atr' oζ ℓ, trace_contract ex oζ ex' ∧ trace_contract atr ℓ atr'). - Proof. rewrite /trace_contract; inversion 1; simplify_eq; eauto 10. Qed. - - Lemma valid_inf_exec_prepend_valid_exec_extend ex c iex ζ: - valid_inf_exec ex (inf_exec_prepend ζ c iex) → - valid_exec (trace_extend ex ζ c). - Proof. - inversion 1 as [|???????? Hex]; simplify_eq. - inversion Hex; done. - Qed. - - Lemma produce_inf_aux_trace_next_aux_state_exists - (ex : execution_trace Λ) (atr : auxiliary_trace M) - (Hcsm : continued_simulation φ ex atr) - (c : cfg Λ) - (ζ: olocale Λ) - (iex : inf_execution_trace Λ) - (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) : - ∃ δℓ, continued_simulation φ (trace_extend ex ζ c) (trace_extend atr δℓ.2 δℓ.1). - Proof. - eapply continued_simulation_next_aux_state_exists; first done. - eapply valid_inf_exec_prepend_valid_exec_extend; eauto. - Qed. - - Definition produce_inf_aux_trace_next_aux_state - (ex : execution_trace Λ) (atr : auxiliary_trace M) - (Hcsm : continued_simulation φ ex atr) - (c : cfg Λ) - (ζ: olocale Λ) - (iex : inf_execution_trace Λ) - (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) - : (M * mlabel M)%type := - epsilon - (produce_inf_aux_trace_next_aux_state_exists ex atr Hcsm c ζ iex Hvex). - - Definition trace_extend_uncurry (tr: auxiliary_trace M) xy := trace_extend tr xy.2 xy.1. - - Lemma produce_inf_aux_trace_next_aux_state_continued_simulation - (ex : execution_trace Λ) (atr : auxiliary_trace M) - (Hcsm : continued_simulation φ ex atr) - (c : cfg Λ) - (ζ: olocale Λ) - (iex : inf_execution_trace Λ) - (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) : - continued_simulation - φ - (trace_extend ex ζ c) - (trace_extend_uncurry - atr (produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex Hvex)). - Proof. - rewrite /produce_inf_aux_trace_next_aux_state. - apply epsilon_correct. - Qed. - - Local Lemma valid_inf_exec_adjust {ex c iex ζ} : - valid_inf_exec ex ((ζ, c) :: iex)%inflist → - valid_inf_exec (trace_extend ex ζ c) iex. - Proof. inversion 1; done. Qed. - - Lemma valid_inf_exe_valid_exec ex iex : - valid_inf_exec ex iex → valid_exec ex. - Proof. by destruct 1. Qed. - Lemma valid_inf_exe_take_drop ex iex n : - valid_inf_exec ex iex → valid_inf_exec (ex +trl+ inflist_take n iex) (inflist_drop n iex). - Proof. - revert ex iex; induction n as [|n IHn]; intros ex iex Hvl; simpl; first done. - destruct iex as [|[??]]; simpl; first done. - apply IHn. - apply valid_inf_exec_adjust; done. - Qed. - - CoFixpoint produce_inf_aux_trace - (ex : execution_trace Λ) (atr : auxiliary_trace M) - (Hcsm : continued_simulation φ ex atr) - (iex : inf_execution_trace Λ) - (Hvex : valid_inf_exec ex iex) : - inf_auxiliary_trace M := - match iex as l return valid_inf_exec ex l → inf_auxiliary_trace M with - | [] => λ _, [] - | (ζ, c) :: iex' => - λ Hvex', - let δℓ := - produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex' Hvex' - in - (δℓ.2, δℓ.1) :: (produce_inf_aux_trace - (trace_extend ex ζ c) - (trace_extend atr δℓ.2 δℓ.1) - (produce_inf_aux_trace_next_aux_state_continued_simulation - ex atr Hcsm c ζ iex' Hvex') - iex' - (valid_inf_exec_adjust Hvex')) - end%inflist Hvex. - - Theorem produced_inf_aux_trace_valid_inf - (ex : execution_trace Λ) (atr : auxiliary_trace M) - (Hst : valid_system_trace ex atr) - (Hcsm : continued_simulation φ ex atr) - (iex : inf_execution_trace Λ) - (Hvex : valid_inf_exec ex iex) - : valid_inf_system_trace - (continued_simulation φ) - ex atr - iex - (produce_inf_aux_trace ex atr Hcsm iex Hvex). - Proof. - revert ex atr Hcsm Hst iex Hvex; cofix CIH; intros ex atr Hcsm Hst iex Hvex. - destruct iex as [|[ζ c] iex]. - - rewrite [produce_inf_aux_trace _ _ _ _ _]inflist_unfold_fold /=. - constructor; trivial. - - rewrite [produce_inf_aux_trace _ _ _ _ _]inflist_unfold_fold /=. - pose proof (produce_inf_aux_trace_next_aux_state_continued_simulation - ex atr Hcsm c ζ iex Hvex) as Hcsm'. - assert (valid_system_trace - (ex :tr[ζ]: c) - (trace_extend_uncurry - atr (produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex Hvex))) - as Hst'. - { inversion Hvex; simplify_eq. - econstructor; try done. } - apply valid_system_trace_extend_inv in Hst' as (?&?&?&?). - econstructor; eauto using valid_system_trace_step. - Qed. - -End simulation. diff --git a/trillium/program_logic/weakestpre.v b/trillium/program_logic/weakestpre.v deleted file mode 100644 index 2ff7530d..00000000 --- a/trillium/program_logic/weakestpre.v +++ /dev/null @@ -1,699 +0,0 @@ -From iris.proofmode Require Import base proofmode classes. -From iris.base_logic.lib Require Export fancy_updates. -From trillium.program_logic Require Export language traces. -From trillium.bi Require Export weakestpre. -From iris.prelude Require Import options. - -Class irisG (Λ : language) (M : Model) (Σ : gFunctors) := IrisG { - iris_invGS :> invGS_gen HasNoLc Σ; - - (** The state interpretation is an invariant that should hold in between each - step of reduction. Here [Λstate] is the global state, [list Λobservation] are - the remaining observations, and [nat] is the number of forked-off threads - (not the total number of threads, which is one higher because there is always - a main thread). *) - state_interp : execution_trace Λ → auxiliary_trace M → iProp Σ; - - (** A fixed postcondition for any forked-off thread. For most languages, e.g. - heap_lang, this will simply be [True]. However, it is useful if one wants to - keep track of resources precisely, as in e.g. Iron. *) - fork_post : locale Λ → val Λ → iProp Σ; -}. -Global Opaque iris_invGS. - -Definition wp_pre `{!irisG Λ AS Σ} (s : stuckness) - (wp : coPset -d> locale Λ -d> expr Λ -d> (val Λ -d> iPropO Σ) -d> iPropO Σ) : - coPset -d> locale Λ -d> expr Λ -d> (val Λ -d> iPropO Σ) -d> iPropO Σ := λ E ζ e1 Φ, - match to_val e1 with - | Some v => |={E}=> Φ v - | None => ∀ (extr : execution_trace Λ) (atr : auxiliary_trace AS) K tp1 tp2 σ1, - ⌜valid_exec extr⌝ -∗ - ⌜locale_of tp1 (ectx_fill K e1) = ζ⌝ -∗ - ⌜trace_ends_in extr (tp1 ++ ectx_fill K e1 :: tp2, σ1)⌝ -∗ - state_interp extr atr ={E,∅}=∗ - ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ - ∀ e2 σ2 efs, - ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅}▷=∗^(S $ trace_length extr) |={∅,E}=> - ∃ δ2 ℓ, - state_interp - (trace_extend extr (Some ζ) (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2)) - (trace_extend atr ℓ δ2) ∗ - wp E ζ e2 Φ ∗ - [∗ list] i ↦ ef ∈ efs, - wp ⊤ (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef) ef - (fork_post (locale_of (tp1 ++ ectx_fill K e1 :: tp2 ++ (take i efs)) ef)) - end%I. - -#[local] Instance wp_pre_contractive `{!irisG Λ AS Σ} s : Contractive (wp_pre s). -Proof. - rewrite /wp_pre=> n wp wp' Hwp E e1 ζ Φ /=. - do 26 (f_contractive || f_equiv). - induction trace_length as [|k IH]; simpl. - - repeat (f_contractive || f_equiv); apply Hwp. - - by rewrite -IH. -Qed. - -Definition wp_def `{!irisG Λ AS Σ} : Wp Λ (iProp Σ) stuckness := - λ s : stuckness, fixpoint (wp_pre s). -Definition wp_aux : seal (@wp_def). Proof. by eexists. Qed. -Definition wp' := wp_aux.(unseal). -Arguments wp' {Λ AS Σ _}. -#[global] Existing Instance wp'. -Lemma wp_eq `{!irisG Λ AS Σ} : wp = @wp_def Λ AS Σ _. -Proof. rewrite -wp_aux.(seal_eq) //. Qed. - -Section wp. -Context `{!irisG Λ AS Σ}. -Implicit Types s : stuckness. -Implicit Types P : iProp Σ. -Implicit Types Φ : val Λ → iProp Σ. -Implicit Types v : val Λ. -Implicit Types e : expr Λ. -Implicit Types ζ : locale Λ. - -(* Weakest pre *) -Lemma wp_unfold s E e ζ Φ : - WP e @ s; ζ; E {{ Φ }} ⊣⊢ wp_pre s (wp (PROP:=iProp Σ) s) E ζ e Φ. -Proof. rewrite wp_eq. apply (fixpoint_unfold (wp_pre s)). Qed. - -#[global] Instance wp_ne s E ζ e n : - Proper (pointwise_relation _ (dist n) ==> dist n) (wp (PROP:=iProp Σ) s E ζ e). -Proof. - revert e. induction (lt_wf n) as [n _ IH]=> e Φ Ψ HΦ. - rewrite !wp_unfold /wp_pre /=. - do 29 (f_contractive || f_equiv). - induction trace_length as [|k IHk]; simpl; [|by rewrite IHk]. - do 7 (f_contractive || f_equiv). - rewrite IH; [done|lia|]. intros v. eapply dist_lt; eauto. -Qed. -#[global] Instance wp_proper s E ζ e : - Proper (pointwise_relation _ (≡) ==> (≡)) (wp (PROP:=iProp Σ) s E ζ e). -Proof. - by intros Φ Φ' ?; apply equiv_dist=>n; apply wp_ne=>v; apply equiv_dist. -Qed. -#[global] Instance wp_contractive s E ζ e n : - TCEq (to_val e) None → - Proper (pointwise_relation _ (dist_later n) ==> dist n) (wp (PROP:=iProp Σ) s E ζ e). -Proof. - intros He Φ Ψ HΦ. rewrite !wp_unfold /wp_pre He /=. - do 27 (f_contractive || f_equiv). - induction trace_length as [|k IHk]; simpl; [|by rewrite IHk]. - by repeat f_equiv. -Qed. - -Lemma wp_value' s E ζ Φ v : Φ v ⊢ WP of_val v @ s; ζ; E {{ Φ }}. -Proof. iIntros "HΦ". rewrite wp_unfold /wp_pre to_of_val. auto. Qed. -Lemma wp_value_inv' s E ζ Φ v : WP of_val v @ s; ζ; E {{ Φ }} ={E}=∗ Φ v. -Proof. by rewrite wp_unfold /wp_pre to_of_val. Qed. - -Lemma wp_strong_mono s1 s2 E1 E2 ζ e Φ Ψ : - s1 ⊑ s2 → E1 ⊆ E2 → - WP e @ s1; ζ; E1 {{ Φ }} -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ WP e @ s2; ζ; E2 {{ Ψ }}. -Proof. - iIntros (? HE) "H HΦ". iLöb as "IH" forall (e ζ E1 E2 HE Φ Ψ). - rewrite !wp_unfold /wp_pre. - destruct (to_val e) as [v|] eqn:?. - { iApply ("HΦ" with "[> -]"). by iApply (fupd_mask_mono E1 _). } - iIntros (extr atr K tp1 tp2 σ1 Hexvalid Hloc Hexe) "Hsi". - iMod (fupd_mask_subseteq E1) as "Hclose"; first done. - iMod ("H" with "[//] [//] [//] [$]") as "[% H]". - iModIntro. iSplit; [by iPureIntro; destruct s1, s2|]. - iIntros (e2 σ2 efs Hstep). simpl. - iMod ("H" with "[//]") as "H". iIntros "!> !>". - iMod "H" as "H". iIntros "!>". - iApply (step_fupdN_wand with "[H]"); first by iApply "H". - iIntros "H". iMod "H" as (δ2 ℓ) "(Hσ & H & Hefs)". - iMod "Hclose" as "_". iModIntro. - iExists δ2, ℓ. - iFrame "Hσ". iSplitR "Hefs". - - iApply ("IH" with "[//] H HΦ"). - - iApply (big_sepL_impl with "Hefs"); iIntros "!>" (k ef _). - iIntros "H". iApply ("IH" with "[] H"); auto. -Qed. - -Lemma fupd_wp s E ζ e Φ : (|={E}=> WP e @ s; ζ; E {{ Φ }}) ⊢ WP e @ s; ζ; E {{ Φ }}. -Proof. - rewrite wp_unfold /wp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?. - { by iMod "H". } - iMod "H". iApply "H"; done. -Qed. -Lemma wp_fupd s E ζ e Φ : WP e @ s; ζ; E {{ v, |={E}=> Φ v }} ⊢ WP e @ s; ζ; E {{ Φ }}. -Proof. iIntros "H". iApply (wp_strong_mono s s E with "H"); auto. Qed. - -Class AllowsStuttering := { - stuttering_label: mlabel AS; - allows_stuttering : - ∀ (extr : execution_trace Λ) (atr : auxiliary_trace AS) c δ oζ, - valid_exec extr → - trace_ends_in extr c → - trace_ends_in atr δ → - locale_step c oζ c → - state_interp extr atr ==∗ - state_interp (trace_extend extr oζ c) (trace_extend atr stuttering_label δ); - }. - -Class AllowsPureStep := { - pure_label: mlabel AS; - allows_pure_step : - ∀ (extr : execution_trace Λ) (atr : auxiliary_trace AS) tp tp' σ δ oζ, - valid_exec extr → - trace_ends_in extr (tp, σ) → - trace_ends_in atr δ → - locale_step (tp, σ) oζ (tp', σ) → - state_interp extr atr ==∗ - state_interp (trace_extend extr oζ (tp', σ)) (trace_extend atr pure_label δ); - }. - -#[global] Instance AllowsPureStep_AllowsStuttering : - AllowsPureStep → AllowsStuttering. -Proof. - intros Haps. refine ({| stuttering_label := pure_label |}). - iIntros (extr atr [tp σ] δ oζ ? ? ? ?) "Hsi". - iApply allows_pure_step; done. -Qed. - -Lemma wp_stuttering_atomic s E1 E2 ζ e Φ - `{!AllowsStuttering} - `{!StutteringAtomic (stuckness_to_atomicity s) e} : - (|={E1,E2}=> WP e @ s; ζ; E2 {{ v, |={E2,E1}=> Φ v }}) ⊢ WP e @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros "H". - iLöb as "IH". - rewrite {2}(wp_unfold s E1 e) /wp_pre. - rewrite !(wp_unfold s E2 e) /wp_pre. - destruct (to_val e) as [v|] eqn:He. - { by iDestruct "H" as ">>> $". } - iIntros (extr atr K tp1 tp2 σ1 Hexvalid Hlocale Hexe) "Hsi". - iAssert ((|={E1}=> ⌜match s with - | NotStuck => reducible e σ1 - | MaybeStuck => True - end⌝ ∗ - state_interp extr atr ∗ _)%I) with "[H Hsi]" as - ">(Hnstuck & Hsi & H)". - { iApply fupd_plain_keep_l. - iSplitR; last (iFrame "Hsi"; iExact "H"). - iIntros "[Hsi H]". - iApply fupd_plain_mask. - iMod "H". - iMod ("H" with "[//] [//] [//] Hsi") as "[? _]". - iModIntro; done. } - iPoseProof (fupd_mask_intro_subseteq E1 ∅ True%I with "[]") as "Hmsk"; - [set_solver|done|]. - iMod "Hmsk". - iModIntro. - iSplitL "Hnstuck"; first done. - iIntros (e2 σ2 efs Hstep). - destruct (stutteringatomic _ _ _ _ Hstep) as [(?&?&?)|Hs]; simplify_eq/=. - - iModIntro; iNext. - iMod (allows_stuttering with "Hsi") as "Hsi"; [done|done|done| |]. - { econstructor 1; [done| |by apply fill_step]; by rewrite app_nil_r. } - iIntros "!>". iApply step_fupdN_intro; [done|]. iIntros "!>". - iMod "Hmsk" as "_"; iModIntro. - rewrite app_nil_r. - iExists (trace_last atr), stuttering_label; iFrame "Hsi". - iSplitL; last done. - iApply "IH"; done. - - iClear "IH". - iMod "Hmsk" as "_". - iMod "H". iMod ("H" with "[//] [//] [//] Hsi") as "[_ H]". - iMod ("H" with "[//]") as "H". iIntros "!>!>". - iMod "H" as "H". iIntros "!>". - iApply (step_fupdN_wand with "[H]"); first by iApply "H". - iIntros "H". - iMod "H" as (δ2 ℓ) "(Hσ & H & Hefs)". destruct s. - + rewrite !wp_unfold /wp_pre. destruct (to_val e2) as [v2|] eqn:He2. - * iDestruct "H" as ">> H". - iModIntro; iExists _, _. - iFrame. - rewrite !wp_unfold /wp_pre He2; done. - * iMod ("H" with "[] [] [] [$]") as "[H _]". - { iPureIntro. eapply extend_valid_exec; [done|done|]. - econstructor; [done|done|]. - apply fill_step; done. } - { by erewrite <-locale_fill_step. } - { done. } - iDestruct "H" as %(? & ? & ? & ?%Hs); done. - + destruct Hs as [v <-%of_to_val]. - rewrite !wp_unfold /wp_pre to_of_val. - iMod "H" as ">H"; iModIntro. - iExists _, _. - rewrite !wp_unfold /wp_pre to_of_val. - eauto with iFrame. -Qed. - -Lemma wp_stutteringatomic_take_step - s E1 E2 ζ e Φ - `{!AllowsStuttering} - `{!StutteringAtomic (stuckness_to_atomicity s) e} : - TCEq (to_val e) None → - (|={E1,E2}=> - ∀ extr atr c1 δ1 ζ', - ⌜trace_ends_in extr c1⌝ -∗ - ⌜trace_ends_in atr δ1⌝ -∗ - ⌜ζ = ζ'⌝ -∗ - state_interp extr atr ={E2}=∗ - ∃ Q R, - state_interp extr atr ∗ - (∀ c2 δ2 ℓ, - ∃ δ', - state_interp - (trace_extend extr (Some ζ') c2) - (trace_extend atr ℓ δ2) ∗ Q ={E2}=∗ - state_interp - (trace_extend extr (Some ζ') c2) - (trace_extend atr stuttering_label δ') ∗ R) ∗ - (state_interp extr atr ={E2}=∗ state_interp extr atr ∗ Q) ∗ - WP e @ s; ζ; E2 {{ v, R ={E2,E1}=∗ Φ v }}) ⊢ WP e @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros (He) "H". - iLöb as "IH". - rewrite {2}wp_unfold /wp_pre He. - iIntros (extr atr K tp1 tp2 σ1 Hexvalid Hlocale Hexe) "Hsi". - iAssert ((|={E1}=> ⌜match s with - | NotStuck => reducible e σ1 - | MaybeStuck => True - end⌝ ∗ - state_interp extr atr ∗ _)%I) with "[H Hsi]" as - ">(Hnstuck & Hsi & H)". - { iApply fupd_plain_keep_l. - iSplitR; last (iFrame "Hsi"; iExact "H"). - iIntros "[Hsi H]". - iApply fupd_plain_mask. - iMod "H". - iMod ("H" with "[//] [//] [//] Hsi") as (Q R) "[Hsi (_&_&H)]". - rewrite !wp_unfold /wp_pre He. - iMod ("H" with "[] [] [] Hsi") as "[? _]"; done. } - iMod (fupd_mask_intro_subseteq E1 ∅ True%I with "[]") as "Hmsk"; - [set_solver|done|]. - iModIntro. - iSplit; first done. - iIntros (e2 σ2 efs Hstep). - pose proof Hstep as [(?&?&?)|HSA]%stutteringatomic; simplify_eq/=. - - iModIntro; iNext. - iMod (allows_stuttering with "Hsi") as "Hsi"; [done|done|done| |]. - { econstructor 1; [done| |by apply fill_step]; by rewrite app_nil_r. } - iIntros "!>". iApply step_fupdN_intro; [done|]. iIntros "!>". - iMod "Hmsk" as "_"; iModIntro. - rewrite app_nil_r. - iExists (trace_last atr), stuttering_label; iFrame "Hsi". - iSplitL; last done. - iApply "IH"; done. - - iMod "Hmsk" as "_". - iMod ("H" with "[//] [//] [//] Hsi") as ">H". - iDestruct "H" as (Q R) "(Hsi & Hupdate & Htrans & H)". - rewrite (wp_unfold s E2 e) /wp_pre He. - iMod ("Htrans" with "Hsi") as "(Hsi & HQ)". - iMod ("H" with "[//] [//] [//] Hsi") as "[_ H]". - iMod ("H" with "[//]") as "H". iIntros "!>!>". - iMod "H" as "H". iIntros "!>". - iApply (step_fupdN_wand with "[H]"); first by iApply "H". - iIntros "H". - iMod "H" as (δ3 ℓ) "(Hsi & H & Hefs)". - iDestruct ("Hupdate" $! (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2) δ3 ℓ) - as (δ') "Hupdate". - iMod ("Hupdate" with "[$HQ $Hsi]") as "(Hsi & HR)". - destruct s. - + rewrite (wp_unfold _ E2 e2); rewrite /wp_pre. - destruct (to_val e2) as [v2|] eqn:He2. - * iDestruct ("H" with "HR") as ">> H". - iModIntro; iExists _, _; iFrame. - rewrite -(of_to_val _ _ He2) -wp_value'; done. - * iMod ("H" with "[] [] [] Hsi") as "[% _]"; try done. - { iPureIntro. eapply extend_valid_exec; [done|done|]. - econstructor; [done|done|]. - apply fill_step; done. } - { by erewrite locale_fill_step. } - exfalso; simpl in *; eapply not_reducible; eauto. - + simpl in *. - destruct HSA as [v <-%of_to_val]. - iMod (wp_value_inv' with "H HR") as ">H". - iModIntro. iExists _, _. - iFrame "Hsi Hefs". by iApply wp_value'. -Qed. - -Lemma wp_atomic s E1 E2 ζ e Φ - `{!Atomic (stuckness_to_atomicity s) e} : - (|={E1,E2}=> WP e @ s; ζ; E2 {{ v, |={E2,E1}=> Φ v }}) ⊢ WP e @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros "H". - rewrite (wp_unfold s E1 e) /wp_pre. - rewrite !(wp_unfold s E2 e) /wp_pre. - destruct (to_val e) as [v|] eqn:He. - { by iDestruct "H" as ">>> $". } - iIntros (extr atr K tp1 tp2 σ1 Hexvalid Hlocale exe) "Hsi". - iMod "H". - iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". - iModIntro. - iSplit; first by iPureIntro. - iIntros (e2 σ2 efs Hstep). - pose proof (atomic _ _ _ _ Hstep) as Hs; simplify_eq/=. - iMod ("H" with "[//]") as "H". iIntros "!>!>". - iMod "H" as "H". iIntros "!>". - iApply (step_fupdN_wand with "[H]"); first by iApply "H". - iIntros "H". - iMod "H" as (δ2 ℓ) "(Hσ & H & Hefs)". destruct s. - - rewrite !wp_unfold /wp_pre. destruct (to_val e2) as [v2|] eqn:He2. - + iDestruct "H" as ">> H". - iModIntro; iExists _, _. - iFrame. - rewrite !wp_unfold /wp_pre He2; done. - + iMod ("H" with "[] [] [] [$]") as "[H _]"; try done. - { iPureIntro. eapply extend_valid_exec; [done|done|]. - econstructor; [done|done|]. - apply fill_step; done. } - { by erewrite <-locale_fill_step. } - iDestruct "H" as %(? & ? & ? & ?%Hs); done. - - destruct Hs as [v <-%of_to_val]. - rewrite !wp_unfold /wp_pre to_of_val. - iMod "H" as ">H"; iModIntro. - iExists _, _. - rewrite !wp_unfold /wp_pre to_of_val. - eauto with iFrame. -Qed. - -Lemma wp_atomic_take_step - s E1 E2 ζ e Φ - `{!Atomic (stuckness_to_atomicity s) e} : - TCEq (to_val e) None → - (|={E1,E2}=> - ∀ extr atr c1 δ1 ζ', - ⌜trace_ends_in extr c1⌝ -∗ - ⌜trace_ends_in atr δ1⌝ -∗ - ⌜ζ = ζ'⌝ -∗ - state_interp extr atr ={E2}=∗ - ∃ Q R, - state_interp extr atr ∗ - (∀ c2 δ2 ℓ, - ∃ δ' ℓ', - state_interp - (trace_extend extr (Some ζ') c2) - (trace_extend atr ℓ δ2) ∗ Q ={E2}=∗ - state_interp - (trace_extend extr (Some ζ') c2) - (trace_extend atr ℓ' δ') ∗ R) ∗ - (state_interp extr atr ={E2}=∗ state_interp extr atr ∗ Q) ∗ - WP e @ s; ζ; E2 {{ v, R ={E2,E1}=∗ Φ v }}) ⊢ WP e @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros (He) "H". - rewrite wp_unfold /wp_pre He. - iIntros (extr atr K tp1 tp2 σ1 Hexvalid Hlocale Hexe) "Hsi". - iMod ("H" with "[//] [//] [//] Hsi") as ">H". - iDestruct "H" as (Q R) "(Hsi & Hupdate & Htrans & H)". - rewrite (wp_unfold s E2 e) /wp_pre He. - iMod ("Htrans" with "Hsi") as "(Hsi & HQ)". - iMod ("H" with "[//] [//] [//] Hsi") as "[% H]". - iModIntro. - iSplit; first by iPureIntro. - iIntros (e2 σ2 efs Hstep). - pose proof (atomic _ _ _ _ Hstep) as Hs; simplify_eq/=. - iMod ("H" with "[//]") as "H". iIntros "!>!>". - iMod "H" as "H". iIntros "!>". - iApply (step_fupdN_wand with "[H]"); first by iApply "H". - iIntros "H". - iMod "H" as (δ3 ℓ) "(Hsi & H & Hefs)". - iDestruct ("Hupdate" $! (tp1 ++ ectx_fill K e2 :: tp2 ++ efs, σ2) δ3 ℓ) - as (δ' ℓ') "Hupdate". - iMod ("Hupdate" with "[$HQ $Hsi]") as "(Hsi & HR)". - destruct s. - - rewrite (wp_unfold _ E2 e2); rewrite /wp_pre. - destruct (to_val e2) as [v2|] eqn:He2. - + iDestruct ("H" with "HR") as ">> H". - iModIntro; iExists _,_; iFrame. - rewrite -(of_to_val _ _ He2) -wp_value'; done. - + iMod ("H" with "[] [] [] Hsi") as "[% _]"; try done. - { iPureIntro. eapply extend_valid_exec; [done|done|]. - econstructor; [done|done|]. - apply fill_step; done. } - { by erewrite <-locale_fill_step. } - exfalso; simpl in *; eapply not_reducible; eauto. - - simpl in *. - destruct Hs as [v <-%of_to_val]. - iMod (wp_value_inv' with "H HR") as ">H". - iModIntro. iExists _, _. - iFrame "Hsi Hefs". by iApply wp_value'. -Qed. - -(** In this stronger version of [wp_step_fupdN], the masks in the - step-taking fancy update are a bit weird and somewhat difficult to - use in practice. Hence, we prove it for the sake of completeness, - but [wp_step_fupdN] is just a little bit weaker, suffices in - practice and is easier to use. - - See the statement of [wp_step_fupdN] below to understand the use of - ordinary conjunction here. *) -Lemma wp_step_fupdN_strong n s ζ E1 E2 e P Φ : - TCEq (to_val e) None → E2 ⊆ E1 → - (∀ extr atr, state_interp extr atr - ={E1,∅}=∗ ⌜n ≤ S (trace_length extr)⌝) ∧ - ((|={E1,E2}=> |={∅}▷=>^n |={E2,E1}=> P) ∗ - WP e @ s; ζ; E2 {{ v, P ={E1}=∗ Φ v }}) -∗ - WP e @ s; ζ; E1 {{ Φ }}. -Proof. - destruct n as [|n]. - { iIntros (_ ?) "/= [_ [HP Hwp]]". - iApply (wp_strong_mono with "Hwp"); [done..|]. - iIntros (v) "H". iApply ("H" with "[>HP]"). by do 2 iMod "HP". } - rewrite !wp_unfold /wp_pre /=. iIntros (-> ?) "H". - iIntros (extr atr K tp1 tp2 σ1 Hexvalid Hlocale Hexe) "Hσ". - destruct (decide (n ≤ trace_length extr)) as [Hn|Hn]; first last. - { iDestruct "H" as "[Hn _]". iMod ("Hn" with "Hσ") as %?. lia. } - iDestruct "H" as "[_ [>HP Hwp]]". - iMod ("Hwp" with "[//] [//] [//] [$]") as "[$ H]". iMod "HP". - iIntros "!>" (e2 σ2 efs Hstep). iMod ("H" $! e2 σ2 efs with "[% //]") as "H". - iIntros "!>!>". iMod "H". iMod "HP". iModIntro. - revert n Hn. generalize (trace_length extr)=>n0 n Hn. - iInduction n as [|n] "IH" forall (n0 Hn). - - iApply (step_fupdN_wand with "H"). - iIntros "H". iMod "H" as "H". iDestruct "H" as (δ2 ℓ) "(Hσ & Hwp & Hwp')". - iMod "HP". iModIntro. iExists _, _. iFrame "Hσ Hwp'". - iApply (wp_strong_mono with "Hwp"); [done|set_solver|]. - iIntros (v) "HΦ". iApply ("HΦ" with "HP"). - - destruct n0 as [|n0]; [lia|]=>/=. iMod "HP". iMod "H". iIntros "!> !>". - iMod "HP". iMod "H". iModIntro. iApply ("IH" with "[] HP H"). - auto with lia. -Qed. - -Lemma wp_step_fupdN n s ζ E1 E2 e P Φ : - TCEq (to_val e) None → E2 ⊆ E1 → - (∀ extr atr, state_interp extr atr - ={E1,∅}=∗ ⌜n ≤ S (trace_length extr)⌝) ∧ - ((|={E1∖E2,∅}=> |={∅}▷=>^n |={∅,E1∖E2}=> P) ∗ - WP e @ s; ζ; E2 {{ v, P ={E1}=∗ Φ v }}) -∗ - WP e @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros (??) "H". iApply (wp_step_fupdN_strong with "[H]"); [done|]. - iApply (bi.and_mono_r with "H"). apply bi.sep_mono_l. iIntros "HP". - iMod fupd_mask_subseteq_emptyset_difference as "H"; [|iMod "HP"]; [set_solver|]. - iMod "H" as "_". replace (E1 ∖ (E1 ∖ E2)) with E2; last first. - { set_unfold=>x. destruct (decide (x ∈ E2)); naive_solver. } - iModIntro. iApply (step_fupdN_wand with "HP"). iIntros "H". - iApply fupd_mask_frame; [|iMod "H"; iModIntro]; [set_solver|]. - by rewrite difference_empty_L (comm_L (∪)) -union_difference_L. -Qed. -Lemma wp_step_fupd s E1 E2 ζ e P Φ : - TCEq (to_val e) None → E2 ⊆ E1 → - (|={E1}[E2]▷=> P) -∗ WP e @ s; ζ; E2 {{ v, P ={E1}=∗ Φ v }} -∗ WP e @ s; ζ; E1 {{ Φ }}. -Proof. - iIntros (??) "HR H". - iApply (wp_step_fupdN_strong 1 _ _ E1 E2 with "[-]"); [done|..]. iSplit. - - iIntros (??) "_". iMod (fupd_mask_subseteq ∅) as "_"; [set_solver+|]. - auto with lia. - - iFrame "H". iMod "HR" as "$". auto. -Qed. - -Lemma wp_bind K s E ζ e Φ : - WP e @ s; ζ; E {{ v, WP ectx_fill K (of_val v) @ s; ζ; E {{ Φ }} }} ⊢ - WP ectx_fill K e @ s; ζ; E {{ Φ }}. -Proof. - iIntros "H". iLöb as "IH" forall (E e ζ Φ). rewrite wp_unfold /wp_pre. - destruct (to_val e) as [v|] eqn:He. - { apply of_to_val in He as <-. by iApply fupd_wp. } - rewrite wp_unfold /wp_pre fill_not_val; last done. - iIntros (extr atr K' tp1 tp2 σ1 Hexvalid Hlocale Hexe) "Hsi". - iMod ("H" $! _ _ (ectx_comp K' K) with "[//] [] [] [$]") as "[% H]". - { rewrite ectx_comp_comp; done. } - { rewrite ectx_comp_comp; done. } - iModIntro; iSplit. - { iPureIntro. destruct s; first apply reducible_fill; done. } - iIntros (e2 σ2 efs Hstep). - destruct (fill_step_inv K e σ1 e2 σ2 efs) as (e2'&->&?); - [done|done|]. - iMod ("H" with "[//]") as "H". iIntros "!>!>". - iMod "H" as "H". iIntros "!>". - iApply (step_fupdN_wand with "[H]"); first by iApply "H". - iIntros "H". - iMod "H" as (δ2 ℓ) "(Hσ & H & Hefs)". - rewrite !ectx_comp_comp. - iModIntro; iExists δ2, ℓ. - iFrame "Hefs Hσ". by iApply "IH". -Qed. - -(** * Derived rules *) -Lemma wp_mono s E ζ e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → WP e @ s; ζ; E {{ Φ }} ⊢ WP e @ s; ζ; E {{ Ψ }}. -Proof. - iIntros (HΦ) "H"; iApply (wp_strong_mono with "H"); auto. - iIntros (v) "?". by iApply HΦ. -Qed. -Lemma wp_stuck_mono s1 s2 E ζ e Φ : - s1 ⊑ s2 → WP e @ s1; ζ; E {{ Φ }} ⊢ WP e @ s2; ζ; E {{ Φ }}. -Proof. iIntros (?) "H". iApply (wp_strong_mono with "H"); auto. Qed. -Lemma wp_stuck_weaken s E ζ e Φ : - WP e @ s; ζ; E {{ Φ }} ⊢ WP e @ ζ; E ?{{ Φ }}. -Proof. apply wp_stuck_mono. by destruct s. Qed. -Lemma wp_mask_mono s E1 E2 ζ e Φ : E1 ⊆ E2 → WP e @ s; ζ; E1 {{ Φ }} ⊢ WP e @ s; ζ; E2 {{ Φ }}. -Proof. iIntros (?) "H"; iApply (wp_strong_mono with "H"); auto. Qed. -#[global] Instance wp_mono' s E ζ e : - Proper (pointwise_relation _ (⊢) ==> (⊢)) (wp (PROP:=iProp Σ) s E ζ e). -Proof. by intros Φ Φ' ?; apply wp_mono. Qed. -#[global] Instance wp_flip_mono' s E ζ e : - Proper (pointwise_relation _ (flip (⊢)) ==> (flip (⊢))) (wp (PROP:=iProp Σ) s E ζ e). -Proof. by intros Φ Φ' ?; apply wp_mono. Qed. - -Lemma wp_value s E Φ ζ e v : IntoVal e v → Φ v ⊢ WP e @ s; ζ; E {{ Φ }}. -Proof. intros <-. by apply wp_value'. Qed. -Lemma wp_value_fupd' s E ζ Φ v : (|={E}=> Φ v) ⊢ WP of_val v @ s; ζ; E {{ Φ }}. -Proof. intros. by rewrite -wp_fupd -wp_value'. Qed. -Lemma wp_value_fupd s E Φ ζ e v `{!IntoVal e v} : - (|={E}=> Φ v) ⊢ WP e @ s; ζ; E {{ Φ }}. -Proof. intros. rewrite -wp_fupd -wp_value //. Qed. -Lemma wp_value_inv s E Φ ζ e v : IntoVal e v → WP e @ s; ζ; E {{ Φ }} ={E}=∗ Φ v. -Proof. intros <-. by apply wp_value_inv'. Qed. - -Lemma wp_frame_l s E ζ e Φ R : R ∗ WP e @ s; ζ; E {{ Φ }} ⊢ WP e @ s; ζ; E {{ v, R ∗ Φ v }}. -Proof. iIntros "[? H]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed. -Lemma wp_frame_r s E ζ e Φ R : WP e @ s; ζ; E {{ Φ }} ∗ R ⊢ WP e @ s; ζ; E {{ v, Φ v ∗ R }}. -Proof. iIntros "[H ?]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed. - -Lemma wp_frame_step_l s E1 E2 ζ e Φ R : - TCEq (to_val e) None → E2 ⊆ E1 → - (|={E1}[E2]▷=> R) ∗ WP e @ s; ζ; E2 {{ Φ }} ⊢ WP e @ s; ζ; E1 {{ v, R ∗ Φ v }}. -Proof. - iIntros (??) "[Hu Hwp]". iApply (wp_step_fupd with "Hu"); try done. - iApply (wp_mono with "Hwp"). by iIntros (?) "$$". -Qed. -Lemma wp_frame_step_r s E1 E2 ζ e Φ R : - TCEq (to_val e) None → E2 ⊆ E1 → - WP e @ s; ζ; E2 {{ Φ }} ∗ (|={E1}[E2]▷=> R) ⊢ WP e @ s; ζ; E1 {{ v, Φ v ∗ R }}. -Proof. - rewrite [(WP _ @ _; _; _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). - apply wp_frame_step_l. -Qed. -Lemma wp_frame_step_l' s E ζ e Φ R : - TCEq (to_val e) None → ▷ R ∗ WP e @ s; ζ; E {{ Φ }} ⊢ WP e @ s; ζ; E {{ v, R ∗ Φ v }}. -Proof. iIntros (?) "[??]". iApply (wp_frame_step_l s E E); try iFrame; eauto. Qed. -Lemma wp_frame_step_r' s E ζ e Φ R : - TCEq (to_val e) None → WP e @ s; ζ; E {{ Φ }} ∗ ▷ R ⊢ WP e @ s; ζ; E {{ v, Φ v ∗ R }}. -Proof. iIntros (?) "[??]". iApply (wp_frame_step_r s E E); try iFrame; eauto. Qed. - -Lemma wp_wand s E ζ e Φ Ψ : - WP e @ s; ζ; E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; ζ; E {{ Ψ }}. -Proof. - iIntros "Hwp H". iApply (wp_strong_mono with "Hwp"); auto. - iIntros (?) "?". by iApply "H". -Qed. -Lemma wp_wand_l s E ζ e Φ Ψ : - (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s; ζ; E {{ Φ }} ⊢ WP e @ s; ζ; E {{ Ψ }}. -Proof. iIntros "[H Hwp]". iApply (wp_wand with "Hwp H"). Qed. -Lemma wp_wand_r s E ζ e Φ Ψ : - WP e @ s; ζ; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @ s; ζ; E {{ Ψ }}. -Proof. iIntros "[Hwp H]". iApply (wp_wand with "Hwp H"). Qed. -Lemma wp_frame_wand_l s E ζ e Q Φ : - Q ∗ WP e @ s; ζ; E {{ v, Q -∗ Φ v }} -∗ WP e @ s; ζ; E {{ Φ }}. -Proof. - iIntros "[HQ HWP]". iApply (wp_wand with "HWP"). - iIntros (v) "HΦ". by iApply "HΦ". -Qed. - -End wp. - -#[global] Arguments AllowsStuttering {_} _ _ {_}. -#[global] Arguments AllowsPureStep {_} _ _ {_}. - -(** Proofmode class instances *) -Section proofmode_classes. - Context `{!irisG Λ AS Σ}. - Implicit Types P Q : iProp Σ. - Implicit Types Φ : val Λ → iProp Σ. - - #[global] Instance frame_wp p s E ζ e R Φ Ψ : - (∀ v, Frame p R (Φ v) (Ψ v)) → - Frame p R (WP e @ s; ζ; E {{ Φ }}) (WP e @ s; ζ; E {{ Ψ }}). - Proof. rewrite /Frame=> HR. rewrite wp_frame_l. apply wp_mono, HR. Qed. - - #[global] Instance is_except_0_wp s E ζ e Φ : IsExcept0 (WP e @ s; ζ; E {{ Φ }}). - Proof. by rewrite /IsExcept0 -{2}fupd_wp -except_0_fupd -fupd_intro. Qed. - - #[global] Instance elim_modal_bupd_wp p s E ζ e P Φ : - ElimModal True p false (|==> P) P (WP e @ s; ζ; E {{ Φ }}) (WP e @ s; ζ; E {{ Φ }}). - Proof. - by rewrite /ElimModal bi.intuitionistically_if_elim - (bupd_fupd E) fupd_frame_r bi.wand_elim_r fupd_wp. - Qed. - - #[global] Instance elim_modal_fupd_wp p s E ζ e P Φ : - ElimModal True p false (|={E}=> P) P (WP e @ s; ζ; E {{ Φ }}) (WP e @ s; ζ; E {{ Φ }}). - Proof. - by rewrite /ElimModal bi.intuitionistically_if_elim - fupd_frame_r bi.wand_elim_r fupd_wp. - Qed. - - #[global] Instance elim_modal_fupd_wp_stutteringatomic p s E1 E2 ζ e P Φ : - AllowsStuttering AS Σ → - StutteringAtomic (stuckness_to_atomicity s) e → - ElimModal True p false (|={E1,E2}=> P) P - (WP e @ s; ζ; E1 {{ Φ }}) (WP e @ s; ζ; E2 {{ v, |={E2,E1}=> Φ v }})%I. - Proof. - intros. by rewrite /ElimModal bi.intuitionistically_if_elim - fupd_frame_r bi.wand_elim_r wp_stuttering_atomic. - Qed. - - #[global] Instance add_modal_fupd_wp s E ζ e P Φ : - AddModal (|={E}=> P) P (WP e @ s; ζ; E {{ Φ }}). - Proof. by rewrite /AddModal fupd_frame_r bi.wand_elim_r fupd_wp. Qed. - - #[global] Instance elim_acc_wp_stuttering {X} E1 E2 ζ α β γ e s Φ : - AllowsStuttering AS Σ → - StutteringAtomic (stuckness_to_atomicity s) e → - ElimAcc (X:=X) True (fupd E1 E2) (fupd E2 E1) - α β γ (WP e @ s; ζ; E1 {{ Φ }}) - (λ x, WP e @ s; ζ; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I. - Proof. - intros ? ? _. - iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". - iApply (wp_wand with "(Hinner Hα)"). - iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose". - Qed. - - #[global] Instance elim_modal_fupd_wp_atomic p s E1 E2 ζ e P Φ : - Atomic (stuckness_to_atomicity s) e → - ElimModal True p false (|={E1,E2}=> P) P - (WP e @ s; ζ; E1 {{ Φ }}) (WP e @ s; ζ; E2 {{ v, |={E2,E1}=> Φ v }})%I. - Proof. - intros. by rewrite /ElimModal bi.intuitionistically_if_elim - fupd_frame_r bi.wand_elim_r wp_atomic. - Qed. - - #[global] Instance elim_acc_wp_atomic {X} E1 E2 ζ α β γ e s Φ : - Atomic (stuckness_to_atomicity s) e → - ElimAcc (X:=X) True (fupd E1 E2) (fupd E2 E1) - α β γ (WP e @ s; ζ; E1 {{ Φ }}) - (λ x, WP e @ s; ζ; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I. - Proof. - intros ? _. - iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". - iApply (wp_wand with "(Hinner Hα)"). - iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose". - Qed. - - #[global] Instance elim_acc_wp_nonatomic {X} E ζ α β γ e s Φ : - ElimAcc (X:=X) True (fupd E E) (fupd E E) - α β γ (WP e @ s; ζ; E {{ Φ }}) - (λ x, WP e @ s; ζ; E {{ v, |={E}=> β x ∗ (γ x -∗? Φ v) }})%I. - Proof. - rewrite /ElimAcc. - iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". - iApply wp_fupd. - iApply (wp_wand with "(Hinner Hα)"). - iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose". - Qed. -End proofmode_classes. diff --git a/trillium/traces/infinite_trace.v b/trillium/traces/infinite_trace.v deleted file mode 100644 index 6b426a10..00000000 --- a/trillium/traces/infinite_trace.v +++ /dev/null @@ -1,164 +0,0 @@ -From Coq.ssr Require Import ssreflect. -From stdpp Require Import prelude. - -Set Default Proof Using "Type". - -Delimit Scope inflist_scope with inflist. - -CoInductive inflist (A : Type) : Type := -| infnil -| infcons (x : A) (il : inflist A). - -Bind Scope inflist_scope with inflist. - -Arguments infnil {_}, _. -Arguments infcons {_} _ _%inflist. - -Module InfListNotations. -Notation "[ ]" := infnil (format "[ ]") : inflist_scope. -Notation "[ x ]" := (infcons x infnil) : inflist_scope. -Notation "[ x ; y ; .. ; z ]" := - (infcons x (infcons y .. (infcons z nil) ..)) : inflist_scope. - -Infix "::" := infcons (at level 60, right associativity) : inflist_scope. -End InfListNotations. - -Import InfListNotations. - -Section inflist. - Context {A : Type}. - - Implicit Types il : inflist A. - - Lemma inflist_unfold_fold il : - il = match il with - | [] => [] - | a :: il' => a :: il' - end%inflist. - Proof. destruct il; trivial. Qed. - - Fixpoint inflist_take (n : nat) (il : inflist A) : list A := - match n with - | O => [] - | S n' => - match il with - | []%inflist => [] - | (a :: il')%inflist => a :: inflist_take n' il' - end - end. - - Fixpoint inflist_drop (n : nat) (il : inflist A) : inflist A := - match n with - | O => il - | S n' => - match il with - | []%inflist => [] - | (a :: il')%inflist => inflist_drop n' il' - end - end. - - Lemma inflist_take_add n m il : - inflist_take (n + m) il = inflist_take n il ++ (inflist_take m (inflist_drop n il)). - Proof. - revert m il; induction n; intros m il; first done. - destruct il; simpl; first by destruct m. - rewrite IHn //. - Qed. - - Lemma inflist_drop_add n m il : inflist_drop (n + m) il = (inflist_drop n (inflist_drop m il)). - Proof. - revert n il; induction m as [|m IHm]; intros n il. - { rewrite /= Nat.add_0_r //. } - rewrite Nat.add_succ_r /=. - destruct il; last done. - destruct n; done. - Qed. - -End inflist. - -Definition inflist_same_length {A B} (il : inflist A) (il' : inflist B) : Prop := - (∀ n, (inflist_drop n il) = [] ↔ (inflist_drop n il') = [])%inflist. - -Lemma inflist_same_length_refl {A} (il : inflist A) : inflist_same_length il il. -Proof. done. Qed. - -Lemma inflist_same_length_sym {A B} (il : inflist A) (il' : inflist B) : - inflist_same_length il il' → inflist_same_length il' il. -Proof. firstorder. Qed. - -Lemma inflist_same_length_trans {A B C} (il : inflist A) (il' : inflist B) (il'' : inflist C) : - inflist_same_length il il' → inflist_same_length il' il'' → inflist_same_length il il''. -Proof. firstorder. Qed. - -Lemma inflist_same_length_nil {A B}: inflist_same_length (@infnil A) (@infnil B). -Proof. intros []; done. Qed. - -Lemma inflist_same_length_nil_inv_l {A B} (x : B) (il : inflist B) : - ¬ inflist_same_length (@infnil A) (x :: il). -Proof. intros Heq; specialize (Heq 0) as [Heq _]; specialize (Heq eq_refl); done. Qed. -Lemma inflist_same_length_nil_inv_r {A B} (x : A) (il : inflist A) : - ¬ inflist_same_length (x :: il) (@infnil B). -Proof. intros Heq; specialize (Heq 0) as [_ Heq]; specialize (Heq eq_refl); done. Qed. - -Lemma inflist_same_length_cons {A B} (x : A) (il : inflist A) (y : B) (il' : inflist B) : - inflist_same_length (x :: il) (y :: il') ↔ inflist_same_length il il'. -Proof. - split. - - by intros Heq n; specialize (Heq (S n)). - - by intros Heq []; simpl; last apply Heq. -Qed. - -Lemma inflist_same_length_drop n {A B} (il : inflist A) (il' : inflist B): - inflist_same_length il il' → inflist_same_length (inflist_drop n il) (inflist_drop n il'). -Proof. rewrite /inflist_same_length; intros Hsl k; rewrite -!inflist_drop_add; auto. Qed. - -Global Hint Extern 0 => -match goal with -| H : inflist_same_length []%inflist (_ :: _)%inflist |- _ => - apply inflist_same_length_nil_inv_l in H; contradiction -| H : inflist_same_length (_ :: _)%inflist []%inflist |- _ => - let Hf := fresh "H" in - apply inflist_same_length_nil_inv_r in H; contradiction -end : core. - -Global Instance ilist_fmap : FMap inflist := - λ A B f, cofix go (il : inflist A) := - match il with - | [] => [] - | x :: il' => f x :: go il' - end%inflist. - -Section inflist_fmap. - Context {A B} (f : A → B). - - Lemma inflist_fmap_length (il : inflist A) : inflist_same_length il (f <$> il). - Proof. - intros n; revert il; induction n; intros il. - - rewrite (inflist_unfold_fold (f <$> il)). - destruct il; done. - - destruct il; simpl; done. - Qed. - - Lemma inflist_fmap_cons_inv (il : inflist A) (b : B) (il' : inflist B) : - f <$> il = (b :: il')%inflist → ∃ a il'', il = (a :: il'')%inflist ∧ b = f a ∧ il' = f <$> il''. - Proof. - rewrite (inflist_unfold_fold (f <$> il)). - destruct il; simpl; first done. - intros ?; simplify_eq; eauto. - Qed. - -End inflist_fmap. - -Lemma inflist_take_of_same_length k {A B} (il : inflist A) (il' : inflist B) : - inflist_same_length il il' → - length (inflist_take k il) = length (inflist_take k il'). -Proof. - revert il il'. - induction k as [|k IHk]; simpl; first done. - intros il il' Hsl. - destruct il as [|a il]; destruct il' as [|a' il']; - [done|by apply inflist_same_length_nil_inv_l in Hsl| - by apply inflist_same_length_nil_inv_r in Hsl|]. - rewrite /= (IHk il il'); last done. - rewrite -> inflist_same_length_cons in Hsl; done. -Qed. diff --git a/trillium/traces/trace.v b/trillium/traces/trace.v deleted file mode 100644 index 3b677e7b..00000000 --- a/trillium/traces/trace.v +++ /dev/null @@ -1,859 +0,0 @@ -From trillium.prelude Require Export fixpoint classical. -Require Import iris.prelude.prelude. - -Set Default Proof Using "Type". - -Inductive finite_trace (A : Type) (L : Type) : Type := -| trace_singleton (a : A) -| trace_extend (ft : finite_trace A L) (l : L) (a : A). - -Global Arguments trace_singleton {_ _} _. -Global Arguments trace_extend {_ _} _ _ _. - -Notation "'{tr[' a ]}" := (trace_singleton a) (at level 1, format "{tr[ a ]}"). -Notation "t ':tr[' l ']:' a" := (trace_extend t l a) (at level 60). - -Section finite_trace. - Context {A L : Type}. - - Implicit Types a : A. - Implicit Types ft : finite_trace A L. - Implicit Types l : list (L * A). - - Fixpoint trace_first (ft : finite_trace A L) : A := - match ft with - | {tr[a]} => a - | ft' :tr[_]: _ => trace_first ft' - end. - - Definition trace_last (ft : finite_trace A L) : A := - match ft with - | {tr[a]} => a - | _ :tr[_]: a => a - end. - - Definition trace_starts_in (ft : finite_trace A L) (a : A) : Prop := - trace_first ft = a. - - Definition trace_ends_in (ft : finite_trace A L) (a : A) : Prop := - trace_last ft = a. - - Fixpoint trace_append_list (ft : finite_trace A L) (l : list (L * A)) : finite_trace A L := - match l with - | [] => ft - | (ℓ, a) :: l' => trace_append_list (ft :tr[ℓ]: a) l' - end. - - Infix "+trl+" := trace_append_list (at level 60). - - Definition trace_prefix (ft ft' : finite_trace A L) : Prop := - ∃ l, ft' = ft +trl+ l. - - Infix "`trace_prefix_of`" := trace_prefix (at level 70). - - (** instance and properties *) - - Lemma trace_starts_in_first ft : trace_starts_in ft (trace_first ft). - Proof. done. Qed. - - Lemma trace_ends_in_last ft : trace_ends_in ft (trace_last ft). - Proof. done. Qed. - - Lemma first_eq_trace_starts_in ft a : trace_starts_in ft a → trace_first ft = a. - Proof. done. Qed. - - Lemma last_eq_trace_ends_in ft a: trace_ends_in ft a → trace_last ft = a. - Proof. done. Qed. - - Lemma trace_singleton_starts_in c : trace_starts_in {tr[c]} c. - Proof. done. Qed. - - Lemma trace_singleton_starts_in_inv c c' : - trace_starts_in {tr[c']} c → c' = c. - Proof. by inversion 1. Qed. - - Lemma trace_singleton_ends_in c : trace_ends_in {tr[c]} c. - Proof. done. Qed. - - Lemma trace_singleton_ends_in_inv c c' : - trace_ends_in {tr[c']} c → c' = c. - Proof. by inversion 1. Qed. - - Lemma trace_starts_in_inj ft c c' : - trace_starts_in ft c → trace_starts_in ft c' → c = c'. - Proof. rewrite /trace_starts_in; intros ->; done. Qed. - - Lemma trace_ends_in_inj ft c c' : - trace_ends_in ft c → trace_ends_in ft c' → c = c'. - Proof. rewrite /trace_ends_in; intros ->; done. Qed. - - Definition trace_contract (ft: finite_trace A L) ℓ ft' : Prop := - ∃ a, ft = ft' :tr[ℓ]: a. - - Lemma trace_contract_of_extend ft ℓ a ft' ℓ' : - trace_contract (ft :tr[ℓ]: a) ℓ' ft' → ft' = ft ∧ ℓ = ℓ'. - Proof. intros (? & Heq); simplify_eq; done. Qed. - - Lemma not_trace_contract_singleton a ft ℓ: - ¬ trace_contract {tr[a]} ℓ ft. - Proof. intros (?&?); destruct ft; simplify_eq/=. Qed. - - Lemma trace_extend_starts_in ft a' ℓ a : - trace_starts_in ft a' → trace_starts_in (ft :tr[ℓ]: a) a'. - Proof. induction ft; auto. Qed. - - Lemma trace_extend_starts_in_inv ft a' ℓ a : - trace_starts_in (ft :tr[ℓ]: a) a' → trace_starts_in ft a'. - Proof. induction ft; auto. Qed. - - Lemma trace_extend_ends_in ft c ℓ : trace_ends_in (ft :tr[ℓ]: c) c. - Proof. done. Qed. - - Lemma trace_does_end_in ft : ∃ a, trace_ends_in ft a. - Proof. destruct ft; rewrite /trace_ends_in; eauto. Qed. - - Lemma trace_extend_neq_singleton ft a a' ℓ : ¬ ft :tr[ℓ]: a = {tr[ a' ]}. - Proof. inversion 1. Qed. - - Lemma trace_prefix_append ft ft' : - ft `trace_prefix_of` ft' → ∃ l, ft' = ft +trl+ l. - Proof. done. Qed. - - Global Instance finite_trace_eq_dec `{!EqDecision A, EqDecision L} : - EqDecision (finite_trace A L). - Proof. - intros ft ft'; rewrite /Decision. - decide equality; try apply (_ : EqDecision A); apply (_ : EqDecision L). - Qed. - - Lemma trace_append_list_assoc ft l l' : - (ft +trl+ l) +trl+ l' = ft +trl+ (l ++ l'). - Proof. - revert ft l'; induction l as [|[ℓ a] l IHl]; first done. - intros ft l'; rewrite /= IHl; done. - Qed. - - Lemma trace_appned_list_eq_singleton_inv ft l a: - ft +trl+ l = {tr[a]} → ft = {tr[a]} ∧ l = []. - Proof. - intros Hl. - revert ft Hl; induction l as [|[? b] l IHl]; first done. - simpl; intros ft [Hft ?]%IHl. - destruct ft; apply trace_extend_neq_singleton in Hft; done. - Qed. - - Lemma trace_append_list_snoc ft l ℓ a : ft +trl+ (l ++ [(ℓ, a)]) = (ft +trl+ l) :tr[ℓ]: a. - Proof. rewrite -trace_append_list_assoc; done. Qed. - - Lemma trace_extend_eq_trace_append_list ft ft' l ℓ a : - ft :tr[ℓ]: a = ft' +trl+ l → (ft' = ft :tr[ℓ]: a ∧ l = []) ∨ (∃ l', l = l' ++ [(ℓ, a)]). - Proof. - revert ft a ft'. - induction l as [|[? b] l IHl] using rev_ind; intros ft a ft'; first by left. - rewrite trace_append_list_snoc. - intros; simplify_eq; eauto. - Qed. - - Lemma trace_append_list_eq_self_inv ft l: ft = ft +trl+ l → l = []. - Proof. - revert l; induction ft as [|ft IHft ℓ a]; intros l Hft. - - symmetry in Hft. - apply trace_appned_list_eq_singleton_inv in Hft as [_ ?]; done. - - edestruct trace_extend_eq_trace_append_list as [[]|[l' Hl']]; - [done|done|]. - rewrite Hl' -trace_append_list_assoc /= in Hft. - simplify_eq. - apply (IHft ((ℓ, a) :: l')) in Hft; done. - Qed. - - Global Instance trace_prefix_equivalence : PartialOrder trace_prefix. - Proof. - split; first split. - - intros ft; exists []; done. - - intros ft ft' ft'' [l ->] [l' ->]. - exists (l ++ l'); rewrite trace_append_list_assoc; done. - - intros ft ft' [l Hl] [l' Hl']. - rewrite Hl trace_append_list_assoc in Hl'. - apply trace_append_list_eq_self_inv in Hl'. - destruct l; done. - Qed. - - Lemma trace_prefix_antisym ft ft' : - ft `trace_prefix_of` ft' → ft' `trace_prefix_of` ft → ft = ft'. - Proof. intros; eapply (anti_symm_iff (R := trace_prefix)); done. Qed. - - Lemma trace_append_list_first ft l : trace_first (ft +trl+ l) = trace_first ft. - Proof. - revert ft; induction l as [|[? a] l IHl]; intros ft; [|rewrite /= IHl]; done. - Qed. - - Lemma trace_prefix_eq_firsts ft ft': - ft `trace_prefix_of` ft' → trace_first ft = trace_first ft'. - Proof. intros [? ->]. rewrite trace_append_list_first; done. Qed. - - Lemma trace_prefix_of_singleton ft a: - trace_starts_in ft a → {tr[a]} `trace_prefix_of` ft. - Proof. - induction ft as [|ft IHft ℓ b]. - - intros ->; reflexivity. - - intros Hfta%trace_extend_starts_in_inv. - apply IHft in Hfta as [l Hl]. - exists (l ++ [(ℓ, b)]); rewrite -trace_append_list_assoc Hl; done. - Qed. - - Lemma trace_prefix_trace_append ft ft' l : - ft `trace_prefix_of` ft' → ft `trace_prefix_of` ft' +trl+ l. - Proof. - intros [l' ->]; exists (l' ++ l); rewrite trace_append_list_assoc; done. - Qed. - - Lemma trace_prefix_trace_extend ft ft' ℓ a : - ft `trace_prefix_of` ft' → ft `trace_prefix_of` ft' :tr[ℓ]: a. - Proof. - intros [l ->]; exists (l ++ [(ℓ, a)]); rewrite -trace_append_list_assoc; done. - Qed. - - Lemma trace_append_prefix ft ft' l : - ft +trl+ l `trace_prefix_of` ft' → ft `trace_prefix_of` ft'. - Proof. - intros [l' ->]; exists (l ++ l'); rewrite trace_append_list_assoc; done. - Qed. - - Lemma trace_extend_prefix ft ft' ℓ a : - ft :tr[ℓ]: a `trace_prefix_of` ft' → ft `trace_prefix_of` ft'. - Proof. intros [l ->]; exists ((ℓ, a) :: l); done. Qed. - - Lemma trace_prefix_of_singleton_inv ft a: - ft `trace_prefix_of` {tr[a]} → ft = {tr[a]}. - Proof. intros []; eapply trace_appned_list_eq_singleton_inv; done. Qed. - - Lemma trace_prefix_of_extend ft ft' ℓ a : - ft `trace_prefix_of` ft' :tr[ℓ]: a → ft = ft' :tr[ℓ]: a ∨ ft `trace_prefix_of` ft'. - Proof. - intros [l Hl]. - edestruct trace_extend_eq_trace_append_list as [[? ?]|[l' Hl']]; - [done|eauto|]. - rewrite Hl' trace_append_list_snoc in Hl; simplify_eq. - right; apply trace_prefix_trace_append; done. - Qed. - - Global Instance trace_prefix_dec `{!EqDecision A, EqDecision L} : - RelDecision trace_prefix. - Proof. - intros ft ft'. - revert ft; induction ft' as [a'|ft' IHft' ℓ' a']; intros ft. - - destruct ft as [a|ft ℓ a]. - + destruct (decide (a = a')) as [->|]; first by left. - right; intros Hpf%trace_prefix_eq_firsts; done. - + right; intros Hft%trace_prefix_of_singleton_inv. - apply trace_extend_neq_singleton in Hft; done. - - destruct (decide (ft `trace_prefix_of` ft')) as [|Hnpf]. - + left; by apply trace_prefix_trace_extend. - + destruct (decide (ft = ft' :tr[ℓ']: a')) as [->|]; first by left. - right; intros [|]%trace_prefix_of_extend; done. - Qed. - - Lemma trace_prefixes_related ft ft' ft'' : - ft `trace_prefix_of` ft'' → ft' `trace_prefix_of` ft'' → - ft `trace_prefix_of` ft' ∨ ft' `trace_prefix_of` ft. - Proof. - intros [l Hl] [l' Hl']. - rewrite Hl in Hl'. - clear Hl ft''. - revert ft ft' l' Hl'. - induction l as [|[ℓ a] l IHl]; simpl. - - intros ??? ->; right; apply trace_prefix_trace_append; done. - - intros ft ft' l' [Hpf|Hpf]%IHl. - + left; eapply trace_extend_prefix; done. - + apply trace_prefix_of_extend in Hpf as [->|]; [left|by right]. - apply trace_prefix_trace_extend; done. - Qed. - - Lemma trace_last_of_append_list ft l oζ: - exists oζ', - ((oζ, trace_last ft) :: l) !! length l = Some (oζ', trace_last (ft +trl+ l)). - Proof. - induction l as [|[a ?] l IHl] using rev_ind; first by eexists. - rewrite app_length /= trace_append_list_snoc /=. - rewrite (lookup_app_r (_ :: _)) /=; last by simpl; lia. - replace (length l + 1 - S (length l)) with 0 by lia. - eexists. done. - Qed. - - Lemma trace_last_of_append_list_map (ft : finite_trace A L) l: - ((trace_last ft) :: map snd l) !! length l = Some (trace_last (ft +trl+ l)). - Proof. - induction l as [|[a ?] l IHl] using rev_ind; first by eexists. - rewrite app_length /= trace_append_list_snoc /=. - rewrite map_app (lookup_app_r (_ :: _)) /=; last by rewrite map_length /=; lia. - rewrite map_length. - replace (length l + 1 - S (length l)) with 0 by lia. - done. - Qed. - - Lemma trace_append_list_inj2 ft l l' : - ft +trl+ l = ft +trl+ l' → l = l'. - Proof. - revert ft l'; induction l as [|[? a] l IHl] using rev_ind; intros ft l' Heq; simpl in *. - - apply trace_append_list_eq_self_inv in Heq; done. - - destruct l' as [|[? a'] l' _] using rev_ind; simpl in *. - + symmetry in Heq. - apply (trace_append_list_eq_self_inv) in Heq; done. - + rewrite -!trace_append_list_assoc /= in Heq; simplify_eq. - rewrite (IHl ft l'); auto. - Qed. - -End finite_trace. - -(* Global Instance trace_fmap : FMap finite_trace := *) -(* λ A B f, fix go (ft : finite_trace A) := *) -(* match ft with *) -(* | trace_singleton a => {tr[f a]} *) -(* | trace_extend ft a => go ft :tr: f a *) -(* end. *) - -(* Fixpoint trace_fold {A B} (f : B → A → B) (b : B) (ft : finite_trace A) := *) -(* match ft with *) -(* | {tr[a]} => f b a *) -(* | ft' :tr: a => f (trace_fold f b ft') a *) -(* end. *) - - -Infix "+trl+" := trace_append_list (at level 60). -Infix "`trace_prefix_of`" := trace_prefix (at level 70). - -(* Section fmap. *) -(* Context {A B : Type} (f : A → B). *) -(* Implicit Types ft : finite_trace A. *) - -(* Lemma trace_fmap_compose {C} (g : B → C) ft : *) -(* g ∘ f <$> ft = g <$> (f <$> ft). *) -(* Proof. induction ft; f_equal/=; auto. Qed. *) - -(* Lemma trace_fmap_singleton a : f <$> {tr[a]} = {tr[f a]}. *) -(* Proof. reflexivity. Qed. *) - -(* Lemma trace_fmap_extend a ft : f <$> ft :tr: a = (f <$> ft) :tr: f a. *) -(* Proof. reflexivity. Qed. *) - -(* Lemma trace_fmap_append_list ft l : *) -(* f <$> ft +trl+ l = (f <$> ft) +trl+ (f <$> l). *) -(* Proof. *) -(* revert ft; induction l as [|a l IHl]; [done|]. *) -(* intros ft'; rewrite /= IHl; done. *) -(* Qed. *) - -(* Lemma trace_fmap_first ft : *) -(* trace_first (f <$> ft) = f (trace_first ft). *) -(* Proof. induction ft; [done|]. rewrite /= IHft //. Qed. *) - -(* Lemma trace_fmap_last ft : *) -(* trace_last (f <$> ft) = f (trace_last ft). *) -(* Proof. by destruct ft. Qed. *) - -(* Lemma trace_fmap_starts_in a ft : *) -(* trace_starts_in ft a → trace_starts_in (f <$> ft) (f a). *) -(* Proof. rewrite /trace_starts_in trace_fmap_first. by intros ->. Qed. *) - -(* Lemma trace_fmap_ends_in a ft : *) -(* trace_ends_in ft a → trace_ends_in (f <$> ft) (f a). *) -(* Proof. rewrite /trace_ends_in trace_fmap_last. by intros ->. Qed. *) - -(* Lemma trace_fmap_prefix ft ft' : *) -(* ft `trace_prefix_of` ft' → (f <$> ft) `trace_prefix_of` (f <$> ft'). *) -(* Proof. *) -(* destruct 1 as [l Hl]. *) -(* exists (f <$> l). rewrite Hl. *) -(* apply trace_fmap_append_list. *) -(* Qed. *) - -(* End fmap. *) - -(* Section trace_fold. *) -(* Context {A B : Type}. *) - -(* Implicit Types ft : finite_trace A. *) -(* Implicit Types f : B → A → B. *) - -(* Lemma trace_fold_singleton f b a : trace_fold f b {tr[a]} = f b a. *) -(* Proof. done. Qed. *) - -(* Lemma trace_fold_extend f b ft a : trace_fold f b (ft :tr: a) = f (trace_fold f b ft) a. *) -(* Proof. done. Qed. *) - -(* Lemma trace_fold_append_list f b ft l : *) -(* trace_fold f b (ft +trl+ l) = fold_left f l (trace_fold f b ft). *) -(* Proof. *) -(* induction l as [|a l IHl] using rev_ind; first done. *) -(* rewrite -trace_append_list_assoc fold_left_app /= IHl //. *) -(* Qed. *) - -(* End trace_fold. *) - -(* Section trace_fold. *) -(* Context {A B C : Type}. *) - -(* Implicit Types ft : finite_trace C. *) -(* Implicit Types f : B → A → B. *) -(* Implicit Types G : C → A. *) - -(* Lemma trace_fold_fmap g f b ft : trace_fold f b (g <$> ft) = trace_fold (λ b c, f b (g c)) b ft. *) -(* Proof. *) -(* induction ft as [|ft IHft a]; first done. *) -(* rewrite trace_fmap_extend /= IHft //. *) -(* Qed. *) - -(* End trace_fold. *) - -Inductive trace_steps {A L : Type} (R : A -> L -> A -> Prop) : finite_trace A L → Prop := -| trace_steps_singleton x : trace_steps R {tr[x]} -| trace_steps_step ex x ℓ y : - trace_ends_in ex x → - R x ℓ y → - trace_steps R ex → - trace_steps R (ex :tr[ℓ]: y). - -Inductive trace_steps2 {A B L1 L2 : Type} (R : A → B → L1 -> L2 -> A → B → Prop) : finite_trace A L1 → finite_trace B L2 → Prop := -| trace_steps2_singleton x y : trace_steps2 R {tr[x]} {tr[y]} -| trace_steps2_step ex1 ex2 x1 y1 ℓ1 ℓ2 x2 y2 : - trace_ends_in ex1 x1 → - trace_ends_in ex2 y1 → - R x1 y1 ℓ1 ℓ2 x2 y2 → - trace_steps2 R ex1 ex2 → - trace_steps2 R (ex1 :tr[ℓ1]: x2) (ex2 :tr[ℓ2]: y2). - -Section trace_steps. - Context {A L : Type} (R : A -> L -> A -> Prop). - - Lemma trace_steps_step_inv ex ℓ x: - trace_steps R (ex :tr[ℓ]: x) → - trace_steps R ex ∧ - ∃ y, trace_ends_in ex y ∧ R y ℓ x. - Proof. inversion 1; eauto. Qed. - - Lemma trace_steps_impl (R' : A -> L -> A -> Prop) : - (∀ x ℓ y, R x ℓ y → R' x ℓ y) → ∀ ex, trace_steps R ex → trace_steps R' ex. - Proof. intros HR ex Hex; induction Hex; econstructor; eauto. Qed. - - Lemma trace_steps_rtc x y : - rtc (λ x y, ∃ ℓ, R x ℓ y) x y ↔ ∃ ex, trace_steps R ex ∧ trace_starts_in ex x ∧ trace_ends_in ex y. - Proof. - split. - - apply (rtc_ind_r (λ z, ∃ ex, trace_steps R ex ∧ trace_starts_in ex x ∧ trace_ends_in ex z) x). - + eexists {tr[ _ ]}; split_and!; [constructor|done|done]. - + intros ? ? ? [??] (? & ? & ? & ?). - eexists (_ :tr[_]: _); split_and!; [|done|done]. - econstructor; eauto. - - intros (ex & Hex & Hex1 & Hex2). - revert x y Hex1 Hex2; induction Hex as [|? ? ? ? ? ? IHex IH]; intros z w Hex1 Hex2. - + inversion Hex1; simplify_eq. - inversion Hex2; simplify_eq. - econstructor. - + inversion Hex1; simplify_eq. - inversion Hex2; simplify_eq. - eapply rtc_r; last by eexists. - apply IH; done. - Qed. - - Lemma trace_steps_rtc_1 x y : - rtc (λ x y, ∃ ℓ, R x ℓ y) x y → ∃ ex, trace_steps R ex ∧ trace_starts_in ex x ∧ trace_ends_in ex y. - Proof. intros ?. by eapply trace_steps_rtc. Qed. - - Lemma trace_steps_rtc_2 ex : - trace_steps R ex → rtc (λ x y, ∃ ℓ, R x ℓ y) (trace_first ex) (trace_last ex). - Proof. intros ?. eapply trace_steps_rtc. eexists; done. Qed. -End trace_steps. - -Section traces_step_binary. - Context {A L : Type} (R : A -> A -> Prop). - - Notation Rb := (λ x (_ : L) y, R x y). - - Lemma trace_steps_step_inv_bin ex x ℓ: - trace_steps Rb (ex :tr[ℓ]: x) → - trace_steps Rb ex ∧ - ∃ y, trace_ends_in ex y ∧ R y x. - Proof. inversion 1; eauto. Qed. - - Lemma trace_steps_impl_bin (R' : relation A) : - (∀ x y, R x y → R' x y) → ∀ (ex : finite_trace A L), trace_steps (λ x _ y, R x y) ex → trace_steps (λ x _ y, R' x y) ex. - Proof. intros HR ex Hex; induction Hex; econstructor; eauto. Qed. - - Lemma trace_steps_rtc_bin `{Inhabited L} x y : - rtc R x y ↔ ∃ ex, trace_steps Rb ex ∧ trace_starts_in ex x ∧ trace_ends_in ex y. - Proof. - split. - - apply (rtc_ind_r (λ z, ∃ ex, trace_steps Rb ex ∧ trace_starts_in ex x ∧ trace_ends_in ex z) x). - + eexists {tr[ _ ]}; split_and!; [constructor|done|done]. - + intros ? ? ? ? (? & ? & ? & ?). - eexists (_ :tr[inhabitant]: _); split_and!; [|done|done]. - econstructor; eauto. - - intros (ex & Hex & Hex1 & Hex2). - revert x y Hex1 Hex2; induction Hex as [|? ? ? ? ? ? IHex IH]; intros z w Hex1 Hex2. - + inversion Hex1; simplify_eq. - inversion Hex2; simplify_eq. - econstructor. - + inversion Hex1; simplify_eq. - inversion Hex2; simplify_eq. - eapply rtc_r; last done. - apply IH; done. - Qed. - - Lemma trace_steps_rtc_1_bin `{Inhabited L} x y : - rtc R x y → ∃ ex, trace_steps Rb ex ∧ trace_starts_in ex x ∧ trace_ends_in ex y. - Proof. intros ?. by eapply trace_steps_rtc_bin. Qed. - - Lemma trace_steps_rtc_2_bin `{Inhabited L} ex : - trace_steps Rb ex → rtc R (trace_first ex) (trace_last ex). - Proof. intros ?. eapply trace_steps_rtc_bin. eexists; done. Qed. - - Lemma trace_append_list_steps_rtc_bin (x y : A) (ex : finite_trace A L) (l : list (L * A)) : - trace_ends_in ex x → - trace_ends_in (ex +trl+ l) y → - trace_steps (λ x _ y, R x y) (ex +trl+ l) → - rtc R x y. - Proof. - revert ex x y; induction l as [|[? a] l IHl] using rev_ind ; simpl; intros ex x y Hx Hy Hts. - - assert (x = y) as -> by by eapply trace_ends_in_inj; eauto. - constructor. - - rewrite -trace_append_list_assoc in Hy, Hts. - simpl in Hts. - apply trace_steps_step_inv in Hts as [Hts1 [z [Hts2 Htz3]]]. - apply last_eq_trace_ends_in in Hy; simplify_eq. - eapply rtc_r; last apply Htz3. - eapply IHl; eauto. - Qed. - -End traces_step_binary. - -Section trace_steps_no_labels. - Context {A : Type} (R : A -> A -> Prop). - - Lemma trace_steps_step_inv_nl (ex : finite_trace A ()) ℓ x: - trace_steps (λ x _ y, R x y) (ex :tr[ℓ]: x) → - trace_steps (λ x _ y, R x y) ex ∧ - ∃ y, trace_ends_in ex y ∧ R y x. - Proof. inversion 1; eauto. Qed. - - Lemma trace_steps_impl_nl (R' : A -> A -> Prop) : - (∀ x y, R x y → R' x y) → ∀ (ex: finite_trace A ()), trace_steps (λ x _ y, R x y) ex → trace_steps (λ x _ y, R' x y) ex. - Proof. intros HR ex Hex; induction Hex; econstructor; eauto. Qed. - - Lemma trace_steps_rtc_nl x y : - rtc R x y ↔ ∃ (ex : finite_trace A ()), trace_steps (λ x _ y, R x y) ex ∧ trace_starts_in ex x ∧ trace_ends_in ex y. - Proof. - split. - - apply (rtc_ind_r (λ z, ∃ ex, trace_steps (λ x _ y, R x y) ex ∧ trace_starts_in ex x ∧ trace_ends_in ex z) x). - + eexists {tr[ _ ]}; split_and!; [constructor|done|done]. - + intros ? ? ? ? (? & ? & ? & ?). - eexists (_ :tr[tt]: _); split_and!; [|done|done]. - econstructor; eauto. - - intros (ex & Hex & Hex1 & Hex2). - revert x y Hex1 Hex2; induction Hex as [|? ? ? ? ? ? IHex IH]; intros z w Hex1 Hex2. - + inversion Hex1; simplify_eq. - inversion Hex2; simplify_eq. - econstructor. - + inversion Hex1; simplify_eq. - inversion Hex2; simplify_eq. - eapply rtc_r; last by []. - apply IH; done. - Qed. - - Lemma trace_steps_rtc_1_nl x y : - rtc R x y → ∃ (ex : finite_trace A ()), trace_steps (λ x _ y, R x y) ex ∧ trace_starts_in ex x ∧ trace_ends_in ex y. - Proof. intros ?. by eapply trace_steps_rtc_nl. Qed. - - Lemma trace_steps_rtc_2_nl (ex : finite_trace A ()) : - trace_steps (λ x _ y, R x y) ex → rtc R (trace_first ex) (trace_last ex). - Proof. intros ?. eapply trace_steps_rtc_nl. eexists; done. Qed. - - Lemma trace_append_list_steps_rtc_nl (x y : A) (ex : finite_trace A ()) (l : list (() * A)) : - trace_ends_in ex x → - trace_ends_in (ex +trl+ l) y → - trace_steps (λ x _ y, R x y) (ex +trl+ l) → - rtc R x y. - Proof. - revert ex x y; induction l as [|[? a] l IHl] using rev_ind ; simpl; intros ex x y Hx Hy Hts. - - assert (x = y) as -> by by eapply trace_ends_in_inj; eauto. - constructor. - - rewrite -trace_append_list_assoc in Hy, Hts. - simpl in Hts. - apply trace_steps_step_inv_nl in Hts as [Hts1 [z [Hts2 Htz3]]]. - apply last_eq_trace_ends_in in Hy; simplify_eq. - eapply rtc_r; last apply Htz3. - eapply IHl; eauto. - Qed. -End trace_steps_no_labels. - -Section trace_steps2. - Context {A B L1 L2 : Type} (R : A → B → L1 -> L2 -> A → B → Prop). - - Lemma trace_steps2_step_inv ex1 x ex2 y ℓ1 ℓ2: - trace_steps2 R (ex1 :tr[ℓ1]: x) (ex2 :tr[ℓ2]: y) → - trace_steps2 R ex1 ex2 ∧ - ∃ x' y', trace_ends_in ex1 x' ∧ trace_ends_in ex2 y' ∧ R x' y' ℓ1 ℓ2 x y. - Proof. inversion 1; simplify_eq; eauto 10. Qed. - - Lemma trace_steps2_impl (R' : A → B -> L1 -> L2 -> A → B → Prop) : - (∀ x1 y1 ℓ1 ℓ2 x2 y2, R x1 y1 ℓ1 ℓ2 x2 y2 → R' x1 y1 ℓ1 ℓ2 x2 y2) → - ∀ ex ex', trace_steps2 R ex ex' → trace_steps2 R' ex ex'. - Proof. intros HR ex ex' Hex; induction Hex; econstructor; eauto. Qed. - - Lemma trace_steps2_trace_steps (R1 : A -> L1 -> A -> Prop) (R2 : B -> L2 -> B -> Prop) : - (∀ x1 y1 ℓ1 ℓ2 x2 y2, R x1 y1 ℓ1 ℓ2 x2 y2 → R1 x1 ℓ1 x2 ∧ R2 y1 ℓ2 y2) → - ∀ ex ex', trace_steps2 R ex ex' → trace_steps R1 ex ∧ trace_steps R2 ex'. - Proof. - intros HR ex ex' Hexs. - induction Hexs as [|?????????? []%HR ? []]. - - split; constructor. - - split; econstructor; done. - Qed. - -End trace_steps2. -Section traces_forall. - Context {A L : Type}. - - Inductive trace_forall (P : A → Prop) : finite_trace A L → Prop := - | TFA_singleton a : P a → trace_forall P {tr[a]} - | TFA_extend tr a ℓ: trace_forall P tr → P a → trace_forall P (tr :tr[ℓ]: a). - - Lemma trace_forall_last P tr : trace_forall P tr → P (trace_last tr). - Proof. inversion 1; done. Qed. - - Lemma trace_forall_first P tr : trace_forall P tr → P (trace_first tr). - Proof. induction 1; done. Qed. - - Lemma trace_forall_extend_inv P tr a ℓ: trace_forall P (tr :tr[ℓ]: a) → trace_forall P tr ∧ P a. - Proof. inversion 1; done. Qed. - -End traces_forall. - -Section traces_forall2. - Context {A B L1 L2: Type}. - - Inductive trace_forall2 (P : A → B → Prop) : finite_trace A L1 → finite_trace B L2 → Prop := - | TFA2_singleton a b : P a b → trace_forall2 P {tr[a]} {tr[b]} - | TFA2_extend tr tr' a b ℓ1 ℓ2 : - trace_forall2 P tr tr' → P a b → trace_forall2 P (tr :tr[ℓ1]: a) (tr' :tr[ℓ2]: b). - - Lemma trace_forall2_impl (P Q : A → B → Prop) tr tr' : - (∀ x y, P x y → Q x y) → trace_forall2 P tr tr' → trace_forall2 Q tr tr'. - Proof. intros HPQ; induction 1; constructor; auto. Qed. - - Lemma trace_forall2_last P tr tr' : trace_forall2 P tr tr' → P (trace_last tr) (trace_last tr'). - Proof. inversion 1; done. Qed. - - Lemma trace_forall2_first P tr tr' : trace_forall2 P tr tr' → P (trace_first tr) (trace_first tr'). - Proof. induction 1; done. Qed. - - Lemma trace_forall2_singleton_inv P a b : trace_forall2 P {tr[a]} {tr[b]} → P a b. - Proof. inversion 1; done. Qed. - - Lemma trace_forall2_singleton_inv_l P tr' a : - trace_forall2 P {tr[a]} tr' → ∃ b, tr' = {tr[b]} ∧ P a b. - Proof. inversion 1; eauto. Qed. - - Lemma trace_forall2_singleton_inv_r P tr b : - trace_forall2 P tr {tr[b]} → ∃ a, tr = {tr[a]} ∧ P a b. - Proof. inversion 1; eauto. Qed. - - Lemma trace_forall2_extend_inv P tr tr' a b ℓ1 ℓ2: - trace_forall2 P (tr :tr[ℓ1]: a) (tr' :tr[ℓ2]: b) → trace_forall2 P tr tr' ∧ P a b. - Proof. inversion 1; done. Qed. - - Lemma trace_forall2_extend_inv_l P tr tr' a ℓ1: - trace_forall2 P (tr :tr[ℓ1]: a) tr' → ∃ b tr'' ℓ2, tr' = tr'' :tr[ℓ2]: b ∧ trace_forall2 P tr tr'' ∧ P a b. - Proof. inversion 1; simplify_eq; eexists _, _. eauto. Qed. - - Lemma trace_forall2_extend_inv_r P tr tr' b ℓ2: - trace_forall2 P tr (tr' :tr[ℓ2]: b) → ∃ a tr'' ℓ1, tr = tr'' :tr[ℓ1]: a ∧ trace_forall2 P tr'' tr' ∧ P a b. - Proof. inversion 1; simplify_eq; eexists _, _; eauto. Qed. - -End traces_forall2. - -Section traces_forall3. - Context {A B C L1 L2 L3: Type}. - - Inductive trace_forall3 (P : A → B → C → Prop) : - finite_trace A L1 → finite_trace B L2 → finite_trace C L3 → Prop := - | TFA3_singleton a b c : P a b c → trace_forall3 P {tr[a]} {tr[b]} {tr[c]} - | TFA3_extend tr tr' tr'' a b c ℓ1 ℓ2 ℓ3: - trace_forall3 P tr tr' tr'' → P a b c → trace_forall3 P (tr :tr[ℓ1]: a) (tr' :tr[ℓ2]: b) (tr'' :tr[ℓ3]: c). - - Lemma trace_forall3_impl (P Q : A → B → C → Prop) tr tr' tr'' : - (∀ x y z, P x y z → Q x y z) → trace_forall3 P tr tr' tr'' → trace_forall3 Q tr tr' tr''. - Proof. intros HPQ; induction 1; constructor; auto. Qed. - - Lemma trace_forall3_last P tr tr' tr'' : - trace_forall3 P tr tr' tr'' → P (trace_last tr) (trace_last tr') (trace_last tr''). - Proof. inversion 1; done. Qed. - - Lemma trace_forall3_first P tr tr' tr'' : - trace_forall3 P tr tr' tr'' → P (trace_first tr) (trace_first tr') (trace_first tr''). - Proof. induction 1; done. Qed. - - Lemma trace_forall3_singleton_inv P a b c : trace_forall3 P {tr[a]} {tr[b]} {tr[c]} → P a b c. - Proof. inversion 1; done. Qed. - - Lemma trace_forall3_singleton_inv_l P a tr' tr'' : - trace_forall3 P {tr[a]} tr' tr'' → ∃ b c, tr' = {tr[b]} ∧ tr'' = {tr[c]} ∧ P a b c. - Proof. inversion 1; eauto. Qed. - - Lemma trace_forall2_singleton_inv_m P tr b tr'' : - trace_forall3 P tr {tr[b]} tr'' → ∃ a c, tr = {tr[a]} ∧ tr'' = {tr[c]} ∧ P a b c. - Proof. inversion 1; eauto. Qed. - - Lemma trace_forall3_singleton_inv_r P tr tr' c : - trace_forall3 P tr tr' {tr[c]} → ∃ a b, tr = {tr[a]} ∧ tr' = {tr[b]} ∧ P a b c. - Proof. inversion 1; eauto. Qed. - - Lemma trace_forall3_extend_inv P tr tr' tr'' a b c ℓ1 ℓ2 ℓ3: - trace_forall3 P (tr :tr[ℓ1]: a) (tr' :tr[ℓ2]: b) (tr'' :tr[ℓ3]: c) → trace_forall3 P tr tr' tr'' ∧ P a b c. - Proof. inversion 1; done. Qed. - - Lemma trace_forall3_extend_inv_l P tr1 a tr2 tr3 ℓ1 : - trace_forall3 P (tr1 :tr[ℓ1]: a) tr2 tr3 → - ∃ b tr2' c tr3' ℓ2 ℓ3, tr2 = tr2' :tr[ℓ2]: b ∧ tr3 = tr3' :tr[ℓ3]: c ∧ trace_forall3 P tr1 tr2' tr3' ∧ P a b c. - Proof. inversion 1; eauto 10. Qed. - - Lemma trace_forall3_extend_inv_m P tr1 tr2 b tr3 ℓ2 : - trace_forall3 P tr1 (tr2 :tr[ℓ2]: b) tr3 → - ∃ a tr1' c tr3' ℓ1 ℓ3, tr1 = tr1' :tr[ℓ1]: a ∧ tr3 = tr3' :tr[ℓ3]: c ∧ trace_forall3 P tr1' tr2 tr3' ∧ P a b c. - Proof. inversion 1; eauto 10. Qed. - - Lemma trace_forall3_extend_inv_r P tr1 tr2 tr3 c ℓ3 : - trace_forall3 P tr1 tr2 (tr3 :tr[ℓ3]: c) → - ∃ a tr1' b tr2' ℓ1 ℓ2, tr1 = tr1' :tr[ℓ1]: a ∧ tr2 = tr2' :tr[ℓ2]: b ∧ trace_forall3 P tr1' tr2' tr3 ∧ P a b c. - Proof. inversion 1; eauto 10. Qed. - -End traces_forall3. - -Section trace_length_lookup. - Context {A L : Type}. - - Implicit Types a : A. - Implicit Types ft : finite_trace A L. - - Fixpoint trace_length {A} (ft : finite_trace A L) : nat := - match ft with - | {tr[_]} => 1 - | ft' :tr[_]: _ => S (trace_length ft') - end. - - Global Instance trace_lookup {A} : Lookup nat A (finite_trace A L) := - (fix go (n : nat) (ft : finite_trace A L) {struct ft} := - match ft with - | {tr[a]} => - match n with - | O => Some a - | _ => None - end - | ft' :tr[_]: a => - if (bool_decide (trace_length ft' = n)) then Some a else go n ft' - end). - - Lemma trace_lookup_lt_Some ft i : is_Some (ft !! i) ↔ i < trace_length ft. - Proof. - revert i; induction ft as [a|ft IHft ℓ a]; intros i; simpl. - - rewrite -not_eq_None_Some; destruct i; simpl. - + split; [lia|done]. - + split; [done|lia]. - - rewrite /lookup /trace_lookup /=. - destruct (decide (trace_length ft = i)). - + rewrite bool_decide_eq_true_2; last done. - split; [lia|by eauto]. - + rewrite bool_decide_eq_false_2; last done. - rewrite IHft; lia. - Qed. - - Lemma trace_length_at_least ft : 1 ≤ trace_length ft. - Proof. destruct ft; simpl; lia. Qed. - - Lemma trace_lookup_lt_Some_1 ft i a : ft !! i = Some a → i < trace_length ft. - Proof. rewrite -trace_lookup_lt_Some; eauto. Qed. - - Lemma trace_lookup_lt_Some_2 ft i : i < trace_length ft → is_Some (ft !! i). - Proof. apply trace_lookup_lt_Some. Qed. - - Lemma trace_lookup_extend ft a i ℓ : i = trace_length ft → (ft :tr[ℓ]: a) !! i = Some a. - Proof. intros ->; rewrite /lookup /= bool_decide_eq_true_2; done. Qed. - - Lemma trace_lookup_extend_lt ft a i ℓ : i < trace_length ft → (ft :tr[ℓ]: a) !! i = ft !! i. - Proof. intros ?; rewrite /lookup /= bool_decide_eq_false_2; auto with lia. Qed. - - Lemma trace_lookup_singelton a i : {tr[a]} !! i = Some a ↔ i = 0. - Proof. destruct i; simpl; split; by auto with lia. Qed. - - Lemma trace_lookup_singelton_1 a i b : {tr[a]} !! i = Some b → i = 0 ∧ b = a. - Proof. destruct i; simpl; split; simplify_eq; done. Qed. - - Lemma trace_lookup_singelton_2 a : {tr[a]} !! 0 = Some a. - Proof. rewrite trace_lookup_singelton; done. Qed. - - Lemma trace_lookup_first ft : ft !! 0 = Some (trace_first ft). - Proof. - induction ft; first done. - pose proof (trace_length_at_least ft). - rewrite /lookup /= bool_decide_eq_false_2; auto with lia. - Qed. - - Lemma trace_lookup_last ft i : S i = trace_length ft → ft !! i = Some (trace_last ft). - Proof. - destruct ft; simpl; intros ?. - - assert (i = 0) as -> by lia. - rewrite trace_lookup_first; done. - - rewrite /lookup /= bool_decide_eq_true_2; auto with lia. - Qed. - - - Lemma trace_lookup_append_list ft l i : i < trace_length ft → (ft +trl+ l) !! i = ft !! i. - Proof. - revert ft i; induction l as [|[? a] l IHl]; intros ft i Hi; first done. - rewrite IHl; last by simpl; lia. - rewrite trace_lookup_extend_lt; done. - Qed. - - Lemma trace_lookup_append_list_inv ft i a : - ft !! i = Some a → ∃ ft' l, ft = ft' +trl+ l ∧ S i = trace_length ft'. - Proof. - revert i a; induction ft as [b|ft IHft ℓ b] ; intros i a Hlu. - - apply trace_lookup_singelton_1 in Hlu as [-> ->]. - eexists {tr[_]}, []; done. - - destruct (decide (i = trace_length ft)) as [->|]. - + rewrite trace_lookup_extend in Hlu; last done. - simplify_eq. - eexists _, []; split; done. - + pose proof (trace_lookup_lt_Some_1 _ _ _ Hlu). - rewrite trace_lookup_extend_lt in Hlu; last by simpl in *; lia. - apply IHft in Hlu as (ft' & l & -> & Hli). - eexists ft', (l ++ [(ℓ, b)]). - rewrite -trace_append_list_assoc //=. - Qed. - - Lemma trace_steps_append_list_inv (R : A → L -> A → Prop) ft l : - trace_steps R (ft +trl+ l) → trace_steps R ft. - Proof. - revert ft; induction l as [|[??] l IHl] using rev_ind; intros ft Hftl; first done. - apply IHl. - rewrite -trace_append_list_assoc /= in Hftl. - eapply trace_steps_step_inv; done. - Qed. - - Lemma trace_steps_lookup (R : A → A → Prop) ft : - trace_steps (λ x _ y, R x y) ft → ∀ i j a b, i ≤ j → ft !! i = Some a → ft !! j = Some b → rtc R a b. - Proof. - intros Hft i j a b Hij Ha Hb. - pose proof (trace_lookup_append_list_inv _ _ _ Hb) as (ft' & l & -> & Hj). - rewrite trace_lookup_append_list in Hb; last lia. - rewrite trace_lookup_append_list in Ha; last lia. - apply trace_steps_append_list_inv in Hft. - pose proof (trace_lookup_append_list_inv _ _ _ Ha) as (ft'' & l' & -> & Hi). - rewrite trace_lookup_append_list in Ha; last lia. - rewrite trace_lookup_last in Ha; last done. - rewrite trace_lookup_last in Hb; last done. - simplify_eq. - eapply trace_append_list_steps_rtc_bin; eauto using trace_ends_in_last. - Qed. - - -End trace_length_lookup. diff --git a/trillium/traces/trace_properties.v b/trillium/traces/trace_properties.v deleted file mode 100644 index a8e16683..00000000 --- a/trillium/traces/trace_properties.v +++ /dev/null @@ -1,807 +0,0 @@ -From stdpp Require Export base prelude finite. -From Coq.ssr Require Import ssreflect. -From trillium.traces Require Import infinite_trace trace. - -Import InfListNotations. - -Section trace_prop. - Context {A L : Type}. - - Implicit Types ψ : finite_trace A L → inflist (L * A) → Prop. - Implicit Types f : finite_trace A L. - Implicit Types inftr : inflist (L * A). - - Inductive eventually ψ : finite_trace A L → inflist (L * A) → Prop := - | eventually_now f inftr : ψ f inftr → eventually ψ f inftr - | eventually_later f ℓ a inftr : - eventually ψ (f :tr[ℓ]: a) inftr → eventually ψ f ((ℓ, a) :: inftr). - - CoInductive always ψ : finite_trace A L → inflist (L * A) → Prop := - | always_continued f inftr : - ψ f inftr → - (∀ ℓ a inftr', inftr = ((ℓ, a) :: inftr')%inflist → always ψ (f :tr[ℓ]: a) inftr') → - always ψ f inftr. - - (* properties *) - (* always is a comonad *) - Lemma always_mono ψ ψ' f inftr : - (∀ f' inftr', ψ f' inftr' → ψ' f' inftr') → - always ψ f inftr → - always ψ' f inftr. - Proof. - intros Hψs. revert f inftr. - cofix IH; intros f inftr Hψ. - inversion Hψ; simplify_eq. - constructor; first by apply Hψs. - intros ? a inftr' ->; auto. - Qed. - - Lemma always_holds ψ f inftr : always ψ f inftr → ψ f inftr. - Proof. destruct 1; done. Qed. - - Lemma always_idemp ψ f inftr : always ψ f inftr → always (always ψ) f inftr. - Proof. - revert f inftr; cofix IH; intros f inftr. - inversion 1; simplify_eq. - constructor; eauto. - Qed. - - Lemma always_unroll ψ f ℓ a inftr : always ψ f ((ℓ, a) :: inftr) → always ψ (f :tr[ℓ]: a) inftr. - Proof. inversion 1; auto. Qed. - - Lemma always_unroll_n ψ n f inftr : - always ψ f inftr → - always ψ (trace_append_list f (inflist_take n inftr)) (inflist_drop n inftr). - Proof. - revert f inftr; induction n as [|n IHn]; intros f inftr Hbase; first done. - inversion Hbase; simplify_eq. - destruct inftr; first done. - destruct x; apply IHn; auto. - Qed. - - Lemma always_take_drop ψ f inftr : - always ψ f inftr ↔ - ∀ n, ψ (trace_append_list f (inflist_take n inftr)) (inflist_drop n inftr). - Proof. - split. - - by intros Hal n; apply always_holds, always_unroll_n. - - revert f inftr. - cofix IH; intros f inftr. - intros Hn. - constructor; first by apply (Hn 0). - intros ? ? ? ->. - apply IH. - intros n; apply (Hn (S n)). - Qed. - - Lemma always_and ψ1 ψ2 f inftr : - always ψ1 f inftr ∧ always ψ2 f inftr ↔ - always (λ f' inftr', ψ1 f' inftr' ∧ ψ2 f' inftr') f inftr. - Proof. setoid_rewrite always_take_drop; firstorder. Qed. - - Lemma always_forall {B} (Ψ : B → finite_trace A L → inflist (L * A) → Prop) f inftr: - (∀ b, always (Ψ b) f inftr) ↔ always (λ f' inftr', ∀ b, Ψ b f' inftr') f inftr. - Proof. setoid_rewrite always_take_drop; firstorder. Qed. - - Lemma always_impl P (Ψ : finite_trace A L → inflist (L * A) → Prop) f inftr: - (P → always Ψ f inftr) ↔ always (λ f' inftr', P → Ψ f' inftr') f inftr. - Proof. setoid_rewrite always_take_drop; firstorder. Qed. - - (* eventually is a monad *) - Lemma eventually_mono ψ ψ' f inftr : - (∀ f' inftr', ψ f' inftr' → ψ' f' inftr') → - eventually ψ f inftr → - eventually ψ' f inftr. - Proof. intros Hψs. induction 1; first by constructor; auto. constructor; done. Qed. - - Lemma holds_eventually ψ f inftr : ψ f inftr → eventually ψ f inftr. - Proof. by constructor. Qed. - - Lemma eventually_idemp ψ f inftr : eventually (eventually ψ) f inftr → eventually ψ f inftr. - Proof. induction 1; first done. constructor; done. Qed. - - - Lemma eventually_take_drop ψ f inftr : - eventually ψ f inftr ↔ - ∃ n, ψ (trace_append_list f (inflist_take n inftr)) (inflist_drop n inftr). - Proof. - split. - - intros Hev. - induction Hev as [|????? [n Hn]]; first by exists 0. - exists (S n); done. - - intros [n Hn]. - revert f inftr Hn. - induction n as [|n IHn]; intros f inftr Hn; first by constructor. - destruct inftr as [|[??]]; first by constructor. - constructor 2; apply IHn; done. - Qed. - - Lemma eventually_exists {B} (Ψ : B → finite_trace A L → inflist (L * A) → Prop) f inftr: - (∃ b, eventually (Ψ b) f inftr) ↔ eventually (λ f' inftr', ∃ b, Ψ b f' inftr') f inftr. - Proof. setoid_rewrite eventually_take_drop; firstorder. Qed. - - (* other properties *) - - Lemma always_eventually_idemp ψ f inftr : - always (eventually ψ) f inftr → always (eventually (always (eventually ψ))) f inftr. - Proof. - intros Hae. - apply always_idemp in Hae. - eapply always_mono; last apply Hae. - clear; intros f' inftr' Hae. - apply holds_eventually; done. - Qed. - - Lemma eventually_always_combine ψ1 ψ2 f inftr : - eventually (always ψ1) f inftr → - eventually (always ψ2) f inftr → - eventually (λ f' inftr', always ψ1 f' inftr' ∧ always ψ2 f' inftr') f inftr. - Proof. - rewrite !eventually_take_drop. - intros [n Hn] [m Hm]. - exists (n `max` m). - split. - - assert (n ≤ n `max` m) as [k ->]%Nat.le_sum by lia. - rewrite inflist_take_add [n + k]Nat.add_comm inflist_drop_add - -trace_append_list_assoc. - apply always_unroll_n; done. - - assert (m ≤ n `max` m) as [k ->]%Nat.le_sum by lia. - rewrite inflist_take_add [m + k]Nat.add_comm inflist_drop_add - -trace_append_list_assoc. - apply always_unroll_n; done. - Qed. - - Lemma eventually_and_always ψ1 ψ2 f inftr : - eventually ψ1 f inftr → - always ψ2 f inftr → - eventually (λ f' inftr', ψ1 f' inftr' ∧ always ψ2 f' inftr') f inftr. - Proof. - intros [n Hn]%eventually_take_drop Hal. - apply eventually_take_drop; exists n. - split; first done. - apply always_unroll_n; done. - Qed. - - Lemma eventually_forall_combine `{!EqDecision B} `{!Finite B} - (Ψ : B → finite_trace A L → inflist (L * A) → Prop) f inftr: - (∀ b, eventually (always (Ψ b)) f inftr) → - eventually (λ f' inftr', ∀ b, always (Ψ b) f' inftr') f inftr. - Proof. - intros Hfa. - cut (eventually (λ f' inftr', ∀ b : B, b ∈ enum B → always (Ψ b) f' inftr') f inftr). - { apply eventually_mono; clear; intros; auto using elem_of_enum. } - induction (enum B) as [|b l IHl]. - { apply holds_eventually; intros ?; rewrite elem_of_nil; done. } - assert (eventually (always (λ f' inftr', ∀ b : B, b ∈ l → Ψ b f' inftr')) f inftr) as IHl'. - { eapply eventually_mono; last by apply IHl. - simpl; intros f' inftr' Hfa'. - rewrite -always_forall; intros b'. - rewrite -always_impl; apply Hfa'. } - clear IHl. - eapply eventually_mono; last by apply eventually_always_combine; [apply (Hfa b)| apply IHl']. - simpl; clear; intros f' inftr' [Hal1 Hal2]. - intros b' [->|Hb']%elem_of_cons; first done. - revert Hb'. rewrite always_impl. - revert b'. rewrite always_forall. - done. - Qed. - -End trace_prop. - -Section trace_prop. - Context {A B L1 L2 : Type}. - - Implicit Types ψ : finite_trace A L1 → finite_trace B L2 → inflist (L1 * A) → inflist (L2 * B) → Prop. - Implicit Types f : finite_trace A L1. - Implicit Types g : finite_trace B L2. - Implicit Types inftr : inflist (L1 * A). - Implicit Types inftrb : inflist (L2 * B). - - Inductive eventually2 ψ : finite_trace A L1 → finite_trace B L2 → inflist (L1 * A) → inflist (L2 * B) → Prop := - | eventually2_now f g inftr inftrb : - inflist_same_length inftr inftrb → - ψ f g inftr inftrb → - eventually2 ψ f g inftr inftrb - | eventually2_later f ℓ1 ℓ2 a g b inftr inftrb : - eventually2 ψ (f :tr[ℓ1]: a) (g :tr[ℓ2]: b) inftr inftrb → - eventually2 ψ f g ((ℓ1, a) :: inftr) ((ℓ2, b) :: inftrb). - - CoInductive always2 ψ : finite_trace A L1 → finite_trace B L2 → inflist (L1 * A) → inflist (L2 * B) → Prop := - | always2_continued f g inftr inftrb : - ψ f g inftr inftrb → - inflist_same_length inftr inftrb → - (∀ a inftr' b inftrb' ℓ1 ℓ2, - inftr = ((ℓ1, a) :: inftr')%inflist → - inftrb = ((ℓ2, b) :: inftrb')%inflist → - always2 ψ (f :tr[ℓ1]: a) (g :tr[ℓ2]: b) inftr' inftrb') → - always2 ψ f g inftr inftrb. - - (* properties *) - (* always 2 is a comonad *) - Lemma always2_mono ψ ψ' f g inftr inftrb : - (∀ f' inftr' g' inftrb', ψ f' g' inftr' inftrb' → ψ' f' g' inftr' inftrb') → - always2 ψ f g inftr inftrb → - always2 ψ' f g inftr inftrb. - Proof. - intros Hψs. revert f g inftr inftrb. - cofix IH; intros f g inftr inftrb Hψ. - inversion Hψ; simplify_eq. - constructor; [by apply Hψs|done|]. - intros a' inftr' b' inftrb' ?? -> ->; auto. - Qed. - - Lemma always2_holds ψ f g inftr inftrb : always2 ψ f g inftr inftrb → ψ f g inftr inftrb. - Proof. destruct 1; done. Qed. - - Lemma always2_idemp ψ f g inftr inftrb : - always2 ψ f g inftr inftrb → always2 (always2 ψ) f g inftr inftrb. - Proof. - revert f g inftr inftrb; cofix IH; intros f g inftr inftrb. - inversion 1; simplify_eq. - constructor; eauto. - Qed. - - Lemma always2_unroll ψ f a g b ℓ1 ℓ2 inftr inftrb : - always2 ψ f g ((ℓ1, a) :: inftr) ((ℓ2, b) :: inftrb) → always2 ψ (f :tr[ℓ1]: a) (g :tr[ℓ2]: b) inftr inftrb. - Proof. inversion 1; auto. Qed. - - Lemma always2_unroll_n ψ n f g inftr inftrb : - always2 ψ f g inftr inftrb → - always2 - ψ - (trace_append_list f (inflist_take n inftr)) - (trace_append_list g (inflist_take n inftrb)) - (inflist_drop n inftr) - (inflist_drop n inftrb). - Proof. - revert f g inftr inftrb; induction n as [|n IHn]; intros f g inftr inftrb Hbase; first done. - inversion Hbase; simplify_eq. - destruct inftr as [|[??]]; destruct inftrb as [|[??]]; [done|done|done|]. - apply IHn; auto. - Qed. - - Lemma always2_inflist_same_length ψ f g inftr inftrb : - always2 ψ f g inftr inftrb → inflist_same_length inftr inftrb. - Proof. by inversion 1. Qed. - - Lemma always2_and_inflist_same_length ψ f g inftr inftrb : - always2 ψ f g inftr inftrb ↔ - always2 (λ f' g' inftr' inftrb', - ψ f' g' inftr' inftrb' ∧ inflist_same_length inftr' inftrb') f g inftr inftrb. - Proof. - split; last by apply always2_mono; tauto. - intros Hal. - revert f g inftr inftrb Hal. - cofix IH; intros f g inftr inftrb Hal. - inversion Hal; simplify_eq. - constructor; [done|done|]. - intros a' inftr' b' inftrb' ?? -> ->; auto. - Qed. - - Lemma always2_take_drop ψ f g inftr inftrb : - always2 ψ f g inftr inftrb ↔ - ∀ n, ψ (trace_append_list f (inflist_take n inftr)) - (trace_append_list g (inflist_take n inftrb)) - (inflist_drop n inftr) - (inflist_drop n inftrb) ∧ - inflist_same_length inftr inftrb. - Proof. - split. - - intros Hal n. - split; last by eapply always2_inflist_same_length; eauto. - by apply always2_holds, always2_unroll_n. - - revert f g inftr inftrb. - cofix IH; intros f g inftr inftrb. - intros Hn. - constructor; [by apply (Hn 0)|by apply (Hn 0)|]. - intros ? ? ? ? ? ? -> ->. - apply IH. - setoid_rewrite inflist_same_length_cons in Hn. - intros n; apply (Hn (S n)). - Qed. - - Lemma always2_and ψ1 ψ2 f g inftr inftrb : - always2 ψ1 f g inftr inftrb ∧ always2 ψ2 f g inftr inftrb ↔ - always2 - (λ f' g' inftr' inftrb',ψ1 f' g' inftr' inftrb' ∧ ψ2 f' g' inftr' inftrb') f g inftr inftrb. - Proof. rewrite !always2_take_drop; firstorder. Qed. - - Lemma always2_forall `{!Inhabited C} - (Ψ : C → finite_trace A L1 → finite_trace B L2 → inflist (L1 * A) → inflist (L2 * B) → Prop) f g inftr inftrb : - (∀ b, always2 (Ψ b) f g inftr inftrb) ↔ - always2 (λ f' g' inftr' inftrb', ∀ b, Ψ b f' g' inftr' inftrb') f g inftr inftrb. - Proof. setoid_rewrite always2_take_drop; firstorder. Qed. - - Lemma always2_impl P ψ f g inftr inftrb : - inflist_same_length inftr inftrb → - (P → always2 ψ f g inftr inftrb) ↔ - always2 (λ f' g' inftr' inftrb', P → ψ f' g' inftr' inftrb') f g inftr inftrb. - Proof. setoid_rewrite always2_take_drop; firstorder. Qed. - - (* eventually2 is a monad *) - Lemma eventually2_mono ψ ψ' f g inftr inftrb : - (∀ f' g' inftr' inftrb', ψ f' g' inftr' inftrb' → ψ' f' g' inftr' inftrb') → - eventually2 ψ f g inftr inftrb → - eventually2 ψ' f g inftr inftrb. - Proof. intros Hψs. induction 1; first by constructor; auto. constructor; done. Qed. - - Lemma holds_eventually2 ψ f g inftr inftrb : - inflist_same_length inftr inftrb → ψ f g inftr inftrb → eventually2 ψ f g inftr inftrb. - Proof. by constructor. Qed. - - Lemma eventually2_idemp ψ f g inftr inftrb : - eventually2 (eventually2 ψ) f g inftr inftrb → eventually2 ψ f g inftr inftrb. - Proof. induction 1; first done. constructor; done. Qed. - - Lemma eventually2_inflist_same_length ψ f g inftr inftrb : - eventually2 ψ f g inftr inftrb → inflist_same_length inftr inftrb. - Proof. - induction 1; first done. - rewrite inflist_same_length_cons; done. - Qed. - - Lemma eventually2_and_inflist_same_length ψ f g inftr inftrb : - eventually2 ψ f g inftr inftrb ↔ - eventually2 (λ f' g' inftr' inftrb', - ψ f' g' inftr' inftrb' ∧ inflist_same_length inftr' inftrb') f g inftr inftrb. - Proof. - split; last by apply eventually2_mono; tauto. - intros Hev. - induction Hev; first by constructor; auto. - constructor 2; auto. - Qed. - - Lemma eventually2_take_drop ψ f g inftr inftrb: - eventually2 ψ f g inftr inftrb ↔ - ∃ n, ψ (trace_append_list f (inflist_take n inftr)) - (trace_append_list g (inflist_take n inftrb)) - (inflist_drop n inftr) - (inflist_drop n inftrb) ∧ - inflist_same_length inftr inftrb. - Proof. - split. - - intros Hev. - induction Hev as [|????????? [n Hn]]; first by exists 0. - setoid_rewrite inflist_same_length_cons. - exists (S n); done. - - intros [n Hn]. - revert f g inftr inftrb Hn. - induction n as [|n IHn]; intros f g inftr inftrb [Hn1 Hn2]; first by constructor. - destruct inftr as [|[??]]; destruct inftrb as [|[??]]; [by constructor|done|done|]; simpl in *. - setoid_rewrite inflist_same_length_cons in Hn2. - constructor 2; apply IHn; done. - Qed. - - Lemma eventually2_exists - {C} (Ψ : C → finite_trace A L1 → finite_trace B L2 → inflist (L1 * A) → inflist (L2 * B) → Prop) - f g inftr inftrb : - (∃ b, eventually2 (Ψ b) f g inftr inftrb) ↔ - eventually2 (λ f' g' inftr' inftrb', ∃ b, Ψ b f' g' inftr' inftrb') f g inftr inftrb. - Proof. setoid_rewrite eventually2_take_drop; firstorder. Qed. - - (* other properties *) - - Lemma always2_eventually2_idemp ψ f g inftr inftrb : - always2 (eventually2 ψ) f g inftr inftrb → - always2 (eventually2 (always2 (eventually2 ψ))) f g inftr inftrb. - Proof. - intros Hae. - apply always2_idemp in Hae. - eapply always2_mono; last apply Hae. - clear; intros f' g' inftr' inftrb' Hae. - pose proof (always2_inflist_same_length _ _ _ _ _ Hae). - apply holds_eventually2; done. - Qed. - - Lemma eventually2_always2_combine ψ1 ψ2 f g inftr inftrb : - eventually2 (always2 ψ1) f g inftr inftrb → - eventually2 (always2 ψ2) f g inftr inftrb → - eventually2 (λ f' g' inftr' inftrb', - always2 ψ1 f' g' inftr' inftrb' ∧ always2 ψ2 f' g' inftr' inftrb') f g inftr inftrb. - Proof. - rewrite !eventually2_take_drop. - intros [n [Hn1 Hn2]] [m [Hm1 Hm2]]. - exists (n `max` m). - split; last done. - split. - - assert (n ≤ n `max` m) as [k ->]%Nat.le_sum by lia. - rewrite !inflist_take_add ![n + k]Nat.add_comm !inflist_drop_add - -!trace_append_list_assoc. - apply always2_unroll_n; done. - - assert (m ≤ n `max` m) as [k ->]%Nat.le_sum by lia. - rewrite !inflist_take_add ![m + k]Nat.add_comm !inflist_drop_add - -!trace_append_list_assoc. - apply always2_unroll_n; done. - Qed. - - Lemma eventually2_and_always2 ψ1 ψ2 f g inftr inftrb : - eventually2 ψ1 f g inftr inftrb → - always2 ψ2 f g inftr inftrb → - eventually2 (λ f' g' inftr' inftrb', - ψ1 f' g' inftr' inftrb' ∧ always2 ψ2 f' g' inftr' inftrb') f g inftr inftrb. - Proof. - intros [n [Hn1 Hn2]]%eventually2_take_drop Hal. - apply eventually2_take_drop; exists n. - split; last done. - split; first done. - apply always2_unroll_n; done. - Qed. - - Lemma eventually2_forall_combine `{!EqDecision C} `{!Finite C} `{!Inhabited C} - (Ψ : C → finite_trace A L1 → finite_trace B L2 → inflist (L1 * A) → inflist (L2 * B) → Prop) - f g inftr inftrb : - (∀ c, eventually2 (always2 (Ψ c)) f g inftr inftrb) → - eventually2 (λ f' g' inftr' inftrb', ∀ c, always2 (Ψ c) f' g' inftr' inftrb') f g inftr inftrb. - Proof. - intros Hfa. - cut (eventually2 - (λ f' g' inftr' inftrb', - ∀ c : C, c ∈ enum C → always2 (Ψ c) f' g' inftr' inftrb') f g inftr inftrb). - { apply eventually2_mono; clear; intros; auto using elem_of_enum. } - induction (enum C) as [|c l IHl]. - { apply holds_eventually2. - - specialize (Hfa inhabitant) as Hfa'%eventually2_inflist_same_length; done. - - intros ?; rewrite elem_of_nil; done. } - assert (eventually2 - (always2 (λ f' g' inftr' inftrb', - ∀ c : C, c ∈ l → Ψ c f' g' inftr' inftrb')) f g inftr inftrb) as IHl'. - { setoid_rewrite eventually2_and_inflist_same_length in IHl. - eapply eventually2_mono; last by apply IHl. - simpl; intros f' g' inftr' inftrb' [Hfa' Hsl]. - rewrite -always2_forall; intros c'. - rewrite -always2_impl; first by apply Hfa'. - done. } - clear IHl. - assert (eventually2 - (λ f' g' inftr' inftrb', - (always2 (λ f'' g'' inftr'' inftrb'', Ψ c f'' g'' inftr'' inftrb'')) - f' g' inftr' inftrb' ∧ - (always2 - (λ f'' g'' inftr'' inftrb'', ∀ c' : C, c' ∈ l → Ψ c' f'' g'' inftr'' inftrb'')) - f' g' inftr' inftrb') - f g inftr inftrb) as IHl. - { apply eventually2_always2_combine; last done. apply Hfa. } - clear IHl'. - eapply eventually2_mono; last apply IHl. - simpl; intros f' g' inftr' inftrb' [Hal1 Hal2] c' [->|Hc']%elem_of_cons; first done. - apply always2_inflist_same_length in Hal1. - revert Hc'; rewrite always2_impl; last done. - revert c'; rewrite always2_forall; done. - Qed. - -End trace_prop. - -Section trace_prop. - Context {A B C L1 L2 L3: Type}. - - Implicit Types ψ : - finite_trace A L1 → finite_trace B L2 → finite_trace C L3 → inflist (L1 * A) → inflist (L2 * B) → inflist (L3 * C) → Prop. - Implicit Types f : finite_trace A L1. - Implicit Types g : finite_trace B L2. - Implicit Types h : finite_trace C L3. - Implicit Types inftr : inflist (L1 * A). - Implicit Types inftrb : inflist (L2 * B). - Implicit Types inftrc : inflist (L3 * C). - - Inductive eventually3 ψ : - finite_trace A L1 → finite_trace B L2 → finite_trace C L3 → inflist (L1 * A) → inflist (L2 * B) → inflist (L3 * C) → Prop := - | eventually3_now f g h inftr inftrb inftrc : - inflist_same_length inftr inftrb → - inflist_same_length inftrb inftrc → - ψ f g h inftr inftrb inftrc → - eventually3 ψ f g h inftr inftrb inftrc - | eventually3_later f a g b h c ℓ1 ℓ2 ℓ3 inftr inftrb inftrc : - eventually3 ψ (f :tr[ℓ1]: a) (g :tr[ℓ2]: b) (h :tr[ℓ3]: c) inftr inftrb inftrc → - eventually3 ψ f g h ((ℓ1, a) :: inftr) ((ℓ2, b) :: inftrb) ((ℓ3, c) :: inftrc). - - CoInductive always3 ψ : - finite_trace A L1 → finite_trace B L2 → finite_trace C L3 → inflist (L1 * A) → inflist (L2 * B) → inflist (L3 * C) → Prop := - | always3_continued f g h inftr inftrb inftrc : - ψ f g h inftr inftrb inftrc → - inflist_same_length inftr inftrb → - inflist_same_length inftrb inftrc → - (∀ a ℓ1 inftr' b ℓ2 inftrb' c ℓ3 inftrc', - inftr = ((ℓ1, a) :: inftr')%inflist → - inftrb = ((ℓ2, b) :: inftrb')%inflist → - inftrc = ((ℓ3, c) :: inftrc')%inflist → - always3 ψ (f :tr[ℓ1]: a) (g :tr[ℓ2]: b) (h :tr[ℓ3]: c) inftr' inftrb' inftrc') → - always3 ψ f g h inftr inftrb inftrc. - - (* properties *) - (* always 3 is a comonad *) - Lemma always3_mono ψ ψ' f g h inftr inftrb inftrc : - (∀ f' g' h' inftr' inftrb' inftrc', - ψ f' g' h' inftr' inftrb' inftrc' → ψ' f' g' h' inftr' inftrb' inftrc') → - always3 ψ f g h inftr inftrb inftrc → - always3 ψ' f g h inftr inftrb inftrc. - Proof. - intros Hψs. revert f g h inftr inftrb inftrc. - cofix IH; intros f g h inftr inftrb inftrc Hψ. - inversion Hψ; simplify_eq. - constructor; [by apply Hψs|done|done|]. - intros ????????? -> -> ->; auto. - Qed. - - Lemma always3_holds ψ f g h inftr inftrb inftrc : - always3 ψ f g h inftr inftrb inftrc → ψ f g h inftr inftrb inftrc. - Proof. destruct 1; done. Qed. - - Lemma always3_idemp ψ f g h inftr inftrb inftrc : - always3 ψ f g h inftr inftrb inftrc → always3 (always3 ψ) f g h inftr inftrb inftrc. - Proof. - revert f g h inftr inftrb inftrc; cofix IH; intros f g h inftr inftrb inftrc. - inversion 1; simplify_eq. - constructor; eauto. - Qed. - - Lemma always3_unroll ψ f a g b h c ℓ1 ℓ2 ℓ3 inftr inftrb inftrc : - always3 ψ f g h ((ℓ1, a) :: inftr) ((ℓ2, b) :: inftrb) ((ℓ3, c) ::inftrc) → - always3 ψ (f :tr[ℓ1]: a) (g :tr[ℓ2]: b) (h :tr[ℓ3]:c) inftr inftrb inftrc. - Proof. inversion 1; eauto. Qed. - - Lemma always3_unroll_n ψ n f g h inftr inftrb inftrc : - always3 ψ f g h inftr inftrb inftrc → - always3 - ψ - (trace_append_list f (inflist_take n inftr)) - (trace_append_list g (inflist_take n inftrb)) - (trace_append_list h (inflist_take n inftrc)) - (inflist_drop n inftr) - (inflist_drop n inftrb) - (inflist_drop n inftrc). - Proof. - revert f g h inftr inftrb inftrc. - induction n as [|n IHn]; intros f g h inftr inftrb inftrc Hbase; first done. - inversion Hbase; simplify_eq. - destruct inftr as [|[??]?]; destruct inftrb as [|[??]?]; destruct inftrc as [|[??]?]; - [done|done|done|done|done|done|done|]. - simpl. apply IHn; auto. - Qed. - - Lemma always3_inflist_same_length ψ f g h inftr inftrb inftrc : - always3 ψ f g h inftr inftrb inftrc → - inflist_same_length inftr inftrb ∧ inflist_same_length inftrb inftrc. - Proof. by inversion 1. Qed. - - Lemma always3_and_inflist_same_length ψ f g h inftr inftrb inftrc : - always3 ψ f g h inftr inftrb inftrc ↔ - always3 (λ f' g' h' inftr' inftrb' inftrc', - ψ f' g' h' inftr' inftrb' inftrc' ∧ - inflist_same_length inftr' inftrb' ∧ - inflist_same_length inftrb' inftrc') f g h inftr inftrb inftrc. - Proof. - split; last by apply always3_mono; tauto. - intros Hal. - revert f g h inftr inftrb inftrc Hal. - cofix IH; intros f g h inftr inftrb inftrc Hal. - inversion Hal; simplify_eq. - constructor; [done|done|done|]. - intros ????????? -> -> ->; auto. - Qed. - - Lemma always3_take_drop ψ f g h inftr inftrb inftrc : - always3 ψ f g h inftr inftrb inftrc ↔ - ∀ n, ψ (trace_append_list f (inflist_take n inftr)) - (trace_append_list g (inflist_take n inftrb)) - (trace_append_list h (inflist_take n inftrc)) - (inflist_drop n inftr) - (inflist_drop n inftrb) - (inflist_drop n inftrc) ∧ - inflist_same_length inftr inftrb ∧ - inflist_same_length inftrb inftrc. - Proof. - split. - - intros Hal n. - split; last by eapply always3_inflist_same_length; eauto. - by apply always3_holds, always3_unroll_n. - - revert f g h inftr inftrb inftrc. - cofix IH; intros f g h inftr inftrb inftrc. - intros Hn. - constructor; [by apply (Hn 0)|by apply (Hn 0)|by apply (Hn 0)|]. - intros ? ? ? ? ? ? ? ? ? -> -> ->. - apply IH. - setoid_rewrite inflist_same_length_cons in Hn. - intros n; apply (Hn (S n)). - Qed. - - Lemma always3_and ψ1 ψ2 f g h inftr inftrb inftrc : - always3 ψ1 f g h inftr inftrb inftrc ∧ always3 ψ2 f g h inftr inftrb inftrc ↔ - always3 - (λ f' g' h' inftr' inftrb' inftrc', - ψ1 f' g' h' inftr' inftrb' inftrc' ∧ ψ2 f' g' h' inftr' inftrb' inftrc') - f g h inftr inftrb inftrc. - Proof. rewrite !always3_take_drop; firstorder. Qed. - - Lemma always3_forall `{!Inhabited D} - (Ψ : D → finite_trace A L1 → finite_trace B L2 → - finite_trace C L3 → inflist (L1 * A) → inflist (L2 * B) → inflist (L3 * C) → Prop) - f g h inftr inftrb inftrc : - (∀ d, always3 (Ψ d) f g h inftr inftrb inftrc) ↔ - always3 (λ f' g' h' inftr' inftrb' inftrc', ∀ b, Ψ b f' g' h' inftr' inftrb' inftrc') - f g h inftr inftrb inftrc. - Proof. setoid_rewrite always3_take_drop; firstorder. Qed. - - Lemma always3_impl P ψ f g h inftr inftrb inftrc : - inflist_same_length inftr inftrb → - inflist_same_length inftrb inftrc → - (P → always3 ψ f g h inftr inftrb inftrc) ↔ - always3 (λ f' g' h' inftr' inftrb' inftrc', P → ψ f' g' h' inftr' inftrb' inftrc') - f g h inftr inftrb inftrc. - Proof. setoid_rewrite always3_take_drop; firstorder. Qed. - - (* eventually3 is a monad *) - Lemma eventually3_mono ψ ψ' f g h inftr inftrb inftrc : - (∀ f' g' h' inftr' inftrb' inftrc', - ψ f' g' h' inftr' inftrb' inftrc' → ψ' f' g' h' inftr' inftrb' inftrc') → - eventually3 ψ f g h inftr inftrb inftrc → - eventually3 ψ' f g h inftr inftrb inftrc. - Proof. intros Hψs. induction 1; first by constructor; auto. constructor; done. Qed. - - Lemma holds_eventually3 ψ f g h inftr inftrb inftrc : - inflist_same_length inftr inftrb → - inflist_same_length inftrb inftrc → - ψ f g h inftr inftrb inftrc → - eventually3 ψ f g h inftr inftrb inftrc. - Proof. by constructor. Qed. - - Lemma eventually3_idemp ψ f g h inftr inftrb inftrc : - eventually3 (eventually3 ψ) f g h inftr inftrb inftrc → - eventually3 ψ f g h inftr inftrb inftrc. - Proof. induction 1; first done. constructor; done. Qed. - - Lemma eventually3_inflist_same_length ψ f g h inftr inftrb inftrc : - eventually3 ψ f g h inftr inftrb inftrc → - inflist_same_length inftr inftrb ∧ inflist_same_length inftrb inftrc. - Proof. - induction 1; first done. - rewrite !inflist_same_length_cons; done. - Qed. - - Lemma eventually3_and_inflist_same_length ψ f g h inftr inftrb inftrc : - eventually3 ψ f g h inftr inftrb inftrc ↔ - eventually3 (λ f' g' h' inftr' inftrb' inftrc', - ψ f' g' h' inftr' inftrb' inftrc' ∧ - inflist_same_length inftr' inftrb' ∧ - inflist_same_length inftrb' inftrc') f g h inftr inftrb inftrc. - Proof. - split; last by apply eventually3_mono; tauto. - intros Hev. - induction Hev; first by constructor; auto. - constructor 2; auto. - Qed. - - Lemma eventually3_take_drop ψ f g h inftr inftrb inftrc : - eventually3 ψ f g h inftr inftrb inftrc ↔ - ∃ n, ψ (trace_append_list f (inflist_take n inftr)) - (trace_append_list g (inflist_take n inftrb)) - (trace_append_list h (inflist_take n inftrc)) - (inflist_drop n inftr) - (inflist_drop n inftrb) - (inflist_drop n inftrc) ∧ - inflist_same_length inftr inftrb ∧ - inflist_same_length inftrb inftrc. - Proof. - split. - - intros Hev. - induction Hev as [|????????????? [n Hn]]; first by exists 0. - setoid_rewrite inflist_same_length_cons. - exists (S n); done. - - intros [n Hn]. - revert f g h inftr inftrb inftrc Hn. - induction n as [|n IHn]; intros f g h inftr inftrb inftrc [Hn1 [Hn2 Hn3]]; - first by constructor. - destruct inftr as [|[??]?]; destruct inftrb as [|[??]?]; destruct inftrc as [|[??]?]; - [by constructor|done|done|done|done|done|done|]; simpl in *. - setoid_rewrite inflist_same_length_cons in Hn2. - setoid_rewrite inflist_same_length_cons in Hn3. - constructor 2; apply IHn; done. - Qed. - - Lemma eventually3_exists - {D} (Ψ : D → finite_trace A L1 → finite_trace B L2 → - finite_trace C L3 → inflist (L1 * A) → inflist (L2 * B) → inflist (L3 * C) → Prop) - f g h inftr inftrb inftrc : - (∃ d, eventually3 (Ψ d) f g h inftr inftrb inftrc) ↔ - eventually3 (λ f' g' h' inftr' inftrb' inftrc', ∃ b, Ψ b f' g' h' inftr' inftrb' inftrc') - f g h inftr inftrb inftrc. - Proof. setoid_rewrite eventually3_take_drop; firstorder. Qed. - - (* other properties *) - - Lemma always3_eventually3_idemp ψ f g h inftr inftrb inftrc : - always3 (eventually3 ψ) f g h inftr inftrb inftrc → - always3 (eventually3 (always3 (eventually3 ψ))) f g h inftr inftrb inftrc. - Proof. - intros Hae. - apply always3_idemp in Hae. - eapply always3_mono; last apply Hae. - clear; intros f' g' h' inftr' inftrb' inftrc' Hae. - pose proof (always3_inflist_same_length _ _ _ _ _ _ _ Hae) as [? ?]. - apply holds_eventually3; done. - Qed. - - Lemma eventually3_always3_combine ψ1 ψ2 f g h inftr inftrb inftrc : - eventually3 (always3 ψ1) f g h inftr inftrb inftrc → - eventually3 (always3 ψ2) f g h inftr inftrb inftrc → - eventually3 (λ f' g' h' inftr' inftrb' inftrc', - always3 ψ1 f' g' h' inftr' inftrb' inftrc' ∧ - always3 ψ2 f' g' h' inftr' inftrb' inftrc') f g h inftr inftrb inftrc. - Proof. - rewrite !eventually3_take_drop. - intros [n [Hn1 [Hn2 Hn3]]] [m [Hm1 [Hm2 Hm3]]]. - exists (n `max` m). - split; last done. - split. - - assert (n ≤ n `max` m) as [k ->]%Nat.le_sum by lia. - rewrite !inflist_take_add ![n + k]Nat.add_comm !inflist_drop_add - -!trace_append_list_assoc. - apply always3_unroll_n; done. - - assert (m ≤ n `max` m) as [k ->]%Nat.le_sum by lia. - rewrite !inflist_take_add ![m + k]Nat.add_comm !inflist_drop_add - -!trace_append_list_assoc. - apply always3_unroll_n; done. - Qed. - - Lemma eventually3_and_always3 ψ1 ψ2 f g h inftr inftrb inftrc : - eventually3 ψ1 f g h inftr inftrb inftrc → - always3 ψ2 f g h inftr inftrb inftrc → - eventually3 (λ f' g' h' inftr' inftrb' inftrc', - ψ1 f' g' h' inftr' inftrb' inftrc' ∧ always3 ψ2 f' g' h' inftr' inftrb' inftrc') - f g h inftr inftrb inftrc. - Proof. - intros [n [Hn1 [Hn2 Hn3]]]%eventually3_take_drop Hal. - apply eventually3_take_drop; exists n. - split; last done. - split; first done. - apply always3_unroll_n; done. - Qed. - - Lemma eventually3_forall_combine `{!EqDecision D} `{!Finite D} `{!Inhabited D} - (Ψ : D → finite_trace A L1 → finite_trace B L2 → - finite_trace C L3 → inflist (L1 * A) → inflist (L2 * B) → inflist (L3 * C) → Prop) - f g h inftr inftrb inftrc : - (∀ c, eventually3 (always3 (Ψ c)) f g h inftr inftrb inftrc) → - eventually3 (λ f' g' h' inftr' inftrb' inftrc', - ∀ d, always3 (Ψ d) f' g' h' inftr' inftrb' inftrc') f g h inftr inftrb inftrc. - Proof. - intros Hfa. - cut (eventually3 - (λ f' g' h' inftr' inftrb' inftrc', - ∀ d : D, d ∈ enum D → always3 (Ψ d) f' g' h' inftr' inftrb' inftrc') - f g h inftr inftrb inftrc). - { apply eventually3_mono; clear; intros; auto using elem_of_enum. } - induction (enum D) as [|d l IHl]. - { apply holds_eventually3. - - specialize (Hfa inhabitant) as [? ?]%eventually3_inflist_same_length; done. - - specialize (Hfa inhabitant) as [? ?]%eventually3_inflist_same_length; done. - - intros ?; rewrite elem_of_nil; done. } - assert (eventually3 - (always3 (λ f' g' h' inftr' inftrb' inftrc', - ∀ d : D, d ∈ l → Ψ d f' g' h' inftr' inftrb' inftrc')) - f g h inftr inftrb inftrc) as IHl'. - { setoid_rewrite eventually3_and_inflist_same_length in IHl. - eapply eventually3_mono; last by apply IHl. - simpl; intros f' g' h' inftr' inftrb' inftrc' [Hfa' [Hsl1 Hsl2]]. - rewrite -always3_forall; intros c'. - rewrite -always3_impl; [by apply Hfa'|done|done]. } - clear IHl. - assert (eventually3 - (λ f' g' h' inftr' inftrb' inftrc', - (always3 (λ f'' g'' h'' inftr'' inftrb'' inftrc'', - Ψ d f'' g'' h'' inftr'' inftrb'' inftrc'')) - f' g' h' inftr' inftrb' inftrc' ∧ - (always3 - (λ f'' g'' h'' inftr'' inftrb'' inftrc'', - ∀ d' : D, d' ∈ l → Ψ d' f'' g'' h'' inftr'' inftrb'' inftrc'')) - f' g' h' inftr' inftrb' inftrc') - f g h inftr inftrb inftrc) as IHl. - { apply eventually3_always3_combine; last done. apply Hfa. } - clear IHl'. - eapply eventually3_mono; last apply IHl. - simpl; intros f' g' h' inftr' inftrb' inftrc' [Hal1 Hal2] c' [->|Hc']%elem_of_cons; first done. - apply always3_inflist_same_length in Hal1 as [? ?]. - revert Hc'; rewrite always3_impl; [|done|done]. - revert c'; rewrite always3_forall; done. - Qed. - -End trace_prop.